Packages March 2017

packages@lists.squeakfoundation.org

1 participants
168 discussions

The Trunk: Tools-jr.745.mcz
by commits＠source.squeak.org 05 Mar '17

05 Mar '17

David T. Lewis uploaded a new version of Tools to project The Trunk: http://source.squeak.org/trunk/Tools-jr.745.mcz ==================== Summary ==================== Name: Tools-jr.745 Author: jr Time: 28 February 2017, 2:20:44.822081 am UUID: c3e3bfae-ac2c-0d4e-a606-c41b7d388d67 Ancestors: Tools-cmm.744 improve Tools support for environments allows... - navigating senders/implementors - using the hierarchy browser - defining new classes and traits - enjoying a Workspace ...in other environments Also ensure all objects understand #environment, so tools can send it without fear. Depends on ToolBuilder-Kernel-jr.109 for choosing something in 'find class'. =============== Diff against Tools-cmm.744 =============== Item was changed: ----- Method: Browser>>copyClass (in category 'class functions') ----- copyClass | originalClass originalName copysName | self hasClassSelected ifFalse: [^ self]. self okToChange ifFalse: [^ self]. originalClass := self selectedClass. originalName := originalClass name. copysName := self request: 'Please type new class name' initialAnswer: originalName. copysName = '' ifTrue: [^ self]. " Cancel returns '' " copysName := copysName asSymbol. copysName = originalName ifTrue: [^ self]. + (self environment hasClassNamed: copysName) - (Smalltalk hasClassNamed: copysName) ifTrue: [^ self error: copysName , ' already exists']. Cursor wait showWhile: [ | newDefinition newMetaDefinition newClass | newDefinition := originalClass definition copyReplaceAll: originalName printString with: copysName printString. + newClass := Compiler evaluate: newDefinition environment: self environment + logged: true. - newClass := Compiler evaluate: newDefinition logged: true. newMetaDefinition := originalClass class definition copyReplaceAll: originalClass class name with: newClass class name. + Compiler evaluate: newMetaDefinition environment: self environment + logged: true. - Compiler evaluate: newMetaDefinition logged: true. newClass copyAllCategoriesFrom: originalClass. newClass class copyAllCategoriesFrom: originalClass class. originalClass hasComment ifTrue: [ newClass comment: originalClass comment ] ]. self classListIndex: 0. self changed: #classList! Item was changed: ----- Method: Browser>>defineClass:notifying: (in category 'class functions') ----- defineClass: defString notifying: aController "The receiver's textual content is a request to define a new class. The source code is defString. If any errors occur in compilation, notify aController." | oldClass class newClassName defTokens keywdIx envt | oldClass := self selectedClassOrMetaClass. defTokens := defString findTokens: Character separators. ((defTokens first = 'Trait' and: [defTokens second = 'named:']) or: [defTokens second = 'classTrait']) ifTrue: [^self defineTrait: defString notifying: aController]. keywdIx := defTokens findFirst: [:x | x beginsWith: 'category']. + envt := self selectedEnvironment. - envt := Smalltalk. keywdIx := defTokens findFirst: [:x | '*subclass*' match: x]. newClassName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'. ((oldClass isNil or: [oldClass theNonMetaClass name asString ~= newClassName]) and: [envt includesKey: newClassName asSymbol]) ifTrue: ["Attempting to define new class over existing one when not looking at the original one in this browser..." (self confirm: ((newClassName , ' is an existing class in this system. Redefining it might cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size)) ifFalse: [^ false]]. "ar 8/29/1999: Use oldClass superclass for defining oldClass since oldClass superclass knows the definerClass of oldClass." oldClass ifNotNil:[oldClass := oldClass superclass]. + class := envt beCurrentDuring: + [oldClass subclassDefinerClass - class := oldClass subclassDefinerClass evaluate: defString + in: envt notifying: aController + logged: false]. - logged: false. (class isKindOf: Behavior) ifTrue: [self changed: #systemCategoryList. self changed: #classList. self clearUserEditFlag. self setClass: class selector: nil. "self clearUserEditFlag; editClass." ^ true] ifFalse: [^ false]! Item was changed: ----- Method: Browser>>defineTrait:notifying: (in category 'traits') ----- defineTrait: defString notifying: aController | defTokens keywdIx envt oldTrait newTraitName trait | oldTrait := self selectedClassOrMetaClass. defTokens := defString findTokens: Character separators. keywdIx := defTokens findFirst: [:x | x = 'category']. envt := self selectedEnvironment. keywdIx := defTokens findFirst: [:x | x = 'named:']. newTraitName := (defTokens at: keywdIx+1) copyWithoutAll: '#()'. ((oldTrait isNil or: [oldTrait baseTrait name asString ~= newTraitName]) and: [envt includesKey: newTraitName asSymbol]) ifTrue: ["Attempting to define new class/trait over existing one when not looking at the original one in this browser..." (self confirm: ((newTraitName , ' is an existing class/trait in this system. Redefining it might cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: newTraitName size)) ifFalse: [^ false]]. + trait := envt beCurrentDuring: + [Compiler evaluate: defString in: envt notifying: aController logged: true]. - trait := Compiler evaluate: defString notifying: aController logged: true. ^(trait isTrait) ifTrue: [ self changed: #classList. self classListIndex: (self classListIndexOf: trait baseTrait name). self clearUserEditFlag; editClass. true] ifFalse: [ false ] ! Item was added: + ----- Method: Browser>>environment (in category 'accessing') ----- + environment + ^ environment ifNil: [super environment]! Item was changed: ----- Method: Browser>>findClass (in category 'system category functions') ----- findClass "Search for a class by name." | foundClass | (self multiWindowState notNil or: [self okToChange]) ifFalse: [^self classNotFound]. + foundClass := UIManager default chooseClassOrTraitFrom: self environment. - foundClass := UIManager default chooseClassOrTrait. foundClass ifNil: [^self classNotFound]. (self selectedClass notNil and: [self multiWindowState notNil "Can only support multi-window if original window has all the right panes." and: [self multiWindowState prototype isHierarchy not]]) ifTrue: [(self classList includes: foundClass name) ifTrue: [self multiWindowState copyWindow] ifFalse: [self multiWindowState addNewWindow]]. self selectCategoryForClass: foundClass. self selectClass: foundClass! Item was changed: ----- Method: Browser>>hierarchicalClassList (in category 'class list') ----- hierarchicalClassList "classNames are an arbitrary collection of classNames of the system. Reorder those class names so that they are sorted and indended by inheritance" | classes | "Creating the hierarchy is *really slow* for the full class list. Skip it for now." self selectedSystemCategory = SystemOrganizer allCategory ifTrue: [^ self defaultClassList]. + classes := self defaultClassList collect: [:sym | self environment classNamed: sym]. - classes := self defaultClassList collect: [:sym | Smalltalk classNamed: sym]. ^ self flattenHierarchyTree: (self createHierarchyTreeOf: classes) on: OrderedCollection new indent: ''.! Item was changed: ----- Method: Browser>>selectedClass (in category 'class list') ----- selectedClass "Answer the class that is currently selected. Answer nil if no selection exists." | name envt | (name := self selectedClassName) ifNil: [^ nil]. (envt := self selectedEnvironment) ifNil: [^ nil]. + ^ envt at: name ifAbsent: [envt valueOf: name ifAbsent: [nil]]! - ^ envt at: name ifAbsent: [nil]! Item was changed: ----- Method: Browser>>selectedEnvironment (in category 'system category list') ----- selectedEnvironment + "Answer the browsed environment. If this returned a system category dependent + value and possibly nil (as it did in previous versions), selectedClass would not work in + a hierarchy browser that has to display classes from different environments + (because the correct categories might be missing in the browser)" - "Answer the name of the selected system category or nil." + ^ environment ifNil: [Smalltalk globals]! - self hasSystemCategorySelected ifFalse: [^nil]. - ^ environment ifNil: [Smalltalk]! Item was changed: ----- Method: ChangeList>>diffedVersionContents (in category 'viewing access') ----- diffedVersionContents "Answer diffed version contents, maybe pretty maybe not" | change class earlier later | (listIndex = 0 or: [changeList size < listIndex]) ifTrue: [^ '']. change := changeList at: listIndex. later := change text. + class := change methodClass: self environment. - class := change methodClass. (listIndex == changeList size or: [class == nil]) ifTrue: [^ (self showingPrettyDiffs and: [class notNil]) ifTrue: [class prettyPrinterClass format: later in: class notifying: nil] ifFalse: [later]]. earlier := (changeList at: listIndex + 1) text. ^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs! Item was changed: ----- Method: ChangeList>>fileInSelections (in category 'menu actions') ----- fileInSelections | any | any := false. + self selectedClass environment beCurrentDuring: [ + listSelections with: changeList do: + [:selected :item | selected ifTrue: [any := true. item fileIn]]]. - listSelections with: changeList do: - [:selected :item | selected ifTrue: [any := true. item fileIn]]. any ifFalse: [self inform: 'nothing selected, so nothing done']! Item was changed: ----- Method: DependencyBrowser>>selectedEnvironment (in category 'accessing') ----- selectedEnvironment "Answer the name of the selected package or nil." self hasPackageSelected ifFalse: [^nil]. + ^ Smalltalk globals! - ^ Smalltalk! Item was changed: ----- Method: HierarchyBrowser>>classList (in category 'class list') ----- classList + classDisplayList := classDisplayList select: [:each | (self environment valueOf: each withBlanksTrimmed asSymbol) notNil]. - classDisplayList := classDisplayList select: [:each | Smalltalk includesKey: each withBlanksTrimmed asSymbol]. ^ classDisplayList! Item was changed: ----- Method: HierarchyBrowser>>classListIndex: (in category 'initialization') ----- classListIndex: newIndex "Cause system organization to reflect appropriate category" | newClassName ind | newIndex ~= 0 ifTrue: [newClassName := (classDisplayList at: newIndex) copyWithout: $ . selectedSystemCategory := (systemOrganizer categories at: + (systemOrganizer numberOfCategoryOfElement: newClassName) + ifAbsent: [nil])]. - (systemOrganizer numberOfCategoryOfElement: newClassName))]. ind := super classListIndex: newIndex. "What I'd like to write:" "self selectedClassName ifNotNil: [ selectedSystemCategory := self selectedClass category ]." self changed: #systemCategorySingleton. ^ ind! Item was changed: ----- Method: HierarchyBrowser>>initHierarchyForClass: (in category 'initialization') ----- initHierarchyForClass: aClassOrMetaClass | nonMetaClass superclasses | centralClass := aClassOrMetaClass. nonMetaClass := aClassOrMetaClass theNonMetaClass. + self selectEnvironment: aClassOrMetaClass environment. - self systemOrganizer: SystemOrganization. metaClassIndicated := aClassOrMetaClass isMeta. classDisplayList := OrderedCollection new. (superclasses := nonMetaClass allSuperclasses reversed) withIndexDo: [ : each : indent | classDisplayList add: (String streamContents: [ : stream | indent - 1 timesRepeat: [ stream nextPutAll: ' ' ]. stream nextPutAll: each name ]) ]. nonMetaClass allSubclassesWithLevelDo: [ : eachClass : lvl | classDisplayList add: (String streamContents: [ : stream | lvl timesRepeat: [ stream nextPutAll: ' ' ]. stream nextPutAll: eachClass name ]) ] startingLevel: superclasses size. self changed: #classList. self selectClass: nonMetaClass! Item was changed: ----- Method: MessageSet class>>parse:toClassAndSelector: (in category 'utilities') ----- parse: methodRef toClassAndSelector: csBlock "Decode strings of the form <className> [class] <selectorName>." | tuple cl | self flag: #mref. "compatibility with pre-MethodReference lists" methodRef ifNil: [^ csBlock value: nil value: nil]. methodRef isString ifFalse: [^methodRef setClassAndSelectorIn: csBlock]. methodRef isEmpty ifTrue: [^csBlock value: nil value: nil]. tuple := (methodRef asString includesSubstring: '>>') ifTrue: [(methodRef findTokens: '>>') fold: [:a :b| (a findTokens: ' '), {b first = $# ifTrue: [b allButFirst] ifFalse: [b]}]] ifFalse: [methodRef asString findTokens: ' .']. + self flag: #environments. "missing information about the class environment" cl := Smalltalk at: tuple first asSymbol ifAbsent: [^ csBlock value: nil value: nil]. ^(tuple size = 2 or: [tuple size > 2 and: [(tuple at: 2) ~= 'class']]) ifTrue: [csBlock value: cl value: (tuple at: 2) asSymbol] ifFalse: [csBlock value: cl class value: (tuple at: 3) asSymbol]! Item was changed: ----- Method: MessageTrace>>filteredSelectorsNamed: (in category 'filtering') ----- filteredSelectorsNamed: selectorSymbol + ^(SystemNavigation for: self environment) allImplementorsOf: selectorSymbol - ^SystemNavigation new allImplementorsOf: selectorSymbol ! Item was added: + ----- Method: Model>>environment (in category '*Tools') ----- + environment + ^ (self selectedClass ifNil: [self class]) environment! Item was added: + ----- Method: Object>>environment (in category '*Tools') ----- + environment + "This is a fallback for models that do not inherit from Model or something else that provides + a useful Environment answer. You should consider copying this method to (base) classes of + objects from which you expect exactly the behavior below. + Absolutely feel free to override this method for objects that have or operate on a dedicated + environment, such as references to classes, code loaders, or tools." + ^ self class environment! Item was changed: StringHolder subclass: #Workspace + instanceVariableNames: 'bindings acceptDroppedMorphs acceptAction mustDeclareVariables shouldStyle environment' - instanceVariableNames: 'bindings acceptDroppedMorphs acceptAction mustDeclareVariables shouldStyle' classVariableNames: 'LookupPools ShouldStyle' poolDictionaries: '' category: 'Tools-Base'! !Workspace commentStamp: 'fbs 6/2/2012 20:46' prior: 0! A Workspace is a text area plus a lot of support for executable code. It is a great place to execute top-level commands to compute something useful, and it is a great place to develop bits of a program before those bits get put into class methods. To open a new workspace, execute: Workspace open A workspace can have its own variables, called "workspace variables", to hold intermediate results. For example, if you type into a workspace "x := 5" and do-it, then later you could type in "y := x * 2" and y would become 10. Additionally, in Morphic, a workspace can gain access to morphs that are on the screen. If acceptDroppedMorphs is turned on, then whenever a morph is dropped on the workspace, a variable will be created which references that morph. This functionality is toggled with the window-wide menu of a workspace. The instance variables of this class are: bindings - holds the workspace variables for this workspace acceptDroppedMorphs - whether dropped morphs should create new variables! Item was added: + ----- Method: Workspace>>environment (in category 'accessing') ----- + environment + ^ environment ifNil: [Smalltalk globals]! Item was added: + ----- Method: Workspace>>environment: (in category 'accessing') ----- + environment: anEnvironment + + environment := anEnvironment.! Item was changed: ----- Method: Workspace>>initialize (in category 'initialize-release') ----- initialize super initialize. self initializeBindings. acceptDroppedMorphs := false. + mustDeclareVariables := false. + environment := Environment current.! - mustDeclareVariables := false!

