Packages October 2016

packages@lists.squeakfoundation.org

1 participants
28 discussions

The Trunk: KernelTests-nice.314.mcz
by commits＠source.squeak.org 20 Oct '16

20 Oct '16

Nicolas Cellier uploaded a new version of KernelTests to project The Trunk: http://source.squeak.org/trunk/KernelTests-nice.314.mcz ==================== Summary ==================== Name: KernelTests-nice.314 Author: nice Time: 20 October 2016, 9:58:13.488357 pm UUID: 20ecfbfa-83c2-4e4c-a272-93619cccc78c Ancestors: KernelTests-nice.313, KernelTests-nice.312 Merge nice.312 (tests for 16 and 64 bits integer array) Adopt Eliot's protocol: HalfWord -> DoubleByte isHalfWords -> isShorts isDoubleWords -> isLongs =============== Diff against KernelTests-nice.313 =============== Item was added: + ----- Method: ClassBuilderTest>>makeDoubleByteVariableSubclassOf: (in category 'utilities') ----- + makeDoubleByteVariableSubclassOf: aClass + ^ aClass variableDoubleByteSubclass: self subClassName + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: self categoryNameForTemporaryClasses! Item was added: + ----- Method: ClassBuilderTest>>makeDoubleWordVariableSubclassOf: (in category 'utilities') ----- + makeDoubleWordVariableSubclassOf: aClass + ^ aClass variableDoubleWordSubclass: self subClassName + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: self categoryNameForTemporaryClasses! Item was changed: ----- Method: ClassBuilderTest>>testByteVariableSubclass (in category 'testing - format') ----- testByteVariableSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object variableByteSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses. [ subClass := self makeNormalSubclassOf: baseClass. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self assert: (subClass isBytes). + self deny: (subClass isWords). + self deny: (subClass isShorts). + self deny: (subClass isLongs). subClass removeFromSystem. "pointer classes" self should:[self makeIVarsSubclassOf: baseClass] raise: Error. self should:[self makeVariableSubclassOf: baseClass] raise: Error. self should:[self makeWeakSubclassOf: baseClass] raise: Error. "bit classes" subClass := self makeByteVariableSubclassOf: baseClass. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self assert: (subClass isBytes). + self deny: (subClass isWords). + self deny: (subClass isShorts). + self deny: (subClass isLongs). subClass removeFromSystem. self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. + self should:[self makeDoubleByteVariableSubclassOf: baseClass] raise: Error. + self should:[self makeDoubleWordVariableSubclassOf: baseClass] raise: Error. ] ensure:[self cleanup].! Item was added: + ----- Method: ClassBuilderTest>>testDoubleByteVariableSubclass (in category 'testing - format') ----- + testDoubleByteVariableSubclass + "Ensure that the invariants for superclass/subclass format are preserved" + baseClass := Object variableDoubleByteSubclass: self baseClassName + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: self categoryNameForTemporaryClasses. + [ + subClass := self makeNormalSubclassOf: baseClass. + self deny: (subClass isPointers). + self assert: (subClass isVariable). + self assert: (subClass isShorts). + self deny: (subClass isWeak). + self deny: (subClass isBytes). + self deny: (subClass isWords). + self deny: (subClass isLongs). + subClass removeFromSystem. + + "pointer classes" + self should:[self makeIVarsSubclassOf: baseClass] raise: Error. + self should:[self makeVariableSubclassOf: baseClass] raise: Error. + self should:[self makeWeakSubclassOf: baseClass] raise: Error. + + "bit classes" + self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. + self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. + self should:[self makeDoubleWordVariableSubclassOf: baseClass] raise: Error. + subClass := self makeDoubleByteVariableSubclassOf: baseClass. + self deny: (subClass isPointers). + self assert: (subClass isVariable). + self assert: (subClass isShorts). + self deny: (subClass isWeak). + self deny: (subClass isBytes). + self deny: (subClass isWords). + self deny: (subClass isLongs). + subClass removeFromSystem. + ] ensure:[self cleanup].! Item was added: + ----- Method: ClassBuilderTest>>testDoubleWordVariableSubclass (in category 'testing - format') ----- + testDoubleWordVariableSubclass + "Ensure that the invariants for superclass/subclass format are preserved" + baseClass := Object variableDoubleWordSubclass: self baseClassName + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: self categoryNameForTemporaryClasses. + [ + subClass := self makeNormalSubclassOf: baseClass. + self deny: (subClass isPointers). + self assert: (subClass isVariable). + self assert: (subClass isLongs). + self deny: (subClass isWeak). + self deny: (subClass isBytes). + self deny: (subClass isShorts). + self deny: (subClass isWords). + subClass removeFromSystem. + + "pointer classes" + self should:[self makeIVarsSubclassOf: baseClass] raise: Error. + self should:[self makeVariableSubclassOf: baseClass] raise: Error. + self should:[self makeWeakSubclassOf: baseClass] raise: Error. + + "bit classes" + self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. + self should:[self makeDoubleByteVariableSubclassOf: baseClass] raise: Error. + self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. + subClass := self makeDoubleWordVariableSubclassOf: baseClass. + self deny: (subClass isPointers). + self assert: (subClass isVariable). + self assert: (subClass isLongs). + self deny: (subClass isWeak). + self deny: (subClass isBytes). + self deny: (subClass isShorts). + self deny: (subClass isWords). + subClass removeFromSystem. + ] ensure:[self cleanup].! Item was changed: ----- Method: ClassBuilderTest>>testWordVariableSubclass (in category 'testing - format') ----- testWordVariableSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object variableWordSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses. [ subClass := self makeNormalSubclassOf: baseClass. self deny: (subClass isPointers). self assert: (subClass isVariable). + self assert: (subClass isWords). self deny: (subClass isWeak). self deny: (subClass isBytes). + self deny: (subClass isShorts). + self deny: (subClass isLongs). subClass removeFromSystem. "pointer classes" self should:[self makeIVarsSubclassOf: baseClass] raise: Error. self should:[self makeVariableSubclassOf: baseClass] raise: Error. self should:[self makeWeakSubclassOf: baseClass] raise: Error. "bit classes" self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. + self should:[self makeDoubleByteVariableSubclassOf: baseClass] raise: Error. + self should:[self makeDoubleWordVariableSubclassOf: baseClass] raise: Error. subClass := self makeWordVariableSubclassOf: baseClass. self deny: (subClass isPointers). self assert: (subClass isVariable). + self assert: (subClass isWords). self deny: (subClass isWeak). self deny: (subClass isBytes). + self deny: (subClass isShorts). + self deny: (subClass isLongs). subClass removeFromSystem. ] ensure:[self cleanup].!

1 0

The Trunk: KernelTests-nice.312.mcz
by commits＠source.squeak.org 20 Oct '16

20 Oct '16

Nicolas Cellier uploaded a new version of KernelTests to project The Trunk: http://source.squeak.org/trunk/KernelTests-nice.312.mcz ==================== Summary ==================== Name: KernelTests-nice.312 Author: nice Time: 20 September 2016, 11:02:44.892325 pm UUID: 20bb751e-7ac1-4e91-8437-9f2cdcb8df5c Ancestors: KernelTests-mt.311 ClassBuilder tests for half and double word variable subclasses =============== Diff against KernelTests-mt.311 =============== Item was added: + ----- Method: ClassBuilderTest>>makeDoubleWordVariableSubclassOf: (in category 'utilities') ----- + makeDoubleWordVariableSubclassOf: aClass + ^ aClass variableDoubleWordSubclass: self subClassName + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: self categoryNameForTemporaryClasses! Item was added: + ----- Method: ClassBuilderTest>>makeHalfWordVariableSubclassOf: (in category 'utilities') ----- + makeHalfWordVariableSubclassOf: aClass + ^ aClass variableHalfWordSubclass: self subClassName + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: self categoryNameForTemporaryClasses! Item was changed: ----- Method: ClassBuilderTest>>testByteVariableSubclass (in category 'testing - format') ----- testByteVariableSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object variableByteSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses. [ subClass := self makeNormalSubclassOf: baseClass. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self assert: (subClass isBytes). + self deny: (subClass isWords). + self deny: (subClass isHalfWords). + self deny: (subClass isDoubleWords). subClass removeFromSystem. "pointer classes" self should:[self makeIVarsSubclassOf: baseClass] raise: Error. self should:[self makeVariableSubclassOf: baseClass] raise: Error. self should:[self makeWeakSubclassOf: baseClass] raise: Error. "bit classes" subClass := self makeByteVariableSubclassOf: baseClass. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self assert: (subClass isBytes). + self deny: (subClass isWords). + self deny: (subClass isHalfWords). + self deny: (subClass isDoubleWords). subClass removeFromSystem. self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. + self should:[self makeHalfWordVariableSubclassOf: baseClass] raise: Error. + self should:[self makeDoubleWordVariableSubclassOf: baseClass] raise: Error. ] ensure:[self cleanup].! Item was added: + ----- Method: ClassBuilderTest>>testDoubleWordVariableSubclass (in category 'testing - format') ----- + testDoubleWordVariableSubclass + "Ensure that the invariants for superclass/subclass format are preserved" + baseClass := Object variableDoubleWordSubclass: self baseClassName + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: self categoryNameForTemporaryClasses. + [ + subClass := self makeNormalSubclassOf: baseClass. + self deny: (subClass isPointers). + self assert: (subClass isVariable). + self assert: (subClass isDoubleWords). + self deny: (subClass isWeak). + self deny: (subClass isBytes). + self deny: (subClass isHalfWords). + self deny: (subClass isWords). + subClass removeFromSystem. + + "pointer classes" + self should:[self makeIVarsSubclassOf: baseClass] raise: Error. + self should:[self makeVariableSubclassOf: baseClass] raise: Error. + self should:[self makeWeakSubclassOf: baseClass] raise: Error. + + "bit classes" + self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. + self should:[self makeHalfWordVariableSubclassOf: baseClass] raise: Error. + self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. + subClass := self makeDoubleWordVariableSubclassOf: baseClass. + self deny: (subClass isPointers). + self assert: (subClass isVariable). + self assert: (subClass isDoubleWords). + self deny: (subClass isWeak). + self deny: (subClass isBytes). + self deny: (subClass isHalfWords). + self deny: (subClass isWords). + subClass removeFromSystem. + ] ensure:[self cleanup].! Item was added: + ----- Method: ClassBuilderTest>>testHalfWordVariableSubclass (in category 'testing - format') ----- + testHalfWordVariableSubclass + "Ensure that the invariants for superclass/subclass format are preserved" + baseClass := Object variableHalfWordSubclass: self baseClassName + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: self categoryNameForTemporaryClasses. + [ + subClass := self makeNormalSubclassOf: baseClass. + self deny: (subClass isPointers). + self assert: (subClass isVariable). + self assert: (subClass isHalfWords). + self deny: (subClass isWeak). + self deny: (subClass isBytes). + self deny: (subClass isWords). + self deny: (subClass isDoubleWords). + subClass removeFromSystem. + + "pointer classes" + self should:[self makeIVarsSubclassOf: baseClass] raise: Error. + self should:[self makeVariableSubclassOf: baseClass] raise: Error. + self should:[self makeWeakSubclassOf: baseClass] raise: Error. + + "bit classes" + self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. + self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. + self should:[self makeDoubleWordVariableSubclassOf: baseClass] raise: Error. + subClass := self makeHalfWordVariableSubclassOf: baseClass. + self deny: (subClass isPointers). + self assert: (subClass isVariable). + self assert: (subClass isHalfWords). + self deny: (subClass isWeak). + self deny: (subClass isBytes). + self deny: (subClass isWords). + self deny: (subClass isDoubleWords). + subClass removeFromSystem. + ] ensure:[self cleanup].! Item was changed: ----- Method: ClassBuilderTest>>testWordVariableSubclass (in category 'testing - format') ----- testWordVariableSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object variableWordSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses. [ subClass := self makeNormalSubclassOf: baseClass. self deny: (subClass isPointers). self assert: (subClass isVariable). + self assert: (subClass isWords). self deny: (subClass isWeak). self deny: (subClass isBytes). + self deny: (subClass isHalfWords). + self deny: (subClass isDoubleWords). subClass removeFromSystem. "pointer classes" self should:[self makeIVarsSubclassOf: baseClass] raise: Error. self should:[self makeVariableSubclassOf: baseClass] raise: Error. self should:[self makeWeakSubclassOf: baseClass] raise: Error. "bit classes" self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. + self should:[self makeHalfWordVariableSubclassOf: baseClass] raise: Error. + self should:[self makeDoubleWordVariableSubclassOf: baseClass] raise: Error. subClass := self makeWordVariableSubclassOf: baseClass. self deny: (subClass isPointers). self assert: (subClass isVariable). + self assert: (subClass isWords). self deny: (subClass isWeak). self deny: (subClass isBytes). + self deny: (subClass isHalfWords). + self deny: (subClass isDoubleWords). subClass removeFromSystem. ] ensure:[self cleanup].!

1 0

The Trunk: Monticello-nice.650.mcz
by commits＠source.squeak.org 20 Oct '16

20 Oct '16

Nicolas Cellier uploaded a new version of Monticello to project The Trunk: http://source.squeak.org/trunk/Monticello-nice.650.mcz ==================== Summary ==================== Name: Monticello-nice.650 Author: nice Time: 20 October 2016, 9:40:29.118416 pm UUID: a672602e-278e-4480-b569-362600f892da Ancestors: Monticello-nice.649, Monticello-eem.649 Merge eem.649 and nice.649 for 16bits and 64bits integer array. Adopt Eliot's "DoubleByte" rather than "HalfWord" =============== Diff against Monticello-nice.649 =============== Item was changed: ----- Method: MCClassDefinition>>kindOfSubclass (in category 'printing') ----- kindOfSubclass type = #normal ifTrue: [^' subclass: ']. type = #variable ifTrue: [^' variableSubclass: ']. type = #bytes ifTrue: [^' variableByteSubclass: ']. type = #compiledMethod ifTrue: [^' variableByteSubclass: ' ]. + type = #shorts ifTrue: [^' variableDoubleByteSubclass: ']. - type = #shorts ifTrue: [^' variableHalfWordSubclass: ']. type = #words ifTrue: [^' variableWordSubclass: ']. type = #longs ifTrue: [^' variableDoubleWordSubclass: ']. type = #weak ifTrue: [^' weakSubclass: ' ]. type = #ephemeron ifTrue: [^' ephemeronSubclass: ' ]. type = #immediate ifTrue: [^' immediateSubclass: ' ]. self error: 'Unrecognized class type' ! Item was changed: ----- Method: MCStReader>>typeOfSubclass: (in category 'as yet unclassified') ----- typeOfSubclass: aSymbol #( (subclass: normal) (variableSubclass: variable) (variableByteSubclass: bytes) + (variableDoubleByteSubclass: shorts) - (variableHalfWordSubclass: shorts) (variableWordSubclass: words) (variableDoubleWordSubclass: longs) (weakSubclass: weak) (ephemeronSubclass: ephemeron) (immediateSubclass: immediate) ) do: [:ea | ea first = aSymbol ifTrue: [^ ea second]]. self error: 'Unrecognized class definition'!

1 0

The Trunk: Monticello-nice.649.mcz
by commits＠source.squeak.org 20 Oct '16

20 Oct '16

Nicolas Cellier uploaded a new version of Monticello to project The Trunk: http://source.squeak.org/trunk/Monticello-nice.649.mcz ==================== Summary ==================== Name: Monticello-nice.649 Author: nice Time: 20 September 2016, 11:05:23.764791 pm UUID: 21077de5-41b3-4bd4-99ee-93cb5aca0301 Ancestors: Monticello-mt.648 Support for half and double word variable subclasses =============== Diff against Monticello-mt.648 =============== Item was changed: ----- Method: MCClassDefinition>>kindOfSubclass (in category 'printing') ----- kindOfSubclass type = #normal ifTrue: [^' subclass: ']. type = #variable ifTrue: [^' variableSubclass: ']. type = #bytes ifTrue: [^' variableByteSubclass: ']. type = #compiledMethod ifTrue: [^' variableByteSubclass: ' ]. + type = #shorts ifTrue: [^' variableHalfWordSubclass: ']. type = #words ifTrue: [^' variableWordSubclass: ']. + type = #longs ifTrue: [^' variableDoubleWordSubclass: ']. type = #weak ifTrue: [^' weakSubclass: ' ]. type = #ephemeron ifTrue: [^' ephemeronSubclass: ' ]. type = #immediate ifTrue: [^' immediateSubclass: ' ]. self error: 'Unrecognized class type' ! Item was changed: ----- Method: MCStReader>>typeOfSubclass: (in category 'as yet unclassified') ----- typeOfSubclass: aSymbol #( (subclass: normal) (variableSubclass: variable) (variableByteSubclass: bytes) + (variableHalfWordSubclass: shorts) (variableWordSubclass: words) + (variableDoubleWordSubclass: longs) (weakSubclass: weak) (ephemeronSubclass: ephemeron) (immediateSubclass: immediate) ) do: [:ea | ea first = aSymbol ifTrue: [^ ea second]]. self error: 'Unrecognized class definition'!

1 0

The Trunk: MonticelloConfigurations-bf.147.mcz
by commits＠source.squeak.org 19 Oct '16

19 Oct '16

Bert Freudenberg uploaded a new version of MonticelloConfigurations to project The Trunk: http://source.squeak.org/trunk/MonticelloConfigurations-bf.147.mcz ==================== Summary ==================== Name: MonticelloConfigurations-bf.147 Author: bf Time: 19 October 2016, 9:30:22.470476 pm UUID: b1d019c1-7569-4ea8-8f6a-aac4b395beca Ancestors: MonticelloConfigurations-pre.146 During update, log error instead of stopping. =============== Diff against MonticelloConfigurations-pre.146 =============== Item was changed: ----- Method: MCConfiguration>>depsSatisfying:versionDo:displayingProgress: (in category 'private') ----- depsSatisfying: selectBlock versionDo: verBlock displayingProgress: progressString | count selectedVersions cleanWorkingCopies | self cacheAllFileNamesDuring: [ self repositories do: [ :eachRepository | MCRepositoryGroup default addRepository: eachRepository ]. "First, download selected versions" count := 0. selectedVersions := OrderedCollection new. self withProgress: progressString in: self dependencies do: [ :dep | | verName repo | verName := dep versionInfo name. self class extraProgressInfo ifTrue: [ ProgressNotification signal: '' extra: 'Downloading ' , verName ]. repo := self repositories detect: [ :eachRepository | eachRepository includesVersionNamed: verName ] ifNone: [ self logError: 'Version ' , verName , ' not found in any repository'. self logError: 'Aborting'. ^ count ]. (selectBlock value: dep) ifTrue: [ | version | version := self versionNamed: verName for: dep from: repo. version ifNil: [ self logError: 'Could not download version ' , verName , ' from ' , repo description. self logError: 'Aborting'. ^ count ]. dep package workingCopy newRepositoryGroupIfDefault. "fix old working copies" dep package workingCopy repositoryGroup addRepository: repo. selectedVersions add: version]]. "Then, process only those definitions that moved from one package to another, to avoid order dependence" cleanWorkingCopies := MCWorkingCopy allManagers reject: [ :wc | wc modified ]. MCReorganizationPreloader preloadMovesBetween: selectedVersions. "Finally, load/merge selected versions" self withProgress: progressString in: selectedVersions do: [ :version | self logUpdate: version package with: version. self class extraProgressInfo ifTrue: [ ProgressNotification signal: '' extra: 'Installing ' , version info name ]. verBlock value: version. count := count + 1 ]. "Clean up packages made dirty by MCReorganizationPreloader" + cleanWorkingCopies do: [ :wc | wc modified ifTrue: [[wc checkModified] on: Error do: [:ex | self logWarning: ex description] ]]. - cleanWorkingCopies do: [ :wc | wc modified ifTrue: [wc checkModified] ]. ]. ^ count!