1 0

The Trunk: ToolBuilder-Kernel-jr.109.mcz
by commits＠source.squeak.org 05 Mar '17

05 Mar '17

David T. Lewis uploaded a new version of ToolBuilder-Kernel to project The Trunk: http://source.squeak.org/trunk/ToolBuilder-Kernel-jr.109.mcz ==================== Summary ==================== Name: ToolBuilder-Kernel-jr.109 Author: jr Time: 28 February 2017, 1:37:47.610081 am UUID: edda3c34-f8df-fc4f-b6a5-6404053750f1 Ancestors: ToolBuilder-Kernel-tfel.108 offer a class selection from another environment =============== Diff against ToolBuilder-Kernel-tfel.108 =============== Item was changed: ----- Method: UIManager>>chooseClassOrTrait (in category 'ui requests') ----- chooseClassOrTrait "Let the user choose a Class or Trait" + ^self chooseClassOrTraitFrom: Smalltalk globals! - ^self chooseClassOrTrait: 'Class name or fragment?'! Item was added: + ----- Method: UIManager>>chooseClassOrTraitFrom: (in category 'ui requests') ----- + chooseClassOrTraitFrom: anEnvironment + "Let the user choose a Class or Trait from the given environment" + + ^self chooseClassOrTrait: 'Class name or fragment?' from: anEnvironment! Item was changed: ----- Method: UIManager>>classFromPattern:withCaption: (in category 'system introspecting') ----- classFromPattern: pattern withCaption: aCaption + ^self classFromPattern: pattern withCaption: aCaption in: Smalltalk environment - "If there is a class or trait whose name exactly given by pattern, return it. - If there is only one class or trait in the system whose name matches pattern, return it. - Otherwise, put up a menu offering the names of all classes that match pattern, and return the class chosen, else nil if nothing chosen. - This method ignores separator characters in the pattern" - - ^self classOrTraitFrom: Smalltalk environment pattern: pattern label: aCaption " self classFromPattern: 'CharRecog' withCaption: '' self classFromPattern: 'rRecog' withCaption: '' self classFromPattern: 'znak' withCaption: '' self classFromPattern: 'orph' withCaption: '' self classFromPattern: 'TCompil' withCaption: '' " ! Item was added: + ----- Method: UIManager>>classFromPattern:withCaption:in: (in category 'system introspecting') ----- + classFromPattern: pattern withCaption: aCaption in: anEnvironment + "If there is a class or trait whose name exactly given by pattern, return it. + If there is only one class or trait in the system whose name matches pattern, return it. + Otherwise, put up a menu offering the names of all classes that match pattern, and return the class chosen, else nil if nothing chosen. + This method ignores separator characters in the pattern" + + ^self classOrTraitFrom: anEnvironment pattern: pattern label: aCaption + " + for examples, see #classFromPattern:withCaption: + " + !

1 0

The Trunk: System-jr.927.mcz
by commits＠source.squeak.org 05 Mar '17

05 Mar '17

David T. Lewis uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-jr.927.mcz ==================== Summary ==================== Name: System-jr.927 Author: jr Time: 28 February 2017, 1:18:53.473081 am UUID: 7c830682-637d-e94b-b695-9f1d7499e19b Ancestors: System-ul.926 improve environment awareness of references also support Text as stringVersion of MethodReference (so Lexicon could use method references) =============== Diff against System-ul.926 =============== Item was changed: Object subclass: #ClassReference + instanceVariableNames: 'classSymbol stringVersion classIsMeta environment' - instanceVariableNames: 'classSymbol stringVersion classIsMeta' classVariableNames: '' poolDictionaries: '' category: 'System-Tools'! !ClassReference commentStamp: '<historical>' prior: 0! A ClassReference is is a lightweight proxy for a Class's definition. Allows class definitions to be viewed in MessageLists Instance Variables classSymbol: Symbol for method's class (without class keyword if meta) stringVersion: the class's definition ! Item was changed: ----- Method: ClassReference>>= (in category 'comparisons') ----- = anotherMethodReference "Answer whether the receiver and the argument represent the same object." ^ self species == anotherMethodReference species and: [self classSymbol = anotherMethodReference classSymbol + and: [self classIsMeta = anotherMethodReference classIsMeta + and: [self environment == anotherMethodReference environment]]]! - and: [self classIsMeta = anotherMethodReference classIsMeta]]! Item was changed: ----- Method: ClassReference>>actualClass (in category 'accessing') ----- actualClass | actualClass | + environment ifNil: [^ nil]. + actualClass := environment at: classSymbol ifAbsent: [^nil]. + ^classIsMeta ifTrue: [actualClass theMetaClass] ifFalse: [actualClass]! - actualClass := Smalltalk at: classSymbol ifAbsent: [^nil]. - ^classIsMeta ifTrue: [actualClass class] ifFalse: [actualClass]! Item was added: + ----- Method: ClassReference>>environment (in category 'accessing') ----- + environment + + ^ environment! Item was added: + ----- Method: ClassReference>>hash (in category 'comparisons') ----- + hash + "Answer a SmallInteger whose value is related to the receiver's + identity." + ^ (self species hash bitXor: self classSymbol hash) + bitXor: self environment hash! Item was added: + ----- Method: ClassReference>>printOn: (in category 'printing') ----- + printOn: aStream + | actualClass | + "Print the receiver on a stream" + actualClass := classSymbol asString. + classIsMeta ifTrue: [actualClass := actualClass, ' class']. + super printOn: aStream. + aStream nextPutAll: ' ', actualClass! Item was added: + ----- Method: ClassReference>>setClassSymbol:classIsMeta:environment:stringVersion: (in category 'initialize-release') ----- + setClassSymbol: classSym classIsMeta: isMeta environment: anEnvironment stringVersion: aString + + classSymbol := classSym. + classIsMeta := isMeta. + stringVersion := aString, ' (definition)'. + environment := anEnvironment! Item was changed: ----- Method: ClassReference>>setStandardClass: (in category 'initialize-release') ----- setStandardClass: aClass self setClassSymbol: aClass theNonMetaClass name classIsMeta: aClass isMeta + environment: aClass environment stringVersion: aClass name! Item was changed: ----- Method: MethodReference class>>class:selector: (in category 'instance creation') ----- class: aClass selector: aSelector + ^ self class: aClass selector: aSelector environment: aClass environment.! - ^ self class: aClass selector: aSelector environment: Smalltalk globals.! Item was changed: ----- Method: MethodReference>>= (in category 'comparing') ----- = anotherMethodReference "Answer whether the receiver and the argument represent the same object." ^ self species == anotherMethodReference species and: [self classSymbol = anotherMethodReference classSymbol and: [self classIsMeta = anotherMethodReference classIsMeta + and: [self methodSymbol = anotherMethodReference methodSymbol + and: [self environment == anotherMethodReference environment]]]]! - and: [self methodSymbol = anotherMethodReference methodSymbol]]]! Item was changed: ----- Method: MethodReference>>asString (in category 'converting') ----- asString + ^(stringVersion ifNil: [ self stringVersionDefault ]) asString! - ^stringVersion ifNil: [ self stringVersionDefault ]! Item was added: + ----- Method: MethodReference>>asStringOrText (in category 'converting') ----- + asStringOrText + + ^stringVersion ifNil: [ self stringVersionDefault ]! Item was changed: ----- Method: MethodReference>>setClass:methodSymbol:stringVersion: (in category 'initialize-release') ----- setClass: aClass methodSymbol: methodSym stringVersion: aString classSymbol := aClass theNonMetaClass name. classIsMeta := aClass isMeta. methodSymbol := methodSym. + environment := aClass environment. stringVersion := aString.! Item was changed: ----- Method: MethodReference>>setStandardClass:methodSymbol: (in category 'initialize-release') ----- setStandardClass: aClass methodSymbol: methodSym classSymbol := aClass theNonMetaClass name. + environment := aClass environment. classIsMeta := aClass isMeta. methodSymbol := methodSym. stringVersion := nil.! Item was changed: ----- Method: MethodReference>>stringVersion (in category 'accessing') ----- stringVersion + ^stringVersion ifNil: [self asStringOrText]! - ^stringVersion! Item was changed: ----- Method: SystemNavigation>>methodHierarchyBrowserForClass:selector: (in category 'browse') ----- methodHierarchyBrowserForClass: aClass selector: selectorSymbol "Create and schedule a message set browser on all implementors of the currently selected message selector. Do nothing if no message is selected." "SystemNavigation default methodHierarchyBrowserForClass: ParagraphEditor selector: #isControlActive" | list aClassNonMeta isMeta tab compiledMethod window | aClass ifNil: [^ self]. aClass isTrait ifTrue: [^ self]. selectorSymbol ifNil: [^ self]. aClassNonMeta := aClass theNonMetaClass. isMeta := aClassNonMeta ~~ aClass. list := OrderedCollection new. tab := ''. aClass allSuperclasses reverseDo: [:cl | (cl includesSelector: selectorSymbol) ifTrue: + [list addLast: (MethodReference new + setClass: cl + methodSymbol: selectorSymbol + stringVersion: tab , cl name, ' ', selectorSymbol)]. - [list addLast: tab , cl name, ' ', selectorSymbol]. tab := tab , ' ']. aClassNonMeta allSubclassesWithLevelDo: [:cl :level | | theClassOrMeta stab | theClassOrMeta := isMeta ifTrue: [cl class] ifFalse: [cl]. (theClassOrMeta includesSelector: selectorSymbol) ifTrue: [stab := ''. 1 to: level do: [:i | stab := stab , ' ']. + list addLast: (MethodReference new + setClass: theClassOrMeta + methodSymbol: selectorSymbol + stringVersion: tab , stab , theClassOrMeta name, ' ', selectorSymbol)]] - list addLast: tab , stab , theClassOrMeta name, ' ', selectorSymbol]] startingLevel: 0. window := self browseMessageList: list name: 'Inheritance of ' , selectorSymbol. window isSystemWindow ifTrue: [ window model deselectAll ; yourself. compiledMethod := aClass compiledMethodAt: selectorSymbol ifAbsent:[nil]. compiledMethod ifNotNil: [ window model selectReference: compiledMethod methodReference ] ]! Item was changed: ----- Method: SystemOrganizer>>classify:under: (in category 'accessing') ----- classify: element under: newCategory | oldCategory class | + self flag: #environments. "do we want notifications for classes in other environments?" oldCategory := self categoryOfElement: element. super classify: element under: newCategory. class := Smalltalk at: element ifAbsent: [^ self]. self == SystemOrganization ifTrue: [ SystemChangeNotifier uniqueInstance class: class recategorizedFrom: oldCategory to: newCategory]!

1 0

The Trunk: System-jr.927.mcz
by commits＠source.squeak.org 05 Mar '17

05 Mar '17

1 0

The Trunk: System-jr.928.mcz
by commits＠source.squeak.org 05 Mar '17

05 Mar '17