1 0

The Trunk: Kernel-tfel.1046.mcz
by commits＠source.squeak.org 19 Oct '16

19 Oct '16

Tim Felgentreff uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-tfel.1046.mcz ==================== Summary ==================== Name: Kernel-tfel.1046 Author: tfel Time: 19 October 2016, 5:34:18.991659 pm UUID: 12ebf345-b919-2845-8147-56a8b2f4cae4 Ancestors: Kernel-eem.1045 Improve performance of large integer fallback code for multiplication and division with small integers, by avoiding recalculating SmallInteger>>digitLength a lot of times. (This yields a 3x speedup in some integer heavy shootout benchmarks like pidigits for RSqueak, where we don't have a LargeIntegers plugin) =============== Diff against Kernel-eem.1045 =============== Item was changed: ----- Method: Integer>>digitDiv:neg: (in category 'private') ----- 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 divDigitLength remDigitLength | - | quo rem ql d div dh dnh dl qhi qlo j l hi lo r3 a t | <primitive: 'primDigitDivNegative' module:'LargeIntegers'> arg = 0 ifTrue: [^ (ZeroDivide dividend: self) signal]. "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 highBitOfByte. div := arg digitLshift: d. + divDigitLength := div digitLength + 1. + div := div growto: divDigitLength. - 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]. + remDigitLength := rem digitLength. "makes a copy and shifts" quo := Integer new: l neg: ng. + dl := divDigitLength - 1. - 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 := remDigitLength + 1 - k. - 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: divDigitLength do: - 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: divDigitLength do: - 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: ql + 1 - k put: (qhi bitShift: 4) - quo digitAt: quo digitLength + 1 - k put: (qhi bitShift: 4) + qlo]. rem := rem digitRshift: d bytes: 0 lookfirst: dl. ^ Array with: quo with: rem! Item was changed: ----- Method: Integer>>digitMultiply:neg: (in category 'private') ----- digitMultiply: arg neg: ng + | selfLen argLen prod prodLen carry digit k ab | - | prod prodLen carry digit k ab | <primitive: 'primDigitMultiplyNegative' module:'LargeIntegers'> + argLen := arg digitLength. + (argLen = 1 and: [(arg digitAt: 1) - (arg digitLength = 1 and: [(arg digitAt: 1) = 0]) ifTrue: [^ 0]. + selfLen := self digitLength. + (selfLen = 1 and: [(self digitAt: 1) - (self digitLength = 1 and: [(self digitAt: 1) = 0]) ifTrue: [^ 0]. + prodLen := selfLen + argLen. - prodLen := self digitLength + arg digitLength. prod := Integer new: prodLen neg: ng. "prod starts out all zero" + 1 to: selfLen do: [:i | (digit := self digitAt: i) ~= 0 - 1 to: self digitLength do: [:i | (digit := self digitAt: i) ~= 0 ifTrue: [k := i. carry := 0. "Loop invariant: 0<=carry<=0377, k=i+j-1" + 1 to: argLen do: - 1 to: arg digitLength do: [:j | ab := (arg digitAt: j) * digit + carry + (prod digitAt: k). carry := ab bitShift: -8. prod digitAt: k put: (ab bitAnd: 255). k := k + 1]. prod digitAt: k put: carry]]. ^ prod normalize!

1 0

The Trunk: Monticello-eem.649.mcz
by commits＠source.squeak.org 17 Oct '16

17 Oct '16

Eliot Miranda uploaded a new version of Monticello to project The Trunk: http://source.squeak.org/trunk/Monticello-eem.649.mcz ==================== Summary ==================== Name: Monticello-eem.649 Author: eem Time: 17 October 2016, 12:48:18.49536 pm UUID: 0309f626-9ab4-43ee-a31e-031794753283 Ancestors: Monticello-mt.648 Fix Monticello for 16-bit and 64-bit integer arrays. =============== Diff against Monticello-mt.648 =============== Item was changed: ----- Method: MCClassDefinition>>kindOfSubclass (in category 'printing') ----- kindOfSubclass type = #normal ifTrue: [^' subclass: ']. type = #variable ifTrue: [^' variableSubclass: ']. type = #bytes ifTrue: [^' variableByteSubclass: ']. type = #compiledMethod ifTrue: [^' variableByteSubclass: ' ]. + type = #shorts ifTrue: [^' variableDoubleByteSubclass: ']. type = #words ifTrue: [^' variableWordSubclass: ']. + type = #longs ifTrue: [^' variableDoubleWordSubclass: ']. type = #weak ifTrue: [^' weakSubclass: ' ]. type = #ephemeron ifTrue: [^' ephemeronSubclass: ' ]. type = #immediate ifTrue: [^' immediateSubclass: ' ]. self error: 'Unrecognized class type' !

1 0

The Trunk: Tools-eem.730.mcz
by commits＠source.squeak.org 17 Oct '16

17 Oct '16

Eliot Miranda uploaded a new version of Tools to project The Trunk: http://source.squeak.org/trunk/Tools-eem.730.mcz ==================== Summary ==================== Name: Tools-eem.730 Author: eem Time: 17 October 2016, 12:29:51.991505 pm UUID: 34a02f77-e6db-4ae1-af45-dbf885667ebc Ancestors: Tools-tfel.729 Browser robustness when e.g. revert package removes a class definitioon and so self selectedClass evaluates to nil. =============== Diff against Tools-tfel.729 =============== Item was changed: ----- Method: Browser>>didCodeChangeElsewhere (in category 'self-updating') ----- didCodeChangeElsewhere + super didCodeChangeElsewhere ifTrue: + [^true]. + self classDefinitionIndicated ifFalse: + [^false]. + ^self metaClassIndicated + ifFalse: + [classDefinition ~= (self selectedClass ifNotNil: [:selectedClass| selectedClass definition])] + ifTrue: + [metaClassDefinition ~= (self selectedClass ifNotNil: [:selectedClass| selectedClass theMetaClass definition])]! - ^ super didCodeChangeElsewhere or: [self classDefinitionIndicated - and: [self metaClassIndicated - ifFalse: [classDefinition ~= self selectedClass definition] - ifTrue: [metaClassDefinition ~= self selectedClass theMetaClass definition]]]!

1 0

The Trunk: Morphic-tpr.1312.mcz
by commits＠source.squeak.org 17 Oct '16

17 Oct '16

tim Rowledge uploaded a new version of Morphic to project The Trunk: http://source.squeak.org/trunk/Morphic-tpr.1312.mcz ==================== Summary ==================== Name: Morphic-tpr.1312 Author: tpr Time: 17 October 2016, 10:15:36.854001 am UUID: e31d55cf-b908-4ac5-829a-8d9f01ff14ec Ancestors: Morphic-mt.1295, Morphic-tfel.1311 Setting the border's baseColor in SimpleBorder>>initialize prevents #trackColorFrom: ever working to set the border color to suit the owner morph. So don't default baseColor. =============== Diff against Morphic-mt.1295 =============== Item was changed: ----- Method: CircleMorph class>>supplementaryPartsDescriptions (in category 'as yet unclassified') ----- supplementaryPartsDescriptions "Extra items for parts bins" ^ {DescriptionForPartsBin + formalName: 'Circle' translatedNoop + categoryList: {'Graphics' translatedNoop} + documentation: 'A circular shape' translatedNoop - formalName: 'Circle1' - categoryList: #('Graphics') - documentation: 'A circular shape' globalReceiverSymbol: #CircleMorph nativitySelector: #newStandAlone. + DescriptionForPartsBin + formalName: 'Pin' translatedNoop + categoryList: {'Connectors' translatedNoop} + documentation: 'An attachment point for Connectors that you can embed in another Morph.' translatedNoop - "DescriptionForPartsBin - formalName: 'Pin' - categoryList: #('Connectors') - documentation: 'An attachment point for Connectors that you can embed in another Morph.' globalReceiverSymbol: #NCPinMorph + nativitySelector: #newPin. - nativitySelector: #newPin." }! Item was changed: SketchMorph subclass: #ColorPickerMorph + instanceVariableNames: 'selectedColor sourceHand deleteOnMouseUp updateContinuously target selector argument originalColor theSelectorDisplayMorph command isModal clickedTranslucency noChart' - instanceVariableNames: 'selectedColor sourceHand deleteOnMouseUp updateContinuously target selector argument originalColor theSelectorDisplayMorph command isModal clickedTranslucency' classVariableNames: 'ColorChart DragBox FeedbackBox RevertBox TransText TransparentBox' poolDictionaries: '' category: 'Morphic-Widgets'! !ColorPickerMorph commentStamp: 'kfr 10/27/2003 16:16' prior: 0! A gui for setting color and transparency. Behaviour can be changed with the Preference modalColorPickers.! Item was changed: ----- Method: ColorPickerMorph>>pickUpColorFor: (in category 'menu') ----- pickUpColorFor: aMorph "Show the eyedropper cursor, and modally track the mouse through a mouse-down and mouse-up cycle" | aHand localPt c | aHand := aMorph ifNil: [self activeHand] ifNotNil: [aMorph activeHand]. aHand ifNil: [aHand := self currentHand]. self addToWorld: aHand world near: (aMorph ifNil: [aHand world]) fullBounds. self owner ifNil: [^ self]. aHand showTemporaryCursor: (ScriptingSystem formAtKey: #Eyedropper) + hotSpotOffset: 6 @ 31. "<<<< the form was changed a bit??" - hotSpotOffset: 6 negated @ 4 negated. "<<<< the form was changed a bit??" self updateContinuously: false. [Sensor anyButtonPressed] whileFalse: [self trackColorUnderMouse]. self deleteAllBalloons. localPt := Sensor cursorPoint - self topLeft. self inhibitDragging ifFalse: [ (DragBox containsPoint: localPt) ifTrue: ["Click or drag the drag-dot means to anchor as a modeless picker" ^ self anchorAndRunModeless: aHand]. ]. (clickedTranslucency := TransparentBox containsPoint: localPt) ifTrue: [selectedColor := originalColor]. self updateContinuously: true. [Sensor anyButtonPressed] whileTrue: [self updateTargetColorWith: self indicateColorUnderMouse]. c := self getColorFromKedamaWorldIfPossible: Sensor cursorPoint. c ifNotNil: [selectedColor := c]. aHand newMouseFocus: nil; showTemporaryCursor: nil; flushEvents. self delete. ! Item was changed: ----- Method: EllipseMorph class>>descriptionForPartsBin (in category 'parts bin') ----- descriptionForPartsBin + ^ self partName: 'Ellipse' translatedNoop + categories: {'Graphics' translatedNoop. 'Basic' translatedNoop} + documentation: 'An elliptical or circular shape' translatedNoop! - ^ self partName: 'Ellipse' - categories: #('Graphics' 'Basic') - documentation: 'An elliptical or circular shape'! Item was changed: ----- Method: FillInTheBlankMorph>>createTextPaneAcceptOnCR: (in category 'initialization') ----- createTextPaneAcceptOnCR: acceptBoolean textPane := PluggableTextMorph on: self text: #response accept: #response: readSelection: #selectionInterval menu: #codePaneMenu:shifted:. textPane showScrollBarsOnlyWhenNeeded; wantsFrameAdornments: false; hasUnacceptedEdits: true; acceptOnCR: acceptBoolean; setNameTo: 'textPane'; layoutFrame: (LayoutFrame fractions: (0@0 corner: 1@1)); hResizing: #spaceFill; + vResizing: #spaceFill; + scrollToTop. - vResizing: #spaceFill. - ^ textPane! Item was changed: ----- Method: FillInTheBlankMorph>>setQuery:initialAnswer:answerExtent:acceptOnCR: (in category 'initialization') ----- setQuery: queryString initialAnswer: initialAnswer answerExtent: answerExtent acceptOnCR: acceptBoolean | text | result := initialAnswer. done := false. self paneMorph removeAllMorphs. + self title: 'Input Requested' translated. - self title: 'Input Requested'. self message: queryString. text := self createTextPaneAcceptOnCR: acceptBoolean. self paneMorph addMorphBack: text. self paneMorph wantsPaneSplitters: true; addCornerGrips. self paneMorph grips do: [:ea | ea drawCornerResizeHandles: true]. self paneMorph extent: ((initialAnswer asText asMorph extent + (20@10) max: answerExtent) min: 500@500). self setDefaultParameters.! Item was changed: ----- Method: HaloMorph>>addDupHandle: (in category 'handles') ----- addDupHandle: haloSpec "Add the halo that offers duplication, or, when shift is down, make-sibling" + | aSelector | + aSelector := innerTarget couldMakeSibling + ifTrue: + [#doDupOrMakeSibling:with:] + ifFalse: + [#doDup:with:]. - self addHandle: haloSpec on: #mouseDown send: #doDupOrMakeSibling:with: to: self + self addHandle: haloSpec on: #mouseDown send: aSelector to: self + ! Item was changed: ----- Method: HaloMorph>>addHandle:on:send:to: (in category 'private') ----- addHandle: handleSpec on: eventName send: selector to: recipient "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 | aPoint := self positionIn: haloBox horizontalPlacement: handleSpec horizontalPlacement verticalPlacement: handleSpec verticalPlacement. handle := self addHandleAt: aPoint color: (Color colorFrom: handleSpec color) icon: handleSpec iconSymbol on: eventName send: selector to: recipient. - self isMagicHalo - ifTrue: [ - handle on: #mouseEnter send: #handleEntered to: self. - handle on: #mouseLeave send: #handleLeft to: self]. - ^ handle! Item was changed: ----- Method: HaloMorph>>addHandlesForWorldHalos (in category 'private') ----- addHandlesForWorldHalos "Add handles for world halos, like the man said" | box w | w := self world ifNil:[target world]. self removeAllMorphs. "remove old handles, if any" self bounds: target bounds. + box := w bounds insetBy: self handleSize // 2. - box := w bounds insetBy: 9. target addWorldHandlesTo: self box: box. Preferences uniqueNamesInHalos ifTrue: [innerTarget assureExternalName]. self addNameBeneath: (box insetBy: (0@0 corner: 0@10)) string: innerTarget externalName. growingOrRotating := false. self layoutChanged. self changed. ! Item was changed: ----- Method: HaloMorph>>addViewingHandle: (in category 'handles') ----- addViewingHandle: haloSpec + "If appropriate, add a special Viewing halo handle to the receiver. On 26 Sept 07, we decided to eliminate this item from the UI, so the code of is method is now commented out... - "If appropriate, add a special Viewing halo handle to the receiver" (innerTarget isKindOf: PasteUpMorph) ifTrue: [self addHandle: haloSpec on: #mouseDown send: #presentViewMenu to: innerTarget]. + " ! Item was changed: ----- Method: HaloMorph>>basicBox (in category 'private') ----- basicBox | aBox minSide anExtent w | minSide := 4 * self handleSize. anExtent := ((self width + self handleSize + 8) max: minSide) @ ((self height + self handleSize + 8) max: minSide). aBox := Rectangle center: self center extent: anExtent. w := self world ifNil:[target outermostWorldMorph]. ^ w ifNil: [aBox] ifNotNil: + [aBox intersect: (w viewBox insetBy: self handleSize // 2)] - [aBox intersect: (w viewBox insetBy: 8@8)] ! Item was changed: ----- Method: HaloMorph>>doDirection:with: (in category 'private') ----- doDirection: anEvent with: directionHandle + "The mouse went down on the forward-direction halo handle; respond appropriately." + anEvent hand obtainHalo: self. + anEvent shiftPressed + ifTrue: + [directionArrowAnchor := (target point: target referencePosition in: self world) rounded. + self positionDirectionShaft: directionHandle. + self removeAllHandlesBut: directionHandle. + directionHandle setProperty: #trackDirectionArrow toValue: true] + ifFalse: + [ActiveHand spawnBalloonFor: directionHandle]! - self removeAllHandlesBut: directionHandle! Item was changed: ----- Method: HaloMorph>>doResizeTarget: (in category 'dragging or resizing') ----- + doResizeTarget: evt + | newExtent | - doResizeTarget: evt - - | oldExtent newExtent newPosition | newExtent := originalExtent + (evt position - positionOffset * 2). + (newExtent x > 1 and: [ newExtent y > 1 ]) ifTrue: + [ | oldExtent dockingBarBottom newPosition | + oldExtent := target extent. + dockingBarBottom := owner mainDockingBars + inject: 0 + into: [ : bottomMostBottom : each | bottomMostBottom max: each bottom ]. + target setExtentFromHalo: (newExtent min: owner extent x @ (owner extent y - dockingBarBottom)). + newPosition := target position - (target extent - oldExtent // 2). + newPosition := (newPosition x + min: owner extent x - newExtent x + max: 0) @ + (newPosition y + min: owner extent y - newExtent y + max: dockingBarBottom). + target + setConstrainedPosition: newPosition + hangOut: true ]. + self bounds: self target worldBoundsForHalo! - - (newExtent x > 1 and: [newExtent y > 1]) - ifTrue: [ - oldExtent := target extent. - target setExtentFromHalo: (newExtent min: owner extent). - newPosition := target position - (target extent - oldExtent // 2). - newPosition := (newPosition x min: owner extent x - newExtent x max: 0) @ (newPosition y min: owner extent y - newExtent y max: 0). - target setConstrainedPosition: newPosition hangOut: true]. - - self bounds: self target worldBoundsForHalo.! Item was changed: ----- Method: HaloMorph>>handleSize (in category 'private') ----- handleSize ^ Preferences biggerHandles + ifTrue: [30] - ifTrue: [20] ifFalse: [16]! Item was changed: ----- Method: HaloMorph>>isMagicHalo: (in category 'accessing') ----- isMagicHalo: aBool self setProperty: #isMagicHalo toValue: aBool. + aBool + ifTrue: [ + self on: #mouseEnter send: #handleEntered to: self. + self on: #mouseLeave send: #handleLeft to: self] + ifFalse:[ + "Reset everything" + self eventHandler ifNotNil: [:eh | + eh forgetDispatchesTo: #handleEntered; + forgetDispatchesTo: #handleLeft]. + self stopStepping. "get rid of all" + self startStepping. "only those of interest"].! - aBool ifFalse:[ - "Reset everything" - self stopStepping. "get rid of all" - self startStepping. "only those of interest" - ].! Item was changed: ----- Method: HaloMorph>>prepareToTrackCenterOfRotation:with: (in category 'private') ----- prepareToTrackCenterOfRotation: evt with: rotationHandle + "The mouse went down on the center of rotation." + evt hand obtainHalo: self. + evt shiftPressed + ifTrue: + [self removeAllHandlesBut: rotationHandle. + rotationHandle setProperty: #trackCenterOfRotation toValue: true. + evt hand showTemporaryCursor: Cursor blank] + ifFalse: + [ActiveHand spawnBalloonFor: rotationHandle]! - evt shiftPressed ifTrue:[ - self removeAllHandlesBut: rotationHandle. - ] ifFalse:[ - rotationHandle setProperty: #dragByCenterOfRotation toValue: true. - self startDrag: evt with: rotationHandle - ]. - evt hand showTemporaryCursor: Cursor blank! Item was changed: ----- Method: HaloMorph>>setCenterOfRotation:with: (in category 'private') ----- setCenterOfRotation: evt with: rotationHandle | localPt | evt hand obtainHalo: self. evt hand showTemporaryCursor: nil. + (rotationHandle hasProperty: #trackCenterOfRotation) ifTrue: + [localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center. + innerTarget setRotationCenterFrom: localPt]. + + rotationHandle removeProperty: #trackCenterOfRotation. + self endInteraction! - (rotationHandle hasProperty: #dragByCenterOfRotation) ifFalse:[ - localPt := innerTarget transformFromWorld globalPointToLocal: rotationHandle center. - innerTarget setRotationCenterFrom: localPt. - ]. - rotationHandle removeProperty: #dragByCenterOfRotation. - self endInteraction - ! Item was changed: ----- Method: HaloMorph>>setDirection:with: (in category 'private') ----- setDirection: anEvent with: directionHandle "The user has let up after having dragged the direction arrow; now set the forward direction of the actual SketchMorph accordingly" + (directionHandle hasProperty: #trackDirectionArrow) ifTrue: + [anEvent hand obtainHalo: self. + target setDirectionFrom: directionHandle center. + directionHandle removeProperty: #trackDirectionArrow. + self endInteraction]! - anEvent hand obtainHalo: self. - target setDirectionFrom: directionHandle center. - self endInteraction! Item was changed: ----- Method: HaloMorph>>trackCenterOfRotation:with: (in category 'private') ----- trackCenterOfRotation: anEvent with: rotationHandle (rotationHandle hasProperty: #dragByCenterOfRotation) ifTrue:[^self doDrag: anEvent with: rotationHandle]. + (rotationHandle hasProperty: #trackCenterOfRotation) + ifTrue: + [anEvent hand obtainHalo: self. + rotationHandle center: anEvent cursorPoint]! - anEvent hand obtainHalo: self. - rotationHandle center: anEvent cursorPoint.! Item was changed: ----- Method: HaloMorph>>trackDirectionArrow:with: (in category 'private') ----- trackDirectionArrow: anEvent with: shaft + (shaft hasProperty: #trackDirectionArrow) ifTrue: + [anEvent hand obtainHalo: self. + shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}. + self layoutChanged]! - anEvent hand obtainHalo: self. - shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}. - self layoutChanged! Item was changed: ----- Method: HandleMorph>>initialize (in category 'initialization') ----- initialize "initialize the state of the receiver" super initialize. "" + self extent: 16 @ 16. - self extent: 8 @ 8. ! Item was changed: ----- Method: IconicButton>>stationarySetup (in category 'initialization') ----- stationarySetup + "Set up event handlers for mouse actions. Should be spelled stationery..." self actWhen: #startDrag. self cornerStyle: #rounded. self borderNormal. self on: #mouseEnter send: #borderThick to: self. self on: #mouseDown send: nil to: nil. self on: #mouseLeave send: #borderNormal to: self. self on: #mouseLeaveDragging send: #borderNormal to: self. + self on: #mouseUp send: #borderThick to: self. + + self on: #click send: #launchPartFromClick to: self! - self on: #mouseUp send: #borderThick to: self.! Item was changed: ----- Method: ImageMorph class>>descriptionForPartsBin (in category 'parts bin') ----- descriptionForPartsBin + ^ self partName: 'Image' translatedNoop - ^ self partName: 'Image' categories: #('Graphics' 'Basic') + documentation: 'A non-editable picture. If you use the Paint palette to make a picture, you can edit it afterwards.' translatedNoop! - documentation: 'A non-editable picture. If you use the Paint palette to make a picture, you can edit it afterwards.'! Item was changed: ----- Method: ImageMorph class>>registerInFlapsRegistry (in category 'class initialization') ----- registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps + ifPresent: [:cl | cl registerQuad: {#ImageMorph. #authoringPrototype. 'Picture' translatedNoop. 'A non-editable picture of something' translatedNoop} - ifPresent: [:cl | cl registerQuad: #(ImageMorph authoringPrototype 'Picture' 'A non-editable picture of something') forFlapNamed: 'Supplies']! Item was changed: ----- Method: JoystickMorph class>>descriptionForPartsBin (in category 'parts bin') ----- descriptionForPartsBin + ^ self partName: 'Joystick' translatedNoop + categories: {'Basic' translatedNoop} + documentation: 'A joystick-like control' translatedNoop! - ^ self partName: 'Joystick' - categories: #('Useful') - documentation: 'A joystick-like control'! Item was changed: ----- Method: JoystickMorph class>>registerInFlapsRegistry (in category 'class initialization') ----- registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps + ifPresent: [:cl | cl registerQuad: {#JoystickMorph. #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop} - ifPresent: [:cl | cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control') forFlapNamed: 'PlugIn Supplies'. + cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop} - cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control') forFlapNamed: 'Scripting'. + cl registerQuad: {#JoystickMorph . #authoringPrototype. 'Joystick' translatedNoop. 'A joystick-like control' translatedNoop} - cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control') forFlapNamed: 'Supplies']! Item was changed: ----- Method: LineMorph class>>descriptionForPartsBin (in category 'parts bin') ----- descriptionForPartsBin + "Answer a description for the parts bin." + + ^ self partName: 'Line' translatedNoop + categories: {'Graphics' translatedNoop} + documentation: 'A straight line. Shift-click to get handles and move the ends.' translatedNoop! - ^ self partName: 'Line' - categories: #('Graphics' 'Basic') - documentation: 'A straight line. Shift-click to get handles and move the ends.'! Item was changed: ----- Method: MVCMenuMorph>>displayAt:during: (in category 'invoking') ----- displayAt: aPoint during: aBlock "Add this menu to the Morphic world during the execution of the given block." Smalltalk isMorphic ifFalse: [^ self]. + [ActiveWorld addMorph: self centeredNear: aPoint. - ActiveWorld addMorph: self centeredNear: aPoint. self world displayWorld. "show myself" + aBlock value] + ensure: [self delete]! - aBlock value. - self delete! Item was changed: ----- Method: MenuMorph>>delete (in category 'initialization') ----- delete + "Delete the receiver." + + activeSubMenu ifNotNil: [activeSubMenu stayUp ifFalse: [activeSubMenu delete]]. + self isFlexed ifTrue: [^ owner delete]. + ^ super delete! - activeSubMenu ifNotNil:[activeSubMenu delete]. - ^super delete! Item was changed: ----- Method: Morph class>>serviceLoadMorphFromFile (in category 'fileIn/Out') ----- serviceLoadMorphFromFile "Answer a service for loading a .morph file" ^ SimpleServiceEntry provider: self + label: 'load as morph' translatedNoop - label: 'load as morph' selector: #fromFileName: + description: 'load as morph' translatedNoop + buttonLabel: 'load' translatedNoop! - description: 'load as morph' - buttonLabel: 'load'! Item was changed: ----- Method: Morph>>addEmbeddingMenuItemsTo:hand: (in category 'meta-actions') ----- addEmbeddingMenuItemsTo: aMenu hand: aHandMorph "Construct a menu offerring embed targets for the receiver. If the incoming menu is is not degenerate, add the constructed menu as a submenu; in any case, answer the embed-target menu" + | menu w | - | menu potentialEmbeddingTargets | - - potentialEmbeddingTargets := self potentialEmbeddingTargets. - potentialEmbeddingTargets size > 1 ifFalse:[^ self]. - menu := MenuMorph new defaultTarget: self. + w := self world. + self potentialEmbeddingTargets reverseDo: [:m | + menu add: (m == w ifTrue: ['desktop' translated] ifFalse: [m knownName ifNil:[m class name asString]]) target: m selector: #addMorphFrontFromWorldPosition: argumentList: {self topRendererOrSelf}. + m == self topRendererOrSelf owner ifTrue: + [menu lastItem color: Color red]]. + aMenu ifNotNil: + [menu submorphCount > 0 + ifTrue:[aMenu add:'embed into' translated subMenu: menu]]. - - potentialEmbeddingTargets reverseDo: [:m | - menu - add: (m knownName ifNil:[m class name asString]) - target: m - selector: #addMorphFrontFromWorldPosition: - argument: self topRendererOrSelf. - - menu lastItem icon: (m iconOrThumbnailOfSize: 16). - - self owner == m ifTrue:[menu lastItem emphasis: 1]. - ]. - - aMenu add:'embed into' translated subMenu: menu. - ^ menu! Item was changed: ----- Method: Morph>>addFlexShell (in category 'rotate scale and flex') ----- addFlexShell "Wrap a rotating and scaling shell around this morph." + | oldHalo myWorld flexMorph anIndex | - | oldHalo flexMorph myWorld anIndex | + oldHalo:= self halo. myWorld := self world. + self owner + ifNil: [flexMorph := self newTransformationMorph asFlexOf: self] + ifNotNil: [:myOwner | + anIndex := myOwner submorphIndexOf: self. + flexMorph := self newTransformationMorph asFlexOf: self. + myOwner addMorph: flexMorph asElementNumber: anIndex. + myWorld ifNotNil: [myWorld startSteppingSubmorphsOf: flexMorph]]. - oldHalo := self halo. - anIndex := self owner submorphIndexOf: self. - self owner addMorph: (flexMorph := self newTransformationMorph asFlexOf: self) - asElementNumber: anIndex. self transferStateToRenderer: flexMorph. oldHalo ifNotNil: [oldHalo setTarget: flexMorph]. - myWorld ifNotNil: [myWorld startSteppingSubmorphsOf: flexMorph]. ^ flexMorph! Item was changed: ----- Method: Morph>>addHaloActionsTo: (in category 'menus') ----- addHaloActionsTo: aMenu "Add items to aMenu representing actions requestable via halo" | subMenu | subMenu := MenuMorph new defaultTarget: self. subMenu addTitle: self externalName. subMenu addStayUpItemSpecial. subMenu addLine. subMenu add: 'delete' translated action: #dismissViaHalo. subMenu balloonTextForLastItem: 'Delete this object -- warning -- can be destructive!!' translated. self maybeAddCollapseItemTo: subMenu. subMenu add: 'grab' translated action: #openInHand. subMenu balloonTextForLastItem: 'Pick this object up -- warning, since this removes it from its container, it can have adverse effects.' translated. subMenu addLine. subMenu add: 'resize' translated action: #resizeFromMenu. subMenu balloonTextForLastItem: 'Change the size of this object' translated. subMenu add: 'duplicate' translated action: #maybeDuplicateMorph. subMenu balloonTextForLastItem: 'Hand me a copy of this object' translated. "Note that this allows access to the non-instancing duplicate even when this is a uniclass instance" self couldMakeSibling ifTrue: [subMenu add: 'make a sibling' translated action: #handUserASibling. subMenu balloonTextForLastItem: 'Make a new sibling of this object and hand it to me' translated]. subMenu addLine. subMenu add: 'property sheet' translated target: self renderedMorph action: #openAPropertySheet. subMenu balloonTextForLastItem: 'Open a property sheet for me. Allows changing lots of stuff at once.' translated. subMenu add: 'set color' translated target: self renderedMorph action: #changeColor. subMenu balloonTextForLastItem: 'Change the color of this object' translated. subMenu add: 'viewer' translated target: self action: #beViewed. subMenu balloonTextForLastItem: 'Open a Viewer that will allow everything about this object to be seen and controlled.' translated. + subMenu add: 'tile browser' translated target: self action: #openInstanceBrowserWithTiles. subMenu balloonTextForLastItem: 'Open a tool that will facilitate tile scripting of this object.' translated. + subMenu add: 'tile representing this object' translated target: self action: #tearOffTile. - subMenu add: 'hand me a tile' translated target: self action: #tearOffTile. subMenu balloonTextForLastItem: 'Hand me a tile represting this object' translated. subMenu addLine. subMenu add: 'inspect' translated target: self action: #inspect. subMenu balloonTextForLastItem: 'Open an Inspector on this object' translated. aMenu add: 'halo actions...' translated subMenu: subMenu ! Item was removed: - ----- Method: Morph>>becomeModal (in category 'user interface') ----- - becomeModal - self currentWorld - ifNotNil: [self currentWorld modalWindow: self]! Item was changed: ----- Method: Morph>>buildDebugMenu: (in category 'debug and other') ----- buildDebugMenu: aHand "Answer a debugging menu for the receiver. The hand argument is seemingly historical and plays no role presently" | aMenu aPlayer | aMenu := MenuMorph new defaultTarget: self. aMenu addStayUpItem. (self hasProperty: #errorOnDraw) ifTrue: [aMenu add: 'start drawing again' translated action: #resumeAfterDrawError. aMenu addLine]. (self hasProperty: #errorOnStep) ifTrue: [aMenu add: 'start stepping again' translated action: #resumeAfterStepError. aMenu addLine]. aMenu add: 'inspect morph' translated action: #inspectInMorphic:. aMenu add: 'inspect owner chain' translated action: #inspectOwnerChain. Smalltalk isMorphic ifFalse: [aMenu add: 'inspect morph (in MVC)' translated action: #inspect]. self isMorphicModel ifTrue: [aMenu add: 'inspect model' translated target: self model action: #inspect]. (aPlayer := self player) ifNotNil: [aMenu add: 'inspect player' translated target: aPlayer action: #inspect]. aMenu add: 'explore morph' translated target: self selector: #exploreInMorphic:. aMenu addLine. aPlayer ifNotNil: [ aMenu add: 'viewer for Player' translated target: self player action: #beViewed. aMenu balloonTextForLastItem: 'Opens a viewer on my Player -- this is the same thing you get if you click on the cyan "View" halo handle' translated ]. aMenu add: 'viewer for Morph' translated target: self action: #viewMorphDirectly. aMenu balloonTextForLastItem: 'Opens a Viewer on this Morph, rather than on its Player' translated. aMenu addLine. aPlayer ifNotNil: [aPlayer class isUniClass ifTrue: [ + aMenu add: 'browse player class' translated target: aPlayer selector: #haveFullProtocolBrowsedShowingSelector: argumentList: #(nil)]]. - aMenu add: 'browse player class' translated target: aPlayer action: #browseHierarchy]]. aMenu add: 'browse morph class' translated target: self selector: #browseHierarchy. (self isMorphicModel) ifTrue: [aMenu add: 'browse model class' target: self model selector: #browseHierarchy]. aMenu addLine. self addViewingItemsTo: aMenu. aMenu add: 'make own subclass' translated action: #subclassMorph; add: 'save morph in file' translated action: #saveOnFile; addLine; add: 'call #tempCommand' translated action: #tempCommand; add: 'define #tempCommand' translated action: #defineTempCommand; addLine; add: 'control-menu...' translated target: self selector: #invokeMetaMenu:; add: 'edit balloon help' translated action: #editBalloonHelpText. ^ aMenu! Item was changed: ----- Method: Morph>>chooseNewGraphicCoexisting: (in category 'menus') ----- chooseNewGraphicCoexisting: aBoolean "Allow the user to choose a different form for her form-based morph" + | replacee aGraphicalMenu | + self isInWorld ifFalse: "menu must have persisted for a not-in-world object." + [aGraphicalMenu := ActiveWorld submorphThat: + [:m | (m isKindOf: GraphicalMenu) and: [m target == self]] + ifNone: + [^ self]. + ^ aGraphicalMenu show; flashBounds]. aGraphicalMenu := GraphicalMenu new initializeFor: self withForms: self reasonableForms coexist: aBoolean. aBoolean ifTrue: [self primaryHand attachMorph: aGraphicalMenu] ifFalse: [replacee := self topRendererOrSelf. replacee owner replaceSubmorph: replacee by: aGraphicalMenu]! Item was changed: ----- Method: Morph>>goBehind (in category 'submorphs-add/remove') ----- goBehind + "Move the receiver to bottom z-order." + | topRend | + topRend := self topRendererOrSelf. + topRend owner ifNotNil: + [:own | own addMorphNearBack: topRend] - owner addMorphNearBack: self. ! Item was changed: ----- Method: Morph>>helpButton (in category 'menus') ----- helpButton "Answer a button whose action would be to put up help concerning the receiver" | aButton | aButton := SimpleButtonMorph new. aButton target: self; + color: Color lightGreen; + borderColor: Color lightGreen muchDarker; - color: ColorTheme current helpColor; - borderColor: ColorTheme current helpColor muchDarker; borderWidth: 1; label: '?' translated font: Preferences standardButtonFont; actionSelector: #presentHelp; setBalloonText: 'click here for help' translated. ^ aButton! Item was changed: ----- Method: Morph>>invokeMetaMenu: (in category 'meta-actions') ----- invokeMetaMenu: evt + "Put up the 'meta' menu, invoked via control-click, unless eToyFriendly is true." + | menu | + Preferences eToyFriendly ifTrue: [^ self]. + menu := self buildMetaMenu: evt. menu addTitle: self externalName. + menu popUpEvent: evt in: self world! - self world ifNotNil: [ - menu popUpEvent: evt in: self world - ]! Item was changed: ----- Method: Morph>>obtrudesBeyondContainer (in category 'geometry testing') ----- obtrudesBeyondContainer "Answer whether the receiver obtrudes beyond the bounds of its container" + | top formerOwner | - | top | top := self topRendererOrSelf. + top owner ifNil: [^ false]. + ^ top owner isHandMorph + ifTrue: + [((formerOwner := top formerOwner) notNil and: [formerOwner isInWorld]) + ifFalse: + [false] + ifTrue: + [(formerOwner boundsInWorld containsRect: top boundsInWorld) not]] + ifFalse: + [(top owner bounds containsRect: top bounds) not]! - (top owner isNil or: [top owner isHandMorph]) ifTrue: [^false]. - ^(top owner bounds containsRect: top bounds) not! Item was changed: ----- Method: Morph>>overlapsShadowForm:bounds: (in category 'geometry') ----- overlapsShadowForm: itsShadow bounds: itsBounds "Answer true if itsShadow and my shadow overlap at all" + | overlapExtent overlap myRect myShadow goalRect goalShadow bb | + overlap := self fullBounds intersect: itsBounds. + overlapExtent := overlap extent. - | andForm overlapExtent | - overlapExtent := (itsBounds intersect: self fullBounds) extent. overlapExtent > (0 @ 0) ifFalse: [^ false]. + myRect := overlap translateBy: 0 @ 0 - self topLeft. + myShadow := (self imageForm contentsOfArea: myRect) stencil. + goalRect := overlap translateBy: 0 @ 0 - itsBounds topLeft. + goalShadow := (itsShadow contentsOfArea: goalRect) stencil. + + "compute a pixel-by-pixel AND of the two stencils. Result will be black + (pixel value = 1) where black parts of the stencils overlap" + bb := BitBlt toForm: myShadow. + bb + copyForm: goalShadow + to: 0 @ 0 + rule: Form and. + + ^(bb destForm tallyPixelValues second) > 0 ! - andForm := self shadowForm. - overlapExtent ~= self fullBounds extent - ifTrue: [andForm := andForm - contentsOfArea: (0 @ 0 extent: overlapExtent)]. - andForm := andForm - copyBits: (self fullBounds translateBy: itsShadow offset negated) - from: itsShadow - at: 0 @ 0 - clippingBox: (0 @ 0 extent: overlapExtent) - rule: Form and - fillColor: nil. - ^ andForm bits - anySatisfy: [:w | w ~= 0]! Item was changed: ----- Method: Morph>>roundUpStrays (in category 'miscellaneous') ----- roundUpStrays + "Bring submorphs of playfieldlike structures in the receiver's interior back within view." + + self submorphsDo: + [:m | m isPlayfieldLike ifTrue: [m roundUpStrays]]! - self submorphs - do: [:each | each roundUpStrays]! Item was changed: ----- Method: Morph>>slideBackToFormerSituation: (in category 'dropping/grabbing') ----- slideBackToFormerSituation: evt + "A drop of the receiver having been rejected, slide it back to where it came from, if possible." + | slideForm formerOwner formerPosition aWorld startPoint endPoint trans | formerOwner := self formerOwner. formerPosition := self formerPosition. + (aWorld := evt hand world) ifNil: [^ self delete]. "Likely a moribund hand from an EventRecorder playback." + - aWorld := evt hand world. trans := formerOwner transformFromWorld. slideForm := trans isPureTranslation ifTrue: [self imageForm offset: 0 @ 0] ifFalse: [((TransformationMorph new asFlexOf: self) transform: trans) imageForm offset: 0 @ 0]. startPoint := evt hand fullBounds origin. endPoint := trans localPointToGlobal: formerPosition. owner removeMorph: self. aWorld displayWorld. slideForm slideFrom: startPoint to: endPoint nSteps: 12 delay: 15. + "The OLPC Virtual Screen wouldn't notice the last update here." + self refreshWorld. formerOwner addMorph: self. self position: formerPosition. self justDroppedInto: formerOwner event: evt! Item was changed: ----- Method: Morph>>usableSiblingInstance (in category 'copying') ----- usableSiblingInstance "Return another similar morph whose Player is of the same class as mine. Do not open it in the world." + | aName newPlayer newMorph topRenderer counter world | - | aName usedNames newPlayer newMorph topRenderer | (topRenderer := self topRendererOrSelf) == self ifFalse: [^topRenderer usableSiblingInstance]. self assuredPlayer assureUniClass. newMorph := self veryDeepCopySibling. newPlayer := newMorph player. newPlayer resetCostumeList. (aName := self knownName) isNil ifTrue: [self player notNil ifTrue: [aName := newMorph innocuousName]]. "Force a difference here" + + aName := aName stemAndNumericSuffix at: 1. + + world := self world ifNil: [Project current world]. + (world hasProperty: #nameCounter) ifFalse: [ + (world setProperty: #nameCounter toValue: Dictionary new) + ]. + + counter := (world valueOfProperty: #nameCounter) at: aName ifAbsent: [1]. + newMorph setNameTo: aName, counter. + (world valueOfProperty: #nameCounter) at: aName put: counter + 1. + - aName notNil - ifTrue: - [usedNames := (self world ifNil: [OrderedCollection new] - ifNotNil: [self world allKnownNames]) copyWith: aName. - newMorph setNameTo: (Utilities keyLike: aName - satisfying: [:f | (usedNames includes: f) not])]. newMorph privateOwner: nil. newPlayer assureEventHandlerRepresentsStatus. self presenter flushPlayerListCache. ^newMorph! Item was changed: ----- Method: Morph>>wantsHaloFromClick (in category 'halos and balloon help') ----- wantsHaloFromClick + + ^ self valueOfProperty: #wantsHaloFromClick ifAbsent: [^true].! - ^ true! Item was changed: ----- Method: MorphHierarchyListMorph>>createContainer (in category 'private') ----- createContainer "Private - Create a container" | container | container := BorderedMorph new. container extent: (World extent * (1 / 4 @ (2 / 3))) rounded. container layoutPolicy: TableLayout new. container hResizing: #rigid. container vResizing: #rigid. container + setColor: (Color gray: 0.9) + borderWidth: 1 + borderColor: Color gray. - setColor: MenuMorph menuColor - borderWidth: MenuMorph menuBorderWidth - borderColor: MenuMorph menuBorderColor. container layoutInset: 0. "container useRoundedCorners." "" container setProperty: #morphHierarchy toValue: true. container setNameTo: 'Objects Hierarchy' translated. "" ^ container! Item was added: + ----- Method: MorphicModel>>addModelYellowButtonMenuItemsTo:forMorph:hand: (in category 'graph model') ----- + addModelYellowButtonMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph + + Preferences noviceMode ifFalse: [ + super addModelYellowButtonMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph]. + ^ aCustomMenu! Item was added: + ----- Method: MorphicProject>>acceptProjectDetails: (in category 'file in/out') ----- + acceptProjectDetails: details + "Store project details back into a property of the world, and if a name is provided, make sure the name is properly installed in the project." + + self world setProperty: #ProjectDetails toValue: details. + details at: 'projectname' ifPresent: [ :newName | + self renameTo: newName]! Item was added: + ----- Method: MorphicProject>>compressFilesIn:to:in: (in category 'file in/out') ----- + compressFilesIn: tempDir to: localName in: localDirectory + "Compress all the files in tempDir making up a zip file in localDirectory named localName" + + | archive archiveName entry fileNames | + archive := ZipArchive new. + fileNames := tempDir fileNames. + (fileNames includes: 'manifest') + ifTrue: [fileNames := #('manifest'), (fileNames copyWithout: 'manifest')]. + fileNames do:[:fn| + archiveName := fn. + entry := archive addFile: (tempDir fullNameFor: fn) as: archiveName. + entry desiredCompressionMethod: ( + fn = 'manifest' + ifTrue: [ZipArchive compressionLevelNone] + ifFalse: [ZipArchive compressionDeflated]). + ]. + archive writeToFileNamed: (localDirectory fullNameFor: localName). + archive close. + tempDir fileNames do:[:fn| + tempDir deleteFileNamed: fn ifAbsent:[]]. + localDirectory deleteDirectory: tempDir localName.! Item was added: + ----- Method: MorphicProject>>compressFilesIn:to:in:resources: (in category 'file in/out') ----- + compressFilesIn: tempDir to: localName in: localDirectory resources: collector + "Compress all the files in tempDir making up a zip file in localDirectory named localName" + | archive urlMap | + urlMap := Dictionary new. + collector locatorsDo:[:loc| + "map local file names to urls" + urlMap at: (tempDir localNameFor: loc localFileName) put: loc urlString. + ResourceManager cacheResource: loc urlString inArchive: localName]. + archive := ZipArchive new. + tempDir fileNames do:[:fn| | archiveName entry | + archiveName := urlMap at: fn ifAbsent:[fn]. + entry := archive addFile: (tempDir fullNameFor: fn) as: archiveName. + entry desiredCompressionMethod: ZipArchive compressionStored. + ]. + archive writeToFileNamed: (localDirectory fullNameFor: localName). + archive close. + tempDir fileNames do:[:fn| + tempDir deleteFileNamed: fn ifAbsent:[]]. + localDirectory deleteDirectory: tempDir localName.! Item was added: + ----- Method: MorphicProject>>exportSegmentInSexpWithChangeSet:fileName:directory:withoutInteraction: (in category 'file in/out') ----- + exportSegmentInSexpWithChangeSet: aChangeSetOrNil fileName: aFileName directory: aDirectory withoutInteraction: noInteraction + + | fd sexp actualName | + + world ifNil: [^ false]. + world presenter ifNil: [^ false]. + (world respondsTo: #sissScanObjectsAsEtoysProject) ifFalse: [^ false]. + + Command initialize. + world clearCommandHistory. + world cleanseStepList. + world localFlapTabs size = world flapTabs size ifFalse: [ + noInteraction ifTrue: [^ false]. + self error: 'Still holding onto Global flaps']. + + fd := aDirectory directoryNamed: self resourceDirectoryName. + fd assureExistence. + + "Must activate old world because this is run at #armsLength. + Otherwise references to ActiveWorld, ActiveHand, or ActiveEvent + will not be captured correctly if referenced from blocks or user code." + world becomeActiveDuring:[ + sexp := world sissScanObjectsAsEtoysProject. + ]. + (aFileName endsWith: '.pr') ifTrue: [ + actualName := (aFileName copyFrom: 1 to: aFileName size - 3), '.sexp'. + ] ifFalse: [ + actualName := aFileName + ]. + + self + writeForExportInSexp: sexp withSources: actualName + inDirectory: fd + changeSet: aChangeSetOrNil. + SecurityManager default signFile: actualName directory: fd. + self storeHtmlPageIn: fd. + (world valueOfProperty: #ProjectDetails ifAbsent: [Dictionary new]) + at: 'Project-Format' put: 'S-Expression'. + self storeManifestFileIn: fd. + self compressFilesIn: fd to: aFileName in: aDirectory. + + ^ true + ! Item was changed: ----- Method: MorphicProject>>exportSegmentWithChangeSet:fileName:directory: (in category 'file in/out') ----- exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName directory: aDirectory - "Store my project out on the disk as an *exported* - ImageSegment. All outPointers will be in a form that can be resolved - in the target image. Name it <project name>.extSeg. Whatdo we do - about subProjects, especially if they are out as local image - segments? Force them to come in? - Player classes are included automatically." + ^ self exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName directory: aDirectory withoutInteraction: false! - | is str ans revertSeg roots holder collector fd mgr stacks | - - "Files out a changeSet first, so that a project can contain - its own classes" - world ifNil: [^ false]. - world presenter ifNil: [^ false]. - - ScrapBook default emptyScrapBook. - world currentHand pasteBuffer: nil. "don't write the paste buffer." - world currentHand mouseOverHandler initialize. "forget about any - references here" - "Display checkCurrentHandForObjectToPaste." - Command initialize. - world clearCommandHistory. - world fullReleaseCachedState; releaseViewers. - world cleanseStepList. - world localFlapTabs size = world flapTabs size ifFalse: [ - self error: 'Still holding onto Global flaps']. - world releaseSqueakPages. - holder := Project allProjects. "force them in to outPointers, where - DiskProxys are made" - - "Just export me, not my previous version" - revertSeg := self parameterAt: #revertToMe. - self removeParameter: #revertToMe. - - roots := OrderedCollection new. - roots add: self; add: world; add: transcript; add: aChangeSetOrNil; add: thumbnail; add: world activeHand. - - "; addAll: classList; addAll: (classList collect: [:cls | cls class])" - - roots := roots reject: [ :x | x isNil]. "early saves may not have - active hand or thumbnail" - - fd := aDirectory directoryNamed: self resourceDirectoryName. - fd assureExistence. - "Clean up resource references before writing out" - mgr := self resourceManager. - self resourceManager: nil. - ResourceCollector current: ResourceCollector new. - ResourceCollector current localDirectory: fd. - ResourceCollector current baseUrl: self resourceUrl. - ResourceCollector current initializeFrom: mgr. - ProgressNotification signal: '2:findingResources' extra: - '(collecting resources...)' translated. - "Must activate old world because this is run at #armsLength. - Otherwise references to ActiveWorld, ActiveHand, or ActiveEvent - will not be captured correctly if referenced from blocks or user code." - world becomeActiveDuring: [world firstHand becomeActiveDuring: [ - is := ImageSegment new copySmartRootsExport: roots asArray. - "old way was (is := ImageSegment new - copyFromRootsForExport: roots asArray)" - ]]. - self resourceManager: mgr. - collector := ResourceCollector current. - ResourceCollector current: nil. - ProgressNotification signal: '2:foundResources' extra: ''. - is state = #tooBig ifTrue: [ - collector replaceAll. - ^ false]. - - str := ''. - "considered legal to save a project that has never been entered" - (is outPointers includes: world) ifTrue: [ - str := str, '\Project''s own world is not in the segment.' translated withCRs]. - str isEmpty ifFalse: [ - ans := UIManager default chooseFrom: { - 'Do not write file' translated. - 'Write file anyway' translated. - 'Debug' translated. - } title: str. - ans = 1 ifTrue: [ - revertSeg ifNotNil: [projectParameters at: - #revertToMe put: revertSeg]. - collector replaceAll. - ^ false]. - ans = 3 ifTrue: [ - collector replaceAll. - self halt: 'Segment not written' translated]]. - stacks := is findStacks. - - is - writeForExportWithSources: aFileName - inDirectory: fd - changeSet: aChangeSetOrNil. - SecurityManager default signFile: aFileName directory: fd. - "Compress all files and update check sums" - collector forgetObsolete. - self storeResourceList: collector in: fd. - self storeHtmlPageIn: fd. - self storeManifestFileIn: fd. - self writeStackText: stacks in: fd registerIn: collector. - "local proj.005.myStack.t" - self compressFilesIn: fd to: aFileName in: aDirectory - resources: collector. - "also deletes the resource directory" - "Now update everything that we know about" - mgr updateResourcesFrom: collector. - - revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg]. - holder. - - collector replaceAll. - - world flapTabs do: [:ft | - (ft respondsTo: #unhibernate) ifTrue: [ft unhibernate]]. - is arrayOfRoots do: [:obj | - obj isScriptEditorMorph ifTrue: [obj unhibernate]]. - ^ true - ! Item was added: + ----- Method: MorphicProject>>exportSegmentWithChangeSet:fileName:directory:withoutInteraction: (in category 'file in/out') ----- + exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName + directory: aDirectory withoutInteraction: noInteraction + "Store my project out on the disk as an *exported* + ImageSegment. All outPointers will be in a form that can be resolved + in the target image. Name it <project name>.extSeg. Whatdo we do + about subProjects, especially if they are out as local image + segments? Force them to come in? + Player classes are included automatically." + + | is str ans revertSeg roots holder collector fd mgr stacks | + + "Files out a changeSet first, so that a project can contain + its own classes" + world ifNil: [^ false]. + world presenter ifNil: [^ false]. + + Utilities emptyScrapsBook. + world cleanUpReferences. + world currentHand pasteBuffer: nil. "don't write the paste buffer." + world currentHand mouseOverHandler initialize. "forget about any + references here" + "Display checkCurrentHandForObjectToPaste." + Command initialize. + world clearCommandHistory. + world fullReleaseCachedState; releaseViewers. + world cleanseStepList. + world localFlapTabs size = world flapTabs size ifFalse: [ + noInteraction ifTrue: [^ false]. + self error: 'Still holding onto Global flaps']. + world releaseSqueakPages. + Smalltalk at: #ScriptEditorMorph ifPresent: [:s | + s writingUniversalTiles: (self projectParameterAt: #universalTiles ifAbsent: [false])]. + holder := Project allProjects. "force them in to outPointers, where + DiskProxys are made" + + "Just export me, not my previous version" + revertSeg := self parameterAt: #revertToMe. + self removeParameter: #revertToMe. + + roots := OrderedCollection new. + roots add: self; add: world; add: transcript; add: aChangeSetOrNil; add: thumbnail; add: world activeHand. + + "; addAll: classList; addAll: (classList collect: [:cls | cls class])" + + roots := roots reject: [ :x | x isNil]. "early saves may not have + active hand or thumbnail" + + fd := aDirectory directoryNamed: self resourceDirectoryName. + fd assureExistence. + "Clean up resource references before writing out" + mgr := self resourceManager. + self resourceManager: nil. + ResourceCollector current: ResourceCollector new. + ResourceCollector current localDirectory: fd. + ResourceCollector current baseUrl: self resourceUrl. + ResourceCollector current initializeFrom: mgr. + ProgressNotification signal: '2:findingResources' extra: + '(collecting resources...)' translated. + "Must activate old world because this is run at #armsLength. + Otherwise references to ActiveWorld, ActiveHand, or ActiveEvent + will not be captured correctly if referenced from blocks or user code." + world becomeActiveDuring:[ + is := ImageSegment new copySmartRootsExport: roots asArray. + "old way was (is := ImageSegment new + copyFromRootsForExport: roots asArray)" + ]. + self resourceManager: mgr. + collector := ResourceCollector current. + ResourceCollector current: nil. + ProgressNotification signal: '2:foundResources' extra: ''. + is state = #tooBig ifTrue: [ + collector replaceAll. + ^ false]. + + str := ''. + "considered legal to save a project that has never been entered" + (is outPointers includes: world) ifTrue: [ + str := str, '\Project''s own world is not in the segment.' translated withCRs]. + str isEmpty ifFalse: [ + ans := UIManager default chooseFrom: { + 'Do not write file' translated. + 'Write file anyway' translated. + 'Debug' translated. + } title: str. + ans = 1 ifTrue: [ + revertSeg ifNotNil: [projectParameters at: + #revertToMe put: revertSeg]. + collector replaceAll. + ^ false]. + ans = 3 ifTrue: [ + collector replaceAll. + self halt: 'Segment not written' translated]]. + stacks := is findStacks. + + is + writeForExportWithSources: aFileName + inDirectory: fd + changeSet: aChangeSetOrNil. + SecurityManager default signFile: aFileName directory: fd. + "Compress all files and update check sums" + collector forgetObsolete. + self storeResourceList: collector in: fd. + self storeHtmlPageIn: fd. + self storeManifestFileIn: fd. + self writeStackText: stacks in: fd registerIn: collector. + "local proj.005.myStack.t" + self compressFilesIn: fd to: aFileName in: aDirectory + resources: collector. + "also deletes the resource directory" + "Now update everything that we know about" + mgr updateResourcesFrom: collector. + + revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg]. + holder. + + collector replaceAll. + + world flapTabs do: [:ft | + (ft respondsTo: #unhibernate) ifTrue: [ft unhibernate]]. + is arrayOfRoots do: [:obj | + obj isScriptEditorMorph ifTrue: [obj unhibernate]]. + ^ true + ! Item was added: + ----- Method: MorphicProject>>myPlayerClasses (in category 'release') ----- + myPlayerClasses + "Answer all my (non-systemDefined) player classes" + | classes presenter | + classes := Set new. + presenter := self world presenter. + presenter ifNotNil: [ + presenter flushPlayerListCache. "old and outside guys" + presenter allExtantPlayers do: + [:p | p class isSystemDefined ifFalse: [classes add: p class]]]. + ^classes! Item was changed: ----- Method: MorphicProject>>prepareForDelete (in category 'release') ----- prepareForDelete "The window in which the project is housed is about to deleted. Perform any necessary actions to prepare for deletion." + | list | - | is list | Smalltalk at: #WonderlandCameraMorph ifPresent:[:aClass | world submorphs do: "special release for wonderlands" [:m | (m isKindOf: aClass) and: [m getWonderland release]]]. "Remove Player classes and metaclasses owned by project" + self myPlayerClasses do: [:playerCls | playerCls removeFromSystemUnlogged]. - is := ImageSegment new arrayOfRoots: (Array with: self). - (list := is rootsIncludingPlayers) ifNotNil: - [list do: [:playerCls | - (playerCls respondsTo: #isMeta) ifTrue: - [playerCls isMeta ifFalse: - [playerCls removeFromSystemUnlogged]]]] ! Item was changed: ----- Method: MorphicProject>>updateLocaleDependents (in category 'language') ----- updateLocaleDependents "Set the project's natural language as indicated" ActiveWorld allTileScriptingElements do: [:viewerOrScriptor | viewerOrScriptor localeChanged]. Flaps disableGlobalFlaps: false. + (Preferences eToyFriendly or: [ + (Smalltalk classNamed: 'SugarNavigatorBar') ifNotNil: [:c | c showSugarNavigator] ifNil: [false]]) - Preferences eToyFriendly ifTrue: [ Flaps addAndEnableEToyFlaps. ActiveWorld addGlobalFlaps] ifFalse: [Flaps enableGlobalFlaps]. (Project current isFlapIDEnabled: 'Navigator' translated) ifFalse: [Flaps enableDisableGlobalFlapWithID: 'Navigator' translated]. ScrapBook default emptyScrapBook. MenuIcons initializeTranslations. super updateLocaleDependents. "self setFlaps. self setPaletteFor: aLanguageSymbol." ! Item was added: + ----- Method: NewBalloonMorph>>color: (in category 'accessing') ----- + color: aColor + + super color: aColor. + self updateGradient.! Item was changed: ----- Method: NewBalloonMorph>>setDefaultParameters (in category 'initialization') ----- setDefaultParameters self borderWidth: (self userInterfaceTheme borderWidth ifNil: [1]); borderColor: (self userInterfaceTheme borderColor ifNil: [Color r: 0.46 g: 0.46 b: 0.353]); color: (self userInterfaceTheme color ifNil: [Color r: 0.92 g: 0.92 b: 0.706]); hasDropShadow: (Preferences menuAppearance3d and: [self color isTranslucent not]); shadowOffset: 1@1; shadowColor: (self color muchDarker muchDarker alpha: 0.333); + orientation: #bottomLeft; + cornerStyle: (MenuMorph roundedMenuCorners ifTrue: [#rounded] ifFalse: [#square]).! - orientation: #bottomLeft. - - MenuMorph roundedMenuCorners - ifTrue: [self cornerStyle: #rounded]. - - "Gradients?" - MenuMorph gradientMenu ifTrue: [ - | cc fill | - cc := self color. - fill := GradientFillStyle ramp: { - 0.0 -> Color white. - 0.15 -> (cc mixed: 0.5 with: Color white). - 0.5 -> cc. - 0.8 -> cc twiceDarker}. - fill - origin: self topLeft; - direction: 0@self height. - self fillStyle: fill].! Item was added: + ----- Method: NewBalloonMorph>>updateGradient (in category 'updating') ----- + updateGradient + + | cc fill | + + MenuMorph gradientMenu ifFalse: [^ self]. + + cc := self color. + fill := GradientFillStyle ramp: { + 0.0 -> Color white. + 0.15 -> (cc mixed: 0.5 with: Color white). + 0.5 -> cc. + 0.8 -> cc twiceDarker}. + fill + origin: self topLeft; + direction: 0@self height. + self fillStyle: fill.! Item was changed: ----- Method: PasteUpMorph class>>authoringPrototype (in category 'scripting') ----- authoringPrototype "Answer an instance of the receiver suitable for placing in a parts bin for authors" | proto | proto := self new markAsPartsDonor. proto color: Color green muchLighter; extent: 100 @ 80; borderColor: (Color r: 0.645 g: 0.935 b: 0.161). proto extent: 300 @ 240. + proto wantsMouseOverHalos: false. proto beSticky. ^ proto! Item was changed: ----- Method: PasteUpMorph class>>defaultNameStemForInstances (in category 'printing') ----- defaultNameStemForInstances "Answer a basis for names of default instances of the receiver" + ^ 'playfield' translatedNoop! - ^ 'playfield'! Item was changed: ----- Method: PasteUpMorph>>addPenMenuItems:hand: (in category 'menu & halo') ----- addPenMenuItems: menu hand: aHandMorph "Add a pen-trails-within submenu to the given menu" + menu add: 'pen trails...' translated target: self selector: #putUpPenTrailsSubmenu. + menu balloonTextForLastItem: 'its governing pen trails drawn within' translated! - menu add: 'penTrails within...' translated target: self action: #putUpPenTrailsSubmenu! Item was changed: ----- Method: PasteUpMorph>>addPenTrailsMenuItemsTo: (in category 'menu & halo') ----- addPenTrailsMenuItemsTo: aMenu "Add items relating to pen trails to aMenu" | oldTarget | oldTarget := aMenu defaultTarget. aMenu defaultTarget: self. aMenu add: 'clear pen trails' translated action: #clearTurtleTrails. aMenu addLine. aMenu add: 'all pens up' translated action: #liftAllPens. aMenu add: 'all pens down' translated action: #lowerAllPens. aMenu addLine. aMenu add: 'all pens show lines' translated action: #linesForAllPens. aMenu add: 'all pens show arrowheads' translated action: #arrowsForAllPens. aMenu add: 'all pens show arrows' translated action: #linesAndArrowsForAllPens. aMenu add: 'all pens show dots' translated action: #dotsForAllPens. + aMenu addLine. + aMenu addUpdating: #batchPenTrailsString action: #toggleBatchPenTrails. + aMenu balloonTextForLastItem: 'if true, detailed movement of pens between display updates is ignored. Thus multiple line segments drawn within a script may not be seen individually.' translated. + aMenu defaultTarget: oldTarget! Item was changed: ----- Method: PasteUpMorph>>assureNotPaintingElse: (in category 'world state') ----- assureNotPaintingElse: aBlock "If painting is already underway in the receiver, put up an informer to that effect and evalute aBlock" - self removeModalWindow. self sketchEditorOrNil ifNotNil: [self inform: 'Sorry, you can only paint one object at a time' translated. Cursor normal show. ^ aBlock value] ! Item was changed: ----- Method: PasteUpMorph>>chooseClickTarget (in category 'world state') ----- chooseClickTarget Cursor crossHair showWhile: [Sensor waitButton]. Cursor down showWhile: [Sensor anyButtonPressed]. + ^ (self morphsAt: Sensor cursorPoint) first topRendererOrSelf! - ^ (self morphsAt: Sensor cursorPoint) first! Item was changed: ----- Method: PasteUpMorph>>correspondingFlapTab (in category 'flaps') ----- correspondingFlapTab + "If there is a flap tab whose referent is me, return it, else return nil. Will also work for flaps on the edge of embedded subareas such as within scripting-areas, but more slowly." + - "If there is a flap tab whose referent is me, return it, else return nil" self currentWorld flapTabs do: [:aTab | aTab referent == self ifTrue: [^ aTab]]. + + "Catch guys in embedded worldlets" + ActiveWorld allMorphs do: + [:aTab | ((aTab isKindOf: FlapTab) and: [aTab referent == self]) ifTrue: [^ aTab]]. + ^ nil! Item was added: + ----- Method: PasteUpMorph>>couldMakeSibling (in category 'classification') ----- + couldMakeSibling + + ^ self isWorldMorph not! Item was changed: ----- Method: PasteUpMorph>>defaultNameStemForInstances (in category 'viewer') ----- defaultNameStemForInstances "Answer a basis for names of default instances of the receiver" ^ self isWorldMorph ifFalse: [super defaultNameStemForInstances] ifTrue: + ['world' translatedNoop]! - ['world']! Item was changed: ----- Method: PasteUpMorph>>extractScreenRegion:andPutSketchInHand: (in category 'world menu') ----- extractScreenRegion: poly andPutSketchInHand: hand "The user has specified a polygonal area of the Display. Now capture the pixels from that region, and put in the hand as a Sketch." | screenForm outline topLeft innerForm exterior | outline := poly shadowForm. topLeft := outline offset. exterior := (outline offset: 0@0) anyShapeFill reverse. screenForm := Form fromDisplay: (topLeft extent: outline extent). screenForm eraseShape: exterior. innerForm := screenForm trimBordersOfColor: Color transparent. + ActiveHand showTemporaryCursor: nil. innerForm isAllWhite ifFalse: [hand attachMorph: (self drawingClass withForm: innerForm)]! Item was changed: ----- Method: PasteUpMorph>>flapTab (in category 'accessing') ----- flapTab + "Answer the tab affilitated with the receiver. Normally every flap tab is expected to have a PasteUpMorph which serves as its 'referent.'" + | ww | self isFlap ifFalse:[^nil]. + ww := self presenter associatedMorph ifNil: [ActiveWorld]. + ^ ww ifNotNil: [ww flapTabs detect:[:any| any referent == self] ifNone: [nil]]! - ww := self world ifNil: [World]. - ^ww flapTabs detect:[:any| any referent == self] ifNone:[nil]! Item was changed: ----- Method: PasteUpMorph>>gridVisibleString (in category 'gridding') ----- gridVisibleString "Answer a string to be used in a menu offering the opportunity to show or hide the grid" ^ (self gridVisible ifTrue: ['<yes>'] ifFalse: ['<no>']) + , 'grid visible when gridding' translated! - , 'show grid when gridding' translated! Item was changed: ----- Method: PasteUpMorph>>indicateCursor: (in category 'options') ----- indicateCursor: aBoolean + indicateCursor := aBoolean. + self changed.! - indicateCursor := aBoolean! Item was changed: ----- Method: PasteUpMorph>>installFlaps (in category 'world state') ----- installFlaps "Get flaps installed within the bounds of the receiver" + | localFlapTabs | Project current assureFlapIntegrity. self addGlobalFlaps. + localFlapTabs := self localFlapTabs. + localFlapTabs do: [:each | each visible: false]. + + Preferences eToyFriendly ifTrue: [ + ProgressInitiationException display: 'Building Viewers...' translated + during: [:bar | + localFlapTabs keysAndValuesDo: [:i :each | + each adaptToWorld. + each visible: true. + each unhibernate. + self displayWorld. + bar value: i / self localFlapTabs size]]. + ] ifFalse: [ + localFlapTabs keysAndValuesDo: [:i :each | + each adaptToWorld. + each visible: true. + self displayWorld]]. + - self localFlapTabs do: - [:aFlapTab | aFlapTab adaptToWorld]. self assureFlapTabsFitOnScreen. self bringTopmostsToFront! Item was changed: ----- Method: PasteUpMorph>>makeNewDrawing:at: (in category 'world menu') ----- makeNewDrawing: evt at: aPoint "make a new drawing, triggered by the given event, with the painting area centered around the given point" | w newSketch newPlayer sketchEditor aPalette rect aPaintBox aPaintTab aWorld | w := self world. w assureNotPaintingElse: [^ self]. rect := self paintingBoundsAround: aPoint. aPalette := self standardPalette. aPalette ifNotNil: [aPalette showNoPalette; layoutChanged]. w prepareToPaint. newSketch := self drawingClass new. Smalltalk at: #UnscriptedPlayer ifPresent:[:aClass| newSketch player: (newPlayer := aClass newUserInstance). newPlayer costume: newSketch. ]. newSketch nominalForm: (Form extent: rect extent depth: w assuredCanvas depth). newSketch bounds: rect. sketchEditor := SketchEditorMorph new. w addMorphFront: sketchEditor. sketchEditor initializeFor: newSketch inBounds: rect pasteUpMorph: self. sketchEditor + afterNewPicDo: [:aForm :aRect | | tfx whereToPresent | - afterNewPicDo: [:aForm :aRect | | tfx ownerBeforeHack whereToPresent | whereToPresent := self presenter. newSketch form: aForm. tfx := self transformFrom: w. newSketch position: (tfx globalPointToLocal: aRect origin). newSketch rotationStyle: sketchEditor rotationStyle. newSketch forwardDirection: sketchEditor forwardDirection. - ownerBeforeHack := newSketch owner. "about to break the invariant!!!!" - newSketch privateOwner: self. "temp for halo access" newPlayer ifNotNil:[newPlayer setHeading: sketchEditor forwardDirection]. (aPaintTab := (aWorld := self world) paintingFlapTab) ifNotNil:[aPaintTab hideFlap] ifNil:[(aPaintBox := aWorld paintBox) ifNotNil:[aPaintBox delete]]. - "Includes newSketch rotationDegrees: sketchEditor forwardDirection." - newSketch privateOwner: ownerBeforeHack. "probably nil, but let's be certain" - self addMorphFront: (newPlayer ifNil:[newSketch] ifNotNil:[newPlayer costume]). w startSteppingSubmorphsOf: newSketch. whereToPresent drawingJustCompleted: newSketch] ifNoBits:[ (aPaintTab := (aWorld := self world) paintingFlapTab) ifNotNil:[aPaintTab hideFlap] ifNil:[(aPaintBox := aWorld paintBox) ifNotNil:[aPaintBox delete]]. aPalette ifNotNil: [aPalette showNoPalette].]! Item was removed: - ----- Method: PasteUpMorph>>modalWindow: (in category 'accessing') ----- - modalWindow: aMorph - (self valueOfProperty: #modalWindow) - ifNotNil: [:morph | morph doCancel]. - self setProperty: #modalWindow toValue: aMorph. - aMorph - ifNotNil: [self - when: #aboutToLeaveWorld - send: #removeModalWindow - to: self]! Item was changed: ----- Method: PasteUpMorph>>presentCardAndStackMenu (in category 'menu & halo') ----- presentCardAndStackMenu "Put up a menu holding card/stack-related options." | aMenu | aMenu := MenuMorph new defaultTarget: self. aMenu addStayUpItem. + aMenu addTitle: 'card and stack' translated. + aMenu add: 'add new card' translated action: #insertCard. + aMenu add: 'delete this card' translated action: #deleteCard. + aMenu add: 'go to next card' translated action: #goToNextCardInStack. + aMenu add: 'go to previous card' translated action: #goToPreviousCardInStack. - aMenu addTitle: 'card und stack'. - aMenu add: 'add new card' action: #insertCard. - aMenu add: 'delete this card' action: #deleteCard. - aMenu add: 'go to next card' action: #goToNextCardInStack. - aMenu add: 'go to previous card' action: #goToPreviousCardInStack. aMenu addLine. + aMenu add: 'show foreground objects' translated action: #showForegroundObjects. + aMenu add: 'show background objects' translated action: #showBackgroundObjects. + aMenu add: 'show designations' translated action: #showDesignationsOfObjects. + aMenu add: 'explain designations' translated action: #explainDesignations. - aMenu add: 'show foreground objects' action: #showForegroundObjects. - aMenu add: 'show background objects' action: #showBackgroundObjects. - aMenu add: 'show designations' action: #showDesignationsOfObjects. - aMenu add: 'explain designations' action: #explainDesignations. aMenu popUpInWorld: (self world ifNil: [self currentWorld])! Item was changed: ----- Method: PasteUpMorph>>referencePool (in category 'objects from disk') ----- referencePool ^ self valueOfProperty: #References + ifAbsentPut: [WeakValueDictionary new] + ! - ifAbsentPut: [OrderedCollection new] - - ! Item was changed: ----- Method: PasteUpMorph>>releaseCachedState (in category 'caching') ----- releaseCachedState super releaseCachedState. - self removeModalWindow. presenter ifNotNil:[presenter flushPlayerListCache]. self isWorldMorph ifTrue:[self cleanseStepList].! Item was removed: - ----- Method: PasteUpMorph>>removeModalWindow (in category 'accessing') ----- - removeModalWindow - self modalWindow: nil! Item was changed: ----- Method: PasteUpMorph>>startRunningAll (in category 'misc') ----- startRunningAll "Start running all scripted morphs. Triggered by user hitting GO button" self presenter flushPlayerListCache. "Inefficient, but makes sure things come right whenever GO hit" self presenter allExtantPlayers do: [:aPlayer | aPlayer costume residesInPartsBin ifFalse: [aPlayer startRunning]]. - self allScriptors do: - [:aScriptor | aScriptor startRunningIfPaused]. self world updateStatusForAllScriptEditors! Item was changed: ----- Method: PasteUpMorph>>stepAll (in category 'misc') ----- stepAll "tick all the paused player scripts in the receiver" self presenter allExtantPlayers do: [:aPlayer | + aPlayer startRunning; step; stopRunning]! - aPlayer startRunning; step; stopRunning]. - - self allScriptors do: - [:aScript | aScript startRunningIfPaused; step; pauseIfTicking]. - ! Item was changed: ----- Method: PasteUpMorph>>stopRunningAll (in category 'misc') ----- stopRunningAll "Reset all ticking scripts to be paused. Triggered by user hitting STOP button" self presenter allExtantPlayers do: [:aPlayer | + aPlayer stopRunning]. - aPlayer stopRunning]. - self allScriptors do: - [:aScript | aScript pauseIfTicking]. self world updateStatusForAllScriptEditors! Item was changed: ----- Method: PasteUpMorph>>triggerClosingScripts (in category 'world state') ----- triggerClosingScripts "If the receiver has any scripts set to run on closing, run them now" | aPlayer | + self allMorphsDo:[ :m| + (aPlayer := m player) ifNotNil: + [aPlayer runAllClosingScripts]]! - (aPlayer := self player) ifNotNil: - [aPlayer runAllClosingScripts]! Item was changed: ----- Method: PasteUpMorph>>triggerOpeningScripts (in category 'world state') ----- triggerOpeningScripts "If the receiver has any scripts set to run on opening, run them now" | aPlayer | + self allMorphsDo:[ :m| + (aPlayer := m player) ifNotNil: + [aPlayer runAllOpeningScripts]]! - (aPlayer := self player) ifNotNil: - [aPlayer runAllOpeningScripts]! Item was changed: ----- Method: PasteUpMorph>>wantsHaloFor: (in category 'halos and balloon help') ----- wantsHaloFor: aSubMorph "Answer whether the receiver wishes for a mouse-over halo to be produced for aSubMorph" ^ wantsMouseOverHalos == true and: [self visible and: [isPartsBin ~~ true and: [self dropEnabled and: + [aSubMorph renderedMorph isLikelyRecipientForMouseOverHalos]]]]! - [self isWorldMorph not or: [aSubMorph renderedMorph isLikelyRecipientForMouseOverHalos]]]]] - - "The odd logic at the end of the above says... - - * If we're an interior playfield, then if we're set up for mouseover halos, show em. - * If we're a World that's set up for mouseover halos, only show 'em if the putative - recipient is a SketchMorph. - - This (old) logic was put in to suit a particular need in early e-toy days and seems rather strange now!!"! Item was changed: ----- Method: PluggableTextMorph>>setTextColor: (in category 'model access') ----- setTextColor: aColor "Set the color of my text to the given color" + textMorph textColor: aColor! - textMorph color: aColor! Item was changed: ----- Method: PolygonMorph class>>descriptionForPartsBin (in category 'parts bin') ----- descriptionForPartsBin + ^ self partName: 'Polygon' translatedNoop + categories: {'Graphics' translatedNoop. 'Basic' translatedNoop} + documentation: 'A series of connected line segments, which may be a closed solid, or a zig-zag line. Shift-click to get handles and move the points.' translatedNoop! - ^ self partName: 'Polygon' - categories: #('Graphics' 'Basic') - documentation: 'A series of connected line segments, which may be a closed solid, or a zig-zag line. Shift-click to get handles and move the points.'! Item was changed: ----- Method: PolygonMorph>>addCustomMenuItems:hand: (in category 'menu') ----- + addCustomMenuItems: aMenu hand: aHandMorph + "Add morph-specific items to the given menu which was invoked by the given hand. This method provides is invoked both from the halo-menu and from the control-menu regimes." + - addCustomMenuItems: aMenu hand: aHandMorph - | | super addCustomMenuItems: aMenu hand: aHandMorph. + aMenu addUpdating: #handlesShowingPhrase target: self action: #showOrHideHandles. + vertices size > 2 ifTrue: + [aMenu addUpdating: #openOrClosePhrase target: self action: #makeOpenOrClosed]. + + aMenu addUpdating: #smoothPhrase target: self action: #toggleSmoothing. + aMenu addLine. + aMenu add: 'specify dashed line' translated action: #specifyDashedLine. + + self isOpen ifTrue: + [aMenu addLine. + aMenu addWithLabel: '---' enablement: [self isOpen and: [arrows ~~ #none]] action: #makeNoArrows. + aMenu addWithLabel: '-->' enablement: [self isOpen and: [arrows ~~ #forward]] action: #makeForwardArrow. + aMenu addWithLabel: '<--' enablement: [self isOpen and: [arrows ~~ #back]] action: #makeBackArrow. + aMenu addWithLabel: '<->' enablement: [self isOpen and: [arrows ~~ #both]] action: #makeBothArrows. + aMenu add: 'customize arrows' translated action: #customizeArrows:. + (self hasProperty: #arrowSpec) + ifTrue: [aMenu add: 'standard arrows' translated action: #standardArrows]].! - aMenu - addUpdating: #handlesShowingPhrase - target: self - action: #showOrHideHandles. - vertices size > 2 - ifTrue: [ self addPolyLIneCurveMenuItems: aMenu hand: aHandMorph ]. - aMenu add: 'specify dashed line' translated action: #specifyDashedLine. - "aMenu add: 'use debug border' translated action: #showSegmentsBorderStyle." - self isOpen - ifTrue: [self addPolyArrowMenuItems: aMenu hand: aHandMorph] - ifFalse: [self addPolyShapingMenuItems: aMenu hand: aHandMorph]! Item was changed: ----- Method: PolygonMorph>>defaultBorderColor (in category 'initialization') ----- defaultBorderColor "answer the default border color/fill style for the receiver" + + ^ Color black + + "Until September 2007, this had long been... ^ Color r: 0.0 g: 0.419 + b: 0.935"! - b: 0.935! Item was changed: ----- Method: PolygonMorph>>fillStyle (in category 'visual properties') ----- fillStyle + "Answer the receiver's fillStyle. For an *open* polygon, we return the borderColor, provided it's a true color rather than something strange like the symbol #raised." + | aColor | self isOpen + ifTrue: + [(aColor := self borderColor) isColor ifTrue: [^ aColor]]. "easy access to line color from halo -- di's old note" + + ^ super fillStyle! - ifTrue: [^ self borderColor "easy access to line color from halo"] - ifFalse: [^ super fillStyle]! Item was changed: ----- Method: PolygonMorph>>handlesShowingPhrase (in category 'menu') ----- handlesShowingPhrase + "Answer a phrase characterizing whether handles are showing or not." + + ^ (self showingHandles ifTrue: ['<yes>'] ifFalse: ['<no>']), ('show handles' translated)! - ^ (self showingHandles - ifTrue: ['hide handles'] - ifFalse: ['show handles']) translated! Item was changed: ----- Method: PolygonMorph>>mouseDown: (in category 'event handling') ----- mouseDown: evt + "Handle a mouse-down event." + ^ (evt shiftPressed and: [(self hasProperty: #activateOnShift) not]) - ^ evt shiftPressed ifTrue: [((owner isKindOf: PolygonMorph) and: [owner includesHandle: self]) ifTrue: ["Prevent insertion handles from getting edited" ^ super mouseDown: evt]. self toggleHandles. handles ifNil: [^ self]. vertices withIndexDo: "Check for click-to-drag at handle site" [:vertPt :vertIndex | ((handles at: vertIndex*2-1 ifAbsent: [ ^self ]) containsPoint: evt cursorPoint) ifTrue: ["If clicked near a vertex, jump into drag-vertex action" evt hand newMouseFocus: (handles at: vertIndex*2-1)]]] ifFalse: [super mouseDown: evt]! Item was changed: ----- Method: PolygonMorph>>openOrClosePhrase (in category 'access') ----- openOrClosePhrase + "Answer a string indicating whether the receiver is open or closed." + + ^ (closed ifTrue: ['<yes>'] ifFalse: ['<no>']), 'closed' translated! - | curveName | - curveName := (self isCurve - ifTrue: ['curve'] - ifFalse: ['polygon']) translated. - ^ closed - ifTrue: ['make open {1}' translated format: {curveName}] - ifFalse: ['make closed {1}' translated format: {curveName}]! Item was changed: ----- Method: PolygonMorph>>stepTime (in category 'testing') ----- stepTime + "Answer the desired time between steps in milliseconds." + ^ self topRendererOrSelf player ifNotNil: [10] ifNil: [100] + + "NB: in all currently known cases, polygons are not actually wrapped in TransformationMorphs, so the #topRendererOrSelf call above is probably redundant, but is retained for safety."! - ^ 100! Item was changed: ----- Method: PolygonMorph>>verticesAt:put: (in category 'editing') ----- + verticesAt: anInteger put: aPoint + + self vertices at: anInteger put: aPoint asFloatPoint. - verticesAt: ix put: newPoint - vertices at: ix put: newPoint. self computeBounds! Item was changed: ----- Method: Presenter>>allCurrentlyTickingScriptInstantiations (in category 'stubs') ----- allCurrentlyTickingScriptInstantiations + "Answer a list of ScriptInstantiation objects representing all the scripts within the scope of the receiver which are currently ticking." + + ^ Array streamContents: + [:aStream | + self allExtantPlayers do: + [:aPlayer | aPlayer instantiatedUserScriptsDo: + [:aScriptInstantiation | + aScriptInstantiation status == #ticking ifTrue: + [aStream nextPut: aScriptInstantiation]]]]! - ^#()! Item was changed: ----- Method: Presenter>>browseAllScriptsTextually (in category 'stubs') ----- + browseAllScriptsTextually + "Open a method-list browser on all the scripts in the project" + + | aList aMethodList | + self flushPlayerListCache. "Just to be certain we get everything" + + (aList := self uniclassesAndCounts) size == 0 ifTrue: [^ self inform: 'there are no scripted players' translated]. + aMethodList := OrderedCollection new. + aList do: + [:aPair | aPair first addMethodReferencesTo: aMethodList]. + aMethodList size > 0 ifFalse: [^ self inform: 'there are no scripts in this project!!' translated]. + + SystemNavigation new + browseMessageList: aMethodList + name: 'All scripts in this project' + autoSelect: nil + + " + ActiveWorld presenter browseAllScriptsTextually + "! - browseAllScriptsTextually! Item was changed: ----- Method: ProjectViewMorph class>>defaultNameStemForInstances (in category 'scripting') ----- defaultNameStemForInstances + ^ 'ProjectView' translatedNoop! - ^ 'ProjectView'! Item was changed: ----- Method: ProjectViewMorph class>>serviceOpenProjectFromFile (in category 'project window creation') ----- serviceOpenProjectFromFile "Answer a service for opening a .pr project file" ^ (SimpleServiceEntry provider: self + label: 'load as project' translatedNoop - label: 'load as project' selector: #openFromDirectoryAndFileName: + description: 'open project from file' translatedNoop + buttonLabel: 'load' translatedNoop - description: 'open project from file' - buttonLabel: 'load' ) argumentGetter: [ :fileList | fileList dirAndFileName]! Item was changed: ----- Method: ProjectViewMorph>>acceptDroppingMorph:event: (in category 'layout') ----- acceptDroppingMorph: morphToDrop event: evt + "Accept -- in a custom sense here -- a morph dropped on the receiver." | myCopy smallR | (self isTheRealProjectPresent) ifFalse: [ ^morphToDrop rejectDropMorphEvent: evt. "can't handle it right now" ]. (morphToDrop isKindOf: NewHandleMorph) ifTrue: [ "don't send these" ^morphToDrop rejectDropMorphEvent: evt. ]. + self dropEnabled ifFalse: + [^ morphToDrop rejectDropMorphEvent: evt]. + self eToyRejectDropMorph: morphToDrop event: evt. "we will send a copy" myCopy := morphToDrop veryDeepCopy. "gradient fills require doing this second" smallR := (morphToDrop bounds scaleBy: image height / Display height) rounded. smallR := smallR squishedWithin: image boundingBox. image getCanvas paintImage: (morphToDrop imageForm scaledToSize: smallR extent) at: smallR topLeft. myCopy openInWorld: project world ! Item was changed: ----- Method: ProjectViewMorph>>editTheName: (in category 'as yet unclassified') ----- editTheName: evt self isTheRealProjectPresent ifFalse: [ + ^self inform: 'The project is not present and may not be renamed now' translated - ^self inform: 'The project is not present and may not be renamed now' ]. self addProjectNameMorph launchMiniEditor: evt.! Item was changed: ----- Method: ProjectViewMorph>>enter (in category 'events') ----- enter "Enter my project." self world == self outermostWorldMorph ifFalse: [^Beeper beep]. "can't do this at the moment" project class == DiskProxy ifFalse: [(project world notNil and: [project world isMorph and: [project world hasOwner: self outermostWorldMorph]]) ifTrue: [^Beeper beep "project is open in a window already"]]. project class == DiskProxy ifTrue: ["When target is not in yet" self enterWhenNotPresent. "will bring it in" + project class == DiskProxy ifTrue: [^self inform: 'Project not found' translated]]. - project class == DiskProxy ifTrue: [^self inform: 'Project not found']]. (owner isSystemWindow) ifTrue: [project setViewSize: self extent]. self showMouseState: 3. project enter: false revert: false saveForRevert: false! Item was changed: ----- Method: ProjectViewMorph>>expungeProject (in category 'as yet unclassified') ----- expungeProject (self confirm: ('Do you really want to delete {1} and all its content?' translated format: {project name})) ifFalse: [^ self]. owner isSystemWindow ifTrue: [owner model: nil; delete]. + project delete. + self delete.! - project delete.! Item was changed: ----- Method: ProjectViewMorph>>fontForName (in category 'drawing') ----- fontForName + ^(TextStyle default fontOfSize: 15) emphasized: 1 - | pickem | - pickem := 3. - - pickem = 1 ifTrue: [ - ^(((TextStyle named: #Helvetica) ifNil: [TextStyle default]) fontOfSize: 13) emphasized: 1. - ]. - pickem = 2 ifTrue: [ - ^(((TextStyle named: #Palatino) ifNil: [TextStyle default]) fontOfSize: 12) emphasized: 1. - ]. - ^((TextStyle default) fontAt: 1) emphasized: 1 ! Item was changed: ----- Method: ProjectViewMorph>>initialize (in category 'initialization') ----- initialize + "Initialize the receiver." + super initialize. "currentBorderColor := Color gray." + self addProjectNameMorphFiller. + self enableDragNDrop: true. + self isOpaque: true. + ! - self addProjectNameMorphFiller.! Item was changed: ----- Method: ProjectViewMorph>>wantsDroppedMorph:event: (in category 'dropping/grabbing') ----- wantsDroppedMorph: aMorph event: evt + "Answer if the receiver would accept a drop of a given morph." + "If drop-enabled not set, answer false" + (super wantsDroppedMorph: aMorph event: evt) ifFalse: [^ false]. + + "If project not present, not morphic, or not initialized, answer false" + self isTheRealProjectPresent ifFalse: [^ false]. + project isMorphic ifFalse: [^ false]. + project world viewBox ifNil: [^ false]. + + ^ true! - self isTheRealProjectPresent ifFalse: [^false]. - project isMorphic ifFalse: [^false]. - project world viewBox ifNil: [^false]. "uninitialized" - ^true! Item was changed: ----- Method: RectangleMorph class>>descriptionForPartsBin (in category 'parts bin') ----- descriptionForPartsBin + ^ self partName: 'Rectangle' translatedNoop + categories: {'Graphics' translatedNoop. 'Basic' translatedNoop} + documentation: 'A rectangular shape, with border and fill style' translatedNoop! - ^ self partName: 'Rectangle' - categories: #('Graphics' 'Basic') - documentation: 'A rectangular shape, with border and fill style'! Item was changed: ----- Method: RectangleMorph class>>roundRectPrototype (in category 'as yet unclassified') ----- roundRectPrototype + "Answer a prototypical RoundRect object for a parts bin." + ^ self authoringPrototype useRoundedCorners + color: (Color r: 1.0 g: 0.3 b: 0.6); - color: ((Color r: 1.0 g: 0.3 b: 0.6) alpha: 0.5); borderWidth: 1; setNameTo: 'RoundRect'! Item was changed: ----- Method: SelectionMorph class>>defaultNameStemForInstances (in category 'scripting') ----- defaultNameStemForInstances + ^ 'Selection' translatedNoop! - ^ 'Selection'! Item was changed: ----- Method: SelectionMorph>>addCustomMenuItems:hand: (in category 'halo commands') ----- addCustomMenuItems: aMenu hand: aHandMorph "Add custom menu items to the menu" super addCustomMenuItems: aMenu hand: aHandMorph. - aMenu addLine. - aMenu add: 'add or remove items' translated target: self selector: #addOrRemoveItems: argument: aHandMorph. aMenu addList: { #-. {'place into a row' translated. #organizeIntoRow}. {'place into a column' translated. #organizeIntoColumn}. #-. {'align left edges' translated. #alignLeftEdges}. {'align top edges' translated. #alignTopEdges}. {'align right edges' translated. #alignRightEdges}. {'align bottom edges' translated. #alignBottomEdges}. #-. {'align centers vertically' translated. #alignCentersVertically}. {'align centers horizontally' translated. #alignCentersHorizontally}. + #-. + {'distribute vertically' translated. #distributeVertically}. + {'distribute horizontally' translated. #distributeHorizontally}. + } - }. + - self selectedItems size > 2 - ifTrue:[ - aMenu addList: { - #-. - {'distribute vertically' translated. #distributeVertically}. - {'distribute horizontally' translated. #distributeHorizontally}. - }. - ]. ! Item was changed: ----- Method: SelectionMorph>>defaultBorderColor (in category 'initialization') ----- defaultBorderColor "answer the default border color/fill style for the receiver" + ^ self userInterfaceTheme borderColor ifNil: [Color blue twiceDarker alpha: 0.75]! - ^ ( MenuMorph menuSelectionColor ifNil: [Color blue]) twiceDarker alpha: 0.75! Item was changed: ----- Method: SelectionMorph>>defaultColor (in category 'initialization') ----- defaultColor "answer the default color/fill style for the receiver" + ^ self userInterfaceTheme color ifNil: [Color blue alpha: 0.08] - ^ (MenuMorph menuSelectionColor ifNil: [Color blue]) alpha: 0.08 ! Item was changed: ----- Method: SelectionMorph>>dismissViaHalo (in category 'submorphs-add/remove') ----- dismissViaHalo + selectedItems do: [:m | m dismissViaHalo]. - super dismissViaHalo. + ! - selectedItems do: [:m | m dismissViaHalo]! Item was changed: ----- Method: SelectionMorph>>extent: (in category 'geometry') ----- extent: newExtent + "Set the receiver's extent Extend or contract the receiver's selection to encompass morphs within the new extent." super extent: newExtent. + self selectSubmorphsOf: (self pasteUpMorph ifNil: [^ self])! - self selectSubmorphsOf: self pasteUpMorph! Item was changed: ----- Method: SelectionMorph>>justDroppedInto:event: (in category 'dropping/grabbing') ----- justDroppedInto: newOwner event: evt + "This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph" selectedItems isEmpty ifTrue: ["Hand just clicked down to draw out a new selection" ^ self extendByHand: evt hand]. dupLoc ifNotNil: [dupDelta := self position - dupLoc]. selectedItems reverseDo: [:m | WorldState addDeferredUIMessage: [m referencePosition: (newOwner localPointToGlobal: m referencePosition). newOwner handleDropMorph: + (DropEvent new setPosition: evt cursorPoint contents: m hand: evt hand)] fixTemps]. + selectedItems := nil. + self removeHalo. + self halo ifNotNil: [self halo visible: false]. + self delete. - (DropEvent new setPosition: evt cursorPoint contents: m hand: evt hand)]]. evt wasHandled: true! Item was changed: ----- Method: SelectionMorph>>selectSubmorphsOf: (in category 'private') ----- selectSubmorphsOf: aMorph + "Given the receiver's current bounds, select submorphs of the indicated pasteup morph that fall entirely within those bounds. If nobody is within the bounds, delete the receiver." | newItems removals | newItems := aMorph submorphs select: [:m | (bounds containsRect: m fullBounds) and: [m~~self and: [(m isKindOf: HaloMorph) not]]]. otherSelection ifNil: [^ selectedItems := newItems]. removals := newItems intersection: itemsAlreadySelected. otherSelection setSelectedItems: (itemsAlreadySelected copyWithoutAll: removals). selectedItems := (newItems copyWithoutAll: removals). + selectedItems ifEmpty: [self delete] ! Item was changed: ----- Method: SelectionMorph>>slideToTrash: (in category 'dropping/grabbing') ----- slideToTrash: evt self delete. + "selectedItems do: [:m | m slideToTrash: evt]"! - selectedItems do: [:m | m slideToTrash: evt]! Item was changed: ----- Method: Set>>hasContentsInExplorer (in category '*Morphic-Explorer') ----- hasContentsInExplorer + ^self notEmpty! - ^self isEmpty not! Item was changed: ----- Method: SimpleBorder>>initialize (in category 'initialize-release') ----- initialize width := 0. + + color := Color transparent! - baseColor := color := Color transparent! Item was changed: ----- Method: SimpleButtonMorph class>>defaultNameStemForInstances (in category 'printing') ----- defaultNameStemForInstances ^ self = SimpleButtonMorph + ifTrue: ['Button' translatedNoop] - ifTrue: ['Button'] ifFalse: [^ super defaultNameStemForInstances]! Item was changed: ----- Method: SimpleButtonMorph>>addCustomMenuItems:hand: (in category 'menu') ----- addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. self addLabelItemsTo: aCustomMenu hand: aHandMorph. (target isKindOf: BookMorph) ifTrue: [aCustomMenu add: 'set page sound' translated action: #setPageSound:. aCustomMenu add: 'set page visual' translated action: #setPageVisual:] ifFalse: + [ + aCustomMenu add: 'change action selector' translated action: #setActionSelector. - [aCustomMenu add: 'change action selector' translated action: #setActionSelector. aCustomMenu add: 'change arguments' translated action: #setArguments. aCustomMenu add: 'change when to act' translated action: #setActWhen. + aCustomMenu add: 'set target' translated action: #sightTargets:. + target ifNotNil: [aCustomMenu add: 'clear target' translated action: #clearTarget]]. - self addTargetingMenuItems: aCustomMenu hand: aHandMorph .]. ! Item was changed: ----- Method: SimpleButtonMorph>>doButtonAction (in category 'button') ----- doButtonAction "Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments." (target notNil and: [actionSelector notNil]) ifTrue: + [target perform: actionSelector withArguments: arguments]. - [Cursor normal - showWhile: [target perform: actionSelector withArguments: arguments]]. actWhen == #startDrag ifTrue: [oldColor ifNotNil: [self color: oldColor]]! Item was changed: ----- Method: SimpleButtonMorph>>objectForDataStream: (in category 'objects from disk') ----- objectForDataStream: refStrm - "I am about to be written on an object file. If I send a message to a BookMorph, it would be bad to write that object out. Create and write out a URLMorph instead." + ^ super objectForDataStream: refStrm + + + "I am about to be written on an object file. If I send a message to a BookMorph, it would be bad to write that object out. Create and write out a URLMorph instead. + Feb 2007: It seems unlikely that Squeak Pages will be used in the OLPC image. Don't use this code. Consider removing all code that supports SqueakPages." + " | bb thatPage um stem ind sqPg | (actionSelector == #goToPageMorph:fromBookmark:) | (actionSelector == #goToPageMorph:) ifFalse: [ + ^ super objectForDataStream: refStrm]. 'normal case'. - ^ super objectForDataStream: refStrm]. "normal case" + target url ifNil: ['Later force target book to get a url.'. + bb := SimpleButtonMorph new. 'write out a dummy'. - target url ifNil: ["Later force target book to get a url." - bb := SimpleButtonMorph new. "write out a dummy" bb label: self label. bb bounds: bounds. refStrm replace: self with: bb. ^ bb]. (thatPage := arguments first) url ifNil: [ + 'Need to assign a url to a page that will be written later. - "Need to assign a url to a page that will be written later. It might have bookmarks too. Don't want to recurse deeply. + Have that page write out a dummy morph to save its url on the server.'. + stem := target getStemUrl. 'know it has one'. - Have that page write out a dummy morph to save its url on the server." - stem := target getStemUrl. "know it has one" ind := target pages identityIndexOf: thatPage. thatPage reserveUrl: stem,(ind printString),'.sp']. um := URLMorph newForURL: thatPage url. sqPg := thatPage sqkPage clone. sqPg contentsMorph: nil. um setURL: thatPage url page: sqPg. (SqueakPage stemUrl: target url) = (SqueakPage stemUrl: thatPage url) ifTrue: [um book: true] + ifFalse: [um book: target url]. 'remember which book'. - ifFalse: [um book: target url]. "remember which book" um privateOwner: owner. um bounds: bounds. um isBookmark: true; label: self label. um borderWidth: borderWidth; borderColor: borderColor. um color: color. refStrm replace: self with: um. + ^ um + "! - ^ um! Item was changed: ----- Method: SimpleHaloMorph>>drawOn: (in category 'drawing') ----- drawOn: aCanvas "Draw this morph only if it has no target." (Preferences showBoundsInHalo and: [self target isWorldMorph not]) ifTrue: [ - | boundsColor | - boundsColor := MenuMorph menuSelectionColor - ifNil: [Color blue]. aCanvas frameAndFillRectangle: self bounds fillColor: Color transparent borderWidth: 2 + borderColor: (self userInterfaceTheme borderColor ifNil: [Color blue alpha: 0.8])]! - borderColor: - (boundsColor isTranslucent - ifTrue: [boundsColor] - ifFalse: [boundsColor alpha: 0.8])]! Item was changed: ----- Method: SimpleHierarchicalListMorph>>initialize (in category 'initialization') ----- initialize "initialize the state of the receiver" super initialize. + self setProperty: #autoExpand toValue: false. self on: #mouseMove send: #mouseStillDown:onItem: to: self! Item was changed: ----- Method: SketchMorph class>>defaultNameStemForInstances (in category 'scripting') ----- defaultNameStemForInstances + ^ 'Sketch' translatedNoop! - ^ 'Sketch'! Item was changed: ----- Method: SketchMorph>>collapse (in category 'menus') ----- collapse + "Replace the receiver with a collapsed rendition of itself." - - | priorPosition w collapsedVersion a | + | w collapsedVersion a ht tab | + (w := self world) ifNil: [^self]. collapsedVersion := (self imageForm scaledToSize: 50@50) asMorph. collapsedVersion setProperty: #uncollapsedMorph toValue: self. collapsedVersion on: #mouseUp send: #uncollapseSketch to: collapsedVersion. + + collapsedVersion setBalloonText: ('A collapsed version of {1}. Click to open it back up.' translated format: {self externalName}). + - collapsedVersion setBalloonText: 'A collapsed version of ',self name. - self delete. w addMorphFront: ( a := AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; borderWidth: 4; borderColor: Color white; + addMorph: collapsedVersion; + yourself). + a setNameTo: self externalName. + ht := (tab := Smalltalk at: #SugarNavTab ifPresent: [:c | ActiveWorld findA: c]) + ifNotNil: + [tab height] + ifNil: + [80]. + a position: 0@ht. + - addMorph: collapsedVersion - ). collapsedVersion setProperty: #collapsedMorphCarrier toValue: a. + (self valueOfProperty: #collapsedPosition) ifNotNilDo: + [:priorPosition | + a position: priorPosition]! - (priorPosition := self valueOfProperty: #collapsedPosition ifAbsent: [nil]) - ifNotNil: - [a position: priorPosition]. - ! Item was changed: ----- Method: SketchMorph>>flipHorizontal (in category 'e-toy support') ----- flipHorizontal + | r | + r := self rotationCenter. + self left: self left - (1.0 - (2 * r x) * self width). + self form: (self form flipBy: #horizontal centerAt: self form center). + self rotationCenter: (1 - r x) @ (r y).! - self form: (self form flipBy: #horizontal centerAt: self form center)! Item was changed: ----- Method: SketchMorph>>flipVertical (in category 'e-toy support') ----- flipVertical + | r | + r := self rotationCenter. + self top: self top - (1.0 - (2 * r y) * self height). + self form: (self form flipBy: #vertical centerAt: self form center). + self rotationCenter: r x @ (1 - r y).! - self form: (self form flipBy: #vertical centerAt: self form center)! Item was changed: ----- Method: SketchMorph>>initializeWith: (in category 'initialization') ----- initializeWith: aForm super initialize. originalForm := aForm. - self rotationCenter: 0.5(a)0.5. "relative to the top-left corner of the Form" rotationStyle := #normal. "styles: #normal, #leftRight, #upDown, or #none" scalePoint := 1.0(a)1.0. framesToDwell := 1. rotatedForm := originalForm. "cached rotation of originalForm" self extent: originalForm extent. ! Item was changed: ----- Method: SketchMorph>>rotationStyle: (in category 'e-toy support') ----- rotationStyle: aSymbol "Set my rotation style to #normal, #leftRight, #upDown, or #none. Styles mean: #normal -- continuous 360 degree rotation #leftRight -- quantize angle to left or right facing #upDown -- quantize angle to up or down facing + #none -- do not rotate + Because my rendering code flips the form (see generateRotatedForm) we 'pre-flip' it here to preserve the same visual appearance. + " - #none -- do not rotate" + | wasFlippedX wasFlippedY isFlippedX isFlippedY | + wasFlippedX := rotationStyle == #leftRight + and: [ self heading asSmallAngleDegrees < 0.0 ]. + wasFlippedY := rotationStyle == #upDown + and: [ self heading asSmallAngleDegrees abs > 90.0 ]. + rotationStyle := aSymbol. + + isFlippedX := rotationStyle == #leftRight + and: [ self heading asSmallAngleDegrees < 0.0 ]. + isFlippedY := rotationStyle == #upDown + and: [ self heading asSmallAngleDegrees abs > 90.0 ]. + + wasFlippedX == isFlippedX + ifFalse: [self form: (self form flipBy: #horizontal centerAt: self form center)]. + wasFlippedY == isFlippedY + ifFalse: [self form: (self form flipBy: #vertical centerAt: self form center)]. + self layoutChanged. ! Item was changed: ----- Method: StandardScriptingSystem>>formAtKey: (in category 'form dictionary') ----- formAtKey: aString "Answer the form saved under the given key" Symbol hasInterned: aString ifTrue: + [:aKey | ^ FormDictionary at: aKey ifAbsent: [FormDictionary at: #Cat]]. + ^ FormDictionary at: #Cat! - [:aKey | ^ FormDictionary at: aKey ifAbsent: [nil]]. - ^ nil! Item was changed: ----- Method: StringMorph>>addOptionalHandlesTo:box: (in category 'halos and balloon help') ----- addOptionalHandlesTo: aHalo box: box + "eventually, add more handles for font..." + self flag: #deferred. + ^ super addOptionalHandlesTo: aHalo box: box "Eventually... self addFontHandlesTo: aHalo box: box"! Item was changed: ----- Method: StringMorph>>font: (in category 'printing') ----- font: aFont "Set the font my text will use. The emphasis remains unchanged." + aFont = font ifTrue: [^ self]. + ^ self font: aFont emphasis: emphasis! - font := aFont. - ^ self font: font emphasis: emphasis! Item was changed: ----- Method: StringMorphEditor>>initialize (in category 'display') ----- initialize "Initialize the receiver. Give it a white background" super initialize. self backgroundColor: Color white. + self textColor: Color red.! - self color: Color red! Item was changed: ----- Method: TTSampleStringMorph class>>descriptionForPartsBin (in category 'parts bin') ----- descriptionForPartsBin + ^ self partName: 'TrueType banner' translatedNoop + categories: #() + documentation: 'A short text in a beautiful font. Use the resize handle to change size.' translatedNoop! - ^ self partName: 'TrueType banner' - categories: #('Demo') - documentation: 'A short text in a beautiful font. Use the resize handle to change size.'! Item was changed: ----- Method: TextFieldMorph class>>registerInFlapsRegistry (in category 'class initialization') ----- registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps + ifPresent: [:cl | cl registerQuad: {#TextFieldMorph. #exampleBackgroundField. 'Scrolling Field' translatedNoop. 'A scrolling data field which will have a different value on every card of the background' translatedNoop} - ifPresent: [:cl | cl registerQuad: #(TextFieldMorph exampleBackgroundField 'Scrolling Field' 'A scrolling data field which will have a different value on every card of the background') forFlapNamed: 'Scripting'.]! Item was changed: ----- Method: TextMorph class>>borderedPrototype (in category 'parts bin') ----- borderedPrototype | t | t := self authoringPrototype. t fontName: 'BitstreamVeraSans' pointSize: 24. t autoFit: false; extent: 250@100. + t borderWidth: 1; margins: 4@0; backgroundColor: Color white. - t borderWidth: 1; margins: 4@0. "Strangeness here in order to avoid two offset copies of the default contents when operating in an mvc project before cursor enters the morphic window" t paragraph. ^ t! Item was changed: ----- Method: TextMorph class>>defaultNameStemForInstances (in category 'scripting') ----- defaultNameStemForInstances + ^ 'Text' translatedNoop! - ^ 'Text'! Item was changed: ----- Method: TextMorph class>>fancyPrototype (in category 'parts bin') ----- fancyPrototype | t | t := self authoringPrototype. t autoFit: false; extent: 150@75. t borderWidth: 2; margins: 4@0; useRoundedCorners. "Why not rounded?" "fancy font, shadow, rounded" + t fontName: Preferences standardEToysFont familyName size: 18; textColor: Color blue; fillStyle: Color lightBrown. - t fontName: Preferences standardEToysFont familyName size: 18; textColor: Color blue; backgroundColor: Color lightBrown. t addDropShadow. "Strangeness here in order to avoid two offset copies of the default contents when operating in an mvc project before cursor enters the morphic window" t paragraph. ^ t! Item was changed: ----- Method: TextMorph class>>registerInFlapsRegistry (in category 'class initialization') ----- registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps + ifPresent: [:cl | cl registerQuad: {#TextMorph. #authoringPrototype. 'Text' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop} - ifPresent: [:cl | cl registerQuad: #(TextMorph authoringPrototype 'Text' 'Text that you can edit into anything you desire.') forFlapNamed: 'PlugIn Supplies'. + cl registerQuad: {#TextMorph . #exampleBackgroundLabel. 'Background Label' translatedNoop. 'A piece of text that will occur on every card of the background' translatedNoop} - cl registerQuad: #(TextMorph exampleBackgroundLabel 'Background Label' 'A piece of text that will occur on every card of the background') forFlapNamed: 'Scripting'. + cl registerQuad: {#TextMorph . #exampleBackgroundField. 'Background Field' translatedNoop. 'A data field which will have a different value on every card of the background' translatedNoop} - cl registerQuad: #(TextMorph exampleBackgroundField 'Background Field' 'A data field which will have a different value on every card of the background') forFlapNamed: 'Scripting'. + cl registerQuad: {#TextMorph . #authoringPrototype. 'Simple Text' translatedNoop. 'Text that you can edit into anything you wish' translatedNoop} - cl registerQuad: #(TextMorph authoringPrototype 'Simple Text' 'Text that you can edit into anything you wish') forFlapNamed: 'Stack Tools'. + cl registerQuad: {#TextMorph . #fancyPrototype. 'Fancy Text' translatedNoop. 'A text field with a rounded shadowed border, with a fancy font.' translatedNoop} - cl registerQuad: #(TextMorph fancyPrototype 'Fancy Text' 'A text field with a rounded shadowed border, with a fancy font.') forFlapNamed: 'Stack Tools'. + cl registerQuad: {#TextMorph . #authoringPrototype. 'Text' translatedNoop. 'Text that you can edit into anything you desire.' translatedNoop} - cl registerQuad: #(TextMorph authoringPrototype 'Text' 'Text that you can edit into anything you desire.') forFlapNamed: 'Supplies'.]! Item was changed: ----- Method: TextMorph>>areasRemainingToFill: (in category 'drawing') ----- areasRemainingToFill: aRectangle "Overridden from BorderedMorph to test backgroundColor instead of (text) color." + (self backgroundColor isNil or: [self backgroundColor asColor isTranslucent]) - (backgroundColor isNil or: [backgroundColor isTranslucent]) ifTrue: [^ Array with: aRectangle]. self wantsRoundedCorners ifTrue: [(borderWidth > 0 and: [borderColor isColor and: [borderColor isTranslucent]]) ifTrue: [^ aRectangle areasOutside: (self innerBounds intersect: self boundsWithinCorners)] ifFalse: [^ aRectangle areasOutside: self boundsWithinCorners]] ifFalse: [(borderWidth > 0 and: [borderColor isColor and: [borderColor isTranslucent]]) ifTrue: [^ aRectangle areasOutside: self innerBounds] ifFalse: [^ aRectangle areasOutside: self bounds]]! Item was changed: ----- Method: TextMorph>>backgroundColor (in category 'accessing') ----- backgroundColor + ^ self fillStyle. + ! - ^ backgroundColor! Item was changed: ----- Method: TextMorph>>backgroundColor: (in category 'accessing') ----- backgroundColor: newColor + self fillStyle: newColor. + ! - backgroundColor := newColor. - self changed! Item was changed: ----- Method: TextMorph>>beAllFont: (in category 'initialization') ----- beAllFont: aFont textStyle := TextStyle fontArray: (Array with: aFont). + text ifNotNil: [text addAttribute: (TextFontReference toFont: aFont)]. self releaseCachedState; changed! Item was changed: ----- Method: TextMorph>>fit (in category 'private') ----- fit "Adjust my bounds to fit the text. Should be a no-op if autoFit is not specified. Required after the text changes, or if wrapFlag is true and the user attempts to change the extent." + | newExtent para cBounds lastOfLines heightOfLast wid | - | newExtent para cBounds lastOfLines heightOfLast | self isAutoFit ifTrue: + [wid := (text notNil and: [text size > 2]) ifTrue: [5] ifFalse: [40]. + newExtent := (self paragraph extent max: wid @ ( self defaultLineHeight)) + (0 @ 2). - [newExtent := (self paragraph extent max: 9 @ textStyle lineGrid) + (0 @ 2). newExtent := newExtent + (2 * borderWidth). margins ifNotNil: [newExtent := ((0 @ 0 extent: newExtent) expandBy: margins) extent]. newExtent ~= bounds extent ifTrue: [(container isNil and: [successor isNil]) ifTrue: [para := paragraph. "Save para (layoutChanged smashes it)" super extent: newExtent. paragraph := para]]. container notNil & successor isNil ifTrue: [cBounds := container bounds truncated. "23 sept 2000 - try to allow vertical growth" lastOfLines := self paragraph lines last. heightOfLast := lastOfLines bottom - lastOfLines top. (lastOfLines last < text size and: [lastOfLines bottom + heightOfLast >= self bottom]) ifTrue: [container releaseCachedState. cBounds := cBounds origin corner: cBounds corner + (0 @ heightOfLast)]. self privateBounds: cBounds]]. "These statements should be pushed back into senders" self paragraph positionWhenComposed: self position. successor ifNotNil: [successor predecessorChanged]. self changed "Too conservative: only paragraph composition should cause invalidation."! Item was changed: ----- Method: TextMorph>>insertCharacters: (in category 'scripting access') ----- + insertCharacters: aString - insertCharacters: aSource "Insert the characters from the given source at my current cursor position" + | aLoc aText attributes | - | aLoc | aLoc := self cursor max: 1. + aText := aLoc > text size + ifTrue: [aString asText] + ifFalse: [ + attributes := (text attributesAt: aLoc) + select: [:attr | attr mayBeExtended]. + Text string: aString attributes: attributes]. + paragraph replaceFrom: aLoc to: (aLoc - 1) with: aText displaying: true. - paragraph replaceFrom: aLoc to: (aLoc - 1) with: aSource asText displaying: true. self updateFromParagraph ! Item was changed: ----- Method: TextMorph>>setAllButFirstCharacter: (in category 'scripting access') ----- setAllButFirstCharacter: source "Set all but the first char of the receiver to the source" + | chars | - | aChar chars | - aChar := source asCharacter. (chars := self getCharacters) isEmpty ifTrue: [self newContents: '·' , source asString] + ifFalse: [self newContents: (String - ifFalse: [chars first = aChar - ifFalse: ["" - self - newContents: (String streamContents: [:aStream | aStream nextPut: chars first. + aStream nextPutAll: source])]! - aStream nextPutAll: source])]] ! Item was changed: ----- Method: TheWorldMainDockingBar>>colorIcon: (in category 'private') ----- colorIcon: aColor "Guess if 'uniform window colors' are used and avoid all icons to be just gray" (aColor = (UserInterfaceTheme current get: #uniformWindowColor for: Model) or: [Preferences tinyDisplay]) ifTrue: [ ^nil ]. ^(aColor iconOrThumbnailOfSize: 14) + borderWidth: 3 color: ((UserInterfaceTheme current get: #color for: #MenuMorph) ifNil: [(Color r: 0.9 g: 0.9 b: 0.9)]) muchDarker; - borderWidth: 3 color: MenuMorph menuColor muchDarker; borderWidth: 2 color: Color transparent! Item was removed: - ----- Method: TheWorldMainDockingBar>>gradientRamp (in category 'private') ----- - gradientRamp - - ^{ - 0.0 -> Color white. - 1.0 -> MenuMorph menuColor darker }! Item was changed: ----- Method: TheWorldMainDockingBar>>listWindowsOn: (in category 'submenu - windows') ----- listWindowsOn: menu | windows | + windows := self allVisibleWindows sorted: [:winA :winB | - windows := SortedCollection sortBlock: [:winA :winB | ((winA model isNil or: [winB model isNil]) or: [winA model name = winB model name]) ifTrue: [winA label < winB label] ifFalse: [winA model name < winB model name]]. - windows addAll: self allVisibleWindows. windows ifEmpty: [ menu addItem: [ :item | item contents: 'No Windows' translated; isEnabled: false ] ]. windows do: [ :each | menu addItem: [ :item | item contents: (self windowMenuItemLabelFor: each); icon: (each model ifNotNil: [self colorIcon: each model windowColorToUse]); target: each; selector: #comeToFront; subMenuUpdater: self selector: #windowMenuFor:on: arguments: { each }; action: [ each beKeyWindow; expand ] ] ]. menu addLine; add: 'Close all windows' target: self selector: #closeAllWindowsUnsafe; addItem: [:item | item contents: 'Close all windows without changes'; target: self; icon: MenuIcons smallBroomIcon; selector: #closeAllWindows]; add: 'Close all windows but workspaces' target: self selector: #closeAllWindowsButWorkspaces.! Item was changed: ----- Method: TheWorldMenu>>remoteMenu (in category 'construction') ----- remoteMenu "Build the Telemorphic menu for the world." + ^self fillIn: (self menu: 'Telemorphic' translatedNoop) from: { + { 'local host address' translatedNoop. { #myWorld . #reportLocalAddress } }. + { 'connect remote user' translatedNoop. { #myWorld . #connectRemoteUser } }. + { 'disconnect remote user' translatedNoop. { #myWorld . #disconnectRemoteUser } }. + { 'disconnect all remote users' translatedNoop. { #myWorld . #disconnectAllRemoteUsers } }. - ^self fillIn: (self menu: 'Telemorphic') from: { - { 'local host address' . { #myWorld . #reportLocalAddress } }. - { 'connect remote user' . { #myWorld . #connectRemoteUser } }. - { 'disconnect remote user' . { #myWorld . #disconnectRemoteUser } }. - { 'disconnect all remote users' . { #myWorld . #disconnectAllRemoteUsers } }. }! Item was changed: ----- Method: TheWorldMenu>>windowsMenu (in category 'windows & flaps menu') ----- windowsMenu "Build the windows menu for the world." + ^ self fillIn: (self menu: 'windows' translatedNoop) from: { + { 'find window' translatedNoop. { #myWorld . #findWindow: }. 'Presents a list of all windows; if you choose one from the list, it becomes the active window.' translatedNoop}. - ^ self fillIn: (self menu: 'windows') from: { - { 'find window' . { #myWorld . #findWindow: }. 'Presents a list of all windows; if you choose one from the list, it becomes the active window.'}. + { 'find changed browsers...' translatedNoop. { #myWorld . #findDirtyBrowsers: }. 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}. - { 'find changed browsers...' . { #myWorld . #findDirtyBrowsers: }. 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.'}. + { 'find changed windows...' translatedNoop. { #myWorld . #findDirtyWindows: }. 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.' translatedNoop}. - { 'find changed windows...' . { #myWorld . #findDirtyWindows: }. 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.'}. nil. + { 'find a transcript (t)' translatedNoop. { #myWorld . #findATranscript: }. 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window' translatedNoop}. - { 'find a transcript (t)' . { #myWorld . #findATranscript: }. 'Brings an open Transcript to the front, creating one if necessary, and makes it the active window'}. + { 'find a fileList (L)' translatedNoop. { #myWorld . #findAFileList: }. 'Brings an open fileList to the front, creating one if necessary, and makes it the active window' translatedNoop}. - { 'find a fileList (L)' . { #myWorld . #findAFileList: }. 'Brings an open fileList to the front, creating one if necessary, and makes it the active window'}. + { 'find a change sorter (C)' translatedNoop. { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window' translatedNoop}. - { 'find a change sorter (C)' . { #myWorld . #findAChangeSorter: }. 'Brings an open change sorter to the front, creating one if necessary, and makes it the active window'}. + { 'find message names (W)' translatedNoop. { #myWorld . #findAMessageNamesWindow: }. 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window' translatedNoop}. - { 'find message names (W)' . { #myWorld . #findAMessageNamesWindow: }. 'Brings an open MessageNames window to the front, creating one if necessary, and makes it the active window'}. nil. { #staggerPolicyString . { self . #toggleWindowPolicy }. 'stagger: new windows positioned so you can see a portion of each one. + tile: new windows positioned so that they do not overlap others, if possible.' translatedNoop}. - tile: new windows positioned so that they do not overlap others, if possible.'}. nil. + { 'collapse all windows' translatedNoop. { #myWorld . #collapseAll }. 'Reduce all open windows to collapsed forms that only show titles.' translatedNoop}. + { 'expand all' translatedNoop. { #myWorld . #expandAll }. 'Expand all collapsed windows and other collapsed objects back to their expanded forms.' translatedNoop}. + + { 'close top window (w)' translatedNoop. { SystemWindow . #closeTopWindow }. 'Close the topmost window if possible.' translatedNoop}. + { 'send top window to back (\)' translatedNoop. { SystemWindow . #sendTopWindowToBack }. 'Make the topmost window become the backmost one, and activate the window just beneath it.' translatedNoop}. + { 'move windows onscreen' translatedNoop. { #myWorld . #bringWindowsFullOnscreen }. 'Make all windows fully visible on the screen' translatedNoop}. - { 'collapse all windows' . { #myWorld . #collapseAll }. 'Reduce all open windows to collapsed forms that only show titles.'}. - { 'expand all windows' . { #myWorld . #expandAll }. 'Expand all collapsed windows back to their expanded forms.'}. - { 'close top window (w)' . { SystemWindow . #closeTopWindow }. 'Close the topmost window if possible.'}. - { 'send top window to back (\)' . { SystemWindow . #sendTopWindowToBack }. 'Make the topmost window become the backmost one, and activate the window just beneath it.'}. - { 'move windows onscreen' . { #myWorld . #bringWindowsFullOnscreen }. 'Make all windows fully visible on the screen'}. nil. + { 'delete unchanged windows' translatedNoop. { #myWorld . #closeUnchangedWindows }. 'Deletes all windows that do not have unsaved text edits.' translatedNoop}. + { 'delete non-windows' translatedNoop. { #myWorld . #deleteNonWindows }. 'Deletes all non-window morphs lying on the world.' translatedNoop}. + { 'delete both of the above' translatedNoop. { self . #cleanUpWorld }. 'deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.' translatedNoop}. - { 'delete unchanged windows' . { #myWorld . #closeUnchangedWindows }. 'Deletes all windows that do not have unsaved text edits.'}. - { 'delete non-windows' . { #myWorld . #deleteNonWindows }. 'Deletes all non-window morphs lying on the world.'}. - { 'delete both of the above' . { self . #cleanUpWorld }. 'deletes all unchanged windows and also all non-window morphs lying on the world, other than flaps.'}. }! Item was changed: ----- Method: ThreePhaseButtonMorph>>doButtonAction (in category 'button') ----- doButtonAction "Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments." + | args | (target notNil and: [actionSelector notNil]) ifTrue: + [args := actionSelector numArgs > arguments size + ifTrue: + [arguments copyWith: ActiveEvent] + ifFalse: + [arguments]. + Cursor normal + showWhile: [target perform: actionSelector withArguments: args]. - [Cursor normal - showWhile: [target perform: actionSelector withArguments: arguments]. target isMorph ifTrue: [target changed]]! Item was changed: ----- Method: ThreePhaseButtonMorph>>mouseDown: (in category 'event handling') ----- mouseDown: evt | now dt | - self state: #pressed. actWhen == #buttonDown + ifTrue: [self doButtonAction]. + actWhen == #buttonUp + ifTrue: [self state: #pressed]. + actWhen == #whilePressed + ifTrue: + [self state: #pressed. + now := Time millisecondClockValue. - ifTrue: - [self doButtonAction] - ifFalse: - [now := Time millisecondClockValue. - super mouseDown: evt. "Allow on:send:to: to set the response to events other than actWhen" dt := Time millisecondClockValue - now max: 0. "Time it took to do" + "NOTE: this delay is temporary disabled because it makes event reaction delay, + e.g. the action is not stopped even if you release the button... - Takashi" + [dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]]. + self mouseStillDown: evt]. + super mouseDown: evt! - dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]]. - self mouseStillDown: evt.! Item was changed: ----- Method: ThreePhaseButtonMorph>>mouseMove: (in category 'event handling') ----- + mouseMove: evt + (#(#buttonUp #whilePressed ) includes: actWhen) + ifTrue: [(self containsPoint: evt cursorPoint) + ifTrue: [self state: #pressed] + ifFalse: [self state: #off]]. + super mouseMove: evt! - mouseMove: evt - (self containsPoint: evt cursorPoint) - ifTrue: [self state: #pressed. - super mouseMove: evt] - "Allow on:send:to: to set the response to events other than actWhen" - ifFalse: [self state: #off]. - ! Item was changed: ----- Method: ThreePhaseButtonMorph>>mouseUp: (in category 'event handling') ----- + mouseUp: evt - mouseUp: evt "Allow on:send:to: to set the response to events other than actWhen" + actWhen == #buttonDown + ifTrue: [super mouseUp: evt]. + actWhen == #buttonUp + ifTrue: [(self containsPoint: evt cursorPoint) + ifTrue: [self state: #on. + self doButtonAction: evt. + super mouseUp: evt] + ifFalse: [self state: #off. + target + ifNotNil: ["Allow owner to keep it selected for radio + buttons" + target mouseUpBalk: evt]]]. + actWhen == #whilePressed + ifTrue: [self state: #off. + super mouseUp: evt]! - actWhen == #buttonUp ifFalse: [^super mouseUp: evt]. - - (self containsPoint: evt cursorPoint) ifTrue: [ - self state: #on. - self doButtonAction: evt - ] ifFalse: [ - self state: #off. - target ifNotNil: [target mouseUpBalk: evt] - ]. - "Allow owner to keep it selected for radio buttons" - ! Item was changed: ----- Method: TransformationMorph>>removeFlexShell (in category 'menu') ----- removeFlexShell "Remove the shell used to make a morph rotatable and scalable." | oldHalo unflexed pensDown myWorld refPos aPosition | + self isInWorld ifFalse: [^self]. refPos := self referencePosition. myWorld := self world. oldHalo := self halo. submorphs isEmpty ifTrue: [^ self delete]. aPosition := (owner submorphIndexOf: self) ifNil: [1]. unflexed := self firstSubmorph. pensDown := OrderedCollection new. self allMorphsDo: "Note any pens down -- must not be down during the move" [:m | | player | ((player := m player) notNil and: [player getPenDown]) ifTrue: [m == player costume ifTrue: [pensDown add: player. player setPenDown: false]]]. self submorphs do: [:m | m position: self center - (m extent // 2). owner addMorph: m asElementNumber: aPosition]. unflexed absorbStateFromRenderer: self. pensDown do: [:p | p setPenDown: true]. oldHalo ifNotNil: [oldHalo setTarget: unflexed]. myWorld ifNotNil: [myWorld startSteppingSubmorphsOf: unflexed]. self delete. unflexed referencePosition: refPos. ^ unflexed! Item was changed: ----- Method: UpdatingStringMorph>>fitContents (in category 'accessing') ----- fitContents + | newExtent | + newExtent := self measureContents. + newExtent := ((newExtent x max: self minimumWidth) min: self maximumWidth) @ newExtent y. - | newExtent f | - f := self fontToUse. - newExtent := (((f widthOfString: contents) max: self minimumWidth) min: self maximumWidth) @ f height. (self extent = newExtent) ifFalse: [self extent: newExtent. self changed] ! Item was changed: ----- Method: UpdatingStringMorph>>initialize (in category 'initialization') ----- initialize + "Initialize the receiver to have default values in its instance variables." - "Initialie the receiver to have default values in its instance - variables " super initialize. "" format := #default. "formats: #string, #default" target := getSelector := putSelector := nil. floatPrecision := 1. growable := true. + stepTime := nil. - stepTime := 50. autoAcceptOnFocusLoss := true. minimumWidth := 8. + maximumWidth := 366! - maximumWidth := 300! Item was changed: ----- Method: UpdatingStringMorph>>readFromTarget (in category 'target access') ----- readFromTarget "Update my readout from my target" + | v ret places | - | v ret | (target isNil or: [getSelector isNil]) ifTrue: [^contents]. ret := self checkTarget. ret ifFalse: [^ '0']. + ((target isMorph) or:[target isPlayerLike]) ifTrue:[ + places := target decimalPlacesForGetter: getSelector. + (places ~= nil and: [ places ~= (self valueOfProperty: #decimalPlaces ifAbsent: [0])]) ifTrue: [ self decimalPlaces: places ]]. v := target perform: getSelector. "scriptPerformer" (v isKindOf: Text) ifTrue: [v := v asString]. ^self acceptValueFromTarget: v! Item was changed: ----- Method: UpdatingStringMorph>>setPrecision (in category 'editing') ----- setPrecision "Allow the user to specify a number of decimal places. This UI is invoked from a menu. Nowadays the precision can be set by simple type-in, making this menu approach mostly obsolete. However, it's still useful for read-only readouts, where type-in is not allowed." | aMenu | aMenu := MenuMorph new. aMenu addTitle: ('How many decimal places? (currently {1})' translated format: {self decimalPlaces}). + 0 to: 10 do: - 0 to: 5 do: [:places | aMenu add: places asString target: self selector: #setDecimalPlaces: argument: places]. aMenu popUpInWorld! Item was changed: ----- Method: UpdatingStringMorph>>stepTime (in category 'testing') ----- stepTime + ^ stepTime ifNil: [200] - ^ stepTime ifNil: [50] ! Item was changed: ----- Method: UpdatingStringMorph>>veryDeepInner: (in category 'copying') ----- veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared." super veryDeepInner: deepCopier. format := format veryDeepCopyWith: deepCopier. target := target. "Weakly copied" lastValue := lastValue veryDeepCopyWith: deepCopier. getSelector := getSelector. "Symbol" putSelector := putSelector. "Symbol" floatPrecision := floatPrecision veryDeepCopyWith: deepCopier. growable := growable veryDeepCopyWith: deepCopier. stepTime := stepTime veryDeepCopyWith: deepCopier. autoAcceptOnFocusLoss := autoAcceptOnFocusLoss veryDeepCopyWith: deepCopier. minimumWidth := minimumWidth veryDeepCopyWith: deepCopier. maximumWidth := maximumWidth veryDeepCopyWith: deepCopier. + self setProperty: #decimalPlaces toValue: ((self valueOfProperty: #decimalPlaces ifAbsent: [0]) veryDeepCopyWith: deepCopier). !

1 0

The Trunk: Collections-eem.717.mcz
by commits＠source.squeak.org 14 Oct '16

14 Oct '16

Eliot Miranda uploaded a new version of Collections to project The Trunk: http://source.squeak.org/trunk/Collections-eem.717.mcz ==================== Summary ==================== Name: Collections-eem.717 Author: eem Time: 13 October 2016, 4:14:34.323953 pm UUID: ff6f9273-5077-47f9-b660-0cdd4b184bb1 Ancestors: Collections-dtl.716 Revise upwards the cross-over in SequenceableCollection>>atAllPut: at which point to move from a simple loop using at:put: to connivance using replaceFrom:to:with:startingAt:. Add a comment that includes the code to actually test this, instead of simply claiming without support. =============== Diff against Collections-dtl.716 =============== Item was changed: ----- Method: SequenceableCollection>>atAllPut: (in category 'accessing') ----- atAllPut: anObject "Put anObject at every one of the receiver's indices." | size | + (size := self size) > 50 "first method faster for larger sizes; see below" - (size := self size) > 26 "first method faster from 27 accesses and on" ifTrue: [self from: 1 to: size put: anObject] + ifFalse: [1 to: size do: [:index | self at: index put: anObject]] + + "Here's code to test what's a good cross over." + "(1 to: 3) collect: + [:j| + { Array. ByteArray. FloatArray. WordArray } collect: + [:class| | a e | + a := class new: 250. + e := a at: 1. + (1 to: a size) detect: + [:n| | t1 t2 | + t1 := [1 to: 1000 do: [:i| a from: 1 to: n put: e]] timeToRun. + t2 := [1 to: 1000 do: [:i| 1 to: n do: [:index | a at: index put: e]]] timeToRun. + t1 < t2]]]" + "32-bit Spur x86 #(#(69 54 9 63) #(64 52 10 55) #(63 53 9 61))" + "64-bit Spur x86-64 #(#(63 50 10 55) #(60 48 10 54) #(63 44 9 50))"! - ifFalse: [1 to: size do: [:index | self at: index put: anObject]]!

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Packages October 2016