David T. Lewis uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-jr.928.mcz ==================== Summary ==================== Name: System-jr.928 Author: jr Time: 28 February 2017, 1:52:26.276081 am UUID: 3b79a197-c860-eb40-8f04-645f64bc7988 Ancestors: System-jr.927 return an environment dependent systemNavigation mainly to be used by tools that override #environment =============== Diff against System-ul.926 =============== Item was changed: Object subclass: #ClassReference + instanceVariableNames: 'classSymbol stringVersion classIsMeta environment' - instanceVariableNames: 'classSymbol stringVersion classIsMeta' classVariableNames: '' poolDictionaries: '' category: 'System-Tools'! !ClassReference commentStamp: '<historical>' prior: 0! A ClassReference is is a lightweight proxy for a Class's definition. Allows class definitions to be viewed in MessageLists Instance Variables classSymbol: Symbol for method's class (without class keyword if meta) stringVersion: the class's definition ! Item was changed: ----- Method: ClassReference>>= (in category 'comparisons') ----- = anotherMethodReference "Answer whether the receiver and the argument represent the same object." ^ self species == anotherMethodReference species and: [self classSymbol = anotherMethodReference classSymbol + and: [self classIsMeta = anotherMethodReference classIsMeta + and: [self environment == anotherMethodReference environment]]]! - and: [self classIsMeta = anotherMethodReference classIsMeta]]! Item was changed: ----- Method: ClassReference>>actualClass (in category 'accessing') ----- actualClass | actualClass | + environment ifNil: [^ nil]. + actualClass := environment at: classSymbol ifAbsent: [^nil]. + ^classIsMeta ifTrue: [actualClass theMetaClass] ifFalse: [actualClass]! - actualClass := Smalltalk at: classSymbol ifAbsent: [^nil]. - ^classIsMeta ifTrue: [actualClass class] ifFalse: [actualClass]! Item was added: + ----- Method: ClassReference>>environment (in category 'accessing') ----- + environment + + ^ environment! Item was added: + ----- Method: ClassReference>>hash (in category 'comparisons') ----- + hash + "Answer a SmallInteger whose value is related to the receiver's + identity." + ^ (self species hash bitXor: self classSymbol hash) + bitXor: self environment hash! Item was added: + ----- Method: ClassReference>>printOn: (in category 'printing') ----- + printOn: aStream + | actualClass | + "Print the receiver on a stream" + actualClass := classSymbol asString. + classIsMeta ifTrue: [actualClass := actualClass, ' class']. + super printOn: aStream. + aStream nextPutAll: ' ', actualClass! Item was added: + ----- Method: ClassReference>>setClassSymbol:classIsMeta:environment:stringVersion: (in category 'initialize-release') ----- + setClassSymbol: classSym classIsMeta: isMeta environment: anEnvironment stringVersion: aString + + classSymbol := classSym. + classIsMeta := isMeta. + stringVersion := aString, ' (definition)'. + environment := anEnvironment! Item was changed: ----- Method: ClassReference>>setStandardClass: (in category 'initialize-release') ----- setStandardClass: aClass self setClassSymbol: aClass theNonMetaClass name classIsMeta: aClass isMeta + environment: aClass environment stringVersion: aClass name! Item was changed: ----- Method: MethodReference class>>class:selector: (in category 'instance creation') ----- class: aClass selector: aSelector + ^ self class: aClass selector: aSelector environment: aClass environment.! - ^ self class: aClass selector: aSelector environment: Smalltalk globals.! Item was changed: ----- Method: MethodReference>>= (in category 'comparing') ----- = anotherMethodReference "Answer whether the receiver and the argument represent the same object." ^ self species == anotherMethodReference species and: [self classSymbol = anotherMethodReference classSymbol and: [self classIsMeta = anotherMethodReference classIsMeta + and: [self methodSymbol = anotherMethodReference methodSymbol + and: [self environment == anotherMethodReference environment]]]]! - and: [self methodSymbol = anotherMethodReference methodSymbol]]]! Item was changed: ----- Method: MethodReference>>asString (in category 'converting') ----- asString + ^(stringVersion ifNil: [ self stringVersionDefault ]) asString! - ^stringVersion ifNil: [ self stringVersionDefault ]! Item was added: + ----- Method: MethodReference>>asStringOrText (in category 'converting') ----- + asStringOrText + + ^stringVersion ifNil: [ self stringVersionDefault ]! Item was changed: ----- Method: MethodReference>>setClass:methodSymbol:stringVersion: (in category 'initialize-release') ----- setClass: aClass methodSymbol: methodSym stringVersion: aString classSymbol := aClass theNonMetaClass name. classIsMeta := aClass isMeta. methodSymbol := methodSym. + environment := aClass environment. stringVersion := aString.! Item was changed: ----- Method: MethodReference>>setStandardClass:methodSymbol: (in category 'initialize-release') ----- setStandardClass: aClass methodSymbol: methodSym classSymbol := aClass theNonMetaClass name. + environment := aClass environment. classIsMeta := aClass isMeta. methodSymbol := methodSym. stringVersion := nil.! Item was changed: ----- Method: MethodReference>>stringVersion (in category 'accessing') ----- stringVersion + ^stringVersion ifNil: [self asStringOrText]! - ^stringVersion! Item was changed: ----- Method: Object>>systemNavigation (in category '*system-support') ----- systemNavigation + ^ SystemNavigation for: self environment! - ^ SystemNavigation default! Item was changed: ----- Method: SystemNavigation>>methodHierarchyBrowserForClass:selector: (in category 'browse') ----- methodHierarchyBrowserForClass: aClass selector: selectorSymbol "Create and schedule a message set browser on all implementors of the currently selected message selector. Do nothing if no message is selected." "SystemNavigation default methodHierarchyBrowserForClass: ParagraphEditor selector: #isControlActive" | list aClassNonMeta isMeta tab compiledMethod window | aClass ifNil: [^ self]. aClass isTrait ifTrue: [^ self]. selectorSymbol ifNil: [^ self]. aClassNonMeta := aClass theNonMetaClass. isMeta := aClassNonMeta ~~ aClass. list := OrderedCollection new. tab := ''. aClass allSuperclasses reverseDo: [:cl | (cl includesSelector: selectorSymbol) ifTrue: + [list addLast: (MethodReference new + setClass: cl + methodSymbol: selectorSymbol + stringVersion: tab , cl name, ' ', selectorSymbol)]. - [list addLast: tab , cl name, ' ', selectorSymbol]. tab := tab , ' ']. aClassNonMeta allSubclassesWithLevelDo: [:cl :level | | theClassOrMeta stab | theClassOrMeta := isMeta ifTrue: [cl class] ifFalse: [cl]. (theClassOrMeta includesSelector: selectorSymbol) ifTrue: [stab := ''. 1 to: level do: [:i | stab := stab , ' ']. + list addLast: (MethodReference new + setClass: theClassOrMeta + methodSymbol: selectorSymbol + stringVersion: tab , stab , theClassOrMeta name, ' ', selectorSymbol)]] - list addLast: tab , stab , theClassOrMeta name, ' ', selectorSymbol]] startingLevel: 0. window := self browseMessageList: list name: 'Inheritance of ' , selectorSymbol. window isSystemWindow ifTrue: [ window model deselectAll ; yourself. compiledMethod := aClass compiledMethodAt: selectorSymbol ifAbsent:[nil]. compiledMethod ifNotNil: [ window model selectReference: compiledMethod methodReference ] ]! Item was changed: ----- Method: SystemOrganizer>>classify:under: (in category 'accessing') ----- classify: element under: newCategory | oldCategory class | + self flag: #environments. "do we want notifications for classes in other environments?" oldCategory := self categoryOfElement: element. super classify: element under: newCategory. class := Smalltalk at: element ifAbsent: [^ self]. self == SystemOrganization ifTrue: [ SystemChangeNotifier uniqueInstance class: class recategorizedFrom: oldCategory to: newCategory]!

1 0

The Trunk: Kernel-jr.1061.mcz
by commits＠source.squeak.org 05 Mar '17

05 Mar '17

David T. Lewis uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-jr.1061.mcz ==================== Summary ==================== Name: Kernel-jr.1061 Author: jr Time: 28 February 2017, 12:28:50.653081 am UUID: acd952fb-8e90-e940-8d2e-6c1a9e3a7d3f Ancestors: Kernel-ul.1060 increase environment awareness for behaviors =============== Diff against Kernel-ul.1060 =============== Item was added: + ----- Method: Behavior>>compile:environment:notifying:trailer:ifFail: (in category 'compiling') ----- + compile: code environment: anEnvironment notifying: requestor trailer: bytes ifFail: failBlock + "Compile code in another Environment without logging the source in the changes file" + + | methodNode | + methodNode := self newCompiler + compile: code + in: self + environment: anEnvironment + notifying: requestor + ifFail: failBlock. + ^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.! Item was changed: ----- Method: Class>>category: (in category 'organization') ----- category: aString "Categorize the receiver under the system category, aString, removing it from any previous categorization." | oldCategory | oldCategory := category. aString isString ifTrue: [ category := aString asSymbol. + self environment organization classify: self name under: category ] - SystemOrganization classify: self name under: category ] ifFalse: [self errorCategoryName]! Item was changed: ----- Method: ClassDescription>>definition (in category 'fileIn/Out') ----- definition "Answer a String that defines the receiver." | aStream path | aStream := WriteStream on: (String new: 300). superclass == nil ifTrue: [aStream nextPutAll: 'ProtoObject'] ifFalse: [path := ''. self environment scopeFor: superclass name from: nil envtAndPathIfFound: [:envt :remotePath | path := remotePath]. aStream nextPutAll: path , superclass name]. aStream nextPutAll: self kindOfSubclass; store: self name. (self hasTraitComposition and: [self traitComposition notEmpty]) ifTrue: [ aStream cr; tab; nextPutAll: 'uses: '; nextPutAll: self traitCompositionString]. aStream cr; tab; nextPutAll: 'instanceVariableNames: '; store: self instanceVariablesString. aStream cr; tab; nextPutAll: 'classVariableNames: '; store: self classVariablesString. aStream cr; tab; nextPutAll: 'poolDictionaries: '; store: self sharedPoolsString. aStream cr; tab; nextPutAll: 'category: '; + store: (self environment organization categoryOfElement: self name) asString. - store: (SystemOrganization categoryOfElement: self name) asString. superclass ifNil: [ aStream nextPutAll: '.'; cr. aStream nextPutAll: self name. aStream space; nextPutAll: 'superclass: nil'. ]. ^ aStream contents! Item was changed: ----- Method: Object class>>readFrom: (in category 'instance creation') ----- readFrom: textStringOrStream "Create an object based on the contents of textStringOrStream." | object | (Compiler couldEvaluate: textStringOrStream) ifFalse: [^ self error: 'expected String, Stream, or Text']. + object := self environment beCurrentDuring: [Compiler evaluate: textStringOrStream environment: self environment]. - object := Compiler evaluate: textStringOrStream. (object isKindOf: self) ifFalse: [self error: self name, ' expected']. ^object!

1 0

The Trunk: Compiler-jr.329.mcz
by commits＠source.squeak.org 05 Mar '17

05 Mar '17

David T. Lewis uploaded a new version of Compiler to project The Trunk: http://source.squeak.org/trunk/Compiler-jr.329.mcz ==================== Summary ==================== Name: Compiler-jr.329 Author: jr Time: 28 February 2017, 12:19:04.434081 am UUID: 6053da84-5a5b-b043-8dcc-019bc75762df Ancestors: Compiler-nice.328 add method variants with environment parameters =============== Diff against Compiler-nice.328 =============== Item was added: + ----- Method: CompilationCue class>>source:context:class:environment:requestor: (in category 'instance creation') ----- + source: aTextOrStream context: aContext class: aClass environment: anEnvironment requestor: reqObject + ^ self basicNew + initializeWithSource: aTextOrStream + context: aContext + receiver: (aContext ifNotNil: [aContext receiver]) + class: aClass + environment: anEnvironment + requestor: reqObject! Item was added: + ----- Method: CompilationCue class>>source:environment:requestor: (in category 'instance creation') ----- + source: aString environment: anEnvironment requestor: aRequestor + ^ self + source: aString + context: nil + receiver: nil + class: UndefinedObject + environment: anEnvironment + requestor: aRequestor! Item was added: + ----- Method: Compiler class>>evaluate:in:notifying:logged: (in category 'evaluating logged') ----- + evaluate: textOrString in: anEnvironment notifying: aController logged: logFlag + "Compile and execute the argument, textOrString in anEnvironment. + If a compilation error occurs, notify aController. If both + compilation and execution are successful then, if logFlag is true, log + (write) the text onto a system changes file so that it can be replayed if + necessary." + + ^ self new + evaluate: textOrString + in: anEnvironment + notifying: aController + logged: logFlag.! Item was added: + ----- Method: Compiler>>compile:in:environment:notifying:ifFail: (in category 'public access') ----- + compile: textOrStream in: aClass environment: anEnvironment notifying: aRequestor ifFail: failBlock + "Answer a MethodNode for the argument, textOrStream. If the + MethodNode can not be created, notify the argument, aRequestor; if + aRequestor is nil, evaluate failBlock instead. The MethodNode is the root + of a parse tree. It can be told to generate a CompiledMethod to be + installed in the method dictionary of the argument, aClass." + + ^self + compileCue: (CompilationCue + source: textOrStream + class: aClass + environment: anEnvironment + requestor: aRequestor) + noPattern: false + ifFail: failBlock + ! Item was added: + ----- Method: Compiler>>compileNoPattern:in:context:environment:notifying:ifFail: (in category 'public access') ----- + compileNoPattern: textOrStream in: aClass context: aContext environment: anEnvironment notifying: aRequestor ifFail: failBlock + "Similar to #compile:in:notifying:ifFail:, but the compiled code is + expected to be a do-it expression, with no message pattern, + and it will be in an explicit environment." + + ^self + compileCue: (CompilationCue + source: textOrStream + context: aContext + class: aClass + environment: anEnvironment + requestor: aRequestor) + noPattern: true + ifFail: failBlock + ! Item was added: + ----- Method: Compiler>>evaluate:in:environment:notifying:ifFail:logged: (in category 'public access logging') ----- + evaluate: textOrStream in: aContext environment: anEnvironment notifying: aRequestor ifFail: failBlock logged: logFlag + "Compiles the sourceStream into a parse tree, then generates code into + a method. If aContext is not nil, the text can refer to temporaries in that + context (the Debugger uses this). If aRequestor is not nil, then it will receive + a notify:at: message before the attempt to evaluate is aborted. Finally, the + compiled method is invoked from here via withArgs:executeMethod:, hence + the system no longer creates Doit method litter on errors." + ^self + evaluateCue: (CompilationCue + source: textOrStream + context: aContext + receiver: nil + class: UndefinedObject + environment: anEnvironment + requestor: aRequestor) + ifFail: failBlock + logged: logFlag! Item was added: + ----- Method: Compiler>>evaluate:in:notifying:logged: (in category 'public access logging') ----- + evaluate: textOrString in: anEnvironment notifying: aController logged: logFlag + "Compile and execute the argument, textOrString in anEnvironment. + If a compilation error occurs, notify aController. If both + compilation and execution are successful then, if logFlag is true, log + (write) the text onto a system changes file so that it can be replayed if + necessary." + + ^self + evaluate: textOrString + in: nil + environment: anEnvironment + notifying: aController + ifFail: [^nil] + logged: logFlag! Item was added: + ----- Method: Compiler>>evaluate:in:to:environment:notifying:ifFail:logged: (in category 'public access logging') ----- + evaluate: textOrStream in: aContext to: receiver environment: anEnvironment notifying: aRequestor ifFail: failBlock logged: logFlag + "Same as #evaluate:in:to:notifying:ifFail:logged: but with an explicit environment" + | theClass | + theClass := (aContext == nil ifTrue: [receiver class] ifFalse: [aContext methodClass]). + ^self + evaluateCue: (CompilationCue + source: textOrStream + context: aContext + receiver: receiver + class: theClass + environment: anEnvironment + requestor: aRequestor) + ifFail: failBlock + logged: logFlag!

1 0

The Trunk: Morphic-tpr.1324.mcz
by commits＠source.squeak.org 01 Mar '17

01 Mar '17

tim Rowledge uploaded a new version of Morphic to project The Trunk: http://source.squeak.org/trunk/Morphic-tpr.1324.mcz ==================== Summary ==================== Name: Morphic-tpr.1324 Author: tpr Time: 1 March 2017, 2:26:17.114978 pm UUID: 8cb81f4d-2ba4-4c44-8805-203cc17ae86c Ancestors: Morphic-mt.1296, Morphic-ul.1323 Minimal fix for PluggableMultiColumnListMorph>>getListItem: to allow #userStrings to work. Not a substitute for working out what #userStrings for a list ought to be =============== Diff against Morphic-mt.1296 =============== 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: ComplexBorder>>trackColorFrom: (in category 'color tracking') ----- trackColorFrom: aMorph + baseColor isTransparent ifTrue:[self color: aMorph raisedColor].! - baseColor ifNil:[self color: aMorph raisedColor].! Item was changed: ----- Method: Editor>>beginningOfParagraph: (in category 'private') ----- beginningOfParagraph: position ^ (self string lastIndexOf: Character cr + startingAt: position) + 1.! - startingAt: position - ifAbsent: [ 0 ]) + 1.! 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: FontChooserTool>>selectedFontIndex (in category 'font list') ----- selectedFontIndex | font textStyleName family | selectedFontIndex ifNotNil: [^selectedFontIndex]. selectedFontIndex := 0. font := (getSelector isSymbol and:[target notNil]) ifTrue:[target perform: getSelector] ifFalse:[getSelector]. font ifNotNil:[ emphasis := font emphasis. pointSize := font pointSize. textStyleName := font textStyleName. family := self fontList detect:[:f | f = textStyleName] ifNone:[]. ]. + selectedFontIndex := self fontList indexOf: family. - selectedFontIndex := self fontList indexOf: family ifAbsent:[0]. self selectedFontIndex: selectedFontIndex. ^selectedFontIndex! 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: InsetBorder>>trackColorFrom: (in category 'color tracking') ----- trackColorFrom: aMorph + baseColor isTransparent ifTrue:[self color: aMorph insetColor].! - baseColor ifNil:[self color: aMorph insetColor].! 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>>morphPreceding: (in category 'structure') ----- morphPreceding: aSubmorph "Answer the morph immediately preceding aSubmorph, or nil if none" + | index | + (index := submorphs indexOf: aSubmorph) > 1 ifTrue: [ + ^submorphs at: index - 1 ]. + ^nil! - | anIndex | - anIndex := submorphs indexOf: aSubmorph ifAbsent: [^ nil]. - ^ anIndex > 1 - ifTrue: - [submorphs at: (anIndex - 1)] - ifFalse: - [nil]! 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: NewParagraph>>displaySelectionInLine:on: (in category 'display') ----- displaySelectionInLine: line on: aCanvas | leftX rightX w | selectionStart ifNil: [^self]. "No selection" aCanvas isShadowDrawing ifTrue: [ ^self ]. "don't draw selection with shadow" selectionStart = selectionStop ifTrue: ["Only show caret on line where clicked" selectionStart textLine ~= line ifTrue: [^self]] ifFalse: ["Test entire selection before or after here" (selectionStop stringIndex < line first or: [selectionStart stringIndex > (line last + 1)]) ifTrue: [^self]. "No selection on this line" (selectionStop stringIndex = line first and: [selectionStop textLine ~= line]) ifTrue: [^self]. "Selection ends on line above" (selectionStart stringIndex = (line last + 1) and: [selectionStop textLine ~= line]) ifTrue: [^self]]. "Selection begins on line below" + leftX := (selectionStart stringIndex <= line first - leftX := (selectionStart stringIndex < line first ifTrue: [line ] ifFalse: [selectionStart ])left. rightX := (selectionStop stringIndex > (line last + 1) or: [selectionStop stringIndex = (line last + 1) and: [selectionStop textLine ~= line]]) ifTrue: [line right] ifFalse: [selectionStop left]. selectionStart = selectionStop ifTrue: [ rightX := rightX + 1. caretRect := (leftX-2) @ line top corner: (rightX+2)@ line bottom. "sigh..." self showCaret ifFalse: [^self]. w := (Editor dumbbellCursor ifTrue: [self displayDumbbellCursorOn: aCanvas at: leftX in: line] ifFalse: [self displaySimpleCursorOn: aCanvas at: leftX in: line]). caretRect := (leftX-w) @ line top corner: (rightX+w)@ line bottom] ifFalse: [ caretRect := nil. aCanvas fillRectangle: (leftX @ line top corner: rightX @ line bottom) color: (self focused ifTrue: [self selectionColor] ifFalse: [self unfocusedSelectionColor])]! Item was changed: ----- Method: NewParagraph>>selectionRectsFrom:to: (in category 'selection') ----- selectionRectsFrom: characterBlock1 to: characterBlock2 "Return an array of rectangles representing the area between the two character blocks given as arguments." | line1 line2 rects cb1 cb2 w | characterBlock1 <= characterBlock2 ifTrue: [cb1 := characterBlock1. cb2 := characterBlock2] ifFalse: [cb2 := characterBlock1. cb1 := characterBlock2]. cb1 = cb2 ifTrue: [w := self caretWidth. ^ Array with: (cb1 topLeft - (w@0) corner: cb1 bottomLeft + ((w+1)@0))]. line1 := self lineIndexOfCharacterIndex: cb1 stringIndex. line2 := self lineIndexOfCharacterIndex: cb2 stringIndex. + cb1 top = (lines at: line1) top + ifFalse: + ["a word did not fit on prev line - start selection on prev line" + line1 := line1 - 1]. line1 = line2 ifTrue: [^ Array with: (cb1 topLeft corner: cb2 bottomRight)]. rects := OrderedCollection new. rects addLast: (cb1 topLeft corner: (lines at: line1) bottomRight). line1+1 to: line2-1 do: [ :i | | line | line := lines at: i. (line left = rects last left and: [ line right = rects last right ]) ifTrue: [ "new line has same margins as old one -- merge them, so that the caller gets as few rectangles as possible" | lastRect | lastRect := rects removeLast. rects add: (lastRect bottom: line bottom) ] ifFalse: [ "differing margins; cannot merge" rects add: line rectangle ] ]. rects addLast: ((lines at: line2) topLeft corner: cb2 bottomLeft). ^ rects! 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>>filterEvent:for: (in category 'events-processing') ----- filterEvent: aKeyboardEvent for: anObject "Provide keyboard shortcuts." + - "Delegate keyboard shortcuts to my docking bars." self submorphsDo: [:ea | ea isDockingBar ifTrue: [ ea filterEvent: aKeyboardEvent for: anObject. "No support for converting events here!!" aKeyboardEvent wasIgnored ifTrue: [^ aKeyboardEvent "early out"]]]. aKeyboardEvent isKeystroke ifFalse: [^ aKeyboardEvent]. + - aKeyboardEvent commandKeyPressed ifTrue: [ aKeyboardEvent keyCharacter caseOf: { [$R] -> [Utilities browseRecentSubmissions]. [$L] -> [self findAFileList: aKeyboardEvent]. [$O] -> [self findAMonticelloBrowser]. [$P] -> [self findAPreferencesPanel: aKeyboardEvent]. "[$Z] -> [ChangeList browseRecentLog]." [$]] -> [Smalltalk snapshot: true andQuit: false]. + [$+] -> [Preferences increaseFontSize]. + [$-] -> [Preferences decreaseFontSize]. + [$=] -> [Preferences restoreDefaultFonts]. } otherwise: [^ aKeyboardEvent "no hit"]. ^ aKeyboardEvent ignore "hit!!"]. ^ aKeyboardEvent "no hit"! 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>>startSteppingSubmorphsOf: (in category 'world state') ----- startSteppingSubmorphsOf: aMorph - "Ensure that all submorphs of the given morph that want to be stepped are added to the step list. Typically used after adding a morph to the world." + self flag: #obsolete. "the intoWorld mechanism in addMorph nowadays takes care of adding submorphs to steplist" - aMorph allMorphsDo: [:m | - m wantsSteps ifTrue: [m arrangeToStartSteppingIn: m world]. - ] + " aMorph allMorphsDo: [:m | + aMorph ~~ m & m wantsSteps ifTrue: [ + m arrangeToStartSteppingIn: m world]]. + " + ! 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 added: + ----- Method: PluggableMultiColumnListMorph>>getListItem: (in category 'selection') ----- + getListItem: index + "get the index-th item in the displayed list" + getListElementSelector ifNotNil: [ ^(model perform: getListElementSelector with: index) asStringOrText ]. + list ifNotNil: [ ^list first at: index ]. "this is a very trivial fix for the issue of having rows ofdata in the multiple columns. It is *not* a robust solution" + ^self getList at: index! Item was changed: ----- Method: PluggableTextMorph class>>visualWrapBorder (in category 'preferences') ----- visualWrapBorder <preference: 'Show wrap border in code panes.' categoryList: #(editing visuals performance) + description: 'Show a visual border after a specific amount of characters. Makes sense for monospaced fonts.' - description: 'Show a visual border after a specific amout of characters. Makes sense for monospaced fonts.' type: #Boolean> ^ VisualWrapBorder ifNil: [false]! 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: RaisedBorder>>trackColorFrom: (in category 'color tracking') ----- trackColorFrom: aMorph + baseColor isTransparent ifTrue:[self color: aMorph raisedColor].! - baseColor ifNil:[self color: aMorph raisedColor].! 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: SmalltalkEditor>>handleEmphasisExtra:with: (in category 'editing keys') ----- handleEmphasisExtra: index with: aKeyboardEvent "Handle an extra emphasis menu item" | action attribute thisSel | action := { [attribute := TextDoIt new. + thisSel := attribute analyze: self selection]. - thisSel := attribute analyze: self selection asString]. [attribute := TextPrintIt new. + thisSel := attribute analyze: self selection]. - thisSel := attribute analyze: self selection asString]. [attribute := TextLink new. thisSel := attribute analyze: self selection asString with: 'Comment']. [attribute := TextLink new. thisSel := attribute analyze: self selection asString with: 'Definition']. [attribute := TextLink new. thisSel := attribute analyze: self selection asString with: 'Hierarchy']. [attribute := TextLink new. thisSel := attribute analyze: self selection asString]. [attribute := TextURL new. thisSel := attribute analyze: self selection asString]. ["Edit hidden info" thisSel := self hiddenInfo. "includes selection" attribute := TextEmphasis normal]. ["Copy hidden info" self copyHiddenInfo. ^true]. "no other action" } at: index. action value. thisSel ifNil: [^true]. "Could not figure out what to link to" attribute ifNotNil: [ thisSel ifEmpty:[ | oldAttributes | "only change emphasisHere while typing" oldAttributes := paragraph text attributesAt: self pointIndex. emphasisHere := Text addAttribute: attribute toArray: oldAttributes. ] ifNotEmpty: [ self replaceSelectionWith: (thisSel asText addAttribute: attribute). ] ]. ^true! 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: MorphicModel subclass: #SystemWindow instanceVariableNames: 'labelString stripes label closeBox collapseBox paneMorphs paneRects collapsedFrame fullFrame isCollapsed isActive isLookingFocused menuBox mustNotClose labelWidgetAllowance updatablePanes allowReframeHandles labelArea expandBox' + classVariableNames: 'ClickOnLabelToEdit CloseBoxFrame CloseBoxImageFlat CloseBoxImageGradient CollapseBoxImageFlat CollapseBoxImageGradient DoubleClickOnLabelToExpand DragToEdges ExpandBoxFrame ExpandBoxImageFlat ExpandBoxImageGradient FocusFollowsMouse GradientWindow HideExpandButton MenuBoxFrame MenuBoxImageFlat MenuBoxImageGradient ResizeAlongEdges ReuseWindows RoundedWindowCorners TopWindow WindowTitleActiveOnFirstClick WindowsRaiseOnClick' - classVariableNames: 'ClickOnLabelToEdit CloseBoxFrame CloseBoxImageFlat CloseBoxImageGradient CollapseBoxImageFlat CollapseBoxImageGradient DoubleClickOnLabelToExpand ExpandBoxFrame ExpandBoxImageFlat ExpandBoxImageGradient FocusFollowsMouse GradientWindow HideExpandButton MenuBoxFrame MenuBoxImageFlat MenuBoxImageGradient ResizeAlongEdges ReuseWindows RoundedWindowCorners TopWindow WindowTitleActiveOnFirstClick WindowsRaiseOnClick' poolDictionaries: '' category: 'Morphic-Windows'! !SystemWindow commentStamp: '<historical>' prior: 0! SystemWindow is the Morphic equivalent of StandardSystemView -- a labelled container for rectangular views, with iconic facilities for close, collapse/expand, and resizing. The attribute onlyActiveOnTop, if set to true (and any call to activate will set this), determines that only the top member of a collection of such windows on the screen shall be active. To be not active means that a mouse click in any region will only result in bringing the window to the top and then making it active.! Item was added: + ----- Method: SystemWindow class>>dragToEdges (in category 'preferences') ----- + dragToEdges + <preference: 'Drag To Edges' + category: 'windows' + description: 'When true, windows snap and resize to corners and edges of the Display.' + type: #Boolean> + ^DragToEdges ifNil: [false]! Item was added: + ----- Method: SystemWindow class>>dragToEdges: (in category 'preferences') ----- + dragToEdges: aBoolean + DragToEdges := aBoolean! Item was changed: ----- Method: SystemWindow>>doFastFrameDrag: (in category 'events') ----- doFastFrameDrag: grabPoint "Do fast frame dragging from the given point" + | offset newBounds outerWorldBounds clearArea | - | offset newBounds outerWorldBounds | outerWorldBounds := self boundsIn: nil. offset := outerWorldBounds origin - grabPoint. + clearArea := ActiveWorld clearArea. + newBounds := outerWorldBounds newRectFrom: [:f | + | p selector | + p := Sensor cursorPoint. + (self class dragToEdges and: [(selector := self dragToEdgesSelectorFor: p in: clearArea) notNil]) + ifTrue: [clearArea perform: selector] + ifFalse: [p + offset extent: outerWorldBounds extent]]. + self bounds: newBounds; comeToFront! - newBounds := outerWorldBounds newRectFrom: [:f | - Sensor cursorPoint + offset extent: outerWorldBounds extent]. - self position: (self globalPointToLocal: newBounds topLeft); comeToFront! Item was added: + ----- Method: SystemWindow>>dragToEdgeDistance (in category 'resize/collapse') ----- + dragToEdgeDistance + ^10! Item was added: + ----- Method: SystemWindow>>dragToEdgesSelectorFor:in: (in category 'resize/collapse') ----- + dragToEdgesSelectorFor: p in: a + "answer first matching drag resize selector, if none is found, answer nil" + #(isPoint:nearTopLeftOf: isPoint:nearTopRightOf: isPoint:nearBottomLeftOf: isPoint:nearBottomRightOf: isPoint:nearTopOf: isPoint:nearBottomOf: isPoint:nearLeftOf: isPoint:nearRightOf:) + with: #(topLeftQuadrant topRightQuadrant bottomLeftQuadrant bottomRightQuadrant topHalf bottomHalf leftHalf rightHalf) + do: [:predicate :selector | + (self perform: predicate with: p with: a) ifTrue: [^selector]]. + ^nil! Item was added: + ----- Method: SystemWindow>>isPoint:nearBottomLeftOf: (in category 'resize/collapse') ----- + isPoint: p nearBottomLeftOf: a + ^(self isPoint: p nearBottomOf: a) and: [self isPoint: p nearLeftOf: a]! Item was added: + ----- Method: SystemWindow>>isPoint:nearBottomOf: (in category 'resize/collapse') ----- + isPoint: p nearBottomOf: a + ^p y > (a bottom - self dragToEdgeDistance)! Item was added: + ----- Method: SystemWindow>>isPoint:nearBottomRightOf: (in category 'resize/collapse') ----- + isPoint: p nearBottomRightOf: a + ^(self isPoint: p nearBottomOf: a) and: [self isPoint: p nearRightOf: a]! Item was added: + ----- Method: SystemWindow>>isPoint:nearLeftOf: (in category 'resize/collapse') ----- + isPoint: p nearLeftOf: a + ^p x < (a left + self dragToEdgeDistance)! Item was added: + ----- Method: SystemWindow>>isPoint:nearRightOf: (in category 'resize/collapse') ----- + isPoint: p nearRightOf: a + ^p x > (a right - self dragToEdgeDistance)! Item was added: + ----- Method: SystemWindow>>isPoint:nearTopLeftOf: (in category 'resize/collapse') ----- + isPoint: p nearTopLeftOf: a + ^(self isPoint: p nearTopOf: a) and: [self isPoint: p nearLeftOf: a]! Item was added: + ----- Method: SystemWindow>>isPoint:nearTopOf: (in category 'resize/collapse') ----- + isPoint: p nearTopOf: a + ^p y < (a top + self dragToEdgeDistance)! Item was added: + ----- Method: SystemWindow>>isPoint:nearTopRightOf: (in category 'resize/collapse') ----- + isPoint: p nearTopRightOf: a + ^(self isPoint: p nearTopOf: a) and: [self isPoint: p nearRightOf: a]! Item was changed: ----- Method: SystemWindow>>setFramesForLabelArea (in category 'initialization') ----- setFramesForLabelArea "an aid to converting old instances, but then I found convertAlignment (jesse welton's note)" | frame | labelArea ifNil: [^ self]. labelArea layoutPolicy: TableLayout new; listDirection: #leftToRight; hResizing: #spaceFill; layoutInset: 0. label hResizing: #spaceFill. + {closeBox. menuBox. expandBox. collapseBox} do: [:box | + box ifNotNil: [box extent: self boxExtent]]. + frame := LayoutFrame new. + frame leftFraction: 0; + topFraction: 0; + rightFraction: 1; + bottomFraction: 0; + topOffset: self labelHeight negated. + labelArea layoutFrame: frame! - labelArea - ifNotNil: [frame := LayoutFrame new. - frame leftFraction: 0; - topFraction: 0; - rightFraction: 1; - bottomFraction: 0; - topOffset: self labelHeight negated. - labelArea layoutFrame: frame]! 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: TextEditor>>cursorHome: (in category 'nonediting/nontyping keys') ----- cursorHome: aKeyboardEvent "Private - Move cursor from position in current line to beginning of current line. If control key is pressed put cursor at beginning of text" | string | string := paragraph text string. self moveCursor: [ :position | Preferences wordStyleCursorMovement ifTrue:[ (paragraph lines at:(paragraph lineIndexOfCharacterIndex: position)) first] ifFalse:[ (string lastIndexOfAnyOf: CharacterSet crlf + startingAt: position - 1) + 1]] - startingAt: position - 1 - ifAbsent:[0]) + 1]] forward: false event: aKeyboardEvent specialBlock: [:dummy | 1]. ^true! Item was changed: ----- Method: TextEditor>>encompassLine: (in category 'new selection') ----- encompassLine: anInterval "Return an interval that encompasses the entire line" | string left right | string := paragraph text string. + left := (string lastIndexOfAnyOf: CharacterSet crlf startingAt: anInterval first - 1) + 1. - left := (string lastIndexOfAnyOf: CharacterSet crlf startingAt: anInterval first - 1 ifAbsent:[0]) + 1. right := (string indexOfAnyOf: CharacterSet crlf startingAt: anInterval last + 1 ifAbsent: [string size + 1]) - 1. ^left to: right! Item was changed: ----- Method: TextEditor>>inOutdent:delta: (in category 'editing keys') ----- inOutdent: aKeyboardEvent delta: delta "Add/remove a tab at the front of every line occupied by the selection. Flushes typeahead. Derived from work by Larry Tesler back in December 1985. Now triggered by Cmd-L and Cmd-R. 2/29/96 sw" + | realStart realStop lines startLine stopLine start stop adjustStart "indentation" numLines oldText newText newSize | - | realStart realStop lines startLine stopLine start stop adjustStart indentation numLines oldString newString newSize | "Operate on entire lines, but remember the real selection for re-highlighting later" realStart := self startIndex. realStop := self stopIndex - 1. "Special case a caret on a line of its own, including weird case at end of paragraph" (realStart > realStop and: [realStart < 2 or: [(paragraph string at: realStart - 1) == Character cr or: [(paragraph string at: realStart - 1) == Character lf]]]) ifTrue: [delta < 0 ifTrue: [morph flash] ifFalse: [self replaceSelectionWith: Character tab asText. self selectAt: realStart + 1]. ^true]. lines := paragraph lines. startLine := paragraph lineIndexOfCharacterIndex: realStart. "start on a real line, not a wrapped line" [startLine = 1 or: [CharacterSet crlf includes: (paragraph string at: (lines at: startLine-1) last)]] whileFalse: [startLine := startLine - 1]. stopLine := paragraph lineIndexOfCharacterIndex: (realStart max: realStop). start := (lines at: startLine) first. stop := (lines at: stopLine) last. + - "Pin the start of highlighting unless the selection starts a line" adjustStart := realStart > start. "Find the indentation of the least-indented non-blank line; never outdent more" + "indentation := (startLine to: stopLine) inject: 1000 into: - indentation := (startLine to: stopLine) inject: 1000 into: [:m :l | m min: (paragraph indentationOfLineIndex: l ifBlank: [:tabs | 1000])]. + indentation + delta <= 0 ifTrue: [^false]." - indentation + delta <= 0 ifTrue: ["^false"]. numLines := stopLine + 1 - startLine. + oldText := paragraph text copyFrom: start to: stop. + newText := oldText species new: oldText size + ((numLines * delta) max: 0). - oldString := paragraph string copyFrom: start to: stop. - newString := oldString species new: oldString size + ((numLines * delta) max: 0). "Do the actual work" newSize := 0. delta > 0 ifTrue: [| tabs | + tabs := oldText species new: delta withAll: Character tab. + oldText string lineIndicesDo: [:startL :endWithoutDelimiters :endL | + startL < endWithoutDelimiters ifTrue: [newText replaceFrom: 1 + newSize to: (newSize := newSize + delta) with: tabs startingAt: 1]. + newText replaceFrom: 1 + newSize to: (newSize := 1 + newSize + endL - startL) with: oldText startingAt: startL]] - tabs := oldString species new: delta withAll: Character tab. - oldString lineIndicesDo: [:startL :endWithoutDelimiters :endL | - startL < endWithoutDelimiters ifTrue: [newString replaceFrom: 1 + newSize to: (newSize := newSize + delta) with: tabs startingAt: 1]. - newString replaceFrom: 1 + newSize to: (newSize := 1 + newSize + endL - startL) with: oldString startingAt: startL]] ifFalse: [| tab | tab := Character tab. + oldText string lineIndicesDo: [:startL :endWithoutDelimiters :endL | - oldString lineIndicesDo: [:startL :endWithoutDelimiters :endL | | i | i := 0. + [i + delta < 0 and: [ i + startL <= endWithoutDelimiters and: [(oldText at: i + startL) == tab]]] whileTrue: [i := i + 1]. + newText replaceFrom: 1 + newSize to: (newSize := 1 + newSize + endL - (i + startL)) with: oldText startingAt: i + startL]]. + newSize < newText size ifTrue: [newText := newText copyFrom: 1 to: newSize]. - [i + delta < 0 and: [ i + startL <= endWithoutDelimiters and: [(oldString at: i + startL) == tab]]] whileTrue: [i := i + 1]. - newString replaceFrom: 1 + newSize to: (newSize := 1 + newSize + endL - (i + startL)) with: oldString startingAt: i + startL]]. - newSize < newString size ifTrue: [newString := newString copyFrom: 1 to: newSize]. "Adjust the range that will be highlighted later" adjustStart ifTrue: [realStart := (realStart + delta) max: start]. + realStop := realStop + newSize - oldText size. - realStop := realStop + newSize - oldString size. "Replace selection" self selectInvisiblyFrom: start to: stop. + self replaceSelectionWith: newText. - self replaceSelectionWith: newString asText. self selectFrom: realStart to: realStop. "highlight only the original range" ^ true! Item was changed: ----- Method: TextEditor>>querySymbol: (in category 'typing/selecting keys') ----- querySymbol: aKeyboardEvent "Invoked by Ctrl-q to query the Symbol table and display alternate symbols." | hintText lastOffering offering | (self isTypingIn not or: [self history current type ~= #query]) ifTrue: [ self closeTypeIn. self openTypeIn. self selectPrecedingIdentifier. self closeTypeIn]. self openTypeInFor: #query. hintText := self history current contentsBefore string. hintText := hintText copyFrom: (hintText lastIndexOfAnyOf: Character separators, '#' + startingAt: hintText size) + 1 to: hintText size. - startingAt: hintText size ifAbsent: [0])+1 to: hintText size. self selectInvisiblyFrom: self history current intervalBefore first to: self stopIndex-1. lastOffering := self selection string. lastOffering := (lastOffering copyReplaceAll: ': ' with: ':') withBlanksTrimmed. "Only offer suggestions for not-empty tokens." hintText ifEmpty: [morph flash. self closeTypeIn. ^ true]. offering := Symbol thatStarts: hintText skipping: lastOffering. offering ifNil: [offering := Symbol thatStarts: hintText skipping: nil]. offering ifNil: [morph flash. self closeTypeIn. ^ true]. "Add some nice spacing to the suggestion." offering := offering copyReplaceAll: ':' with: ': '. offering last = Character space ifTrue: [offering := offering allButLast]. "Insert the suggestions. (Note that due to previous selection, things will be overwritten and not appended.)" self typeAhead nextPutAll: offering. ^ false! Item was changed: ----- Method: TextEditor>>saveContentsInFile (in category 'menu messages') ----- saveContentsInFile "Save the receiver's contents string to a file, prompting the user for a file-name. Suggest a reasonable file-name." | fileName stringToSave parentWindow labelToUse suggestedName | stringToSave := paragraph text string. stringToSave size = 0 ifTrue: [^self inform: 'nothing to save.']. parentWindow := model dependents detect: [:dep | dep isKindOf: SystemWindow] ifNone: [nil]. labelToUse := parentWindow ifNil: ['Untitled'] ifNotNil: [parentWindow label]. suggestedName := nil. #(#('Decompressed contents of: ' '.gz')) do: [:leaderTrailer | | lastIndex | "can add more here..." (labelToUse beginsWith: leaderTrailer first) ifTrue: [suggestedName := labelToUse copyFrom: leaderTrailer first size + 1 to: labelToUse size. (labelToUse endsWith: leaderTrailer last) ifTrue: [suggestedName := suggestedName copyFrom: 1 to: suggestedName size - leaderTrailer last size] ifFalse: + [lastIndex := suggestedName lastIndexOf: $.. + lastIndex > 1 + ifTrue: [suggestedName := suggestedName copyFrom: 1 to: lastIndex - 1]]]]. - [lastIndex := suggestedName lastIndexOf: $. ifAbsent: [0]. - (lastIndex = 0 or: [lastIndex = 1]) - ifFalse: [suggestedName := suggestedName copyFrom: 1 to: lastIndex - 1]]]]. suggestedName ifNil: [suggestedName := labelToUse , '.text']. fileName := UIManager default request: 'File name?' initialAnswer: suggestedName. fileName isEmptyOrNil ifFalse: [(FileStream newFileNamed: fileName) nextPutAll: stringToSave; close]! 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>>anchorMorph:at:type: (in category 'anchors') ----- anchorMorph: aMorph at: aPoint type: anchorType | relPt index newText block | aMorph owner == self ifTrue:[self removeMorph: aMorph]. aMorph textAnchorType: nil. aMorph relativeTextAnchorPosition: nil. self addMorphFront: aMorph. aMorph textAnchorType: anchorType. aMorph relativeTextAnchorPosition: nil. anchorType == #document ifTrue:[^self]. relPt := self transformFromWorld globalPointToLocal: aPoint. index := (self paragraph characterBlockAtPoint: relPt) stringIndex. newText := Text string: (String value: 1) attribute: (TextAnchor new anchoredMorph: aMorph). anchorType == #inline ifTrue:[ self paragraph replaceFrom: index to: index-1 with: newText displaying: false. ] ifFalse:[ index := index min: paragraph text size. + index := paragraph text string lastIndexOf: Character cr startingAt: index. - index := paragraph text string lastIndexOf: Character cr startingAt: index ifAbsent:[0]. block := paragraph characterBlockForIndex: index+1. aMorph relativeTextAnchorPosition: (relPt x - bounds left) @ (relPt y - block top ). self paragraph replaceFrom: index+1 to: index with: newText displaying: false. ]. self fit.! 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: 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

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Packages March 2017