Marcel Taeumel uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-mt.1950.mcz
==================== Summary ====================
Name: Morphic-mt.1950
Author: mt
Time: 28 March 2022, 4:44:05.416636 pm
UUID: c3d26fbe-87b1-0248-84b9-03e0097e2d01
Ancestors: Morphic-ct.1949
Minor speed-up and less GC pressure when drawing the keyboard-focus indication.
=============== Diff against Morphic-ct.1949 ===============
Item was changed:
----- Method: Morph>>indicateKeyboardFocus (in category 'testing') -----
indicateKeyboardFocus
+ ^ (self valueOfProperty: #indicateKeyboardFocus ifAbsent: nil)
+ ifNil: [self class indicateKeyboardFocus]
+ ifNotNil: [:symbol | symbol ~~ #never]!
- ^ (self hasProperty: #indicateKeyboardFocus)
- ifTrue: [(self valueOfProperty: #indicateKeyboardFocus) ~~ #never]
- ifFalse: [self class indicateKeyboardFocus]!
Item was changed:
----- Method: Morph>>keyboardFocusColor (in category 'drawing') -----
keyboardFocusColor
+ ^ self
+ valueOfProperty: #keyboardFocusColor
+ ifAbsentPut: [self userInterfaceTheme keyboardFocusColor ifNil: [TranslucentColor r: 0.3 g: 0.5 b: 0.5 alpha: 0.5]]!
- ^ self userInterfaceTheme keyboardFocusColor ifNil: [TranslucentColor r: 0.3 g: 0.5 b: 0.5 alpha: 0.5]!
Item was changed:
----- Method: Morph>>keyboardFocusWidth (in category 'drawing') -----
keyboardFocusWidth
+ ^ self
+ valueOfProperty: #keyboardFocusWidth
+ ifAbsentPut: [((self userInterfaceTheme keyboardFocusWidth ifNil: [2])
+ * RealEstateAgent scaleFactor) truncated]!
- ^ ((self userInterfaceTheme keyboardFocusWidth ifNil: [2]) * RealEstateAgent scaleFactor) truncated!
Item was changed:
----- Method: ScrollPane>>setDefaultParameters (in category 'initialization') -----
setDefaultParameters
"change the receiver's appareance parameters"
self
color: (self userInterfaceTheme color ifNil: [Color white]);
borderStyle: (self userInterfaceTheme borderStyle ifNil: [BorderStyle simple]) copy;
borderColor: (self userInterfaceTheme borderColor ifNil: [Color gray: 0.6]);
+ borderWidth: ((self userInterfaceTheme borderWidth ifNil: [1]) * RealEstateAgent scaleFactor) truncated.
+
+ self removeProperty: #keyboardFocusWidth.
+ self removeProperty: #keyboardFocusColor.!
- borderWidth: ((self userInterfaceTheme borderWidth ifNil: [1]) * RealEstateAgent scaleFactor) truncated.!
1
0
Christoph Thiede uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-ct.1949.mcz
==================== Summary ====================
Name: Morphic-ct.1949
Author: ct
Time: 28 March 2022, 3:33:24.490426 pm
UUID: 6f511594-4ada-da4b-b01d-5dbe8befb2f1
Ancestors: Morphic-mt.1947
In menus, handle the 'delete' key to reset the current filter rather than appending a special character to the filter.
=============== Diff against Morphic-mt.1947 ===============
Item was added:
+ ----- Method: MenuMorph>>handleDelStroke: (in category 'keystroke helpers') -----
+ handleDelStroke: evt
+
+ evt keyCharacter = Character delete ifFalse: [^ false].
+ self
+ valueOfProperty: #matchString
+ ifPresentDo: [:str | "reset filter"
+ self setProperty: #matchString toValue: String new.
+ self selectItem: nil event: evt.
+ self displayFiltered: evt].
+ ^ true!
Item was changed:
----- Method: MenuMorph>>keyStrokeHandlers (in category 'keystroke helpers') -----
keyStrokeHandlers
^#(
handleCommandKeyPress:
handleCRStroke:
+ handleDelStroke:
handleEscStroke:
handleLeftStroke:
handleRightStroke:
handleUpStroke:
handleDownStroke:
handlePageUpStroke:
handlePageDownStroke:)!
1
0
Christoph Thiede uploaded a new version of Collections to project The Trunk:
http://source.squeak.org/trunk/Collections-ct.998.mcz
==================== Summary ====================
Name: Collections-ct.998
Author: ct
Time: 28 March 2022, 1:56:52.242267 pm
UUID: 74080f41-16ed-dc43-8f7c-1cd16bc91db7
Ancestors: Collections-ct.997
Adds literal arrays and scaled decimals to the smalltalk postcard. Removes obsolete line breaks from the comment.
=============== Diff against Collections-ct.997 ===============
Item was changed:
----- Method: Text class>>codeSample (in category 'filler text') -----
codeSample
^ 'exampleWithNumber: x
+ "A method that illustrates every part of Smalltalk method syntax including primitives. It has unary, binary, and keyboard messages; declares arguments and temporaries; accesses a global variable (but not an instance variable); uses literals (array, nested array, character, symbol, string, integer, float, scaled decimal, and byte array); uses the pseudo variables nil, true, false, self, super, and thisContext; shows that within a literal array nil, true, and false are symbols not pseudo variables; and has sequence, assignment, return, cascade, and tuple (array) creation. It has both zero argument and one argument blocks, and has a block temporary."
- "A method that illustrates every part of Smalltalk method syntax
- including primitives. It has unary, binary, and keyboard messages,
- declares arguments and temporaries, accesses a global variable
- (but not an instance variable), uses literals (array, character, symbol,
- string, integer, float, byte array), uses the pseudo variables nil, true,
- false, self, super, and thisContext, shows that within a literal array
- nil, true and false are symbols not pseudo variables, and has sequence,
- assignment, return, cascade, and tuple (array) creation. It has both
- zero argument and one argument blocks, and has a block temporary."
<primitive: ''primitiveCopyBits'' module: #BitBltPlugin error: ec>
| y |
true & false not & (nil isNil) ifFalse: [self halt].
y := self size + super size.
+ #($a #a ''a'' "a" (1 1.0 1.0s2) nil true false), { #[65]. thisContext. nil. true. false }
- #($a #a ''a'' "a" 1 1.0 nil true false), { #[65]. thisContext. nil. true. false }
do: [ :each | | class |
class := each class.
Transcript
show: (class name);
show: '' ''].
^ x < y'!
1
0
Marcel Taeumel uploaded a new version of PreferenceBrowser to project The Trunk:
http://source.squeak.org/trunk/PreferenceBrowser-mt.140.mcz
==================== Summary ====================
Name: PreferenceBrowser-mt.140
Author: mt
Time: 28 March 2022, 11:29:33.206448 am
UUID: 2334a5fb-5e75-7f41-bc1e-9c3bd9fc933d
Ancestors: PreferenceBrowser-mt.139
Complements System-mt.1331
=============== Diff against PreferenceBrowser-mt.139 ===============
Item was changed:
----- Method: PreferenceWizardMorph>>updateFromChangedScaleFactor (in category 'display scale') -----
updateFromChangedScaleFactor
- DisplayScreen displayIsFullScreen ifFalse: [
- DisplayScreen setNewScreenSize: (Display uiScaleFactor = 0.75
- ifTrue: [800@600]
- ifFalse: [(self defaultExtent * RealEstateAgent scaleFactor) rounded])].
-
checkmark := nil.
radiomark := nil.
self
layoutInset: (self defaultFont widthOf: $x) * 2;
cellGap: (self defaultFont widthOf: $x).
titleMorph
font: (UserInterfaceTheme current get: #wizardTitleFont);
margins: (self cellGap @ 0 corner: self cellGap @ self cellGap).
titleMorph layoutFrame
bottomOffset: titleMorph height.
self updateLowPerformanceLabel: lowPerformanceMorph contents.
"buttons"
{startButton. skipButton. previousButton. nextButton. doneButton},
(pages gather: [:page | page allMorphs select: [:ea | ea isButton]])
do: [:button |
((button owner hasProperty: #isRadioButton)
or: [button owner hasProperty: #isCheckbox])
ifTrue: [
button
"layoutInset: 0;"
extent: (TextStyle defaultFont height * 1.75) asPoint;
update: button getLabelSelector.
button owner cellGap: (TextStyle defaultFont widthOf: $x).
button owner balloonText ifNotNil: [:text |
text addAttribute: (TextFontReference toFont: (UserInterfaceTheme current get: #wizardHelpFont))]]
ifFalse: [
button
layoutInset: self defaultButtonMargins].
button
borderWidth: (2 * RealEstateAgent scaleFactor) truncated;
font: (UserInterfaceTheme current get: #wizardButtonFont);
updateMinimumExtent "Font might not change but PPI did."].
self fullBounds.
(startButton minimumWidth max: skipButton minimumWidth) in: [:w |
startButton hResizing: #rigid; width: w.
skipButton hResizing: #rigid; width: w.
startButton layoutFrame leftOffset: 2*w negated.
skipButton layoutFrame rightOffset: 2*w].
(previousButton minimumWidth max: nextButton minimumWidth) in: [:w |
previousButton hResizing: #rigid; width: w.
nextButton hResizing: #rigid; width: w].
pagesLabel
margins: (self layoutInset@0 corner: self layoutInset@0);
font: (UserInterfaceTheme current get: #wizardStandardFont).
buttonRowMorph
cellGap: self cellGap;
layoutInset: (0@self layoutInset corner: 0@0).
buttonRowMorph layoutFrame
topOffset: buttonRowMorph fullBounds height negated.
"labels"
{controlMorph firstSubmorph}, (pages gather: [:page | page allMorphs select: [:ea | ea isTextMorph]])
do: [:label |
label
font: (UserInterfaceTheme current get: #wizardStandardFont);
margins: self defaultTextMargins
"No need for #releaseParagraph because window resizing will happen anyway."].
"controlMorph"
controlMorph layoutInset: (0@0 corner: self cellGap@0).
controlMorph layoutFrame
topOffset: titleMorph height;
bottomOffset: buttonRowMorph height negated.
"scroll panes in pages"
pages do: [:page | | scrollPane |
page
layoutInset: (self layoutInset asPoint corner: self cellGap@0);
cellGap: self cellGap.
scrollPane := page submorphs second.
scrollPane scrollBarThickness: self layoutInset.
scrollPane scroller firstSubmorph
cellGap: self cellGap;
layoutInset: (0@0 corner: self cellGap@0).
(scrollPane vScrollBar instVarNamed: #slider)
borderWidth: (2 * RealEstateAgent scaleFactor) truncated].
"previewWorld"
previewWorld layoutFrame
topOffset: titleMorph height;
bottomOffset: buttonRowMorph height negated.
previewWorld borderWidth: (2 * RealEstateAgent scaleFactor) truncated.
self bounds: self world bounds.
self updateWindowBounds.
self updatePageVisibility.!
1
0
Marcel Taeumel uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-mt.1947.mcz
==================== Summary ====================
Name: Morphic-mt.1947
Author: mt
Time: 28 March 2022, 11:05:29.42409 am
UUID: 3d8c8c8f-c37b-e843-bd78-4fe4a1ab32e5
Ancestors: Morphic-ct.1946
Complements System-mt.1331.
=============== Diff against Morphic-ct.1946 ===============
Item was changed:
----- Method: BorderedMorph>>displayScaleChangedBy: (in category 'display scale') -----
displayScaleChangedBy: factor
"The system's scale factor has changed. Try to scale the receiver so that it looks nice on the display. See DisplayScreen >> #uiScaleFactor:."
self paneMorphs
select: [:ea | ea respondsTo: #displayScaleChangedBy:]
thenDo: [:ea | ea displayScaleChangedBy: factor].
+ self bounds: ((self topLeft * factor) rounded extent: (self extent * factor) rounded).
- "Scale my bounds. Is okay even if I am layouted in my owner. Keep the center. If you also change the world bounds, make sure to move the receiver after this."
- self bounds: ((self extent * factor) rounded center: self center).
self removeGrips; removePaneSplitters.
self cellGap: 0.
self paneMorphs do: [:ea | ea layoutFrame ifNotNil: [:frame |
frame topOffset: (frame topOffset * factor) rounded.
frame bottomOffset: (frame bottomOffset * factor) rounded.
frame leftOffset: (frame leftOffset * factor) rounded.
frame rightOffset: (frame rightOffset * factor) rounded]].
self wantsGrips ifTrue: [self addGrips].
self wantsPaneSplitters ifTrue: [self addPaneSplitters].!
Item was changed:
----- Method: MorphicProject>>displayScaleChangedFrom:to: (in category 'display') -----
displayScaleChangedFrom: oldFactor to: newFactor
"Update Morphic-specific geometry. Try to be more efficient than UI theme's #applyUserInterfaceTheme."
super displayScaleChangedFrom: oldFactor to: newFactor.
"Switching UI themes involves updating geometry for different fonts anyway. Maybe we can speed up this at some point by avoiding to refresh non-geometry properties such as colors."
UserInterfaceTheme current
basicApply;
+ scaleMorphicWorldBy: newFactor / oldFactor;
scaleMorphicToolsBy: newFactor / oldFactor.
!
1
0
Marcel Taeumel uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-mt.1331.mcz
==================== Summary ====================
Name: System-mt.1331
Author: mt
Time: 28 March 2022, 11:03:20.99909 am
UUID: ad69b8ce-b5e7-4343-a205-89bf6a262623
Ancestors: System-mt.1330
When changing the #uiScaleFactor, resize the window/world if not already done by the platform.
=============== Diff against System-mt.1330 ===============
Item was changed:
----- Method: UserInterfaceTheme>>fixFontsAndScaleAround: (in category 'private - fonts') -----
fixFontsAndScaleAround: applyThemeBlock
"Given that the receiver is the current UI theme, set the system's default fonts, which define RealEstateAgent's #scaleFactor. If the factor changes, resize open windows to make them fit the scaled contents. Note that themes can have arbitrary point sizes for their system font, even though it is not recommended. See TTCFont class >> #referencePointSize."
lastScaleFactor ifNil: [lastScaleFactor := RealEstateAgent scaleFactor].
"Due to the current font situation, update TextConstants."
(self get: #standardSystemFont) ifNotNil: [:font | self installSystemFont: font].
(self get: #standardFixedFont) ifNotNil: [:font | self installFixedFont: font].
"Propagate the receiver's properties across the system."
applyThemeBlock value.
"Due to the current real-estate manager situation, resize all windows. Works only for Morphic projects."
+ self scaleMorphicWorldBy: RealEstateAgent scaleFactor / lastScaleFactor.
self scaleMorphicToolsBy: RealEstateAgent scaleFactor / lastScaleFactor.
lastScaleFactor := nil.!
Item was added:
+ ----- Method: UserInterfaceTheme>>scaleMorphicWorldBy: (in category 'private - fonts') -----
+ scaleMorphicWorldBy: factor
+
+ (factor closeTo: 1) ifTrue: [^ self].
+
+ self flag: #todo. "mt: Once the UserInterfaceTheme does not fake any scale factors anymore and we are all-in with #isTTCBased, the following code can be moved to Project >> #displayScaleChangedFrom:to:. Note that we can stop faking when a low-resolution TTCFont starts looking okay but for now, we rely on pre-rendered StrikeFont."
+
+ (DisplayScreen displayIsFullScreen not
+ and: [Display extent = DisplayScreen actualScreenSize])
+ ifTrue: [ "The platform has not (yet?) adapted the window size but maybe the #platformScaleFactor. So we have to change the window size now to account for re-scaled tools. Note that projects should do #checkForNewScreenScaleFactor *before* #checkForNewScreenSize."
+ DisplayScreen setNewScreenSize: (Display extent * factor) rounded].!
1
0
Marcel Taeumel uploaded a new version of Graphics to project The Trunk:
http://source.squeak.org/trunk/Graphics-mt.505.mcz
==================== Summary ====================
Name: Graphics-mt.505
Author: mt
Time: 28 March 2022, 11:01:24.78109 am
UUID: 21fb6966-c70d-344e-9435-0a46778a197b
Ancestors: Graphics-mt.504
Tweaks the commentary around #uiScaleFactor.
=============== Diff against Graphics-mt.504 ===============
Item was changed:
----- Method: DisplayScreen>>uiScaleFactor (in category 'scale factor') -----
uiScaleFactor
+ "Answers the current scale factor used to configure all widgets, tools, or windows to be prepared for the current rendering system, i.e., BitBlt. Note that 1.0 is usually the design space for pixel-based metrics such as #borderWidth or #layoutInset (if not based on font metrics)."
- "Answers the current scale factor used to configure all widgets, tools, or windows to be prepared for the current rendering system, i.e., BitBlt. Note that 1.0 means 'pixel perfect'."
^ UserInterfaceTheme current isTTCBased
ifTrue: [TextStyle pixelsPerInch / 96.0 "Hide rounding errors in TTCFont >> #height."]
ifFalse: [RealEstateAgent scaleFactor roundTo: 0.25 "Force 25% steps. See, e.g., #doScale150."].!
Item was changed:
----- Method: DisplayScreen>>uiScaleFactor: (in category 'scale factor') -----
uiScaleFactor: aFloat
+ "Sets the effective scale factor for the user interface, i.e., all widgets, tools, and windows. Note that the user can override the #platformScaleFactor, which is just a hint recommended by the platform."
- "Sets the effective scale factor for the user interface, i.e., all widgets, tools, and windows. The user can override the CurrentScaleFactor recommended by the platform."
+ | oldPixelFactor newPixelFactor newScaleFactor |
+ newScaleFactor := aFloat max: 0.75.
+
+ (UserInterfaceTheme current canFakeScaleFactor: newScaleFactor) ifTrue: [
- | oldFactor newFactor |
- (UserInterfaceTheme current canFakeScaleFactor: aFloat) ifTrue: [
self flag: #isTTCBased.
+ ^ UserInterfaceTheme current applyScaled: newScaleFactor].
+
+ newScaleFactor = 0.75 ifTrue: [(Project uiManager
+ confirm: ('You are currently using <b>TrueType fonts</b>. Your requested scale factor of <b>{1}%</b> looks better using pre-rendered <b>pixel fonts</b>.<br><br>Do you want to switch to pixel fonts now?' translated format: {(newScaleFactor * 100) rounded}) asTextFromHtml
- ^ UserInterfaceTheme current applyScaled: aFloat].
-
- aFloat = 0.75 ifTrue: [(Project uiManager
- confirm: ('You are currently using <b>TrueType fonts</b>. Your requested scale factor of <b>{1}%</b> looks better using pre-rendered <b>pixel fonts</b>.<br><br>Do you want to switch to pixel fonts now?' translated format: {(aFloat * 100) rounded}) asTextFromHtml
title: 'Blurry Fonts Detected' translated) == true
+ ifTrue: [UserInterfaceTheme cleanUpAndReset. ^ self uiScaleFactor: newScaleFactor]].
- ifTrue: [UserInterfaceTheme cleanUpAndReset. ^ self uiScaleFactor: aFloat]].
+ "Do nothing if the factor is unchanged. For comparison, use actual pixel-based scale factor to account for rounding errors, instead of #uiScaleFactor."
+ oldPixelFactor := RealEstateAgent scaleFactor.
+ newScaleFactor = oldPixelFactor ifTrue: [^ self].
+
+ "Update system's PPI to then compute the new pixel-based scale factor."
+ TextStyle pixelsPerInch: 96.0 * newScaleFactor.
+ newPixelFactor := RealEstateAgent resetScaleFactor; scaleFactor.
- oldFactor := RealEstateAgent scaleFactor. "Use effective, pixel-based factor to account for rounding errors. See #isTTCBased and #uiScaleFactor."
- newFactor := aFloat max: 0.75.
- newFactor = oldFactor ifTrue: [^ self].
+ "Let the current project (kind) decide how to update the system."
+ Project current ifNotNil: [:p | p displayScaleChangedFrom: oldPixelFactor to: newPixelFactor].!
- TextStyle pixelsPerInch: 96.0 * aFloat.
- newFactor := RealEstateAgent resetScaleFactor; scaleFactor. "Again, account for rounding errors."
- Project current ifNotNil: [:p | p displayScaleChangedFrom: oldFactor to: newFactor].!
1
0
Christoph Thiede uploaded a new version of Sound to project The Trunk:
http://source.squeak.org/trunk/Sound-ct.88.mcz
==================== Summary ====================
Name: Sound-ct.88
Author: ct
Time: 26 March 2022, 7:56:05.035593 pm
UUID: d40ab95a-8643-a649-99ed-598a37950ddb
Ancestors: Sound-dtl.87
Uses FileDirectory slash in SampledInstrument examples. Thanks to David (dto)!
=============== Diff against Sound-dtl.87 ===============
Item was changed:
----- Method: SampledInstrument class>>readLoudAndStaccatoInstrument:fromDirectory: (in category 'instance creation') -----
+ readLoudAndStaccatoInstrument: instName fromDirectory: orchestraDir
- readLoudAndStaccatoInstrument: instName fromDirectory: orchestraDir
"SampledInstrument
readLoudAndStaccatoInstrument: 'oboe'
+ fromDirectory: 'Tosh/Sample Library/Orchestra'"
- fromDirectory: 'Tosh:Sample Library:Orchestra'"
-
| sampleSetDir memBefore memAfter loud short snd |
+ sampleSetDir := orchestraDir , FileDirectory slash , instName.
- sampleSetDir := orchestraDir, ':', instName.
memBefore := Smalltalk garbageCollect.
loud := SampledInstrument new readSampleSetFrom: sampleSetDir, ' f'.
short := SampledInstrument new readSampleSetFrom: sampleSetDir, ' stacc'.
memAfter := Smalltalk garbageCollect.
Transcript show:
instName, ': ', (memBefore - memAfter) printString,
' bytes; ', memAfter printString, ' bytes left'; cr.
AbstractSound soundNamed: instName, '-f&stacc' put:
(snd := SampledInstrument new
allSampleSets: loud;
staccatoLoudAndSoftSampleSet: short).
"fix slow attacks"
snd allNotes do: [:n | n firstSample: (n findStartPointForThreshold: 500)].
AbstractSound soundNamed: instName, '-f' put:
(snd := SampledInstrument new
allSampleSets: loud).
"fix slow attacks"
+ snd allNotes do: [:n | n firstSample: (n findStartPointForThreshold: 1000)].!
- snd allNotes do: [:n | n firstSample: (n findStartPointForThreshold: 1000)].
- !
Item was changed:
----- Method: SampledInstrument class>>readPizzInstrument:fromDirectory: (in category 'instance creation') -----
+ readPizzInstrument: instName fromDirectory: orchestraDir
- readPizzInstrument: instName fromDirectory: orchestraDir
"SampledInstrument
readPizzInstrument: 'violin'
+ fromDirectory: 'Tosh/Sample Library/Orchestra'"
- fromDirectory: 'Tosh:Sample Library:Orchestra'"
-
| sampleSetDir memBefore memAfter sampleSet snd |
+ sampleSetDir := orchestraDir , FileDirectory slash , instName , ' pizz'.
- sampleSetDir := orchestraDir, ':', instName, ' pizz'.
memBefore := Smalltalk garbageCollect.
sampleSet := SampledInstrument new readSampleSetFrom: sampleSetDir.
memAfter := Smalltalk garbageCollect.
Transcript show:
instName, ': ', (memBefore - memAfter) printString,
' bytes; ', memAfter printString, ' bytes left'; cr.
AbstractSound soundNamed: instName, '-pizz' put:
(snd := SampledInstrument new allSampleSets: sampleSet).
"fix slow attacks"
snd allNotes do: [:n |
n firstSample: (n findStartPointForThreshold: 1000)].
+ ^ snd!
- ^ snd
- !
1
0
Christoph Thiede uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-ct.1946.mcz
==================== Summary ====================
Name: Morphic-ct.1946
Author: ct
Time: 26 March 2022, 4:21:09.439018 pm
UUID: 365b0a35-0bbc-4647-aa0f-cb0cd0a8a8d8
Ancestors: Morphic-ct.1587, Morphic-ct.1945
Merges Morphic-ct.1587:
Add ultimative emphasisExtra "Custom attribute".
In any text editor, you can now press <opt>5, select "Custom attribute...", and enter a Smalltalk expression that produces a TextAttribute, such as `TextIndent tabs: 1` or `PluggableTextAttribute evalBlock: [self halt]`.
Revision: Extract method and type-check the evaluated attribute object.
=============== Diff against Morphic-ct.1587 ===============
Item was changed:
+ (PackageInfo named: 'Morphic') preamble: '"Turn off Morphic drawing because we are refactoring ActiveWorld, ActiveHand, and ActiveEvent."
+ Project current world setProperty: #shouldDisplayWorld toValue: false.'!
- (PackageInfo named: 'Morphic') preamble: 'PluggableListMorph allSubInstancesDo: [:m |
- m listMorph cellInset: 3@0].'!
Item was added:
+ ----- Method: AbstractFont>>lineGapForMorphs (in category '*Morphic-Widgets') -----
+ lineGapForMorphs
+ "Use this hook to control the compactness of Morphic views such as lists, trees, and buttons."
+
+ ^ MorphicProject useCompactLists
+ ifTrue: [0]
+ ifFalse: [self lineGap]!
Item was added:
+ ----- Method: AbstractFont>>lineGapSliceForMorphs (in category '*Morphic-Widgets') -----
+ lineGapSliceForMorphs
+ "Use this hook to control the compactness of Morphic views such as lists, trees, and buttons."
+
+ ^ MorphicProject useCompactLists
+ ifTrue: [0]
+ ifFalse: [self lineGapSlice]!
Item was added:
+ ----- Method: AbstractFont>>lineGridForMorphs (in category '*Morphic-Widgets') -----
+ lineGridForMorphs
+ "Use this hook to control the compactness of Morphic views such as lists, trees, and buttons."
+
+ ^ MorphicProject useCompactLists
+ ifTrue: [self height]
+ ifFalse: [self lineGrid]!
Item was changed:
Model subclass: #AbstractHierarchicalList
+ instanceVariableNames: 'currentSelection'
- instanceVariableNames: 'currentSelection myBrowser'
classVariableNames: ''
poolDictionaries: ''
category: 'Morphic-Explorer'!
!AbstractHierarchicalList commentStamp: '<historical>' prior: 0!
Contributed by Bob Arning as part of the ObjectExplorer package.
!
Item was removed:
- ----- Method: AbstractHierarchicalList>>perform:orSendTo: (in category 'message handling') -----
- perform: selector orSendTo: otherTarget
- "Selector was just chosen from a menu by a user. If can respond, then
- perform it on myself. If not, send it to otherTarget, presumably the
- editPane from which the menu was invoked."
-
- (self respondsTo: selector)
- ifTrue: [^ self perform: selector]
- ifFalse: [^ otherTarget perform: selector]!
Item was added:
+ ----- Method: AbstractHierarchicalList>>veryDeepInner: (in category 'copying') -----
+ veryDeepInner: aDeepCopier
+ "This method required to avoid copying my 'currentSelection'. See Object>>#veryDeepCopyWith:."
+ super veryDeepInner: aDeepCopier!
Item was changed:
----- Method: AbstractResizerMorph class>>gripThickness (in category 'preferences') -----
gripThickness
"A number in pixels that encodes the area were the user can target splitters or edge grips."
<preference: 'Grip Thickness'
+ categoryList: #(windows Accessibility)
- category: 'windows'
description: 'A number in pixels that encodes the area were the user can target splitters or edge grips such as in application windows. Bigger grips make it easier to click on them.'
type: #Number>
+ ^ ((GripThickness ifNil: [4]) * RealEstateAgent scaleFactor) rounded!
- ^ GripThickness ifNil: [4]!
Item was changed:
----- Method: AbstractResizerMorph class>>gripThickness: (in category 'preferences') -----
gripThickness: anInteger
+ GripThickness := anInteger ifNotNil: [(anInteger / RealEstateAgent scaleFactor) rounded].
- GripThickness := anInteger.
Project current restoreDisplay.
self flag: #todo. "mt: Update existing grips. This is challenging because it interferes with ProportionalLayoutPolicy, which is tricky to refresh from here for arbitrary morphs."!
Item was changed:
----- Method: AbstractResizerMorph class>>handleLength (in category 'preferences') -----
handleLength
<preference: 'Handle Length'
+ categoryList: #(windows Accessibility)
- category: 'windows'
description: 'AThe size of a grip handle if shown. Can be interpreted as width or height, depending of the resizer orientation. Does not affect the clickable area. See grip thickness for that.'
type: #Number>
+ ^ ((HandleLength ifNil: [16]) * RealEstateAgent scaleFactor) rounded!
- ^ HandleLength ifNil: [25]!
Item was changed:
----- Method: AbstractResizerMorph class>>handleLength: (in category 'preferences') -----
handleLength: anInteger
+ HandleLength := anInteger ifNotNil: [(anInteger / RealEstateAgent scaleFactor) rounded].
- HandleLength := anInteger.
Project current restoreDisplay.
self flag: #todo. "mt: Update existing grips. This is challenging because it interferes with ProportionalLayoutPolicy, which is tricky to refresh from here for arbitrary morphs."!
Item was changed:
----- Method: AbstractResizerMorph>>mouseDown: (in category 'event handling') -----
mouseDown: anEvent
+ self referencePoint: anEvent position - self position.!
- self referencePoint: anEvent position.!
Item was changed:
----- Method: AcceptableCleanTextMorph>>accept (in category 'menu commands') -----
accept
"Overridden to allow accept of clean text"
| textToAccept ok |
+ textToAccept := textMorph text.
- textToAccept := textMorph asText.
ok := setTextSelector isNil or:
[setTextSelector numArgs = 2
ifTrue:
[model
perform: setTextSelector
with: textToAccept
with: self]
ifFalse: [model perform: setTextSelector with: textToAccept]].
ok
ifTrue:
[self setText: self getText.
self hasUnacceptedEdits: false]!
Item was added:
+ DynamicVariable subclass: #ActiveEventVariable
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Worlds'!
+
+ !ActiveEventVariable commentStamp: 'mt 11/9/2020 08:50' prior: 0!
+ I refer to the event responsible for the current action. Inbetween event handling cycles my value will be last event from the previous cycle, usually a mouse event.
+
+ Please talk to me only through #currentEvent, which is understood by all objects.
+
+ For more information, see http://wiki.squeak.org/squeak/6647.!
Item was added:
+ ----- Method: ActiveEventVariable class>>default (in category 'accessing') -----
+ default
+
+ ^ self currentHand ifNotNil: [:hand | hand lastEvent]!
Item was added:
+ ----- Method: ActiveEventVariable class>>value:during: (in category 'accessing') -----
+ value: anObject during: aBlock
+ "For backword compatibility with 5.3 and earlier, still maintain the original global variable."
+
+ | priorEvent |
+ priorEvent := self value.
+ ActiveEvent := anObject.
+ ^ [super value: anObject during: aBlock] ensure: [
+ ActiveEvent == anObject ifTrue: [ActiveEvent := priorEvent]]!
Item was added:
+ DynamicVariable subclass: #ActiveHandVariable
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Worlds'!
+
+ !ActiveHandVariable commentStamp: 'mt 11/9/2020 08:50' prior: 0!
+ I refer to the hand that issued the event responsible for the current action. In a multi-user setup, this hand identifies which user-incarnation invoked the action. Inbetween event handling cycles, my value is equivalent to the current project's primary hand.
+
+ Please talk to me only through #currentHand, which is understood by all objects.
+
+ For more information, see http://wiki.squeak.org/squeak/6647.!
Item was added:
+ ----- Method: ActiveHandVariable class>>default (in category 'accessing') -----
+ default
+
+ ^ self currentWorld primaryHand!
Item was added:
+ ----- Method: ActiveHandVariable class>>value:during: (in category 'accessing') -----
+ value: anObject during: aBlock
+ "For backword compatibility with 5.3 and earlier, still maintain the original global variable."
+
+ | priorHand |
+ priorHand := self value.
+ ActiveHand := anObject.
+ ^ [super value: anObject during: aBlock] ensure: [
+ ActiveHand == anObject ifTrue: [ActiveHand := priorHand]]!
Item was added:
+ DynamicVariable subclass: #ActiveWorldVariable
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Worlds'!
+
+ !ActiveWorldVariable commentStamp: 'mt 11/9/2020 08:49' prior: 0!
+ I refer to the world currently in control of handling some event. Usually my value is identical with the current project's world, but for embedded worlds the world will change when event handling reaches the new (inner world) and will be restored when event handling leaves it.
+
+ Please talk to me only through #currentWorld, which is understood by all objects.
+
+ For more information, see http://wiki.squeak.org/squeak/6647.!
Item was added:
+ ----- Method: ActiveWorldVariable class>>default (in category 'accessing') -----
+ default
+
+ ^ Project current world!
Item was added:
+ ----- Method: ActiveWorldVariable class>>value:during: (in category 'accessing') -----
+ value: anObject during: aBlock
+ "For backword compatibility with 5.3 and earlier, still maintain the original global variable."
+
+ | priorWorld |
+ priorWorld := self value.
+ ActiveWorld := anObject.
+ ^ [super value: anObject during: aBlock] ensure: [
+ ActiveWorld == anObject ifTrue: [ActiveWorld := priorWorld]]!
Item was added:
+ ----- Method: AlternatePluggableListMorphOfMany>>mouseLeaveDragging: (in category 'event handling') -----
+ mouseLeaveDragging: anEvent
+ "Dragging means changing the list's multi-selection state. Thus, there is no support for drag-and-drop of elements within a selection."
+
+ self hoverRow: nil.
+ self resetPotentialDropRow.!
Item was changed:
----- Method: BalloonMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
+ self disableLayout: true.
+ self morphicLayerNumber: self class balloonLayer.
""
self beSmoothCurve.
offsetFromTarget := 0 @ 0.
self setDefaultParameters.!
Item was removed:
- ----- Method: BalloonMorph>>morphicLayerNumber (in category 'WiW support') -----
- morphicLayerNumber
-
- "helpful for insuring some morphs always appear in front of or behind others.
- smaller numbers are in front"
-
- ^5 "Balloons are very front-like things"!
Item was changed:
----- Method: BalloonMorph>>prepareToOpen (in category 'private') -----
prepareToOpen
"Override the color if not already set."
self userInterfaceTheme color ifNotNil: [ : col | self color: col].
self
lock ;
+ fullBounds!
- fullBounds ;
- setProperty: #morphicLayerNumber
- toValue: self morphicLayerNumber!
Item was added:
+ ----- Method: BorderedMorph>>addCellGapToLayoutFrames (in category 'resize handling') -----
+ addCellGapToLayoutFrames
+
+ self changeCellGapOfLayoutFrames: self cellGap.!
Item was added:
+ ----- Method: BorderedMorph>>addGrips (in category 'resize handling') -----
+ addGrips
+ "Always add both corner grips and edge grips."
+
+ self removeGrips.
+
+ self addCornerGrips.
+ self addEdgeGrips. !
Item was changed:
----- Method: BorderedMorph>>addMorph:fullFrame: (in category 'resize handling') -----
addMorph: aMorph fullFrame: aLayoutFrame
"Add aMorph according to aLayoutFrame."
+ self removeCellGapFromLayoutFrames.
- self cellGap > 0 ifTrue: [
- | left right bottom top spacing |
-
- spacing := self cellGap.
- left := aLayoutFrame leftOffset ifNil: [0].
- right := aLayoutFrame rightOffset ifNil: [0].
-
- bottom := aLayoutFrame bottomOffset ifNil: [0].
- top := aLayoutFrame topOffset ifNil: [0].
-
- "Add a spacing to the frame if it is not top or leftmost."
- aLayoutFrame leftFraction = 0
- ifFalse: [left := left + spacing]
- ifTrue: [
- "Expect another, resizable widget besides me if I have a fixed width."
- aLayoutFrame hasFixedWidth ifTrue: [right := right - spacing]].
- aLayoutFrame topFraction = 0
- ifFalse: [top := top + spacing]
- ifTrue: [
- "Expect another, resizable widget besides me if I have a fixed height."
- aLayoutFrame hasFixedHeight ifTrue: [bottom := bottom - spacing]].
-
- aLayoutFrame
- topOffset: top;
- bottomOffset: bottom;
- leftOffset: left;
- rightOffset: right].
-
super addMorph: aMorph fullFrame: aLayoutFrame.
+ self addCellGapToLayoutFrames.
self wantsPaneSplitters ifTrue: [self addPaneSplitters].!
Item was added:
+ ----- Method: BorderedMorph>>addPaneHSplitterAtBottomOfRow: (in category 'resize handling') -----
+ addPaneHSplitterAtBottomOfRow: someMorphs
+
+ | targetFrame targetY minX maxX splitter |
+ targetFrame := someMorphs first layoutFrame.
+ targetY := targetFrame bottomFraction.
+
+ minX := (someMorphs detectMin: [:each | each layoutFrame leftFraction]) layoutFrame leftFraction.
+ maxX := (someMorphs detectMax: [:each | each layoutFrame rightFraction]) layoutFrame rightFraction.
+
+ splitter := ProportionalSplitterMorph new beSplitsTopAndBottom; yourself.
+ splitter layoutFrame: (LayoutFrame
+ fractions: (minX @ targetY corner: maxX @ targetY)
+ offsets: (targetFrame leftOffset @ targetFrame bottomOffset
+ corner: targetFrame rightOffset @ 0)).
+
+ self addMorphBack: (splitter position: self position).!
Item was removed:
- ----- Method: BorderedMorph>>addPaneHSplitterBetween:and: (in category 'resize handling') -----
- addPaneHSplitterBetween: topMorph and: bottomMorphs
-
- | targetY minX maxX splitter |
- targetY := topMorph layoutFrame bottomFraction.
-
- minX := (bottomMorphs detectMin: [:each | each layoutFrame leftFraction]) layoutFrame leftFraction.
- maxX := (bottomMorphs detectMax: [:each | each layoutFrame rightFraction]) layoutFrame rightFraction.
- splitter := ProportionalSplitterMorph new beSplitsTopAndBottom; yourself.
- splitter layoutFrame: (LayoutFrame
- fractions: (minX @ targetY corner: maxX @ targetY)
- offsets: (((topMorph layoutFrame leftOffset ifNil: [0]) @ 0
- corner: (topMorph layoutFrame rightOffset ifNil: [0]) @ AbstractResizerMorph gripThickness)
- translateBy: 0 @ (topMorph layoutFrame bottomOffset ifNil: [0]))).
-
- self addMorphBack: (splitter position: self position).!
Item was changed:
----- Method: BorderedMorph>>addPaneHSplitters (in category 'resize handling') -----
addPaneHSplitters
| remaining targetY sameY |
remaining := self paneMorphs reject: [:each |
+ each layoutFrame isNil
+ or: [each layoutFrame bottomFraction = 1
+ or: [each layoutFrame hasFixedHeight]]].
- each layoutFrame bottomFraction = 1
- or: [each layoutFrame hasFixedHeight]].
[remaining notEmpty] whileTrue:
[targetY := remaining first layoutFrame bottomFraction.
sameY := self paneMorphs select: [:each | each layoutFrame bottomFraction = targetY].
+ self addPaneHSplitterAtBottomOfRow: sameY.
- self addPaneHSplitterBetween: remaining first and: sameY.
remaining := remaining copyWithoutAll: sameY]!
Item was added:
+ ----- Method: BorderedMorph>>addPaneVSplitterAtRightOfColumn: (in category 'resize handling') -----
+ addPaneVSplitterAtRightOfColumn: someMorphs
+
+ | targetFrame targetX minY maxY splitter |
+ targetFrame := someMorphs first layoutFrame.
+ targetX := targetFrame rightFraction.
+
+ minY := (someMorphs detectMin: [:each | each layoutFrame topFraction]) layoutFrame topFraction.
+ maxY := (someMorphs detectMax: [:each | each layoutFrame bottomFraction]) layoutFrame bottomFraction.
+
+ splitter := ProportionalSplitterMorph new beSplitsLeftAndRight; yourself.
+ splitter layoutFrame: (LayoutFrame
+ fractions: (targetX @ minY corner: targetX @ maxY)
+ offsets: (targetFrame rightOffset @ (targetFrame topOffset)
+ corner: (0 @ (targetFrame bottomOffset)))).
+
+ self addMorphBack: (splitter position: self position).!
Item was removed:
- ----- Method: BorderedMorph>>addPaneVSplitterBetween:and: (in category 'resize handling') -----
- addPaneVSplitterBetween: leftMorph and: rightMorphs
-
- | targetX minY maxY splitter |
- targetX := leftMorph layoutFrame rightFraction.
- minY := (rightMorphs detectMin: [:each | each layoutFrame topFraction]) layoutFrame topFraction.
- maxY := (rightMorphs detectMax: [:each | each layoutFrame bottomFraction]) layoutFrame bottomFraction.
-
- splitter := ProportionalSplitterMorph new.
- splitter layoutFrame: (LayoutFrame
- fractions: (targetX @ minY corner: targetX @ maxY)
- offsets: ((0 @ (leftMorph layoutFrame topOffset ifNil: [0]) corner: (AbstractResizerMorph gripThickness@ (leftMorph layoutFrame bottomOffset ifNil: [0]))) translateBy: (leftMorph layoutFrame rightOffset ifNil: [0]) @ 0)).
-
- self addMorphBack: (splitter position: self position).!
Item was changed:
----- Method: BorderedMorph>>addPaneVSplitters (in category 'resize handling') -----
addPaneVSplitters
| remaining targetX sameX |
remaining := self paneMorphs reject: [:each |
+ each layoutFrame isNil
+ or: [each layoutFrame rightFraction = 1
+ or: [each layoutFrame hasFixedWidth]]].
- each layoutFrame rightFraction = 1
- or: [each layoutFrame hasFixedWidth]].
[remaining notEmpty] whileTrue:
[targetX := remaining first layoutFrame rightFraction.
sameX := self paneMorphs select: [:each | each layoutFrame rightFraction = targetX].
+ self addPaneVSplitterAtRightOfColumn: sameX.
- self addPaneVSplitterBetween: remaining first and: sameX.
remaining := remaining copyWithoutAll: sameX]!
Item was added:
+ ----- Method: BorderedMorph>>cellGap: (in category 'layout properties') -----
+ cellGap: aNumber
+
+ self cellGap = aNumber ifTrue: [^ self].
+
+ self removeCellGapFromLayoutFrames.
+ super cellGap: aNumber.
+ self addCellGapToLayoutFrames.
+
+ (self wantsPaneSplitters and: [aNumber > 0])
+ ifTrue: [self addPaneSplitters]
+ ifFalse: [self removePaneSplitters].!
Item was added:
+ ----- Method: BorderedMorph>>changeCellGapOfLayoutFrames: (in category 'resize handling') -----
+ changeCellGapOfLayoutFrames: delta
+ "Enumerate all submorphs' #layoutFrame and change their offsets the amount of the receiver's #cellGap to that #addPaneSplitters can work. NOTE THAT not fully general-purpose and the rules a little bit hacky, currently optimized for horizontal text fields and button rows that have a fixed height besides a resizable widget such as other text fields or lists. Most challenging layouts include MessageNames and MCOperationsBrowser (incl. variations)."
+
+ | frames |
+ delta = 0 ifTrue: [^ self].
+
+ "For robustness, only work on submorphs that have their layout frame set."
+ frames := self paneMorphs
+ select: [:ea | ea layoutFrame notNil]
+ thenCollect: [:ea | ea layoutFrame].
+
+ frames ifEmpty: [^ self].
+
+ "Sort all frames to prioritize the ones with fixed height, e.g., button rows or one-liners."
+ frames := frames sorted: [:a :b |
+ (a hasFixedHeight and: [b hasFixedHeight not])
+ or: [a hasFixedHeight = b hasFixedHeight
+ and: [a topFraction < b topFraction]] ].
+
+ "Enumerate all frames and add the gap by changing the corresponding offsets."
+ frames do: [:thisFrame |
+ | left right bottom top |
+
+ "First, the easy part. Left and right offsets."
+ left := thisFrame leftOffset.
+ right := thisFrame rightOffset.
+
+ thisFrame leftFraction = 0
+ ifFalse: [ "Add a spacing to the frame if it is not top or leftmost."
+ left := left + delta]
+ ifTrue: [ "Expect another, resizable widget besides me if I have a fixed width."
+ thisFrame hasFixedWidth ifTrue: [right := right - delta]].
+
+ "Second, the tricky part. Optimized for fixed button rows and text lines."
+ bottom := thisFrame bottomOffset.
+ top := thisFrame topOffset.
+
+ thisFrame topFraction = 0 ifTrue: [ "Special treatment for the topmost row"
+ (frames anySatisfy: [:otherFrame | otherFrame ~~ thisFrame
+ "Is there any otherFrame that hasFixedHeight with whom thisFrame shares the topFraction?"
+ and: [otherFrame hasFixedHeight
+ and: [otherFrame leftFraction <= thisFrame leftFraction
+ and: [otherFrame rightFraction >= thisFrame rightFraction
+ and: [otherFrame topFraction = thisFrame topFraction]]]] ])
+ ifTrue: [ "Okay, make room for that otherFrame."
+ top := top + delta.
+ thisFrame hasFixedHeight ifTrue: [
+ "If thisFrame happens to be fixed too, be sure to not change its height."
+ bottom := bottom + delta ]] ].
+
+ (frames anySatisfy: [:otherFrame | otherFrame ~~ thisFrame
+ "Is there any otherFrame that hasFixedHeight with whom thisFrame shares the bottomFraction?"
+ and: [otherFrame hasFixedHeight
+ and: [otherFrame leftFraction <= thisFrame leftFraction
+ and: [otherFrame rightFraction >= thisFrame rightFraction
+ and: [otherFrame bottomFraction = thisFrame bottomFraction]]]] ])
+ ifTrue: [ "Okay, make room for that otherFrame."
+ bottom := bottom - delta.
+ thisFrame hasFixedHeight ifTrue: [
+ "If thisFrame happens to be fixed too, be sure to not change its height."
+ top := top - delta ]].
+
+ thisFrame bottomFraction ~= 1 ifTrue: [ "Basic treatment for all (inner) rows"
+ (thisFrame hasFixedHeight not or: [thisFrame topFraction ~= 0])
+ ifTrue: [ "All inner frames whould make room at the bottom except for topmost fixed ones, which we already treated above."
+ bottom := bottom - delta.
+ thisFrame hasFixedHeight ifTrue: [
+ "If thisFrame happens to be fixed too, be sure to not change its height."
+ top := top - delta ]] ].
+
+ "We are finished. Remember the new offsets."
+ thisFrame
+ topOffset: top;
+ bottomOffset: bottom;
+ leftOffset: left;
+ rightOffset: right].
+
+ self layoutChanged.!
Item was added:
+ ----- Method: BorderedMorph>>cornerGrips (in category 'resize handling') -----
+ cornerGrips
+
+ ^ self submorphsSatisfying: [:each | (each isKindOf: CornerGripMorph) and: [(each isKindOf: BorderGripMorph) not]]!
Item was added:
+ ----- Method: BorderedMorph>>displayScaleChangedBy: (in category 'display scale') -----
+ displayScaleChangedBy: factor
+ "The system's scale factor has changed. Try to scale the receiver so that it looks nice on the display. See DisplayScreen >> #uiScaleFactor:."
+
+ self paneMorphs
+ select: [:ea | ea respondsTo: #displayScaleChangedBy:]
+ thenDo: [:ea | ea displayScaleChangedBy: factor].
+
+ "Scale my bounds. Is okay even if I am layouted in my owner. Keep the center. If you also change the world bounds, make sure to move the receiver after this."
+ self bounds: ((self extent * factor) rounded center: self center).
+
+ self removeGrips; removePaneSplitters.
+ self cellGap: 0.
+
+ self paneMorphs do: [:ea | ea layoutFrame ifNotNil: [:frame |
+ frame topOffset: (frame topOffset * factor) rounded.
+ frame bottomOffset: (frame bottomOffset * factor) rounded.
+ frame leftOffset: (frame leftOffset * factor) rounded.
+ frame rightOffset: (frame rightOffset * factor) rounded]].
+
+ self wantsGrips ifTrue: [self addGrips].
+ self wantsPaneSplitters ifTrue: [self addPaneSplitters].!
Item was changed:
----- Method: BorderedMorph>>doFastWindowReframe: (in category 'resize handling') -----
doFastWindowReframe: ptName
+ | newBounds delta |
- | newBounds |
"For fast display, only higlight the rectangle during loop"
newBounds := self bounds newRectButtonPressedDo: [:f |
f
withSideOrCorner: ptName
setToPoint: (self pointFromWorld: Sensor cursorPoint)
minExtent: self minimumExtent].
+ delta := newBounds origin - self bounds origin.
self bounds: newBounds.
+ self flag: #workaround. "mt: Due to a layout-specific 'let us start in the top-left corner of a layout cell'-behavior, we have to go up the owner chain and propagate the delta. See Morph >> #layoutInBounds:positioning: and there section 1.2."
+ self allOwnersDo: [:owner |
+ (owner layoutPolicy notNil and: [owner ~~ Project current world])
+ ifTrue: [owner topLeft: owner topLeft + delta]].
^newBounds.!
Item was added:
+ ----- Method: BorderedMorph>>edgeGrips (in category 'resize handling') -----
+ edgeGrips
+
+ ^ self submorphsSatisfying: [:each | each isKindOf: BorderGripMorph]!
Item was changed:
----- Method: BorderedMorph>>linkSubmorphsToSplitters (in category 'resize handling') -----
linkSubmorphsToSplitters
self splitters do: [:splitter |
splitter splitsTopAndBottom ifTrue: [
self submorphsDo: [:morph |
((morph ~= splitter
and: [morph layoutFrame bottomFraction = splitter layoutFrame topFraction])
and: [morph layoutFrame hasFixedHeight not
+ or: [(morph layoutFrame topOffset) < 0]])
- or: [(morph layoutFrame topOffset ifNil: [0]) < 0]])
ifTrue: [splitter addLeftOrTop: morph].
((morph ~= splitter
and: [morph layoutFrame topFraction = splitter layoutFrame bottomFraction])
and: [morph layoutFrame hasFixedHeight not
+ or: [(morph layoutFrame bottomOffset) > 0]])
- or: [(morph layoutFrame bottomOffset ifNil: [0]) > 0]])
ifTrue: [splitter addRightOrBottom: morph]]].
splitter splitsLeftAndRight ifTrue: [
self submorphsDo: [:morph |
((morph ~= splitter
and: [morph layoutFrame rightFraction = splitter layoutFrame leftFraction])
and: [morph layoutFrame hasFixedWidth not
+ or: [(morph layoutFrame leftOffset) < 0]])
- or: [(morph layoutFrame leftOffset ifNil: [0]) < 0]])
ifTrue: [splitter addLeftOrTop: morph].
((morph ~= splitter
and: [morph layoutFrame leftFraction = splitter layoutFrame rightFraction])
and: [morph layoutFrame hasFixedWidth not
+ or: [(morph layoutFrame rightOffset) > 0]])
- or: [(morph layoutFrame rightOffset ifNil: [0]) > 0]])
ifTrue: [splitter addRightOrBottom: morph]]]]!
Item was changed:
----- Method: BorderedMorph>>paneMorphs (in category 'resize handling') -----
paneMorphs
+ ^ self submorphs copyWithoutAll: self splitters, self grips!
- ^ self submorphs copyWithoutAll: self splitters!
Item was added:
+ ----- Method: BorderedMorph>>removeCellGapFromLayoutFrames (in category 'resize handling') -----
+ removeCellGapFromLayoutFrames
+
+ self changeCellGapOfLayoutFrames: self cellGap negated.!
Item was changed:
----- Method: BorderedMorph>>removeCornerGrips (in category 'resize handling') -----
removeCornerGrips
+ self cornerGrips do: [:each | each delete].!
- | corners |
- corners := self submorphsSatisfying: [:each | each isKindOf: CornerGripMorph].
- corners do: [:each | each delete]!
Item was added:
+ ----- Method: BorderedMorph>>removeEdgeGrips (in category 'resize handling') -----
+ removeEdgeGrips
+
+ self edgeGrips do: [:ea | ea delete].!
Item was added:
+ ----- Method: BorderedMorph>>removeGrips (in category 'resize handling') -----
+ removeGrips
+
+ self removeCornerGrips.
+ self removeEdgeGrips.!
Item was added:
+ ----- Method: BorderedMorph>>wantsGrips (in category 'resize handling') -----
+ wantsGrips
+
+ ^ self valueOfProperty: #allowGrips ifAbsent: [false]!
Item was added:
+ ----- Method: BorderedMorph>>wantsGrips: (in category 'resize handling') -----
+ wantsGrips: aBoolean
+
+ self setProperty: #allowGrips toValue: aBoolean.!
Item was changed:
----- Method: BottomLeftGripMorph>>apply: (in category 'target resize') -----
apply: delta
| oldBounds |
oldBounds := self target bounds.
self target
+ bounds: (oldBounds origin + (delta x @ 0) corner: oldBounds corner + (0 @ delta y)).
+ self flag: #workaround. "mt: Due to a layout-specific 'let us start in the top-left corner of a layout cell'-behavior, we have to go up the owner chain and propagate the delta. See Morph >> #layoutInBounds:positioning: and there section 1.2."
+ self target allOwnersDo:
+ [:anOwner |
+ (anOwner layoutPolicy notNil and: [anOwner ~~ Project current world])
+ ifTrue: [anOwner left: anOwner left + delta x]].!
- bounds: (oldBounds origin + (delta x @ 0) corner: oldBounds corner + (0 @ delta y))!
Item was added:
+ ----- Method: Browser>>displayClass: (in category '*Morphic-Menus-DockingBar-accessing') -----
+ displayClass: aClass
+ "Assuming the receiver has answered true to isDisplayingClass:, come to the front and select the given class."
+ | index |
+ index := self multiWindowIndexForClassName: aClass name.
+ index ~= 0 ifTrue:
+ [multiWindowState selectWindowIndex: index.
+ ^(multiWindowState models at: index) selectClass: aClass].
+ self selectClass: aClass!
Item was added:
+ ----- Method: Browser>>isDisplayingClass: (in category '*Morphic-Menus-DockingBar-accessing') -----
+ isDisplayingClass: aClass
+ | className |
+ className := aClass name.
+ (self multiWindowIndexForClassName: className) ~= 0 ifTrue: [^true].
+ ^selectedClassName = className!
Item was added:
+ ----- Method: Browser>>multiWindowIndexForClassName: (in category '*Morphic-Menus-DockingBar-accessing') -----
+ multiWindowIndexForClassName: className
+ "Answer the index of a browser displaying className in multiWindowState, if any.
+ Otherwise answer zero."
+ multiWindowState ifNil: [^0].
+ multiWindowState models withIndexDo:
+ [:browser :index|
+ browser selectedClassName = className ifTrue: [^index]].
+ ^0!
Item was removed:
- ----- Method: Canvas>>image:at: (in category 'drawing-obsolete') -----
- image: aForm at: aPoint
- "Note: This protocol is deprecated. Use #paintImage: instead."
- self image: aForm
- at: aPoint
- sourceRect: aForm boundingBox
- rule: Form paint.
- !
Item was removed:
- ----- Method: Canvas>>image:at:rule: (in category 'drawing-obsolete') -----
- image: aForm at: aPoint rule: combinationRule
- "Note: This protocol is deprecated. Use one of the explicit image drawing messages (#paintImage, #drawImage) instead."
- self image: aForm
- at: aPoint
- sourceRect: aForm boundingBox
- rule: combinationRule.
- !
Item was removed:
- ----- Method: Canvas>>imageWithOpaqueWhite:at: (in category 'drawing-obsolete') -----
- imageWithOpaqueWhite: aForm at: aPoint
- "Note: This protocol is deprecated. Use #drawImage: instead"
- self image: aForm
- at: aPoint
- sourceRect: (0@0 extent: aForm extent)
- rule: Form over.
- !
Item was changed:
----- Method: CircleMorph class>>supplementaryPartsDescriptions (in category 'parts bin') -----
supplementaryPartsDescriptions
"Extra items for parts bins"
^ {DescriptionForPartsBin
formalName: 'Circle' translatedNoop
categoryList: {'Graphics' translatedNoop}
documentation: 'A circular shape' translatedNoop
globalReceiverSymbol: #CircleMorph
+ nativitySelector: #newStandAlone}!
- nativitySelector: #newStandAlone.
-
- DescriptionForPartsBin
- formalName: 'Pin' translatedNoop
- categoryList: {'Connectors' translatedNoop}
- documentation: 'An attachment point for Connectors that you can embed in another Morph.' translatedNoop
- globalReceiverSymbol: #NCPinMorph
- nativitySelector: #newPin.
- }!
Item was added:
+ ----- Method: CircleMorph>>heading (in category 'rotate scale and flex') -----
+ heading
+ "Overwritten to store the angle in #forwardDirection."
+
+ ^ self rotationDegrees!
Item was changed:
+ ----- Method: CircleMorph>>heading: (in category 'rotate scale and flex') -----
- ----- Method: CircleMorph>>heading: (in category 'geometry eToy') -----
heading: newHeading
+ "Overwritten to store the angle in #forwardDirection."
+
- "Set the receiver's heading (in eToy terms).
- Note that circles never use flex shells."
self rotationDegrees: newHeading.!
Item was changed:
----- Method: CollapsedMorph>>uncollapseToHand (in category 'collapse/expand') -----
uncollapseToHand
"Hand the uncollapsedMorph to the user, placing it in her hand, after remembering appropriate state for possible future use"
| nakedMorph |
nakedMorph := uncollapsedMorph.
uncollapsedMorph := nil.
nakedMorph setProperty: #collapsedPosition toValue: self position.
mustNotClose := false. "so the delete will succeed"
self delete.
+ self currentHand attachMorph: nakedMorph.!
- ActiveHand attachMorph: nakedMorph!
Item was added:
+ ----- Method: Collection>>explorerContents (in category '*Morphic-Explorer') -----
+ explorerContents
+
+ ^self explorerContentsWithIndexCollect: [:value :index |
+ ObjectExplorerWrapper
+ with: value
+ name: index printString
+ model: self]!
Item was added:
+ ----- Method: Collection>>explorerContentsWithIndexCollect: (in category '*Morphic-Explorer') -----
+ explorerContentsWithIndexCollect: twoArgBlock
+
+ ^ self asOrderedCollection withIndexCollect: twoArgBlock
+ !
Item was changed:
----- Method: ColorPatchCanvas>>transformBy:clippingTo:during:smoothing: (in category 'drawing-support') -----
transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
"Note: This method has been originally copied from TransformationMorph."
| innerRect patchRect sourceQuad warp start subCanvas |
+ aDisplayTransform isPureTranslation ifTrue: [
+ ^ self
+ translateBy: (aDisplayTransform localPointToGlobal: 0@0) truncated
+ clippingTo: aClipRect
+ during: aBlock].
- (aDisplayTransform isPureTranslation) ifTrue:[
- subCanvas := self copyOffset: aDisplayTransform offset negated truncated
- clipRect: aClipRect.
- aBlock value: subCanvas.
- foundMorph := subCanvas foundMorph.
- ^self
- ].
"Prepare an appropriate warp from patch to innerRect"
innerRect := aClipRect.
patchRect := aDisplayTransform globalBoundsToLocal:
(self clipRect intersect: innerRect).
sourceQuad := (aDisplayTransform sourceQuadFor: innerRect)
collect: [:p | p - patchRect topLeft].
warp := self warpFrom: sourceQuad toRect: innerRect.
warp cellSize: cellSize.
"Render the submorphs visible in the clipping rectangle, as patchForm"
start := (self depth = 1 and: [self isShadowDrawing not])
"If this is true B&W, then we need a first pass for erasure."
ifTrue: [1] ifFalse: [2].
start to: 2 do:
[:i | "If i=1 we first make a shadow and erase it for opaque whites in B&W"
subCanvas := ColorPatchCanvas extent: patchRect extent depth: self depth.
subCanvas stopMorph: stopMorph.
subCanvas foundMorph: foundMorph.
subCanvas doStop: doStop.
i=1 ifTrue: [subCanvas shadowColor: Color black.
warp combinationRule: Form erase]
ifFalse: [self isShadowDrawing ifTrue:
[subCanvas shadowColor: self shadowColor].
warp combinationRule: Form paint].
subCanvas
translateBy: patchRect topLeft negated
during: aBlock.
i = 2 ifTrue:[foundMorph := subCanvas foundMorph].
warp sourceForm: subCanvas form; warpBits.
warp sourceForm: nil. subCanvas := nil "release space for next loop"]
!
Item was changed:
+ ----- Method: ColorPickerMorph>>delete (in category 'submorphs - add/remove') -----
- ----- Method: ColorPickerMorph>>delete (in category 'submorphs-add/remove') -----
delete
"The moment of departure has come.
If the receiver has an affiliated command, finalize it and have the system remember it.
In any case, delete the receiver"
(selector isNil or: [ target isNil ]) ifFalse: [
self rememberCommand:
(Command new
cmdWording: 'color change' translated;
undoTarget: target selector: selector arguments: (self argumentsWith: originalColor);
redoTarget: target selector: selector arguments: (self argumentsWith: selectedColor)).
].
super delete!
Item was changed:
----- Method: ColorPickerMorph>>putUpFor:near: (in category 'other') -----
putUpFor: aMorph near: aRectangle
"Put the receiver up on the screen. Note highly variant behavior depending on the setting of the #modalColorPickers preference"
| layerNumber |
aMorph isMorph ifTrue: [
layerNumber := aMorph morphicLayerNumber.
aMorph allOwnersDo:[:m|
layerNumber := layerNumber min: m morphicLayerNumber].
+ self morphicLayerNumber: layerNumber - 0.1
- self setProperty: #morphicLayerNumber toValue: layerNumber - 0.1
].
isModal == true "backward compatibility"
ifTrue:
[self pickUpColorFor: aMorph]
ifFalse:
[self addToWorld:
((aMorph notNil and: [aMorph world notNil])
ifTrue:
[aMorph world]
ifFalse:
[self currentWorld])
near:
(aRectangle ifNil:
[aMorph ifNil: [100@100 extent: 1@1] ifNotNil: [aMorph fullBoundsInWorld]])]!
Item was changed:
+ ----- Method: ComplexProgressIndicator>>addProgressDecoration: (in category 'private') -----
- ----- Method: ComplexProgressIndicator>>addProgressDecoration: (in category 'as yet unclassified') -----
addProgressDecoration: extraParam
| f m |
targetMorph ifNil: [^self].
(extraParam isForm)
ifTrue:
[targetMorph
submorphsDo: [:mm | (mm isSketchMorph) ifTrue: [mm delete]].
f := Form extent: extraParam extent depth: extraParam depth.
extraParam displayOn: f.
m := SketchMorph withForm: f.
m align: m fullBounds leftCenter
with: targetMorph fullBounds leftCenter + (2 @ 0).
targetMorph addMorph: m.
^self].
(extraParam isString)
ifTrue:
[targetMorph
submorphsDo: [:mm | (mm isKindOf: StringMorph) ifTrue: [mm delete]].
m := StringMorph contents: extraParam translated.
m align: m fullBounds bottomCenter + (0 @ 8)
with: targetMorph bounds bottomCenter.
targetMorph addMorph: m.
^self]!
Item was changed:
+ ----- Method: ComplexProgressIndicator>>backgroundWorldDisplay (in category 'private') -----
- ----- Method: ComplexProgressIndicator>>backgroundWorldDisplay (in category 'as yet unclassified') -----
backgroundWorldDisplay
| world |
self flag: #bob. "really need a better way to do this"
"World displayWorldSafely."
"ugliness to try to track down a possible error"
world := Project current world.
[world displayWorld] ifError: [ :a :b |
| f |
stageCompleted := 999.
f := FileDirectory default fileNamed: 'bob.errors'.
f nextPutAll: a printString,' ',b printString; cr; cr.
f nextPutAll: 'worlds equal ',(formerWorld == world) printString; cr; cr.
f nextPutAll: thisContext longStack; cr; cr.
f nextPutAll: formerProcess suspendedContext longStack; cr; cr.
f close. Beeper beep.
].
!
Item was changed:
+ ----- Method: ComplexProgressIndicator>>forkProgressWatcher (in category 'private - background process') -----
- ----- Method: ComplexProgressIndicator>>forkProgressWatcher (in category 'as yet unclassified') -----
forkProgressWatcher
[
| currentWorld killTarget |
currentWorld := Project current world.
[stageCompleted < 999 and:
[formerProject == Project current and:
[formerWorld == currentWorld and:
[translucentMorph world notNil and:
[formerProcess suspendedContext notNil and:
[Project uiProcess == formerProcess]]]]]] whileTrue: [
translucentMorph setProperty: #revealTimes toValue:
{(Time millisecondClockValue - start max: 1). (estimate * newRatio max: 1)}.
translucentMorph changed.
translucentMorph owner addMorphInLayer: translucentMorph.
(Time millisecondClockValue - WorldState lastCycleTime) abs > 500 ifTrue: [
self backgroundWorldDisplay
].
(Delay forMilliseconds: 100) wait.
].
translucentMorph removeProperty: #revealTimes.
self loadingHistoryAt: 'total' add: (Time millisecondClockValue - start max: 1).
killTarget := targetMorph ifNotNil: [
targetMorph valueOfProperty: #deleteOnProgressCompletion
].
formerWorld == currentWorld ifTrue: [
translucentMorph delete.
killTarget ifNotNil: [killTarget delete].
] ifFalse: [
translucentMorph privateDeleteWithAbsolutelyNoSideEffects.
killTarget ifNotNil: [killTarget privateDeleteWithAbsolutelyNoSideEffects].
].
] forkAt: Processor lowIOPriority.!
Item was changed:
+ ----- Method: ComplexProgressIndicator>>historyCategory: (in category 'configuration') -----
- ----- Method: ComplexProgressIndicator>>historyCategory: (in category 'as yet unclassified') -----
historyCategory: aKey
History ifNil: [History := Dictionary new].
specificHistory := History
at: aKey
ifAbsentPut: [Dictionary new].
^specificHistory
!
Item was changed:
+ ----- Method: ComplexProgressIndicator>>loadingHistoryAt:add: (in category 'private') -----
- ----- Method: ComplexProgressIndicator>>loadingHistoryAt:add: (in category 'as yet unclassified') -----
loadingHistoryAt: aKey add: aNumber
(self loadingHistoryDataForKey: aKey) add: aNumber.
!
Item was changed:
+ ----- Method: ComplexProgressIndicator>>loadingHistoryDataForKey: (in category 'private') -----
- ----- Method: ComplexProgressIndicator>>loadingHistoryDataForKey: (in category 'as yet unclassified') -----
loadingHistoryDataForKey: anObject
| answer |
answer := specificHistory
at: anObject
ifAbsentPut: [OrderedCollection new].
answer size > 50 ifTrue: [
answer := answer copyFrom: 25 to: answer size.
specificHistory at: anObject put: answer.
].
^answer
!
Item was changed:
+ ----- Method: ComplexProgressIndicator>>targetMorph: (in category 'configuration') -----
- ----- Method: ComplexProgressIndicator>>targetMorph: (in category 'as yet unclassified') -----
targetMorph: aMorph
targetMorph := aMorph!
Item was changed:
+ ----- Method: ComplexProgressIndicator>>withProgressDo: (in category 'configuration') -----
- ----- Method: ComplexProgressIndicator>>withProgressDo: (in category 'as yet unclassified') -----
withProgressDo: aBlock
+ | safetyFactor totals trialRect delta |
- | safetyFactor totals trialRect delta targetOwner |
Smalltalk isMorphic ifFalse: [^aBlock value].
formerProject := Project current.
formerWorld := formerProject world.
formerProcess := Processor activeProcess.
targetMorph
ifNil: [targetMorph := ProgressTargetRequestNotification signal].
targetMorph ifNil: [
trialRect := Rectangle center: Sensor cursorPoint extent: 80@80.
delta := trialRect amountToTranslateWithin: formerWorld bounds.
trialRect := trialRect translateBy: delta.
translucentMorph := TranslucentProgessMorph new
opaqueBackgroundColor: Color white;
bounds: trialRect;
openInWorld: formerWorld.
] ifNotNil: [
- targetOwner := targetMorph owner.
translucentMorph := TranslucentProgessMorph new
+ morphicLayerNumber: targetMorph morphicLayerNumber - 0.1;
- setProperty: #morphicLayerNumber toValue: targetMorph morphicLayerNumber - 0.1;
bounds: targetMorph boundsInWorld;
openInWorld: targetMorph world.
].
stageCompleted := 0.
safetyFactor := 1.1. "better to guess high than low"
translucentMorph setProperty: #progressStageNumber toValue: 1.
translucentMorph hide.
- targetOwner ifNotNil: [targetOwner hide].
totals := self loadingHistoryDataForKey: 'total'.
newRatio := 1.0.
estimate := totals size < 2 ifTrue: [
15000 "be a pessimist"
] ifFalse: [
(totals sum - totals max) / (totals size - 1 max: 1) * safetyFactor.
].
start := Time millisecondClockValue.
self forkProgressWatcher.
[
aBlock
on: ProgressInitiationException
do: [ :ex |
ex sendNotificationsTo: [ :min :max :curr |
"ignore this as it is inaccurate"
].
].
] on: ProgressNotification do: [ :note | | stageCompletedString |
translucentMorph show.
- targetOwner ifNotNil: [targetOwner show].
note extraParam ifNotNil:[self addProgressDecoration: note extraParam].
stageCompletedString := (note messageText findTokens: ' ') first.
stageCompleted := (stageCompletedString copyUpTo: $:) asNumber.
cumulativeStageTime := Time millisecondClockValue - start max: 1.
prevData := self loadingHistoryDataForKey: stageCompletedString.
prevData isEmpty ifFalse: [
newRatio := (cumulativeStageTime / (prevData average max: 1)) asFloat.
].
self
loadingHistoryAt: stageCompletedString
add: cumulativeStageTime.
translucentMorph
setProperty: #progressStageNumber
toValue: stageCompleted + 1.
note resume.
].
stageCompleted := 999. "we may or may not get here"
!
Item was changed:
----- Method: CornerGripMorph class>>drawCornerResizeHandles (in category 'preferences') -----
drawCornerResizeHandles
<preference: 'Draw Corner Resize Handles'
+ categoryList: #(windows Accessibility)
- category: 'windows'
description: 'Set whether the resize handles on windows should be drawn on the window frame. This does not enable nor disable the resizing function'
type: #Boolean>
^ DrawCornerResizeHandles ifNil: [ false ]!
Item was changed:
----- Method: CornerGripMorph class>>drawEdgeResizeHandles (in category 'preferences') -----
drawEdgeResizeHandles
<preference: 'Draw Edge Resize Handles'
+ categoryList: #(windows Accessibility)
- category: 'windows'
description: 'Set whether the resize handles on windows should be drawn on the window frame. This does not enable nor disable the resizing function.'
type: #Boolean>
^ DrawEdgeResizeHandles ifNil: [ false ]!
Item was added:
+ ----- Method: CornerGripMorph>>backupAndHideTargetDropShadows (in category 'private') -----
+ backupAndHideTargetDropShadows
+
+ self target fastFramingOn ifFalse: [
+ self setProperty: #targetHadDropShadow toValue: target hasDropShadow.
+ self target hasDropShadow: false].!
Item was changed:
----- Method: CornerGripMorph>>mouseDown: (in category 'event handling') -----
mouseDown: anEvent
"Disable drop shadow to improve performance while resizing."
super mouseDown: anEvent.
self target ifNil: [^ self].
+ self backupAndHideTargetDropShadows.!
- self target fastFramingOn ifFalse: [
- self setProperty: #targetHadDropShadow toValue: target hasDropShadow.
- self target hasDropShadow: false].!
Item was changed:
----- Method: CornerGripMorph>>mouseMove: (in category 'event handling') -----
mouseMove: anEvent
| delta |
self target ifNil: [^ self].
+ (self hasProperty: #targetHadDropShadow) ifFalse: [
+ "When dragging resizing an inactive system window, the shadow will be added after sending #mouseDown: on the receiver by the event filter on SystemWindow. Take a second chance to remove the expensive drop shadow temporarily."
+ self backupAndHideTargetDropShadows].
self target fastFramingOn
ifTrue: [delta := self target doFastWindowReframe: self ptName]
ifFalse: [
+ delta := anEvent position - (self referencePoint + self position).
- delta := self referencePoint ifNil: [0@0] ifNotNil: [anEvent position - self referencePoint].
- self referencePoint: anEvent position.
self apply: delta.
self bounds: (self bounds origin + delta extent: self bounds extent)].!
Item was changed:
----- Method: CornerGripMorph>>mouseUp: (in category 'event handling') -----
mouseUp: anEvent
"Restore target drop shadow if there was one. See #mouseDown:."
self target ifNil: [^ self].
self target fastFramingOn ifFalse: [
+ ((self removeProperty: #targetHadDropShadow) ifNil: [false])
+ ifTrue: [self target hasDropShadow: true]].!
- (self valueOfProperty: #targetHadDropShadow ifAbsent: [false]) ifTrue: [self target hasDropShadow: true].
- self removeProperty: #targetHadDropShadow].!
Item was added:
+ ----- Method: DialogWindow>>browseInvocation (in category 'running') -----
+ browseInvocation
+ "Browse the first meaningful invocation method of the receiver."
+
+ self exclusive: false.
+
+ (thisContext findContextSuchThat: self invocationContextPredicate) method browse.!
Item was changed:
----- Method: DialogWindow>>createBody (in category 'initialization') -----
createBody
| body |
body := Morph new
name: 'Body';
changeTableLayout;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
rubberBandCells: true;
listDirection: #topToBottom;
+ layoutInset: ((10@5 * RealEstateAgent scaleFactor) rounded corner: (10@10 * RealEstateAgent scaleFactor) rounded);
+ cellGap: (5 * RealEstateAgent scaleFactor) rounded;
- layoutInset: (10@5 corner: 10@10);
- cellGap: 5;
color: Color transparent;
yourself.
body addAllMorphs: {self createMessage: ''. self createPane. self createButtonRow. self createFilter}.
self addMorphBack: body.!
Item was changed:
----- Method: DialogWindow>>createButtonRow (in category 'initialization') -----
createButtonRow
^ buttonRow := Morph new
name: 'Buttons';
color: Color transparent;
changeTableLayout;
vResizing: #shrinkWrap;
+ hResizing: #shrinkWrap;
- hResizing: #spaceFill;
listDirection: #leftToRight;
listCentering: #center;
+ cellGap: (5 * RealEstateAgent scaleFactor) rounded;
- cellGap: 5;
yourself!
Item was changed:
----- Method: DialogWindow>>createFilter (in category 'initialization') -----
createFilter
"This is an invisible morph that catches keystrokes to filter content in multiple widgets at once. Needs #filterEnabled to be true."
filterMorph := '' asText asMorph lock.
filterMorph
name: 'Filter';
visible: false;
+ disableLayout: true.
- disableTableLayout: true.
^ filterMorph!
Item was changed:
----- Method: DialogWindow>>createMessage: (in category 'initialization') -----
createMessage: aString
+ messageMorph := aString asText asMorph.
+ messageMorph
+ name: 'Message';
+ readOnly: true;
+ hResizing: #shrinkWrap; vResizing: #shrinkWrap;
+ numCharactersPerLine: 45;
+ setProperty: #indicateKeyboardFocus toValue: #never;
+ handlesKeyboardOnlyOnFocus: true. "If user presses enter while only hovering the text, we want to process the stroke to close the dialog."
- messageMorph := aString asText asMorph lock.
- messageMorph name: 'Message'.
self setMessageParameters.
^ messageMorph!
Item was changed:
----- Method: DialogWindow>>createPane (in category 'initialization') -----
createPane
^ paneMorph := BorderedMorph new
name: 'Content';
changeProportionalLayout;
hResizing: #rigid;
vResizing: #rigid;
+ layoutInset: (0@0 corner: 0@ (TextStyle pointsToPixels: 5) truncated);
- layoutInset: 0;
color: Color transparent;
borderWidth: 0;
yourself.!
Item was changed:
----- Method: DialogWindow>>createTitle: (in category 'initialization') -----
createTitle: aString
"Mimick behavior of MenuMorph title creation."
| box closeButton menuButton |
box := Morph new
name: #title;
changeTableLayout;
listDirection: #leftToRight;
yourself.
titleMorph := aString asText asMorph lock.
closeButton := SystemWindowButton new
color: Color transparent;
target: self;
extent: 12@12;
actionSelector: #cancelDialog;
balloonText: 'Cancel this dialog' translated;
borderWidth: 0;
- labelGraphic: SystemWindow closeBoxImage;
- extent: SystemWindow closeBoxImage extent;
visible: self class includeCloseButton;
yourself.
+ SystemWindow closeBoxImage scaleIconToDisplay in: [:icon |
+ closeButton labelGraphic: icon; extent: icon extent].
menuButton := SystemWindowButton new
color: Color transparent;
target: self;
actionSelector: #offerDialogMenu;
balloonText: 'Dialog menu' translated;
borderWidth: 0;
- labelGraphic: SystemWindow menuBoxImage;
- extent: SystemWindow menuBoxImage extent;
visible: self class includeControlMenu;
yourself.
+ SystemWindow menuBoxImage scaleIconToDisplay in: [:icon |
+ menuButton labelGraphic: icon; extent: icon extent].
box addAllMorphs: {closeButton. titleMorph. menuButton}.
self addMorphBack: box.
self setTitleParameters.!
Item was changed:
----- Method: DialogWindow>>debugInvocation (in category 'running') -----
debugInvocation
+ "Bring up a debugger on the active process, displaying the invocation of the receiver. Strip off irrelevant stack frames that are an implementation detail of the invocation."
+ self exclusive: false.
+
+ ^ Processor
+ debugContextThat: self invocationContextPredicate
+ title: 'Dialog invocation' translated
+ full: true!
- [Processor activeProcess
- debug: self findInvocationContext
- title: 'Dialog invocation']
- ifCurtailed: [self closeDialog].!
Item was removed:
- ----- Method: DialogWindow>>exploreInvocation (in category 'running') -----
- exploreInvocation
-
- self exclusive: false.
- (self findInvocationContext stack collect: #method)
- explore!
Item was removed:
- ----- Method: DialogWindow>>findInvocationContext (in category 'running') -----
- findInvocationContext
-
- | context |
- context := thisContext.
- [context method selector = #getUserResponse and: [context isMethodContext]]
- whileFalse: [context := context sender].
- ^ context!
Item was changed:
----- Method: DialogWindow>>getUserResponse (in category 'running') -----
getUserResponse
| hand world |
self message ifEmpty: [messageMorph delete]. "Do not waste space."
self paneMorph submorphs
ifEmpty: ["Do not waste space and avoid strange button-row wraps."
self paneMorph delete.
self buttonRowMorph wrapDirection: #none].
hand := self currentHand.
world := self currentWorld.
self fullBounds.
+ self morphicLayerNumber: self class dialogLayer.
self moveToPreferredPosition.
self openInWorld: world.
hand showTemporaryCursor: nil. "Since we are out of context, reset the cursor."
hand keyboardFocus in: [:priorKeyboardFocus |
hand mouseFocus in: [:priorMouseFocus |
self exclusive ifTrue: [hand newMouseFocus: self].
hand newKeyboardFocus: self.
+ [[self isInWorld] whileTrue: [world doOneSubCycle]]
+ ifCurtailed: [self cancelDialog].
- [self isInWorld] whileTrue:[world doOneSubCycle].
hand newKeyboardFocus: priorKeyboardFocus.
+
+ self flag: #discuss. "Since 2016 we are having this *ping pong* between (a) restoring the prior mouse focus and (b) just clearing it globally. The former solution makes more sense while the latter fixes issues with some modal dialogs. We have to investigate this further."
+ hand releaseMouseFocus.
+ "hand newMouseFocus: priorMouseFocus."]].
- hand newMouseFocus: priorMouseFocus]].
^ result!
Item was added:
+ ----- Method: DialogWindow>>handleMouseDown: (in category 'events') -----
+ handleMouseDown: event
+ "Always bring me to the front since I am modal"
+
+ self comeToFront.
+ ^ super handleMouseDown: event!
Item was changed:
----- Method: DialogWindow>>initialExtent (in category 'initialization') -----
initialExtent
+ "Scale here because dialogs -- unlike SystemWindow -- will not use the RealEstateAgent to open (i.e., #openInWorld:)."
+ ^ ((200@150) * RealEstateAgent scaleFactor) truncated!
- ^ 200@150!
Item was changed:
----- Method: DialogWindow>>initialize (in category 'initialization') -----
initialize
super initialize.
self
changeTableLayout;
listDirection: #topToBottom;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
rubberBandCells: true;
+ disableLayout: true;
setProperty: #indicateKeyboardFocus toValue: #never.
self createTitle: 'Dialog'.
self createBody.
self setDefaultParameters.
keyMap := Dictionary new.
exclusive := true.
autoCancel := false.
+ preferredPosition := self currentWorld center.!
- preferredPosition := ActiveWorld center.!
Item was added:
+ ----- Method: DialogWindow>>invocationContextPredicate (in category 'private') -----
+ invocationContextPredicate
+
+ | searchPhase hiddenCategories |
+ self flag: #todo. "ct: Currently, this might cut away a few contexts too much when a dialog window is opened from Morphic code (e.g., SystemWindow>>relabel) directly. With the introduction of UserNotifications, however, this problem will be solved because there will be always an external context between the client and the receiver. See http://forum.world.st/Discussion-Warning-vs-Halt-or-quot-Why-is-a-warning-a… and others."
+
+ searchPhase := true.
+ hiddenCategories := #('Morphic-Windows' 'ToolBuilder-Kernel' 'ToolBuilder-Morphic' 'ToolBuilder-Morphic-Tools').
+ ^ [:ctx |
+ searchPhase
+ ifTrue: [ "search invocation context"
+ (ctx isMethodContext and: [ctx method selector = #getUserResponse])
+ ifTrue: [searchPhase := false].
+ false]
+ ifFalse: [ "filter out irrelevant contexts"
+ (hiddenCategories includes: ctx receiver class category) not]]!
Item was changed:
----- Method: DialogWindow>>message: (in category 'accessing') -----
message: aStringOrText
+ aStringOrText size > 900 ifTrue: [
+ "NOTE THAT this is an awkward compromise for clients misusing the medium of a dialog window. Because of a dialog's rather short lifespan, users should only be presented with compact content and a concise message. If you notice that your dialog is getting too tall or -- in this case -- wider than usual, please consider rewriting its message."
+ self messageMorph numCharactersPerLine: 65].
+
messageMorph contents: aStringOrText.
self setMessageParameters.!
Item was changed:
----- Method: DialogWindow>>mouseDown: (in category 'events') -----
mouseDown: event
self stopAutoTrigger.
-
- "Always bring me to the front since I am modal"
- self comeToFront.
(self containsPoint: event position) ifFalse: [
^ self autoCancel
ifTrue: [self cancelDialog]
ifFalse: [self flash]].
event hand
waitForClicksOrDrag: self
event: event
selectors: { nil. nil. nil. #startDrag: }
threshold: HandMorph dragThreshold.!
Item was changed:
----- Method: DialogWindow>>moveToHand (in category 'position') -----
moveToHand
+ self moveToHand: self currentHand.!
- self moveToHand: self activeHand.!
Item was changed:
----- Method: DialogWindow>>moveToPreferredPosition (in category 'initialization') -----
moveToPreferredPosition
+ "Moves the dialog window to its preferred position, which can be a point on the screen or a named widget in the dialog's central pane. Ensure that the dialog is fully visible in the world. Also see #positionOverWidgetNamed:."
+
+ | visibleArea decorationOffset |
+ self fullBounds. "Compute new layout to have updated bounds."
+ visibleArea := self currentWorld visibleClearArea.
+ decorationOffset := self extent - self paneMorph extent.
+ self paneMorph extent:
+ (self paneMorph extent min: visibleArea extent - decorationOffset).
+ self fullBounds. "Compute new layout to have updated bounds."
self center:
(preferredPosition isPoint
ifTrue: [ preferredPosition ]
ifFalse: [ self center + self currentHand position - preferredPosition center ]).
+ self bounds:
+ (self bounds translatedToBeWithin: visibleArea).!
- self bounds: (self bounds translatedToBeWithin: self currentWorld bounds)!
Item was changed:
----- Method: DialogWindow>>offerDialogMenu (in category 'running') -----
offerDialogMenu
| menu |
menu := MenuMorph new defaultTarget: self.
menu
add: (exclusive == true ifTrue: ['<yes>'] ifFalse: ['<no>']), 'be modally exclusive' translated
action: #toggleExclusive;
addLine;
+ add: 'browse invocation' translated
+ action: #browseInvocation;
+ add: 'debug invocation' translated
- add: 'explore dialog invocation' translated
- action: #exploreInvocation;
- add: 'debug dialog invocation' translated
action: #debugInvocation.
menu popUpEvent: self currentEvent in: self world.
[menu isInWorld] whileTrue: [self world doOneSubCycle].
self exclusive ifTrue: [self activeHand newMouseFocus: self].!
Item was changed:
----- Method: DialogWindow>>setDefaultParameters (in category 'initialization') -----
setDefaultParameters
"change the receiver's appareance parameters"
self
color: (self userInterfaceTheme color ifNil: [Color white]);
borderStyle: (self userInterfaceTheme borderStyle ifNil: [BorderStyle simple]) copy;
borderColor: (self userInterfaceTheme borderColor ifNil: [Color gray]);
+ borderWidth: ((self userInterfaceTheme borderWidth ifNil: [1]) * RealEstateAgent scaleFactor) truncated;
- borderWidth: (self userInterfaceTheme borderWidth ifNil: [1]);
layoutInset: ((self class roundedDialogCorners and: [self class gradientDialog])
"This check compensates a bug in balloon."
ifTrue: [0] ifFalse: [self borderWidth negated asPoint]).
Preferences menuAppearance3d ifTrue: [self addDropShadow].!
Item was changed:
----- Method: DialogWindow>>setMessageParameters (in category 'initialization') -----
setMessageParameters
+
+ | fontToUse colorToUse margins |
+ messageMorph ifNil: [^ self].
+
+ fontToUse := self userInterfaceTheme font ifNil: [TextStyle defaultFont].
+ colorToUse := self userInterfaceTheme textColor ifNil: [Color black].
+
+ margins := (TextStyle pointsToPixels: 5) truncated.
+
+ messageMorph
+ margins: (self wantsRoundedCorners
+ ifTrue: [margins @ (margins - self cornerRadius) corner: margins @ margins]
+ ifFalse: [margins]);
+ textColor: colorToUse;
+ textStyle: fontToUse asNewTextStyle. "Use style with other point sizes available"!
-
- messageMorph ifNotNil: [
- | fontToUse colorToUse |
- fontToUse := self userInterfaceTheme font ifNil: [TextStyle defaultFont].
- colorToUse := self userInterfaceTheme textColor ifNil: [Color black].
-
- messageMorph
- hResizing: #shrinkWrap;
- vResizing: #shrinkWrap.
-
- messageMorph contents
- addAttribute: (TextFontReference toFont: fontToUse);
- addAttribute: (TextColor color: colorToUse).
- messageMorph textColor: colorToUse].!
Item was changed:
----- Method: DialogWindow>>setTitleParameters (in category 'initialization') -----
setTitleParameters
+ | scaleFactor |
+ scaleFactor := RealEstateAgent scaleFactor.
(self submorphNamed: #title) ifNotNil: [:title |
title
fillStyle: (self class gradientDialog
ifFalse: [SolidFillStyle color: (self userInterfaceTheme titleColor ifNil: [Color r: 0.658 g: 0.678 b: 0.78])]
ifTrue: [self titleGradientFor: title from: (self userInterfaceTheme titleColor ifNil: [Color r: 0.658 g: 0.678 b: 0.78])]);
borderStyle: (self userInterfaceTheme titleBorderStyle ifNil: [BorderStyle simple]) copy;
borderColor: (self userInterfaceTheme titleBorderColor ifNil: [Color r: 0.6 g: 0.7 b: 1]);
borderWidth: (self userInterfaceTheme titleBorderWidth ifNil: [0]);
cornerStyle: (self wantsRoundedCorners ifTrue: [#rounded] ifFalse: [#square]);
vResizing: #shrinkWrap;
hResizing: #spaceFill;
+ cellGap: (5 * scaleFactor) rounded;
+ layoutInset: ((5@3 * scaleFactor) rounded
+ corner: (5@2 * scaleFactor) rounded
+ + (self wantsRoundedCorners ifFalse: [0@0] ifTrue: [0@self cornerRadius]) )].
- cellGap: 5;
- layoutInset: (5@3 corner: 5@ (2+(self wantsRoundedCorners ifFalse: [0] ifTrue: [self cornerRadius])))].
titleMorph ifNotNil: [
| fontToUse colorToUse |
fontToUse := self userInterfaceTheme titleFont ifNil: [TextStyle defaultFont].
colorToUse := self userInterfaceTheme titleTextColor ifNil: [Color black].
"Temporary HACK for 64-bit CI build. Can be removed in the future."
titleMorph contents isText ifFalse: [^ self].
titleMorph
hResizing: #spaceFill;
vResizing: #shrinkWrap.
titleMorph contents
addAttribute: (TextFontReference toFont: fontToUse);
addAttribute: (TextColor color: colorToUse);
addAttribute: TextAlignment centered].!
Item was changed:
----- Method: DialogWindow>>updateButtonExtent (in category 'updating') -----
updateButtonExtent
+ self updateButtonExtent: (20@0 * RealEstateAgent scaleFactor) rounded.!
- self updateButtonExtent: 20@10.!
Item was changed:
----- Method: DialogWindow>>updateButtonExtent: (in category 'updating') -----
updateButtonExtent: margin
"Update all button extents."
+ | preferredButtonHeight |
+ preferredButtonHeight := ToolBuilder default buttonRowHeight.
(buttonRow submorphs collect: [:ea | ea minimumExtent]) max + margin in: [:preferredExtent |
+ buttonRow submorphsDo: [:ea | ea extent: preferredExtent x @ preferredButtonHeight]].
- buttonRow submorphsDo: [:ea | ea extent: preferredExtent]].
+ "Check whether horizontal or vertical button layout would be more appropriate."
+ buttonRow listDirection: #leftToRight; fullBounds.
+ buttonRow width > self messageMorph compositionRectangle width
+ ifTrue: [buttonRow listDirection: #topToBottom].!
- "See if horizontal button layout would be more appropriate."
- self flag: #magicNumber. "mt: Remove number with computation, maybe choose button font and 20 characters"
- (buttonRow submorphs collect: [:ea | ea fullBounds width]) sum > 400
- ifTrue: [buttonRow
- hResizing: #shrinkWrap;
- listDirection: #topToBottom;
- wrapDirection: #none;
- layoutInset: (buttonRow owner fullBounds width - (buttonRow owner layoutInset left*2) - buttonRow submorphs first fullBounds width // 2@0)]
- ifFalse: [buttonRow
- hResizing: #spaceFill;
- listDirection: #leftToRight;
- wrapDirection: #topToBottom;
- layoutInset: 0].!
Item was changed:
----- Method: DialogWindow>>updateFilter (in category 'updating') -----
updateFilter
self buttons do: [:ea |
ea enabled: (self filter isEmpty or: [ea label asString includesSubstring: self filter caseSensitive: false])].
filterMorph
visible: self filter notEmpty;
+ disableLayout: self filter isEmpty;
- disableTableLayout: self filter isEmpty;
contents: '<', self filter, '>';
textColor: self messageMorph textColor.
self ensureSelectedButton.!
Item was changed:
----- Method: DockingBarItemMorph>>selectedIcon: (in category 'accessing') -----
+ selectedIcon: aFormOrNil
- selectedIcon: aForm
+ selectedIcon := aFormOrNil
+ ifNotNil: [:form | form scaleIconToDisplay].!
- selectedIcon := aForm!
Item was changed:
----- Method: DockingBarMorph>>add:icon:help:subMenu: (in category 'construction') -----
add: wordingString icon: aForm help: helpString subMenu: aMenuMorph
"Append the given submenu with the given label."
| item |
item := DockingBarItemMorph new.
item contents: wordingString.
item subMenu: aMenuMorph.
item icon: aForm.
helpString isNil
ifFalse: [item setBalloonText: helpString].
+ aMenuMorph ifNotNil: [
+ aMenuMorph morphicLayerNumber: self morphicLayerNumber + 1].
self addMorphBack: item!
Item was changed:
----- Method: DockingBarMorph>>add:icon:selectedIcon:help:subMenu: (in category 'construction') -----
add: wordingString icon: aForm selectedIcon: anotherForm help: helpString subMenu: aMenuMorph
"Append the given submenu with the given label."
| item |
item := DockingBarItemMorph new
contents: wordingString;
subMenu: aMenuMorph;
icon: aForm;
selectedIcon: anotherForm.
+ helpString ifNotNil: [
- helpString isNil ifFalse: [
item setBalloonText: helpString ].
+ aMenuMorph ifNotNil: [
+ aMenuMorph morphicLayerNumber: self morphicLayerNumber + 1 ].
self addMorphBack: item!
Item was changed:
----- Method: DockingBarMorph>>addDefaultSpace (in category 'construction') -----
addDefaultSpace
"Add a new space of the given size to the receiver."
+ ^ self addSpace: ((Preferences tinyDisplay ifFalse:[10] ifTrue:[3]) * RealEstateAgent scaleFactor) truncated!
- ^ self addSpace: (Preferences tinyDisplay ifFalse:[10] ifTrue:[3])!
Item was changed:
----- Method: DockingBarMorph>>addItem: (in category 'construction') -----
addItem: aBlock
| item |
item := DockingBarItemMorph new.
aBlock value: item.
+ item subMenu ifNotNil: [:menu |
+ "Docking bar and protruding menu should appear visually merged."
+ menu morphicLayerNumber: self morphicLayerNumber + 1].
self addMorphBack: item!
Item was changed:
----- Method: DockingBarMorph>>addUpdatingItem: (in category 'construction') -----
addUpdatingItem: aBlock
| item |
item := DockingBarUpdatingItemMorph new.
aBlock value: item.
+ item subMenu ifNotNil: [:menu |
+ "Docking bar and protruding menu should appear visually merged."
+ menu morphicLayerNumber: self morphicLayerNumber + 1].
self addMorphBack: item!
Item was changed:
+ ----- Method: DockingBarMorph>>delete (in category 'submorphs - add/remove') -----
- ----- Method: DockingBarMorph>>delete (in category 'submorphs-add/remove') -----
delete
+ self currentHand removeKeyboardListener: self.
+ activeSubMenu ifNotNil: [
+ activeSubMenu delete].
- ActiveHand removeKeyboardListener: self.
- activeSubMenu
- ifNotNil: [activeSubMenu delete].
^ super delete!
Item was changed:
----- Method: DockingBarMorph>>ensureSelectedItem: (in category 'events') -----
ensureSelectedItem: evt
self selectedItem ifNil: [
self
selectItem: (
self submorphs
+ detect: [ :each | each isMenuItemMorph ]
- detect: [ :each | each isKindOf: DockingBarItemMorph ]
ifNone: [ ^self ])
event: evt ]!
Item was changed:
----- Method: DockingBarMorph>>filterEvent:for: (in category 'events-processing') -----
filterEvent: aKeyboardEvent for: anObject
"Provide keyboard shortcuts."
| index itemToSelect |
aKeyboardEvent controlKeyPressed
ifFalse: [^ aKeyboardEvent].
+ aKeyboardEvent isKeystroke
- (aKeyboardEvent isKeyDown or: [aKeyboardEvent isKeystroke]) "We also need #keyDown for Windows platforms because CTRL+X does not trigger key strokes there..."
ifFalse: [^ aKeyboardEvent].
"Search field."
aKeyboardEvent keyCharacter = $0
ifTrue: [
self searchBarMorph ifNotNil: [ :morph |
morph model activate: aKeyboardEvent in: morph ].
^ aKeyboardEvent ignore "hit!!"].
"Select menu items."
(aKeyboardEvent keyValue
between: $1 asciiValue
and: $9 asciiValue)
ifFalse: [^ aKeyboardEvent].
index := aKeyboardEvent keyValue - $1 asciiValue + 1.
itemToSelect := (self submorphs select: [ :each |
+ each isMenuItemMorph ])
- each isKindOf: DockingBarItemMorph ])
at: index
ifAbsent: [^ aKeyboardEvent].
self activate: aKeyboardEvent.
self
selectItem: itemToSelect
event: aKeyboardEvent.
^ aKeyboardEvent ignore "hit!!"!
Item was changed:
+ ----- Method: DockingBarMorph>>morphicLayerNumber (in category 'submorphs - layers') -----
- ----- Method: DockingBarMorph>>morphicLayerNumber (in category 'WiW support') -----
morphicLayerNumber
+
+ ^ self valueOfProperty: #morphicLayerNumber ifAbsent: [self class navigatorLayer]!
- "helpful for insuring some morphs always appear in front of or
- behind others. smaller numbers are in front"
- ^ 11!
Item was changed:
----- Method: DockingBarMorph>>moveSelectionDown:event: (in category 'control') -----
moveSelectionDown: direction event: evt
"Move the current selection up or down by one, presumably under keyboard control.
direction = +/-1"
| index |
+ index := (submorphs
+ indexOf: selectedItem
+ ifAbsent: [direction positive ifTrue: [0] ifFalse: [1]]
+ ) + direction.
- index := (submorphs indexOf: selectedItem ifAbsent: [1-direction]) + direction.
submorphs do: "Ensure finite"
[:unused | | m |
m := submorphs atWrap: index.
+ (m isMenuItemMorph and: [m isEnabled]) ifTrue:
- ((m isKindOf: DockingBarItemMorph) and: [m isEnabled]) ifTrue:
[^ self selectItem: m event: evt].
"Keep looking for an enabled item"
index := index + direction sign].
^ self selectItem: nil event: evt!
Item was changed:
----- Method: DockingBarMorph>>setDefaultParameters (in category 'initialize-release') -----
setDefaultParameters
"private - set the default parameter using Preferences as the inspiration source"
self
color: (self userInterfaceTheme color ifNil: [Color r: 0.9 g: 0.9 b: 0.9]);
borderStyle: (self userInterfaceTheme borderStyle ifNil: [BorderStyle simple]) copy;
borderColor: (self userInterfaceTheme borderColor ifNil: [Color gray]);
borderWidth: (self userInterfaceTheme borderWidth ifNil: [0]).
+ self extent: (Preferences standardMenuFont lineGridForMorphs asPoint).!
- self extent: (Preferences standardMenuFont height asPoint).!
Item was added:
+ ----- Method: DockingBarUpdatingItemMorph>>adjacentTo (in category 'selecting') -----
+ adjacentTo
+
+ | roundedCornersOffset verticalOffset |
+ roundedCornersOffset := MenuMorph roundedMenuCorners
+ ifTrue: [Morph preferredCornerRadius negated]
+ ifFalse: [0].
+ verticalOffset := 2.
+
+ owner isFloating
+ ifTrue: [^ {self bounds bottomLeft + (roundedCornersOffset @ verticalOffset)}].
+ owner isAdheringToTop
+ ifTrue: [^ {self bounds bottomLeft + (roundedCornersOffset @ verticalOffset)}].
+ owner isAdheringToLeft
+ ifTrue: [^ {self bounds topRight + (roundedCornersOffset @ verticalOffset)}].
+ owner isAdheringToBottom
+ ifTrue: [^ {self bounds topLeft + (roundedCornersOffset @ verticalOffset)}].
+ owner isAdheringToRight
+ ifTrue: [^ {self bounds topLeft + (roundedCornersOffset @ verticalOffset negated)}].
+ ^ {self bounds bottomLeft + (roundedCornersOffset @ 5)}!
Item was added:
+ ----- Method: DockingBarUpdatingItemMorph>>createSubmenu (in category 'private') -----
+ createSubmenu
+
+ ^DockingBarMenuMorph new!
Item was added:
+ ----- Method: DockingBarUpdatingItemMorph>>createUpdatingSubmenu (in category 'private') -----
+ createUpdatingSubmenu
+
+ ^DockingBarUpdatingMenuMorph new!
Item was changed:
+ ----- Method: DockingBarUpdatingItemMorph>>decorateOwner (in category 'world') -----
- ----- Method: DockingBarUpdatingItemMorph>>decorateOwner (in category 'as yet unclassified') -----
decorateOwner
"Ignore."!
Item was added:
+ ----- Method: DockingBarUpdatingItemMorph>>drawIconOn: (in category 'drawing') -----
+ drawIconOn: aCanvas
+
+ | pos |
+ self hasIcon ifTrue: [
+ | iconForm |
+ iconForm := self iconForm.
+
+ pos := (contents
+ ifEmpty: [self left + (self width - iconForm width // 2)]
+ ifNotEmpty: [self left])
+ @ (self top + (self height - iconForm height // 2)).
+
+ aCanvas
+ translucentImage: iconForm
+ at: pos].!
Item was added:
+ ----- Method: DockingBarUpdatingItemMorph>>drawLabelOn: (in category 'drawing') -----
+ drawLabelOn: aCanvas
+
+ | stringBounds |
+ self contents ifEmpty: [^ self].
+
+ stringBounds := bounds.
+
+ self hasIcon ifTrue: [
+ stringBounds := stringBounds left: stringBounds left + self iconForm width + 2 ].
+
+ "Vertical centering."
+ stringBounds := stringBounds top: stringBounds top + stringBounds bottom - self fontToUse height // 2.
+ "Horizontal centering."
+ stringBounds := stringBounds left: stringBounds left + (stringBounds width - (self fontToUse widthOfString: contents) // 2) abs.
+
+ aCanvas
+ drawString: contents
+ in: stringBounds
+ font: self fontToUse
+ color: self colorToUse.!
Item was added:
+ ----- Method: DockingBarUpdatingItemMorph>>drawSubMenuMarkerOn: (in category 'drawing') -----
+ drawSubMenuMarkerOn: aCanvas
+ "Ignore."!
Item was added:
+ ----- Method: DockingBarUpdatingItemMorph>>mouseDown: (in category 'events') -----
+ mouseDown: evt
+ "Handle a mouse down event. Menu items get activated when the mouse is over them."
+
+ (evt shiftPressed and:[self wantsKeyboardFocusOnShiftClick]) ifTrue: [ ^super mouseDown: evt ]. "enable label editing"
+ isSelected
+ ifTrue: [
+ owner selectItem: nil event: evt. ]
+ ifFalse: [
+ owner activate: evt. "Redirect to menu for valid transitions"
+ owner selectItem: self event: evt. ]
+ !
Item was changed:
+ ----- Method: DockingBarUpdatingItemMorph>>mouseEnter: (in category 'events') -----
- ----- Method: DockingBarUpdatingItemMorph>>mouseEnter: (in category 'as yet unclassified') -----
mouseEnter: evt
"Do not hover docking bar items directory. Mouse-down required. But if you already see a submenu, support hovering."
owner selectedItem ifNotNil: [owner selectItem: self event: evt]!
Item was added:
+ ----- Method: DockingBarUpdatingItemMorph>>mouseUp: (in category 'events') -----
+ mouseUp: evt
+ "Handle a mouse up event. Menu items get activated when the mouse is over them. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu."
+
+ evt hand mouseFocus == owner ifFalse: [ ^self ].
+ self contentString ifNotNil: [
+ self contents: self contentString withMarkers: true inverse: true.
+ self refreshWorld.
+ (Delay forMilliseconds: 200) wait ].!
Item was added:
+ ----- Method: DockingBarUpdatingItemMorph>>select: (in category 'selecting') -----
+ select: evt
+
+ super select: evt.
+ subMenu ifNotNil: [
+ evt hand newKeyboardFocus: subMenu ]!
Item was added:
+ ----- Method: DockingBarUpdatingItemMorph>>wantsKeyboardFocusOnShiftClick (in category 'events') -----
+ wantsKeyboardFocusOnShiftClick
+ "set this preference to false to prevent user editing of docking bar menu items"
+ ^Preferences valueOfPreference: #allowMenubarItemEditing ifAbsent: [false]!
Item was added:
+ ----- Method: DockingBarUpdatingMenuMorph>>morphicLayerNumber: (in category 'update') -----
+ morphicLayerNumber: n
+
+ super morphicLayerNumber: n.
+ !
Item was removed:
- DropEvent subclass: #DropFilesEvent
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Morphic-Events'!
Item was removed:
- ----- Method: DropFilesEvent>>sentTo: (in category 'dispatching') -----
- sentTo: anObject
- "Dispatch the receiver into anObject"
- self type == #dropFilesEvent ifTrue:[^anObject handleDropFiles: self].!
Item was removed:
- ----- Method: DropFilesEvent>>type (in category 'accessing') -----
- type
- ^#dropFilesEvent!
Item was changed:
Object subclass: #Editor
+ instanceVariableNames: 'morph'
- instanceVariableNames: 'morph selectionShowing'
classVariableNames: 'BlinkingCursor DestructiveBackWord DumbbellCursor KeystrokeActions SelectionsMayShrink'
poolDictionaries: ''
category: 'Morphic-Text Support'!
!Editor commentStamp: 'hjh 9/28/2017 11:37' prior: 0!
New text editors.
TextEditor provides most of the functionality that used to be in TextMorphEditor.
SmalltalkEditor is has Smalltalk code specific features.
!
Item was added:
+ ----- Method: Editor class>>cleanUp: (in category 'class initialization') -----
+ cleanUp: aggressive
+
+ aggressive ifTrue: [self initialize].!
Item was removed:
- ----- Method: Editor>>deselect (in category 'current selection') -----
- deselect
- "If the text selection is visible on the screen, reverse its highlight."
-
- selectionShowing ifTrue: [self reverseSelection]!
Item was changed:
----- Method: Editor>>lineSelectAndEmptyCheck: (in category 'menu messages') -----
lineSelectAndEmptyCheck: returnBlock
"If the current selection is an insertion point, expand it to be the entire current line; if after that's done the selection is still empty, then evaluate the returnBlock, which will typically consist of '[^ self]' in the caller -- check senders of this method to understand this."
+ self hasSelection ifFalse: [
+ self selectLine.
+ self hasSelection ifFalse: [
+ morph flash.
+ ^ returnBlock value]].!
- self selectLine. "if current selection is an insertion point, then first select the entire line in which occurs before proceeding"
- self hasSelection ifFalse: [morph flash. ^ returnBlock value]!
Item was added:
+ ----- Method: Editor>>selectIntervalInvisibly: (in category 'new selection') -----
+ selectIntervalInvisibly: anInterval
+ "Deselect, then select the specified characters inclusive.
+ Do not yet make the new selection visible."
+
+ self selectInvisiblyFrom: anInterval first to: anInterval last!
Item was changed:
----- Method: Editor>>wordSelectAndEmptyCheck: (in category 'menu messages') -----
wordSelectAndEmptyCheck: returnBlock
"Ensure selecting the entire current word; if after that's done the selection is still empty, then evaluate the returnBlock, which will typically consist of '[^ self]' in the caller -- check senders of this method to understand this."
+ self hasSelection ifFalse: [
+ self selectWord.
+ self hasSelection ifFalse: [
+ morph flash.
+ ^ returnBlock value]].!
- self selectWord. "Select exactly a whole word"
- self hasSelection ifFalse: [morph flash. ^ returnBlock value]!
Item was changed:
----- Method: FillInTheBlankMorph class>>defaultAnswerExtent (in category 'default constants') -----
defaultAnswerExtent
+ ^ ((TextStyle defaultFont widthOf: $x) * 30) @ (3 * TextStyle defaultFont height)!
- ^ (200@ (3 * Preferences standardDefaultTextFont height))!
Item was changed:
----- Method: FillInTheBlankMorph class>>request: (in category 'instance creation') -----
request: queryString
"Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels."
"FillInTheBlankMorph request: 'What is your favorite color?'"
^ self
request: queryString
initialAnswer: ''
+ centerAt: (self currentHand ifNil: [Sensor]) cursorPoint!
- centerAt: (ActiveHand ifNil:[Sensor]) cursorPoint!
Item was changed:
----- Method: FillInTheBlankMorph class>>request:initialAnswer: (in category 'instance creation') -----
request: queryString initialAnswer: defaultAnswer
"Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels."
"FillInTheBlankMorph
request: 'What is your favorite color?'
initialAnswer: 'red, no blue. Ahhh!!'"
^ self
request: queryString
initialAnswer: defaultAnswer
+ centerAt: (self currentHand ifNil: [Sensor]) cursorPoint!
- centerAt: ActiveHand cursorPoint!
Item was changed:
----- Method: FillInTheBlankMorph class>>request:initialAnswer:centerAt: (in category 'instance creation') -----
request: queryString initialAnswer: defaultAnswer centerAt: aPoint
"Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels.
This variant is only for calling from within a Morphic project."
"FillInTheBlankMorph
request: 'Type something, then type CR.'
initialAnswer: 'yo ho ho!!'
centerAt: Display center"
^ self
request: queryString
initialAnswer: defaultAnswer
centerAt: aPoint
+ inWorld: self currentWorld!
- inWorld: ActiveWorld
- !
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
+ plainTextOnly: true;
+ hScrollBarPolicy: ((acceptBoolean or: (Preferences alwaysHideHScrollbar))
+ ifTrue: [#never] ifFalse: [#whenNeeded]);
+ vScrollBarPolicy: #whenNeeded;
- textPane
- showScrollBarsOnlyWhenNeeded;
wantsFrameAdornments: false;
hasUnacceptedEdits: true;
+ askBeforeDiscardingEdits: false;
+ setProperty: #alwaysAccept toValue: true;
acceptOnCR: acceptBoolean;
setNameTo: 'textPane';
layoutFrame: (LayoutFrame fractions: (0@0 corner: 1@1));
hResizing: #spaceFill;
vResizing: #spaceFill;
scrollToTop.
^ textPane!
Item was changed:
----- Method: FillInTheBlankMorph>>setPasswordQuery:initialAnswer:answerHeight:acceptOnCR: (in category 'initialization') -----
setPasswordQuery: queryString initialAnswer: initialAnswer answerHeight: answerHeight acceptOnCR: acceptBoolean
self setQuery: queryString
initialAnswer: initialAnswer
answerHeight: answerHeight
acceptOnCR: acceptBoolean.
+ textPane font: StrikeFont passwordFont.!
- textPane font: (StrikeFont passwordFontSize: 12).!
Item was changed:
----- Method: FillInTheBlankMorph>>setQuery:initialAnswer:answerExtent:acceptOnCR: (in category 'initialization') -----
setQuery: queryString initialAnswer: initialAnswer answerExtent: answerExtent acceptOnCR: acceptBoolean
+ | text textFont preferredLineCount preferredCharCount preferredExtent |
- | text |
+ result := initialAnswer asString. "plain text only; see #createTextPaneAcceptOnCR:"
- result := initialAnswer.
done := false.
self paneMorph removeAllMorphs.
self title: 'Input Requested' translated.
self message: queryString.
+ preferredLineCount := (result lineCount
+ min: 10 "Both one-liner and multi-liner show this max. lines before scrolling"
+ max: (acceptBoolean ifTrue: [1 "one-liner"] ifFalse: [3 "multi-liner"])).
+ preferredCharCount := 0.
+ result lineIndicesDo: [:start :end :endCR |
+ preferredCharCount := preferredCharCount max: end-start].
+ preferredCharCount := preferredCharCount
+ min: 75 "Optimized for bigger multi-line input request"
+ max: 30 "Optimized for a small search field".
+
+ textFont := TextStyle defaultFont.
+ preferredExtent := (textFont widthOf: $x) * preferredCharCount
+ @ (ToolBuilder default inputFieldHeightFor: preferredLineCount).
+
text := self createTextPaneAcceptOnCR: acceptBoolean.
self paneMorph addMorphBack: text.
self paneMorph
wantsPaneSplitters: true;
+ cellGap: ProportionalSplitterMorph gripThickness.
+
+ acceptBoolean ifFalse: [
+ self paneMorph
+ addCornerGrips;
+ layoutInset: ProportionalSplitterMorph gripThickness.
+ self paneMorph grips do: [:ea | ea showHandle: true]].
+
+ self paneMorph layoutExtent: preferredExtent.
- addCornerGrips.
- self paneMorph grips do: [:ea | ea showHandle: true].
-
- self paneMorph extent: ((initialAnswer asText asMorph extent + (20@10) max: answerExtent) min: 500@500).
self setDefaultParameters.!
Item was changed:
----- Method: FontChooserTool>>buildButtonBarWith: (in category 'toolbuilder') -----
buildButtonBarWith: builder
"Build the button bar"
| panelSpec buttonSpec |
panelSpec := builder pluggablePanelSpec new.
panelSpec
layout: #horizontal;
children: OrderedCollection new.
buttonSpec := builder pluggableButtonSpec new.
buttonSpec
model: self;
label: 'Apply' translated;
action: #apply.
panelSpec children addLast: buttonSpec.
+ panelSpec children addLast: (builder pluggableSpacerSpec new extent: ((TextStyle defaultFont widthOf: $m) @1)).
buttonSpec := builder pluggableButtonSpec new.
buttonSpec
model: self;
label: 'OK' translated;
action: #accept.
panelSpec children addLast: buttonSpec.
buttonSpec := builder pluggableButtonSpec new.
buttonSpec
model: self;
label: 'Cancel' translated;
action: #cancel.
panelSpec children addLast: buttonSpec.
^panelSpec!
Item was changed:
----- Method: FontChooserTool>>buildFontListWith: (in category 'toolbuilder') -----
buildFontListWith: builder
"Build the font choosers list of font names"
| listSpec |
listSpec := builder pluggableListSpec new.
listSpec
model: self;
name: #fontList;
+ list: #fontList;
+ icon: #fontListIconAt:;
- list: #fontList;
getIndex: #selectedFontIndex;
setIndex: #selectedFontIndex:.
^listSpec
!
Item was added:
+ ----- Method: FontChooserTool>>buildPointSizeInputWith: (in category 'toolbuilder') -----
+ buildPointSizeInputWith: builder
+ "Build the font choosers list of point sizes"
+ | listSpec |
+ listSpec := builder pluggableInputFieldSpec new.
+ listSpec
+ model: self;
+ plainTextOnly: true;
+ getText: #pointSizeInput;
+ setText: #pointSizeInput:;
+ textStyle: TextStyle default copy centered;
+ softLineWrap: true.
+ ^listSpec
+ !
Item was changed:
----- Method: FontChooserTool>>buildPointSizeListWith: (in category 'toolbuilder') -----
buildPointSizeListWith: builder
"Build the font choosers list of point sizes"
| listSpec |
listSpec := builder pluggableListSpec new.
listSpec
model: self;
list: #pointSizeList;
getIndex: #selectedPointSizeIndex;
+ setIndex: #selectedPointSizeIndex:;
+ itemAlignment: #right;
+ padding: self pointSizePadding.
- setIndex: #selectedPointSizeIndex:.
^listSpec
!
Item was changed:
----- Method: FontChooserTool>>buildPreviewPaneWith: (in category 'toolbuilder') -----
buildPreviewPaneWith: builder
"Build the preview panel"
| textSpec |
textSpec := builder pluggableTextSpec new.
textSpec
name: #preview;
model: self;
getText: #contents;
+ textStyle: #selectedFontTextStyle;
softLineWrap: false.
^textSpec!
Item was changed:
----- Method: FontChooserTool>>buildWith: (in category 'toolbuilder') -----
buildWith: builder
"Create the ui for the browser"
"ToolBuilder open: self"
+ | windowSpec hDiv |
+ hDiv := 0.55.
- | windowSpec |
self offerStyleList ifTrue:[
windowSpec := self buildWindowWith: builder specs: {
+ (0@0 corner: 0.5@hDiv) -> [self buildFontListWith: builder].
+ (0.5@0 corner: 0.8@hDiv) -> [self buildStyleListWith: builder].
+ (LayoutFrame fractions: (0.8@0 corner: 1.0@hDiv) offsets: (0@0 corner: 0 @ self pointSizeInputHeight negated))
+ -> [self buildPointSizeListWith: builder].
+ (LayoutFrame fractions: (0.8@hDiv corner: 1.0@hDiv) offsets: (0@self pointSizeInputHeight negated corner: 0@0))
+ -> [self buildPointSizeInputWith: builder].
+ (LayoutFrame fractions: (0.0@hDiv corner: 1.0(a)1.0) offsets: (0@0 corner: 0 @ self buttonHeight negated))
+ -> [self buildPreviewPaneWith: builder].
+ (LayoutFrame fractions: (0@1 corner: 1@1) offsets: (0@ self buttonHeight negated corner: 0@0))
+ -> [self buildButtonBarWith: builder].
- (0@0 corner: 0.4(a)0.4) -> [self buildFontListWith: builder].
- (0.4@0 corner: 0.8(a)0.4) -> [self buildStyleListWith: builder].
- (0.8@0 corner: 1.0(a)0.4) -> [self buildPointSizeListWith: builder].
- (LayoutFrame fractions: (0.0(a)0.4 corner: 1.0(a)1.0) offsets: (0@0 corner: 0 @ self buttonHeight negated)) -> [self buildPreviewPaneWith: builder].
- (LayoutFrame fractions: (0@1 corner: 1@1) offsets: (0@ self buttonHeight negated corner: 0@0)) -> [self buildButtonBarWith: builder].
}.
] ifFalse:[
windowSpec := self buildWindowWith: builder specs: {
+ (0@0 corner: 0.7@hDiv) -> [self buildFontListWith: builder].
+ (LayoutFrame fractions: (0.7@0 corner: 1.0@hDiv) offsets: (0@0 corner: 0 @ self pointSizeInputHeight negated))
+ -> [self buildPointSizeListWith: builder].
+
+ (LayoutFrame fractions: (0.7@hDiv corner: 1.0@hDiv) offsets: (0@self pointSizeInputHeight negated corner: 0@0))
+ -> [self buildPointSizeInputWith: builder].
+ (LayoutFrame fractions: (0.0@hDiv corner: 1.0(a)1.0) offsets: (0@0 corner: 0 @ self buttonHeight negated))
+ -> [self buildPreviewPaneWith: builder].
+ (LayoutFrame fractions: (0@1 corner: 1@1) offsets: (0@ self buttonHeight negated corner: 0@0))
+ -> [self buildButtonBarWith: builder].
- (0@0 corner: 0.7(a)0.4) -> [self buildFontListWith: builder].
- " (0.4@0 corner: 0.8(a)0.4) -> [self buildStyleListWith: builder]."
- (0.7@0 corner: 1.0(a)0.4) -> [self buildPointSizeListWith: builder].
- (LayoutFrame fractions: (0.0(a)0.4 corner: 1.0(a)1.0) offsets: (0@0 corner: 0 @ self buttonHeight negated)) -> [self buildPreviewPaneWith: builder].
- (LayoutFrame fractions: (0@1 corner: 1@1) offsets: (0@ self buttonHeight negated corner: 0@0)) -> [self buildButtonBarWith: builder].
}.
].
windowSpec extent: self initialExtent.
window := builder build: windowSpec.
"Now that the window has been built, notify selection again to scroll it into view."
self changed: #selectedFontIndex.
+ self changed: #selectedFontStyleIndex.
+ self changed: #selectedPointSizeIndex.
^window!
Item was changed:
----- Method: FontChooserTool>>buttonHeight (in category 'toolbuilder') -----
buttonHeight
+
+ ^ ToolBuilder default buttonRowHeight!
- ^ Preferences standardButtonFont height * 3!
Item was changed:
----- Method: FontChooserTool>>contents (in category 'toolbuilder') -----
contents
+ "Note that we cannot just rely on #selectedTextStyle because there are, for example, symbol fonts out there, which require a different set of characters as a sample text."
+
-
^ self selectedFont
ifNil: [Text new]
+ ifNotNil: [:font |
+ font isSymbolFont
+ ifTrue: [font symbolSample]
+ ifFalse: [Text textSample]]!
- ifNotNil: [:font | font sampleText]!
Item was changed:
----- Method: FontChooserTool>>fontList (in category 'font list') -----
fontList
+ "List of available font family names. Avoid StrikeFonts if PPI is not 96.0."
+
+ fontList ifNotNil: [^ fontList].
+
+ fontList := TextStyle knownTextStylesWithoutDefault.
+ self getFontFromRequestor ifNotNil: [:font |
+ (fontList includes: font familyName) ifFalse: [
+ fontList := (fontList, {font familyName}) sorted]].
+ TextStyle pixelsPerInch = 96.0 ifFalse: [
+ fontList := fontList select: [:styleName |
+ (TextStyle named: styleName) ifNil: [true "not yet installed"] ifNotNil: [:style | style isTTCStyle] ]].
+ ^ fontList!
- "List of available font family names"
- ^fontList ifNil:[fontList := TextStyle knownTextStyles]!
Item was added:
+ ----- Method: FontChooserTool>>fontListIconAt: (in category 'font list') -----
+ fontListIconAt: index
+
+ ^ ToolIcons iconNamed: ( ((TextStyle named: (self fontList at: index))
+ ifNil: [self getFontFromRequestor ifNotNil: [:font | TextStyle fontArray: {font} "Not yet installed" ]])
+ ifNil: [#blank16]
+ ifNotNil: [:style | style isTTCStyle ifTrue: [#font] ifFalse: [#blank16]] )!
Item was added:
+ ----- Method: FontChooserTool>>getFontFromRequestor (in category 'updating') -----
+ getFontFromRequestor
+
+ ^ (getSelector isSymbol and:[target notNil])
+ ifTrue:[target perform: getSelector]
+ ifFalse:[getSelector]!
Item was changed:
----- Method: FontChooserTool>>getSelector: (in category 'accessing') -----
getSelector: aSelectorSymbolOrFont
"Set the value of getSelector"
+ getSelector := aSelectorSymbolOrFont.
+ self updateFromRequestor.!
- getSelector := aSelectorSymbolOrFont!
Item was changed:
----- Method: FontChooserTool>>initialExtent (in category 'initialize') -----
initialExtent
+
+ ^ self offerStyleList
+ ifTrue:[450@250]
+ ifFalse:[400@250].!
- ^self offerStyleList ifTrue:[420@300] ifFalse:[320@200].!
Item was changed:
----- Method: FontChooserTool>>pointSize: (in category 'point size') -----
pointSize: aNumber
+
pointSize := aNumber.
+
+ self changed: #selectedFontTextStyle.
+ self changed: #contents.
+
+ self changed: #pointSizeList.
+ self changed: #selectedPointSizeIndex.
+ self changed: #pointSizeInput.!
- self changed: #pointSize.
- self changed: #contents.!
Item was added:
+ ----- Method: FontChooserTool>>pointSizeInput (in category 'point size') -----
+ pointSizeInput
+
+ ^ self pointSize asString!
Item was added:
+ ----- Method: FontChooserTool>>pointSizeInput: (in category 'point size') -----
+ pointSizeInput: aString
+
+ self pointSize: (aString asNumber roundTo: 0.5).
+ self changed: #pointSizeInput.!
Item was added:
+ ----- Method: FontChooserTool>>pointSizeInputHeight (in category 'toolbuilder') -----
+ pointSizeInputHeight
+ ^ ToolBuilder default inputFieldHeight!
Item was changed:
----- Method: FontChooserTool>>pointSizeList (in category 'point size') -----
pointSizeList
+ ^self selectedTextStyle pointSizes collect: [:each | each printShowingDecimalPlaces: 1]!
- ^self selectedTextStyle pointSizes collect: [:each | each asString padded: #left to: 3 with: $ ]!
Item was added:
+ ----- Method: FontChooserTool>>pointSizePadding (in category 'toolbuilder') -----
+ pointSizePadding
+
+ ^ 0@0 corner: (10 * RealEstateAgent scaleFactor) truncated @0!
Item was changed:
----- Method: FontChooserTool>>selectedFont (in category 'font list') -----
selectedFont
+ "Generate missing pointSIze only if TrueType font."
+
+ | style |
+ ^ (style := self selectedTextStyle) isTTCStyle
+ ifTrue: [ style fontArray size = 1 "Font not yet installed..."
+ ifTrue: [style defaultFont]
+ ifFalse: [TTCFont familyName: self selectedFontFamily pointSize: pointSize emphasized: emphasis]]
+ ifFalse: [
+ | font |
+ font := (style fontOfPointSize: pointSize) emphasized: emphasis.
+ pointSize ~= font pointSize ifTrue: [
+ self inform: ('The point size you requested is not available for this pre-rendered font. Please choose a TrueType font, where you can add custom point sizes.' translated withNoLineLongerThan: 45).
+ pointSize := font pointSize].
+ self changed: #selectedPointSizeIndex.
+ font]!
- | font |
- font := self selectedTextStyle fontOfPointSize: pointSize.
- ^font emphasized: emphasis!
Item was changed:
----- Method: FontChooserTool>>selectedFontIndex (in category 'font list') -----
selectedFontIndex
+
+ ^ selectedFontIndex ifNil: [0]!
- | 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.
- self selectedFontIndex: selectedFontIndex.
- ^selectedFontIndex!
Item was changed:
----- Method: FontChooserTool>>selectedFontIndex: (in category 'font list') -----
selectedFontIndex: anIndex
anIndex = 0 ifTrue: [^self].
selectedFontIndex := anIndex.
self changed: #selectedFontIndex.
self changed: #selectedFontStyleIndex.
+
+ self changed: #selectedFontTextStyle.
+ self changed: #contents.
+
self changed: #pointSizeList.
+ self changed: #selectedPointSizeIndex.
+ !
- self changed: #pointSizeIndex.
- self changed: #contents.!
Item was changed:
----- Method: FontChooserTool>>selectedFontStyleIndex: (in category 'style list') -----
selectedFontStyleIndex: anIndex
anIndex = 0 ifTrue: [^self].
emphasis := anIndex - 1.
self changed: #selectedFontStyleIndex.
+ self changed: #selectedFontTextStyle.
self changed: #contents.!
Item was added:
+ ----- Method: FontChooserTool>>selectedFontTextStyle (in category 'font list') -----
+ selectedFontTextStyle
+
+ ^ TextStyle fontArray: {self selectedFont}!
Item was changed:
----- Method: FontChooserTool>>selectedPointSizeIndex (in category 'point size') -----
selectedPointSizeIndex
+
+ ^ pointSize
+ ifNil: [0]
+ ifNotNil: [self pointSizeList indexOf: (pointSize printShowingDecimalPlaces: 1)]!
- ^self pointSizeList indexOf: (pointSize reduce asString padded: #left to: 3 with: $ )!
Item was changed:
----- Method: FontChooserTool>>selectedPointSizeIndex: (in category 'point size') -----
selectedPointSizeIndex: anIndex
anIndex = 0 ifTrue: [^self].
+ self pointSizeInput: (self pointSizeList at: anIndex).
+ self changed: #selectedPointSizeIndex.!
- pointSize := (self pointSizeList at: anIndex) withBlanksTrimmed asNumber.
- self changed: #pointSizeList.
- self changed: #contents.!
Item was changed:
----- Method: FontChooserTool>>selectedTextStyle (in category 'font list') -----
selectedTextStyle
+ ^ (TextStyle named: self selectedFontFamily)
+ ifNil: [ self getFontFromRequestor
+ ifNil: [ TextStyle default ]
+ ifNotNil: [:font | TextStyle fontArray: {font} "Not yet installed" ]].!
- ^TextStyle named: (self selectedFontFamily ifNil:[^TextStyle default]).!
Item was added:
+ ----- Method: FontChooserTool>>updateFromRequestor (in category 'updating') -----
+ updateFromRequestor
+
+
+ self getFontFromRequestor ifNotNil: [ :font |
+ | textStyleName |
+ textStyleName := font textStyleName.
+ self fontList
+ detect: [:f | f = textStyleName]
+ ifFound: [:family | self selectedFontIndex: (self fontList indexOf: family)].
+ self selectedFontStyleIndex: font emphasis + 1.
+ self pointSize: font pointSize].!
Item was removed:
- Object subclass: #FontImporterFontDescription
- instanceVariableNames: 'fontname filename children parent'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Morphic-Support'!
Item was removed:
- ----- Method: FontImporterFontDescription>><= (in category 'comparing') -----
- <= other
-
- ^ self fontname asString <= other fontname asString!
Item was removed:
- ----- Method: FontImporterFontDescription>>addChild: (in category 'accessing') -----
- addChild: aChild
-
- ^ self children add: aChild!
Item was removed:
- ----- Method: FontImporterFontDescription>>allFilenames (in category 'accessing') -----
- allFilenames
-
- ^ self filename
- ifNil: [
- (self children
- select: [:child | child filename notNil]
- thenCollect: [:child | child filename])
- asSet asArray]
- ifNotNil: [:f | {f}] !
Item was removed:
- ----- Method: FontImporterFontDescription>>children (in category 'accessing') -----
- children
-
- ^ children ifNil: [children := OrderedCollection new].!
Item was removed:
- ----- Method: FontImporterFontDescription>>children: (in category 'accessing') -----
- children: anObject
-
- children := anObject!
Item was removed:
- ----- Method: FontImporterFontDescription>>filename (in category 'accessing') -----
- filename
-
- ^ filename!
Item was removed:
- ----- Method: FontImporterFontDescription>>filename: (in category 'accessing') -----
- filename: anObject
-
- filename := anObject!
Item was removed:
- ----- Method: FontImporterFontDescription>>fontname (in category 'accessing') -----
- fontname
-
- ^ fontname!
Item was removed:
- ----- Method: FontImporterFontDescription>>fontname: (in category 'accessing') -----
- fontname: anObject
-
- fontname := anObject!
Item was removed:
- ----- Method: FontImporterFontDescription>>hasChildren (in category 'testing') -----
- hasChildren
-
- ^ self children notNil and: [self children notEmpty]!
Item was removed:
- ----- Method: FontImporterFontDescription>>normalize (in category 'actions') -----
- normalize
-
- self children size = 1 ifTrue: [ | pseudoChild |
- pseudoChild := self children removeFirst.
- (self filename notNil and: [pseudoChild filename ~= self filename])
- ifTrue: [self error: 'Inconsistent state'].
- self filename: pseudoChild filename]!
Item was removed:
- ----- Method: FontImporterFontDescription>>parent (in category 'accessing') -----
- parent
-
- ^ parent!
Item was removed:
- ----- Method: FontImporterFontDescription>>parent: (in category 'accessing') -----
- parent: anObject
-
- parent := anObject!
Item was removed:
- ----- Method: FontImporterFontDescription>>printOn: (in category 'printing') -----
- printOn: aStream
-
- self parent ifNotNil: [:p | aStream nextPutAll: p fontname; nextPut: $ ].
- aStream nextPutAll: self fontname.
- self children notEmpty ifTrue: [aStream nextPut: $ ].
- self children
- do: [:subfont | aStream nextPutAll: subfont fontname]
- separatedBy: [aStream nextPut: $/].
- aStream nextPut: $ ; nextPut: $(.
- self allFilenames
- do: [:filename | aStream nextPutAll: filename]
- separatedBy: [aStream nextPut: $,; nextPut: $ ].
- aStream nextPut: $).
- !
Item was changed:
Model subclass: #FontImporterTool
+ instanceVariableNames: 'title allFonts currentSelection currentParent selectedFont previewTextSelector customPreviewText pointSize lineSpacing editModeWidgets'
+ classVariableNames: 'CustomPreviewTexts'
- instanceVariableNames: 'title allFonts emphasis currentSelection currentParent warningSeen'
- classVariableNames: ''
poolDictionaries: ''
category: 'Morphic-Support'!
!FontImporterTool commentStamp: 'topa 3/9/2015 18:56' prior: 0!
A tool to import platform (native) fonts into the image!
Item was added:
+ ----- Method: FontImporterTool>>aboutToStyle: (in category 'preview text - code styling') -----
+ aboutToStyle: aStyler
+
+ previewTextSelector = #codeSample ifFalse: [^ false].
+ self customPreviewText ifNotEmpty: [^ false].
+
+ aStyler parseAMethod: true. "See Text class >> #codeSample."
+ ^ true!
Item was added:
+ ----- Method: FontImporterTool>>acceptCustomPreviewText: (in category 'preview text - custom') -----
+ acceptCustomPreviewText: aStringOrTextOrNil
+ "The user accepted (i.e. CMD+S or Return) the current input text, Now we store it in the list of custom texts so that it is retrievable via the preview button."
+
+ customPreviewText := aStringOrTextOrNil ifNotNil: [:value | value asString].
+ self changed: #customPreviewText.
+
+ self customPreviewText ifNotEmpty: [:customText |
+ CustomPreviewTexts ifNil: [CustomPreviewTexts := OrderedCollection new].
+ (CustomPreviewTexts includes: customText)
+ ifFalse:[CustomPreviewTexts add: customText] ].
+
+ ^ true!
Item was added:
+ ----- Method: FontImporterTool>>adjustXHeight (in category 'edit mode - actions') -----
+ adjustXHeight
+
+ self selectedFont adjustXHeight; adjustLineGapToGlyphScale.
+
+ self currentSelection
+ ttExtraScale: self selectedFont extraGlyphScale;
+ ttExtraGap: self selectedFont extraLineGap.
+
+ self changed: #objectChanged with: self currentSelection.
+ self changed: #selectedFontTextStyle.
+
+ self changed: #pointSizeInput.
+ self changed: #lineSpacingInput.
+ self changed: #ttExtraScaleInput.
+ self changed: #ttExtraGapInput.!
Item was changed:
+ ----- Method: FontImporterTool>>allFonts (in category 'font list/tree') -----
- ----- Method: FontImporterTool>>allFonts (in category 'accessing') -----
allFonts
- ^ allFonts ifNil: [ | fonts |
- fonts := Dictionary new.
- Cursor wait showWhile: [
- TTFileDescription fontPathsDo:[:path |
- TTFileDescription fontFilesIn: path do:[:font| | fontDesc filename fname |
- filename := path, FileDirectory slash, font fileName.
- fname := self textForFamily: font familyName subfamily: nil.
- fontDesc := fonts
- at: font familyName
- ifAbsentPut: (FontImporterFontDescription new fontname: fname; yourself).
- font subfamilyName
- ifNil: [fontDesc filename: filename]
- ifNotNil: [ |subfontDesc sname |
- sname := self textForFamily: font familyName subfamily: font subfamilyName.
- subfontDesc := FontImporterFontDescription new fontname: sname; yourself.
- subfontDesc
- parent: fontDesc;
- filename: filename.
- fontDesc addChild: subfontDesc]]]].
- allFonts := fonts values sorted.
- allFonts do: [:fontDesc | fontDesc normalize].
- allFonts].
+ ^ allFonts ifNil: [Cursor wait showWhile: [allFonts := TTFontFileHandle allHandles values sorted]]!
- !
Item was changed:
+ ----- Method: FontImporterTool>>allFonts: (in category 'font list/tree') -----
- ----- Method: FontImporterTool>>allFonts: (in category 'accessing') -----
allFonts: anObject
allFonts := anObject.
self changed: #allFonts.!
Item was added:
+ ----- Method: FontImporterTool>>applyFont (in category 'actions') -----
+ applyFont
+
+ | fontSymbols fontLabels choice |
+ fontSymbols := self fontSymbolsToUse.
+ fontLabels := fontSymbols collect: [:ea | (ea findFeatures joinSeparatedBy: ' ') capitalized].
+
+ fontSymbols := #(all allScaled), fontSymbols, #(fallback).
+ fontLabels := #('All fonts' 'All fonts (only font family)'), fontLabels, #('Fallback font').
+
+ choice := Project uiManager chooseFrom: fontLabels values: fontSymbols title: 'Apply font as...' translated.
+ choice ifNil: [^ self].
+
+ choice caseOf: {
+ [#all] -> [self applyFontToAll].
+ [#allScaled] -> [self applyFontToAllScaled].
+ [#fallback] -> [self applyFontToFallback].
+ } otherwise: [self applyFontTo: choice].!
Item was added:
+ ----- Method: FontImporterTool>>applyFontTo: (in category 'actions') -----
+ applyFontTo: fontSymbol
+
+ self currentSelection isInstalled ifFalse: [self installFont].
+
+ Cursor wait showWhile: [
+ UserInterfaceTheme setFont: fontSymbol to: self selectedFont].!
Item was added:
+ ----- Method: FontImporterTool>>applyFontToAll (in category 'actions') -----
+ applyFontToAll
+
+ | fontSymbolsToApply |
+ (Project uiManager
+ confirm: 'Do you really want to overwrite individual\point sizes and emphases such as in\buttons and window titles?' translated withCRs
+ title: 'Apply Font to Everything' translated)
+ ifFalse: [^ self].
+
+ self currentSelection isInstalled ifFalse: [self installFont].
+
+ fontSymbolsToApply := self selectedFont hasFixedWidth
+ ifTrue: [self fontSymbolsToUse]
+ ifFalse: [
+ self inform: 'This font is not monospaced. It will\not replace the current one.' translated withCRs.
+ self fontSymbolsToUse copyWithout: #standardFixedFont].
+
+ Cursor wait showWhile: [
+ UserInterfaceTheme makeAllTTCBased.
+ UserInterfaceTheme current applyAfter: [
+ fontSymbolsToApply do: [:fontSymbol |
+ UserInterfaceTheme setFont: fontSymbol to: self selectedFont] ]].!
Item was added:
+ ----- Method: FontImporterTool>>applyFontToAllScaled (in category 'actions') -----
+ applyFontToAllScaled
+ "Like #applyFontToAll but keep the respective point sizes and emphases."
+
+ | fontSymbolsToApply |
+ self currentSelection isInstalled ifFalse: [self installFont].
+
+ fontSymbolsToApply := self selectedFont hasFixedWidth
+ ifTrue: [self fontSymbolsToUse]
+ ifFalse: [
+ self inform: 'This font is not monospaced. It will\not replace the current one.' translated withCRs.
+ self fontSymbolsToUse copyWithout: #standardFixedFont].
+
+ Cursor wait showWhile: [
+ UserInterfaceTheme makeAllTTCBased.
+ UserInterfaceTheme current applyAfter: [
+ fontSymbolsToApply do: [:fontSymbol | | fontToUse |
+
+ (UserInterfaceTheme current get: fontSymbol)
+ ifNil: [fontToUse := self selectedFont]
+ ifNotNil: [:usedFont |
+ fontToUse := (self selectedFont
+ asPointSize: usedFont pointSize)
+ emphasized: usedFont emphasis].
+
+ UserInterfaceTheme setFont: fontSymbol to: fontToUse] ]].!
Item was added:
+ ----- Method: FontImporterTool>>applyFontToFallback (in category 'actions') -----
+ applyFontToFallback
+
+ self currentSelection isInstalled ifFalse: [self installFont].
+
+ Cursor wait showWhile: [
+ TextStyle setDefaultFallback: self selectedFont textStyleOrNil.
+ TextStyle installDefaultFallbackTextStyle].!
Item was added:
+ ----- Method: FontImporterTool>>browseFont (in category 'actions') -----
+ browseFont
+
+ self selectedFont browseAllGlyphsByCategory.!
Item was added:
+ ----- Method: FontImporterTool>>browseSystemFonts (in category 'actions') -----
+ browseSystemFonts
+ "Open a workspace that shows the current preview text with the usual system fonts so that users can compare the font they want to import."
+
+ | sample tmp fonts sorted contents preview |
+ previewTextSelector = #widgetSample
+ ifTrue: [ sample := [:font | self widgetSampleFor: font] ]
+ ifFalse: [
+ tmp := self previewText.
+ sample := [:font | tmp]].
+ (TextStyler for: #Smalltalk) ifNotNil: [:stylerClass |
+ | styler |
+ styler := stylerClass new.
+ (self aboutToStyle: styler)
+ ifTrue: [sample := [:font | styler styledTextFor: tmp asText]]].
+
+ fonts := IdentityDictionary new.
+ self fontSymbolsToUse do: [:ea |
+ | font |
+ font := UserInterfaceTheme current get: ea.
+ (fonts at: font ifAbsentPut: [OrderedCollection new]) add: ea].
+
+ sorted := fonts keys sorted: [:a :b |
+ a familyName < b familyName or: [a familyName = b familyName and: [
+ a pointSize < b pointSize or: [a pointSize = b pointSize and: [
+ a emphasis < b emphasis]]]]].
+
+ contents := Text streamContents: [:s |
+
+ sorted do: [:font |
+ preview := '{1} ({2} {3}pt)\ #{4}\\' withCRs asText format: {
+ font familyName asText addAttribute: (PluggableTextAttribute evalBlock: [font explore]); yourself.
+ font subfamilyName.
+ font pointSize.
+ (fonts at: font) joinSeparatedBy: '\ #' withCRs. }.
+
+ preview := preview, (sample value: font).
+ preview := preview, String cr. "for the consistent line height at the end"
+
+ s cr; nextPutAll: (preview asText addAttribute: (TextFontReference toFont: font); yourself); cr ]].
+
+ contents editWithLabel: 'Current system fonts'.!
Item was changed:
+ ----- Method: FontImporterTool>>buildButtonBarWith: (in category 'ui - building') -----
- ----- Method: FontImporterTool>>buildButtonBarWith: (in category 'toolbuilder') -----
buildButtonBarWith: builder
"Build the button bar"
+ | panelSpec |
- | panelSpec buttonSpec |
panelSpec := builder pluggablePanelSpec new.
panelSpec
layout: #horizontal;
children: OrderedCollection new.
+ {
+ #installButtonLabel.
+ #installButtonHelp.
+ #installButtonHit.
+ #installButtonColor.
+ #installButtonEnabled.
+
+ 'Apply...' translated.
+ 'Apply the current font in the system. Assure that the font is installed.' translated.
+ #applyFont.
+ nil.
+ nil.
+
+ "nil. nil. nil. nil."
+
+ 'Browse' translated.
+ 'Browse the glyphs. Do not install the font into the image.' translated.
+ #browseFont.
+ nil.
+ nil.
+
+ 'Explore' translated.
+ 'Explore the font object.' translated.
+ #exploreFont.
+ nil.
+ nil.
+ } groupsDo: [:label :help :action :buttonColor :enabled |
+ | spec |
+ action
+ ifNil: [
+ spec := builder pluggableSpacerSpec new]
+ ifNotNil: [
+ spec := builder pluggableButtonSpec new
+ model: self;
+ label: label;
+ color: buttonColor;
+ help: help;
+ action: action;
+ enabled: enabled;
+ yourself].
+ panelSpec children addLast: spec ].
- buttonSpec := builder pluggableButtonSpec new
- model: self;
- label: 'Import' translated;
- help: 'Include the font data in the image and provide a TextStyle for the font';
- action: #import;
- yourself.
- panelSpec children addLast: buttonSpec.
-
- buttonSpec := builder pluggableButtonSpec new
- model: self;
- label: 'Close' translated;
- action: #close;
- yourself.
- panelSpec children addLast: buttonSpec.
-
-
^panelSpec!
Item was changed:
+ ----- Method: FontImporterTool>>buildFontListWith: (in category 'ui - building') -----
- ----- Method: FontImporterTool>>buildFontListWith: (in category 'toolbuilder') -----
buildFontListWith: builder
"Build the font choosers list of font names"
^ builder pluggableTreeSpec new
model: self;
roots: #allFonts;
label: #labelOf: ;
getChildren: #childrenOf: ;
getSelected: #currentSelection;
setSelected: #currentSelection:;
setSelectedParent: #currentParent:;
menu: #fontListMenu:;
autoDeselect: false;
yourself
!
Item was added:
+ ----- Method: FontImporterTool>>buildFontPanelWith: (in category 'ui - building') -----
+ buildFontPanelWith: builder
+ "Build the main panel for the currently selected font (family). Includes a list of associated file names, an interactive preview panel and the copyright."
+
+ ^ builder pluggablePanelSpec new
+ children: {
+ builder pluggableTextSpec new
+ model: self;
+ getText: #filename;
+ readOnly: true;
+ indicateUnacceptedChanges: false;
+ font: self filenameFont;
+ help: '<- Please select a font family';
+ frame: (LayoutFrame
+ fractions: (0@0 corner: 1@0)
+ offsets: (0@0 corner: 0@ self filenameHeight));
+ yourself.
+
+ (self buildPreviewPaneWith: builder)
+ frame: (LayoutFrame
+ fractions: (0@0 corner: 1@1)
+ offsets: (0@ self filenameHeight corner: 0@ (self copyrightHeight negated)));
+ yourself.
+
+ builder pluggableTextSpec new
+ model: self;
+ getText: #copyright;
+ font: self copyrightFont;
+ readOnly: true;
+ indicateUnacceptedChanges: false;
+ frame: (LayoutFrame
+ fractions: (0@1 corner: 1@1)
+ offsets: (0 @ (self copyrightHeight negated) corner: 0 @ 0));
+ yourself
+
+ };
+ yourself!
Item was changed:
+ ----- Method: FontImporterTool>>buildPreviewPaneWith: (in category 'ui - building') -----
- ----- Method: FontImporterTool>>buildPreviewPaneWith: (in category 'toolbuilder') -----
buildPreviewPaneWith: builder
+ "Build the preview panel. Offer the user the change preview text through the default font, point size, extra (glyph) scale and extra (line) gap."
- "Build the preview panel"
^ builder pluggablePanelSpec new
+ " wantsResizeHandles: true;"
- wantsResizeHandles: true;
children: {
+ builder pluggablePanelSpec new
+ children: {
+ builder pluggableButtonSpec new
+ model: self;
+ help: #previewTextButtonHelp;
+ label: #previewTextButtonLabel;
+ action: #offerPreviewTextMenu;
+ frame: (LayoutFrame fractions: (0@0 corner: 0.15@1));
+ yourself.
+
+ builder pluggableInputFieldSpec new
+ model: self;
+ help: 'Type custom preview text here...' translated;
+ getText: #customPreviewText;
+ setText: #acceptCustomPreviewText:;
+ editText: #editCustomPreviewText:;
+ plainTextOnly: true;
+ frame: (LayoutFrame fractions: (0.15@0 corner: 0.85@1));
+ yourself.
+
+ builder pluggableButtonSpec new
+ model: self;
+ help: 'Click to see current preview text using the system''s current fonts for comparison' translated;
+ label: 'Compare' translated;
+ action: #browseSystemFonts;
+ frame: (LayoutFrame fractions: (0.85@0 corner: 1@1));
+ yourself };
+ frame: (LayoutFrame
- builder pluggableInputFieldSpec new
- model: self;
- getText: #filename;
- readOnly: true;
- indicateUnacceptedChanges: false;
- font: self filenameFont;
- frame: (LayoutFrame
fractions: (0@0 corner: 1@0)
+ offsets: (0@0 corner: 0@ self customPreviewTextHeight));
- offsets: (0@0 corner: 0@ self filenameHeight));
yourself.
+
-
builder pluggableTextSpec new
model: self;
getText: #previewText;
+ textStyle: #selectedFontTextStyle;
askBeforeDiscardingEdits: false;
indicateUnacceptedChanges: false;
softLineWrap: false;
+ padding: self previewTextPadding;
+ stylerClass: (TextStyler for: #Smalltalk);
+ menu: #previewTextMenu:shifted:;
+ frame: (LayoutFrame
+ fractions: (0@0 corner: 1@1)
+ offsets: (0 @ self customPreviewTextHeight corner: 0@ self configurationPanelHeight negated));
- frame: (LayoutFrame
- fractions: (0@0 corner: 1(a)0.75)
- offsets: (0@ self filenameHeight corner: 0@0));
yourself.
+ builder pluggablePanelSpec new name: #configPanel; children: (Array streamContents: [:s | | n |
+ n := 0.
+ self fontConfigurationSpecs groupsDo: [:kind :get :help :label :group | | w |
+ kind caseOf: {
+ [#spacer] -> [
+ w := builder pluggableSpacerSpec new fillSpaceHorizontally].
+ [#button] -> [
+ w := builder pluggableButtonSpec new
+ model: self; label: label; action: get; help: help; yourself].
+ [#text] -> [
+ w := builder pluggableInputFieldSpec new
+ model: self; getText: get; setText: get asSimpleSetter;
+ help: help; plainTextOnly: true; yourself].
+ } otherwise: [ "Ignore" ].
+ w ifNotNil: [ "Remember the group. See #toggleEditMode"
+ w name: (group, (n := n + 1)) asSymbol.
+ s nextPut: w] ]]);
+ layout: #horizontal;
+ frame: self configurationPanelFrame;
+ yourself.
- builder pluggableTextSpec new
- model: self;
- getText: #copyright;
- readOnly: true;
- indicateUnacceptedChanges: false;
- frame: (LayoutFrame
- fractions: (0(a)0.75 corner: 1@1));
- yourself
-
};
yourself!
Item was changed:
+ ----- Method: FontImporterTool>>buildWith: (in category 'ui - building') -----
- ----- Method: FontImporterTool>>buildWith: (in category 'toolbuilder') -----
buildWith: builder
"Create the ui for the browser"
"ToolBuilder open: self"
+ | windowSpec window |
- | windowSpec |
windowSpec := self buildWindowWith: builder specs: {
(self fontListFrame) -> [self buildFontListWith: builder].
+ (self fontPanelFrame) -> [self buildFontPanelWith: builder].
- (self previewFrame) -> [self buildPreviewPaneWith: builder].
(self buttonsFrame) -> [self buildButtonBarWith: builder].
}.
+ window := builder build: windowSpec.
+ self prepareEditMode: (builder widgetAt: #configPanel).
+ ^ window!
- ^ builder build: windowSpec!
Item was changed:
+ ----- Method: FontImporterTool>>buttonHeight (in category 'ui - layout') -----
- ----- Method: FontImporterTool>>buttonHeight (in category 'layout') -----
buttonHeight
+
+ ^ ToolBuilder default buttonRowHeight!
- ^ Preferences standardButtonFont height * 3!
Item was changed:
+ ----- Method: FontImporterTool>>buttonsFrame (in category 'ui - layout') -----
- ----- Method: FontImporterTool>>buttonsFrame (in category 'layout') -----
buttonsFrame
^ LayoutFrame
fractions: (0@1 corner: 1@1)
offsets: (0@ self buttonHeight negated corner: 0@0)
!
Item was changed:
+ ----- Method: FontImporterTool>>childrenOf: (in category 'font list/tree') -----
- ----- Method: FontImporterTool>>childrenOf: (in category 'accessing') -----
childrenOf: aFontDescription
^ aFontDescription children!
Item was removed:
- ----- Method: FontImporterTool>>close (in category 'actions') -----
- close
- self changed: #close.!
Item was added:
+ ----- Method: FontImporterTool>>configurationPanelFrame (in category 'ui - layout') -----
+ configurationPanelFrame
+
+ ^ LayoutFrame
+ fractions: (0@1 corner: 1@1)
+ offsets: (0 @ self configurationPanelHeight negated corner: 0@0)!
Item was added:
+ ----- Method: FontImporterTool>>configurationPanelHeight (in category 'ui - layout') -----
+ configurationPanelHeight
+
+ ^ ToolBuilder default inputFieldHeight!
Item was changed:
+ ----- Method: FontImporterTool>>copyright (in category 'accessing') -----
- ----- Method: FontImporterTool>>copyright (in category 'model access') -----
copyright
| f |
f := self selectedFont ifNil:[^ ''].
^ f isTTCFont
ifTrue: [f ttcDescription copyright ifNil: ['']]
ifFalse: ['']!
Item was added:
+ ----- Method: FontImporterTool>>copyrightFont (in category 'ui - layout') -----
+ copyrightFont
+
+ ^ Preferences standardBalloonHelpFont!
Item was added:
+ ----- Method: FontImporterTool>>copyrightHeight (in category 'ui - layout') -----
+ copyrightHeight
+
+ ^ ToolBuilder default helpFieldHeightFor: 3!
Item was changed:
+ ----- Method: FontImporterTool>>currentParent (in category 'font list/tree') -----
- ----- Method: FontImporterTool>>currentParent (in category 'accessing') -----
currentParent
^ currentParent!
Item was changed:
+ ----- Method: FontImporterTool>>currentParent: (in category 'font list/tree') -----
- ----- Method: FontImporterTool>>currentParent: (in category 'accessing') -----
currentParent: anObject
anObject = currentParent ifTrue: [^ self].
currentParent := anObject.
self changed: #currentParent.
!
Item was changed:
+ ----- Method: FontImporterTool>>currentSelection (in category 'font list/tree') -----
- ----- Method: FontImporterTool>>currentSelection (in category 'accessing') -----
currentSelection
^ currentSelection!
Item was changed:
+ ----- Method: FontImporterTool>>currentSelection: (in category 'font list/tree') -----
+ currentSelection: fontHandleOrNil
- ----- Method: FontImporterTool>>currentSelection: (in category 'accessing') -----
- currentSelection: anObject
+ fontHandleOrNil = currentSelection ifTrue: [
+ ^ self].
+
+ fontHandleOrNil
+ ifNil: [
+ "User probably collapsed subtree with prior selection."
+ self selectTextStyleNamed: self selectedFont textStyleName]
+ ifNotNil: [
+ currentSelection := fontHandleOrNil.
+ self changed: #currentSelection].
+
+ fontHandleOrNil
+ ifNotNil: [self editModeEnabled: self currentSelection isModified].
+
+ self selectedFont: nil. "Refresh preview"
+
+ !
- anObject = currentSelection ifTrue: [^ self].
- currentSelection := anObject.
- self changed: #currentSelection.
- self changed: #previewText.
- self changed: #filename.
- self changed: #copyright.!
Item was added:
+ ----- Method: FontImporterTool>>customPreviewText (in category 'preview text - custom') -----
+ customPreviewText
+
+ ^ customPreviewText ifNil: ['']!
Item was added:
+ ----- Method: FontImporterTool>>customPreviewTextFont (in category 'ui - layout') -----
+ customPreviewTextFont
+
+ ^ TextStyle defaultFont!
Item was added:
+ ----- Method: FontImporterTool>>customPreviewTextHeight (in category 'ui - layout') -----
+ customPreviewTextHeight
+
+ ^ ToolBuilder default inputFieldHeight!
Item was added:
+ ----- Method: FontImporterTool>>defaultButtonColor (in category 'ui - colors') -----
+ defaultButtonColor
+
+ ^ (UserInterfaceTheme current get: #color for: #PluggableButtonMorph) ifNil: [Color gray: 0.91]!
Item was added:
+ ----- Method: FontImporterTool>>discardCustomPreviewTexts (in category 'preview text - custom') -----
+ discardCustomPreviewTexts
+
+ CustomPreviewTexts := nil.
+ self setCustomPreviewText: nil.!
Item was added:
+ ----- Method: FontImporterTool>>editButtonHelp (in category 'edit mode - ui') -----
+ editButtonHelp
+
+ ^ 'Modify font properties such as <b>extra glyph scale</b> and <b>extra line gap</b>, which will be shared through all point sizes and text styles. Be careful.' translated asTextFromHtml!
Item was added:
+ ----- Method: FontImporterTool>>editCustomPreviewText: (in category 'preview text - custom') -----
+ editCustomPreviewText: aStringOrTextOrNil
+ "The user typed something. Use it directly as a new preview text. Note that CMD+S (or Return) means that the user wants to save the text for later."
+
+ customPreviewText := aStringOrTextOrNil ifNotNil: [:value | value asString].
+ self changed: #previewText.
+ self changed: #previewTextButtonLabel.!
Item was added:
+ ----- Method: FontImporterTool>>editModeEnabled (in category 'edit mode') -----
+ editModeEnabled
+
+ ^ Project current isMorphic
+ ifFalse: [false]
+ ifTrue: [(editModeWidgets at: #on) first visible]!
Item was added:
+ ----- Method: FontImporterTool>>editModeEnabled: (in category 'edit mode') -----
+ editModeEnabled: showEditWidgets
+
+ Project current isMorphic ifFalse: [^ self].
+
+ showEditWidgets
+ ifFalse: [
+ (editModeWidgets at: #on) do: [:ea | ea hide; disableLayout: true].
+ (editModeWidgets at: #off) do: [:ea | ea show; disableLayout: false]]
+ ifTrue: [
+ (editModeWidgets at: #on) do: [:ea | ea show; disableLayout: false].
+ (editModeWidgets at: #off) do: [:ea | ea hide; disableLayout: true]].!
Item was removed:
- ----- Method: FontImporterTool>>emphasis (in category 'accessing') -----
- emphasis
-
- ^ emphasis!
Item was removed:
- ----- Method: FontImporterTool>>emphasis: (in category 'accessing') -----
- emphasis: anObject
-
- emphasis := anObject!
Item was added:
+ ----- Method: FontImporterTool>>errorText: (in category 'preview text') -----
+ errorText: aString
+ "Style the error text in a font that can display the characters."
+
+ ^ Text
+ string: aString
+ attribute: (TextFontReference toFont: TextStyle defaultFont)!
Item was added:
+ ----- Method: FontImporterTool>>exploreFont (in category 'actions') -----
+ exploreFont
+
+ self selectedFont explore.!
Item was changed:
+ ----- Method: FontImporterTool>>filename (in category 'accessing') -----
- ----- Method: FontImporterTool>>filename (in category 'model access') -----
filename
^ self currentSelection
ifNil: ['']
ifNotNil: [:sel |
String streamContents: [:stream |
+ (sel allFilenames ifEmpty: [{'(unknown file location; image only)' translated}])
- sel allFilenames
do: [:filename | stream nextPutAll: filename]
+ separatedBy: [stream cr ]]]!
- separatedBy: [stream nextPut: $,;nextPut: $ ]]]!
Item was changed:
+ ----- Method: FontImporterTool>>filenameFont (in category 'ui - layout') -----
- ----- Method: FontImporterTool>>filenameFont (in category 'toolbuilder') -----
filenameFont
+
+ ^ Preferences standardBalloonHelpFont!
- ^ Preferences standardDefaultTextFont!
Item was changed:
+ ----- Method: FontImporterTool>>filenameHeight (in category 'ui - layout') -----
- ----- Method: FontImporterTool>>filenameHeight (in category 'layout') -----
filenameHeight
+
+ ^ ToolBuilder default helpFieldHeightFor: 2 "lines"!
- ^ self filenameFont height * 2!
Item was removed:
- ----- Method: FontImporterTool>>font:hasGlyphOf: (in category 'helper') -----
- font: f hasGlyphOf: aCharacter
-
- | font |
- font := f isFontSet ifTrue: [f fontArray first] ifFalse: [f].
- ^ font isTTCFont
- ifFalse: [font hasGlyphOf: aCharacter]
- ifTrue: [
- " [(f hasGlyphOf: aCharacter) not] does not work, the fallback glyph is always found instead.
- So we fake. if aCharacter is the same form as Character null aka 0, we assume absence."
- (font characterFormAt: aCharacter) bits ~= font fallbackForm bits]
- !
Item was added:
+ ----- Method: FontImporterTool>>fontConfigurationSpecs (in category 'ui - building') -----
+ fontConfigurationSpecs
+
+ ^ #(
+ text pointSizeInput pointSizeInputHelp nil preview
+ text lineSpacingInput lineSpacingInputHelp nil preview
+ spacer nil nil nil preview
+ button adjustXHeight 'Adjust the font''s x-height to match the system''s default font.' 'Adjust x' edit
+ text ttExtraScaleInput ttExtraScaleInputHelp nil edit
+ text ttExtraGapInput ttExtraGapInputHelp nil edit
+ button resetFontMetrics 'Reset all fields to their default value. Disable the edit mode.' 'Reset' edit
+ button toggleEditMode editButtonHelp 'Edit' toggle
+ )!
Item was removed:
- ----- Method: FontImporterTool>>fontFromFamily: (in category 'helper') -----
- fontFromFamily: aFamily
-
- | readFonts |
- aFamily ifNil: [^ TextStyle default fonts first].
- readFonts := TTFileDescription readFontsFrom: aFamily allFilenames anyOne.
- ^ (readFonts size > 1
- ifTrue: [
- | ftArray |
- " see TTCFontSet>>newTextStyleFromTT: "
- ftArray := readFonts collect: [:ttc | |f|
- ttc ifNil: [nil] ifNotNil: [
- f := TTCFont new.
- f ttcDescription: ttc.
- f pointSize: 11.0 .
- f]].
- TTCFontSet newFontArray: ftArray]
- ifFalse: [ |f|
- f := TTCFont new.
- f ttcDescription: readFonts anyOne.
- f pointSize: 11.0 .
- f])!
Item was changed:
+ ----- Method: FontImporterTool>>fontListFrame (in category 'ui - layout') -----
- ----- Method: FontImporterTool>>fontListFrame (in category 'layout') -----
fontListFrame
^ LayoutFrame
+ fractions: (0@0 corner: 0.25@1)
- fractions: (0@0 corner: 0.4@1)
offsets: (0@0 corner: 0@ self buttonHeight negated)!
Item was changed:
+ ----- Method: FontImporterTool>>fontListMenu: (in category 'font list/tree') -----
- ----- Method: FontImporterTool>>fontListMenu: (in category 'font list') -----
fontListMenu: aMenu
^ aMenu addTranslatedList: #(
+ ('Browse' browseFont 'Browse all glyphs in the font')
+ ('Explore' exploreFont 'Explore the font object')
+ -
+ ('Install' installFont 'Make the font available in the environment but keep the glyph data outside the image')
+ ('Install & Load' installAndLoadFont 'Make the font available in the environment including all the glyph data to ensure portability of the image')
+ ), (self selectedFont textStyleOrNil ifNil: [#()] ifNotNil: [#(
+ -
+ ('Uninstall' uninstallFont 'Remove the font from the system')
+ )])
- ('Import Font' import 'Include the font data in the image and provide a TextStyle for the font')
- ('Link Font' link 'Install the font as a link to its file and provide a TextStyle for the referenced font'))
yourself!
Item was added:
+ ----- Method: FontImporterTool>>fontPanelFrame (in category 'ui - layout') -----
+ fontPanelFrame
+
+ ^ LayoutFrame
+ fractions: (0.25@0 corner: 1@1)
+ offsets: (0@0 corner: 0@ self buttonHeight negated)!
Item was added:
+ ----- Method: FontImporterTool>>fontSymbolsToUse (in category 'accessing') -----
+ fontSymbolsToUse
+
+ ^ UserInterfaceTheme knownFontSymbols reject: [:ea | ea beginsWith: #wizard]!
Item was removed:
- ----- Method: FontImporterTool>>import (in category 'actions') -----
- import
- | megaSize filenames fonts |
- fonts := self currentSelection.
- filenames := fonts allFilenames.
- megaSize := ((filenames inject: 0 into: [ :sum :fn |
- sum + (FileStream readOnlyFileNamed: fn do: [:file | file size])]) / (1024 * 1024)) asFloat.
- (UIManager default confirm: (
- 'About to import {1}{2}.\\This is at least {3} MB of space required in the image.\
- Please respect the copyright and embedding restrictions of the font.\
- Proceed?'
- withCRs format: {
- self currentParent
- ifNotNil: [:p| p fontname, ' ', self currentSelection fontname]
- ifNil: [self currentSelection fontname].
- filenames size > 1 ifTrue: [' (', filenames size, ' font files)'] ifFalse: [''].
- megaSize printShowingDecimalPlaces: 2}))
- ifTrue: [
- filenames do: [:filename | | readFonts |
- readFonts := TTCFontDescription addFromTTFile: filename.
- readFonts isCollection
- ifFalse: [TTCFont newTextStyleFromTT: readFonts]
- ifTrue: [self importFontFamily: readFonts]]].
- self allFonts: nil. "force redraw"
- !
Item was removed:
- ----- Method: FontImporterTool>>importFontFamily: (in category 'helper') -----
- importFontFamily: readFonts
-
- |r rest array |
- r := readFonts detect: [:f |
- [f isRegular] on: Error do: [false] "hack for unknown emphases"
- ] ifNone: [^ TTCFont newTextStyleFromTT: readFonts first].
- rest := readFonts copyWithout: r.
- array :=TTCFont pointSizes collect: [:pt | | f |
- f := TTCFont new ttcDescription: r; pointSize: pt; yourself.
- rest do: [:rf |
- (self isStyleNameSupported: rf subfamilyName)
- ifTrue: [f derivativeFont: (TTCFont new ttcDescription: rf; pointSize: pt; yourself)]
- ifFalse: [
- Transcript show: 'Cannot import unknown style ', rf subfamilyName, ' from Font family ', f name]].
- f].
- ^ TTCFont reorganizeForNewFontArray: array name: array first name asSymbol.!
Item was changed:
----- Method: FontImporterTool>>initialExtent (in category 'initialize') -----
initialExtent
+ ^ 670@500!
- ^ 600@400.!
Item was changed:
----- Method: FontImporterTool>>initialize (in category 'initialize') -----
initialize
super initialize.
+
+ previewTextSelector := #textSample.
+ self selectTextStyleNamed: self selectedFont textStyleName.!
- emphasis := 0.
- !
Item was added:
+ ----- Method: FontImporterTool>>installAndLoadFont (in category 'actions') -----
+ installAndLoadFont
+
+ self installFont ifTrue: [
+ self selectedFont becomeLocalFont.
+ self currentSelection parent ifNotNil: [:p | self currentSelection: p].
+ self changed: #objectChanged with: self currentSelection].
+
+ self flag: #todo. "mt: Warn the user about space constraints!!"!
Item was added:
+ ----- Method: FontImporterTool>>installButtonColor (in category 'ui - installation') -----
+ installButtonColor
+
+ self currentSelection ifNil: [^ self defaultButtonColor].
+
+ ^ self currentSelection isFullyInstalled
+ ifTrue: [self uninstallColor]
+ ifFalse: [self installColor]!
Item was added:
+ ----- Method: FontImporterTool>>installButtonEnabled (in category 'ui - installation') -----
+ installButtonEnabled
+
+ ^ self currentSelection
+ ifNil: [false]
+ ifNotNil: [:handle | handle isProtected not]!
Item was added:
+ ----- Method: FontImporterTool>>installButtonHelp (in category 'ui - installation') -----
+ installButtonHelp
+
+ self currentSelection ifNil: [^ ''].
+
+ ^ self currentSelection isInstalled
+ ifTrue: ['Remove all font data from the image. Note that existing texts or text styles may still refer to it for a while longer.' translated]
+ ifFalse: ['Include the font data in the image and provide a TextStyle for the font' translated].!
Item was added:
+ ----- Method: FontImporterTool>>installButtonHit (in category 'ui - installation') -----
+ installButtonHit
+
+ self currentSelection ifNil: [^ self].
+
+ self currentSelection isFullyInstalled
+ ifTrue: [self uninstallFont]
+ ifFalse: [self installFont].
+
+ self changed: #installButtonLabel.
+ self changed: #installButtonColor.!
Item was added:
+ ----- Method: FontImporterTool>>installButtonLabel (in category 'ui - installation') -----
+ installButtonLabel
+
+ self currentSelection ifNil: [^ 'Install' translated].
+
+ ^ self currentSelection isFullyInstalled
+ ifTrue: ['Uninstall' translated]
+ ifFalse: [
+ self currentSelection isInstalled
+ ifTrue: ['Update' translated]
+ ifFalse: ['Install' translated] ]!
Item was added:
+ ----- Method: FontImporterTool>>installColor (in category 'ui - colors') -----
+ installColor
+
+ ^ (UserInterfaceTheme current get: #okColor for: #ListChooser) ifNil: [Color r: 0.49 g: 0.749 b: 0.49]!
Item was added:
+ ----- Method: FontImporterTool>>installFont (in category 'actions') -----
+ installFont
+ "Install the selected font. Inform tha user that a modification is best reflected with a custom font name so that it is possible to also install the font with its original parameters."
+
+ | handle wasRenamed |
+ handle := self currentSelection.
+ wasRenamed := false.
+
+ (handle isModified and: [handle hasModifiedName not]) ifTrue: [
+ (Project uiManager
+ request: 'You modified the selected font.\Please choose a new name:' translated withCRs
+ initialAnswer: 'My ', handle familyName)
+ ifEmpty: [^ false]
+ ifNotEmpty: [:answer |
+ wasRenamed := true.
+ handle fontname: answer]].
+
+ self currentSelection installFont.
+ self selectedFont: nil. "New identity from the handle"
+
+ wasRenamed ifTrue: [
+ "New child in the tree. So refresh everything."
+ allFonts := nil. self changed: #allFonts. ^ true].
+
+ self currentSelection parent ifNotNil: [:p | self currentSelection: p].
+ self changed: #objectChanged with: self currentSelection.
+
+ ^ true!
Item was removed:
- ----- Method: FontImporterTool>>isStyleNameSupported: (in category 'helper') -----
- isStyleNameSupported: subfamilyName
-
- ^ (TextStyle decodeStyleName: subfamilyName) second isEmpty!
Item was changed:
+ ----- Method: FontImporterTool>>labelOf: (in category 'font list/tree') -----
+ labelOf: aHandle
- ----- Method: FontImporterTool>>labelOf: (in category 'model access') -----
- labelOf: aFontDescription
+ | label numSubfamilies|
+ self flag: #performance. "mt: Cache labels?"
+
+ label := aHandle fontname.
+
+ aHandle isLocalFont ifTrue: [label := '[', label, ']'].
+ (aHandle hasChildren and: [(numSubfamilies := aHandle children size) > 1])
+ ifTrue: [label := label, ' (', numSubfamilies, ')'].
+ aHandle isModified ifTrue: [label := label, ' *'].
+ label := label asText.
+ aHandle isFullyInstalled
+ ifTrue: [label addAttribute: TextEmphasis underlined]
+ ifFalse: [aHandle isInstalled ifTrue: [
+ label := '!! ' asText, label ]].
+ aHandle isSubfamilySupported
+ ifFalse: [label addAttribute: TextColor gray].
+ ^ label!
- ^ aFontDescription fontname
-
- !
Item was added:
+ ----- Method: FontImporterTool>>lineSpacing (in category 'preview text - ui') -----
+ lineSpacing
+
+ ^ lineSpacing ifNil: [0.0]!
Item was added:
+ ----- Method: FontImporterTool>>lineSpacingInput (in category 'preview text - ui') -----
+ lineSpacingInput
+ "Redirect through #selectedFontTextStyle to get automatic suggestions e.g., for symbol fonts."
+
+ ^ (lineSpacing ifNil: [self selectedFontTextStyle lineSpacing]) asString!
Item was added:
+ ----- Method: FontImporterTool>>lineSpacingInput: (in category 'preview text - ui') -----
+ lineSpacingInput: anObject
+
+ self currentSelection ifNil: [^ false].
+
+ lineSpacing := [anObject asNumber] on: NumberParserError do: [nil].
+ self changed: #lineSpacingInput.
+ self changed: #selectedFontTextStyle.
+
+ ^ true!
Item was added:
+ ----- Method: FontImporterTool>>lineSpacingInputHelp (in category 'preview text - ui') -----
+ lineSpacingInputHelp
+
+ self editModeEnabled ifFalse: [
+ ^ 'Line spacing in the preview box' translated].
+
+ ^ '<b>Line spacing</b> in the preview box. A factor of 0.0 means no extra spacing while 1.0 means to double the current line height, which is based on the fonts within each line. The value may be negative.<br><br>Note that line spacing is application-specific and can thus be different for any <b>text style</b> (or text field). You can tweak the font itself through <b>extra line gap</b> to affect all its uses.<br><br>Make empty to reset to default value.' translated asTextFromHtml!
Item was removed:
- ----- Method: FontImporterTool>>link (in category 'actions') -----
- link
- | filenames fonts |
- fonts := self currentSelection.
- self warningSeen ifFalse: [
- (UIManager default confirm: (
- 'Note that linking a font instead of importing may make the
- image un-portable, since the linked font must be present on
- the system the next time the image is run.
-
- This warning is only shown once per session.' ) trueChoice: 'Proceed' falseChoice: 'Cancel')
- ifFalse: [^ self].
- self warningSeen: true]..
- filenames := fonts allFilenames.
- filenames do: [:filename | | readFonts |
- readFonts := TTFileDescription readFontsFrom: filename.
- readFonts isCollection
- ifFalse: [TTCFont newTextStyleFromTT: readFonts]
- ifTrue: [self importFontFamily: readFonts]].
- self allFonts: nil. "force redraw"!
Item was added:
+ ----- Method: FontImporterTool>>offerPreviewTextMenu (in category 'preview text') -----
+ offerPreviewTextMenu
+
+ | builder menuSpec |
+ builder := ToolBuilder default.
+ menuSpec := builder pluggableMenuSpec new.
+
+ #(textSample codeSample widgetSample nil forssmanSample melvilleSample fontSample) do: [:selector |
+ selector ifNil: [menuSpec addLine] ifNotNil: [
+ | item marker |
+ marker := (customPreviewText isEmptyOrNil and: [previewTextSelector = selector])
+ ifTrue: ['<yes>'] ifFalse: ['<no>'].
+ item := menuSpec
+ add: marker, (self previewTextSelectorLabelFor: selector)
+ target: self
+ selector: #setPreviewTextSelector:
+ argumentList: {selector}.
+ item help: (self previewTextSelectorHelpFor: selector)]].
+ menuSpec addLine.
+
+ (CustomPreviewTexts ifNil: [CustomPreviewTexts := OrderedCollection new])
+ do: [:text | | marker |
+ marker := customPreviewText = text ifTrue: ['<yes>'] ifFalse: ['<no>'].
+ menuSpec
+ add: marker, (text contractTo: 40)
+ target: self
+ selector: #setCustomPreviewText:
+ argumentList: {text}].
+ CustomPreviewTexts ifNotEmpty: [menuSpec addLine].
+
+ menuSpec
+ add: 'Discard custom texts' translated
+ target: self
+ selector: #discardCustomPreviewTexts
+ argumentList: #().
+
+ builder runModal: (builder open: menuSpec).!
Item was added:
+ ----- Method: FontImporterTool>>okToClose (in category 'ui - building') -----
+ okToClose
+ "Check for modifications to not installed fonts. Ask the user if those modifications should be discarded. Not that modifications to installed fonts were already applied."
+
+ | modifiedFonts |
+ modifiedFonts := self allFonts "top level" select: [:ea | ea isModified and: [ea isInstalled not]].
+ ^ (super okToClose and: [modifiedFonts isEmpty])
+ ifTrue: [true]
+ ifFalse: [Project uiManager
+ confirm: ('You modified the following fonts:\\' translated,
+ (modifiedFonts inject: '' into: [:list :each | list, ' ', each fontname, '\']),
+ '\These fonts are not yet installed. Do\you want to discard your changes?' translated) withCRs
+ title: 'Discard Changes' translated]!
Item was added:
+ ----- Method: FontImporterTool>>pointSize (in category 'preview text - ui') -----
+ pointSize
+
+ ^ pointSize ifNil: [TextStyle defaultFont pointSize]!
Item was added:
+ ----- Method: FontImporterTool>>pointSizeInput (in category 'preview text - ui') -----
+ pointSizeInput
+
+ ^ self pointSize asString!
Item was added:
+ ----- Method: FontImporterTool>>pointSizeInput: (in category 'preview text - ui') -----
+ pointSizeInput: anObject
+
+ self currentSelection ifNil: [^ false].
+
+ pointSize := [anObject asNumber roundTo: 0.5] on: NumberParserError do: [TextStyle defaultFont pointSize].
+ pointSize := pointSize max: 1.0.
+ self changed: #pointSizeInput.
+ self selectedFont: nil.
+
+ ^ true!
Item was added:
+ ----- Method: FontImporterTool>>pointSizeInputHelp (in category 'preview text - ui') -----
+ pointSizeInputHelp
+
+ self editModeEnabled ifFalse: [
+ ^ 'Point size in the preview box' translated].
+
+ ^ ('<b>Point size</b> in the preview box. The system''s default is currently <b>{1}</b> points. It is recommended to adjust the font''s <b>extra glyph scale</b> and <b>extra line gap</b> using the default point size. Look at other text in the system to assess whether this font would integrate nicely.<br><br>Make empty to reset to default value.' translated
+ format: {TextStyle defaultFont pointSize}) asTextFromHtml!
Item was added:
+ ----- Method: FontImporterTool>>prepareEditMode: (in category 'edit mode') -----
+ prepareEditMode: container
+
+ Project current isMorphic ifFalse: [^ self].
+
+ editModeWidgets := Dictionary new
+ at: #on put: OrderedCollection new;
+ at: #off put: OrderedCollection new;
+ yourself.
+
+ container allMorphsDo: [:m |
+ ((m knownName ifNil: ['']) beginsWith: 'edit')
+ ifTrue: [(editModeWidgets at: #on) add: m]
+ ifFalse: [((m knownName ifNil: ['']) beginsWith: 'toggle')
+ ifTrue: [(editModeWidgets at: #off) add: m]]].
+
+ self toggleEditMode. "Turn it off"!
Item was removed:
- ----- Method: FontImporterTool>>previewFrame (in category 'layout') -----
- previewFrame
-
- ^ LayoutFrame
- fractions: (0.4@0 corner: 1@1)
- offsets: (0@0 corner: 0@ self buttonHeight negated)!
Item was changed:
+ ----- Method: FontImporterTool>>previewText (in category 'preview text') -----
- ----- Method: FontImporterTool>>previewText (in category 'model access') -----
previewText
+ "Answer the current preview text. Avoid using a text with font-reference attributes so that any not-yet-installed font does not get spreaded across the system. See #selectedFontTextStyle to learn how the preview is rendered using the selected font."
+ self customPreviewText ifNotEmpty: [:text | ^ text withCRs].
+
+ previewTextSelector = #fontSample ifTrue: [
+ ^ self selectedFont ttcDescription sampleText
+ ifEmpty: [self errorText: 'This font does not provide a sample text.' translated]].
+
+ (previewTextSelector ~= #textSample and: [self selectedFont isSymbolFont])
+ ifTrue: [^ self errorText: 'This symbol font does not support the preview text.\Please use ''Text/Symbol'' or type a custom text.' translated withCRs].
+
+ self selectedFont isSymbolFont
+ ifTrue: [^ self selectedFont symbolSample asString].
+ (Text respondsTo: previewTextSelector)
+ ifTrue: [^ (Text perform: previewTextSelector) asString].
+ previewTextSelector = #widgetSample
+ ifTrue: [^ self widgetSample].
+
+ ^ ''!
- ^ self selectedFont
- ifNil: [Text new]
- ifNotNil: [:font | font sampleText]!
Item was added:
+ ----- Method: FontImporterTool>>previewTextButtonHelp (in category 'preview text') -----
+ previewTextButtonHelp
+
+ ^ self customPreviewText
+ ifNotEmpty: [^ 'Custom ->' "The arrow points to the input field in the UI."]
+ ifEmpty: [self previewTextSelectorHelpFor: previewTextSelector]!
Item was added:
+ ----- Method: FontImporterTool>>previewTextButtonLabel (in category 'preview text') -----
+ previewTextButtonLabel
+
+ ^ self customPreviewText
+ ifNotEmpty: ['Custom ->']
+ ifEmpty: [self previewTextSelectorLabelFor: previewTextSelector]!
Item was added:
+ ----- Method: FontImporterTool>>previewTextMenu:shifted: (in category 'preview text') -----
+ previewTextMenu: aMenu shifted: shifted
+ <previewTextMenu>
+ "See commentary in StringHolder >> #mainCodePaneMenu:shifted:."
+
+ ^ StringHolder codePaneMenu: aMenu shifted: shifted!
Item was added:
+ ----- Method: FontImporterTool>>previewTextPadding (in category 'preview text') -----
+ previewTextPadding
+ "Static. Give a little bit more space so that the user can focus on the font, not the window ui. For UI themes that use bitmap fonts (i.e., the default 75%, 100%, 125%, and 150% scale factor) use the current font metrics. Otherwise, just use a font-agnostic measure in points. Maybe we can make text-field margins more dynamic (and per-font) in the future."
+
+ ^ UserInterfaceTheme current isTTCBased
+ ifTrue: [(TextStyle pointsToPixels: 16 "pt" @20 "pt") truncated]
+ ifFalse: [(TextStyle defaultFont widthOf: $m) @ TextStyle defaultFont lineGrid]!
Item was added:
+ ----- Method: FontImporterTool>>previewTextSelectorHelpFor: (in category 'preview text') -----
+ previewTextSelectorHelpFor: symbol
+
+ ^ symbol caseOf: {
+ [#textSample] -> ['See the font''s alphabet as a dummy text. For symbol fonts, show a selection of symbols.' translated].
+ [#codeSample] -> ['See how the font would render some Smalltalk source code.' translated].
+ [#forssmanSample] -> ['See an example of ragged text used in the book "Detailtypografie" by Friedrich Forssman and Ralf de Jong.' translated].
+ [#melvilleSample] -> ['See the first two paragraphs of "Moby Dick" by Herman Melville.' translated].
+ [#fontSample] -> ['See the example text that was provided by the font designer in the font description itself.' translated asTextFromHtml].
+ [#widgetSample] -> ['See how the font would look in a list, tree, or menu widget.' translated].
+ } otherwise: [ '' ]!
Item was added:
+ ----- Method: FontImporterTool>>previewTextSelectorLabelFor: (in category 'preview text') -----
+ previewTextSelectorLabelFor: symbol
+
+ ^ symbol caseOf: {
+ [#textSample] -> ['Text/Symbols'].
+ [#codeSample] -> ['Source code'].
+ [#widgetSample] -> ['Widgets'].
+ [#forssmanSample] -> ['Forssman'].
+ [#melvilleSample] -> ['Melville'].
+ [#fontSample] -> ['Font sample'].
+ } otherwise: [ '???' ]!
Item was added:
+ ----- Method: FontImporterTool>>resetFontMetrics (in category 'edit mode - actions') -----
+ resetFontMetrics
+
+ self selectedFont familyName = TextStyle defaultTTFont familyName
+ ifTrue: [^ self inform: 'You should not reset the font that is used as\reference for x-height adjustment. Please\change manually if at all.' translated withCRs].
+
+ self toggleEditMode.
+
+ pointSize := nil.
+ lineSpacing := nil.
+
+ self currentSelection ifNotNil: [:fontDescr |
+ fontDescr ttExtraScale: nil.
+ fontDescr ttExtraGap: nil].
+
+ self changed: #objectChanged with: self currentSelection.
+ self selectedFont: nil. !
Item was added:
+ ----- Method: FontImporterTool>>selectTextStyleNamed: (in category 'initialize') -----
+ selectTextStyleNamed: textStyleName
+
+ currentSelection := (self allFonts detect: [:handle | handle textStyleName = self selectedFont textStyleName]).
+ self changed: #currentSelection.!
Item was changed:
+ ----- Method: FontImporterTool>>selectedFont (in category 'accessing') -----
- ----- Method: FontImporterTool>>selectedFont (in category 'font list') -----
selectedFont
+
+ ^ selectedFont ifNil: [selectedFont := self currentSelection
+ ifNil: [TextStyle defaultTTFont]
+ ifNotNil: [:o | o fontOfPointSize: self pointSize] ]!
- | fontDesc font |
- fontDesc := self currentSelection.
- font := self fontFromFamily: fontDesc.
- font isFontSet ifTrue: [
- font := (self currentParent isNil or: [self currentParent = self currentSelection])
- ifTrue: [font fontArray anyOne]
- ifFalse: [ "we have selected a leaf "
- font fontArray
- detect: [:subfont | subfont subfamilyName = fontDesc fontname]
- ifNone: [font]]].
- ^font emphasized: emphasis!
Item was added:
+ ----- Method: FontImporterTool>>selectedFont: (in category 'accessing') -----
+ selectedFont: aTTCFont
+
+ selectedFont := aTTCFont.
+
+ self changed: #previewText.
+ self changed: #selectedFontTextStyle.
+
+ self changed: #filename.
+ self changed: #copyright.
+
+ self changed: #pointSizeInput.
+ self changed: #lineSpacingInput.
+ self changed: #ttExtraScaleInput.
+ self changed: #ttExtraGapInput.
+
+ self changed: #installButtonColor.
+ self changed: #installButtonLabel.
+ self changed: #installButtonEnabled.
+
+ self changed: #windowTitle.!
Item was added:
+ ----- Method: FontImporterTool>>selectedFontTextStyle (in category 'accessing') -----
+ selectedFontTextStyle
+ "Construct a new text style from the #selectedFont."
+
+ ^( self currentSelection
+ ifNil: [TextStyle defaultTT copy]
+ ifNotNil: [:handle | handle textStyleOfPointSize: self pointSize])
+ lineSpacing: ((lineSpacing isNil and: [self selectedFont isSymbolFont])
+ ifTrue: [ 0.3 ]
+ ifFalse: [ self lineSpacing ]);
+ yourself
+
+ !
Item was added:
+ ----- Method: FontImporterTool>>setCustomPreviewText: (in category 'preview text - custom') -----
+ setCustomPreviewText: aString
+
+ self editCustomPreviewText: aString.
+ self changed: #customPreviewText.!
Item was added:
+ ----- Method: FontImporterTool>>setPreviewTextSelector: (in category 'preview text') -----
+ setPreviewTextSelector: symbol
+
+ previewTextSelector := symbol.
+ self setCustomPreviewText: nil.!
Item was removed:
- ----- Method: FontImporterTool>>textForFamily:subfamily: (in category 'helper') -----
- textForFamily: familyName subfamily: subfamilyName
-
- subfamilyName ifNil: [
- ^ (TextStyle named: familyName)
- ifNil: [familyName]
- ifNotNil: [:style | style isTTCStyle
- ifTrue: ["we are already present "
- Text string: familyName attribute: TextEmphasis underlined]
- ifFalse: [familyName]]].
-
- " frome here on it is only about subfamilies"
-
- (self isStyleNameSupported: subfamilyName)
- ifFalse: [^ Text string: subfamilyName attribute: TextColor gray].
-
- ^ (TextStyle named: familyName)
- ifNil: ["importable" subfamilyName]
- ifNotNil: [:style |
- (style isTTCStyle and: [ | regular emph |
- regular := style fonts anyOne.
- emph := TTCFont indexOfSubfamilyName: subfamilyName.
- " detect if this style is already imported "
- regular emphasis = emph or: [(regular emphasis: emph) ~= regular]])
- ifFalse: ["again importable" subfamilyName]
- ifTrue: [Text string: subfamilyName attribute: TextEmphasis underlined]]!
Item was added:
+ ----- Method: FontImporterTool>>toggleEditMode (in category 'edit mode') -----
+ toggleEditMode
+
+ self editModeEnabled: self editModeEnabled not.!
Item was added:
+ ----- Method: FontImporterTool>>ttExtraGapInput (in category 'edit mode - ui') -----
+ ttExtraGapInput
+
+ ^ (self currentSelection
+ ifNil: [0]
+ ifNotNil: [:handle | handle ttExtraGap]) asString!
Item was added:
+ ----- Method: FontImporterTool>>ttExtraGapInput: (in category 'edit mode - ui') -----
+ ttExtraGapInput: anObject
+
+ self currentSelection ifNil: [^ false].
+
+ self currentSelection ttExtraGap: ([anObject asNumber truncated] on: NumberParserError do: [nil]).
+ self changed: #ttExtraGapInput.
+ self changed: #objectChanged with: self currentSelection.
+
+ self selectedFont: nil.
+
+ ^ true!
Item was added:
+ ----- Method: FontImporterTool>>ttExtraGapInputHelp (in category 'edit mode - ui') -----
+ ttExtraGapInputHelp
+
+ | tt |
+ tt := self selectedFont ifNotNil: [:f | f isTTCFont ifTrue: [ f ttcDescription ] ].
+ ^ ('<b>Extra line gap</b> in font measures. This font''s own value is <b>{1}</b> with units-per-em (UPM) being <b>{2}</b>. Adjust to change the font''s line grid (or "height") to compensate for <b>extra glyph scale</b>. The value may be negative.<br><br>Note that there is also <b>line spacing</b>, which is not per font but per <b>text style</b> and thus application-specific.<br><br>Make empty to reset to default value.' translated
+ format: {
+ tt ifNil: ['?'] ifNotNil: [tt typographicLineGap].
+ tt ifNil: ['?'] ifNotNil: [tt unitsPerEm].
+ }) asTextFromHtml!
Item was added:
+ ----- Method: FontImporterTool>>ttExtraScaleInput (in category 'edit mode - ui') -----
+ ttExtraScaleInput
+
+ ^ (self currentSelection
+ ifNil: [1.0]
+ ifNotNil: [:handle | handle ttExtraScale]) printShowingDecimalPlaces: 3!
Item was added:
+ ----- Method: FontImporterTool>>ttExtraScaleInput: (in category 'edit mode - ui') -----
+ ttExtraScaleInput: anObject
+
+ self currentSelection ifNil: [^ false].
+
+ self currentSelection ttExtraScale: ([anObject asNumber] on: NumberParserError do: [nil]).
+ self changed: #ttExtraScaleInput.
+ self changed: #objectChanged with: self currentSelection.
+
+ self selectedFont: nil.
+
+ ^ true!
Item was added:
+ ----- Method: FontImporterTool>>ttExtraScaleInputHelp (in category 'edit mode - ui') -----
+ ttExtraScaleInputHelp
+
+ (self selectedFont isNil or: [self selectedFont isTTCFont not])
+ ifTrue: [ ^ ''].
+
+ ^ ('<b>Extra glyph scale</b> to accommodate varying heights when using different fonts side-by-side. This font has a relative x-height of <b>{1}</b> while the system''s reference is <b>{2}</b>. You can only use values greater than 0.0.<br><br>Note that this does not change the font''s "pixel height" and is thus unrelated to the system''s overall <b>UI scale factor</b>. You may want to adjust <b>extra line gap</b> as well to retain the font''s aesthetics.<br><br>Make empty to reset to default value.' translated
+ format: {
+ self selectedFont xHeightFraction printShowingDecimalPlaces: 3.
+ TextStyle defaultTTFont xHeightFraction printShowingDecimalPlaces: 3 }) asTextFromHtml!
Item was added:
+ ----- Method: FontImporterTool>>uninstallColor (in category 'ui - colors') -----
+ uninstallColor
+
+ ^ (UserInterfaceTheme current get: #cancel for: #ListChooser) ifNil: [Color r: 1 g: 0.6 b: 0.588]!
Item was added:
+ ----- Method: FontImporterTool>>uninstallFont (in category 'actions') -----
+ uninstallFont
+
+ (Project uiManager
+ confirm: ('Do you want to uninstall the following font?\\ ' translated,
+ self currentSelection familyName,
+ '\\(There may be references left to this font\in text attributes and text styles.)' translated) withCRs
+ title: 'Uninstall Font' translated) ifFalse: [^ false].
+
+ self currentSelection uninstallFont.
+
+ self currentSelection parent ifNotNil: [:p | self currentSelection: p].
+ self changed: #objectChanged with: self currentSelection.
+
+ ^ true!
Item was removed:
- ----- Method: FontImporterTool>>warningSeen (in category 'accessing') -----
- warningSeen
-
- ^ warningSeen ifNil: [false]!
Item was removed:
- ----- Method: FontImporterTool>>warningSeen: (in category 'accessing') -----
- warningSeen: anObject
-
- warningSeen := anObject!
Item was added:
+ ----- Method: FontImporterTool>>widgetSample (in category 'preview text') -----
+ widgetSample
+
+ ^ self widgetSampleFor: self selectedFont!
Item was added:
+ ----- Method: FontImporterTool>>widgetSampleFor: (in category 'preview text') -----
+ widgetSampleFor: font
+
+ | widgets data preferredWidth |
+ data := ChronologyConstants classPool at: #MonthNames.
+ widgets := OrderedCollection new.
+ preferredWidth := ((font widthOfString: (data detectMax: [:ea | ea size])) * 1.3) truncated.
+
+ "1) List morph"
+ widgets add: ((PluggableListMorph on: data list: #value selected: nil changeSelected: nil) vResizing: #shrinkWrap; width: preferredWidth; font: font; yourself).
+
+ "2) Menu morph"
+ widgets add: (MenuMorph new in: [:menu | data do: [:o | menu add: o action: #yourself. menu lastItem font: font]. menu]).
+
+ "3) Buttons"
+ widgets add: (Morph new color: Color transparent; changeTableLayout; listDirection: #topToBottom; vResizing: #shrinkWrap; cellGap: (font widthOf: Character space); width: preferredWidth; addAllMorphs: (data collect: [:ea | (PluggableButtonMorph on: ea getState: nil action: #yourself label: #yourself) hResizing: #spaceFill; font: font; fullBounds; in: [:button | MorphicProject useCompactButtons ifFalse: [button vResizing: #rigid; height: button height * 1.6; flag: #magicNumber]]; yourself ])).
+
+ ^ Text streamContents: [:sample |
+ widgets
+ do: [:widget |
+ widget textAnchorProperties verticalAlignment: #top.
+ sample nextPutAll: (
+ Text
+ string: Character startOfHeader asString
+ attribute: widget asTextAnchor)]
+ separatedBy: [sample space: 5]]!
Item was changed:
+ ----- Method: FontImporterTool>>windowTitle (in category 'ui - building') -----
- ----- Method: FontImporterTool>>windowTitle (in category 'toolbuilder') -----
windowTitle
+ ^ 'Font Importer: ', self selectedFont familyName!
- ^'Choose a Font to import' translated!
Item was removed:
- ----- Method: Form class>>exampleColorSees (in category '*Morphic-examples') -----
- exampleColorSees
- "Form exampleColorSees"
- "First column as above shows the sneaky red/yellow pirate sneaking up on the blue/peach galleon.
- Second column shows the 1bpp made from the red/yellow/transparent - white -> ignore this, black -> test this
- Third shows the hit area - where red touches blue - superimposed on the original scene.
- Fourth column is the tally of hits via the old algorithm
- Last column shows the tally of hits via the new prim"
-
- |formA formB maskA offset tally map intersection left top dCanvas sensitiveColor soughtColor index|
- formA := formB := maskA := offset := tally := map := intersection := nil. "just to shut up the compiler when testing"
- ActiveWorld restoreMorphicDisplay; doOneCycle.
-
- sensitiveColor := Color red.
- soughtColor := Color blue.
-
- top := 50.
- dCanvas := FormCanvas on: Display.
- -50 to: 80 by: 10 do:[:p|
- offset:= p@0. "vary this to check different states"
- left := 10.
-
- formA := (Form extent: 100@50 depth: 32) asFormOfDepth: 16 "so we can try original forms of other depths".
- formB := Form extent: 100@50 depth: 32.
-
- "make a red square in the middle of the form"
- (FormCanvas on: formA) fillRectangle: (25@25 extent: 50@5) fillStyle: sensitiveColor.
- (FormCanvas on: formA) fillRectangle: (25@30 extent: 50@5) fillStyle: Color transparent.
- (FormCanvas on: formA) fillRectangle: (25@35 extent: 50@50) fillStyle: Color yellow.
- "formA displayOn: Display at: left@top rule: Form paint.
- dCanvas frameRectangle: (left@top extent: formA extent) width:2 color: Color green.
- left := left + 150."
-
- "make a blue block on the right half of the form"
- (FormCanvas on: formB) fillRectangle: (50@0 extent: 50@100) fillStyle: soughtColor.
- (FormCanvas on: formB) fillRectangle: (60@0 extent: 10@100) fillStyle: Color palePeach.
- "formB displayOn: Display at: left@top rule: Form paint.
- dCanvas frameRectangle: (left@top extent: formA extent) width:2 color: Color green.
- left := left + 150."
-
- intersection := (formA boundingBox translateBy: offset) intersect: (formB boundingBox).
-
- formB displayOn: Display at: left@top rule: Form paint.
- formA displayOn: Display at: (left@top) + offset rule: Form paint.
- dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green.
- left := left + 150.
-
- maskA := Form extent: intersection extent depth: 1.
-
- map := Bitmap new: (1 bitShift: (formA depth min: 15)).
- map at: (index := sensitiveColor indexInMap: map) put: 1.
-
- maskA copyBits: (intersection translateBy: offset negated) from: formA at: 0@0 colorMap: map.
- formB displayOn: Display at: left@top rule: Form paint.
- formA displayOn: Display at: (left@top) + offset rule: Form paint.
- maskA displayOn: Display at: (left@top) + intersection origin rule: Form paint.
- dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green. left := left + 150.
-
- "intersect world pixels of the color we're looking for with sensitive pixels mask"
- map at: index put: 0. "clear map and reuse it"
- map at: (soughtColor indexInMap: map) put: 1.
-
- maskA
- copyBits: intersection
- from: formB at: 0@0 clippingBox: formB boundingBox
- rule: Form and
- fillColor: nil
- map: map.
-
- formB displayOn: Display at: left@top rule: Form paint.
- formA displayOn: Display at: (left@top) + offset rule: Form paint.
- maskA displayOn: Display at: (left@top) + intersection origin rule: Form paint.
- dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green.
- left := left + 170.
-
- (maskA tallyPixelValues at: 2) asString asDisplayText displayOn: Display at: left@(top +20).
- left := left + 70.
-
- "now try using the new primitive"
- tally := (BitBlt
- destForm: formB
- sourceForm: formA
- fillColor: nil
- combinationRule: 3 "really ought to work with nil but prim code checks"
- destOrigin: intersection origin
- sourceOrigin: (offset negated max: 0@0)
- extent: intersection extent
- clipRect: intersection)
- primCompareColor: ((sensitiveColor pixelValueForDepth: formA depth) ) to: ((soughtColor pixelValueForDepth: formB depth) ) test: (Form compareMatchColor bitOr: Form compareTallyFlag).
- tally asString asDisplayText displayOn: Display at: left@(top +20).
- top:= top + 60]
-
- !
Item was removed:
- ----- Method: Form class>>exampleTouchTest (in category '*Morphic-examples') -----
- exampleTouchTest
- "Form exampleTouchTest"
- "Demonstrate the algorithm used in Scratch code to determine if a sprite's non-transparent pixels touch a
- non-transparent pixel of the background upon which it is displayed.
- First column shows a form with a red block in the midst of transparent area sneaking up on a form with a transparent LHS and blue RHS. The green frame shows the intersection area.
- Second column shows in grey the part of the red that is within the intersection.
- Third column shows in black the blue that is within the intersection.
- Fourth column shows just the A touching B area.
- Fifth column is the tally of hits via the old algorithm
- Last column shows the tally of hits via the new prim"
- |formA formB maskA maskB offset tally map intersection left top dCanvas|
- formA := formB := maskA := maskB := offset := tally := map := intersection := nil. "just to shut up the compiler when testing"
-
- ActiveWorld restoreMorphicDisplay; doOneCycle.
-
- top := 50.
- dCanvas := FormCanvas on: Display.
- -50 to: 80 by: 10 do:[:p|
- offset:= p@0. "vary this to check different states"
- left := 10.
-
- formA := Form extent: 100@50 depth: 32.
- formB := Form extent: 100@50 depth: 16.
-
- "make a red square in the middle of the form"
- (FormCanvas on: formA) fillRectangle: (25@25 extent: 50@5) fillStyle: Color yellow.
- (FormCanvas on: formA) fillRectangle: (25@30 extent: 50@5) fillStyle: Color transparent.
- (FormCanvas on: formA) fillRectangle: (25@35 extent: 50@50) fillStyle: Color red.
- "formA displayOn: Display at: left@top rule: Form paint.
- dCanvas frameRectangle: (left@top extent: formA extent) width:2 color: Color green.
- left := left + 150."
-
- "make a blue block on the right half of the form"
- (FormCanvas on: formB) fillRectangle: (50@0 extent: 50@100) fillStyle: Color blue.
- (FormCanvas on: formB) fillRectangle: (60@0 extent: 10@100) fillStyle: Color palePeach.
- "formB displayOn: Display at: left@top rule: Form paint.
- dCanvas frameRectangle: (left@top extent: formA extent) width:2 color: Color green.
- left := left + 150."
-
- intersection := (formA boundingBox translateBy: offset) intersect: (formB boundingBox).
-
- formB displayOn: Display at: left@top rule: Form paint.
- formA displayOn: Display at: (left@top) + offset rule: Form paint.
- dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green.
- left := left + 150.
-
- maskA := Form extent: intersection extent depth: 2.
- formA displayOn: maskA at: offset - intersection origin rule: Form paint.
- formB displayOn: Display at: left@top rule: Form paint.
- formA displayOn: Display at: (left@top) + offset rule: Form paint.
- maskA displayOn: Display at: (left@top) + intersection origin rule: Form paint.
- dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green.
- left := left + 150.
-
- maskB := Form extent: intersection extent depth: 2.
- formB displayOn: maskB at: intersection origin negated rule: Form paint.
- formB displayOn: Display at: left@top rule: Form paint.
- formA displayOn: Display at: (left@top) + offset rule: Form paint.
- maskB displayOn: Display at: (left@top) + intersection origin rule: Form paint.
- dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green.
- left := left + 150.
-
- map := Bitmap new: 4 withAll: 1.
- map at: 1 put: 0. "transparent"
-
- maskA copyBits: maskA boundingBox from: maskA at: 0@0 colorMap: map.
- "maskA displayOn: Display at: (left@top) + intersection origin rule: Form paint.
- dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green.
- left := left + 150."
-
- maskB copyBits: maskB boundingBox from: maskB at: 0@0 colorMap: map.
- "maskB displayOn: Display at: (left@top) + intersection origin rule: Form paint.
- dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green.
- left := left + 150."
-
- maskB displayOn: maskA at: 0@0 rule: Form and.
- maskA displayOn: Display at: (left@top) + intersection origin rule: Form paint.
- dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green.
- left := left + 170.
-
- (maskA boundingBox area -( maskA tallyPixelValues at: 1)) asString asDisplayText displayOn: Display at: left@(top +20).
- left := left + 70.
-
- "now try using the new primitive"
- tally := (BitBlt
- destForm: formB
- sourceForm: formA
- fillColor: nil
- combinationRule: 3 "really ought to work with nil but prim code checks"
- destOrigin: intersection origin
- sourceOrigin: (offset negated max: 0@0)
- extent: intersection extent
- clipRect: intersection)
- primCompareColor: ((Color transparent pixelValueForDepth: formA depth) bitAnd: 16rFFFFFF) to: ((Color transparent pixelValueForDepth: formB depth) bitAnd: 16rFFFFFF) test: (Form compareNotColorANotColorB bitOr: Form compareTallyFlag).
- tally asString asDisplayText displayOn: Display at: left@(top +20).
- top:= top + 60]
-
-
- !
Item was removed:
- ----- Method: Form class>>exampleTouchingColor (in category '*Morphic-examples') -----
- exampleTouchingColor
- "Form exampleTouchingColor"
- "Demonstrate the algorithm used in Scratch code to determine if a sprite's non-transparent pixels touch a
- particular color pixel of the background upon which it is displayed.
- First column as above shows the sneaky red/yellow pirate sneaking up on the blue/peach galleon.
- Second column shows the 1bpp made from the red/yellow/transparent - white -> ignore this, black -> test this
- Third shows the hit area (black) superimposed on the original scene
- Fourth column is the tally of hits via the old algorithm
- Last column shows the tally of hits via the new prim"
- |formA formB maskA offset tally map intersection left top dCanvas ignoreColor soughtColor|
- formA := formB := maskA := offset := tally := map := intersection := nil. "just to shut up the compiler when testing"
- ActiveWorld restoreMorphicDisplay; doOneCycle.
-
- ignoreColor := Color transparent.
- soughtColor := Color blue.
-
- top := 50.
- dCanvas := FormCanvas on: Display.
- -50 to: 80 by: 10 do:[:p|
- offset:= p@0. "vary this to check different states"
- left := 10.
-
- formA := (Form extent: 100@50 depth: 32) asFormOfDepth: 16 "so we can try original forms of other depths".
- formB := Form extent: 100@50 depth: 32.
-
- "make a red square in the middle of the form"
- (FormCanvas on: formA) fillRectangle: (25@25 extent: 50@5) fillStyle: Color red.
- (FormCanvas on: formA) fillRectangle: (25@30 extent: 50@5) fillStyle: Color transparent.
- (FormCanvas on: formA) fillRectangle: (25@35 extent: 50@50) fillStyle: Color yellow.
- "formA displayOn: Display at: left@top rule: Form paint.
- dCanvas frameRectangle: (left@top extent: formA extent) width:2 color: Color green.
- left := left + 150."
-
- "make a blue block on the right half of the form"
- (FormCanvas on: formB) fillRectangle: (50@0 extent: 50@100) fillStyle: soughtColor.
- (FormCanvas on: formB) fillRectangle: (60@0 extent: 10@100) fillStyle: Color palePeach.
- "formB displayOn: Display at: left@top rule: Form paint.
- dCanvas frameRectangle: (left@top extent: formA extent) width:2 color: Color green.
- left := left + 150."
-
- intersection := (formA boundingBox translateBy: offset) intersect: (formB boundingBox).
-
- formB displayOn: Display at: left@top rule: Form paint.
- formA displayOn: Display at: (left@top) + offset rule: Form paint.
- dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green.
- left := left + 150.
-
- maskA := Form extent: intersection extent depth: 1.
-
- map := Bitmap new: (1 bitShift: (formA depth min: 15)).
- map atAllPut: 1.
- map at: ( ignoreColor indexInMap: map) put: 0.
-
- maskA copyBits: (intersection translateBy: offset negated) from: formA at: 0@0 colorMap: map.
- formB displayOn: Display at: left@top rule: Form paint.
- formA displayOn: Display at: (left@top) + offset rule: Form paint.
- maskA displayOn: Display at: (left@top) + intersection origin rule: Form paint.
- dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green. left := left + 150.
-
- "intersect world pixels of the color we're looking for with sensitive pixels mask"
- map atAllPut: 0. "clear map and reuse it"
- map at: (soughtColor indexInMap: map) put: 1.
-
- maskA
- copyBits: intersection
- from: formB at: 0@0 clippingBox: formB boundingBox
- rule: Form and
- fillColor: nil
- map: map.
-
- formB displayOn: Display at: left@top rule: Form paint.
- formA displayOn: Display at: (left@top) + offset rule: Form paint.
- maskA displayOn: Display at: (left@top) + intersection origin rule: Form paint.
- dCanvas frameRectangle: (intersection translateBy: left@top) width:2 color: Color green.
- left := left + 170.
-
- (maskA tallyPixelValues at: 2) asString asDisplayText displayOn: Display at: left@(top +20).
- left := left + 70.
-
- "now try using the new primitive"
- tally := (BitBlt
- destForm: formB
- sourceForm: formA
- fillColor: nil
- combinationRule: 3 "really ought to work with nil but prim code checks"
- destOrigin: intersection origin
- sourceOrigin: (offset negated max: 0@0)
- extent: intersection extent
- clipRect: intersection)
- primCompareColor: ((ignoreColor pixelValueForDepth: formA depth) bitAnd: 16rFFFFFF) to: ((soughtColor pixelValueForDepth: formB depth) bitAnd: 16rFFFFFF) test: (Form compareNotColorAMatchColorB bitOr: Form compareTallyFlag).
- tally asString asDisplayText displayOn: Display at: left@(top +20).
- top:= top + 60]
- !
Item was changed:
----- Method: FormCanvas>>transformBy:clippingTo:during:smoothing: (in category 'drawing-support') -----
+ transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
- transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize
"Note: This method has been originally copied from TransformationMorph."
| innerRect patchRect sourceQuad warp start subCanvas |
+ aDisplayTransform isPureTranslation ifTrue: [
+ ^ self
+ translateBy: (aDisplayTransform localPointToGlobal: 0@0) truncated
+ clippingTo: aClipRect
+ during: aBlock].
- (aDisplayTransform isPureTranslation) ifTrue:[
- ^aBlock value: (self copyOffset: aDisplayTransform offset negated truncated
- clipRect: aClipRect)
- ].
"Prepare an appropriate warp from patch to innerRect"
innerRect := aClipRect.
patchRect := (aDisplayTransform globalBoundsToLocal: innerRect) truncated.
sourceQuad := (aDisplayTransform sourceQuadFor: innerRect)
collect: [:p | p - patchRect topLeft].
warp := self warpFrom: sourceQuad toRect: innerRect.
warp cellSize: cellSize.
"Render the submorphs visible in the clipping rectangle, as patchForm"
start := (self depth = 1 and: [self isShadowDrawing not])
"If this is true B&W, then we need a first pass for erasure."
ifTrue: [1] ifFalse: [2].
start to: 2 do:
[:i | "If i=1 we first make a shadow and erase it for opaque whites in B&W"
subCanvas := self class extent: patchRect extent depth: self depth.
i=1 ifTrue: [subCanvas shadowColor: Color black.
warp combinationRule: Form erase]
ifFalse: [self isShadowDrawing ifTrue:
[subCanvas shadowColor: self shadowColor].
warp combinationRule: (self depth = 32
ifTrue: [Form blendAlphaScaled]
ifFalse: [Form paint])].
subCanvas
translateBy: patchRect topLeft negated
during: aBlock.
warp sourceForm: subCanvas form; warpBits.
warp sourceForm: nil. subCanvas := nil "release space for next loop"]
!
Item was changed:
----- Method: GradientEditor>>addButtonRow (in category 'initialization') -----
addButtonRow
| button button2 buttonRow button3 |
buttonRow := RectangleMorph new borderWidth: 0;
color: Color transparent;
layoutPolicy: TableLayout new;
+ hResizing: #spaceFill;
- hResizing: #spaceFil;
vResizing: #spaceFill;
cellPositioning: #center;
listCentering: #topLeft;
listDirection: #LeftToRight;
reverseTableCells: true;
cellGap: 4.
button := PluggableButtonMorph on: self
getState: nil
action: #addHandle
label: #addColorButtonLabel.
button hResizing: #spaceFill;
vResizing: #spaceFill.
buttonRow addMorph: button.
button2 := PluggableButtonMorph on: self
getState: nil
action: #deleteHandle
label: #removeColorButtonLabel.
button2 hResizing: #spaceFill;
vResizing: #spaceFill.
buttonRow addMorph: button2.
button3 := PluggableButtonMorph on: self
getState: nil
action: #delete
label: #closeButtonLabel.
button3 hResizing: #spaceFill;
vResizing: #spaceFill.
buttonRow addMorph: button3.
self addMorph: buttonRow!
Item was changed:
----- Method: GrafPort>>frameRoundRect:radius:borderWidth: (in category 'drawing support') -----
frameRoundRect: aRectangle radius: radius borderWidth: borderWidth
| nextY outer nextOuterX ovalDiameter rectExtent rectOffset rectX rectY rectWidth rectHeight ovalRadius ovalRect innerRadius innerDiameter innerRect inner nextInnerX wp |
aRectangle area <= 0 ifTrue: [^ self].
ovalDiameter := (radius * 2) asPoint min: aRectangle extent.
(ovalDiameter x <= 0 or:[ovalDiameter y <= 0]) ifTrue:[
^self fillRect: aRectangle offset: 0@0.
].
"force diameter to be even - this simplifies lots of stuff"
ovalRadius := (ovalDiameter x // 2) @ (ovalDiameter y // 2).
(ovalRadius x <= 0 or:[ovalRadius y <= 0]) ifTrue:[
^self fillRect: aRectangle offset: 0@0.
].
wp := borderWidth asPoint.
ovalDiameter := ovalRadius * 2.
innerRadius := ovalRadius - borderWidth max: 0@0.
innerDiameter := innerRadius * 2.
rectExtent := aRectangle extent - ovalDiameter.
rectWidth := rectExtent x.
rectHeight := rectExtent y.
rectOffset := aRectangle origin + ovalRadius.
rectX := rectOffset x.
rectY := rectOffset y.
ovalRect := 0@0 extent: ovalDiameter.
innerRect := 0@0 extent: innerDiameter.
height := 1.
outer := EllipseMidpointTracer new on: ovalRect.
inner := EllipseMidpointTracer new on: innerRect.
nextY := ovalRadius y.
1 to: (wp y min: nextY) do:[:i|
nextOuterX := outer stepInY.
width := nextOuterX * 2 + rectWidth.
destX := rectX - nextOuterX.
destY := rectY - nextY.
self copyBits.
destY := rectY + nextY + rectHeight - 1.
self copyBits.
nextY := nextY - 1.
].
[nextY > 0] whileTrue:[
nextOuterX := outer stepInY.
nextInnerX := inner stepInY.
destX := rectX - nextOuterX.
destY := rectY - nextY.
width := nextOuterX - nextInnerX.
self copyBits.
destX := rectX + nextInnerX + rectWidth.
self copyBits.
destX := rectX - nextOuterX.
destY := rectY + nextY + rectHeight-1.
self copyBits.
destX := rectX + nextInnerX + rectWidth.
self copyBits.
nextY := nextY - 1.
].
destX := aRectangle left.
destY := rectOffset y.
height := rectHeight.
width := wp x.
self copyBits.
destX := aRectangle right - width.
self copyBits.
innerRadius y = 0 ifTrue:[
destX := aRectangle left + wp x.
destY := rectY.
+ width := aRectangle width - (wp x * 2).
- width := rectWidth.
height := wp y - ovalRadius y.
self copyBits.
destY := aRectangle bottom - wp y.
self copyBits.
].!
Item was changed:
----- Method: GrafPort>>installTTCFont: (in category 'private') -----
installTTCFont: aTTCFont
+ aTTCFont foregroundColor: (lastFontForegroundColor ifNil: [Color black]).
+
+ ^ self installTTCFont: aTTCFont foregroundColor: aTTCFont foregroundColor backgroundColor: (lastFontBackgroundColor ifNil: [Color transparent]).
- ^ self installTTCFont: aTTCFont foregroundColor: (lastFontForegroundColor ifNil: [Color black]) backgroundColor: (lastFontBackgroundColor ifNil: [Color transparent]).
!
Item was added:
+ LayoutPolicy subclass: #GridLayout
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Layouts'!
Item was added:
+ ----- Method: GridLayout>>griddedPoint:in: (in category 'layout') -----
+ griddedPoint: ungriddedPoint in: container
+ "For convenience only. Manually grid a point from the outside."
+
+ | properties |
+ properties := container assureGridLayoutProperties.
+ ^ ((ungriddedPoint - container position - properties origin)
+ grid: properties modulus)
+ + container position + properties origin!
Item was added:
+ ----- Method: GridLayout>>isGridLayout (in category 'testing') -----
+ isGridLayout
+
+ ^ true!
Item was added:
+ ----- Method: GridLayout>>layout:in: (in category 'layout') -----
+ layout: container in: box
+ "Moves and resizes the container's submorphs to snap to the grid cells. Ignore edge-adhereing morphs such as docking bars."
+
+ | properties cellOrigin cellExtent |
+ properties := container assureGridLayoutProperties.
+ container submorphsDo: [:morph |
+ (morph disableLayout or: [morph hasProperty: #edgeToAdhereTo]) ifFalse: [
+ cellOrigin := ((morph position - container position - properties origin)
+ grid: properties modulus)
+ + container position + properties origin.
+ cellExtent := (morph extent grid: properties modulus) max: properties modulus "= minExtent".
+ morph layoutInBounds: (cellOrigin extent: cellExtent) positioning: properties cellPositioning]].!
Item was added:
+ LayoutProperties subclass: #GridLayoutProperties
+ instanceVariableNames: 'origin modulus layoutInset'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Layouts'!
Item was added:
+ ----- Method: GridLayoutProperties>>cellPositioning (in category 'accessing') -----
+ cellPositioning
+
+ ^ #topLeft!
Item was added:
+ ----- Method: GridLayoutProperties>>includesGridLayoutProperties (in category 'testing') -----
+ includesGridLayoutProperties
+
+ ^ true!
Item was added:
+ ----- Method: GridLayoutProperties>>initialize (in category 'initialize') -----
+ initialize
+
+ super initialize.
+
+ origin := 0@0.
+ modulus := 8@8.
+ layoutInset := 0.!
Item was added:
+ ----- Method: GridLayoutProperties>>layoutInset (in category 'accessing') -----
+ layoutInset
+
+ self flag: #todo. "mt: Move up to LayoutProperties."
+ ^ layoutInset!
Item was added:
+ ----- Method: GridLayoutProperties>>layoutInset: (in category 'accessing') -----
+ layoutInset: anObject
+
+ self flag: #todo. "mt: Move up to LayoutProperties."
+ layoutInset := anObject.!
Item was added:
+ ----- Method: GridLayoutProperties>>modulus (in category 'accessing') -----
+ modulus
+
+ ^ modulus!
Item was added:
+ ----- Method: GridLayoutProperties>>modulus: (in category 'accessing') -----
+ modulus: anObject
+
+ modulus := anObject.!
Item was added:
+ ----- Method: GridLayoutProperties>>origin (in category 'accessing') -----
+ origin
+
+ self flag: #discuss. "mt: Is this really needed? We could easily configure this through #layoutInset."
+ ^ origin!
Item was added:
+ ----- Method: GridLayoutProperties>>origin: (in category 'accessing') -----
+ origin: anObject
+
+ origin := anObject.!
Item was changed:
----- Method: HaloMorph>>addCircleHandles (in category 'private') -----
addCircleHandles
| box |
simpleMode := false.
target isWorldMorph ifTrue: [^ self addHandlesForWorldHalos].
self removeAllMorphs. "remove old handles, if any"
+ self updateBounds.
- self bounds: target renderedMorph worldBoundsForHalo. "update my size"
box := self basicBox.
target addHandlesTo: self box: box.
self addName.
growingOrRotating := false.
self layoutChanged.
+ self changed.!
- self changed.
- !
Item was changed:
----- Method: HaloMorph>>addGraphicalHandleFrom:at: (in category 'private') -----
addGraphicalHandleFrom: formKey at: aPoint
"Add the supplied form as a graphical handle centered at the given point. Return the handle."
| handle aForm |
aForm := (ScriptingSystem formAtKey: formKey) ifNil: [ScriptingSystem formAtKey: #SolidMenu].
handle := ImageMorph new image: aForm; bounds: (Rectangle center: aPoint extent: aForm extent).
+ handle borderColor: Color black; borderWidth: 2.
handle wantsYellowButtonMenu: false.
self addMorph: handle.
handle on: #mouseUp send: #endInteraction: to: self.
^ handle
!
Item was changed:
----- Method: HaloMorph>>addSimpleHandles (in category 'private') -----
addSimpleHandles
target isWorldMorph ifTrue: [^ self addHandlesForWorldHalos].
self removeAllMorphs. "remove old handles, if any"
+ self updateBounds.
- self bounds: target renderedMorph worldBoundsForHalo. "update my size"
self innerTarget addSimpleHandlesTo: self box: self basicBoxForSimpleHalos
!
Item was changed:
----- Method: HaloMorph>>addSimpleHandlesTo:box: (in category 'halos and balloon help') -----
addSimpleHandlesTo: aHaloMorph box: aBox
| aHandle |
simpleMode := true.
target isWorldMorph ifTrue: [^ self addSimpleHandlesForWorldHalos].
self removeAllMorphs. "remove old handles, if any"
+ self updateBounds.
- self bounds: target renderedMorph worldBoundsForHalo. "update my size"
self addHandleAt: (((aBox topLeft + aBox leftCenter) // 2) + self simpleFudgeOffset) color: Color paleBuff icon: 'Halo-MoreHandles'
on: #mouseDown send: #addFullHandles to: self.
aHandle := self addGraphicalHandle: #Rotate at: aBox bottomLeft on: #mouseDown send: #startRot:with: to: self.
aHandle on: #mouseMove send: #doRot:with: to: self.
(target isFlexMorph and: [target renderedMorph ~~ target])
ifTrue: [(self addGraphicalHandle: #Scale at: aBox bottomRight on: #mouseDown send: #startScale:with: to: self)
on: #mouseMove send: #doScale:with: to: self]
ifFalse: [(self addGraphicalHandle: #Scale at: aBox bottomRight on: #mouseDown send: #startGrow:with: to: self)
on: #mouseMove send: #doGrow:with: to: self].
innerTarget wantsSimpleSketchMorphHandles ifTrue:
[self addSimpleSketchMorphHandlesInBox: aBox].
growingOrRotating := false.
self layoutChanged.
+ self changed.!
- self changed.
- !
Item was added:
+ ----- Method: HaloMorph>>backupAndHideTargetDropShadows (in category 'private') -----
+ backupAndHideTargetDropShadows
+
+ self setProperty: #targetHadDropShadow toValue: target hasDropShadow.
+ self target hasDropShadow: false.!
Item was changed:
----- Method: HaloMorph>>basicBoxForSimpleHalos (in category 'private') -----
basicBoxForSimpleHalos
| w |
w := self world ifNil:[target outermostWorldMorph].
+ ^ ((self haloBoundsFor: target topRendererOrSelf) expandBy: self handleAllowanceForIconicHalos)
- ^ (target topRendererOrSelf worldBoundsForHalo expandBy: self handleAllowanceForIconicHalos)
intersect: (w bounds insetBy: 8@8)
!
Item was changed:
+ ----- Method: HaloMorph>>delete (in category 'submorphs - add/remove') -----
- ----- Method: HaloMorph>>delete (in category 'submorphs-add/remove') -----
delete
"Delete the halo. Tell the target that it no longer has the halo; accept any pending edits to the name; and then either actually delete myself or start to fade out"
self acceptNameEdit.
self isMagicHalo: false.
Preferences haloTransitions
ifFalse: [super delete]
ifTrue: [
self
stopStepping;
startStepping;
startSteppingSelector: #fadeOutFinally].
!
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:
+ [self currentHand spawnBalloonFor: directionHandle]!
- [ActiveHand spawnBalloonFor: directionHandle]!
Item was changed:
----- Method: HaloMorph>>doDrag:with: (in category 'private') -----
doDrag: evt with: dragHandle
| thePoint |
evt hand obtainHalo: self.
thePoint := target point: evt position - positionOffset from: owner.
+ target setConstrainedPosition: thePoint hangOut: true.
- target setConstrainedPosition:(target griddedPoint: thePoint) hangOut: true.
!
Item was changed:
----- Method: HaloMorph>>doGrow:with: (in category 'private') -----
doGrow: evt with: growHandle
"Called while the mouse is down in the grow handle"
| newExtent extentToUse scale |
evt hand obtainHalo: self.
+ newExtent := (target pointFromWorld: evt cursorPoint - positionOffset)
- newExtent := (target pointFromWorld: (target griddedPoint: evt cursorPoint - positionOffset))
- target topLeft.
evt shiftPressed ifTrue: [
scale := (newExtent x / (originalExtent x max: 1)) min:
(newExtent y / (originalExtent y max: 1)).
newExtent := (originalExtent x * scale) asInteger @ (originalExtent y * scale) asInteger
].
(newExtent x < 1 or: [newExtent y < 1 ]) ifTrue: [^ self].
target renderedMorph setExtentFromHalo: (extentToUse := newExtent).
growHandle position: evt cursorPoint - (growHandle extent // 2).
self layoutChanged.
(self valueOfProperty: #commandInProgress) ifNotNil:
[:cmd | "Update the final extent"
cmd redoTarget: target renderedMorph selector: #setFlexExtentFromHalo: argument: extentToUse]
!
Item was changed:
----- Method: HaloMorph>>doResizeTarget: (in category 'dragging or resizing') -----
doResizeTarget: evt
| newExtent |
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 updateBounds.!
- self bounds: self target worldBoundsForHalo!
Item was changed:
----- Method: HaloMorph>>endInteraction: (in category 'private') -----
endInteraction: event
"Clean up after a user interaction with the a halo control"
| m |
self isMagicHalo: false. "no longer"
self magicAlpha: 1.0.
(target isInWorld not or: [owner isNil]) ifTrue: [^self].
[target isFlexMorph and: [target hasNoScaleOrRotation]] whileTrue:
[m := target firstSubmorph.
target removeFlexShell.
target := m].
+ self restoreTargetDropShadows.
+ target changedViaHalo: self.
self isInWorld
ifTrue:
["make sure handles show in front, even if flex shell added"
self flag: #tofix. "mt: Try to avoid deleting and re-creating an event handler (here: the handle) while handling the event."
self comeToFront.
self addHandles.
event hand newMouseFocus: self].
(self valueOfProperty: #commandInProgress) ifNotNil:
[:cmd |
self rememberCommand: cmd.
self removeProperty: #commandInProgress].!
Item was added:
+ ----- Method: HaloMorph>>handleMouseUp: (in category 'events') -----
+ handleMouseUp: evt
+
+ super handleMouseUp: evt.
+
+ self restoreTargetDropShadows.
+ target changedViaHalo: self.!
Item was changed:
----- Method: HaloMorph>>handleSize (in category 'private') -----
handleSize
+ ^ ((Preferences biggerHandles
- ^ (Preferences biggerHandles
ifTrue: [30]
+ ifFalse: [16]) * RealEstateAgent scaleFactor) rounded!
- ifFalse: [16]) * RealEstateAgent scaleFactor!
Item was changed:
----- Method: HaloMorph>>localHaloBoundsFor: (in category 'stepping') -----
localHaloBoundsFor: aMorph
"aMorph may be in the hand and perhaps not in our world"
| r |
+ r := (self haloBoundsFor: aMorph) truncated.
- r := aMorph worldBoundsForHalo truncated.
aMorph world = self world ifFalse: [^r].
^((self transformFromOutermostWorld) globalBoundsToLocal: r) truncated!
Item was changed:
----- Method: HaloMorph>>maybeDismiss:with: (in category 'private') -----
maybeDismiss: evt with: dismissHandle
"Ask hand to dismiss my target if mouse comes up in it."
evt hand obtainHalo: self.
(dismissHandle containsPoint: evt cursorPoint)
+ ifFalse: [
+ self delete.
- ifFalse:
- [self delete.
target addHalo: evt]
+ ifTrue: [
+ target resistsRemoval ifTrue:
- ifTrue:
- [target resistsRemoval ifTrue:
[(UIManager default chooseFrom: {
'Yes' translated.
'Um, no, let me reconsider' translated.
+ } title: 'Really throw this away?' translated) = 1 ifFalse: [^ self]].
- } title: 'Really throw this away' translated) = 1 ifFalse: [^ self]].
evt hand removeHalo.
self delete.
target dismissViaHalo.
+ self currentWorld presenter flushPlayerListCache].!
- ActiveWorld presenter flushPlayerListCache]!
Item was removed:
- ----- Method: HaloMorph>>morphicLayerNumber (in category 'WiW support') -----
- morphicLayerNumber
-
- "helpful for insuring some morphs always appear in front of or behind others.
- smaller numbers are in front"
-
- ^7 "Halos are very front-like things"!
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:
+ [self currentHand spawnBalloonFor: rotationHandle]!
- [ActiveHand spawnBalloonFor: rotationHandle]!
Item was added:
+ ----- Method: HaloMorph>>restoreTargetDropShadows (in category 'private') -----
+ restoreTargetDropShadows
+
+ ((self removeProperty: #targetHadDropShadow) ifNil: [false])
+ ifTrue: [self target hasDropShadow: true].!
Item was changed:
----- Method: HaloMorph>>startDrag:with: (in category 'private') -----
startDrag: evt with: dragHandle
"Drag my target without removing it from its owner."
| itsOwner |
self obtainHaloForEvent: evt andRemoveAllHandlesBut: dragHandle.
+ target aboutToBeDraggedViaHalo.
+
positionOffset := dragHandle center - (target point: target position in: owner).
((itsOwner := target topRendererOrSelf owner) notNil and:
[itsOwner automaticViewing]) ifTrue:
[target openViewerForArgument]!
Item was changed:
----- Method: HaloMorph>>startGrow:with: (in category 'private') -----
startGrow: evt with: growHandle
"Initialize resizing of my target. Launch a command representing it, to support Undo"
| botRt |
self obtainHaloForEvent: evt andRemoveAllHandlesBut: growHandle.
+ self backupAndHideTargetDropShadows.
+ target aboutToBeGrownViaHalo.
+
botRt := target point: target bottomRight in: owner.
positionOffset := (self world viewBox containsPoint: botRt)
ifTrue: [evt cursorPoint - botRt]
ifFalse: [0@0].
self setProperty: #commandInProgress toValue:
(Command new
cmdWording: ('resize ' translated, target nameForUndoWording);
undoTarget: target renderedMorph selector: #setFlexExtentFromHalo: argument: target extent).
originalExtent := target extent!
Item was changed:
----- Method: HaloMorph>>startResizeTarget: (in category 'dragging or resizing') -----
startResizeTarget: event
"Begin resizing the target"
growingOrRotating := true.
positionOffset := event position.
+ self backupAndHideTargetDropShadows.
+ target aboutToBeScaledViaHalo.
+
originalExtent := target extent.
self removeAllHandlesBut: nil.
event hand newMouseFocus: self.
event hand addMouseListener: self. "add handles back on mouse-up"!
Item was changed:
----- Method: HaloMorph>>startRot:with: (in category 'private') -----
startRot: evt with: rotHandle
"Initialize rotation of my target if it is rotatable. Launch a command object to represent the action"
self obtainHaloForEvent: evt andRemoveAllHandlesBut: rotHandle.
+ self backupAndHideTargetDropShadows.
+ target aboutToBeRotatedViaHalo.
target isFlexMorph ifFalse:
[target isInWorld ifFalse: [self setTarget: target player costume].
target addFlexShellIfNecessary].
growingOrRotating := true.
self removeAllHandlesBut: rotHandle. "remove all other handles"
angleOffset := evt cursorPoint - (target pointInWorld: target referencePosition).
angleOffset := Point
r: angleOffset r
degrees: angleOffset degrees - target rotationDegrees.
self setProperty: #commandInProgress toValue:
(Command new
cmdWording: ('rotate ' translated, target nameForUndoWording);
undoTarget: target renderedMorph selector: #heading: argument: target rotationDegrees)
!
Item was changed:
----- Method: HaloMorph>>startScale:with: (in category 'private') -----
startScale: evt with: scaleHandle
"Initialize scaling of my target."
self obtainHaloForEvent: evt andRemoveAllHandlesBut: scaleHandle.
+ self backupAndHideTargetDropShadows.
+ target aboutToBeScaledViaHalo.
target isFlexMorph ifFalse: [target addFlexShellIfNecessary].
growingOrRotating := true.
positionOffset := 0@0.
self setProperty: #commandInProgress toValue:
(Command new
cmdWording: ('resize ' translated, target nameForUndoWording);
undoTarget: target renderedMorph selector: #setFlexExtentFromHalo: argument: target extent).
originalExtent := target extent
!
Item was changed:
Morph subclass: #HandMorph
+ instanceVariableNames: 'mouseFocus keyboardFocus eventListeners mouseListeners keyboardListeners eventCaptureFilters mouseCaptureFilters keyboardCaptureFilters mouseClickState mouseOverHandler targetOffset lastMouseEvent lastKeyDownEvent damageRecorder cacheCanvas cachedCanvasHasHoles temporaryCursor temporaryCursorOffset hardwareCursor hasChanged savedPatch userInitials lastEventBuffer genieGestureProcessor keyboardInterpreter externalDropMorph'
+ classVariableNames: 'CompositionWindowManager DoubleClickTime DragThreshold EventStats MinimalWheelDelta NewEventRules NormalCursor PasteBuffer SendMouseWheelToKeyboardFocus ShowEvents SynthesizeMouseWheelEvents'
- instanceVariableNames: 'mouseFocus keyboardFocus eventListeners mouseListeners keyboardListeners eventCaptureFilters mouseCaptureFilters keyboardCaptureFilters mouseClickState mouseOverHandler mouseWheelState lastMouseEvent targetOffset damageRecorder cacheCanvas cachedCanvasHasHoles temporaryCursor temporaryCursorOffset hardwareCursor hasChanged savedPatch userInitials lastEventBuffer genieGestureProcessor keyboardInterpreter'
- classVariableNames: 'CompositionWindowManager DoubleClickTime DragThreshold EventStats NewEventRules NormalCursor PasteBuffer SendMouseWheelToKeyboardFocus ShowEvents SynthesizeMouseWheelEvents'
poolDictionaries: 'EventSensorConstants'
category: 'Morphic-Kernel'!
!HandMorph commentStamp: '<historical>' prior: 0!
The cursor may be thought of as the HandMorph. The hand's submorphs hold anything being carried by dragging.
There is some minimal support for multiple hands in the same world.!
Item was added:
+ ----- Method: HandMorph class>>cleanUp: (in category 'initialization') -----
+ cleanUp: aggressive
+
+ aggressive ifTrue: [EventStats := nil].!
Item was changed:
----- Method: HandMorph class>>localeChanged (in category 'class initialization') -----
localeChanged
+ self startUp: true.!
- self startUp.!
Item was added:
+ ----- Method: HandMorph class>>minimumWheelDelta (in category 'preferences') -----
+ minimumWheelDelta
+ <preference: 'Minimal Mouse Wheel Detection Threshold'
+ categoryList: #(Morphic mouse)
+ description: 'Answer the minimal scrolling units taken into account
+ Defaults to 120 (See #scrollUnitsPerMouseWheelNotch), corresponding to a single mouse wheel notch.
+ Use a lower value (20 - See #minimalScrollUnitsPerEvent) if wanting smoother scrolling with trackpads.'
+ type: #Number>
+ ^MinimalWheelDelta ifNil: [MouseWheelEvent scrollUnitsPerMouseWheelNotch].!
Item was added:
+ ----- Method: HandMorph class>>minimumWheelDelta: (in category 'preferences') -----
+ minimumWheelDelta: anInteger
+ MinimalWheelDelta := anInteger ifNotNil: [anInteger
+ clampLow: MouseWheelEvent minimalScrollUnitsPerEvent
+ high: MouseWheelEvent scrollUnitsPerMouseWheelNotch]!
Item was changed:
----- Method: HandMorph class>>sendMouseWheelToKeyboardFocus (in category 'preferences') -----
sendMouseWheelToKeyboardFocus
<preference: 'Send Mouse Wheel Events to Keyboard Focus'
categoryList: #(Morphic keyboard mouse)
+ description: 'If enabled, follow the behavior known from older versions of Microsoft Windows, where the mouse wheel works for the widget that has the keyboard focus. If disabled, follow the Mac OS style, where the mouse wheel is send to the widget under the mouse position.'
- description: 'If enabled, follow the behavior known from Microsoft Windows, where the mouse wheel works for the widget that has the keyboard focus. If disabled, follow the Mac OS style, where the mouse wheel is send to the widget under the mouse position'
type: #Boolean>
^ SendMouseWheelToKeyboardFocus ifNil: [true]!
Item was changed:
----- Method: HandMorph class>>showEvents: (in category 'utilities') -----
showEvents: aBool
"HandMorph showEvents: true"
"HandMorph showEvents: false"
+
ShowEvents := aBool.
+ aBool ifFalse: [
+ Project current world invalidRect: (0@0 extent: 250@120)].!
- aBool ifFalse: [ ActiveWorld invalidRect: (0@0 extent: 250@120) ].!
Item was removed:
- ----- Method: HandMorph class>>startUp (in category 'initialization') -----
- startUp
-
- self clearCompositionWindowManager.
- self clearInterpreters.
- !
Item was added:
+ ----- Method: HandMorph class>>startUp: (in category 'initialization') -----
+ startUp: resuming
+
+ resuming ifFalse: [^ self].
+ self clearCompositionWindowManager.
+ self clearInterpreters.
+ !
Item was changed:
----- Method: HandMorph>>balloonHelpList (in category 'balloon help') -----
balloonHelpList
"Return all balloon morphs associated with this hand"
+ self flag: #performance. "mt: Make it an instance variable because we need to access this on every keystroke in a text field. See senders of #deleteBalloon."
+
^ self
valueOfProperty: #balloonHelpMorphs
ifAbsentPut: [OrderedCollection new]!
Item was changed:
----- Method: HandMorph>>becomeActiveDuring: (in category 'initialization') -----
becomeActiveDuring: aBlock
+ "Make the receiver the active hand during the evaluation of aBlock."
- "Make the receiver the ActiveHand during the evaluation of aBlock."
+ ^ ActiveHandVariable value: self during: aBlock!
- | priorHand |
- priorHand := ActiveHand.
- ActiveHand := self.
- ^ aBlock ensure: [
- "check to support project switching."
- ActiveHand == self ifTrue: [ActiveHand := priorHand]].!
Item was removed:
- ----- Method: HandMorph>>checkForMoreKeyboard (in category 'event handling') -----
- checkForMoreKeyboard
- "Quick check for more keyboard activity -- Allows, eg, many characters
- to be accumulated into a single replacement during type-in."
-
- | evtBuf |
- self flag: #arNote. "Will not work if we don't examine event queue in Sensor"
- evtBuf := Sensor peekKeyboardEvent.
- evtBuf ifNil: [^nil].
- ^self generateKeyboardEvent: evtBuf!
Item was added:
+ ----- Method: HandMorph>>cleanUp: (in category 'initialize-release') -----
+ cleanUp: aggressive
+
+ aggressive ifTrue: [
+ externalDropMorph := nil].!
Item was changed:
----- Method: HandMorph>>cursorPoint (in category 'event handling') -----
cursorPoint
"Implemented for allowing embedded worlds in an event cycle to query a hand's position and get it in its coordinates. The same can be achieved by #point:from: but this is simply much more convenient since it will look as if the hand is in the lower world."
+ ^ self currentWorld point: self position from: owner!
- | pos |
- pos := self position.
- (ActiveWorld isNil or: [ActiveWorld == owner]) ifTrue: [^pos].
- ^ActiveWorld point: pos from: owner!
Item was changed:
----- Method: HandMorph>>dropMorph:event: (in category 'grabbing/dropping') -----
dropMorph: aMorph event: anEvent
"Drop the given morph which was carried by the hand"
| event dropped |
+ (anEvent isMouseUp and: [aMorph shouldDropOnMouseUp not]) ifTrue: [^ self].
- (anEvent isMouseUp and:[aMorph shouldDropOnMouseUp not]) ifTrue:[^self].
+ "Note: For robustness in drag and drop handling, we remove the morph BEFORE we drop it, but we keep its owner set to the hand. This prevents system lockups when there is a problem in drop handling (for example if there's an error in #wantsToBeDroppedInto:). THIS TECHNIQUE IS NOT RECOMMENDED FOR CASUAL USE."
- "Note: For robustness in drag and drop handling we remove the morph BEFORE we drop him, but we keep his owner set to the hand. This prevents system lockups when there is a problem in drop handling (for example if there's an error in #wantsToBeDroppedInto:). THIS TECHNIQUE IS NOT RECOMMENDED FOR CASUAL USE."
self privateRemove: aMorph.
aMorph privateOwner: self.
+
-
dropped := aMorph.
(dropped hasProperty: #addedFlexAtGrab)
+ ifTrue: [dropped := aMorph removeFlexShell].
- ifTrue:[dropped := aMorph removeFlexShell].
event := DropEvent new setPosition: self position contents: dropped hand: self.
[ "In case of an error, ensure that the morph-to-be-dropped will be disposed. Otherwise it may confuse garbage handler. See the sends of #privateRemove: and #privateOwner: above."
event := self sendEvent: event focus: nil. "event filters can apply and filtered events will be returned"
event wasHandled ifFalse: [aMorph rejectDropMorphEvent: event] ]
ensure: [ aMorph owner == self ifTrue: [aMorph delete] ].
self mouseOverHandler processMouseOver: anEvent.!
Item was changed:
----- Method: HandMorph>>generateDropFilesEvent: (in category 'private events') -----
generateDropFilesEvent: evtBuf
+ "Generate the appropriate mouse event for the given raw event buffer."
- "Generate the appropriate mouse event for the given raw event buffer"
- "Note: This is still in an experimental phase and will need more work"
-
| position buttons modifiers stamp numFiles dragType |
stamp := evtBuf second.
stamp = 0 ifTrue: [stamp := Time eventMillisecondClock].
dragType := evtBuf third.
position := evtBuf fourth @ evtBuf fifth.
+ buttons := MouseEvent redButton. "hacked because necessary for correct mouseMoveDragging handling"
- buttons := 0.
modifiers := evtBuf sixth.
+ buttons := buttons bitOr: (modifiers bitShift: MouseEvent numButtons).
- buttons := buttons bitOr: (modifiers bitShift: 3).
numFiles := evtBuf seventh.
+
+ dragType caseOf: {
+ [1] -> [ "dragEnter"
+ externalDropMorph := TransferMorph new
+ dragTransferType: #filesAndDirectories;
+ source: self;
+ passenger: (numFiles = 0 "Usually, numFiles and drop paths are delivered on dragDrop only. Still reserving this possibility for able host implementations."
+ ifTrue: [self flag: #vmCapabilityMissing. 'Unknown host content' translated]
+ ifFalse: [FileDirectory dropFilesAndDirectories: numFiles]);
+ yourself.
+
+ "During the drag operation, the host system is responsible for displaying the cursor."
+ self grabMorph: externalDropMorph.
+ self showTemporaryCursor: Cursor blank.
+ externalDropMorph bottomRight: self topLeft. "Southeast area of the cursor is blocked by drawings from the source application. Display our drop morph at the opposite corner of the cursor." ].
+ [2] -> [ "dragMove"
+ ^ MouseMoveEvent new
+ setType: #mouseMove
+ startPoint: self position
+ endPoint: position
+ trail: "{self position. position}"(self mouseDragTrailFrom: evtBuf)
+ buttons: buttons
+ hand: self
+ stamp: stamp ].
+ [3] -> [ "dragLeave"
+ externalDropMorph ifNotNil: #abandon.
+ externalDropMorph := nil.
+ self showTemporaryCursor: nil ].
+ [4] -> [ "dragDrop"
+ | oldButtons event |
+ oldButtons := lastEventBuffer fifth
+ bitOr: (lastEventBuffer sixth bitShift: MouseEvent numButtons).
+ event := MouseButtonEvent new
+ setType: #mouseUp
+ position: position
+ which: (oldButtons bitXor: buttons)
+ buttons: buttons
+ nClicks: 0
+ hand: self
+ stamp: stamp.
+
+ externalDropMorph ifNil: [
+ "dragDrop has been sent without prior dragging. This happens when the VM is configured as singleton application and has been invoked again with a new image file (aka #launchDrop, runAsSingleInstance on Unix, or RunSingleApp on Windows)."
+ self flag: #forLater. "ct: When we decouple event generation from Morphic, we will probably need to introduce a separate SystemLaunchEvent class for this event. See http://forum.world.st/Changeset-Enhanced-integration-of-drag-n-drop-from-ho…."
+ Project current
+ launchSystemFiles: (FileDirectory dropFilesAndDirectories: numFiles)
+ event: event.
+ ^ nil].
+
+ self showTemporaryCursor: nil.
+ externalDropMorph passenger isString ifTrue: [
+ self flag: #vmCapabilityMissing. "See above."
+ externalDropMorph passenger: (FileDirectory dropFilesAndDirectories: numFiles)].
+ externalDropMorph := nil.
+
+ (Smalltalk classNamed: #DropFilesEvent) ifNotNil: [:eventClass |
+ | classicEvent |
+ "Generate classic DropFilesEvent, providing backward compatibility."
+ classicEvent := eventClass new
+ setPosition: position
+ contents: numFiles
+ hand: self.
+ self processEvent: classicEvent.
+ classicEvent wasHandled ifTrue: [^ nil]].
+
+ ^ event ].
+ [5] -> [ "drag request"
+ "For dnd out. Not properly implemented at the moment."
+ self shouldBeImplemented] }.
+ ^ nil!
- dragType = 4
- ifTrue:
- ["e.g., drop"
-
- owner borderWidth: 0.
- ^DropFilesEvent new
- setPosition: position
- contents: numFiles
- hand: self].
- "the others are currently not handled by morphs themselves"
- dragType = 1
- ifTrue:
- ["experimental drag enter"
-
- owner
- borderWidth: 4;
- borderColor: owner color asColor negated].
- dragType = 2
- ifTrue:
- ["experimental drag move"
-
- ].
- dragType = 3
- ifTrue:
- ["experimental drag leave"
-
- owner borderWidth: 0].
- ^nil!
Item was changed:
----- Method: HandMorph>>generateKeyboardEvent: (in category 'private events') -----
generateKeyboardEvent: evtBuf
"Generate the appropriate mouse event for the given raw event buffer"
+ | buttons modifiers type pressType stamp keyValue keyCode |
- | buttons modifiers type pressType stamp keyValue |
stamp := evtBuf second.
+ stamp = 0 ifTrue: [stamp := Sensor eventTimeNow].
- stamp = 0 ifTrue: [stamp := Time eventMillisecondClock].
pressType := evtBuf fourth.
pressType = EventKeyDown ifTrue: [type := #keyDown].
pressType = EventKeyUp ifTrue: [type := #keyUp].
pressType = EventKeyChar ifTrue: [type := #keystroke].
modifiers := evtBuf fifth.
+ buttons := (modifiers bitShift: MouseEvent numButtons) bitOr: (lastMouseEvent buttons bitAnd: MouseEvent anyButton).
- buttons := (modifiers bitShift: 3) bitOr: (lastMouseEvent buttons bitAnd: 7).
type = #keystroke
+ ifTrue: [
+ keyValue := (self keyboardInterpreter nextCharFrom: EventSensor default firstEvt: evtBuf) asInteger.
+ keyCode := lastKeyDownEvent keyValue]
+ ifFalse: [keyValue := keyCode := evtBuf third].
- ifTrue: [keyValue := (self keyboardInterpreter nextCharFrom: Sensor firstEvt: evtBuf) asInteger]
- ifFalse: [keyValue := evtBuf third].
^ KeyboardEvent new
setType: type
buttons: buttons
position: self position
keyValue: keyValue
+ keyCode: keyCode
hand: self
stamp: stamp.
!
Item was changed:
----- Method: HandMorph>>generateMouseEvent: (in category 'private events') -----
generateMouseEvent: evtBuf
"Generate the appropriate mouse event for the given raw event buffer"
| position buttons modifiers type trail stamp oldButtons evtChanged |
+ evtBuf first = lastEventBuffer first ifTrue:
+ ["Workaround for Mac VM bug, *always* generating 3 events on clicks"
+ evtChanged := false.
+ 3 to: evtBuf size do:
+ [:i | (lastEventBuffer at: i) = (evtBuf at: i) ifFalse: [evtChanged := true]].
+ evtChanged ifFalse: [^nil]].
- evtBuf first = lastEventBuffer first
- ifTrue:
- ["Workaround for Mac VM bug, *always* generating 3 events on clicks"
-
- evtChanged := false.
- 3 to: evtBuf size
- do: [:i | (lastEventBuffer at: i) = (evtBuf at: i) ifFalse: [evtChanged := true]].
- evtChanged ifFalse: [^nil]].
stamp := evtBuf second.
+ stamp = 0 ifTrue: [stamp := Sensor eventTimeNow].
- stamp = 0 ifTrue: [stamp := Time eventMillisecondClock].
position := evtBuf third @ evtBuf fourth.
buttons := evtBuf fifth.
modifiers := evtBuf sixth.
type := buttons = 0
+ ifTrue:
+ [lastEventBuffer fifth = 0
+ ifTrue: [#mouseMove] "this time no button and previously no button .. just mouse move"
+ ifFalse: [#mouseUp]] "this time no button but previously some button ... therefore button was released"
+ ifFalse:
+ [buttons = lastEventBuffer fifth
+ ifTrue: [#mouseMove] "button states are the same .. now and past .. therfore a mouse movement"
+ ifFalse: "button states are different .. button was pressed or released"
+ [buttons > lastEventBuffer fifth
- ifTrue:[
- lastEventBuffer fifth = 0
- ifTrue: [#mouseMove] "this time no button and previously no button .. just mouse move"
- ifFalse: [#mouseUp] "this time no button but previously some button ... therefore button was released"
- ]
- ifFalse:[
- buttons = lastEventBuffer fifth
- ifTrue: [#mouseMove] "button states are the same .. now and past .. therfore a mouse movement"
- ifFalse: [ "button states are different .. button was pressed or released"
- buttons > lastEventBuffer fifth
ifTrue: [#mouseDown]
+ ifFalse:[#mouseUp]]].
+ buttons := buttons bitOr: (modifiers bitShift: MouseEvent numButtons).
+ oldButtons := lastEventBuffer fifth bitOr: (lastEventBuffer sixth bitShift: MouseEvent numButtons).
- ifFalse:[#mouseUp].
- ].
- ].
- buttons := buttons bitOr: (modifiers bitShift: 3).
- oldButtons := lastEventBuffer fifth
- bitOr: (lastEventBuffer sixth bitShift: 3).
lastEventBuffer := evtBuf.
+ type == #mouseMove ifTrue:
+ [trail := self mouseTrailFrom: evtBuf.
+ ^MouseMoveEvent new
+ setType: type
+ startPoint: self position
+ endPoint: trail last
+ trail: trail
+ buttons: buttons
+ hand: self
+ stamp: stamp].
- type == #mouseMove
- ifTrue:
- [trail := self mouseTrailFrom: evtBuf.
- ^MouseMoveEvent new
- setType: type
- startPoint: (self position)
- endPoint: trail last
- trail: trail
- buttons: buttons
- hand: self
- stamp: stamp].
^MouseButtonEvent new
setType: type
position: position
which: (oldButtons bitXor: buttons)
buttons: buttons
nClicks: (evtBuf seventh ifNil: [0])
hand: self
stamp: stamp!
Item was changed:
----- Method: HandMorph>>generateMouseWheelEvent: (in category 'private events') -----
generateMouseWheelEvent: evtBuf
"Generate the appropriate mouse wheel event for the given raw event buffer"
+ | buttons modifiers deltaX deltaY stamp nextEvent |
- | buttons modifiers deltaX deltaY stamp |
stamp := evtBuf second.
+ stamp = 0 ifTrue: [stamp := Sensor eventTimeNow].
- stamp = 0 ifTrue: [stamp := Time eventMillisecondClock].
deltaX := evtBuf third.
deltaY := evtBuf fourth.
+ buttons := evtBuf fifth.
+ modifiers := evtBuf sixth.
+ [(deltaX abs + deltaY abs < self class minimumWheelDelta)
+ and: [(nextEvent := Sensor peekEvent) notNil
+ and: [nextEvent first = evtBuf first
+ and: [nextEvent fifth = evtBuf fifth
+ and: [nextEvent sixth = evtBuf sixth]
+ and: [nextEvent third isZero = evtBuf third isZero "both horizontal or vertical"]]]]]
+ whileTrue:
+ ["nextEvent is similar. Remove it from the queue, and check the next."
+ nextEvent := Sensor nextEvent.
+ deltaX := deltaX + nextEvent third.
+ deltaY := deltaY + nextEvent fourth].
- modifiers := evtBuf fifth.
- buttons := (modifiers bitShift: 3) bitOr: (lastMouseEvent buttons bitAnd: 7).
^ MouseWheelEvent new
setType: #mouseWheel
position: self position
delta: deltaX@deltaY
- direction: 2r0000
buttons: buttons
hand: self
stamp: stamp!
Item was changed:
----- Method: HandMorph>>generateMouseWheelEvent:direction: (in category 'private events') -----
generateMouseWheelEvent: keystrokeEvent direction: direction
"Generate the appropriate mouse wheel event from the keystrokeEvent. Before calling this, ensure that the control key is pressed.
This method can be discarded once the VM produces real mouse wheel events."
^ MouseWheelEvent new
setType: #mouseWheel
position: keystrokeEvent position
+ delta: 0 @ ((direction anyMask: 2r1000 "wheel up") ifTrue: [MouseWheelEvent scrollUnitsPerMouseWheelNotch] ifFalse: [MouseWheelEvent scrollUnitsPerMouseWheelNotch negated])
- delta: 0 @ ((direction anyMask: 2r1000 "wheel up") ifTrue: [120] ifFalse: [-120])
direction: direction
buttons: (keystrokeEvent buttons bitAnd: 2r01111) "drop control key pressed for this conversion"
hand: keystrokeEvent hand
stamp: keystrokeEvent timeStamp!
Item was changed:
----- Method: HandMorph>>generateWindowEvent: (in category 'private events') -----
generateWindowEvent: evtBuf
"Generate the appropriate window event for the given raw event buffer"
| evt |
evt := WindowEvent new.
+ evt setHand: self.
evt setTimeStamp: evtBuf second.
+ evt timeStamp = 0 ifTrue: [evt setTimeStamp: Sensor eventTimeNow].
- evt timeStamp = 0 ifTrue: [evt setTimeStamp: Time eventMillisecondClock].
evt action: evtBuf third.
evt rectangle: (Rectangle origin: evtBuf fourth @ evtBuf fifth corner: evtBuf sixth @ evtBuf seventh ).
^evt!
Item was changed:
----- Method: HandMorph>>griddedPoint: (in category 'gridded cursor') -----
griddedPoint: aPoint
"return the equivalent point snapped to the grid, if indeed any gridding is set"
+ self valueOfProperty: #gridStep ifPresentDo: [:step | | offset |
- self valueOfProperty: #gridStep ifPresentDo: [:grid| |offset|
offset := self valueOfProperty: #gridOffset ifAbsent: [0@0].
+ ^ ((aPoint + targetOffset - offset) grid: step) - targetOffset + offset].
- ^ offset + (aPoint + (grid //2) - offset truncateTo: grid)].
^aPoint!
Item was added:
+ ----- Method: HandMorph>>griddingOn (in category 'gridded cursor') -----
+ griddingOn
+
+ ^ self hasSubmorphs
+ and: [(self hasProperty: #gridStep)
+ and: [self firstSubmorph disableLayout not]]!
Item was changed:
----- Method: HandMorph>>handleEvent: (in category 'events-processing') -----
handleEvent: unfilteredEvent
| filteredEvent |
owner ifNil: [^ unfilteredEvent "not necessary but good style -- see Morph >> #handleEvent:"].
self logEvent: unfilteredEvent.
"Mouse-over events occur really, really, really often. They are kind of the heart beat of the Morphic UI process."
unfilteredEvent isMouseOver ifTrue: [^ self sendMouseEvent: unfilteredEvent].
self showEvent: unfilteredEvent.
self sendListenEvents: unfilteredEvent.
filteredEvent := self sendFilterEventCapture: unfilteredEvent for: nil.
"filteredEvent := unfilteredEvent" " <-- use this to disable global capture filters"
filteredEvent wasIgnored ifTrue: [
self mouseOverHandler processMouseOver: lastMouseEvent.
^ filteredEvent].
filteredEvent isWindowEvent ifTrue: [
self sendEvent: filteredEvent focus: nil.
self mouseOverHandler processMouseOver: lastMouseEvent.
^ filteredEvent].
+ filteredEvent isKeyboard ifTrue: [
+ filteredEvent isKeyDown ifTrue: [lastKeyDownEvent := filteredEvent].
- filteredEvent isKeyboard ifTrue:[
self sendKeyboardEvent: filteredEvent.
self mouseOverHandler processMouseOver: lastMouseEvent.
^ filteredEvent].
filteredEvent isDropEvent ifTrue:[
self sendEvent: filteredEvent focus: nil.
self mouseOverHandler processMouseOver: lastMouseEvent.
^ filteredEvent].
filteredEvent isMouse ifFalse: [
self mouseOverHandler processMouseOver: lastMouseEvent.
^ filteredEvent].
" ********** MOUSE EVENT *********** "
lastMouseEvent := filteredEvent.
"Check for pending drag or double click operations."
mouseClickState ifNotNil:[
(mouseClickState handleEvent: filteredEvent from: self) ifFalse:[
"Possibly dispatched #click: or something and will not re-establish otherwise"
self mouseOverHandler processMouseOver: lastMouseEvent.
^ filteredEvent]].
filteredEvent isMouseWheel ifTrue: [
+ self class sendMouseWheelToKeyboardFocus
+ ifFalse: [self sendMouseEvent: filteredEvent]
+ ifTrue: [self sendEvent: filteredEvent focus: self keyboardFocus clear: [self keyboardFocus: nil]].
- mouseWheelState ifNil: [mouseWheelState := MouseWheelState new].
- mouseWheelState handleEvent: filteredEvent from: self.
self mouseOverHandler processMouseOver: lastMouseEvent.
^ filteredEvent].
filteredEvent isMove ifTrue:[
self position: filteredEvent position.
self sendMouseEvent: filteredEvent.
self mouseOverHandler processMouseOver: lastMouseEvent.
^ filteredEvent].
"Issue a synthetic move event if we're not at the position of the event"
+ self flag: #bug. "mt: Incompatible with how #mouseMove: is handled when #wantsEveryMouseMove: answers false. Handler might think that #mouseDown: was already received. For example, TextEditor and HaloMorph will issue drags in their #mouseMove: based on old data. That is, the first #mouseMove: appears to come before #mouseDown: while actually sent due to #moveToEvent:."
filteredEvent position = self position
ifFalse: [self moveToEvent: filteredEvent].
"Drop submorphs on button events"
self hasSubmorphs
ifTrue:[self dropMorphs: filteredEvent]
ifFalse:[self sendMouseEvent: filteredEvent].
self mouseOverHandler processMouseOver: lastMouseEvent.
^ filteredEvent "not necessary but good style -- see Morph >> #handleEvent:" !
Item was added:
+ ----- Method: HandMorph>>ignoreEvent: (in category 'events-filtering') -----
+ ignoreEvent: anEvent
+ "Double dispatch from MorphicEvent >> #ignore: to let custom hands tweak this behavior such as logging it."
+
+ anEvent wasIgnored: true.!
Item was changed:
----- Method: HandMorph>>initForEvents (in category 'initialization') -----
initForEvents
mouseOverHandler := nil.
lastMouseEvent := MouseEvent new setType: #mouseMove position: 0@0 buttons: 0 hand: self.
+ lastKeyDownEvent := KeyboardEvent new setType: #keyDown buttons: 0 position: 0@0 keyValue: 0 hand: self stamp: 0.
lastEventBuffer := {1. 0. 0. 0. 0. 0. nil. nil}.
self resetClickState.
self addKeyboardCaptureFilter: self. "to convert unusual VM events"!
Item was changed:
----- Method: HandMorph>>keyboardInterpreter (in category 'multilingual') -----
keyboardInterpreter
+ ^keyboardInterpreter ifNil: [keyboardInterpreter := Locale currentPlatform inputInterpreter]!
- ^keyboardInterpreter ifNil: [keyboardInterpreter := LanguageEnvironment currentPlatform class defaultInputInterpreter]!
Item was changed:
----- Method: HandMorph>>logEvent: (in category 'events-debugging') -----
logEvent: anEvent
"Update statistics for processed events."
+ EventStats ifNil: [EventStats := IdentityDictionary new].
+ EventStats at: #count put: (EventStats at: #count ifAbsent: [0]) + 1.
+ EventStats at: anEvent type put: (EventStats at: anEvent type ifAbsent: [0]) + 1.!
- EventStats ifNil:[EventStats := IdentityDictionary new].
- EventStats at: #count put: (EventStats at: #count ifAbsent:[0]) + 1.
- EventStats at: anEvent type put: (EventStats at: anEvent type ifAbsent:[0]) + 1.!
Item was added:
+ ----- Method: HandMorph>>mouseDragTrailFrom: (in category 'private events') -----
+ mouseDragTrailFrom: currentBuf
+ "Current event, a dragMove event buffer, is about to be processed. If there are other similar dragMove events queued up, then drop them from the queue, and report the positions inbetween. Adapted version of #mouseTrailFrom:."
+
+ | nextEvent trail |
+ trail := WriteStream on: (Array new: 1).
+ trail nextPut: currentBuf fourth @ currentBuf fifth.
+ [(nextEvent := Sensor peekEvent) isNil] whileFalse: [
+ nextEvent first = currentBuf first
+ ifFalse: [^ trail contents "different event type"].
+ nextEvent third = currentBuf third
+ ifFalse: [^ trail contents "dragType changed"].
+ nextEvent sixth = currentBuf sixth
+ ifFalse: [^ trail contents "modifiers changed"].
+ nextEvent seventh = currentBuf seventh
+ ifFalse: [^ trail contents "numFiles changed"].
+ "nextEvent is similar. Remove it from the queue, and check the next."
+ nextEvent := Sensor nextEvent.
+ trail nextPut: nextEvent fourth @ nextEvent fifth].
+ ^ trail contents!
Item was changed:
----- Method: HandMorph>>position: (in category 'geometry') -----
+ position: ungriddedPosition
- position: aPoint
"Overridden to align submorph origins to the grid if gridding is on."
| adjustedPosition delta box |
+ adjustedPosition := ungriddedPosition.
+ self griddingOn
+ ifTrue: [adjustedPosition := self griddedPoint: ungriddedPosition].
+ temporaryCursor
+ ifNotNil: [adjustedPosition := adjustedPosition + temporaryCursorOffset].
- adjustedPosition := aPoint.
- temporaryCursor ifNotNil: [adjustedPosition := (self griddedPoint: adjustedPosition) + temporaryCursorOffset].
"Copied from Morph to avoid owner layoutChanged"
"Change the position of this morph and and all of its submorphs."
delta := adjustedPosition - bounds topLeft.
delta isZero ifTrue: [^ self]. "Null change"
box := self fullBounds.
(delta dotProduct: delta) > 100 ifTrue:[
"e.g., more than 10 pixels moved"
self invalidRect: box.
self invalidRect: (box translateBy: delta).
] ifFalse:[
self invalidRect: (box merge: (box translateBy: delta)).
].
self privateFullMoveBy: delta.
!
Item was changed:
----- Method: HandMorph>>processEvents (in category 'event handling') -----
processEvents
"Process user input events from the local input devices."
+ | evtBuf hadAny |
+ self currentEvent ~= lastMouseEvent ifTrue: [
+ "Meaning that we were invoked from within an event response.
+ Make sure z-order is up to date."
+ self mouseOverHandler processMouseOver: lastMouseEvent].
+
- | evt evtBuf type hadAny |
- ActiveEvent ifNotNil:
- ["Meaning that we were invoked from within an event response.
- Make sure z-order is up to date"
-
- self mouseOverHandler processMouseOver: lastMouseEvent].
hadAny := false.
+ [(evtBuf := Sensor nextEvent) isNil] whileFalse: [
+ | evt |
+ evt := evtBuf first "type"
+ caseOf: {
+ [EventTypeMouse] -> [self generateMouseEvent: evtBuf].
+ [EventTypeMouseWheel] -> [self generateMouseWheelEvent: evtBuf].
+ [EventTypeKeyboard] -> [self generateKeyboardEvent: evtBuf].
+ [EventTypeDragDropFiles] -> [self generateDropFilesEvent: evtBuf].
+ [EventTypeWindow] -> [self generateWindowEvent: evtBuf] }
+ otherwise: [nil "All other events are ignored"].
+
+ evt ifNotNil: [
+ "Finally, handle it"
+ self handleEvent: evt.
+ hadAny := true.
+
+ "For better user feedback, return immediately after a mouse event has been processed."
+ evt isMouse ifTrue: [^ self] ] ].
+
- [(evtBuf := Sensor nextEvent) isNil] whileFalse:
- [evt := nil. "for unknown event types"
- type := evtBuf first.
- type = EventTypeMouse
- ifTrue: [evt := self generateMouseEvent: evtBuf].
- type = EventTypeMouseWheel
- ifTrue: [evt := self generateMouseWheelEvent: evtBuf].
- type = EventTypeKeyboard
- ifTrue: [evt := self generateKeyboardEvent: evtBuf].
- type = EventTypeDragDropFiles
- ifTrue: [evt := self generateDropFilesEvent: evtBuf].
- type = EventTypeWindow
- ifTrue:[evt := self generateWindowEvent: evtBuf].
- "All other events are ignored"
- (type ~= EventTypeDragDropFiles and: [evt isNil]) ifTrue: [^self].
- evt isNil
- ifFalse:
- ["Finally, handle it"
-
- self handleEvent: evt.
- hadAny := true.
-
- "For better user feedback, return immediately after a mouse event has been processed."
- evt isMouse ifTrue: [^self]]].
"note: if we come here we didn't have any mouse events"
+ mouseClickState ifNotNil: [
+ "No mouse events during this cycle. Make sure click states time out accordingly"
+ mouseClickState handleEvent: lastMouseEvent asMouseMove from: self].
+ hadAny ifFalse: [
+ "No pending events. Make sure z-order is up to date"
+ self mouseOverHandler processMouseOver: lastMouseEvent].!
- mouseClickState notNil
- ifTrue:
- ["No mouse events during this cycle. Make sure click states time out accordingly"
-
- mouseClickState handleEvent: lastMouseEvent asMouseMove from: self].
- hadAny
- ifFalse:
- ["No pending events. Make sure z-order is up to date"
-
- self mouseOverHandler processMouseOver: lastMouseEvent]!
Item was changed:
----- Method: HandMorph>>removePendingBalloonFor: (in category 'balloon help') -----
removePendingBalloonFor: aMorph
+ "Get rid of pending balloon help or remove the balloon help if already shown."
+
+ self flag: #workaround. "mt: We do not track for which morph there is a pending balloon. To avoid cancelling the wrong requests, check whether the given morph wants a balloon or not. Seems to work fine."
+ aMorph wantsBalloon ifFalse: [^ self].
+
- "Get rid of pending balloon help."
self removeAlarm: #spawnBalloonFor:.
self deleteBalloonTarget: aMorph.!
Item was changed:
----- Method: HandMorph>>showEvent: (in category 'events-debugging') -----
showEvent: anEvent
"Show details about the event on the display form. Useful for debugging."
+ "ShowEvents := true"
+ "ShowEvents := false"
+ | message borderWidth heightOffset |
-
- | message borderWidth |
ShowEvents == true ifFalse: [^ self].
borderWidth := 5.
message := String streamContents: [:strm |
strm
nextPutAll: '[HandMorph >> #showEvent:]'; cr;
nextPutAll: 'event'; tab; tab; tab; tab; nextPutAll: anEvent printString; cr;
+ nextPutAll: 'keyboard focus'; tab; tab; nextPutAll: self keyboardFocus printString; cr;
- nextPutAll: 'keyboard focus'; tab; nextPutAll: self keyboardFocus printString; cr;
nextPutAll: 'mouse focus'; tab; tab; nextPutAll: self mouseFocus printString].
message := message asDisplayText
foregroundColor: Color black
backgroundColor: Color white.
+ heightOffset := (owner submorphs detect: [:m| m isDockingBar] ifNone: [])
+ ifNil: [0]
+ ifNotNil: [:m| m height].
-
"Offset to support multiple hands debugging."
+ Display fill: (0 @ heightOffset extent: message form extent + (borderWidth asPoint * 2)) rule: Form over fillColor: Color white.
+ message displayOn: Display at: (borderWidth @ heightOffset) + (0 @ ((owner hands indexOf: self) - 1 * message form height)).!
- Display fill: (0 @ 0 extent: message form extent + (borderWidth asPoint * 2)) rule: Form over fillColor: Color white.
- message displayOn: Display at: borderWidth asPoint + (0 @ ((owner hands indexOf: self) - 1 * message form height)).!
Item was added:
+ ----- Method: HandMorph>>turnOnGridding (in category 'gridded cursor') -----
+ turnOnGridding
+
+ self
+ gridTo: self world gridModulus
+ origin: self world gridOrigin.!
Item was changed:
----- Method: HandleMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
self extent: 16 @ 16.
+ self disableLayout: true.
+ self morphicLayerNumber: self class frontmostLayer.!
- !
Item was changed:
+ ----- Method: IconicButton>>darken (in category 'ui') -----
- ----- Method: IconicButton>>darken (in category 'as yet unclassified') -----
darken
self firstSubmorph form: self darkenedForm!
Item was changed:
----- Method: ImageMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
+ self borderStyle ifNotNil:[:style |
- | style |
- (style := self borderStyle) ifNotNil:[
style frameRectangle: bounds on: aCanvas.
].
self isOpaque
ifTrue:[aCanvas drawImage: image at: self innerBounds origin]
ifFalse:[aCanvas translucentImage: image at: self innerBounds origin]!
Item was changed:
----- Method: IndentingListItemMorph>>getLabelFor: (in category 'model access') -----
getLabelFor: model
+ "Note that the given model is usually aListItemWrapper."
+
+ ^ model asStringOrText!
-
- ^ model asString!
Item was added:
+ ----- Method: IndentingListItemMorph>>initWithColor:andFont: (in category 'initialization') -----
+ initWithColor: aColor andFont: aFont
+
+ (self hasProperty: #hasColorFromText)
+ ifFalse: [self color: aColor].
+
+ (self hasProperty: #hasEmphasisFromText)
+ ifTrue: [
+ (self hasProperty: #hasFontFromText)
+ ifFalse: [self font: aFont "Keeps emphasis from text."]]
+ ifFalse: [
+ (self hasProperty: #hasFontFromText)
+ ifTrue: [self emphasis: aFont emphasis "Keeps font from text."]
+ ifFalse: [self font: aFont emphasis: aFont emphasis]]
+ !
Item was changed:
----- Method: IndentingListItemMorph>>initWithContents:prior:forList:indentLevel: (in category 'initialization') -----
initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel
container := hostList.
complexContents := anObject.
anObject addDependent: self.
self initWithContents: self getLabel font: Preferences standardListFont emphasis: nil.
indentLevel := 0.
isExpanded := false.
nextSibling := firstChild := nil.
priorMorph ifNotNil: [
priorMorph nextSibling: self.
].
indentLevel := newLevel.
+ icon := self getIcon ifNotNil: [:form | form scaleIconToDisplay].
- icon := self getIcon.
self extent: self minWidth @ self minHeight!
Item was added:
+ ----- Method: IndentingListItemMorph>>initializeFromText: (in category 'initialization') -----
+ initializeFromText: aText
+ "Overridden to keep track of text-based attributes."
+
+ | priorFont priorEmphasis priorColor |
+ priorFont := self font.
+ priorEmphasis := self emphasis.
+ priorColor := self color.
+
+ super initializeFromText: aText.
+
+ priorFont == self font
+ ifFalse: [self setProperty: #hasFontFromText toValue: true].
+ priorFont == self emphasis
+ ifFalse: [self setProperty: #hasEmphasisFromText toValue: true].
+ priorColor == self color
+ ifFalse: [self setProperty: #hasColorFromText toValue: true].!
Item was changed:
----- Method: IndentingListItemMorph>>minHeight (in category 'layout') -----
minHeight
| iconHeight |
iconHeight := self hasIcon
ifTrue: [self icon height + 2]
ifFalse: [0].
+ ^ self fontToUse lineGridForMorphs max: iconHeight !
- ^ self fontToUse height max: iconHeight !
Item was changed:
----- Method: IndentingListItemMorph>>refresh (in category 'initialization') -----
refresh
self contents: self getLabel.
+ self refreshIcon.
- icon := self getIcon.
(self valueOfProperty: #wasRefreshed ifAbsent: [false]) ifFalse: [
self setProperty: #wasRefreshed toValue: true].!
Item was added:
+ ----- Method: IndentingListItemMorph>>refreshIcon (in category 'initialization') -----
+ refreshIcon
+
+ icon := self getIcon ifNotNil: [:form | form scaleIconToDisplay].!
Item was changed:
----- Method: IndentingListItemMorph>>toggleRectangle (in category 'private') -----
toggleRectangle
+ | h indent |
- | h |
h := bounds height.
+ indent := (12 * RealEstateAgent scaleFactor) rounded.
+ ^(bounds left + self hMargin + (indent * indentLevel)) @ bounds top extent: indent@h!
- ^(bounds left + self hMargin + (12 * indentLevel)) @ bounds top extent: 12@h!
Item was changed:
----- Method: Integer>>explorerContents (in category '*Morphic-Explorer') -----
explorerContents
+ ^ Array streamContents: [:stream |
+ #(
+ 'hex' 16 2 0 'hexadecimal, base 16'
+ 'oct' 8 3 0 'octal, base 8'
+ 'bin' 2 4 0 'binary, base 2'
+ 'bit' nil 4 8 'Logical bit field\- Two complement\- Infinite sign bits\- Try #bitAt:') groupsDo: [ :key :base :group :padding :balloon | | label |
+ label := self abs printStringBase: (base ifNil: [2]).
+ base ifNil: [
+ label := String streamContents: [:s |
+ (label size roundUpTo: padding) to: 1 by: -1 do: [:index |
+ s nextPutAll: (self bitAt: index) asString]]].
+ label := label
+ padded: #left
+ to: (label size roundUpTo: group) + padding
+ with: ((base isNil and: [self negative]) ifTrue: [$1] ifFalse: [$0]).
+ label := String streamContents: [:s |
+ (self negative and: [base notNil]) ifTrue: [s nextPutAll: '-'].
+ base ifNil: [s nextPutAll: '... '].
+ (1 to: label size by: group)
+ do: [:index |
+ 1 to: group do: [:gIndex |
+ s nextPut: (label at: index + gIndex - 1)]]
+ separatedBy: [s space]].
+ stream nextPut: ((
+ ObjectExplorerWrapper
+ with: label
+ name: key
+ model: self)
+ balloonText: balloon withCRs;
+ yourself) ]]!
- ^#(
- ('hexadecimal' 16)
- ('octal' 8)
- ('binary' 2)) collect: [ :each |
- ObjectExplorerWrapper
- with: each first translated
- name: (self printStringBase: each second)
- model: self ]!
Item was changed:
+ ----- Method: KeyboardBuffer>>flushKeyboard (in category 'keyboard control') -----
- ----- Method: KeyboardBuffer>>flushKeyboard (in category 'as yet unclassified') -----
flushKeyboard
eventUsed ifFalse: [^ eventUsed := true].!
Item was changed:
+ ----- Method: KeyboardBuffer>>keyboard (in category 'keyboard control') -----
- ----- Method: KeyboardBuffer>>keyboard (in category 'as yet unclassified') -----
keyboard
eventUsed ifFalse: [eventUsed := true. ^ event keyCharacter].
^ nil!
Item was changed:
+ ----- Method: KeyboardBuffer>>keyboardPeek (in category 'keyboard control') -----
- ----- Method: KeyboardBuffer>>keyboardPeek (in category 'as yet unclassified') -----
keyboardPeek
eventUsed ifFalse: [^ event keyCharacter].
^ nil!
Item was changed:
+ ----- Method: KeyboardBuffer>>startingEvent: (in category 'private') -----
- ----- Method: KeyboardBuffer>>startingEvent: (in category 'as yet unclassified') -----
startingEvent: evt
event := evt.
eventUsed := false!
Item was changed:
UserInputEvent subclass: #KeyboardEvent
+ instanceVariableNames: 'keyValue keyCode'
- instanceVariableNames: 'keyValue'
classVariableNames: ''
poolDictionaries: ''
category: 'Morphic-Events'!
Item was changed:
----- Method: KeyboardEvent>>= (in category 'comparing') -----
= aMorphicEvent
super = aMorphicEvent ifFalse:[^false].
buttons = aMorphicEvent buttons ifFalse: [^ false].
keyValue = aMorphicEvent keyValue ifFalse: [^ false].
+ keyCode = aMorphicEvent keyCode ifFalse: [^ false].
+ ^ true!
- ^ true
- !
Item was added:
+ ----- Method: KeyboardEvent>>asMorph (in category 'morphic/tools - converting') -----
+ asMorph
+ "Answers a graphical reprsentation for this keyboard event. Does not work for keyUp and keyDown because we do not have platform-specific mapping tables for the key codes."
+
+ | box color arrow |
+ box := Morph new
+ color: Color transparent;
+ layoutPolicy: TableLayout new;
+ listDirection: #leftToRight;
+ hResizing: #shrinkWrap;
+ vResizing: #shrinkWrap;
+ cellGap: 2;
+ yourself.
+ color := self userInterfaceTheme get: #textColor for: #PluggableButtonMorph.
+
+ self physicalModifiers
+ do: [:modifier |
+ box addMorphBack: (ToolIcons keyboardButtonLabeled: modifier capitalized dyed: color) asMorph.
+ box addMorphBack: (('+' asText addAttribute: (TextColor color: color); asMorph) lock)].
+
+ "Visualize arrow keys."
+ arrow := self key.
+ (arrow isCharacter and: [arrow asciiValue between: 28 and: 31]) ifTrue: [
+ box addMorphBack: (ToolIcons keyboardButtonLabeled: (
+ ScrollBar
+ arrowOfDirection: (#(left right top bottom) at: arrow asciiValue - 27)
+ size: Preferences standardButtonFont height
+ color: Color black) dyed: color) asMorph.
+ ^ box].
+
+ box addMorphBack: (ToolIcons
+ keyboardButtonLabeled: self physicalKey asString capitalized
+ dyed: color) asMorph.
+
+ ^ box!
Item was added:
+ ----- Method: KeyboardEvent>>checkCommandKey (in category 'debugging') -----
+ checkCommandKey
+
+ self flag: #debuggingOnly. "mt: This check documents a trade-off for having platform-specific modifiers and writing cross-platform compatible applications. If you want to support all three modifiers (i.e. CTRL, CMD, OPT), be aware that
+ (1) you should first check for CTRL/OPT then CMD, because
+ (2) physical CTRL and ALT keys on Linux/Windows are mapped to the pairs CTRL+CMD and CMD+OPT respectively and thus overshadow some key bindings if checked in the wrong order -- and that's why
+ (3) you should effectively only use CTRL/CMD, OPT/CMD, or CTRL/OPT in an application on Linux/Windows. And communicate the physical keys being CTRL and ALT.
+
+ Note that point (3) documents the best practice for handling keystroke (not keyUp or keyDown) events while maintaining cross-platform compatibility."
+
+ ^ self commandKeyPressed
+ and: [self controlKeyPressed not
+ and: [self optionKeyPressed not]]!
Item was added:
+ ----- Method: KeyboardEvent>>key (in category 'keyboard') -----
+ key
+ "Answers a representation for the (non-modifier) key, which should be consistent across platforms considering its cause."
+
+ ^ EventSensor virtualKeyAt: keyCode!
Item was added:
+ ----- Method: KeyboardEvent>>keyCode (in category 'keyboard') -----
+ keyCode
+ "Answers the virtual-key code (or scan code) for this event."
+
+ ^ keyCode!
Item was added:
+ ----- Method: KeyboardEvent>>physicalKey (in category 'morphic/tools - accessing') -----
+ physicalKey
+
+ ^ self key
+ ifNil: ['VK-0x', (self keyCode printPaddedWith: $0 to: 2 base: 16)]
+ ifNotNil: [:key |
+ (#(control command option) includes: key)
+ ifTrue: [ "Similar to #physicalModifiers"
+ Smalltalk platformName = 'Mac OS'
+ ifTrue: [key]
+ ifFalse: [
+ self controlKeyPressed
+ ifTrue: [(self optionKeyPressed and: [self commandKeyPressed])
+ ifTrue: [#alt "Linux/X11"]
+ ifFalse: [#control]]
+ ifFalse: [#alt]]]
+ ifFalse: [
+ (key isCharacter
+ ifTrue: [(Character constantNameFor: key) ifNil: [key]]
+ ifFalse: [key]) ]]!
Item was added:
+ ----- Method: KeyboardEvent>>physicalModifiers (in category 'morphic/tools - accessing') -----
+ physicalModifiers
+ "Help users understand the physical modifier keys that where involved in this event. Note that, due to historical reasons, the SHIFT modifier comes first on macOS but last on other platforms."
+
+ | result |
+ result := OrderedCollection new.
+
+ Smalltalk platformName = 'Mac OS'
+ ifTrue: [
+ self shiftPressed ifTrue: [result add: #shift].
+ self controlKeyPressed ifTrue: [result add: #ctrl].
+ self optionKeyPressed ifTrue: [result add: #opt].
+ self commandKeyPressed ifTrue: [result add: #cmd]]
+ ifFalse: [ "Linux/Windows"
+ self controlKeyPressed
+ ifTrue: [result add: #ctrl]
+ ifFalse: [
+ Smalltalk platformName = 'Win32'
+ ifTrue: [
+ (self commandKeyPressed or: [self optionKeyPressed])
+ ifTrue: [result add: #alt]]
+ ifFalse: ["Linux/ARM"
+ self commandKeyPressed
+ ifTrue: [result add: #alt]
+ ifFalse: [self optionKeyPressed
+ ifTrue: [
+ result add: #ctrl.
+ result add: #alt]]]].
+ self shiftPressed ifTrue: [result add: #shift]].
+ ^ result!
Item was changed:
----- Method: KeyboardEvent>>printKeyStringOn: (in category 'printing') -----
printKeyStringOn: aStream
"Print a readable string representing the receiver on a given stream"
| kc inBrackets firstBracket keyString |
kc := self keyCharacter.
inBrackets := false.
firstBracket := [ inBrackets ifFalse: [ aStream nextPut: $<. inBrackets := true ]].
+ self modifiers
+ select: [:modifier |
+ "Show #shift modifier only for control characters for backwards compatibility in #keyString."
+ modifier ~= #shift or: [ keyValue < 32 ]]
+ thenDo: [:modifier |
+ firstBracket value.
+ "Capitalize modifier for backwards compatibility in #keyString."
+ aStream nextPutAll: modifier capitalized; nextPutAll: '-' ].
- self controlKeyPressed ifTrue: [ firstBracket value. aStream nextPutAll: 'Ctrl-' ].
- self commandKeyPressed ifTrue: [ firstBracket value. aStream nextPutAll: 'Cmd-' ].
- (buttons anyMask: 32) ifTrue: [ firstBracket value. aStream nextPutAll: 'Opt-' ].
- (self shiftPressed and: [ (keyValue between: 1 and: 31) or: [self keyCharacter = Character delete ]])
- ifTrue: [ firstBracket value. aStream nextPutAll: 'Shift-' ].
+ keyString := (Character constantNameFor: kc)
+ ifNil: [String with: kc].
- keyString := (kc caseOf: {
- [ Character space ] -> [ 'space' ].
- [ Character tab ] -> [ 'tab' ].
- [ Character cr ] -> [ 'cr' ].
- [ Character lf ] -> [ 'lf' ].
- [ Character enter ] -> [ 'enter' ].
-
- [ Character backspace ] -> [ 'backspace' ].
- [ Character delete ] -> [ 'delete' ].
-
- [ Character escape ] -> [ 'escape' ].
-
- [ Character arrowDown ] -> [ 'down' ].
- [ Character arrowUp ] -> [ 'up' ].
- [ Character arrowLeft ] -> [ 'left' ].
- [ Character arrowRight ] -> [ 'right' ].
-
- [ Character end ] -> [ 'end' ].
- [ Character home ] -> [ 'home' ].
- [ Character pageDown ] -> [ 'pageDown' ].
- [ Character pageUp ] -> [ 'pageUp' ].
-
- [ Character euro ] -> [ 'euro' ].
- [ Character insert ] -> [ 'insert' ].
-
- } otherwise: [ String with: kc ]).
+ keyString := keyString caseOf: {
+ "Rename several keys for backwards compatibility in #keyString."
+ [ 'space' ] -> [ ' ' ].
+ [ 'return' ] -> [ 'cr' ].
+ [ 'arrowDown' ] -> [ 'down' ].
+ [ 'arrowUp' ] -> [ 'up' ].
+ [ 'arrowLeft' ] -> [ 'left' ].
+ [ 'arrowRight' ] -> [ 'right' ]
+ } otherwise: [ keyString ].
+
keyString size > 1 ifTrue: [ firstBracket value ].
aStream nextPutAll: keyString.
inBrackets ifTrue: [aStream nextPut: $> ]!
Item was changed:
----- Method: KeyboardEvent>>printOn: (in category 'printing') -----
printOn: aStream
"Print the receiver on a stream"
aStream nextPut: $[.
aStream nextPutAll: self cursorPoint printString; space.
+ aStream nextPutAll: type; space.
+
+ self isKeystroke ifTrue: [
+ aStream nextPutAll: ''''.
+ self printKeyStringOn: aStream.
+ aStream nextPut: $'; space].
+
- aStream nextPutAll: type; nextPutAll: ' '''.
- self printKeyStringOn: aStream.
- aStream nextPut: $'; space.
aStream nextPut: $(.
aStream nextPutAll: keyValue printString.
aStream nextPut: $); space.
+
aStream nextPutAll: timeStamp printString.
aStream nextPut: $]!
Item was removed:
- ----- Method: KeyboardEvent>>scanCode: (in category 'private') -----
- scanCode: ignore
- " OB-Tests expects this "!
Item was changed:
----- Method: KeyboardEvent>>setType:buttons:position:keyValue:hand:stamp: (in category 'private') -----
setType: aSymbol buttons: anInteger position: pos keyValue: aValue hand: aHand stamp: stamp
+
+ self
+ setType: aSymbol
+ buttons: anInteger
+ position: pos
+ keyValue: aValue
+ keyCode: #unknown
+ hand: aHand
+ stamp: stamp.!
- type := aSymbol.
- buttons := anInteger.
- position := pos.
- keyValue := aValue.
- source := aHand.
- wasHandled := false.
- timeStamp := stamp.!
Item was added:
+ ----- Method: KeyboardEvent>>setType:buttons:position:keyValue:keyCode:hand:stamp: (in category 'private') -----
+ setType: aSymbol buttons: anInteger position: pos keyValue: aValue keyCode: aCode hand: aHand stamp: stamp
+ type := aSymbol.
+ buttons := anInteger.
+ position := pos.
+ keyValue := aValue.
+ keyCode := aCode.
+ source := aHand.
+ wasHandled := false.
+ timeStamp := stamp.!
Item was changed:
----- Method: KeyboardEvent>>storeOn: (in category 'printing') -----
storeOn: aStream
aStream nextPutAll: type.
aStream space.
self timeStamp storeOn: aStream.
aStream space.
buttons storeOn: aStream.
aStream space.
keyValue storeOn: aStream.
+ aStream space.
+ keyCode storeOn: aStream.
!
Item was changed:
----- Method: KeyboardEvent>>type:readFrom: (in category 'initialize') -----
type: eventType readFrom: aStream
type := eventType.
timeStamp := Integer readFrom: aStream.
aStream skip: 1.
buttons := Integer readFrom: aStream.
aStream skip: 1.
+ keyValue := Integer readFrom: aStream.
+ aStream skip: 1.
+ keyCode := Integer readFrom: aStream.!
- keyValue := Integer readFrom: aStream.!
Item was added:
+ ----- Method: KeyboardEvent>>virtualKey (in category 'morphic/tools - accessing') -----
+ virtualKey
+
+ ^ self key!
Item was added:
+ ----- Method: KeyboardEvent>>virtualModifiers (in category 'morphic/tools - accessing') -----
+ virtualModifiers
+
+ ^ self modifiers!
Item was added:
+ Morph subclass: #KeyboardExerciser
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Demo'!
Item was added:
+ ----- Method: KeyboardExerciser class>>descriptionForPartsBin (in category 'parts bin') -----
+ descriptionForPartsBin
+ "KeyboardExerciser descriptionForPartsBin"
+ ^ self partName: 'Exercise Keyboard'
+ categories: #('Demo')
+ documentation: 'An exerciser for key stroke, key down, and key up'!
Item was added:
+ ----- Method: KeyboardExerciser>>checkButton: (in category 'initialization') -----
+ checkButton: checkIndex
+
+ 1 to: 3 do: [:index |
+ (self submorphs at: index)
+ state: #off].
+
+ (self submorphs at: checkIndex) state: #on.!
Item was added:
+ ----- Method: KeyboardExerciser>>clear (in category 'initialization') -----
+ clear
+
+ (self submorphs allButFirst: 3) do: [:m | m delete].!
Item was added:
+ ----- Method: KeyboardExerciser>>drawOn: (in category 'drawing') -----
+ drawOn: aCanvas
+
+ super drawOn: aCanvas.
+
+ aCanvas
+ drawString: 'Move your mouse cursor to here and start typing. Try modifiers, too.' translated
+ at: self topLeft
+ font: Preferences standardButtonFont
+ color: Color gray.!
Item was added:
+ ----- Method: KeyboardExerciser>>handleEvent:deemphasize: (in category 'actions') -----
+ handleEvent: mouseEvent deemphasize: morph
+
+ morph color: Color transparent.!
Item was added:
+ ----- Method: KeyboardExerciser>>handleEvent:emphasize: (in category 'actions') -----
+ handleEvent: mouseEvent emphasize: morph
+
+ morph color: (self userInterfaceTheme get: #selectionColor for: #PluggableListMorph).!
Item was added:
+ ----- Method: KeyboardExerciser>>handleEvent:inspect: (in category 'actions') -----
+ handleEvent: mouseEvent inspect: morph
+
+ mouseEvent shiftPressed
+ ifTrue: [(morph valueOfProperty: #event) explore]
+ ifFalse: [(morph valueOfProperty: #event) inspect].!
Item was added:
+ ----- Method: KeyboardExerciser>>handlesKeyboard: (in category 'event handling') -----
+ handlesKeyboard: evt
+
+ ^ (self valueOfProperty: #eventCheck) value: evt!
Item was added:
+ ----- Method: KeyboardExerciser>>handlesMouseOver: (in category 'event handling') -----
+ handlesMouseOver: evt
+
+ ^ true!
Item was added:
+ ----- Method: KeyboardExerciser>>initialize (in category 'initialization') -----
+ initialize
+
+ super initialize.
+
+ self
+ color: (self userInterfaceTheme get: #color for: #ScrollPane);
+ extent: 300@50;
+ layoutPolicy: TableLayout new;
+ listDirection: #leftToRight;
+ wrapDirection: #topToBottom;
+ hResizing: #rigid;
+ vResizing: #shrinkWrap;
+ cellGap: 10;
+ layoutInset: 20;
+ yourself.
+
+ #(processKeyStroke 'Test key stroke'
+ processKeyDown 'Test key down'
+ processKeyUp 'Test key up')
+ groupsDo: [:selector :label |
+ self addMorphBack: (ThreePhaseButtonMorph checkBox
+ target: self;
+ actionSelector: selector;
+ label: label;
+ yourself)].
+
+ self processKeyStroke.!
Item was added:
+ ----- Method: KeyboardExerciser>>keyDown: (in category 'event handling') -----
+ keyDown: evt
+
+ self logEvent: evt.!
Item was added:
+ ----- Method: KeyboardExerciser>>keyStroke: (in category 'event handling') -----
+ keyStroke: evt
+
+ self logEvent: evt.!
Item was added:
+ ----- Method: KeyboardExerciser>>keyUp: (in category 'event handling') -----
+ keyUp: evt
+
+ self logEvent: evt.!
Item was added:
+ ----- Method: KeyboardExerciser>>lastEvent (in category 'accessing') -----
+ lastEvent
+
+ | view event |
+ view := self submorphs last.
+ (view hasProperty: #event) ifFalse: [^ nil].
+ event := view valueOfProperty: #event.
+ event isCollection ifTrue: [event := event last].
+ ^ event!
Item was added:
+ ----- Method: KeyboardExerciser>>logEvent: (in category 'event handling') -----
+ logEvent: evt
+
+ | eventMorph |
+ evt = self lastEvent
+ ifTrue: [^ self logEventRepetition: evt].
+
+ eventMorph := evt asMorph.
+ eventMorph
+ setProperty: #event toValue: evt copy;
+ balloonText: ('Click to inspect. Shift+click to explore.\\Virtual key: {8}\Virtual modifiers: {5}\\Physical key: {9}\Physical modifiers: {6}\\Key value: 0x{1} ({2}) \Key character: {3}\Key string: {4}\\{7}' translated withCRs format: {
+ evt keyValue printPaddedWith: $0 to: 2 base: 16.
+ evt keyValue.
+ evt isKeystroke ifTrue: [evt keyCharacter printString] ifFalse: ['-'].
+ evt isKeystroke ifTrue: [evt keyString printString] ifFalse: ['-'].
+ (evt virtualModifiers joinSeparatedBy: ' ') asUppercase.
+ (evt physicalModifiers joinSeparatedBy: ' ') asUppercase.
+ evt printString.
+ evt virtualKey printString.
+ evt physicalKey asString printString}).
+
+ eventMorph
+ on: #mouseEnter send: #handleEvent:emphasize: to: self;
+ on: #mouseLeave send: #handleEvent:deemphasize: to: self;
+ on: #mouseDown send: #handleEvent:inspect: to: self.
+
+ self addMorphBack: eventMorph.!
Item was added:
+ ----- Method: KeyboardExerciser>>logEventRepetition: (in category 'event handling') -----
+ logEventRepetition: evt
+
+ | label lastEvents box |
+ (self submorphs last hasProperty: #repetition)
+ ifTrue: [box := self submorphs last. label := box submorphs first]
+ ifFalse: [
+ box := Morph new
+ setProperty: #repetition toValue: true;
+ color: Color transparent;
+ layoutPolicy: TableLayout new;
+ hResizing: #shrinkWrap;
+ vResizing:#shrinkWrap;
+ yourself.
+ label := '' asText asMorph lock.
+ box addMorph: label.
+ box setProperty: #event toValue: (OrderedCollection with: self lastEvent).
+ self addMorphBack: box].
+
+ lastEvents := box valueOfProperty: #event.
+ lastEvents add: evt copy.
+ box setProperty: #event toValue: lastEvents.
+
+ label newContents: (('x ', (lastEvents size)) asText
+ addAttribute: (TextFontReference toFont: Preferences standardButtonFont);
+ yourself).
+ box balloonText: ('{1}{2}' format: {
+ lastEvents size > 10 ifTrue: ['... {1} older events and:\' translated withCRs format: {lastEvents size - 10}] ifFalse: [''].
+ (lastEvents last: (10 min: lastEvents size)) joinSeparatedBy: String cr.
+ }).
+
+ box
+ on: #mouseEnter send: #handleEvent:emphasize: to: self;
+ on: #mouseLeave send: #handleEvent:deemphasize: to: self;
+ on: #mouseDown send: #handleEvent:inspect: to: self.!
Item was added:
+ ----- Method: KeyboardExerciser>>mouseEnter: (in category 'event handling') -----
+ mouseEnter: evt
+
+ self comeToFront.
+ evt hand newKeyboardFocus: self.!
Item was added:
+ ----- Method: KeyboardExerciser>>processKeyDown (in category 'initialization') -----
+ processKeyDown
+
+ self setProperty: #eventCheck toValue: [:evt | evt isKeyDown].
+ self checkButton: 2.
+ self clear.!
Item was added:
+ ----- Method: KeyboardExerciser>>processKeyStroke (in category 'initialization') -----
+ processKeyStroke
+
+ self setProperty: #eventCheck toValue: [:evt | evt isKeystroke].
+ self checkButton: 1.
+ self clear.!
Item was added:
+ ----- Method: KeyboardExerciser>>processKeyUp (in category 'initialization') -----
+ processKeyUp
+
+ self setProperty: #eventCheck toValue: [:evt | evt isKeyUp].
+ self checkButton: 3.
+ self clear.!
Item was added:
+ ----- Method: LayoutPolicy>>isGridLayout (in category 'testing') -----
+ isGridLayout
+
+ ^ false!
Item was added:
+ ----- Method: LayoutProperties>>asGridLayoutProperties (in category 'converting') -----
+ asGridLayoutProperties
+
+ ^ GridLayoutProperties new
+ hResizing: self hResizing;
+ vResizing: self vResizing;
+ disableLayout: self disableLayout;
+ yourself!
Item was changed:
----- Method: LayoutProperties>>asTableLayoutProperties (in category 'converting') -----
asTableLayoutProperties
+
+ ^ TableLayoutProperties new
- ^(TableLayoutProperties new)
hResizing: self hResizing;
vResizing: self vResizing;
+ disableLayout: self disableLayout;
- disableTableLayout: self disableTableLayout;
yourself!
Item was changed:
+ ----- Method: LayoutProperties>>cellGap (in category 'defaults - table layout') -----
- ----- Method: LayoutProperties>>cellGap (in category 'table defaults') -----
cellGap
"Default"
^0!
Item was changed:
+ ----- Method: LayoutProperties>>cellInset (in category 'defaults - table layout') -----
- ----- Method: LayoutProperties>>cellInset (in category 'table defaults') -----
cellInset
"Default"
^0!
Item was changed:
+ ----- Method: LayoutProperties>>cellPositioning (in category 'defaults - table layout') -----
- ----- Method: LayoutProperties>>cellPositioning (in category 'table defaults') -----
cellPositioning
^#center!
Item was changed:
+ ----- Method: LayoutProperties>>cellSpacing (in category 'defaults - table layout') -----
- ----- Method: LayoutProperties>>cellSpacing (in category 'table defaults') -----
cellSpacing
"Default"
^#none!
Item was added:
+ ----- Method: LayoutProperties>>includesGridLayoutProperties (in category 'testing') -----
+ includesGridLayoutProperties
+
+ ^ false!
Item was added:
+ ----- Method: LayoutProperties>>includesTableLayoutProperties (in category 'testing') -----
+ includesTableLayoutProperties
+
+ ^ false!
Item was removed:
- ----- Method: LayoutProperties>>includesTableProperties (in category 'testing') -----
- includesTableProperties
- ^false!
Item was changed:
----- Method: LayoutProperties>>initializeFrom: (in category 'initialize') -----
initializeFrom: defaultProvider
"Initialize the receiver from a default provider"
+
self hResizing: defaultProvider hResizing.
self vResizing: defaultProvider vResizing.
+ self disableLayout: defaultProvider disableLayout.!
- self disableTableLayout: defaultProvider disableTableLayout.!
Item was changed:
+ ----- Method: LayoutProperties>>layoutInset (in category 'defaults - table layout') -----
- ----- Method: LayoutProperties>>layoutInset (in category 'table defaults') -----
layoutInset
^0!
Item was changed:
+ ----- Method: LayoutProperties>>listCentering (in category 'defaults - table layout') -----
- ----- Method: LayoutProperties>>listCentering (in category 'table defaults') -----
listCentering
"Default"
^#topLeft!
Item was changed:
+ ----- Method: LayoutProperties>>listDirection (in category 'defaults - table layout') -----
- ----- Method: LayoutProperties>>listDirection (in category 'table defaults') -----
listDirection
"Default"
^#topToBottom!
Item was changed:
+ ----- Method: LayoutProperties>>listSpacing (in category 'defaults - table layout') -----
- ----- Method: LayoutProperties>>listSpacing (in category 'table defaults') -----
listSpacing
"Default"
^#none!
Item was changed:
+ ----- Method: LayoutProperties>>maxCellSize (in category 'defaults - table layout') -----
- ----- Method: LayoutProperties>>maxCellSize (in category 'table defaults') -----
maxCellSize
^SmallInteger maxVal!
Item was changed:
+ ----- Method: LayoutProperties>>minCellSize (in category 'defaults - table layout') -----
- ----- Method: LayoutProperties>>minCellSize (in category 'table defaults') -----
minCellSize
^0!
Item was added:
+ ----- Method: LayoutProperties>>modulus (in category 'defaults - grid layout') -----
+ modulus
+
+ ^ 8@8!
Item was added:
+ ----- Method: LayoutProperties>>origin (in category 'defaults - grid layout') -----
+ origin
+
+ ^ 0@0!
Item was added:
+ ----- Method: LayoutProperties>>printOn: (in category 'printing') -----
+ printOn: stream
+
+ self flag: #todo. "mt: Find a more readable format. Maybe with line breaks and tabs."
+ self storeOn: stream.!
Item was changed:
+ ----- Method: LayoutProperties>>reverseTableCells (in category 'defaults - table layout') -----
- ----- Method: LayoutProperties>>reverseTableCells (in category 'table defaults') -----
reverseTableCells
^false!
Item was changed:
+ ----- Method: LayoutProperties>>rubberBandCells (in category 'defaults - table layout') -----
- ----- Method: LayoutProperties>>rubberBandCells (in category 'table defaults') -----
rubberBandCells
^false!
Item was added:
+ ----- Method: LayoutProperties>>storeOn: (in category 'printing') -----
+ storeOn: stream
+
+ | defaultProperties uniquePropertiesNames |
+ defaultProperties := self class new.
+ uniquePropertiesNames := self class allInstVarNames
+ select: [:name | (self instVarNamed: name) ~= (defaultProperties instVarNamed: name)].
+ stream
+ nextPutAll: '(', self species name;
+ nextPutAll: ' new'.
+ uniquePropertiesNames
+ do: [:name |
+ stream
+ nextPutAll: ' ', name, ': ';
+ store: (self instVarNamed: name);
+ nextPut: $;].
+ stream nextPutAll: ' yourself)'.!
Item was removed:
- ----- Method: LayoutProperties>>stringWithLayout (in category 'table defaults') -----
- stringWithLayout
- | defaultValues uniqueValues |
- defaultValues := TableLayoutProperties new.
- uniqueValues := self class allInstVarNames
- select: [:title | (self instVarNamed: title)
- ~= (defaultValues instVarNamed: title)].
- ^ String
- streamContents: [:aStream |
- aStream nextPutAll: 'TableLayout new; '.
- uniqueValues
- do: [:title | aStream nextPutAll: title;
- nextPut: $:;
- space;
-
- print: (self instVarNamed: title).
- (title = uniqueValues last)
- ifTrue:[ aStream nextPut:$.]
- ifFalse:[ aStream nextPut: $;; cr]
- ]]!
Item was changed:
+ ----- Method: LayoutProperties>>wrapCentering (in category 'defaults - table layout') -----
- ----- Method: LayoutProperties>>wrapCentering (in category 'table defaults') -----
wrapCentering
^#topLeft!
Item was changed:
+ ----- Method: LayoutProperties>>wrapDirection (in category 'defaults - table layout') -----
- ----- Method: LayoutProperties>>wrapDirection (in category 'table defaults') -----
wrapDirection
^#none!
Item was changed:
----- Method: LazyListMorph>>display:atRow:on: (in category 'drawing') -----
display: item atRow: row on: canvas
"display the given item at row row"
+ | drawBounds leading emphasized rowColor itemAsText alignment |
- | drawBounds emphasized rowColor itemAsText alignment |
itemAsText := item asStringOrText.
alignment := self cellPositioning.
"If it is a text, we will only use the first character's emphasis."
+ emphasized := itemAsText isText
+ ifFalse: [ font "fast path" ]
+ ifTrue: [ "Note that a font change may interfere with the receiver's uniform item height."
+ (itemAsText
+ fontAt: 1 withDefault: font)
+ emphasized: (itemAsText emphasisAt: 1)].
- emphasized := itemAsText isText
- ifTrue: [font emphasized: (itemAsText emphasisAt: 1)]
- ifFalse: [font].
rowColor := itemAsText isText
ifTrue: [itemAsText colorAt: 1 ifNone: [self colorForRow: row]]
ifFalse: [self colorForRow: row].
drawBounds := self drawBoundsForRow: row.
alignment ~= #leftCenter ifTrue: [
| itemWidth |
itemWidth := self widthToDisplayItem: item. "includes left/right margins"
alignment == #center ifTrue: [
drawBounds := (self center x - (itemWidth / 2) floor) @ drawBounds top corner: (self center x + (itemWidth / 2) ceiling) @ drawBounds bottom].
alignment == #rightCenter ifTrue: [
drawBounds := (self right - itemWidth) @ drawBounds top corner: self right @ drawBounds bottom]].
"Draw icon if existing. Adjust draw bounds in that case."
drawBounds := drawBounds translateBy: (self cellInset left @ 0).
(self icon: row) ifNotNil: [ :icon || top |
top := drawBounds top + ((drawBounds height - self iconExtent y) // 2).
canvas translucentImage: icon at: drawBounds left @ top.
+ drawBounds := drawBounds left: drawBounds left + self iconExtent x + self cellInset left ].
- drawBounds := drawBounds left: drawBounds left + self iconExtent x + 2 ].
"We will only draw strings here."
+ leading := emphasized lineGapSliceForMorphs. "look vertically centered"
drawBounds := drawBounds translateBy: (0 @ self cellInset top).
canvas
drawString: itemAsText asString
+ in: (drawBounds origin + (0 @ leading) corner: drawBounds corner)
- in: drawBounds
font: emphasized
color: rowColor.
"Draw filter matches if any."
self
displayFilterOn: canvas
for: row
in: drawBounds
font: emphasized.!
Item was changed:
----- Method: LazyListMorph>>displayFilterOn:for:in:font: (in category 'drawing') -----
displayFilterOn: canvas for: row in: drawBounds font: font
"Draw filter matches if any."
+ | fillStyle fillHeight leading |
- | fillStyle fillHeight |
self showFilter ifFalse: [^ self].
+ fillHeight := font lineGridForMorphs.
- fillHeight := font height.
fillStyle := self filterColor isColor
ifTrue: [SolidFillStyle color: self filterColor]
ifFalse: [self filterColor].
fillStyle isGradientFill ifTrue: [
fillStyle origin: drawBounds topLeft.
fillStyle direction: 0@ fillHeight].
+ leading := font lineGapSliceForMorphs.
+
(self filterOffsets: row) do: [:offset |
| highlightRectangle |
highlightRectangle := ((drawBounds left + offset first first) @ drawBounds top
corner: (drawBounds left + offset first last) @ (drawBounds top + fillHeight)).
canvas
frameAndFillRoundRect: (highlightRectangle outsetBy: 1@0)
radius: (3 * RealEstateAgent scaleFactor) truncated
fillStyle: fillStyle
borderWidth: (1 * RealEstateAgent scaleFactor) truncated
borderColor: fillStyle asColor twiceDarker.
canvas
drawString: offset second
+ in: (highlightRectangle origin + (0 @ leading) corner: highlightRectangle corner)
- in: highlightRectangle
font: font
color: self filterTextColor].!
Item was changed:
----- Method: LazyListMorph>>icon: (in category 'list access - cached') -----
icon: row
+ "Answer a cached form from the model at a specific row. By flagging nil-icons with #none, only try to fetch an icon once from the model until next #listChanged. Also do inst-var access on listIcons here to initialize it as late as possible."
- "Do inst-var access on listIcons here to initialize it as late as possible."
self listSource canHaveIcons ifFalse: [^ nil].
listIcons ifNil: [listIcons := Array new: self getListSize].
+
+ ^ (listIcons at: row)
+ ifNotNil: [:iconOrNone | iconOrNone == #none ifFalse: [iconOrNone]]
+ ifNil: [
+ | icon |
+ icon := (self getListIcon: row) ifNotNil: [:form | form scaleIconToDisplay].
+ "Update cache for uniform icon extent."
+ iconExtent ifNil: [iconExtent := icon ifNotNil: [icon extent]].
+ listIcons at: row put: (icon ifNil: [#none]).
+ icon]!
-
- ^ (listIcons at: row) ifNil: [
- | icon |
- icon := (self getListIcon: row) ifNotNil: [:form | form scaleIconToDisplay].
- "Update cache for uniform icon extent."
- iconExtent ifNil: [iconExtent := icon ifNotNil: [icon extent]].
- listIcons at: row put: icon.
- icon]!
Item was changed:
----- Method: LazyListMorph>>iconExtent (in category 'layout') -----
iconExtent
+ "Answers the uniform icon extent for this lazy list based on sample icons from the list source."
+ | listSize |
+ iconExtent ifNil: [
+
+ self listSource canHaveIcons
+ ifFalse: [^ iconExtent := 0@0].
+
+ (listSize := self getListSize) = 0
+ ifTrue: [^ iconExtent := ((14@14) * RealEstateAgent scaleFactor) truncated].
+
+ (self icon: (2 min: listSize)) "mt: Use second item bc. first one might be visual separator w/o icon."
+ ifNil: [^ iconExtent := 0@0]
+ ifNotNil: [:form | ^ iconExtent := form extent]].
+
+ ^ iconExtent!
- ^ iconExtent ifNil: [
- self getListSize = 0
- ifTrue: [((14@14) * RealEstateAgent scaleFactor) truncated]
- ifFalse: [(self icon: 1) ifNil: [0@0] ifNotNil: [:form | form extent]]]!
Item was changed:
----- Method: LazyListMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
self color: Color black.
- self cellInset: 3@0.
font := Preferences standardListFont.
listItems := nil.
listIcons := nil.
listFilterOffsets := nil.
selectedRow := nil.
selectedRows := PluggableSet integerSet.
preSelectedRow := nil.!
Item was changed:
----- Method: LazyListMorph>>listChanged (in category 'layout') -----
listChanged
"set newList to be the list of strings to display"
listItems := nil.
listIcons := nil.
listFilterOffsets := nil.
maxWidth := nil.
+ "selectedRow := nil. --- avoid reset to keep UI stable. See PluggableListMorph >> #selectionIndex and #selectionIndex:."
- selectedRow := nil.
selectedRows := PluggableSet integerSet.
preSelectedRow := nil.
self layoutChanged.
self changed.
!
Item was changed:
----- Method: LazyListMorph>>rowHeight (in category 'layout') -----
rowHeight
+ ^ font lineGridForMorphs + self cellInset top + self cellInset bottom!
- ^ font height + self cellInset top + self cellInset bottom!
Item was changed:
----- Method: LazyListMorph>>widthToDisplayItem: (in category 'layout') -----
widthToDisplayItem: item
| labelWidth iconWidth leftMargin rightMargin |
- labelWidth := self font widthOfStringOrText: item asStringOrText.
- iconWidth := self listSource canHaveIcons ifTrue: [self iconExtent x] ifFalse: [0].
leftMargin := self cellInset left.
rightMargin := self cellInset right.
+ labelWidth := self font widthOfStringOrText: item asStringOrText.
+ iconWidth := self listSource canHaveIcons ifTrue: [self iconExtent x + leftMargin] ifFalse: [0].
^ leftMargin + iconWidth + labelWidth + rightMargin!
Item was changed:
----- Method: LeftGripMorph>>apply: (in category 'target resize') -----
apply: delta
| oldBounds |
oldBounds := self target bounds.
self target
+ bounds: (oldBounds origin + (delta x @ 0) corner: oldBounds corner).
+ self flag: #workaround. "mt: Due to a layout-specific 'let us start in the top-left corner of a layout cell'-behavior, we have to go up the owner chain and propagate the delta. See Morph >> #layoutInBounds:positioning: and there section 1.2."
+ self target allOwnersDo:
+ [:anOwner |
+ (anOwner layoutPolicy notNil and: [anOwner ~~ Project current world])
+ ifTrue: [anOwner left: anOwner left + delta x]].!
- bounds: (oldBounds origin + (delta x @ 0) corner: oldBounds corner)!
Item was added:
+ Object subclass: #LegacyShortcutsFilter
+ instanceVariableNames: ''
+ classVariableNames: 'LegacyShortcutsEnabled'
+ poolDictionaries: ''
+ category: 'Morphic-Text Support'!
+
+ !LegacyShortcutsFilter commentStamp: 'mt 12/25/2021 14:40' prior: 0!
+ I am an event filter that provides keyboard shortcuts for TextEdtior that have been deprecated due to their incompatibility for non-US keyboard layouts.
+
+ For more information, read on here:
+ http://lists.squeakfoundation.org/pipermail/squeak-dev/2021-December/217304…!
Item was added:
+ ----- Method: LegacyShortcutsFilter class>>filterEvent:for: (in category 'event filter') -----
+ filterEvent: aKeyboardEvent for: textMorph
+
+ aKeyboardEvent isKeystroke ifFalse: [^ aKeyboardEvent].
+ aKeyboardEvent commandKeyPressed ifFalse: [^ aKeyboardEvent].
+ Preferences cmdKeysInText ifFalse: [^ aKeyboardEvent].
+
+ ('()[]{}|''"<>' includes: aKeyboardEvent keyCharacter)
+ ifTrue: [textMorph
+ handleInteraction: [(textMorph editor enclose: aKeyboardEvent) ifTrue: [aKeyboardEvent ignore]]
+ fromEvent: aKeyboardEvent].
+
+ ^ aKeyboardEvent
+
+ "
+ Preferences cmdKeysInText
+ Preferences cmdGesturesEnabled
+ Preferences honorDesktopCmdKeys
+ PasteUpMorph globalCommandKeysEnabled.
+ "!
Item was added:
+ ----- Method: LegacyShortcutsFilter class>>legacyShortcutsEnabled (in category 'preferences') -----
+ legacyShortcutsEnabled
+ <preference: 'Legacy keyboard shortcuts (US/UK only)'
+ categoryList: #(Morphic keyboard editing)
+ description: 'When true, text editors will support legacy keyboard shortcuts, which were originally introduced for US/UK keyboard layouts but are incompatible to several other international layouts. Includes shortcuts to enclose open brackets with closing ones and text selections with opening and closing ones.'
+ type: #Boolean>
+
+ ^ LegacyShortcutsEnabled ifNil: [false]!
Item was added:
+ ----- Method: LegacyShortcutsFilter class>>legacyShortcutsEnabled: (in category 'preferences') -----
+ legacyShortcutsEnabled: aBoolean
+
+ LegacyShortcutsEnabled = aBoolean ifTrue: [^ self].
+ LegacyShortcutsEnabled := aBoolean.
+
+ self legacyShortcutsEnabled
+ ifTrue: [
+ TextMorphForEditView allInstancesDo: [:textMorph |
+ textMorph addKeyboardCaptureFilter: self]]
+ ifFalse: [
+ TextMorphForEditView allInstancesDo: [:textMorph |
+ textMorph removeKeyboardCaptureFilter: self]].!
Item was added:
+ ----- Method: ListItemWrapper>>asStringOrText (in category 'converting') -----
+ asStringOrText
+ "Documentation only. You can create a custom wrapper that returns text with formatting. The tree widget will then use the text attributes of the first characters and applies them to the entire label. LazyListMorph works the same way."
+
+ ^ self asString!
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].
+ [self currentWorld addMorph: self centeredNear: aPoint.
- [ActiveWorld addMorph: self centeredNear: aPoint.
self world displayWorld. "show myself"
aBlock value]
ensure: [self delete]!
Item was changed:
----- Method: MVCMenuMorph>>informUserAt:during: (in category 'invoking') -----
informUserAt: aPoint during: aBlock
"Add this menu to the Morphic world during the execution of the given block."
| title w |
Smalltalk isMorphic ifFalse: [^ self].
+
+ title := self allMorphs detect: [:ea | ea hasProperty: #titleString].
-
- title := self allMorphs detect: [ :ea | ea hasProperty: #titleString ].
title := title submorphs first.
self visible: false.
+ w := self currentWorld.
+ aBlock value: [:string|
+ self visible ifFalse: [
- w := ActiveWorld.
- aBlock value:[:string|
- self visible ifFalse:[
w addMorph: self centeredNear: aPoint.
self visible: true].
title contents: string.
self setConstrainedPosition: Sensor cursorPoint hangOut: false.
self changed.
w displayWorld "show myself"
].
self delete.
+ w displayWorld.!
- w displayWorld!
Item was removed:
- ----- Method: MVCMenuMorph>>initialize (in category 'initializing') -----
- initialize
- super initialize.
- self setProperty: #morphicLayerNumber toValue: self morphicLayerNumber
- !
Item was removed:
- ----- Method: MVCMenuMorph>>morphicLayerNumber (in category 'WiW support') -----
- morphicLayerNumber
- ^self valueOfProperty: #morphicLayerNumber ifAbsent: [10].
- !
Item was changed:
+ ----- Method: MatrixTransformMorph>>heading (in category 'rotate scale and flex') -----
- ----- Method: MatrixTransformMorph>>heading (in category 'geometry eToy') -----
heading
"Return the receiver's heading (in eToy terms)"
^ self forwardDirection + self innerAngle!
Item was added:
+ ----- Method: MatrixTransformMorph>>heading: (in category 'rotate scale and flex') -----
+ heading: newHeading
+ "Set the receiver's heading (in eToy terms)"
+ self rotateBy: ((newHeading - self forwardDirection) - self innerAngle).!
Item was changed:
+ ----- Method: MatrixTransformMorph>>setDirectionFrom: (in category 'rotate scale and flex') -----
- ----- Method: MatrixTransformMorph>>setDirectionFrom: (in category 'geometry eToy') -----
setDirectionFrom: aPoint
| delta degrees |
delta := (self transformFromWorld globalPointToLocal: aPoint) - super rotationCenter.
degrees := delta degrees + 90.0.
self forwardDirection: (degrees \\ 360) rounded.
!
Item was removed:
- ----- Method: MenuIcons class>>backIconContents (in category 'private - icons') -----
- backIconContents
- "Private - Method generated with the content of the file /home/dgd/back.png"
- ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
- RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADRElEQVRIie3WW4hVVRgH8N/e+5y56aCizpnR
- jJzUCNFqLhqEWGlQDz0mGEJBCSL1Ur1YZA9BSIZGZg9dVBoo0B5D6qGwOzVaairZiJiKZ0hs
- 1NE5c2bm7N3DmXF2zQyO5lv+YbFZa/2/77+/y9prcxNpNFnoHi3/xUU4LtYiszX5WGC/ULsW
- m69XMLgqo8UzEhtRlVpNJJb62Tc3TnCxnH7bBR65sra0nt8vkC9Ah9Ay7U5d2Z+jUrUaoRqx
- Hr/qGp9gk0cFPsB0UFfFugUsybH1N7YfS7O7UTE4/u2vgDze02ijXUrRCLFmzwtswwRhwGO3
- Wb55tcWNzQ75g7+KfNmZtqhEZoyXz2IKlutSIe+LNCnQ7A08NxRVuKHVywvXWG+lDXZ5SRs9
- A7Qd53g3pSQlG1GboTY7PKojNh/hXBFK+s0oC85XocoOrASzJ6p9+wE7c69I8K7PfKrdgBK4
- XYNWc+VMFgwGlkgU9Svo06OooOiksw7u3MPrhwySVmVAlTasAAummPzWg16oXWGdD+13fESe
- ulxSZ5I7zTJHg1tNVxIr6FNQ1KlLuw7fOkJ9dTqHDwWarBJoA7lqPlqiflJO58gGuz78cJZn
- fxya/ZQRutdQKZY1MKlifGJJzEA/A32UUs+4NDhispVcjtMRdmeU7BBag8iJM5yOmDmPYIwj
- 2pXn5MGy2LhQl3pJF0O/2CuwBXzfS0cnR7+j9/IoUSWcPnINYuhNcRN/DnXpRFUOoFFNwKYa
- wgJ1s2mYS1TuLedOceLAsIMwIsoSZEhC4oCBgD70xpzB9ktcGExr4PHhvLVqFPsaM02NeC2L
- XjKVTJtVdp7vKNfufB1bznO2RLE03lhj5P5ZqBZ3SHyFnFsyrM+SFEaabqrm6CjrY6Mf79tn
- 7cjOaDVfbA+mmRzyajUVqXpGE3g6NQ88IXZYKFISCUVioUAfetDjolOOKZbpo6HV3WK70SCL
- F2uZ0V3eOzCFd64cm8/t8/C1hDr29dSqXuwT3AfuyjIvy66etPVT9tp2YwShWRZvYu0ouydd
- MG8oVePFyOspjbxY3m4znMD9hm/90xJPOuzYmLZj4Oq/GENYZKqS1QKxPlsdNMqX4Sb+D/gb
- LOgMCUjhiw4AAAAASUVORK5CYII='!
Item was changed:
+ ----- Method: MenuIcons class>>blankIconOfWidth: (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>blankIconOfWidth: (in category 'private - icons') -----
blankIconOfWidth: aNumber
^ Icons
at: ('blankIcon-' , aNumber asString) asSymbol
+ ifAbsentPut: [Form extent: aNumber @ aNumber depth:8]!
- ifAbsentPut: [Form extent: aNumber @ 1 depth:8]!
Item was changed:
+ ----- Method: MenuIcons class>>configurationIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>configurationIcon (in category 'private - icons') -----
configurationIcon
"Private - Generated method"
^ Icons
at: #'configuration'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self configurationIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>confirmIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>confirmIcon (in category 'private - icons') -----
confirmIcon
"Private - Generated method"
^ Icons
at: #'confirm'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self confirmIconContents readStream) ].!
Item was changed:
----- Method: MenuIcons class>>decorateMenu: (in category 'menu decoration') -----
decorateMenu: aMenu
"decorate aMenu with icons"
| maxWidth |
Preferences menuWithIcons ifFalse: [^ self].
Preferences tinyDisplay ifTrue:[^ self].
maxWidth := 0.
aMenu items do: [:item |
item icon isNil ifTrue: [
| icon |
icon := self iconForMenuItem: item.
icon isNil ifFalse: [
item icon: icon.
maxWidth := maxWidth max: item icon width.
]
]
ifFalse: [
maxWidth := maxWidth max: item icon width
].
item hasSubMenu ifTrue: [
self decorateMenu: item subMenu.
].
].
maxWidth isZero ifFalse: [
+ self flag: #hacky. "mt: That manual icon scaling is not optimal..."
+ aMenu addBlankIconsIfNecessary: (self blankIconOfWidth: (
+ "Avoid duplicate scaling because the actual menu icons are already scaled at this point."
+ RealEstateAgent scaleFactor > 1.0
+ ifTrue: [RealEstateAgent defaultIconExtent x]
+ ifFalse: [maxWidth]))].
- aMenu addBlankIconsIfNecessary: (self blankIconOfWidth: maxWidth).
- ].
!
Item was removed:
- ----- Method: MenuIcons class>>forwardIconContents (in category 'private - icons') -----
- forwardIconContents
- "Private - Method generated with the content of the file /home/dgd/forward.png"
- ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
- RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAADXUlEQVRIie3WX2iVZRwH8M97znv2f1o2Fy4r
- hxMvhhCeTewmJcuEbiLLP0GECoJWEIlYUBoR3QTVhRRIXffvJupiBF4oRCZukq5Na4LhlKnT
- 6XE7c/P8ebs4O8fNlh3nVdEPHnif5/d8f9/3+33e53le/usRvyv0UknzzDXgQrmQ2IzJkt4V
- 6BT4xVJfWKa5HFgwI7J27fIOmerQmMBOnfbeGWGrChXmoVZeSlZKjzQisEyznA4s1lhFWwMd
- Z4tZIh0SNjk8vc03CZO2Yzcap32R6WLLIrYt5sgl3jvOudFiZlBki6O+vxVSsKTNK9iLurLJ
- 4PkFLKy38YE1Wp5b7uT1P+hJEakV2KDJiAGHpipMSmAIdeoT7GwlGzGaJT2pjeUK49l8Aflw
- HZtaqI57xwv22OhD33qj+2OZXYe5OFaYF/nIUTtMmB5ot0LeAbB5kSXbn9LqIRXCUksIBZOE
- Dxl2RJ8T+ktjKy2x1RpN5lh7aY/Lr+6n71qR9EvjXtLjRijnyVKt+TVOOqtNiyc84kENQnGJ
- Cef7XXLKgGtG9Ruc4u4B3Q7o1mKelxue9ennCYOv76fzMoENqmXxYiDpK6wD7y9ldVPZS3i7
- mKPe0PAQ6w/etDfwTIjh0qx0mounuXEdAUFAECMekqgkrCCsJFFReA7+/twYMkx9guVz+W7C
- +rwVIVKlWUGK/vPlSQgC5rfSuGD6fD7H6V76SvXGBPbFBJM2aCpTHhlEEQO/E+X/mhu+TO9B
- jl3lxETNyG5dTsbdb1xgK+gaY3YdFdXkagiqCWuIVxFWEYbEYhMkUUFFWEntPYWimXHOdHO2
- l5Fa3koVyQ5aaJteUYCYpAtoKFtdTYwd9zF/sGBtY3OBfOgcuSz5Wbw2zHgEXVilq7B0cUSa
- jKEdNWURZiL6MqyMCkrTVxhNFZTnZ7MrzWgeesSt0ulKETr1GFviXjUqkJAVE8rLysnIqZKT
- 0SzmR1SCfXVEIzfxV+t5e4QbEZzCY7oMTKa48+sp6TNsAetn8fi1wvY4Vssnw8Vb41c8rcuZ
- W+EzIVyNH0r99gT9Oc6XvtavZWx2XHo6+Mwu4DY/iTx6y2hO5E1HfXA76Ex/MTbh50n930RW
- /xMZM1VYxLZZK2/MQh2+kbuLWv/Hvyj+BJaPHpqZ0oo8AAAAAElFTkSuQmCC'!
Item was changed:
+ ----- Method: MenuIcons class>>fugueBroomIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>fugueBroomIcon (in category 'private - icons') -----
fugueBroomIcon
^ Icons
at: #broom
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self fugueBroomIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>fugueDocumentClockIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>fugueDocumentClockIcon (in category 'private - icons') -----
fugueDocumentClockIcon
^ Icons
at: #documentClock
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self fugueDocumentClockIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>fugueUserSilhouetteQuestionIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>fugueUserSilhouetteQuestionIcon (in category 'private - icons') -----
fugueUserSilhouetteQuestionIcon
^ Icons
at: #userSilhouetteQuestion
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self fugueUserSilhouetteQuestionIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>fullScreenIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>fullScreenIcon (in category 'private - icons') -----
fullScreenIcon
"Private - Generated method"
^ Icons
at: #'fullScreen'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self fullScreenIconContents readStream) ].!
Item was removed:
- ----- Method: MenuIcons class>>helpIconContents (in category 'private - icons') -----
- helpIconContents
- "Private - Method generated with the content of the file /home/dgd/help.png"
- ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
- RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAGoklEQVRIicWWeWxU1xWHv/fmzZvF4wF3AION
- XXuKgSAT0yZhNaRKIMIToARSkbQJIVEw2CW0FRQEIoUUNWpLSCsFlECxUKpilsqCsFjESzFl
- bGpsEG4DqUjBLRiN8W6P7Vk8753+ETCbIbSq2t8/V/e+q/vdc879HT34H0t5xH2PAbOByTfn
- UeA68CngB/r+28COzXxt0GNYARDgLBEO08tFot3ANuAdIPxIQNmEejZAriK8BDhNCCkKn13r
- 4srmSrLqrvJqE2nEo953QD19rKCFUkLXgTnA+YcBVYBzDXwT4SeGsB6T1yIma1eWEFtyXN88
- bNwzCzLRB4QBHKOXckJYNCXJEW/5aPpo68QTm9AeBNQAFJOAWGifuJMqwDrI49xvt+m+fXv3
- 2CyqlZ0VL6MMSwKLBSJRJNAEIvyUNt7Xe/ng19vx+XKUtetWZx49dqiyutbx98o8a9ctiICu
- wF+jii2/n1y7jO01S8nxJLpLn587q7epuUlERM6cOSPzJk2TnvIqCZVXSaS8SowDx6T82RfF
- 6XRKZWWl3Klfbnk35ozXwpqDKXcAFX/eoC2V+YPe6weeWcqERU/FfTZufEYkEomIiEhnZ1CK
- i0+I3e6Ro08vktIn5knFs6/I56+ukinDU6SwsFAG0sof5cfcHkeAIcTfOr9yuSvTn+eu/TK6
- XJw75rHX7lLFX3lKRETa2jrkyJFyKSo6LpmZk2Q6HnkOj8zCI9PxSGKiV5qb2wYEBoNBSU0f
- HhvscWzrB+a5X/HnufeoZ9/kceAvBZcGT16y+A2ZNjWbUCjMqVM1RKN9tLQ009p6PVqtB3tO
- 2robTurBi+fjo1esVvOfM2Y8E6upqb3vYbhcLpblrrAYhrkUcJ3Kd+eLQr6uGKuoyaXoD4t4
- yxanSH39lZt1q5OiouPy4Ye/Mz2eYdfgdj3uVHZ2dlZqqjdYV1d3X5Tlf/SL7kTiB9tf8+e5
- L/tXOJMAVAUyV1fQk5aWHktLS6ejo4tr1wIAbN26paG1tWkucHogoN/vr+vrCy3ZuHFj8N5v
- 4VAfSUkpjBo1ai7wZ0xLDoDWZ1A20mXd1Gpq2vz58zlXc562zhAOh4OOjmaVrzByIBA4Vlpa
- epdJw+EI4XCE5KRkWtuax6jSN9vAeuJkvqtKnVLAb62XtZStjQoHVq6hOGMq7/U4yG4JEYtF
- Enl4+1OAHaqq9t65eONGCwDd3d3YbHZt6keh68ARDUu2CiTOJ47nvGOwohDs6cWDhZt9UwOy
- HgJ8B1jc29vrKSsr61/84ot/ICIEAg3YdL27arkjWRFllihGlQo0dWCACABxaSMB8GJFBWw2
- 2/cHAKlAHvD2ehJYb7hVn8/H7t27CQSa6Orqpr7+Ch2dHUxMsSWYivWoqLIme3v3BQDXHJxm
- 1DZWzOMnpenAMdmZ8Lh4cciECRNkxIgRoZkzZ751R2rnAFcAeYN4ieCVKF75ZEqOaCji8y2U
- PXsOSY7vO6I7kVULx+fe11ttKCVX+brE3lwnV3ftk9R4j6xbt04Mw5Bdu3bJkCFDRNM0w+12
- 96iqagBSwgiJ3oTFXv6hGOVV8umLy2QobklISBbNZpXMrNEdD6rFwnnESbN9jEwdniKrV6+X
- 9vbOfk+1t7fLjh07ZMOGDeLz+QSQ0yRLVMuQ2HdXiFFeJe3FFXIkeYrsJl2ySBBQJGPMqIIH
- AVWgJBlNdJsuP3/3fTl4sEQuXaqXWCx2l6EbGxsFkKJpPjH2HZVQeZU0Hi6Tkqzn5QBe+T3p
- kkqc6DY9CiTcC7LcHAUo9gw2X4pqqsN/usLidLqx6S7q6xsIBnuIxQzC4QhWq87evfvxjh3H
- 2Kee5GpFNRd+9gHdl68CsI8uziidaBYtxzCMC/cC7/JYbS4Na/5EXk2jXhiJRl3Dhqay4IXv
- MSP7aRTl9taCggL8pWVsiyVgl9s3LqSLw0ordrv9x6FQ6DcDpfJeYLtuwTv5YxzOePfHXcGu
- maCQOCyVMRmZjExJxaJaaGtt4+DBT8jDzSTsXCBCMZ18rob6TNNcABx9UO3uUm0uLdU/wHNr
- bnfx7SGJg0ptcYqhOxHdoYrVoYnVroui6mJHFwVNQDGBQ8Dor2Lc++9xwxojEWitXspoVcGn
- 0ll95BJLf1FLuhjm+NezePvkdcv+S4FIT1gYjVANHAYuPkpQd6X0bC7rTXgB6FXAA6xFwYuw
- XCwswOQbirDliZ1kKl+W7d/WfY353OsMBfjWbpr7L7KM2WKyWBTCCvzqyZ387T+B/V/0L+bC
- W2tds0/6AAAAAElFTkSuQmCC'!
Item was changed:
+ ----- Method: MenuIcons class>>homeIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>homeIcon (in category 'private - icons') -----
homeIcon
"Private - Generated method"
^ Icons
at: #'home'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self homeIconContents readStream) ].!
Item was changed:
----- Method: MenuIcons class>>initializeIcons (in category 'class initialization') -----
initializeIcons
"self initialize"
+
- | methods |
Icons := IdentityDictionary new.
- methods := self class selectors
- select: [:each | '*Icon' match: each asString].
- methods
- do: [:each | Icons
- at: each
- put: (MenuIcons perform: each)].
self initializeTranslations.
!
Item was changed:
+ ----- Method: MenuIcons class>>jumpIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>jumpIcon (in category 'private - icons') -----
jumpIcon
"Private - Generated method"
^ Icons
at: #'jump'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self jumpIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>objectsIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>objectsIcon (in category 'private - icons') -----
objectsIcon
"Private - Generated method"
^ Icons
at: #'objects'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self objectsIconContents readStream) ].!
Item was removed:
- ----- Method: MenuIcons class>>openIconContents (in category 'private - icons') -----
- openIconContents
- "Private - Method generated with the content of the file /home/dgd/open.png"
- ^ 'iVBORw0KGgoAAAANSUhEUgAAABwAAAAcCAYAAAByDd+UAAAABHNCSVQICAgIfAhkiAAAABF0
- RVh0U29mdHdhcmUAU29kaXBvZGmU4xfQAAAGO0lEQVRIieWWW0wc5xXHf9/MzuwNFnNbYLFJ
- ggFjgs1l1yYhqTExdlKlbpVA7FiK08qt3SqqJSt5cCu/9MVSq0qtKiupZNLkIU2bKoG0TsCY
- RtTGhYLDGjvBxlAcQ1i8G67mzt5m+jDLxU6jKm3y1CMdndGMvu93/uc78+nA/4UdzcEM8DOQ
- Dm9j2xE3+YD4OljiSCmnEPwYWATmEtPSUmVZZmzk9hzwV0nibVWm4VQnM18FUHZncNSW4Mjd
- 5PEo0xMTdmtcHAeOH2fnMzWqSVE2j/tGqhcXgy+6XTzkycD80AaGPxxh8b9WeNjNzwvKyo4f
- e/lldF2nu6WF906fxpGcTM2xY7iys+lpb6ezsZGPWlsJh0IRBBfQqTNJvPvKhwS+lEKPC6ce
- DVXv2rmAQCcjv4yKmn0oqsrvTpzA/0kfj3znacr37qVy/36cWVnS0vx89mQg8KSm6S+Wutjj
- ySShOA1/d4Dp/6jwRx4KNZ2PT9W9gMooyDZIehxsm7h98ya/+uER8rcm84MTz4N1o+FCZWp0
- lEtNTXQ2NjIyMGBsBl4N6pCpq71E/79V+K08JmdD/GTbrnLZ4ZAAHRb7IDxJfGYZkXCEno7L
- PLbHCQt9MNMBwUGsFsgpLadi30FKKiux2O1M+P2u4Pz8LqFz1O3iGU8GE14/1+4Cnh9Ec7uo
- ydq8OT0rOwEkFYQK0Rmw5ZGceT/v177Ojic9mG12EApE5iA4BDNdsHADR4JCwcM7qXruMLml
- pUiyzJjP54yEwzUeF0VuF/VePxqADODOoNwSt66o9JEcAyYpxsamdVgTs7h64QIfdfyTnC3Z
- 2BMcse8qyCpoYQjdhrkriIUeUtITKK56mh3VzzLc38+Yz7cZnSWvn4srwFIXGxdnF/ZU7Xvc
- OIlloK6BZQMFZWXc7LnBO789Q2BkBmucg+SMVISkGhVZdqIQDMBcN6oSpuypF+g8e5aFmRmH
- 10/tCnB7JmJxfv5Q1YFqFAUDJimgB0EyY0vMxLN7D+6qKob7B2n64wd8UN/JZ7dnQTaTlJaC
- rFiMNZIaK/sdhKOUqdEx+q9cDXUHqAXChsIMAsBLuSVFijMzBSQTCJMRI1MQnQWixCWmsmXH
- LnY/9zybPG6mJ6dpfa+Nd2qbCYUk8orzYqoVY73lPob7b9HTeSl4JWC+DNGADOD1o7ldVKhm
- 68aiRz0g5FWokEEPQ2TaOKvwOESXSEhNJW9bBTtqnmXrNx7l3Jv1jPnv8OD2wliJFTC7+LR/
- kI/b2pe6A+YGUGVpuV11ON/V8neiugUk66rLNpBsqxEgMgkLAzDbBUtDrM/bxLFXTtPd1sut
- vnGQ40COB0BRVQSYjIWaZRWo87el+XkG+3wgWe52eTnem4jFgIfGiE9KYvfB79LacAkkO8h2
- QKBYLAhh9AogrQBfvUwnMNjRdH71X5TMhosYUHxBApEp0DXK936bXu91giHJgCKhqCoIlBhG
- WwEaVeW1tjPvc2d8brXVhXlN639BApLRlWarle1PfBPvhStGIkIgm0xIKyWVgmuBaCZej0Yi
- wT/88jdomrz6e4hlxWsTMN+dgLYIukbl/v10NLUa71cqufwQDt0FfLUTn65z4Grrxeipl36K
- b+BTAypMsbg2AeXzFdDmSXQ6cSSnMDoyDmJle6HKyCCCMvfYZT833C56x3y+na3179oHr90g
- dcN9JKZnGLeQEIBkbLbsyLGog1BJTE+nz9tN9pYtBIaG6Wpu5vqYqT4UFUPSvUCA017eBnLR
- +XVPe3vkF4e+z8mD36PhtTcY+cQXK+Ma5ctXoTCBHuKBwkJ0YonFzCJjAvnzCpfN6yfo9XOu
- bD21IY1r45+N09/V5bxYV2f9R0Mj47cDKGYr65wZSLJpVTWAkNB1QVJ6OoHBIbqamxmYMP15
- Lqz2funJrLqAMllIT5lNeqVF1otUs2p+oLCQnOJicktLyN66FYvNhhbVAGg7c4bfnzzJ2ZuW
- Q8N3lv70P42CrnhSHkyRn7CpekWcqhdZFD1fkaX49Xl55JaUkJWfT8tbb3Hreu/Cm1etBxej
- i3/5KmdPO5jTi9J0jzNOe3idJVpgNbEhojE1OCWfa/eZLsJSy9cy7AIy2FMAJ2gOkOZBvQVT
- 0/8ClPo3sCGCJrEAAAAASUVORK5CYII='!
Item was changed:
+ ----- Method: MenuIcons class>>paintIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>paintIcon (in category 'private - icons') -----
paintIcon
"Private - Generated method"
^ Icons
at: #'paint'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self paintIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>projectIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>projectIcon (in category 'private - icons') -----
projectIcon
"Private - Generated method"
^ Icons
at: #'project'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self projectIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>publishIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>publishIcon (in category 'private - icons') -----
publishIcon
"Private - Generated method"
^ Icons
at: #'publish'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self publishIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallBackIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallBackIcon (in category 'private - icons') -----
smallBackIcon
"Private - Generated method"
^ Icons
at: #'smallBack'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallBackIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallDoItIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallDoItIcon (in category 'private - icons') -----
smallDoItIcon
"Private - Generated method"
^ Icons
at: #'smallDoIt'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallDoItIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallExpertIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallExpertIcon (in category 'private - icons') -----
smallExpertIcon
"Private - Generated method"
^ Icons
at: #'smallExpert'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallExpertIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallExportIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallExportIcon (in category 'private - icons') -----
smallExportIcon
"Private - Generated method"
^ Icons
at: #'smallExport'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallExportIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallForwardIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallForwardIcon (in category 'private - icons') -----
smallForwardIcon
"Private - Generated method"
^ Icons
at: #'smallForward'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallForwardIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallFullScreenIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallFullScreenIcon (in category 'private - icons') -----
smallFullScreenIcon
"Private - Generated method"
^ Icons
at: #'smallFullScreen'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallFullScreenIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallInspectItIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallInspectItIcon (in category 'private - icons') -----
smallInspectItIcon
"Private - Generated method"
^ Icons
at: #'smallInspectIt'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallInspectItIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallJumpIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallJumpIcon (in category 'private - icons') -----
smallJumpIcon
"Private - Generated method"
^ Icons
at: #'smallJump'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallJumpIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallLanguageIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallLanguageIcon (in category 'private - icons') -----
smallLanguageIcon
"Private - Generated method"
^ Icons
at: #'smallLanguage'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallLanguageIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallLoadProjectIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallLoadProjectIcon (in category 'private - icons') -----
smallLoadProjectIcon
"Private - Generated method"
^ Icons
at: #'smallLoadProject'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallLoadProjectIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallNewIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallNewIcon (in category 'private - icons') -----
smallNewIcon
"Private - Generated method"
^ Icons
at: #'smallNew'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallNewIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallObjectCatalogIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallObjectCatalogIcon (in category 'private - icons') -----
smallObjectCatalogIcon
"Private - Generated method"
^ Icons
at: #'smallObjectCatalog'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallObjectCatalogIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallObjectsIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallObjectsIcon (in category 'private - icons') -----
smallObjectsIcon
"Private - Generated method"
^ Icons
at: #'smallObjects'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallObjectsIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallPaintIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallPaintIcon (in category 'private - icons') -----
smallPaintIcon
"Private - Generated method"
^ Icons
at: #'smallPaint'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallPaintIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallPublishIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallPublishIcon (in category 'private - icons') -----
smallPublishIcon
"Private - Generated method"
^ Icons
at: #'smallPublish'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallPublishIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallSelectIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallSelectIcon (in category 'private - icons') -----
smallSelectIcon
"Private - Generated method"
^ Icons
at: #'smallSelect'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallSelectIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallSqueakIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallSqueakIcon (in category 'private - icons') -----
smallSqueakIcon
"Private - Generated method"
^ Icons
at: #'smallSqueak'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallSqueakIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallUpdateIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallUpdateIcon (in category 'private - icons') -----
smallUpdateIcon
"Private - Generated method"
^ Icons
at: #'smallUpdate'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallUpdateIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>smallVolumeIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>smallVolumeIcon (in category 'private - icons') -----
smallVolumeIcon
"Private - Generated method"
^ Icons
at: #'smallVolume'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self smallVolumeIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>squeakIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>squeakIcon (in category 'private - icons') -----
squeakIcon
"Private - Generated method"
^ Icons
at: #'squeak'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self squeakIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>volumeIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>volumeIcon (in category 'private - icons') -----
volumeIcon
"Private - Generated method"
^ Icons
at: #'volume'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self volumeIconContents readStream) ].!
Item was changed:
+ ----- Method: MenuIcons class>>windowIcon (in category 'accessing - icons') -----
- ----- Method: MenuIcons class>>windowIcon (in category 'private - icons') -----
windowIcon
"Private - Generated method"
^ Icons
at: #'window'
ifAbsentPut:[ Form fromBinaryStream: (Base64MimeConverter mimeDecodeToBytes: self windowIconContents readStream) ].!
Item was changed:
----- Method: MenuItemMorph class>>applyUserInterfaceTheme (in category 'preferences') -----
applyUserInterfaceTheme
+ SubMenuMarker := self defaultSubMenuMarker scaleIconToDisplay.!
- SubMenuMarker := self defaultSubMenuMarker.!
Item was removed:
- ----- Method: MenuItemMorph>>browseAllImplementorsOfRealSelector (in category 'browse') -----
- browseAllImplementorsOfRealSelector
- SystemNavigation default browseAllImplementorsOf: self realSelector localTo: target class!
Item was changed:
----- Method: MenuItemMorph>>browseImplementationOfActionSelector (in category 'browse') -----
browseImplementationOfActionSelector
| method |
+ method := self effectiveActionTarget class lookupSelector: self effectiveActionSelector.
- method := target class lookupSelector: selector.
ToolSet browse: method methodClass selector: method selector.!
Item was changed:
----- Method: MenuItemMorph>>contents:withMarkers:inverse: (in category 'accessing') -----
contents: aString withMarkers: aBool inverse: inverse
"Set the menu item entry. If aBool is true, parse aString for embedded markers."
| markerIndex marker |
self contentString: nil. "get rid of old"
aBool ifFalse: [^super contents: aString].
self removeAllMorphs. "get rid of old markers if updating"
self hasIcon ifTrue: [ self icon: nil ].
(aString notEmpty and: [aString first = $<])
ifFalse: [^super contents: aString].
markerIndex := aString indexOf: $>.
markerIndex = 0 ifTrue: [^super contents: aString].
marker := (aString copyFrom: 1 to: markerIndex) asLowercase.
(#('<on>' '<off>' '<yes>' '<no>') includes: marker)
ifFalse: [^super contents: aString].
self contentString: aString. "remember actual string"
marker := (marker = '<on>' or: [marker = '<yes>']) ~= inverse
ifTrue: [self onImage]
ifFalse: [self offImage].
super contents: (aString copyFrom: markerIndex + 1 to: aString size).
"And set the marker"
+ marker := ImageMorph new image: marker scaleIconToDisplay.
- marker := ImageMorph new image: marker.
marker position: self left @ (self top + 2).
self addMorphFront: marker!
Item was changed:
----- Method: MenuItemMorph>>debugAction (in category 'browse') -----
debugAction
(Process
forBlock: [self doButtonAction]
+ runUntil: [:context | context selector = self effectiveActionSelector])
+ debugWithTitle: ('Debug menu action "{1}" in model "{2}"' translated format: {self contents. self target printString}).!
- runUntil: [:context | context selector = self selector])
- debugWithTitle: ('Debug menu action "{1}" in model "{2}"' format: {self contents. self target printString}).!
Item was changed:
----- Method: MenuItemMorph>>drawLabelOn: (in category 'drawing') -----
drawLabelOn: aCanvas
| stringBounds |
stringBounds := self bounds.
self hasIcon ifTrue: [
stringBounds := stringBounds left: stringBounds left + self iconForm width + 2 ].
self hasMarker ifTrue: [
stringBounds := stringBounds left: stringBounds left + self submorphBounds width + 8 ].
- stringBounds := stringBounds top: stringBounds top + stringBounds bottom - self fontToUse height // 2.
-
aCanvas
drawString: self contents
+ at: stringBounds left @ (stringBounds center y - (self fontToUse height // 2))
- in: stringBounds
font: self fontToUse
color: self colorToUse.!
Item was added:
+ ----- Method: MenuItemMorph>>effectiveActionSelector (in category 'browse') -----
+ effectiveActionSelector
+
+ ^ self selector = #perform:orSendTo:
+ ifTrue: [self arguments first]
+ ifFalse: [self selector]!
Item was added:
+ ----- Method: MenuItemMorph>>effectiveActionTarget (in category 'browse') -----
+ effectiveActionTarget
+
+ ^ (self selector = #perform:orSendTo:
+ and: [(self target respondsTo: self effectiveActionSelector) not])
+ ifTrue: [self arguments second]
+ ifFalse: [self target]!
Item was changed:
----- Method: MenuItemMorph>>icon: (in category 'accessing') -----
+ icon: aFormOrNil
+
+ icon := aFormOrNil
+ ifNotNil: [:form | form scaleIconToDisplay].
- icon: aForm
- "change the the receiver's icon"
- icon := aForm.
self height: self minHeight.
+ self width: self minWidth.!
- self width: self minWidth!
Item was changed:
----- Method: MenuItemMorph>>invokeWithEvent: (in category 'events') -----
invokeWithEvent: evt
"Perform the action associated with the given menu item."
- | w |
self isEnabled ifFalse: [^ self].
+
+ (owner notNil and: [self isStayUpItem not]) ifTrue: [
- target class == HandMorph ifTrue: [(self notObsolete) ifFalse: [^ self]].
- owner ifNotNil:[self isStayUpItem ifFalse:[
self flag: #workAround. "The tile system invokes menus straightforwardly so the menu might not be in the world."
+ self world ifNotNil: [:world |
- (w := self world) ifNotNil:[
owner deleteIfPopUp: evt.
"Repair damage before invoking the action for better feedback"
+ world displayWorldSafely]].
+
+ selector ifNil: [^ self].
+
+ Cursor normal showWhile: [
+ "show cursor in case item opens a new MVC window"
+ selector numArgs isZero
+ ifTrue: [target perform: selector]
+ ifFalse: [target perform: selector withArguments: (
+ selector numArgs = arguments size
+ ifTrue: [arguments]
+ ifFalse: [arguments copyWith: evt] )] ].!
- w displayWorldSafely]]].
- selector ifNil:[^self].
- Cursor normal showWhile: [ | selArgCount | "show cursor in case item opens a new MVC window"
- (selArgCount := selector numArgs) = 0
- ifTrue:
- [target perform: selector]
- ifFalse:
- [selArgCount = arguments size
- ifTrue: [target perform: selector withArguments: arguments]
- ifFalse: [target perform: selector withArguments: (arguments copyWith: evt)]]].!
Item was changed:
----- Method: MenuItemMorph>>minHeight (in category 'layout') -----
minHeight
| iconHeight |
iconHeight := self hasIcon
ifTrue: [self icon height + 2]
ifFalse: [0].
+ ^ self fontToUse lineGridForMorphs max: iconHeight!
- ^ self fontToUse height + 2 max: iconHeight!
Item was removed:
- ----- Method: MenuItemMorph>>notObsolete (in category 'private') -----
- notObsolete
- "Provide backward compatibility with messages being sent to the Hand. Remove this when no projects made prior to 2.9 are likely to be used. If this method is removed early, the worst that can happen is a notifier when invoking an item in an obsolete menu."
-
- (HandMorph canUnderstand: (selector)) ifTrue: [^ true]. "a modern one"
-
- self inform: 'This world menu is obsolete.
- Please dismiss the menu and open a new one.'.
- ^ false
- !
Item was removed:
- ----- Method: MenuItemMorph>>realSelector (in category 'browse') -----
- realSelector
- selector == #perform:orSendTo: ifTrue: [^arguments first].
- ^selector!
Item was changed:
----- Method: MenuItemMorph>>stringMargin (in category 'layout') -----
stringMargin
+ ^ Preferences tinyDisplay
+ ifTrue: [ 0 "Rely on other measures"]
+ ifFalse: [ ((self fontToUse widthOf: Character space) * 1.5) truncated " 100% = 6px "]
+ !
- ^Preferences tinyDisplay
- ifTrue: [ 1 ]
- ifFalse: [ 6 ]!
Item was removed:
- ----- Method: MenuItemMorph>>wantsHaloFromClick (in category 'meta actions') -----
- wantsHaloFromClick
- "Only if I'm not a lonely submenu"
- ^owner notNil and:[owner submorphs size > 1]!
Item was changed:
----- Method: MenuMorph class>>chooseFrom:lines:title: (in category 'utilities') -----
chooseFrom: aList lines: linesArray title: queryString
"Choose an item from the given list. Answer the index of the selected item."
+
| menu aBlock result |
+ aBlock := [:v | result := v].
- aBlock := [:v| result := v].
menu := self new.
menu addTitle: queryString.
+ 1 to: aList size do: [:i|
- 1 to: aList size do:[:i|
menu add: (aList at: i) asString target: aBlock selector: #value: argument: i.
(linesArray includes: i) ifTrue:[menu addLine]].
MenuIcons decorateMenu: menu.
result := 0.
+ menu
+ invokeAt: self currentHand position
+ in: self currentWorld
+ allowKeyboard: true.
+ ^ result!
- menu invokeAt: ActiveHand position in: ActiveWorld allowKeyboard: true.
- ^result!
Item was changed:
----- Method: MenuMorph class>>confirm:trueChoice:falseChoice: (in category 'utilities') -----
confirm: queryString trueChoice: trueChoice falseChoice: falseChoice
"Put up a yes/no menu with caption queryString. The actual wording for the two choices will be as provided in the trueChoice and falseChoice parameters. Answer true if the response is the true-choice, false if it's the false-choice. This is a modal question -- the user must respond one way or the other."
"MenuMorph
confirm: 'Are you hungry?'
trueChoice: 'yes, I''m famished'
falseChoice: 'no, I just ate'"
+
| menu aBlock result |
+ aBlock := [:v | result := v].
- aBlock := [:v| result := v].
menu := self new.
menu addTitle: queryString icon: MenuIcons confirmIcon.
menu add: trueChoice target: aBlock selector: #value: argument: true.
menu add: falseChoice target: aBlock selector: #value: argument: false.
MenuIcons decorateMenu: menu.
+ [menu
+ invokeAt: self currentHand position
+ in: self currentWorld
+ allowKeyboard: true.
- [menu invokeAt: ActiveHand position in: ActiveWorld allowKeyboard: true.
result == nil] whileTrue.
+ ^ result!
- ^result!
Item was changed:
----- Method: MenuMorph class>>example (in category 'example') -----
example
"MenuMorph example popUpInWorld"
| menu |
menu := MenuMorph new.
menu addTitle: 'Fruit' translated.
menu addStayUpItem.
menu add: 'apples' action: #apples.
menu add: 'oranges' action: #oranges.
menu addLine.
menu addLine. "extra lines ignored"
menu add: 'peaches' action: #peaches.
menu addLine.
menu add: 'pears' action: #pears.
menu addLine.
+ menu add: 'test' subMenu: (MenuMorph new
+ defaultTarget: #peaches;
+ add: 'foo' action: #inspect;
+ yourself) target: 42 selector: #inform: argumentList: #('hello').
+ ^ menu!
- ^ menu
- !
Item was changed:
----- Method: MenuMorph class>>inform: (in category 'utilities') -----
inform: queryString
"MenuMorph inform: 'I like Squeak'"
+
| menu |
menu := self new.
menu addTitle: queryString icon: MenuIcons confirmIcon.
+ menu add: 'OK' translated target: self selector: #yourself.
- menu add: 'OK' target: self selector: #yourself.
MenuIcons decorateMenu: menu.
+ menu
+ invokeAt: self currentHand position
+ in: self currentWorld
+ allowKeyboard: true.!
- menu invokeAt: ActiveHand position in: ActiveWorld allowKeyboard: true.!
Item was changed:
----- Method: MenuMorph>>addItem (in category 'menu') -----
addItem
| string sel |
+ string := Project uiManager request: 'Label for new item?' translated.
- string := UIManager default request: 'Label for new item?'.
string isEmpty ifTrue: [^ self].
+ sel := Project uiManager request: 'Selector?' translated.
- sel := UIManager default request: 'Selector?'.
sel isEmpty ifFalse: [sel := sel asSymbol].
self add: string action: sel.
!
Item was changed:
----- Method: MenuMorph>>addLine (in category 'construction') -----
addLine
"Append a divider line to this menu. Suppress duplicate lines."
| colorToUse |
self hasItems ifFalse: [^ self].
self lastSubmorph knownName = #line ifTrue: [^ self].
colorToUse := self userInterfaceTheme lineColor ifNil: [Color gray: 0.9].
self addMorphBack: (Morph new
color: colorToUse;
hResizing: #spaceFill;
+ height: ((self userInterfaceTheme lineWidth ifNil: [2]) * RealEstateAgent scaleFactor) truncated;
- height: (self userInterfaceTheme lineWidth ifNil: [2]);
borderStyle: (self userInterfaceTheme lineStyle ifNil: [BorderStyle inset]);
borderColor: colorToUse;
+ borderWidth: "1 *" RealEstateAgent scaleFactor truncated;
- borderWidth: 1;
name: #line; "see above"
yourself).!
Item was changed:
----- Method: MenuMorph>>addStayUpIcons (in category 'construction') -----
addStayUpIcons
| title closeBox pinBox |
title := submorphs
detect: [:ea | ea hasProperty: #titleString]
ifNone: [
"Called too soon. Will add stay-up icons when title is added."
self setProperty: #needsTitlebarWidgets toValue: true.
^ self].
closeBox := SystemWindowButton new target: self;
actionSelector: #delete;
- labelGraphic: self class closeBoxImage;
color: Color transparent;
+ setBalloonText: 'close this menu' translated;
- extent: self class closeBoxImage extent;
borderWidth: 0.
+ self class closeBoxImage scaleIconToDisplay in: [:icon |
+ closeBox labelGraphic: icon; extent: icon extent].
pinBox := SystemWindowButton new target: self;
actionSelector: #stayUp:;
arguments: {true};
- labelGraphic: self class pushPinImage;
color: Color transparent;
+ setBalloonText: 'keep this menu up' translated;
- extent: self class pushPinImage extent;
borderWidth: 0.
+ self class pushPinImage scaleIconToDisplay in: [:icon |
+ pinBox labelGraphic: icon; extent: icon extent].
- Preferences noviceMode ifTrue: [
- closeBox setBalloonText: 'close this menu'.
- pinBox setBalloonText: 'keep this menu up'].
title
addMorphFront: closeBox;
addMorphBack: pinBox.
self setProperty: #hasTitlebarWidgets toValue: true.
self removeProperty: #needsTitlebarWidgets.
self removeStayUpItems!
Item was changed:
----- Method: MenuMorph>>addTitle (in category 'menu') -----
addTitle
| string |
+ string := Project uiManager request: 'Title for this menu?' translated.
- string := UIManager default request: 'Title for this menu?'.
string isEmpty ifTrue: [^ self].
self addTitle: string.
!
Item was changed:
----- Method: MenuMorph>>balloonTextForLastItem: (in category 'construction') -----
balloonTextForLastItem: balloonText
+ submorphs last balloonText: balloonText!
- submorphs last setBalloonText: balloonText!
Item was changed:
----- Method: MenuMorph>>delete (in category 'initialization') -----
delete
"Delete the receiver."
+ self hideKeyboardHelp.
activeSubMenu ifNotNil: [activeSubMenu stayUp ifFalse: [activeSubMenu delete]].
self isFlexed ifTrue: [^ owner delete].
^ super delete!
Item was changed:
----- Method: MenuMorph>>deleteIfPopUp (in category 'control') -----
deleteIfPopUp
"Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu."
stayUp ifFalse: [self topRendererOrSelf delete].
(popUpOwner notNil and: [popUpOwner isKindOf: MenuItemMorph]) ifTrue: [
popUpOwner isSelected: false.
(popUpOwner owner isKindOf: MenuMorph)
ifTrue: [popUpOwner owner deleteIfPopUp]].
+ self hideKeyboardHelp.
!
Item was changed:
----- Method: MenuMorph>>deleteIfPopUp: (in category 'control') -----
deleteIfPopUp: evt
"Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu."
stayUp ifFalse: [self topRendererOrSelf delete].
(popUpOwner notNil) ifTrue: [
popUpOwner isSelected: false.
popUpOwner deleteIfPopUp: evt].
evt ifNotNil: [
evt hand releaseMouseFocus: self.
originalFocusHolder ifNotNil: [
+ self hideKeyboardHelp.
evt hand newKeyboardFocus: originalFocusHolder.
originalFocusHolder := nil]].!
Item was changed:
----- Method: MenuMorph>>detachSubMenu: (in category 'menu') -----
detachSubMenu: evt
| possibleTargets item subMenu index |
possibleTargets := self items select:[:any| any hasSubMenu].
possibleTargets size > 0 ifTrue:[
+ index := Project uiManager
- index := UIManager default
chooseFrom: (possibleTargets collect:[:t| t contents asString])
+ title: 'Which menu?' translated.
- title: 'Which menu?'.
index = 0 ifTrue:[^self]].
item := possibleTargets at: index.
subMenu := item subMenu.
subMenu ifNotNil: [
item subMenu: nil.
item delete.
subMenu stayUp: true.
subMenu popUpOwner: nil.
subMenu addTitle: item contents.
evt hand attachMorph: subMenu].
!
Item was removed:
- ----- Method: MenuMorph>>handlePageDownStorke: (in category 'keystroke helpers') -----
- handlePageDownStorke: evt
-
- evt keyValue = 12 ifFalse: [ ^false ].
- self moveSelectionDown: 5 event: evt.
- ^true!
Item was removed:
- ----- Method: MenuMorph>>handleUpStorke: (in category 'keystroke helpers') -----
- handleUpStorke: evt
-
- evt keyValue = 30 ifFalse: [ ^false ].
- self moveSelectionDown: -1 event: evt.
- ^true!
Item was added:
+ ----- Method: MenuMorph>>handleUpStroke: (in category 'keystroke helpers') -----
+ handleUpStroke: evt
+
+ evt keyValue = 30 ifFalse: [ ^false ].
+ self moveSelectionDown: -1 event: evt.
+ ^true!
Item was changed:
----- Method: MenuMorph>>informUserAt:during: (in category 'modal control') -----
informUserAt: aPoint during: aBlock
"Add this menu to the Morphic world during the execution of the given block."
+
+ | title world |
- | title w |
title := self allMorphs detect: [ :ea | ea hasProperty: #titleString ].
title := title submorphs first.
self visible: false.
+ world := self currentWorld.
+ aBlock value: [:string|
- w := ActiveWorld.
- aBlock value:[:string|
self visible ifFalse:[
+ world addMorph: self centeredNear: aPoint.
- w addMorph: self centeredNear: aPoint.
self visible: true].
title contents: string.
+ self setConstrainedPosition: self currentHand cursorPoint hangOut: false.
- self setConstrainedPosition: Sensor cursorPoint hangOut: false.
self changed.
+ world displayWorld "show myself"].
- w displayWorld "show myself"
- ].
self delete.
+ world displayWorld.!
- w displayWorld!
Item was changed:
----- Method: MenuMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
self setDefaultParameters.
self changeTableLayout.
self listDirection: #topToBottom.
self hResizing: #shrinkWrap.
self vResizing: #shrinkWrap.
+ self rubberBandCells: true.
+ self disableLayout: true.
+ self morphicLayerNumber: self class menuLayer.
defaultTarget := nil.
selectedItem := nil.
stayUp := false.
popUpOwner := nil.!
Item was changed:
----- Method: MenuMorph>>invokeModal: (in category 'modal control') -----
invokeModal: allowKeyboardControl
"Invoke this menu and don't return until the user has chosen a value. If the allowKeyboarControl boolean is true, permit keyboard control of the menu"
+ ^ self
+ invokeModalAt: self currentHand position
+ in: self currentWorld
+ allowKeyboard: allowKeyboardControl!
- ^ self invokeModalAt: ActiveHand position in: ActiveWorld allowKeyboard: allowKeyboardControl!
Item was changed:
----- Method: MenuMorph>>keyStrokeHandlers (in category 'keystroke helpers') -----
keyStrokeHandlers
^#(
handleCommandKeyPress:
handleCRStroke:
handleEscStroke:
handleLeftStroke:
handleRightStroke:
+ handleUpStroke:
- handleUpStorke:
handleDownStroke:
handlePageUpStroke:
handlePageDownStroke:)!
Item was removed:
- ----- Method: MenuMorph>>morphicLayerNumber (in category 'private') -----
- morphicLayerNumber
-
- "helpful for insuring some morphs always appear in front of or behind others.
- smaller numbers are in front"
- ^self valueOfProperty: #morphicLayerNumber ifAbsent: [
- stayUp ifTrue:[100] ifFalse:[10]
- ]!
Item was changed:
----- Method: MenuMorph>>moveSelectionDown:event: (in category 'keyboard control') -----
moveSelectionDown: direction event: evt
"Move the current selection up or down by one, presumably under keyboard control.
direction = +/-1"
| index |
+ index := (submorphs
+ indexOf: selectedItem
+ ifAbsent: [direction positive ifTrue: [0] ifFalse: [1]]
+ ) + direction.
- index := (submorphs indexOf: selectedItem ifAbsent: [1-direction]) + direction.
submorphs do: "Ensure finite"
[:unused | | m |
m := submorphs atWrap: index.
((m isKindOf: MenuItemMorph) and: [m isEnabled]) ifTrue:
[^ self selectItem: m event: evt].
"Keep looking for an enabled item"
index := index + direction sign].
^ self selectItem: nil event: evt!
Item was changed:
----- Method: MenuMorph>>popUpAdjacentTo:forHand:from: (in category 'control') -----
popUpAdjacentTo: rightOrLeftPoint forHand: hand from: sourceItem
"Present this menu at the given point under control of the given hand."
| tryToPlace selectedOffset rightPoint leftPoint |
hand world startSteppingSubmorphsOf: self.
popUpOwner := sourceItem.
self fullBounds.
self updateColor.
"ensure layout is current"
selectedOffset := (selectedItem
ifNil: [self items first]) position - self position.
tryToPlace := [:where :mustFit | | delta |
self position: where - selectedOffset.
+ delta := self innerBounds amountToTranslateWithin: sourceItem world visibleClearArea.
- delta := self boundsInWorld amountToTranslateWithin: sourceItem worldBounds.
(delta x = 0
or: [mustFit])
ifTrue: [delta = (0 @ 0)
ifFalse: [self position: self position + delta].
sourceItem world addMorphFront: self.
^ self]].
rightPoint := rightOrLeftPoint first + ((self layoutInset + self borderWidth) @ 0).
leftPoint := rightOrLeftPoint last + ((self layoutInset + self borderWidth - self width) @ 0).
tryToPlace
value: rightPoint value: false;
value: leftPoint value: false;
value: rightPoint value: true.!
Item was changed:
----- Method: MenuMorph>>popUpEvent:in: (in category 'control') -----
popUpEvent: evt in: aWorld
"Present this menu in response to the given event."
| aHand aPosition |
+ aHand := evt ifNotNil: [evt hand] ifNil: [self currentHand].
- aHand := evt ifNotNil: [evt hand] ifNil: [ActiveHand].
aPosition := aHand position truncated.
+ ^ self popUpAt: aPosition forHand: aHand in: aWorld!
- ^ self popUpAt: aPosition forHand: aHand in: aWorld
- !
Item was changed:
----- Method: MenuMorph>>popUpNoKeyboard (in category 'control') -----
popUpNoKeyboard
"Present this menu in the current World, *not* allowing keyboard input into the menu"
+ ^ self
+ popUpAt: self currentHand position
+ forHand: self currentHand
+ in: self currentWorld
+ allowKeyboard: false!
- ^ self popUpAt: ActiveHand position forHand: ActiveHand in: ActiveWorld allowKeyboard: false!
Item was changed:
----- Method: MenuMorph>>positionAt:relativeTo:inWorld: (in category 'private') -----
positionAt: aPoint relativeTo: aMenuItem inWorld: aWorld
"Note: items may not be laid out yet (I found them all to be at 0@0),
so we have to add up heights of items above the selected item."
| i yOffset sub delta |
self fullBounds. "force layout"
i := 0.
yOffset := 0.
[(sub := self submorphs at: (i := i + 1)) == aMenuItem]
whileFalse: [yOffset := yOffset + sub height].
self position: aPoint - (2 @ (yOffset + 8)).
"If it doesn't fit, show it to the left, not to the right of the hand."
self right > aWorld worldBounds right
ifTrue:
[self right: aPoint x + 1].
"Make sure that the menu fits in the world."
delta := self bounds amountToTranslateWithin:
+ (aWorld worldBounds withHeight: ((aWorld worldBounds height - 18) max: (self currentHand position y) + 1)).
+ delta isZero ifFalse: [self position: self position + delta].!
- (aWorld worldBounds withHeight: ((aWorld worldBounds height - 18) max: (ActiveHand position y) + 1)).
- delta = (0 @ 0) ifFalse: [self position: self position + delta]!
Item was changed:
----- Method: MenuMorph>>setDefaultParameters (in category 'initialization') -----
setDefaultParameters
"change the receiver's appareance parameters"
self
color: (self userInterfaceTheme color ifNil: [Color r: 0.9 g: 0.9 b: 0.9]);
borderStyle: (self userInterfaceTheme borderStyle ifNil: [BorderStyle simple]) copy;
borderColor: (self userInterfaceTheme borderColor ifNil: [Color gray]);
+ borderWidth: ((self userInterfaceTheme borderWidth ifNil: [1]) * RealEstateAgent scaleFactor) truncated.
- borderWidth: (self userInterfaceTheme borderWidth ifNil: [1]).
Preferences menuAppearance3d ifTrue: [self addDropShadow].
+ self layoutInset: (3 * RealEstateAgent scaleFactor) truncated.
- self layoutInset: 3.
!
Item was changed:
----- Method: MenuMorph>>showKeyboardHelp (in category 'keystroke helpers') -----
showKeyboardHelp
| help |
+
+ Preferences balloonHelpEnabled ifFalse: [^ self].
+
help := self balloonMorphClass
+ string: 'Enter text to narrow selection\down to matching items' translated withCRs
- string: 'Enter text to narrow selection\down to matching items ' withCRs
for: self
corner: #topLeft.
help popUpAt: self topCenter forHand: self activeHand!
Item was changed:
----- Method: MenuMorph>>stayUp: (in category 'accessing') -----
stayUp: aBoolean
stayUp := aBoolean.
aBoolean ifTrue: [ self removeStayUpBox ].
+ self morphicLayerNumber: (aBoolean ifTrue: [ self class windowLayer ] ifFalse: [ self class menuLayer ]).
originalFocusHolder := nil. "Not needed anymore."!
Item was changed:
----- Method: MenuMorph>>toggleStayUp: (in category 'menu') -----
toggleStayUp: evt
"Toggle my 'stayUp' flag and adjust the menu item to reflect its new state."
self items do: [:item |
item isStayUpItem ifTrue:
[self stayUp: stayUp not.
stayUp
+ ifTrue: [item contents: 'dismiss this menu' translated]
+ ifFalse: [item contents: 'keep this menu up' translated]]].
- ifTrue: [item contents: 'dismiss this menu']
- ifFalse: [item contents: 'keep this menu up']]].
evt hand releaseMouseFocus: self.
+ stayUp ifFalse: [self topRendererOrSelf delete].!
- stayUp ifFalse: [self topRendererOrSelf delete].
- !
Item was added:
+ ----- Method: Morph class>>backmostLayer (in category 'layer names') -----
+ backmostLayer
+
+ ^ 999!
Item was added:
+ ----- Method: Morph class>>balloonLayer (in category 'layer names') -----
+ balloonLayer
+ "Balloons and other tooltip-like morphs."
+
+ ^ 5!
Item was added:
+ ----- Method: Morph class>>defaultLayer (in category 'layer names') -----
+ defaultLayer
+
+ ^ 100!
Item was added:
+ ----- Method: Morph class>>dialogLayer (in category 'layer names') -----
+ dialogLayer
+ "For morphs that request user input."
+
+ ^ self progressLayer + (2 * self menuLayer) // 3
+ !
Item was changed:
----- Method: Morph class>>fromFileName: (in category 'fileIn/Out') -----
fromFileName: fullName
"Reconstitute a Morph from the file, presumed to be represent a Morph saved
via the SmartRefStream mechanism, and open it in an appropriate Morphic world"
| aFileStream morphOrList |
aFileStream := (MultiByteBinaryOrTextStream with: ((FileStream readOnlyFileNamed: fullName) binary contentsOfEntireFile)) binary reset.
morphOrList := aFileStream fileInObjectAndCode.
(morphOrList isKindOf: SqueakPage) ifTrue: [morphOrList := morphOrList contentsMorph].
Smalltalk isMorphic
+ ifTrue: [Project current world addMorphsAndModel: morphOrList]
- ifTrue: [ActiveWorld addMorphsAndModel: morphOrList]
ifFalse:
[morphOrList isMorph ifFalse: [self inform: 'Can only load a single morph
+ into an mvc project via this mechanism.' translated].
- into an mvc project via this mechanism.'].
morphOrList openInWorld]!
Item was added:
+ ----- Method: Morph class>>frontmostLayer (in category 'layer names') -----
+ frontmostLayer
+
+ ^ -999!
Item was added:
+ ----- Method: Morph class>>haloLayer (in category 'layer names') -----
+ haloLayer
+ "A morph's halo is like a meta menu with a tooltip-like information overlay."
+
+ ^ self menuLayer + self balloonLayer // 2!
Item was added:
+ ----- Method: Morph class>>menuLayer (in category 'layer names') -----
+ menuLayer
+ "Pop-up menu-like morphs."
+
+ ^ 10!
Item was added:
+ ----- Method: Morph class>>navigatorLayer (in category 'layer names') -----
+ navigatorLayer
+ "For morphs that float above all (tool) windows and provide quick access to other tools. Examples include docking bars and flaps."
+
+ ^ self progressLayer + self windowLayer // 2!
Item was changed:
----- Method: Morph class>>preferredCornerRadius (in category 'preferences') -----
preferredCornerRadius
<preference: 'Preferred Corner Radius'
categoryList: #(Morphic windows menus)
description: 'If a morph wants rounded corners, use this radius. May be overwritten in subclasses.'
type: #Number>
+ ^ ((PreferredCornerRadius ifNil: [8]) * RealEstateAgent scaleFactor) rounded!
- ^ PreferredCornerRadius ifNil: [6]!
Item was changed:
----- Method: Morph class>>preferredCornerRadius: (in category 'preferences') -----
preferredCornerRadius: anInteger
+ PreferredCornerRadius := anInteger ifNotNil: [(anInteger / RealEstateAgent scaleFactor) rounded].!
- PreferredCornerRadius := anInteger.!
Item was added:
+ ----- Method: Morph class>>progressLayer (in category 'layer names') -----
+ progressLayer
+ "For morphs that help the user understand why a certain operation has not finished yet."
+
+ ^ self windowLayer + self menuLayer // 2!
Item was changed:
----- Method: Morph class>>selectionBackground (in category 'defaults') -----
selectionBackground
"The background for selected items in lists and tree-list thingies."
^ self subduedHilites ifTrue: [
+ TranslucentColor r: 0.0 g: 0.0 b: 0.8 alpha: 0.2
- Preferences textHighlightColor
] ifFalse: [
"This is tuned so the red-foreground used for list texts stays somewhat legible."
Color r: 0.8 g:0.8 b: 0.81 alpha: 0.85
].
!
Item was added:
+ ----- Method: Morph class>>windowLayer (in category 'layer names') -----
+ windowLayer
+ "For morphs that represent windows and other tool-like containers."
+
+ ^ 100!
Item was changed:
+ ----- Method: Morph>>abandon (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>abandon (in category 'submorphs-add/remove') -----
abandon
"Like delete, but we really intend not to use this morph again. Clean up a few things."
self delete!
Item was added:
+ ----- Method: Morph>>aboutToBeDraggedViaHalo (in category 'halo notification') -----
+ aboutToBeDraggedViaHalo
+ "The receiver is about to be dragged via the halo."!
Item was added:
+ ----- Method: Morph>>aboutToBeGrownViaHalo (in category 'halo notification') -----
+ aboutToBeGrownViaHalo
+ "The receiver is about to be grown via the halo."!
Item was added:
+ ----- Method: Morph>>aboutToBeRotatedViaHalo (in category 'halo notification') -----
+ aboutToBeRotatedViaHalo
+ "The receiver is about to be rotated via the halo."!
Item was added:
+ ----- Method: Morph>>aboutToBeScaledViaHalo (in category 'halo notification') -----
+ aboutToBeScaledViaHalo
+ "The receiver is about to be scaled via the halo."!
Item was changed:
+ ----- Method: Morph>>actWhen (in category 'submorphs - misc') -----
- ----- Method: Morph>>actWhen (in category 'submorphs-add/remove') -----
actWhen
"Answer when the receiver, probably being used as a button, should have its action triggered"
^ self valueOfProperty: #actWhen ifAbsentPut: [#buttonDown]!
Item was changed:
+ ----- Method: Morph>>actWhen: (in category 'submorphs - misc') -----
- ----- Method: Morph>>actWhen: (in category 'submorphs-add/remove') -----
actWhen: aButtonPhase
"Set the receiver's actWhen trait"
self setProperty: #actWhen toValue: aButtonPhase!
Item was changed:
----- Method: Morph>>activeHand (in category 'structure') -----
activeHand
+
+ self flag: #deprecated. "mt: Use #currentHand instead."
+ ^ self currentHand!
-
- ^ ActiveHand ifNil: [
- self isInWorld
- ifTrue: [self world activeHand]
- ifFalse: [nil]]!
Item was changed:
+ ----- Method: Morph>>addAllMorphs: (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>addAllMorphs: (in category 'submorphs-add/remove') -----
addAllMorphs: aCollection
^self addAllMorphsBack: aCollection!
Item was changed:
+ ----- Method: Morph>>addAllMorphs:after: (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>addAllMorphs:after: (in category 'submorphs-add/remove') -----
addAllMorphs: aCollection after: anotherMorph
^self addAllMorphs: aCollection behind: anotherMorph!
Item was changed:
+ ----- Method: Morph>>addAllMorphs:behind: (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>addAllMorphs:behind: (in category 'submorphs-add/remove') -----
addAllMorphs: aCollection behind: anotherMorph
^self privateAddAllMorphs: aCollection
atIndex: (submorphs indexOf: anotherMorph) + 1!
Item was changed:
+ ----- Method: Morph>>addAllMorphs:inFrontOf: (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>addAllMorphs:inFrontOf: (in category 'submorphs-add/remove') -----
addAllMorphs: aCollection inFrontOf: anotherMorph
^self privateAddAllMorphs: aCollection
atIndex: ((submorphs indexOf: anotherMorph) max: 1)!
Item was changed:
+ ----- Method: Morph>>addAllMorphsBack: (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>addAllMorphsBack: (in category 'submorphs-add/remove') -----
addAllMorphsBack: aCollection
^self privateAddAllMorphs: aCollection atIndex: submorphs size + 1!
Item was added:
+ ----- Method: Morph>>addAllMorphsBackInLayers: (in category 'submorphs - layers') -----
+ addAllMorphsBackInLayers: morphs
+
+ morphs do: [:morph | self addMorphBackInLayer: morph].!
Item was changed:
+ ----- Method: Morph>>addAllMorphsFront: (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>addAllMorphsFront: (in category 'submorphs-add/remove') -----
addAllMorphsFront: aCollection
^self privateAddAllMorphs: aCollection atIndex: 1!
Item was added:
+ ----- Method: Morph>>addAllMorphsFrontInLayers: (in category 'submorphs - layers') -----
+ addAllMorphsFrontInLayers: morphs
+
+ morphs reverseDo: [:morph | self addMorphFrontInLayer: morph].!
Item was added:
+ ----- Method: Morph>>addAllMorphsInLayers: (in category 'submorphs - layers') -----
+ addAllMorphsInLayers: morphs
+
+ ^self addAllMorphsBackInLayers: morphs!
Item was removed:
- ----- Method: Morph>>addHalo:from: (in category 'halos and balloon help') -----
- addHalo: evt from: formerHaloOwner
- "Transfer a halo from the former halo owner to the receiver"
- ^self addHalo: evt!
Item was changed:
----- Method: Morph>>addMiscExtrasTo: (in category 'menus') -----
addMiscExtrasTo: aMenu
"Add a submenu of miscellaneous extra items to the menu."
| realOwner realMorph subMenu |
subMenu := MenuMorph new defaultTarget: self.
(self isWorldMorph not and: [(self renderedMorph isSystemWindow) not])
ifTrue: [subMenu add: 'put in a window' translated action: #embedInWindow].
+
-
self isWorldMorph ifFalse:
[subMenu add: 'adhere to edge...' translated action: #adhereToEdge.
subMenu addLine].
+
-
realOwner := (realMorph := self topRendererOrSelf) owner.
(realOwner isKindOf: TextPlusPasteUpMorph) ifTrue:
[subMenu add: 'GeeMail stuff...' translated subMenu: (realOwner textPlusMenuFor: realMorph)].
+
-
subMenu
add: 'add mouse up action' translated action: #addMouseUpAction;
add: 'remove mouse up action' translated action: #removeMouseUpAction;
add: 'hand me tiles to fire this button' translated action: #handMeTilesToFire.
subMenu addLine.
subMenu add: 'arrowheads on pen trails...' translated action: #setArrowheads.
subMenu addLine.
+
-
subMenu defaultTarget: self topRendererOrSelf.
subMenu add: 'draw new path' translated action: #definePath.
subMenu add: 'follow existing path' translated action: #followPath.
subMenu add: 'delete existing path' translated action: #deletePath.
subMenu addLine.
+
+ self addGestureMenuItems: subMenu hand: self currentHand.
+
-
- self addGestureMenuItems: subMenu hand: ActiveHand.
-
aMenu add: 'extras...' translated subMenu: subMenu!
Item was changed:
+ ----- Method: Morph>>addMorph: (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>addMorph: (in category 'submorphs-add/remove') -----
addMorph: aMorph
self addMorphFront: aMorph.!
Item was changed:
+ ----- Method: Morph>>addMorph:after: (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>addMorph:after: (in category 'submorphs-add/remove') -----
addMorph: newMorph after: aMorph
^self addMorph: newMorph behind: aMorph!
Item was changed:
+ ----- Method: Morph>>addMorph:asElementNumber: (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>addMorph:asElementNumber: (in category 'submorphs-add/remove') -----
addMorph: aMorph asElementNumber: aNumber
- "Add the given morph so that it becomes the aNumber'th element of my submorph list. If aMorph is already one of my submorphs, reposition it"
+ self flag: #deprecated.
+ ^ self addMorph: aMorph atIndex: aNumber!
- (submorphs includes: aMorph) ifTrue:
- [aMorph privateDelete].
- (aNumber <= submorphs size)
- ifTrue:
- [self addMorph: aMorph inFrontOf: (submorphs at: aNumber)]
- ifFalse:
- [self addMorphBack: aMorph]
- !
Item was added:
+ ----- Method: Morph>>addMorph:atIndex: (in category 'submorphs - add/remove') -----
+ addMorph: aMorph atIndex: aNumber
+ "Add the given morph so that it becomes the aNumber'th element of my submorph list. If aMorph is already one of my submorphs, reposition it."
+
+ (submorphs includes: aMorph) ifTrue:
+ [aMorph privateDelete].
+ (aNumber <= submorphs size)
+ ifTrue:
+ [self addMorph: aMorph inFrontOf: (submorphs at: aNumber)]
+ ifFalse:
+ [self addMorphBack: aMorph].!
Item was changed:
+ ----- Method: Morph>>addMorph:behind: (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>addMorph:behind: (in category 'submorphs-add/remove') -----
addMorph: newMorph behind: aMorph
"Add a morph to the list of submorphs behind the specified morph"
^self privateAddMorph: newMorph atIndex: (submorphs indexOf: aMorph) + 1.
!
Item was changed:
+ ----- Method: Morph>>addMorph:fullFrame: (in category 'submorphs - misc') -----
- ----- Method: Morph>>addMorph:fullFrame: (in category 'submorphs-add/remove') -----
addMorph: aMorph fullFrame: aLayoutFrame
aMorph layoutFrame: aLayoutFrame.
aMorph hResizing: #spaceFill; vResizing: #spaceFill.
self addMorph: aMorph.
!
Item was changed:
+ ----- Method: Morph>>addMorph:inFrontOf: (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>addMorph:inFrontOf: (in category 'submorphs-add/remove') -----
addMorph: newMorph inFrontOf: aMorph
"Add a morph to the list of submorphs in front of the specified morph"
^self privateAddMorph: newMorph atIndex: ((submorphs indexOf: aMorph) max: 1).!
Item was changed:
+ ----- Method: Morph>>addMorphBack: (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>addMorphBack: (in category 'submorphs-add/remove') -----
addMorphBack: aMorph
^self privateAddMorph: aMorph atIndex: submorphs size+1!
Item was added:
+ ----- Method: Morph>>addMorphBackInLayer: (in category 'submorphs - layers') -----
+ addMorphBackInLayer: aMorph
+ "Note that we do not use #addMorph:, #addMorphBack:, #addMorphFront:, or any non-layer derivatives so that subclasses can safely overwrite those protocols and delegate to here."
+
+ | targetLayer layerHere |
+ targetLayer := aMorph morphicLayerNumber.
+
+ submorphs "frontmost to backmost" withIndexDo: [ :each :index |
+ layerHere := each morphicLayerNumber.
+ "An indirect match (<) indicates the back of the target layer."
+ targetLayer < layerHere ifTrue: [
+ ^ self privateAddMorph: aMorph atIndex: index]].
+
+ ^ self privateAddMorph: aMorph atIndex: submorphs size + 1
+ !
Item was changed:
+ ----- Method: Morph>>addMorphCentered: (in category 'submorphs - misc') -----
- ----- Method: Morph>>addMorphCentered: (in category 'submorphs-add/remove') -----
addMorphCentered: aMorph
aMorph position: bounds center - (aMorph extent // 2).
self addMorphFront: aMorph.
!
Item was changed:
+ ----- Method: Morph>>addMorphFront: (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>addMorphFront: (in category 'submorphs-add/remove') -----
addMorphFront: aMorph
^self privateAddMorph: aMorph atIndex: 1!
Item was changed:
+ ----- Method: Morph>>addMorphFront:fromWorldPosition: (in category 'submorphs - misc') -----
- ----- Method: Morph>>addMorphFront:fromWorldPosition: (in category 'submorphs-add/remove') -----
addMorphFront: aMorph fromWorldPosition: wp
self addMorphFront: aMorph.
aMorph position: (self transformFromWorld globalPointToLocal: wp)!
Item was changed:
+ ----- Method: Morph>>addMorphFrontFromWorldPosition: (in category 'submorphs - misc') -----
- ----- Method: Morph>>addMorphFrontFromWorldPosition: (in category 'submorphs-add/remove') -----
addMorphFrontFromWorldPosition: aMorph
^self addMorphFront: aMorph fromWorldPosition: aMorph positionInWorld.!
Item was added:
+ ----- Method: Morph>>addMorphFrontInLayer: (in category 'submorphs - layers') -----
+ addMorphFrontInLayer: aMorph
+ "Note that we do not use #addMorph:, #addMorphBack:, #addMorphFront:, or any non-layer derivatives so that subclasses can safely overwrite those protocols and delegate to here."
+
+ | targetLayer layerHere |
+ targetLayer := aMorph morphicLayerNumber.
+
+ submorphs "frontmost to backmost" withIndexDo: [:each :index |
+ layerHere := each morphicLayerNumber.
+ "A direct match (=) indicates the front of the target layer."
+ targetLayer <= layerHere ifTrue: [
+ ^ self privateAddMorph: aMorph atIndex: index]].
+
+ ^ self privateAddMorph: aMorph atIndex: submorphs size + 1!
Item was removed:
- ----- Method: Morph>>addMorphInFrontOfLayer: (in category 'WiW support') -----
- addMorphInFrontOfLayer: aMorph
-
- | targetLayer |
-
- targetLayer := aMorph morphicLayerNumberWithin: self.
- submorphs do: [ :each | | layerHere |
- each == aMorph ifTrue: [^self].
- layerHere := each morphicLayerNumberWithin: self.
- "the <= is the difference - it insures we go to the front of our layer"
- targetLayer <= layerHere ifTrue: [
- ^self addMorph: aMorph inFrontOf: each
- ].
- ].
- self addMorphBack: aMorph.
- !
Item was changed:
+ ----- Method: Morph>>addMorphInLayer: (in category 'submorphs - layers') -----
- ----- Method: Morph>>addMorphInLayer: (in category 'WiW support') -----
addMorphInLayer: aMorph
+ ^ self addMorphBackInLayer: aMorph!
- submorphs do: [ :each |
- each == aMorph ifTrue: [^self].
- aMorph morphicLayerNumber < each morphicLayerNumber ifTrue: [
- ^self addMorph: aMorph inFrontOf: each
- ].
- ].
- self addMorphBack: aMorph
- !
Item was changed:
+ ----- Method: Morph>>addMorphNearBack: (in category 'submorphs - misc') -----
- ----- Method: Morph>>addMorphNearBack: (in category 'submorphs-add/remove') -----
addMorphNearBack: aMorph
| bg |
(submorphs notEmpty and: [submorphs last mustBeBackmost])
ifTrue:
[bg := submorphs last.
bg privateDelete].
self addMorphBack: aMorph.
bg ifNotNil: [self addMorphBack: bg]!
Item was changed:
----- Method: Morph>>addYellowButtonMenuItemsTo:event: (in category 'menu') -----
addYellowButtonMenuItemsTo: aMenu event: evt
"Populate aMenu with appropriate menu items for a
yellow-button (context menu) click."
aMenu defaultTarget: self.
""
Preferences noviceMode
ifFalse: [aMenu addStayUpItem].
""
self addModelYellowButtonItemsTo: aMenu event: evt.
""
Preferences generalizedYellowButtonMenu
ifFalse: [^ self].
""
aMenu addLine.
aMenu add: 'inspect' translated action: #inspect.
""
aMenu addLine.
self world selectedObject == self
ifTrue: [aMenu add: 'deselect' translated action: #removeHalo]
ifFalse: [aMenu add: 'select' translated action: #addHalo].
""
(self isWorldMorph
or: [self mustBeBackmost
or: [self wantsToBeTopmost]])
ifFalse: [""
aMenu addLine.
aMenu add: 'send to back' translated action: #goBehind.
aMenu add: 'bring to front' translated action: #comeToFront.
self addEmbeddingMenuItemsTo: aMenu hand: evt hand].
""
self isWorldMorph
ifFalse: [""
Smalltalk
at: #NCAAConnectorMorph
ifPresent: [:connectorClass |
aMenu addLine.
aMenu add: 'connect to' translated action: #startWiring.
aMenu addLine].
""
self isFullOnScreen
ifFalse: [aMenu add: 'move onscreen' translated action: #goHome]].
""
Preferences noviceMode
ifFalse: [""
self addLayoutMenuItems: aMenu hand: evt hand.
(owner notNil
and: [owner isTextMorph])
ifTrue: [self addTextAnchorMenuItems: aMenu hand: evt hand]].
""
self isWorldMorph
ifFalse: [""
aMenu addLine.
self addToggleItemsToHaloMenu: aMenu].
""
aMenu addLine.
self isWorldMorph
ifFalse: [aMenu add: 'copy to paste buffer' translated action: #copyToPasteBuffer:].
+ self hasStrings ifTrue: [
+ aMenu add: 'copy text' translated action: #clipText].
- (self allStringsAfter: nil) isEmpty
- ifFalse: [aMenu add: 'copy text' translated action: #clipText].
""
self addExportMenuItems: aMenu hand: evt hand.
""
(Preferences noviceMode not
and: [self isWorldMorph not])
ifTrue: [""
aMenu addLine.
aMenu add: 'adhere to edge...' translated action: #adhereToEdge].
""
self addCustomMenuItems: aMenu hand: evt hand!
Item was changed:
----- Method: Morph>>adjustLayoutBounds (in category 'layout') -----
adjustLayoutBounds
"Adjust the receivers bounds depending on the resizing strategy imposed"
| hFit vFit box sbox myExtent myOrigin myBox |
hFit := self hResizing.
vFit := self vResizing.
(hFit == #shrinkWrap or:[vFit == #shrinkWrap]) ifFalse:[^self]. "not needed"
(self cellSpacing == #none and: [self listSpacing == #none]) ifFalse: [
self flag: #todo. "mt: Find a way to make cell sizes accessible from here."
+ self cellSpacing: #none; listSpacing: #none.
self notify: 'It is not possible to shrink-wrap around submorphs when the layout policy reserves extra cell space. At this point, we have no access to that extra cell space and we do not know whether the submorph did make use of that extra space. So, shrink-wrapping could make the bounds very unstable.\\Please either reset #cellSpacing and #listSpacing - or change the resizing strategy to #rigid or #spaceFill.' withCRs.
^ self].
box := self layoutBounds.
sbox := self submorphBoundsForShrinkWrap outsetBy: self cellInset.
myExtent := box extent.
myOrigin := box origin.
hFit == #shrinkWrap ifTrue:[
myExtent := sbox extent x @ myExtent y.
myOrigin := sbox origin x @ myOrigin y].
vFit == #shrinkWrap ifTrue:[
myExtent := myExtent x @ sbox extent y.
myOrigin := myOrigin x @ sbox origin y].
"Make sure we don't get smaller than minWidth/minHeight"
myExtent x < self minWidth ifTrue:[
myExtent := (myExtent x max:
(self minWidth - self bounds width + self layoutBounds width)) @ myExtent y].
myExtent y < self minHeight ifTrue:[
myExtent := myExtent x @ (myExtent y max:
(self minHeight - self bounds height + self layoutBounds height))].
myBox := myOrigin extent: myExtent.
self setLayoutBoundsFromLayout: myBox.!
Item was changed:
+ ----- Method: Morph>>allKnownNames (in category 'submorphs - accessing') -----
- ----- Method: Morph>>allKnownNames (in category 'submorphs-accessing') -----
allKnownNames
"Return a list of all known names based on the scope of the receiver. Does not include the name of the receiver itself. Items in parts bins are excluded. Reimplementors (q.v.) can extend the list"
^ Array streamContents:
[:s | self allSubmorphNamesDo: [:n | s nextPut: n]]
!
Item was changed:
+ ----- Method: Morph>>allMorphs (in category 'submorphs - accessing') -----
- ----- Method: Morph>>allMorphs (in category 'submorphs-accessing') -----
allMorphs
"Return a collection containing all morphs in this composite morph (including the receiver)."
| all |
all := OrderedCollection new: 100.
self allMorphsDo: [: m | all add: m].
^ all!
Item was added:
+ ----- Method: Morph>>allMorphsBreadthFirstDo: (in category 'submorphs - enumerating') -----
+ allMorphsBreadthFirstDo: aBlock
+
+ self
+ allMorphsBreadthFirstDo: aBlock
+ sorted: nil.!
Item was added:
+ ----- Method: Morph>>allMorphsBreadthFirstDo:sorted: (in category 'submorphs - enumerating') -----
+ allMorphsBreadthFirstDo: aBlock sorted: aSortBlockOrNil
+
+ | remaining |
+ remaining := OrderedCollection with: self.
+ [remaining notEmpty] whileTrue: [
+ | next |
+ next := remaining removeFirst.
+ aBlock value: next.
+ remaining addAll: (aSortBlockOrNil
+ ifNil: [next submorphs "Avoid extra copy. See #sorted:."]
+ ifNotNil: [next submorphs sorted: aSortBlockOrNil])].!
Item was added:
+ ----- Method: Morph>>allMorphsDepthFirstDo: (in category 'submorphs - enumerating') -----
+ allMorphsDepthFirstDo: aBlock
+ "Evaluate the given block for all morphs in this composite morph (including the receiver)."
+
+ submorphs do: [:m | m allMorphsDepthFirstDo: aBlock].
+ aBlock value: self!
Item was changed:
+ ----- Method: Morph>>allMorphsDo: (in category 'submorphs - enumerating') -----
- ----- Method: Morph>>allMorphsDo: (in category 'submorphs-accessing') -----
allMorphsDo: aBlock
"Evaluate the given block for all morphs in this composite morph (including the receiver)."
+ self allMorphsDepthFirstDo: aBlock.!
- submorphs do: [:m | m allMorphsDo: aBlock].
- aBlock value: self!
Item was changed:
+ ----- Method: Morph>>allMorphsWithPlayersDo: (in category 'submorphs - misc') -----
- ----- Method: Morph>>allMorphsWithPlayersDo: (in category 'submorphs-add/remove') -----
allMorphsWithPlayersDo: aTwoArgumentBlock
"Evaluate the given block for all morphs in this composite morph that have non-nil players.
Also evaluate the block for the receiver if it has a player."
submorphs do: [:m | m allMorphsWithPlayersDo: aTwoArgumentBlock ].
self playerRepresented ifNotNil: [ :p | aTwoArgumentBlock value: self value: p ].
!
Item was changed:
+ ----- Method: Morph>>allNonSubmorphMorphs (in category 'submorphs - misc') -----
- ----- Method: Morph>>allNonSubmorphMorphs (in category 'submorphs-accessing') -----
allNonSubmorphMorphs
"Return a collection containing all morphs in this morph which are not currently in the submorph containment hierarchy (put in primarily for bookmorphs)"
^ OrderedCollection new!
Item was changed:
----- Method: Morph>>allStringsAfter: (in category 'debug and other') -----
+ allStringsAfter: submorph
- allStringsAfter: aSubmorph
- "return an OrderedCollection of strings of text in my submorphs. If aSubmorph is non-nil, begin with that container."
+ ^ OrderedCollection streamContents: [:stream |
+ self allStringsAfter: submorph do: [:string |
+ stream nextPut: string]]!
- | list ok |
- list := OrderedCollection new.
- ok := aSubmorph isNil.
- self allMorphsDo:
- [:sub | | string |
- ok ifFalse: [ok := sub == aSubmorph]. "and do this one too"
- ok
- ifTrue:
- [(string := sub userString) ifNotNil:
- [string isString ifTrue: [list add: string] ifFalse: [list addAll: string]]]].
- ^list!
Item was added:
+ ----- Method: Morph>>allStringsAfter:do: (in category 'debug and other') -----
+ allStringsAfter: submorph do: aBlock
+ "Evaluate aBlock for each text in any of my submorphs. If the specified submorph is non-nil, begin with that container."
+
+ | ok |
+ ok := submorph isNil.
+ self allMorphsDo: [:sub | | string |
+ ok ifFalse: [ok := sub == submorph].
+ "and do this one too"
+ ok ifTrue: [
+ (string := sub userString)
+ ifNotNil: [string isString
+ ifTrue: [aBlock value: string]
+ ifFalse: [string do: aBlock]]]].!
Item was changed:
+ ----- Method: Morph>>allSubmorphNamesDo: (in category 'submorphs - enumerating') -----
- ----- Method: Morph>>allSubmorphNamesDo: (in category 'submorphs-accessing') -----
allSubmorphNamesDo: nameBlock
"Return a list of all known names of submorphs and nested submorphs of the receiver, based on the scope of the receiver. Items in parts bins are excluded"
self isPartsBin ifTrue: [^ self]. "Don't report names from parts bins"
self submorphsDo:
[:m | m knownName ifNotNil: [:n | nameBlock value: n].
m allSubmorphNamesDo: nameBlock].
!
Item was removed:
- ----- Method: Morph>>asDraggableMorph (in category 'converting') -----
- asDraggableMorph
- "Huge or complex morphs have a serious impact on performance while being dragged. Use the thumbnail version."
-
- ^ self thumbnail asMorph!
Item was added:
+ ----- Method: Morph>>asTextAnchor (in category 'text-anchor') -----
+ asTextAnchor
+ "Convert the receiver to be embedded in text."
+
+ ^ TextAnchor new anchoredMorph: self!
Item was added:
+ ----- Method: Morph>>assureFlexShell (in category 'rotate scale and flex') -----
+ assureFlexShell
+ "Canonical assure message when working with flex shells."
+
+ ^ self addFlexShellIfNecessary!
Item was added:
+ ----- Method: Morph>>assureGridLayoutProperties (in category 'layout properties') -----
+ assureGridLayoutProperties
+
+ | assuredProperties |
+ self layoutProperties
+ ifNil: [
+ self layoutProperties: (assuredProperties := GridLayoutProperties new initializeFrom: self)]
+ ifNotNil: [:existingProperties |
+ existingProperties includesGridLayoutProperties
+ ifTrue: [assuredProperties := existingProperties]
+ ifFalse: [self layoutProperties: (assuredProperties := existingProperties asGridLayoutProperties)]].
+ ^ assuredProperties!
Item was changed:
+ ----- Method: Morph>>assureLayoutProperties (in category 'layout properties') -----
- ----- Method: Morph>>assureLayoutProperties (in category 'layout-properties') -----
assureLayoutProperties
| props |
props := self layoutProperties.
props == self ifTrue:[props := nil].
props ifNil:[
props := LayoutProperties new initializeFrom: self.
self layoutProperties: props].
^props!
Item was added:
+ ----- Method: Morph>>assureTableLayoutProperties (in category 'layout properties') -----
+ assureTableLayoutProperties
+
+ | assuredProperties |
+ self layoutProperties
+ ifNil: [
+ self layoutProperties: (assuredProperties := TableLayoutProperties new initializeFrom: self)]
+ ifNotNil: [:existingProperties |
+ existingProperties includesTableLayoutProperties
+ ifTrue: [assuredProperties := existingProperties]
+ ifFalse: [self layoutProperties: (assuredProperties := existingProperties asTableLayoutProperties)]].
+ ^ assuredProperties!
Item was removed:
- ----- Method: Morph>>assureTableProperties (in category 'layout-properties') -----
- assureTableProperties
- | props |
- props := self layoutProperties.
- props == self ifTrue:[props := nil].
- props ifNil:[
- props := TableLayoutProperties new initializeFrom: self.
- self layoutProperties: props].
- props includesTableProperties
- ifFalse:[self layoutProperties: (props := props asTableLayoutProperties)].
- ^props!
Item was changed:
----- Method: Morph>>balloonHelpTextForHandle: (in category 'halos and balloon help') -----
balloonHelpTextForHandle: aHandle
"Answer a string providing balloon help for the
given halo handle"
| itsSelector |
itsSelector := aHandle eventHandler firstMouseSelector.
itsSelector == #doRecolor:with:
ifTrue: [^ Preferences propertySheetFromHalo
ifTrue: ['Open a property sheet.']
ifFalse: ['Change color']].
itsSelector == #mouseDownInDimissHandle:with:
ifTrue: [^ TrashCanMorph preserveTrash
ifTrue: ['Move to trash']
ifFalse: ['Remove from screen']].
+ #(#(#addFullHandles 'More halo handles') #(#addSimpleHandles 'Fewer halo handles') #(#chooseEmphasisOrAlignment 'Emphasis & alignment') #(#chooseFont 'Change font') #(#chooseNewGraphicFromHalo 'Choose a new graphic') #(#chooseStyle 'Change style') #(#dismiss 'Remove') #(#doDebug:with: 'Debug') #(#doDirection:with: 'Choose forward direction') #(#doDup:with: 'Duplicate') #(#doMakeSibling:with: 'Make a sibling') #(#doMenu:with: 'Menu') #(#doGrab:with: 'Pick up') #(#editButtonsScript 'See the script for this button') #(#editDrawing 'Repaint') #(#doDupOrMakeSibling:with: 'Duplicate (press shift to make a sibling)') #(#doMakeSiblingOrDup:with: 'Make a sibling (press shift to make simple duplicate)') #(#makeNascentScript 'Make a scratch script') #(#makeNewDrawingWithin 'Paint new object') #(#mouseDownInCollapseHandle:with: 'Collapse') #(#mouseDownOnHelpHandle: 'Help') #(#openViewerForArgument 'Open a Viewer for me. Press shift for a snapshot.') #(#openViewerForTarget:with: 'Open a Viewer
for me. Press shift for a snapshot.') #(#paintBackground 'Paint background') #(#prepareToTrackCenterOfRotation:with: 'Move object or set center of rotation') #(#presentViewMenu 'Present the Viewing menu') #(#startDrag:with: 'Move') #(#startGrow:with: 'Change size (Ctrl + drag blue button)') #(#startRot:with: 'Rotate') #(#startScale:with: 'Change scale') #(#tearOffTile 'Make a tile representing this object') #(#tearOffTileForTarget:with: 'Make a tile representing this object') #(#trackCenterOfRotation:with: 'Set center of rotation') )
- #(#(#addFullHandles 'More halo handles') #(#addSimpleHandles 'Fewer halo handles') #(#chooseEmphasisOrAlignment 'Emphasis & alignment') #(#chooseFont 'Change font') #(#chooseNewGraphicFromHalo 'Choose a new graphic') #(#chooseStyle 'Change style') #(#dismiss 'Remove') #(#doDebug:with: 'Debug') #(#doDirection:with: 'Choose forward direction') #(#doDup:with: 'Duplicate') #(#doMakeSibling:with: 'Make a sibling') #(#doMenu:with: 'Menu') #(#doGrab:with: 'Pick up') #(#editButtonsScript 'See the script for this button') #(#editDrawing 'Repaint') #(#doDupOrMakeSibling:with: 'Duplicate (press shift to make a sibling)') #(#doMakeSiblingOrDup:with: 'Make a sibling (press shift to make simple duplicate)') #(#makeNascentScript 'Make a scratch script') #(#makeNewDrawingWithin 'Paint new object') #(#mouseDownInCollapseHandle:with: 'Collapse') #(#mouseDownOnHelpHandle: 'Help') #(#openViewerForArgument 'Open a Viewer for me. Press shift for a snapshot.') #(#openViewerForTarget:with: 'Open a Viewer
for me. Press shift for a snapshot.') #(#paintBackground 'Paint background') #(#prepareToTrackCenterOfRotation:with: 'Move object or set center of rotation') #(#presentViewMenu 'Present the Viewing menu') #(#startDrag:with: 'Move') #(#startGrow:with: 'Change size') #(#startRot:with: 'Rotate') #(#startScale:with: 'Change scale') #(#tearOffTile 'Make a tile representing this object') #(#tearOffTileForTarget:with: 'Make a tile representing this object') #(#trackCenterOfRotation:with: 'Set center of rotation') )
do: [:pair | itsSelector == pair first
ifTrue: [^ pair last]].
^ 'unknown halo handle'translated!
Item was changed:
----- Method: Morph>>balloonText (in category 'accessing') -----
balloonText
+ "Answer balloon help text or nil, if no help is available."
+ "NB: subclasses may override such that they programatically construct the text, for economy's sake, such as model phrases in a Viewer."
- "Answer balloon help text or nil, if no help is available.
- NB: subclasses may override such that they programatically
- construct the text, for economy's sake, such as model phrases in
- a Viewer"
+ | balloonSelector |
+ extension ifNil: [^ nil].
- | result |
- extension ifNil: [^nil].
extension balloonText
+ ifNotNil: [:balloonText | ^ balloonText].
+ balloonSelector := extension balloonTextSelector
+ ifNil: [^ nil].
+ (ScriptingSystem helpStringOrNilFor: balloonSelector)
+ ifNotNil: [:result | ^ result].
+ balloonSelector == #methodComment
+ ifTrue: [^ self methodCommentAsBalloonHelp].
+ balloonSelector isUnary
+ ifTrue: [
+ (self respondsTo: balloonSelector)
+ ifTrue: [^ self perform: balloonSelector].
+ (self model respondsTo: balloonSelector)
+ ifTrue: [^ self model perform: balloonSelector]].
+ ^ nil!
- ifNotNil: [:balloonText | result := balloonText]
- ifNil: [extension balloonTextSelector
- ifNotNil: [:balloonSelector |
- result := ScriptingSystem helpStringOrNilFor: balloonSelector.
- (result isNil and: [balloonSelector == #methodComment])
- ifTrue: [result := self methodCommentAsBalloonHelp].
- ((result isNil and: [balloonSelector numArgs = 0])
- and: [self respondsTo: balloonSelector])
- ifTrue: [result := self perform: balloonSelector]]].
- ^ result!
Item was changed:
----- Method: Morph>>beFlap: (in category 'accessing') -----
beFlap: aBool
"Mark the receiver with the #flap property, or unmark it"
aBool
ifTrue:
[self setProperty: #flap toValue: true.
+ self disableLayout: true.
self hResizing: #rigid.
+ self vResizing: #rigid.
+ self morphicLayerNumber: self class navigatorLayer]
- self vResizing: #rigid]
ifFalse:
+ [self removeProperty: #flap.
+ self disableLayout: false.
+ self morphicLayerNumber: nil]!
- [self removeProperty: #flap]!
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].
+ (self hasProperty: #errorOnLayout) ifTrue:
+ [aMenu add: 'start layouting again' translated action: #resumeAfterLayoutError.
+ 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;
add: 'explore model' translated target: self model action: #explore].
(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 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>>buildYellowButtonMenu: (in category 'menu') -----
buildYellowButtonMenu: aHand
+ "Build the morph menu for the yellow button."
+
- "build the morph menu for the yellow button"
| menu |
menu := MenuMorph new defaultTarget: self.
+ self addNestedYellowButtonItemsTo: menu event: self currentEvent.
- self addNestedYellowButtonItemsTo: menu event: ActiveEvent.
MenuIcons decorateMenu: menu.
^ menu!
Item was changed:
+ ----- Method: Morph>>cellGap (in category 'layout properties - table') -----
- ----- Method: Morph>>cellGap (in category 'layout-properties') -----
cellGap
"Layout specific. This property specifies an extra space *between* cells in the layout."
| props |
props := self layoutProperties.
^props ifNil:[0] ifNotNil:[props cellGap].!
Item was changed:
+ ----- Method: Morph>>cellGap: (in category 'layout properties - table') -----
- ----- Method: Morph>>cellGap: (in category 'layout-properties') -----
cellGap: aNumber
"Layout specific. This property specifies an extra space *between* cells in the layout."
+ self assureTableLayoutProperties cellGap: aNumber.
- self assureTableProperties cellGap: aNumber.
self layoutChanged.!
Item was changed:
+ ----- Method: Morph>>cellInset (in category 'layout properties - table') -----
- ----- Method: Morph>>cellInset (in category 'layout-properties') -----
cellInset
"Layout specific. This property specifies an extra inset for each cell in the layout."
| props |
props := self layoutProperties.
^props ifNil:[0] ifNotNil:[props cellInset].!
Item was changed:
+ ----- Method: Morph>>cellInset: (in category 'layout properties - table') -----
- ----- Method: Morph>>cellInset: (in category 'layout-properties') -----
cellInset: aNumber
"Layout specific. This property specifies an extra inset for each cell in the layout."
+ self assureTableLayoutProperties cellInset: aNumber.
- self assureTableProperties cellInset: aNumber.
self layoutChanged.!
Item was changed:
+ ----- Method: Morph>>cellPositioning (in category 'layout properties - table') -----
- ----- Method: Morph>>cellPositioning (in category 'layout-properties') -----
cellPositioning
"Layout specific. This property describes how the receiver should be layed out in its owner when the bounds of the cell assigned to the receiver do not exactly match its bounds. Possible values are:
#topLeft, #topRight, #bottomLeft, #bottomRight, #topCenter, #leftCenter, #rightCenter, #bottomCenter, #center
which align the receiver's bounds with the cell at the given point."
| props |
props := self layoutProperties.
^props ifNil:[#center] ifNotNil:[props cellPositioning].!
Item was changed:
+ ----- Method: Morph>>cellPositioning: (in category 'layout properties - table') -----
- ----- Method: Morph>>cellPositioning: (in category 'layout-properties') -----
cellPositioning: aSymbol
"Layout specific. This property describes how the receiver should be layed out in its owner when the bounds of the cell assigned to the receiver do not exactly match its bounds. Possible values are:
#topLeft, #topRight, #bottomLeft, #bottomRight, #topCenter, #leftCenter, #rightCenter, #bottomCenter, #center
which align the receiver's bounds with the cell at the given point."
+ self assureTableLayoutProperties cellPositioning: aSymbol.
- self assureTableProperties cellPositioning: aSymbol.
self layoutChanged.!
Item was changed:
+ ----- Method: Morph>>cellPositioningString: (in category 'layout-menu') -----
- ----- Method: Morph>>cellPositioningString: (in category 'layout-properties') -----
cellPositioningString: aSymbol
^self layoutMenuPropertyString: aSymbol from: self cellPositioning!
Item was changed:
+ ----- Method: Morph>>cellSpacing (in category 'layout properties - table') -----
- ----- Method: Morph>>cellSpacing (in category 'layout-properties') -----
cellSpacing
"Layout specific. This property describes how the cell size for each element in a list should be computed.
#globalRect - globally equal rectangular cells
#globalSquare - globally equal square cells
#localRect - locally (e.g., per row/column) equal rectangular cells
#localSquare - locally (e.g., per row/column) equal square cells
#none - cells are sized based on available row/column constraints
"
| props |
props := self layoutProperties.
^props ifNil:[#none] ifNotNil:[props cellSpacing].!
Item was changed:
+ ----- Method: Morph>>cellSpacing: (in category 'layout properties - table') -----
- ----- Method: Morph>>cellSpacing: (in category 'layout-properties') -----
cellSpacing: aSymbol
"Layout specific. This property describes how the cell size for each element in a list should be computed.
#globalRect - globally equal rectangular cells
#globalSquare - globally equal square cells
#localRect - locally (e.g., per row/column) equal rectangular cells
#localSquare - locally (e.g., per row/column) equal square cells
#none - cells are sized based on available row/column constraints
"
self checkCellSpacingProperty: aSymbol.
+ self assureTableLayoutProperties cellSpacing: aSymbol.
- self assureTableProperties cellSpacing: aSymbol.
self layoutChanged.!
Item was changed:
+ ----- Method: Morph>>cellSpacingString: (in category 'layout-menu') -----
- ----- Method: Morph>>cellSpacingString: (in category 'layout-properties') -----
cellSpacingString: aSymbol
^self layoutMenuPropertyString: aSymbol from: self cellSpacing!
Item was added:
+ ----- Method: Morph>>changedViaHalo: (in category 'halo notification') -----
+ changedViaHalo: halo
+ "The receiver has been manipulated from a halo in an operation that has completed now."!
Item was changed:
----- Method: Morph>>changesHeightForWidth (in category 'layout-menu') -----
changesHeightForWidth
+ "When both axes are on #spaceFill, the receiver (morph) usually adapts any inner height-for-width layout unless there is more space to fill. Since we cannot know in advance, we assume that an extra layout run might be necessary."
+ ^ (self hResizing == #spaceFill and: [self vResizing == #spaceFill])
+ or: [(self hResizing ~= #shrinkWrap
+ and: [self vResizing = #shrinkWrap])
+ and: [self wrapDirection ~= #none]]!
- ^ (self hResizing ~= #shrinkWrap
- and: [self vResizing = #shrinkWrap])
- and: [self wrapDirection ~= #none]!
Item was changed:
----- Method: Morph>>changesWidthForHeight (in category 'layout-menu') -----
changesWidthForHeight
+ "When both axes are on #spaceFill, the receiver (morph) usually adapts any inner height-for-width layout unless there is more space to fill. Since we cannot know in advance, we assume that an extra layout run might be necessary."
+
+ ^ (self hResizing == #spaceFill and: [self vResizing == #spaceFill])
+ or: [(self hResizing = #shrinkWrap
+ and: [self vResizing ~= #shrinkWrap])
+ and: [self wrapDirection ~= #none]]!
-
- ^ (self hResizing = #shrinkWrap
- and: [self vResizing ~= #shrinkWrap])
- and: [self wrapDirection ~= #none]!
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 := Project current world submorphThat:
- [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>>comeToFront (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>comeToFront (in category 'submorphs-add/remove') -----
comeToFront
| outerMorph |
outerMorph := self topRendererOrSelf.
(outerMorph owner isNil or: [outerMorph owner hasSubmorphs not])
ifTrue: [^self].
outerMorph owner firstSubmorph == outerMorph
ifFalse: [outerMorph owner addMorphFront: outerMorph]!
Item was changed:
----- Method: Morph>>containingWindow (in category 'structure') -----
containingWindow
"Answer a window that contains the receiver. Try to use the model to find the right window. If I do not have a model, use the model of one of my owners. We could also just use #isSystemWindow. This, however, gives system windows the chance to refrain from taking ownership of this morph."
| component |
component := self.
component model isNil ifTrue: [component := self firstOwnerSuchThat: [:m| m model notNil]].
^(component isNil or: [component isWindowForModel: component model])
ifTrue: [component]
+ ifFalse: [(component firstOwnerSuchThat: [:m | m isWindowForModel: component model])
+ "For models composed of models, we have to use #isSystemWindow."
+ ifNil: [component firstOwnerSuchThat: [:m | m isSystemWindow]]]!
- ifFalse: [component firstOwnerSuchThat:[:m| m isWindowForModel: component model]]!
Item was changed:
+ ----- Method: Morph>>copyLayoutProperties (in category 'layout properties') -----
- ----- Method: Morph>>copyLayoutProperties (in category 'layout-properties') -----
copyLayoutProperties
+ ^[Clipboard clipboardText: self layoutProperties storeString] ifError:[ nil ] !
- ^[Clipboard clipboardText: self layoutProperties stringWithLayout] ifError:[ nil ] !
Item was changed:
+ ----- Method: Morph>>copyWithoutSubmorph: (in category 'submorphs - misc') -----
- ----- Method: Morph>>copyWithoutSubmorph: (in category 'submorphs-add/remove') -----
copyWithoutSubmorph: sub
"Needed to get a morph to draw without one of its submorphs.
NOTE: This must be thrown away immediately after use."
^ self shallowCopy privateSubmorphs: (submorphs copyWithout: sub)!
Item was changed:
----- Method: Morph>>createHalo (in category 'halos and balloon help') -----
createHalo
+ ^ (Smalltalk at: self haloClass ifAbsent: [HaloMorph]) new!
- ^ (Smalltalk at: self haloClass ifAbsent: [HaloMorph]) new
- bounds: self worldBoundsForHalo
- yourself!
Item was added:
+ ----- Method: Morph>>defaultHaloDispatcher (in category 'halos and balloon help') -----
+ defaultHaloDispatcher
+
+ ^ MorphicHaloDispatcher new!
Item was changed:
+ ----- Method: Morph>>delete (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>delete (in category 'submorphs-add/remove') -----
delete
"Remove the receiver as a submorph of its owner and make its
new owner be nil."
| oldWorld |
self removeHalo.
(oldWorld := self world) ifNotNil: [
self disableSubmorphFocusForHand: self activeHand.
self activeHand
releaseKeyboardFocus: self;
releaseMouseFocus: self].
owner ifNotNil: [
self privateDelete. "remove from world"
self player ifNotNil: [:player |
oldWorld ifNotNil: [
player noteDeletionOf: self fromWorld: oldWorld]]].!
Item was changed:
+ ----- Method: Morph>>deleteDockingBars (in category 'submorphs - misc') -----
- ----- Method: Morph>>deleteDockingBars (in category 'submorphs-add/remove') -----
deleteDockingBars
"Delete the receiver's docking bars"
self dockingBars
do: [:each | each delete]!
Item was changed:
+ ----- Method: Morph>>deleteSubmorphsWithProperty: (in category 'submorphs - misc') -----
- ----- Method: Morph>>deleteSubmorphsWithProperty: (in category 'submorphs-add/remove') -----
deleteSubmorphsWithProperty: aSymbol
submorphs copy do:
[:m | (m hasProperty: aSymbol) ifTrue: [m delete]]!
Item was changed:
+ ----- Method: Morph>>deleteUnlessHasFocus (in category 'submorphs - misc') -----
- ----- Method: Morph>>deleteUnlessHasFocus (in category 'submorphs-add/remove') -----
deleteUnlessHasFocus
"Runs on a step timer because we cannot be guaranteed to get focus change events."
+ (self currentHand keyboardFocus ~= self and: [ self isInWorld ]) ifTrue:
- (ActiveHand keyboardFocus ~= self and: [ self isInWorld ]) ifTrue:
[ self
stopSteppingSelector: #deleteUnlessHasFocus ;
delete ]!
Item was changed:
+ ----- Method: Morph>>disableLayout (in category 'layout properties') -----
- ----- Method: Morph>>disableLayout (in category 'layout-properties') -----
disableLayout
"Layout specific. Disable laying out the receiver in a layout"
| props |
props := self layoutProperties.
^props ifNil:[false] ifNotNil:[props disableLayout].!
Item was changed:
+ ----- Method: Morph>>disableLayout: (in category 'layout properties') -----
- ----- Method: Morph>>disableLayout: (in category 'layout-properties') -----
disableLayout: aBool
+ "Layout specific. Disable laying out the receiver in the owner's layout if any. The receiver's layout (policy) is not affected by this."
- "Layout specific. Disable laying out the receiver in a layout"
self fullBounds; layoutChanged.
self assureLayoutProperties disableLayout: aBool.
self fullBounds; layoutChanged; changed.!
Item was changed:
+ ----- Method: Morph>>disableTableLayout (in category 'layout properties') -----
- ----- Method: Morph>>disableTableLayout (in category 'layout-properties') -----
disableTableLayout
"Layout specific. Disable laying out the receiver in table layout"
| props |
props := self layoutProperties.
^props ifNil:[false] ifNotNil:[props disableTableLayout].!
Item was changed:
+ ----- Method: Morph>>disableTableLayout: (in category 'layout properties') -----
- ----- Method: Morph>>disableTableLayout: (in category 'layout-properties') -----
disableTableLayout: aBool
"Layout specific. Disable laying out the receiver in table layout"
self fullBounds; layoutChanged.
self assureLayoutProperties disableTableLayout: aBool.
self fullBounds; layoutChanged; changed.!
Item was changed:
+ ----- Method: Morph>>dismissViaHalo (in category 'submorphs - misc') -----
- ----- Method: Morph>>dismissViaHalo (in category 'submorphs-add/remove') -----
dismissViaHalo
"The user has clicked in the delete halo-handle. This provides a hook in case some concomitant action should be taken, or if the particular morph is not one which should be put in the trash can, for example."
| cmd |
self setProperty: #lastPosition toValue: self positionInWorld.
self dismissMorph.
TrashCanMorph preserveTrash ifTrue: [
TrashCanMorph slideDismissalsToTrash
ifTrue:[self slideToTrash: nil]
ifFalse:[TrashCanMorph moveToTrash: self].
].
cmd := Command new cmdWording: 'dismiss ' translated, self externalName.
+ cmd undoTarget: Project current world selector: #reintroduceIntoWorld: argument: self.
+ cmd redoTarget: Project current world selector: #onceAgainDismiss: argument: self.
+ Project current world rememberCommand: cmd.!
- cmd undoTarget: ActiveWorld selector: #reintroduceIntoWorld: argument: self.
- cmd redoTarget: ActiveWorld selector: #onceAgainDismiss: argument: self.
- ActiveWorld rememberCommand: cmd!
Item was changed:
----- Method: Morph>>doButtonAction (in category 'button') -----
doButtonAction
+ "If the receiver has a button-action defined, do it now. The default button action of any morph is, well, to do nothing. Note that there are several ways -- too many ways -- for morphs to have button-like actions. It is intended for morph classes whose very nature is to be buttons -- this method provides glue so that arbitrary buttons on the UI can be 'fired' programmatically from user scripts."!
- "If the receiver has a button-action defined, do it now. The default button action of any morph is, well, to do nothing. Note that there are several ways -- too many ways -- for morphs to have button-like actions. This one refers not to the #mouseUpCodeToRun feature, nor does it refer to the Player-scripting mechanism. Instead it is intended for morph classes whose very nature is to be buttons -- this method provides glue so that arbitrary buttons on the UI can be 'fired' programatticaly from user scripts"!
Item was added:
+ ----- Method: Morph>>doLayout (in category 'layout') -----
+ doLayout
+
+ self doLayoutIn: self layoutBounds.!
Item was changed:
----- Method: Morph>>doLayoutIn: (in category 'layout') -----
doLayoutIn: layoutBounds
"Compute a new layout based on the given layout bounds."
| box priorBounds |
"0) Quick return. No children means no effect in layout policies. Use #minWidth and #minHeight to implement #shrinkWrap for morphs without submorphs."
self hasSubmorphs ifFalse: [^ fullBounds := self outerBounds].
"X.1) Prepare redraw. Testing for #bounds or #layoutBounds would be sufficient to figure out if we need an invalidation afterwards but #outerBounds is what we need for all leaf nodes so we use that"
priorBounds := self outerBounds.
"1) Give our children a chance to manually adjust *before* layout (cell) computation. This allows morphs to layout in their owner without having to use a layout policy."
self submorphsDo: [:m | m ownerChanged].
"2) Compute the new layout. This goes down the entire morph hierarchy. See #layoutInBounds: and #minExtent, which are the usual layout-policy callbacks."
+ self layoutPolicy ifNil: [self submorphsDo: [:m | m fullBounds]] ifNotNil: [:layout |
- self layoutPolicy ifNotNil: [:layout |
"2.1) Compute the new layout."
self removeProperty: #doLayoutAgain.
layout layout: self in: layoutBounds.
"2.2) Do one additional run on the layout if requested in #layoutInBounds:."
(self hasProperty: #doLayoutAgain) ifTrue: [
self removeProperty: #doLayoutAgain.
layout flushLayoutCache.
layout layout: self in: layoutBounds].
self assert: (self hasProperty: #doLayoutAgain) not].
"3) Watch out for minimal extent and apply #shrinkWrap constraints."
self adjustLayoutBounds.
"4) Compute and set the new full bounds. IMPORTANT to finish layout computation."
fullBounds := self privateFullBounds.
"X.2) Redraw."
box := self outerBounds.
box = priorBounds ifFalse: [
self invalidRect: (priorBounds quickMerge: box)].!
Item was added:
+ ----- Method: Morph>>doLayoutSafely (in category 'layout') -----
+ doLayoutSafely
+ "Also see #resumeAfterLayoutError."
+
+ [fullBounds] whileNil: [
+ [self doLayout] on: Error, Halt, Warning do: [:error |
+
+ | errorMorph |
+ (error signalerContext
+ findContextSuchThat: [:context |
+ context receiver isMorph and: [context receiver layoutPolicy notNil]])
+ ifNil: [^ error pass "We cannot help here. Maybe the receiver is not yet initialized?"]
+ ifNotNil: [:errorContext | errorMorph := errorContext receiver].
+ errorMorph
+ instVarNamed: #fullBounds
+ put: (errorMorph instVarNamed: #bounds).
+ (Warning handles: error) ifFalse: [
+ "Disable the policy unless it is a warning, which should be secured where signaled to ease debugging."
+ errorMorph
+ setProperty: #errorOnLayout toValue: errorMorph layoutPolicy;
+ setProperty: #layoutPolicy toValue: nil. "Avoid #layoutChanged!!"].
+
+ ToolSet debugException: error]].!
Item was changed:
+ ----- Method: Morph>>dockingBars (in category 'submorphs - misc') -----
- ----- Method: Morph>>dockingBars (in category 'submorphs-accessing') -----
dockingBars
"Answer the receiver's dockingBars"
^ self submorphs
select: [:each | each isDockingBar]
!
Item was changed:
----- Method: Morph>>drawKeyboardFocusIndicationOn: (in category 'drawing') -----
drawKeyboardFocusIndicationOn: aCanvas
self wantsRoundedCorners
+ ifTrue: [aCanvas frameRoundRect: self bounds radius: self cornerRadius width: self keyboardFocusWidth + self borderWidth color: self keyboardFocusColor]
+ ifFalse: [aCanvas frameRectangle: self bounds width: self keyboardFocusWidth + self borderWidth color: self keyboardFocusColor].!
- ifTrue: [aCanvas frameRoundRect: self bounds radius: self cornerRadius width: self keyboardFocusWidth color: self keyboardFocusColor]
- ifFalse: [aCanvas frameRectangle: self bounds width: self keyboardFocusWidth color: self keyboardFocusColor].!
Item was removed:
- ----- Method: Morph>>dropFiles: (in category 'event handling') -----
- dropFiles: anEvent
- "Handle a number of files dropped from the OS"
- !
Item was changed:
----- Method: Morph>>duplicate (in category 'copying') -----
duplicate
"Make and return a duplicate of the receiver"
| newMorph aName w aPlayer topRend |
((topRend := self topRendererOrSelf) ~~ self) ifTrue: [^ topRend duplicate].
self okayToDuplicate ifFalse: [^ self].
aName := (w := self world) ifNotNil:
[w nameForCopyIfAlreadyNamed: self].
newMorph := self veryDeepCopy.
aName ifNotNil: [newMorph setNameTo: aName].
newMorph arrangeToStartStepping.
newMorph privateOwner: nil. "no longer in world"
newMorph isPartsDonor: false. "no longer parts donor"
(aPlayer := newMorph player) belongsToUniClass ifTrue:
[aPlayer class bringScriptsUpToDate].
+ aPlayer ifNotNil: [self currentWorld presenter flushPlayerListCache].
- aPlayer ifNotNil: [ActiveWorld presenter flushPlayerListCache].
^ newMorph!
Item was changed:
+ ----- Method: Morph>>findA: (in category 'submorphs - misc') -----
- ----- Method: Morph>>findA: (in category 'submorphs-accessing') -----
findA: aClass
"Return the first submorph of the receiver that is descended from the given class. Return nil if there is no such submorph. Clients of this code should always check for a nil return value so that the code will be robust if the user takes the morph apart."
^self submorphs
detect: [:p | p isKindOf: aClass]
ifNone: [nil]!
Item was changed:
+ ----- Method: Morph>>findDeepSubmorphThat:ifAbsent: (in category 'submorphs - misc') -----
- ----- Method: Morph>>findDeepSubmorphThat:ifAbsent: (in category 'submorphs-accessing') -----
findDeepSubmorphThat: block1 ifAbsent: block2
self
allMorphsDo: [:m | (block1 value: m)
== true ifTrue: [^ m]].
^ block2 value!
Item was changed:
+ ----- Method: Morph>>findDeeplyA: (in category 'submorphs - misc') -----
- ----- Method: Morph>>findDeeplyA: (in category 'submorphs-accessing') -----
findDeeplyA: aClass
"Return a morph in the submorph tree of the receiver that is descended from the given class. Return nil if there is no such morph. Clients of this code should always check for a nil return value so that the code will be robust if the user takes the morph apart."
^ (self allMorphs copyWithout: self)
detect: [:p | p isKindOf: aClass]
ifNone: [nil]!
Item was changed:
+ ----- Method: Morph>>findSubmorphBinary: (in category 'submorphs - misc') -----
- ----- Method: Morph>>findSubmorphBinary: (in category 'submorphs-accessing') -----
findSubmorphBinary: aBlock
"Use binary search for finding a specific submorph of the receiver. Caller must be certain that the ordering holds for the submorphs."
^submorphs findBinary: aBlock ifNone:[nil].!
Item was changed:
+ ----- Method: Morph>>firstSubmorph (in category 'submorphs - accessing') -----
- ----- Method: Morph>>firstSubmorph (in category 'submorphs-accessing') -----
firstSubmorph
^submorphs first!
Item was changed:
+ ----- Method: Morph>>forwardDirection (in category 'rotate scale and flex') -----
- ----- Method: Morph>>forwardDirection (in category 'accessing') -----
forwardDirection
+ "Return the receiver's offset to distinguish #heading from #rotationDegrees."
+
+ ^ self valueOfProperty: #forwardDirection ifAbsent: [0.0]!
- "Return the receiver's forward direction (in eToy terms)"
- ^self valueOfProperty: #forwardDirection ifAbsent:[0.0]!
Item was added:
+ ----- Method: Morph>>forwardDirection: (in category 'rotate scale and flex') -----
+ forwardDirection: newDirection
+
+ self setProperty: #forwardDirection toValue: newDirection.!
Item was changed:
----- Method: Morph>>fullBounds (in category 'layout') -----
fullBounds
+ "Return the bounding box of the receiver and all its children. Recompute the layout if necessary. See #layoutChanged."
+
+ ^ fullBounds ifNil: [self doLayoutSafely. fullBounds]!
- "Return the bounding box of the receiver and all its children. Recompute the layout if necessary."
- fullBounds ifNotNil:[^fullBounds].
- "Errors at this point can be critical so make sure we catch 'em all right"
- [self doLayoutIn: self layoutBounds] on: Error, Warning, Halt do:[:ex|
- "This should do it unless you don't screw up the bounds"
- fullBounds := bounds.
- ex pass].
- ^fullBounds!
Item was removed:
- ----- Method: Morph>>fullCopy (in category 'copying') -----
- fullCopy
- "Deprecated, but maintained for backward compatibility with existing code (no senders in the base 3.0 image). Calls are revectored to #veryDeepCopy, but note that #veryDeepCopy does not do exactly the same thing that the original #fullCopy did, so beware!!"
-
- ^ self veryDeepCopy!
Item was changed:
+ ----- Method: Morph>>goBehind (in category 'submorphs - add/remove') -----
- ----- 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]
!
Item was added:
+ ----- Method: Morph>>gridModulus (in category 'layout properties - grid') -----
+ gridModulus
+ "Layout specific. This property describes how the cell size in the grid."
+
+ ^ self layoutProperties ifNil: [8@8] ifNotNil: [:properties | properties modulus]!
Item was added:
+ ----- Method: Morph>>gridModulus: (in category 'layout properties - grid') -----
+ gridModulus: aPoint
+ "Layout specific. This property describes how the cell size in the grid."
+
+ self assureGridLayoutProperties modulus: aPoint.
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>gridOrigin (in category 'layout properties - grid') -----
+ gridOrigin
+ "Layout specific. This property describes the offset in the grid."
+
+ ^ self layoutProperties ifNil: [0@0] ifNotNil: [:properties | properties origin]!
Item was added:
+ ----- Method: Morph>>gridOrigin: (in category 'layout properties - grid') -----
+ gridOrigin: aPoint
+ "Layout specific. This property describes the offset in the grid."
+
+ self assureGridLayoutProperties origin: aPoint.
+ self layoutChanged.!
Item was removed:
- ----- Method: Morph>>gridPoint: (in category 'geometry - misc') -----
- gridPoint: ungriddedPoint
-
- ^ ungriddedPoint!
Item was removed:
- ----- Method: Morph>>griddedPoint: (in category 'geometry - misc') -----
- griddedPoint: ungriddedPoint
-
- | griddingContext |
- self flag: #arNote. "Used by event handling - should transform to pasteUp for gridding"
- (griddingContext := self pasteUpMorph) ifNil: [^ ungriddedPoint].
- ^ griddingContext gridPoint: ungriddedPoint!
Item was changed:
+ ----- Method: Morph>>hResizing (in category 'layout properties') -----
- ----- Method: Morph>>hResizing (in category 'layout-properties') -----
hResizing
"Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are:
#rigid - do not resize the receiver
#spaceFill - resize to fill owner's available space
#shrinkWrap - resize to fit children
"
| props |
props := self layoutProperties.
^props ifNil:[#rigid] ifNotNil:[props hResizing].!
Item was changed:
+ ----- Method: Morph>>hResizing: (in category 'layout properties') -----
- ----- Method: Morph>>hResizing: (in category 'layout-properties') -----
hResizing: aSymbol
"Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are:
#rigid - do not resize the receiver
#spaceFill - resize to fill owner's available space
#shrinkWrap - resize to fit children
"
self checkResizingProperty: aSymbol.
self assureLayoutProperties hResizing: aSymbol.
self layoutChanged.
!
Item was changed:
+ ----- Method: Morph>>hResizingString: (in category 'layout-menu') -----
- ----- Method: Morph>>hResizingString: (in category 'layout-properties') -----
hResizingString: aSymbol
^self layoutMenuPropertyString: aSymbol from: self hResizing!
Item was removed:
- ----- Method: Morph>>handleDropFiles: (in category 'events-processing') -----
- handleDropFiles: anEvent
- "Handle a drop from the OS."
- anEvent wasHandled ifTrue:[^self]. "not interested"
- (self wantsDropFiles: anEvent) ifFalse:[^self].
- anEvent wasHandled: true.
- self dropFiles: anEvent.
- !
Item was changed:
----- Method: Morph>>handleKeyDown: (in category 'events-processing') -----
handleKeyDown: anEvent
"System level event handling."
+ anEvent wasHandled ifTrue: [^ self].
+ (self handlesKeyboard: anEvent) ifFalse: [^ self].
+ (anEvent hand keyboardFocus ~~ self
+ and: [self handlesKeyboardOnlyOnFocus])
+ ifTrue: [^ self].
+
- anEvent wasHandled ifTrue:[^self].
- (self handlesKeyboard: anEvent) ifFalse:[^self].
anEvent wasHandled: true.
+ ^ self keyDown: anEvent!
- ^self keyDown: anEvent!
Item was changed:
----- Method: Morph>>handleKeyUp: (in category 'events-processing') -----
handleKeyUp: anEvent
"System level event handling."
+ anEvent wasHandled ifTrue: [^ self].
+ (self handlesKeyboard: anEvent) ifFalse: [^ self].
+ (anEvent hand keyboardFocus ~~ self
+ and: [self handlesKeyboardOnlyOnFocus])
+ ifTrue: [^ self].
+
- anEvent wasHandled ifTrue:[^self].
- (self handlesKeyboard: anEvent) ifFalse:[^self].
anEvent wasHandled: true.
+ ^ self keyUp: anEvent!
- ^self keyUp: anEvent!
Item was changed:
----- Method: Morph>>handleKeystroke: (in category 'events-processing') -----
handleKeystroke: anEvent
"System level event handling. Has support for automatically grabbing the keyboard focus considering the keyboard focus delegate. See #newKeyboardFocus:"
| handler |
anEvent wasHandled ifTrue: [^ self].
(self handlesKeyboard: anEvent) ifFalse: [^ self].
+ (anEvent hand keyboardFocus ~~ self
+ and: [self handlesKeyboardOnlyOnFocus])
+ ifTrue: [^ self].
handler := self wantsKeyboardFocus
ifFalse: [self]
ifTrue: [(anEvent hand newKeyboardFocus: self) ifNil: [self]].
anEvent handler: handler.
anEvent wasHandled: true.
^ handler keyStroke: anEvent!
Item was added:
+ ----- Method: Morph>>handlesKeyboardOnlyOnFocus (in category 'event handling') -----
+ handlesKeyboardOnlyOnFocus
+ "If set, reject every keyboard event until the receiver has received the keyboard focus in another way, i.e. a mouse click (see #mouseDown:) or programmatic focusing (see HandMorph >> #newKeyboardFocus:). This allows sending keyboard events to any owner of the receiver while the receiver is hovered by the hand. See senders.
+ A particular user is DialogWindow which looks for Enter and Escape presses and should not loose these events to the content morph unless it is explicitly focused. For the full discussion, see http://forum.world.st/The-Inbox-Morphic-cbc-1665-mcz-td5117905.html."
+
+ ^ self valueOfProperty: #handlesKeyboardOnlyOnFocus ifAbsent: [false]!
Item was added:
+ ----- Method: Morph>>handlesKeyboardOnlyOnFocus: (in category 'event handling') -----
+ handlesKeyboardOnlyOnFocus: aBoolean
+
+ ^ self setProperty: #handlesKeyboardOnlyOnFocus toValue: aBoolean!
Item was added:
+ ----- Method: Morph>>hasStrings (in category 'debug and other') -----
+ hasStrings
+
+ self allStringsAfter: nil do: [:string | ^ true].
+ ^ false!
Item was changed:
+ ----- Method: Morph>>hasSubmorphWithProperty: (in category 'submorphs - misc') -----
- ----- Method: Morph>>hasSubmorphWithProperty: (in category 'submorphs-accessing') -----
hasSubmorphWithProperty: aSymbol
^submorphs anySatisfy: [:m | m hasProperty: aSymbol]!
Item was changed:
+ ----- Method: Morph>>hasSubmorphs (in category 'submorphs - testing') -----
- ----- Method: Morph>>hasSubmorphs (in category 'submorphs-accessing') -----
hasSubmorphs
^submorphs notEmpty!
Item was added:
+ ----- Method: Morph>>heading (in category 'rotate scale and flex') -----
+ heading
+ "Answer the current heading, which is #rotationDegrees relative to the #forwardDirection."
+
+ ^ self rotationDegrees + self forwardDirection!
Item was added:
+ ----- Method: Morph>>heading: (in category 'rotate scale and flex') -----
+ heading: newHeading
+
+ self rotationDegrees: (newHeading - self forwardDirection).!
Item was changed:
----- Method: Morph>>inAScrollPane (in category 'initialization') -----
inAScrollPane
"Answer a scroll pane that allows the user to scroll the receiver in either direction. It will have permanent scroll bars unless you take some special action."
| widget |
widget := ScrollPane new.
+ widget borderWidth: 0.
+
- widget extent: ((self width min: 300 max: 100) @ (self height min: 150 max: 100));
- borderWidth: 0.
widget scroller addMorph: self.
+ self position: 0@0.
+
+ widget
+ hScrollBarPolicy: #whenNeeded;
+ vScrollBarPolicy: #whenNeeded;
+ fit;
+ extent: (widget width min: 300 max: 100) @ (widget height min: 150 max: 100).
+
- widget setScrollDeltas.
widget color: self color darker darker.
^ widget!
Item was removed:
- ----- Method: Morph>>inATwoWayScrollPane (in category 'initialization') -----
- inATwoWayScrollPane
- "Answer a two-way scroll pane that allows the user to scroll the receiver in either direction. It will have permanent scroll bars unless you take some special action."
-
- | widget |
- widget := TwoWayScrollPane new.
- widget extent: ((self width min: 300 max: 100) @ (self height min: 150 max: 100));
- borderWidth: 0.
- widget scroller addMorph: self.
- widget setScrollDeltas.
- widget color: self color darker darker.
- ^ widget!
Item was changed:
+ ----- Method: Morph>>indexOfMorphAbove: (in category 'submorphs - misc') -----
- ----- Method: Morph>>indexOfMorphAbove: (in category 'submorphs-accessing') -----
indexOfMorphAbove: aPoint
"Return index of lowest morph whose bottom is above aPoint.
Will return 0 if the first morph is not above aPoint."
submorphs withIndexDo: [:mm :ii |
mm fullBounds bottom >= aPoint y ifTrue: [^ ii - 1]].
^ submorphs size!
Item was changed:
----- Method: Morph>>indicateAllSiblings (in category 'meta-actions') -----
indicateAllSiblings
"Indicate all the receiver and all its siblings by flashing momentarily."
| aPlayer allBoxes |
(aPlayer := self topRendererOrSelf player) belongsToUniClass ifFalse: [^ self "error: 'not uniclass'"].
allBoxes := aPlayer class allInstances
+ select: [:m | m costume world == self currentWorld]
- select: [:m | m costume world == ActiveWorld]
thenCollect: [:m | m costume boundsInWorld].
5 timesRepeat:
+ [Display flashAll: allBoxes andWait: 120].!
- [Display flashAll: allBoxes andWait: 120]!
Item was changed:
+ ----- Method: Morph>>intoWorld: (in category 'submorphs - callbacks') -----
- ----- Method: Morph>>intoWorld: (in category 'initialization') -----
intoWorld: aWorld
"The receiver has just appeared in a new world. Note:
* aWorld can be nil (due to optimizations in other places)
* owner is already set
* owner's submorphs may not include receiver yet.
Important: Keep this method fast - it is run whenever morphs are added."
aWorld ifNil:[^self].
self wantsSteps ifTrue:[aWorld startStepping: self].
self submorphsDo:[:m| m intoWorld: aWorld].
!
Item was removed:
- ----- Method: Morph>>invokeHaloOrMove: (in category 'meta-actions') -----
- invokeHaloOrMove: anEvent
- "Special gestures (cmd-mouse on the Macintosh; Alt-mouse on Windows and Unix) allow a mouse-sensitive morph to be moved or bring up a halo for the morph."
- | h tfm doNotDrag |
- h := anEvent hand halo.
- "Prevent wrap around halo transfers originating from throwing the event back in"
- doNotDrag := false.
- h ifNotNil:[
- (h innerTarget == self) ifTrue:[doNotDrag := true].
- (h innerTarget hasOwner: self) ifTrue:[doNotDrag := true].
- (self hasOwner: h target) ifTrue:[doNotDrag := true]].
-
- tfm := (self transformedFrom: nil) inverseTransformation.
-
- "cmd-drag on flexed morphs works better this way"
- h := self addHalo: (anEvent transformedBy: tfm).
- h ifNil: [^ self].
- doNotDrag ifTrue:[^self].
- "Initiate drag transition if requested"
- anEvent hand
- waitForClicksOrDrag: h
- event: (anEvent transformedBy: tfm)
- selectors: { nil. nil. nil. #startDragTarget:. }
- threshold: HandMorph dragThreshold.
- "Pass focus explicitly here"
- anEvent hand newMouseFocus: h.
- "Reset temporary cursors to make available halo interaction visible."
- anEvent hand showTemporaryCursor: nil.!
Item was added:
+ ----- Method: Morph>>isButton (in category 'classification') -----
+ isButton
+ "Answers whether this morph acts like a button, which usually entails a mouse-click handler. Originally used in the projects 'Connectors' and 'Etoys', receivers that claim to be a button need to answer to #actionSelector as well."
+
+ ^ false!
Item was added:
+ ----- Method: Morph>>isTransferMorph (in category 'testing') -----
+ isTransferMorph
+
+ ^ false!
Item was changed:
----- Method: Morph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
justDroppedInto: aMorph event: anEvent
"This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph"
| partsBinCase cmd |
(self formerOwner notNil and: [self formerOwner ~~ aMorph])
ifTrue: [self removeHalo].
self formerOwner: nil.
self formerPosition: nil.
cmd := self valueOfProperty: #undoGrabCommand.
cmd ifNotNil:[aMorph rememberCommand: cmd.
self removeProperty: #undoGrabCommand].
(partsBinCase := aMorph isPartsBin) ifFalse:
[self isPartsDonor: false].
(self isInWorld and: [partsBinCase not]) ifTrue:
[self world startSteppingSubmorphsOf: self].
"Note an unhappy inefficiency here: the startStepping... call will often have already been called in the sequence leading up to entry to this method, but unfortunately the isPartsDonor: call often will not have already happened, with the result that the startStepping... call will not have resulted in the startage of the steppage."
"An object launched by certain parts-launcher mechanisms should end up fully visible..."
(self hasProperty: #beFullyVisibleAfterDrop) ifTrue:
+ [aMorph == self currentWorld ifTrue:
- [aMorph == ActiveWorld ifTrue:
[self goHome].
+ self removeProperty: #beFullyVisibleAfterDrop].!
- self removeProperty: #beFullyVisibleAfterDrop].
- !
Item was changed:
----- Method: Morph>>keyboardFocusWidth (in category 'drawing') -----
keyboardFocusWidth
+ ^ ((self userInterfaceTheme keyboardFocusWidth ifNil: [2]) * RealEstateAgent scaleFactor) truncated!
- ^ self userInterfaceTheme keyboardFocusWidth ifNil: [3]!
Item was changed:
+ ----- Method: Morph>>lastSubmorph (in category 'submorphs - accessing') -----
- ----- Method: Morph>>lastSubmorph (in category 'submorphs-accessing') -----
lastSubmorph
^submorphs last!
Item was changed:
+ ----- Method: Morph>>layoutFrame (in category 'layout properties - proportional') -----
- ----- Method: Morph>>layoutFrame (in category 'layout-properties') -----
layoutFrame
"Layout specific. Return the layout frame describing where the
receiver should appear in a proportional layout"
^ extension ifNotNil: [extension layoutFrame]!
Item was changed:
+ ----- Method: Morph>>layoutFrame: (in category 'layout properties - proportional') -----
- ----- Method: Morph>>layoutFrame: (in category 'layout-properties') -----
layoutFrame: aLayoutFrame
"Layout specific. Return the layout frame describing where the receiver should appear in a proportional layout"
self layoutFrame == aLayoutFrame ifTrue:[^self].
self assureExtension layoutFrame: aLayoutFrame.
self layoutChanged.!
Item was changed:
+ ----- Method: Morph>>layoutInset (in category 'layout properties') -----
- ----- Method: Morph>>layoutInset (in category 'layout-properties') -----
layoutInset
"Return the extra inset for layouts"
| props |
props := self layoutProperties.
^props ifNil:[0] ifNotNil:[props layoutInset].!
Item was changed:
+ ----- Method: Morph>>layoutInset: (in category 'layout properties') -----
- ----- Method: Morph>>layoutInset: (in category 'layout-properties') -----
layoutInset: aNumber
"Return the extra inset for layouts"
+
+ self flag: #todo. "mt: Change to #assureLayoutProperties."
+ self assureTableLayoutProperties layoutInset: aNumber.
- self assureTableProperties layoutInset: aNumber.
self layoutChanged.!
Item was changed:
+ ----- Method: Morph>>layoutPolicy (in category 'layout properties') -----
- ----- Method: Morph>>layoutPolicy (in category 'layout-properties') -----
layoutPolicy
"Layout specific. Return the layout policy describing how children
of the receiver should appear."
^ extension ifNotNil: [ extension layoutPolicy]!
Item was changed:
+ ----- Method: Morph>>layoutPolicy: (in category 'layout properties') -----
- ----- Method: Morph>>layoutPolicy: (in category 'layout-properties') -----
layoutPolicy: aLayoutPolicy
"Layout specific. Return the layout policy describing how children of the receiver should appear."
self layoutPolicy == aLayoutPolicy ifTrue:[^self].
self assureExtension layoutPolicy: aLayoutPolicy.
self layoutChanged.!
Item was changed:
+ ----- Method: Morph>>layoutProperties (in category 'layout properties') -----
- ----- Method: Morph>>layoutProperties (in category 'layout-properties') -----
layoutProperties
"Return the current layout properties associated with the
receiver"
^ extension ifNotNil: [ extension layoutProperties]!
Item was changed:
+ ----- Method: Morph>>layoutProperties: (in category 'layout properties') -----
- ----- Method: Morph>>layoutProperties: (in category 'layout-properties') -----
layoutProperties: newProperties
"Return the current layout properties associated with the receiver"
self layoutProperties == newProperties ifTrue:[^self].
self assureExtension layoutProperties: newProperties.
!
Item was changed:
+ ----- Method: Morph>>listCentering (in category 'layout properties - table') -----
- ----- Method: Morph>>listCentering (in category 'layout-properties') -----
listCentering
"Layout specific. This property describes how the rows/columns in a list-like layout should be centered.
#topLeft - center at start of primary direction
#bottomRight - center at end of primary direction
#center - center in the middle of primary direction
#justified - insert extra space inbetween rows/columns
"
| props |
props := self layoutProperties.
^props ifNil:[#topLeft] ifNotNil:[props listCentering].!
Item was changed:
+ ----- Method: Morph>>listCentering: (in category 'layout properties - table') -----
- ----- Method: Morph>>listCentering: (in category 'layout-properties') -----
listCentering: aSymbol
"Layout specific. This property describes how the rows/columns in a list-like layout should be centered.
#topLeft - center at start of primary direction
#bottomRight - center at end of primary direction
#center - center in the middle of primary direction
#justified - insert extra space inbetween rows/columns
"
+ self assureTableLayoutProperties listCentering: aSymbol.
- self assureTableProperties listCentering: aSymbol.
self layoutChanged.!
Item was changed:
+ ----- Method: Morph>>listCenteringString: (in category 'layout-menu') -----
- ----- Method: Morph>>listCenteringString: (in category 'layout-properties') -----
listCenteringString: aSymbol
^self layoutMenuPropertyString: aSymbol from: self listCentering!
Item was changed:
+ ----- Method: Morph>>listDirection (in category 'layout properties - table') -----
- ----- Method: Morph>>listDirection (in category 'layout-properties') -----
listDirection
"Layout specific. This property describes the direction in which a list-like layout should be applied. Possible values are:
#leftToRight
#rightToLeft
#topToBottom
#bottomToTop
indicating the direction in which any layout should take place"
| props |
props := self layoutProperties.
^props ifNil:[#topToBottom] ifNotNil:[props listDirection].!
Item was changed:
+ ----- Method: Morph>>listDirection: (in category 'layout properties - table') -----
- ----- Method: Morph>>listDirection: (in category 'layout-properties') -----
listDirection: aSymbol
"Layout specific. This property describes the direction in which a list-like layout should be applied. Possible values are:
#leftToRight
#rightToLeft
#topToBottom
#bottomToTop
indicating the direction in which any layout should take place"
+ self assureTableLayoutProperties listDirection: aSymbol.
- self assureTableProperties listDirection: aSymbol.
self layoutChanged.!
Item was changed:
+ ----- Method: Morph>>listDirectionString: (in category 'layout-menu') -----
- ----- Method: Morph>>listDirectionString: (in category 'layout-properties') -----
listDirectionString: aSymbol
^self layoutMenuPropertyString: aSymbol from: self listDirection!
Item was changed:
+ ----- Method: Morph>>listSpacing (in category 'layout properties - table') -----
- ----- Method: Morph>>listSpacing (in category 'layout-properties') -----
listSpacing
"Layout specific. This property describes how the heights for different rows in a table layout should be handled.
#equal - all rows have the same height
#none - all rows may have different heights
"
| props |
props := self layoutProperties.
^props ifNil:[#none] ifNotNil:[props listSpacing].!
Item was changed:
+ ----- Method: Morph>>listSpacing: (in category 'layout properties - table') -----
- ----- Method: Morph>>listSpacing: (in category 'layout-properties') -----
listSpacing: aSymbol
"Layout specific. This property describes how the heights for different rows in a table layout should be handled.
#equal - all rows have the same height
#none - all rows may have different heights
"
self checkListSpacingProperty: aSymbol.
+ self assureTableLayoutProperties listSpacing: aSymbol.
- self assureTableProperties listSpacing: aSymbol.
self layoutChanged.!
Item was changed:
+ ----- Method: Morph>>listSpacingString: (in category 'layout-menu') -----
- ----- Method: Morph>>listSpacingString: (in category 'layout-properties') -----
listSpacingString: aSymbol
^self layoutMenuPropertyString: aSymbol from: self listSpacing!
Item was changed:
+ ----- Method: Morph>>mainDockingBars (in category 'submorphs - misc') -----
- ----- Method: Morph>>mainDockingBars (in category 'submorphs-accessing') -----
mainDockingBars
"Answer the receiver's main dockingBars"
^ self dockingBars
select: [:each | each hasProperty: #mainDockingBarTimeStamp]!
Item was changed:
+ ----- Method: Morph>>maxCellSize (in category 'layout properties - table') -----
- ----- Method: Morph>>maxCellSize (in category 'layout-properties') -----
maxCellSize
"Layout specific. This property specifies the maximum size of a table cell."
| props |
props := self layoutProperties.
^props ifNil:[SmallInteger maxVal] ifNotNil:[props maxCellSize].!
Item was changed:
+ ----- Method: Morph>>maxCellSize: (in category 'layout properties - table') -----
- ----- Method: Morph>>maxCellSize: (in category 'layout-properties') -----
maxCellSize: aPoint
"Layout specific. This property specifies the maximum size of a table cell."
+ self assureTableLayoutProperties maxCellSize: aPoint.
- self assureTableProperties maxCellSize: aPoint.
self layoutChanged.!
Item was changed:
+ ----- Method: Morph>>minCellSize (in category 'layout properties - table') -----
- ----- Method: Morph>>minCellSize (in category 'layout-properties') -----
minCellSize
"Layout specific. This property specifies the minimal size of a table cell."
| props |
props := self layoutProperties.
^props ifNil:[0] ifNotNil:[props minCellSize].!
Item was changed:
+ ----- Method: Morph>>minCellSize: (in category 'layout properties - table') -----
- ----- Method: Morph>>minCellSize: (in category 'layout-properties') -----
minCellSize: aPoint
"Layout specific. This property specifies the minimal size of a table cell."
+ self assureTableLayoutProperties minCellSize: aPoint.
- self assureTableProperties minCellSize: aPoint.
self layoutChanged.!
Item was changed:
----- Method: Morph>>minimumHeight (in category 'geometry - layout') -----
minimumHeight
+ "Wrapper for layout-specific function to avoid confusion. Please configure through #minimumHeight: or #minHeight: or by overriding #minHeight. Please do not override #minimumHeight since the layout mechanism will not call it."
- "Wrapper for layout-specific function to avoid confusion."
^ self minHeight!
Item was changed:
----- Method: Morph>>minimumWidth (in category 'geometry - layout') -----
minimumWidth
+ "Wrapper for layout-specific function to avoid confusion. Please configure through #minimumWidth: or #minWidth: or by overriding #minWidth. Please do not override #minimumWidth since the layout mechanism will not call it."
- "Wrapper for layout-specific function to avoid confusion."
^ self minWidth!
Item was changed:
+ ----- Method: Morph>>morphicLayerNumber (in category 'submorphs - layers') -----
- ----- Method: Morph>>morphicLayerNumber (in category 'WiW support') -----
morphicLayerNumber
+ "Hint the preferred position in the owner's list of submorphs. Smaller layer numbers are in front of larger ones. If not specified, go up the owner chain if possible."
+
+ ^ self
+ valueOfProperty: #morphicLayerNumber
+ ifAbsent: [self topRendererOrSelf owner
+ ifNil: [self class defaultLayer]
+ ifNotNil: [:m | m morphicLayerNumber]]!
-
- "helpful for insuring some morphs always appear in front of or behind others.
- smaller numbers are in front"
-
- ^(owner isNil or: [owner isWorldMorph]) ifTrue: [
- self valueOfProperty: #morphicLayerNumber ifAbsent: [100]
- ] ifFalse: [
- owner morphicLayerNumber
- ].
-
- "leave lots of room for special things"!
Item was added:
+ ----- Method: Morph>>morphicLayerNumber: (in category 'submorphs - layers') -----
+ morphicLayerNumber: aNumber
+ "Changes the receiver's layer. If it is already part of a hierarchy, make sure that the owner's submorphs are in layer order. This can happen if you mix the use of, for example, #addMorph: and #addMorphInLayer:."
+
+ self setProperty: #morphicLayerNumber toValue: aNumber.
+ self owner ifNotNil: [:o | o reorderSubmorphsInLayers].!
Item was removed:
- ----- Method: Morph>>morphicLayerNumberWithin: (in category 'WiW support') -----
- morphicLayerNumberWithin: anOwner
-
- "helpful for insuring some morphs always appear in front of or behind others.
- smaller numbers are in front"
-
- ^(owner isNil or: [owner isWorldMorph or: [anOwner == owner]]) ifTrue: [
- self valueOfProperty: #morphicLayerNumber ifAbsent: [100]
- ] ifFalse: [
- owner morphicLayerNumber
- ].
-
- "leave lots of room for special things"!
Item was changed:
+ ----- Method: Morph>>morphsAt: (in category 'submorphs - accessing') -----
- ----- Method: Morph>>morphsAt: (in category 'submorphs-accessing') -----
morphsAt: aPoint
"Return a collection of all morphs in this morph structure that contain the given point, possibly including the receiver itself. The order is deepest embedding first."
^self morphsAt: aPoint unlocked: false!
Item was changed:
+ ----- Method: Morph>>morphsAt:behind:unlocked: (in category 'submorphs - misc') -----
- ----- Method: Morph>>morphsAt:behind:unlocked: (in category 'submorphs-accessing') -----
morphsAt: aPoint behind: aMorph unlocked: aBool
"Return all morphs at aPoint that are behind frontMorph; if aBool is true return only unlocked, visible morphs."
| isBack all tfm |
all := (aMorph isNil or: [owner isNil])
ifTrue:
["Traverse down"
(self fullBounds containsPoint: aPoint) ifFalse: [^#()].
(aBool and: [self isLocked or: [self visible not]]) ifTrue: [^#()].
nil]
ifFalse:
["Traverse up"
tfm := self transformedFrom: owner.
all := owner
morphsAt: (tfm localPointToGlobal: aPoint)
behind: self
unlocked: aBool.
WriteStream with: all].
isBack := aMorph isNil.
self submorphsDo:
[:m | | found |
isBack
ifTrue:
[tfm := m transformedFrom: self.
found := m
morphsAt: (tfm globalPointToLocal: aPoint)
behind: nil
unlocked: aBool.
found notEmpty
ifTrue:
[all ifNil: [all := WriteStream on: #()].
all nextPutAll: found]].
m == aMorph ifTrue: [isBack := true]].
(isBack and: [self containsPoint: aPoint])
ifTrue:
[all ifNil: [^Array with: self].
all nextPut: self].
^all ifNil: [#()] ifNotNil: [all contents]!
Item was changed:
+ ----- Method: Morph>>morphsAt:unlocked: (in category 'submorphs - accessing') -----
- ----- Method: Morph>>morphsAt:unlocked: (in category 'submorphs-accessing') -----
morphsAt: aPoint unlocked: aBool
+
+ ^ self morphsAt: aPoint unlocked: aBool useFullBounds: false!
- "Return a collection of all morphs in this morph structure that contain the given point, possibly including the receiver itself. The order is deepest embedding first."
- | mList |
- mList := WriteStream on: #().
- self morphsAt: aPoint unlocked: aBool do:[:m| mList nextPut: m].
- ^mList contents!
Item was changed:
+ ----- Method: Morph>>morphsAt:unlocked:do: (in category 'submorphs - enumerating') -----
- ----- Method: Morph>>morphsAt:unlocked:do: (in category 'submorphs-accessing') -----
morphsAt: aPoint unlocked: aBool do: aBlock
+
+ ^ self morphsAt: aPoint unlocked: aBool useFullBounds: false do: aBlock!
- "Evaluate aBlock with all the morphs starting at the receiver which appear at aPoint. If aBool is true take only visible, unlocked morphs into account."
-
- (self fullBounds containsPoint: aPoint) ifFalse:[^self].
- (aBool and:[self isLocked or:[self visible not]]) ifTrue:[^self].
- self submorphsDo:[:m| | tfm |
- tfm := m transformedFrom: self.
- m morphsAt: (tfm globalPointToLocal: aPoint) unlocked: aBool do: aBlock].
- (self containsPoint: aPoint) ifTrue:[aBlock value: self].!
Item was added:
+ ----- Method: Morph>>morphsAt:unlocked:useFullBounds: (in category 'submorphs - accessing') -----
+ morphsAt: aPoint unlocked: unlocked useFullBounds: useFullBounds
+ "Return a collection of all morphs in this morph structure that contain the given point, possibly including the receiver itself. The order is deepest embedding first."
+
+ ^ Array streamContents: [:stream |
+ self
+ morphsAt: aPoint
+ unlocked: unlocked
+ useFullBounds: useFullBounds
+ do: [:morph | stream nextPut: morph]]!
Item was added:
+ ----- Method: Morph>>morphsAt:unlocked:useFullBounds:do: (in category 'submorphs - enumerating') -----
+ morphsAt: aPoint unlocked: unlocked useFullBounds: useFullBounds do: aBlock
+ "Evaluate aBlock with all the morphs starting at the receiver which appear at aPoint, honoring its #fullBounds if useFullBounds is true. If unlocked is true take only visible, unlocked morphs into account."
+
+ (self fullBounds containsPoint: aPoint) ifFalse: [^ self]. "Quick exit. Do not use slower #fullContainsPoint: here."
+ (unlocked and: [self isLocked or: [self visible not]]) ifTrue: [^ self].
+
+ self submorphsDo: [:morph | | tfm |
+ tfm := morph transformedFrom: self.
+ morph
+ morphsAt: (tfm globalPointToLocal: aPoint)
+ unlocked: unlocked
+ useFullBounds: useFullBounds
+ do: aBlock].
+
+ (useFullBounds
+ ifTrue: [self fullContainsPoint: aPoint]
+ ifFalse: [self containsPoint: aPoint])
+ ifTrue: [aBlock value: self].!
Item was changed:
+ ----- Method: Morph>>morphsInFrontOf:overlapping:do: (in category 'submorphs - misc') -----
- ----- Method: Morph>>morphsInFrontOf:overlapping:do: (in category 'submorphs-accessing') -----
morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock
"Evaluate aBlock with all top-level morphs in front of someMorph that overlap with the given rectangle. someMorph is either an immediate child of the receiver or nil (in which case all submorphs of the receiver are enumerated)."
self submorphsDo:[:m|
m == someMorph ifTrue:["Try getting out quickly"
owner ifNil:[^self].
^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock].
(m fullBoundsInWorld intersects: aRectangle)
ifTrue:[aBlock value: m]].
owner ifNil:[^self].
^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock.!
Item was changed:
+ ----- Method: Morph>>morphsInFrontOverlapping: (in category 'submorphs - misc') -----
- ----- Method: Morph>>morphsInFrontOverlapping: (in category 'submorphs-accessing') -----
morphsInFrontOverlapping: aRectangle
"Return all top-level morphs in front of someMorph that overlap with the given rectangle."
| morphList |
morphList := WriteStream on: Array new.
self morphsInFrontOf: nil overlapping: aRectangle do:[:m | morphList nextPut: m].
^morphList contents!
Item was changed:
+ ----- Method: Morph>>morphsInFrontOverlapping:do: (in category 'submorphs - misc') -----
- ----- Method: Morph>>morphsInFrontOverlapping:do: (in category 'submorphs-accessing') -----
morphsInFrontOverlapping: aRectangle do: aBlock
"Evaluate aBlock with all top-level morphs in front of someMorph that overlap with the given rectangle."
^self morphsInFrontOf: nil overlapping: aRectangle do: aBlock!
Item was changed:
+ ----- Method: Morph>>noteNewOwner: (in category 'submorphs - callbacks') -----
- ----- Method: Morph>>noteNewOwner: (in category 'submorphs-accessing') -----
noteNewOwner: aMorph
"I have just been added as a submorph of aMorph"!
Item was changed:
----- Method: Morph>>openInWindowLabeled:inWorld: (in category 'initialization') -----
openInWindowLabeled: aString inWorld: aWorld
| window extent |
window := (SystemWindow labelled: aString) model: nil.
window
" guess at initial extent"
bounds: (RealEstateAgent initialFrameFor: window initialExtent: self fullBounds extent world: aWorld);
addMorph: self frame: (0@0 extent: 1@1);
updatePaneColors.
" calculate extent after adding in case any size related attributes were changed. Use
fullBounds in order to trigger re-layout of layout morphs"
+ extent := self fullBounds extent
+ + (window extent - window layoutBounds extent).
- extent := self fullBounds extent +
- (window borderWidth@window labelHeight) + window borderWidth.
window extent: extent.
aWorld addMorph: window.
window beKeyWindow.
aWorld startSteppingSubmorphsOf: window.
^window
!
Item was changed:
----- Method: Morph>>openModal: (in category 'polymorph') -----
openModal: aSystemWindow
"Open the given window locking the receiver until it is dismissed.
Answer the system window.
Restore the original keyboard focus when closed."
+ | hand priorFocus mySysWin |
+ mySysWin := self isSystemWindow
+ ifTrue: [ self ]
+ ifFalse: [ (self ownerThatIsA: SystemWindow) ifNil: [ self ] ].
+ hand := self currentHand.
+ priorFocus := hand keyboardFocus.
+ [ mySysWin modalLockTo: aSystemWindow.
+ ToolBuilder default runModal: aSystemWindow openAsIs ]
+ ensure:
+ [ mySysWin modalUnlockFrom: aSystemWindow.
+ hand newKeyboardFocus: priorFocus ].
- |area mySysWin keyboardFocus|
- keyboardFocus := self activeHand keyboardFocus.
- mySysWin := self isSystemWindow ifTrue: [self] ifFalse: [self ownerThatIsA: SystemWindow].
- mySysWin ifNil: [mySysWin := self].
- mySysWin modalLockTo: aSystemWindow.
- area := RealEstateAgent maximumUsableArea.
- aSystemWindow extent: aSystemWindow initialExtent.
- aSystemWindow position = (0@0)
- ifTrue: [aSystemWindow
- position: self activeHand position - (aSystemWindow extent // 2)].
- aSystemWindow
- bounds: (aSystemWindow bounds translatedToBeWithin: area).
- [ToolBuilder default runModal: aSystemWindow openAsIs]
- ensure: [mySysWin modalUnlockFrom: aSystemWindow.
- self activeHand newKeyboardFocus: keyboardFocus].
^aSystemWindow!
Item was changed:
+ ----- Method: Morph>>outOfWorld: (in category 'submorphs - callbacks') -----
- ----- Method: Morph>>outOfWorld: (in category 'initialization') -----
outOfWorld: aWorld
"The receiver has just appeared in a new world. Notes:
* aWorld can be nil (due to optimizations in other places)
* owner is still valid
Important: Keep this method fast - it is run whenever morphs are removed."
aWorld ifNil:[^self].
"ar 1/31/2001: We could explicitly stop stepping the receiver here but for the sake of speed I'm for now relying on the lazy machinery in the world itself."
"aWorld stopStepping: self."
self submorphsDo:[:m| m outOfWorld: aWorld].
!
Item was changed:
+ ----- Method: Morph>>ownerChanged (in category 'layout') -----
- ----- Method: Morph>>ownerChanged (in category 'change reporting') -----
ownerChanged
"This morph's owner has changed its geometry and is about to update its layout. This is a simple layout hook to update this morph's geometry according to its owner.
For more advanced strategies, use a LayoutPolicy with some LayoutProperties. See #layoutPolicy: and maybe also #doLayoutIn:."
+ self snapToEdgeIfAppropriate.
+
+ self ownerChangedHandler
+ ifNotNil: [:handler | handler cull: self].!
- self snapToEdgeIfAppropriate.!
Item was added:
+ ----- Method: Morph>>ownerChangedHandler (in category 'layout') -----
+ ownerChangedHandler
+
+ ^ self valueOfProperty: #ownerChangedHandler!
Item was added:
+ ----- Method: Morph>>ownerChangedHandler: (in category 'layout') -----
+ ownerChangedHandler: aHandler
+
+ self
+ setProperty: #ownerChangedHandler
+ toValue: aHandler.
+
+ self layoutChanged.!
Item was added:
+ ----- Method: Morph>>pointAtFraction: (in category 'geometry') -----
+ pointAtFraction: relativePoint
+ "For values between 0.0 and 1.0, answers a point that lies within the receiver's bounds. This method is a more general form of #center (meaning 0.5(a)0.5), #topLeft (meaning 0.0(a)0.0), #bottomCenter (meaning 0.5(a)1.0), etc. If can be useful for layout policies that want to position or resize their submorphs by fraction."
+
+ ^ self bounds pointAtFraction: relativePoint!
Item was changed:
----- Method: Morph>>position: (in category 'geometry') -----
position: aPoint
"Change the position of this morph, which is the top left corner of its bounds."
| delta box |
delta := (aPoint - self bounds topLeft) rounded.
"Skip drawing and layout updates for null changes."
(delta x = 0 and: [delta y = 0])
ifTrue: [^ self].
"Optimize drawing. Record one damage rectangle for short distance and two damage rectangles for large distances."
+ box := fullBounds ifNil: [self outerBounds]. "Avoid premature layout computation. Like in #extent: and #changed."
- box := self fullBounds.
(delta dotProduct: delta) > 100 "More than 10 pixels?"
ifTrue: [self
invalidRect: box;
invalidRect: (box translateBy: delta)]
ifFalse: [self
invalidRect: (box merge: (box translateBy: delta))].
"Move this morph and *all* of its submorphs."
self privateFullMoveBy: delta.
"For all known layout policies, my layout and the layout of my children is fine. Only the layout of my owner might be affected. So, tell about it."
+ self owner ifNotNil: [:o |
+ self flag: #todo. "mt: Maybe we can save a lot of effort and troubles by only calling #layoutChanged if the owner has a layout policy installed? Take the thumbs of scroll-bars as an example..."
+ o layoutChanged].!
- self owner ifNotNil: [:o | o layoutChanged].!
Item was changed:
----- Method: Morph>>primaryHand (in category 'structure') -----
primaryHand
+ ^ self currentWorld primaryHand!
- | outer |
- outer := self outermostWorldMorph ifNil: [^ nil].
- ^ outer activeHand ifNil: [outer firstHand]!
Item was changed:
----- Method: Morph>>privateAddAllMorphs:atIndex: (in category 'private') -----
privateAddAllMorphs: aCollection atIndex: index
"Private. Add aCollection of morphs to the receiver"
| myWorld otherSubmorphs offset |
(index between: 1 and: submorphs size+1)
ifFalse: [^ self error: 'index out of range'].
+ (aCollection anySatisfy: [:newMorph | self hasOwner: newMorph])
+ ifTrue: [^ self error: 'tried to add your (indirect) owner as new submorph'].
+ myWorld := self world.
- myWorld := self world.
otherSubmorphs := submorphs copyWithoutAll: aCollection.
offset := aCollection count: [:m | (submorphs indexOf: m) between: 1 and: index - 1].
submorphs := otherSubmorphs copyReplaceFrom: index-offset to: index-offset-1 with: aCollection.
aCollection do: [:m | | itsOwner itsWorld |
itsOwner := m owner.
itsOwner ifNotNil: [
itsWorld := m world.
(itsWorld == myWorld) ifFalse: [
itsWorld ifNotNil: [self privateInvalidateMorph: m].
m outOfWorld: itsWorld].
(itsOwner ~~ self) ifTrue: [
m owner privateRemove: m.
m owner removedMorph: m ]].
m privateOwner: self.
myWorld ifNotNil: [self privateInvalidateMorph: m].
(myWorld == itsWorld) ifFalse: [m intoWorld: myWorld].
itsOwner == self ifFalse: [
self addedMorph: m.
m noteNewOwner: self ].
].
self layoutChanged.
!
Item was changed:
----- Method: Morph>>privateAddMorph:atIndex: (in category 'private') -----
privateAddMorph: aMorph atIndex: index
| oldIndex myWorld itsWorld oldOwner |
+
((index >= 1) and: [index <= (submorphs size + 1)])
ifFalse: [^ self error: 'index out of range'].
+ (self hasOwner: aMorph)
+ ifTrue: [^ self error: 'tried to add your (indirect) owner as new submorph'].
myWorld := self world.
oldOwner := aMorph owner.
(oldOwner == self and: [(oldIndex := submorphs indexOf: aMorph) > 0]) ifTrue:[
"aMorph's position changes within in the submorph chain"
oldIndex < index ifTrue:[
"moving aMorph to back"
submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1.
submorphs at: index-1 put: aMorph.
] ifFalse:[
"moving aMorph to front"
oldIndex-1 to: index by: -1 do:[:i|
submorphs at: i+1 put: (submorphs at: i)].
submorphs at: index put: aMorph.
].
] ifFalse:[
"adding a new morph"
oldOwner ifNotNil:[
itsWorld := aMorph world.
itsWorld ifNotNil: [self privateInvalidateMorph: aMorph].
(itsWorld == myWorld) ifFalse: [aMorph outOfWorld: itsWorld].
oldOwner privateRemove: aMorph.
oldOwner removedMorph: aMorph.
].
aMorph privateOwner: self.
submorphs := submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph).
(itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld].
].
myWorld ifNotNil:[self privateInvalidateMorph: aMorph].
self layoutChanged.
oldOwner == self ifFalse: [
self addedMorph: aMorph.
aMorph noteNewOwner: self ].
!
Item was changed:
+ ----- Method: Morph>>privateDelete (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>privateDelete (in category 'submorphs-add/remove') -----
privateDelete
"Remove the receiver as a submorph of its owner"
owner ifNotNil:[owner removeMorph: self].!
Item was changed:
----- Method: Morph>>referencePlayfield (in category 'e-toy support') -----
referencePlayfield
"Answer the PasteUpMorph to be used for cartesian-coordinate reference"
| former |
owner ifNotNil:
[(self topRendererOrSelf owner isHandMorph and: [(former := self formerOwner) notNil])
ifTrue:
[former := former renderedMorph.
^ former isPlayfieldLike
ifTrue: [former]
ifFalse: [former referencePlayfield]]].
self allOwnersDo: [:o | o isPlayfieldLike ifTrue: [^ o]].
+ ^ Project current world!
- ^ ActiveWorld!
Item was changed:
+ ----- Method: Morph>>removeAllMorphs (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>removeAllMorphs (in category 'submorphs-add/remove') -----
removeAllMorphs
| oldMorphs myWorld |
myWorld := self world.
(fullBounds notNil or: [ myWorld notNil ]) ifTrue: [ self invalidRect: self fullBounds ].
submorphs do:
[ : m | myWorld ifNotNil: [ m outOfWorld: myWorld ].
m privateOwner: nil ].
oldMorphs := submorphs.
submorphs := Array empty.
oldMorphs do: [ : m | self removedMorph: m ].
self layoutChanged!
Item was changed:
+ ----- Method: Morph>>removeAllMorphsIn: (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>removeAllMorphsIn: (in category 'submorphs-add/remove') -----
removeAllMorphsIn: aCollection
"greatly speeds up the removal of *lots* of submorphs"
| set myWorld |
set := IdentitySet new: aCollection size * 4 // 3.
aCollection do: [:each | each owner == self ifTrue: [ set add: each]].
myWorld := self world.
(fullBounds notNil or:[myWorld notNil]) ifTrue:[self invalidRect: self fullBounds].
set do: [:m | myWorld ifNotNil: [ m outOfWorld: myWorld ]. m privateOwner: nil].
submorphs := submorphs reject: [ :each | set includes: each].
set do: [ :m | self removedMorph: m ].
self layoutChanged.
!
Item was changed:
----- Method: Morph>>removeHalo (in category 'halos and balloon help') -----
removeHalo
"remove the surrounding halo (if any)"
+ self halo ifNotNil: [ self currentHand removeHalo ]!
- self halo ifNotNil: [ self primaryHand removeHalo ]!
Item was changed:
+ ----- Method: Morph>>removeMorph: (in category 'submorphs - add/remove') -----
- ----- Method: Morph>>removeMorph: (in category 'submorphs-add/remove') -----
removeMorph: aMorph
"Remove the given morph from my submorphs"
| aWorld |
aMorph owner == self ifFalse:[^self].
aWorld := self world.
aWorld ifNotNil:[
aMorph outOfWorld: aWorld.
self privateInvalidateMorph: aMorph.
].
self privateRemove: aMorph.
aMorph privateOwner: nil.
self removedMorph: aMorph.
!
Item was changed:
----- Method: Morph>>removeProperty: (in category 'accessing - properties') -----
removeProperty: aSymbol
+ "Remove the property named aSymbol if it exists. Answer the old value or nil."
+ extension ifNil: [^ nil].
+ ^ extension removeProperty: aSymbol!
- "removes the property named aSymbol if it exists"
- extension ifNil: [^ self].
- extension removeProperty: aSymbol!
Item was changed:
+ ----- Method: Morph>>removedMorph: (in category 'submorphs - callbacks') -----
- ----- Method: Morph>>removedMorph: (in category 'submorphs-add/remove') -----
removedMorph: aMorph
"Notify the receiver that aMorph was just removed from its children"
!
Item was added:
+ ----- Method: Morph>>reorderSubmorphsInLayers (in category 'submorphs - layers') -----
+ reorderSubmorphsInLayers
+ "Update submorph order to match their respective layer numbers."
+
+ ((1 to: submorphs size - 1) allSatisfy: [:index |
+ (submorphs at: index) morphicLayerNumber
+ <= (submorphs at: index + 1) morphicLayerNumber])
+ ifTrue: [^ self "No reordering needed"].
+
+ self changed.
+ submorphs := submorphs sorted: [:m1 :m2 |
+ m1 morphicLayerNumber <= m2 morphicLayerNumber].
+ self layoutChanged; changed.!
Item was changed:
+ ----- Method: Morph>>replaceSubmorph:by: (in category 'submorphs - misc') -----
- ----- Method: Morph>>replaceSubmorph:by: (in category 'submorphs-add/remove') -----
replaceSubmorph: oldMorph by: newMorph
| index itsPosition w |
oldMorph stopStepping.
itsPosition := oldMorph referencePositionInWorld.
index := submorphs indexOf: oldMorph.
oldMorph privateDelete.
self privateAddMorph: newMorph atIndex: index.
newMorph referencePositionInWorld: itsPosition.
(w := newMorph world) ifNotNil:
[w startSteppingSubmorphsOf: newMorph]!
Item was changed:
----- Method: Morph>>resizeFromMenu (in category 'meta-actions') -----
resizeFromMenu
"Commence an interaction that will resize the receiver"
+ ^ self resizeMorph: self currentEvent!
- self resizeMorph: ActiveEvent!
Item was changed:
----- Method: Morph>>resizeMorph: (in category 'meta-actions') -----
resizeMorph: evt
| handle |
handle := HandleMorph new forEachPointDo: [:newPoint |
+ self extent: newPoint - self bounds topLeft].
- self extent: (self griddedPoint: newPoint) - self bounds topLeft].
evt hand attachMorph: handle.
handle startStepping.
!
Item was added:
+ ----- Method: Morph>>resumeAfterLayoutError (in category 'debug and other') -----
+ resumeAfterLayoutError
+ "Resume layouting after an error has occured."
+
+ self layoutPolicy: (self valueOfProperty: #errorOnLayout ifAbsent: [^ self]).
+ self removeProperty:#errorOnLayout.!
Item was changed:
+ ----- Method: Morph>>reverseTableCells (in category 'layout properties - table') -----
- ----- Method: Morph>>reverseTableCells (in category 'layout-properties') -----
reverseTableCells
"Layout specific. This property describes if the cells should be treated in reverse order of submorphs."
| props |
props := self layoutProperties.
^props ifNil:[false] ifNotNil:[props reverseTableCells].!
Item was changed:
+ ----- Method: Morph>>reverseTableCells: (in category 'layout properties - table') -----
- ----- Method: Morph>>reverseTableCells: (in category 'layout-properties') -----
reverseTableCells: aBool
"Layout specific. This property describes if the cells should be treated in reverse order of submorphs."
+ self assureTableLayoutProperties reverseTableCells: aBool.
- self assureTableProperties reverseTableCells: aBool.
self layoutChanged.!
Item was changed:
+ ----- Method: Morph>>rootMorphsAt: (in category 'submorphs - misc') -----
- ----- Method: Morph>>rootMorphsAt: (in category 'submorphs-accessing') -----
rootMorphsAt: aPoint
"Return the list of root morphs containing the given point, excluding the receiver.
ar 11/8/1999: Moved into morph for an incredibly ugly hack in 3D worlds"
self flag: #arNote. "check this at some point"
^ self submorphs select:
[:m | (m fullContainsPoint: aPoint) and: [m isLocked not]]!
Item was changed:
+ ----- Method: Morph>>rootMorphsAtGlobal: (in category 'submorphs - misc') -----
- ----- Method: Morph>>rootMorphsAtGlobal: (in category 'submorphs-accessing') -----
rootMorphsAtGlobal: aPoint
"Return the list of root morphs containing the given point, excluding the receiver.
ar 11/8/1999: Moved into morph for an incredibly ugly hack in 3D worlds"
^ self rootMorphsAt: (self pointFromWorld: aPoint)!
Item was changed:
----- Method: Morph>>rotationDegrees (in category 'rotate scale and flex') -----
rotationDegrees
- "Default implementation."
+ self isFlexed ifFalse: [^ 0.0].
+ self owner in: [:flexShell | ^ flexShell rotationDegrees].!
- ^ 0.0
- !
Item was added:
+ ----- Method: Morph>>rotationDegrees: (in category 'rotate scale and flex') -----
+ rotationDegrees: degrees
+
+ self isFlexed ifFalse: [self addFlexShell].
+ self owner in: [:flexShell | flexShell rotationDegrees: degrees].!
Item was changed:
+ ----- Method: Morph>>rubberBandCells (in category 'layout properties - table') -----
- ----- Method: Morph>>rubberBandCells (in category 'layout-properties') -----
rubberBandCells
"Layout specific. This property describes if a parent that is #shrinkWrapped around its children should ignore any #spaceFill children. E.g., when #rubberBandCells is true, the compound layout will always stay at the smallest available size, even though some child may be able to grow."
| props |
props := self layoutProperties.
^props ifNil:[false] ifNotNil:[props rubberBandCells].!
Item was changed:
+ ----- Method: Morph>>rubberBandCells: (in category 'layout properties - table') -----
- ----- Method: Morph>>rubberBandCells: (in category 'layout-properties') -----
rubberBandCells: aBool
"Layout specific. This property describes if a parent that is #shrinkWrapped around its children should ignore any #spaceFill children. E.g., when #rubberBandCells is true, the compound layout will always stay at the smallest available size, even though some child may be able to grow."
+ self assureTableLayoutProperties rubberBandCells: aBool.
- self assureTableProperties rubberBandCells: aBool.
self layoutChanged.!
Item was added:
+ ----- Method: Morph>>setDirectionFrom: (in category 'rotate scale and flex') -----
+ setDirectionFrom: aPoint
+ | delta degrees |
+ delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition.
+ degrees := delta degrees + 90.0.
+ self forwardDirection: (degrees \\ 360) rounded.
+ !
Item was changed:
----- Method: Morph>>setProperties: (in category 'accessing - properties') -----
setProperties: aList
+ "Set many properties at once from a list of prop, value, prop, value. Answer the list."
- "Set many properties at once from a list of prop, value, prop, value"
1 to: aList size by: 2 do: [:ii |
+ self setProperty: (aList at: ii) toValue: (aList at: ii+1)].
+ ^ aList!
- self setProperty: (aList at: ii) toValue: (aList at: ii+1)].!
Item was changed:
----- Method: Morph>>setProperty:toValue: (in category 'accessing - properties') -----
setProperty: aSymbol toValue: anObject
+ "Change the receiver's property named aSymbol to anObject. Answer anObject."
+ anObject ifNil: [
+ self removeProperty: aSymbol.
+ ^ anObject].
+ ^ self assureExtension setProperty: aSymbol toValue: anObject!
- "change the receiver's property named aSymbol to anObject"
- anObject ifNil: [^ self removeProperty: aSymbol].
- self assureExtension setProperty: aSymbol toValue: anObject!
Item was changed:
----- Method: Morph>>setToAdhereToEdge: (in category 'menus') -----
setToAdhereToEdge: anEdge
anEdge ifNil: [^ self].
anEdge == #none ifTrue: [^ self removeProperty: #edgeToAdhereTo].
self setProperty: #edgeToAdhereTo toValue: anEdge.
+ self layoutChanged.
!
Item was changed:
+ ----- Method: Morph>>shuffleSubmorphs (in category 'submorphs - misc') -----
- ----- Method: Morph>>shuffleSubmorphs (in category 'submorphs-accessing') -----
shuffleSubmorphs
"Randomly shuffle the order of my submorphs. Don't call this method lightly!!"
| bg |
self invalidRect: self fullBounds.
(submorphs notEmpty and: [submorphs last mustBeBackmost])
ifTrue:
[bg := submorphs last.
bg privateDelete].
submorphs := submorphs shuffled.
bg ifNotNil: [self addMorphBack: bg].
self layoutChanged!
Item was changed:
----- Method: Morph>>slideToTrash: (in category 'dropping/grabbing') -----
slideToTrash: evt
"Perhaps slide the receiver across the screen to a trash can and make it disappear into it. In any case, remove the receiver from the screen."
| aForm trash startPoint endPoint morphToSlide |
((self renderedMorph == ScrapBook default scrapBook) or: [self renderedMorph isKindOf: TrashCanMorph]) ifTrue:
[self dismissMorph. ^ self].
TrashCanMorph slideDismissalsToTrash ifTrue:
[morphToSlide := self representativeNoTallerThan: 200 norWiderThan: 200 thumbnailHeight: 100.
aForm := morphToSlide imageForm offset: (0@0).
+ trash := self currentWorld
- trash := ActiveWorld
findDeepSubmorphThat:
[:aMorph | (aMorph isKindOf: TrashCanMorph) and:
+ [aMorph topRendererOrSelf owner == self currentWorld]]
- [aMorph topRendererOrSelf owner == ActiveWorld]]
ifAbsent:
[trash := TrashCanMorph new.
+ trash position: self currentWorld bottomLeft - (0 @ (trash extent y + 26)).
- trash position: ActiveWorld bottomLeft - (0 @ (trash extent y + 26)).
trash openInWorld.
trash].
endPoint := trash fullBoundsInWorld center.
startPoint := self topRendererOrSelf fullBoundsInWorld center - (aForm extent // 2)].
self dismissMorph.
+ self currentWorld displayWorld.
- ActiveWorld displayWorld.
TrashCanMorph slideDismissalsToTrash ifTrue:
[aForm slideFrom: startPoint to: endPoint nSteps: 12 delay: 15].
ScrapBook default addToTrash: self!
Item was changed:
+ ----- Method: Morph>>spaceFillWeight (in category 'layout properties - table') -----
- ----- Method: Morph>>spaceFillWeight (in category 'layout-properties') -----
spaceFillWeight
"Layout specific. This property describes the relative weight that
should be given to the receiver when extra space is distributed
between different #spaceFill cells."
^ self
valueOfProperty: #spaceFillWeight
ifAbsent: [1]!
Item was changed:
+ ----- Method: Morph>>spaceFillWeight: (in category 'layout properties - table') -----
- ----- Method: Morph>>spaceFillWeight: (in category 'layout-properties') -----
spaceFillWeight: aNumber
"Layout specific. This property describes the relative weight that should be given to the receiver when extra space is distributed between different #spaceFill cells."
aNumber = 1
ifTrue:[self removeProperty: #spaceFillWeight]
ifFalse:[self setProperty: #spaceFillWeight toValue: aNumber].
self layoutChanged.!
Item was changed:
+ ----- Method: Morph>>submorphAfter (in category 'submorphs - misc') -----
- ----- Method: Morph>>submorphAfter (in category 'submorphs-accessing') -----
submorphAfter
"Return the submorph after (behind) me, or nil"
| ii |
owner ifNil: [^ nil].
^ (ii := owner submorphIndexOf: self) = owner submorphs size
ifTrue: [nil]
ifFalse: [owner submorphs at: ii+1].
!
Item was changed:
+ ----- Method: Morph>>submorphBefore (in category 'submorphs - misc') -----
- ----- Method: Morph>>submorphBefore (in category 'submorphs-accessing') -----
submorphBefore
"Return the submorph after (behind) me, or nil"
| ii |
owner ifNil: [^ nil].
^ (ii := owner submorphIndexOf: self) = 1
ifTrue: [nil]
ifFalse: [owner submorphs at: ii-1].
!
Item was changed:
+ ----- Method: Morph>>submorphCount (in category 'submorphs - accessing') -----
- ----- Method: Morph>>submorphCount (in category 'submorphs-accessing') -----
submorphCount
^ submorphs size!
Item was changed:
+ ----- Method: Morph>>submorphIndexOf: (in category 'submorphs - accessing') -----
- ----- Method: Morph>>submorphIndexOf: (in category 'submorphs-add/remove') -----
submorphIndexOf: aMorph
"Assuming aMorph to be one of my submorphs, answer where it occurs in my submorph list"
^ submorphs indexOf: aMorph ifAbsent: [nil]!
Item was changed:
+ ----- Method: Morph>>submorphNamed: (in category 'submorphs - accessing') -----
- ----- Method: Morph>>submorphNamed: (in category 'submorphs-accessing') -----
submorphNamed: aName
^ self submorphNamed: aName ifNone: [nil]!
Item was changed:
+ ----- Method: Morph>>submorphNamed:ifNone: (in category 'submorphs - accessing') -----
- ----- Method: Morph>>submorphNamed:ifNone: (in category 'submorphs-accessing') -----
submorphNamed: aName ifNone: aBlock
"Find the first submorph with this name, or a button with an action selector of that name"
self submorphs do: [:p | p knownName = aName ifTrue: [^p]].
self submorphs do:
[:button | | sub args |
(button respondsTo: #actionSelector)
ifTrue: [button actionSelector == aName ifTrue: [^button]].
((button respondsTo: #arguments) and: [(args := button arguments) notNil])
ifTrue: [(args at: 2 ifAbsent: [nil]) == aName ifTrue: [^button]].
(button isAlignmentMorph)
ifTrue: [(sub := button submorphNamed: aName ifNone: [nil]) ifNotNil: [^sub]]].
^aBlock value!
Item was changed:
+ ----- Method: Morph>>submorphOfClass: (in category 'submorphs - misc') -----
- ----- Method: Morph>>submorphOfClass: (in category 'submorphs-accessing') -----
submorphOfClass: aClass
^self findA: aClass!
Item was changed:
+ ----- Method: Morph>>submorphThat:ifNone: (in category 'submorphs - accessing') -----
- ----- Method: Morph>>submorphThat:ifNone: (in category 'submorphs-accessing') -----
submorphThat: block1 ifNone: block2
^submorphs detect: block1 ifNone: block2
!
Item was changed:
+ ----- Method: Morph>>submorphWithProperty: (in category 'submorphs - misc') -----
- ----- Method: Morph>>submorphWithProperty: (in category 'submorphs-accessing') -----
submorphWithProperty: aSymbol
^ submorphs detect: [:aMorph | aMorph hasProperty: aSymbol] ifNone: [nil]!
Item was changed:
+ ----- Method: Morph>>submorphs (in category 'submorphs - accessing') -----
- ----- Method: Morph>>submorphs (in category 'submorphs-accessing') -----
submorphs
"This method returns my actual submorphs collection. Modifying the collection directly could be dangerous; make a copy if you need to alter it."
^ submorphs !
Item was changed:
+ ----- Method: Morph>>submorphsBehind:do: (in category 'submorphs - enumerating') -----
- ----- Method: Morph>>submorphsBehind:do: (in category 'submorphs-accessing') -----
submorphsBehind: aMorph do: aBlock
| behind |
behind := false.
submorphs do:
[:m | m == aMorph ifTrue: [behind := true]
ifFalse: [behind ifTrue: [aBlock value: m]]].
!
Item was changed:
+ ----- Method: Morph>>submorphsDo: (in category 'submorphs - enumerating') -----
- ----- Method: Morph>>submorphsDo: (in category 'submorphs-accessing') -----
submorphsDo: aBlock
submorphs do: aBlock!
Item was changed:
+ ----- Method: Morph>>submorphsInFrontOf:do: (in category 'submorphs - enumerating') -----
- ----- Method: Morph>>submorphsInFrontOf:do: (in category 'submorphs-accessing') -----
submorphsInFrontOf: aMorph do: aBlock
| behind |
behind := false.
submorphs do:
[:m | m == aMorph ifTrue: [behind := true]
ifFalse: [behind ifFalse: [aBlock value: m]]].
!
Item was changed:
+ ----- Method: Morph>>submorphsReverseDo: (in category 'submorphs - enumerating') -----
- ----- Method: Morph>>submorphsReverseDo: (in category 'submorphs-accessing') -----
submorphsReverseDo: aBlock
submorphs reverseDo: aBlock.!
Item was changed:
+ ----- Method: Morph>>submorphsSatisfying: (in category 'submorphs - accessing') -----
- ----- Method: Morph>>submorphsSatisfying: (in category 'submorphs-accessing') -----
submorphsSatisfying: aBlock
^ submorphs select: [:m | (aBlock value: m) == true]!
Item was added:
+ ----- Method: Morph>>transferHalo: (in category 'halos and balloon help') -----
+ transferHalo: event
+
+ ^ self transferHalo: event using: self defaultHaloDispatcher!
Item was removed:
- ----- Method: Morph>>transferHalo:from: (in category 'halos and balloon help') -----
- transferHalo: event from: formerHaloOwner
- "Progressively transfer the halo to the next likely recipient"
- | localEvt w target |
-
- self flag: #workAround. "For halo's distinction between 'target' and 'innerTarget' we need to bypass any renderers."
- (formerHaloOwner == self and:[self isRenderer and:[self wantsHaloFromClick not]]) ifTrue:[
- event shiftPressed ifTrue:[
- target := owner.
- localEvt := event transformedBy: (self transformedFrom: owner).
- ] ifFalse:[
- target := self renderedMorph.
- localEvt := event transformedBy: (target transformedFrom: self).
- ].
- ^target transferHalo: localEvt from: target].
-
- " formerHaloOwner == self ifTrue:[^ self removeHalo]."
-
- "Never transfer halo to top-most world"
- (self isWorldMorph and:[owner isNil]) ifFalse:[
- (self wantsHaloFromClick and:[formerHaloOwner ~~ self])
- ifTrue:[^self addHalo: event from: formerHaloOwner]].
-
- event shiftPressed ifTrue:[
- "Pass it outwards"
- owner ifNotNil:[^owner transferHalo: event from: formerHaloOwner].
- "We're at the top level; throw the event back in to find recipient"
- formerHaloOwner removeHalo.
- ^self processEvent: event copy resetHandlerFields.
- ].
- self submorphsDo:[:m|
- localEvt := event transformedBy: (m transformedFrom: self).
- (m fullContainsPoint: localEvt position)
- ifTrue:[^m transferHalo: event from: formerHaloOwner].
- ].
- "We're at the bottom most level; throw the event back up to the root to find recipient"
- formerHaloOwner removeHalo.
-
- Preferences maintainHalos ifFalse:[
- (w := self world) ifNil: [ ^self ].
- localEvt := event transformedBy: (self transformedFrom: w) inverseTransformation.
- ^w processEvent: localEvt resetHandlerFields.
- ].
- !
Item was added:
+ ----- Method: Morph>>transferHalo:using: (in category 'halos and balloon help') -----
+ transferHalo: event using: dispatcher
+
+ ^ dispatcher dispatchHalo: event with: self!
Item was changed:
----- Method: Morph>>updateDropShadowCache (in category 'drawing') -----
updateDropShadowCache
+ "Draws the receiver's drop shadow into a separate form (or cache) to be used repeatedly in #drawDropShadowOn:, which is itself guarded via #hasDropShadow (see #fullDrawOn:).
+
+ Note that this cache is not so much about performance as it is about visual aesthetics. While the shadow itself is just one or more repeated calls to fill/frame a (rounded rectangle), we finally cut out (or mask or erase) the inner portion so that translucent receiver's wont look awkward. This is not possible with direct drawing calls to BitBlt onto Display.
+
+ Also note that with the advent of the Spur object memory (http://www.mirandabanda.org/cogblog/category/spur/) in the OpenSmalltalk VM, we got a different garbage collector (GC) that does not yet have the most efficient incremental collection strategies. As an effect, repeated invalidation of the drop-shadow cache now entails frequent full-GC pauses and thus noticeable lags (or stuttering) in the environment. This has been the case since the release of Squeak 5.0, where we started to use the Spur object memory and hence the new GC.
+
+ To make the full-GC pauses less noticeable, we started to temporarily disable the drop shadow in situations where responsiveness is importent. For example, we do this for frequently used morphs such as all system windows when being resized using their corner (or edge) grips. You can get an overview of thus points by browsing senders of #targetHadDropShadow and #hasDropShadow: (or actually the code 'hasDropShadow: false', which typically starts the temporary disabling of the shadow).
+
+ February 2022: We are currently working on improving the incremental compaction in the OpenSmalltalk VM. Once that issue has been solved, we can remove that source code that disables the drop shadow temporarily."
| shadowOffset shadowBounds offset form canvas drawBlock localBounds mask maskCanvas |
+ self flag: #hasDropShadow. "Marker for senders browsing."
+ self flag: #targetHadDropShadow. "Marker for senders browsing."
+
(shadowOffset := self shadowOffset) isRectangle
ifTrue: [
shadowBounds := 0@0 corner: (self bounds outsetBy: shadowOffset) extent.
offset := 0@0.
localBounds := shadowOffset topLeft extent: self extent ]
ifFalse: [
| extent |
extent := self extent.
shadowBounds := 0@0 corner: extent + shadowOffset abs.
offset := shadowOffset max: 0@0.
localBounds := (shadowOffset negated max: 0@0) extent: extent ].
form := Form extent: shadowBounds extent depth: Display depth.
canvas := form getCanvas.
drawBlock := self useSoftDropShadow
ifFalse: [
[:c | self wantsRoundedCorners
ifTrue: [c fillRoundRect: localBounds radius: self cornerRadius fillStyle: self shadowColor]
ifFalse: [c fillRectangle: localBounds fillStyle: self shadowColor]]]
ifTrue: [
[:c | self wantsRoundedCorners
ifTrue: [0 to: 9 do: [:i |
c
fillRoundRect: (shadowBounds insetBy: i)
radius: (self cornerRadius max: 20) -i
fillStyle: (self shadowColor alpha: self shadowColor alpha * (i+1))]]
ifFalse: [0 to: 9 do: [:i |
c
fillRoundRect: (shadowBounds insetBy: i) radius: 20-i
fillStyle: (self shadowColor alpha: self shadowColor alpha * (i+1))]]]].
canvas
translateBy: offset
during: [ :shadowCanvas | drawBlock value: shadowCanvas].
"Support transparent morph colors without having the shadow to shine through.."
mask := Form extent: shadowBounds extent depth: Display depth.
maskCanvas := mask getCanvas.
self wantsRoundedCorners
ifTrue: [maskCanvas fillRoundRect: (localBounds insetBy: self borderWidth) radius: self cornerRadius fillStyle: Color black]
ifFalse: [maskCanvas fillRectangle: (localBounds insetBy: self borderWidth) fillStyle: Color black].
mask
displayOn: form
at: 0@0
rule: Form erase.
self setProperty: #dropShadow toValue: form.!
Item was changed:
+ ----- Method: Morph>>vResizeToFit: (in category 'layout properties') -----
- ----- Method: Morph>>vResizeToFit: (in category 'layout-properties') -----
vResizeToFit: aBoolean
aBoolean ifTrue:[
self vResizing: #shrinkWrap.
] ifFalse:[
self vResizing: #rigid.
].!
Item was changed:
+ ----- Method: Morph>>vResizing (in category 'layout properties') -----
- ----- Method: Morph>>vResizing (in category 'layout-properties') -----
vResizing
"Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are:
#rigid - do not resize the receiver
#spaceFill - resize to fill owner's available space
#shrinkWrap - resize to fit children
"
| props |
props := self layoutProperties.
^props ifNil:[#rigid] ifNotNil:[props vResizing].!
Item was changed:
+ ----- Method: Morph>>vResizing: (in category 'layout properties') -----
- ----- Method: Morph>>vResizing: (in category 'layout-properties') -----
vResizing: aSymbol
"Layout specific. This property describes how the receiver should be resized with respect to its owner and its children. Possible values are:
#rigid - do not resize the receiver
#spaceFill - resize to fill owner's available space
#shrinkWrap - resize to fit children
"
self checkResizingProperty: aSymbol.
self assureLayoutProperties vResizing: aSymbol.
self layoutChanged.
!
Item was changed:
+ ----- Method: Morph>>vResizingString: (in category 'layout-menu') -----
- ----- Method: Morph>>vResizingString: (in category 'layout-properties') -----
vResizingString: aSymbol
^self layoutMenuPropertyString: aSymbol from: self vResizing!
Item was removed:
- ----- Method: Morph>>wantsDropFiles: (in category 'event handling') -----
- wantsDropFiles: anEvent
- "Return true if the receiver wants files dropped from the OS."
- ^false!
Item was changed:
+ ----- Method: Morph>>wantsToBeTopmost (in category 'e-toy support') -----
- ----- Method: Morph>>wantsToBeTopmost (in category 'accessing') -----
wantsToBeTopmost
"Answer if the receiver want to be one of the topmost objects in its owner"
^ self isFlapOrTab!
Item was changed:
----- Method: Morph>>worldBoundsForHalo (in category 'geometry - misc') -----
worldBoundsForHalo
"Answer the rectangle to be used as the inner dimension of my halos.
Allow for showing either bounds or fullBounds, and compensate for the optional bounds rectangle."
| r |
+ self deprecated: 'ct: Use SimpleHaloMorph >> #haloBoundsFor:'.
r := (Preferences haloEnclosesFullBounds)
ifFalse: [ self boundsIn: nil ]
ifTrue: [ self fullBoundsInWorld ].
Preferences showBoundsInHalo ifTrue: [ ^r outsetBy: 2 ].
^r!
Item was changed:
+ ----- Method: Morph>>wrapCentering (in category 'layout properties - table') -----
- ----- Method: Morph>>wrapCentering (in category 'layout-properties') -----
wrapCentering
"Layout specific. This property describes how the rows/columns in a list-like layout should be centered.
#topLeft - center at start of secondary direction
#bottomRight - center at end of secondary direction
#center - center in the middle of secondary direction
#justified - insert extra space inbetween rows/columns
"
| props |
props := self layoutProperties.
^props ifNil:[#topLeft] ifNotNil:[props wrapCentering].!
Item was changed:
+ ----- Method: Morph>>wrapCentering: (in category 'layout properties - table') -----
- ----- Method: Morph>>wrapCentering: (in category 'layout-properties') -----
wrapCentering: aSymbol
"Layout specific. This property describes how the rows/columns in a list-like layout should be centered.
#topLeft - center at start of secondary direction
#bottomRight - center at end of secondary direction
#center - center in the middle of secondary direction
#justified - insert extra space inbetween rows/columns
"
+ self assureTableLayoutProperties wrapCentering: aSymbol.
- self assureTableProperties wrapCentering: aSymbol.
self layoutChanged.!
Item was changed:
+ ----- Method: Morph>>wrapCenteringString: (in category 'layout-menu') -----
- ----- Method: Morph>>wrapCenteringString: (in category 'layout-properties') -----
wrapCenteringString: aSymbol
^self layoutMenuPropertyString: aSymbol from: self wrapCentering!
Item was changed:
+ ----- Method: Morph>>wrapDirection (in category 'layout properties - table') -----
- ----- Method: Morph>>wrapDirection (in category 'layout-properties') -----
wrapDirection
"Layout specific. This property describes the direction along which a list-like layout should be wrapped. Possible values are:
#leftToRight
#rightToLeft
#topToBottom
#bottomToTop
#none
indicating in which direction wrapping should occur. This direction must be orthogonal to the list direction, that is if listDirection is #leftToRight or #rightToLeft then wrapDirection must be #topToBottom or #bottomToTop and vice versa."
| props |
props := self layoutProperties.
^props ifNil:[#none] ifNotNil:[props wrapDirection].!
Item was changed:
+ ----- Method: Morph>>wrapDirection: (in category 'layout properties - table') -----
- ----- Method: Morph>>wrapDirection: (in category 'layout-properties') -----
wrapDirection: aSymbol
"Layout specific. This property describes the direction along which a list-like layout should be wrapped. Possible values are:
#leftToRight
#rightToLeft
#topToBottom
#bottomToTop
#none
indicating in which direction wrapping should occur. This direction must be orthogonal to the list direction, that is if listDirection is #leftToRight or #rightToLeft then wrapDirection must be #topToBottom or #bottomToTop and vice versa."
+ self assureTableLayoutProperties wrapDirection: aSymbol.
- self assureTableProperties wrapDirection: aSymbol.
self layoutChanged.
!
Item was changed:
+ ----- Method: Morph>>wrapDirectionString: (in category 'layout-menu') -----
- ----- Method: Morph>>wrapDirectionString: (in category 'layout-properties') -----
wrapDirectionString: aSymbol
^self layoutMenuPropertyString: aSymbol from: self wrapDirection !
Item was changed:
----- Method: Morph>>yellowButtonActivity: (in category 'event handling') -----
yellowButtonActivity: shiftState
"Find me or my outermost owner that has items to add to a
yellow button menu.
shiftState is true if the shift was pressed.
Otherwise, build a menu that contains the contributions from
myself and my interested submorphs,
and present it to the user."
| menu |
self isWorldMorph
ifFalse: [| outerOwner |
outerOwner := self outermostOwnerWithYellowButtonMenu.
outerOwner
ifNil: [^ self].
outerOwner == self
ifFalse: [^ outerOwner yellowButtonActivity: shiftState]].
+ menu := self buildYellowButtonMenu: self currentHand.
- menu := self buildYellowButtonMenu: ActiveHand.
menu
addTitle: self externalName
icon: (self iconOrThumbnailOfSize: (Preferences tinyDisplay ifTrue: [16] ifFalse: [28])).
menu popUpInWorld: self currentWorld!
Item was removed:
- ----- Method: MorphExtension>>inspectElement (in category 'other') -----
- inspectElement
- "Create and schedule an Inspector on the otherProperties and the
- named properties."
- | key obj |
- key := UIManager default chooseFrom: self sortedPropertyNames values: self sortedPropertyNames title: 'Inspect which property?'.
- key
- ifNil: [^ self].
- obj := otherProperties
- at: key
- ifAbsent: ['nOT a vALuE'].
- obj = 'nOT a vALuE'
- ifTrue: [(self perform: key) inspect
- "named properties"]
- ifFalse: [obj inspect]!
Item was changed:
----- Method: MorphExtension>>removeProperty: (in category 'accessing - other properties') -----
removeProperty: aSymbol
+ "Removes the property named aSymbol if it exists. Answer the old value or nil."
+ | value |
+ otherProperties ifNil: [^ nil].
+ value := otherProperties removeKey: aSymbol ifAbsent: [].
+ otherProperties ifEmpty: [self removeOtherProperties].
+ ^ value!
- "removes the property named aSymbol if it exists"
- otherProperties ifNil: [^ self].
- otherProperties removeKey: aSymbol ifAbsent: [].
- otherProperties isEmpty ifTrue: [self removeOtherProperties]!
Item was changed:
----- Method: MorphExtension>>setProperty:toValue: (in category 'accessing - other properties') -----
setProperty: aSymbol toValue: abObject
+ "Change the receiver's property named aSymbol to anObject. Answer anObject."
+ ^ self assureOtherProperties at: aSymbol put: abObject!
- "change the receiver's property named aSymbol to anObject"
- self assureOtherProperties at: aSymbol put: abObject!
Item was changed:
----- Method: MorphHierarchy class>>openOrDelete (in category 'opening') -----
openOrDelete
| oldMorph |
oldMorph := Project current world submorphs
detect: [:each | each hasProperty: #morphHierarchy]
ifNone: [| newMorph |
newMorph := self new asMorph.
+ newMorph bottomLeft: self currentHand position.
- newMorph bottomLeft: ActiveHand position.
newMorph openInWorld.
newMorph isFullOnScreen
ifFalse: [newMorph goHome].
^ self].
""
oldMorph delete!
Item was changed:
----- Method: MorphicDebugger class>>openOn:context:label:contents:fullView: (in category 'opening') -----
openOn: processToDebug context: context label: title contents: contentsStringOrNil fullView: full
| debugger uiBlock |
debugger := self new
process: processToDebug context: context;
errorWasInUIProcess: (Project current spawnNewProcessIfThisIsUI: processToDebug).
uiBlock := [
full
ifTrue: [debugger openFullNoSuspendLabel: title]
ifFalse: [debugger openNotifierNoSuspendContents: contentsStringOrNil label: title].
+ "Try layouting the debugger tool at least once to avoid freeze."
+ debugger topView ifNotNil: [:window |
+ "There are way too many #fullBounds sends. Layout errors might already have happened."
+ window allMorphsDo: [:m | (m hasProperty: #errorOnLayout) ifTrue: [self error: 'Layout error']].
+ window world doLayout. "Not safely!!"].
"Try drawing the debugger tool at least once to avoid freeze."
debugger topView ifNotNil: [:window | window world displayWorld. "Not safely!!"].
].
"Schedule debugging in a deferred UI message if necessary. Note that only the ui process should execute ui code."
(Project current uiProcess isActiveProcess not or: [processToDebug isActiveProcess])
+ ifFalse: uiBlock
+ ifTrue: [ | event |
+ self flag: #discuss. "mt: We need to preserve the currentEvent for #openToolsAttachedToMouseCursor ..."
+ event := self currentEvent.
+ Project current addDeferredUIMessage: [event becomeActiveDuring: uiBlock]].
- ifTrue: [Project current addDeferredUIMessage: uiBlock]
- ifFalse: uiBlock.
processToDebug suspend.
"Get here only if active process is not the process-to-debug. So in tests, use a helper process if you want to access this return value."
^ debugger!
Item was changed:
----- Method: MorphicEvent>>becomeActiveDuring: (in category 'initialize') -----
becomeActiveDuring: aBlock
+ "Make the receiver the active event during the evaluation of aBlock."
- "Make the receiver the ActiveEvent during the evaluation of aBlock."
+ ^ ActiveEventVariable value: self during: aBlock!
- | priorEvent |
- priorEvent := ActiveEvent.
- ActiveEvent := self.
- ^ aBlock ensure: [
- "check to support project switching."
- ActiveEvent == self ifTrue: [ActiveEvent := priorEvent]].!
Item was changed:
----- Method: MorphicEvent>>ignore (in category 'dispatching') -----
ignore
+ source ignoreEvent: self.!
- self wasIgnored: true.!
Item was changed:
----- Method: MorphicEvent>>timeStamp (in category 'accessing') -----
timeStamp
"Return the millisecond clock value at which the event was generated"
+ ^timeStamp ifNil:[timeStamp := Sensor eventTimeNow]!
- ^timeStamp ifNil:[timeStamp := Time eventMillisecondClock]!
Item was changed:
----- Method: MorphicEventDispatcher>>dispatchEvent:toSubmorphsOf: (in category 'support') -----
dispatchEvent: anEvent toSubmorphsOf: aMorph
"Dispatch the given event to the submorphs of the given morph. For coordinate transformations, work only with copies. Either return the given event or a copy of any filtered event to employ immutability to some extent. --- PRIVATE!!"
| localEvent filteredEvent |
aMorph submorphsDo: [:child |
localEvent := anEvent transformedBy: (child transformedFrom: aMorph).
+ filteredEvent := child processEvent: localEvent.
+ filteredEvent == #rejected ifFalse: [ "some event or #rejected symbol or any other object"
+ filteredEvent isMorphicEvent ifFalse: [filteredEvent := localEvent].
- filteredEvent := child
- processEvent: localEvent
- using: self. "use same dispatcher"
- filteredEvent == #rejected ifFalse: [ "some event or #rejected symbol"
self flag: #overlappingChildren. "mt: We cannot give two overlapping siblings the chance to handle the event!!"
^ self nextFromOriginal: anEvent local: localEvent filtered: filteredEvent]].
^ #rejected!
Item was changed:
----- Method: MorphicEventDispatcher>>dispatchFocusEventAllOver:with: (in category 'focus events') -----
dispatchFocusEventAllOver: evt with: focusMorph
"Like a full event dispatch BUT adds regular dispatch if the focus morph did nothing with the event. This is useful for letting the focusMorph's siblings handle the events instead. Take halo invocation as an example. See senders of me."
| result hand mouseFocus |
result := self dispatchFocusEventFully: evt with: focusMorph.
+ evt isMouseOver ifTrue: [^ result].
+
result == #rejected ifTrue: [^ result].
result wasIgnored ifTrue: [^ result].
result wasHandled ifTrue: [^ result].
- focusMorph world ifNil: [ ^ result ].
hand := evt hand.
mouseFocus := hand mouseFocus.
[
"Avoid re-dispatching the event to the focus morph. See Morph >> #rejectsEvent:."
focusMorph lock.
-
- "Handle side effect for mouse-enter and mouse-leave events."
- self flag: #hacky. "mt: Maybe we find a better way to synthesize enter/leave events in the future."
hand newMouseFocus: nil.
- hand mouseOverHandler processMouseOver: hand lastEvent.
+ "Give the event's hand a chance to normally dispatch it."
+ ^ hand handleEvent: evt
- "Give the morph's world a chance to normally dispatch the event."
- ^ focusMorph world ifNotNil: [ : world | world processEvent: evt using: self]
] ensure: [
focusMorph unlock.
+ hand newMouseFocus: mouseFocus].!
- evt hand newMouseFocus: mouseFocus].!
Item was added:
+ Object subclass: #MorphicHaloDispatcher
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Events'!
Item was added:
+ ----- Method: MorphicHaloDispatcher>>dispatchHalo:createFor: (in category 'dispatching') -----
+ dispatchHalo: anEvent createFor: aContainer
+ "Invoke a halo on any aContainer's submorph that wants it. Dispatch uses anEvent's #position. The dispatch only ends in that container if no other morph wants it. Note that the event's #shiftPressed state determines whether the dispatch goes innermost-to-outermost (if pressed) or the other way around (if not pressed).
+
+ If there already is a halo, check whether the event still points into the same hierarchy. If it does, do nothing here but rely on the halo itself to process the event (see implementors of #transferHalo:from:). If, however, the event points to a different hierarchy in the container, invoke a new halo and discard the current one. We do this here because the current halo should not bother with its container but only its #target."
+
+ | stack innermost haloTarget |
+ "The stack is the frontmost (i.e. innermost) to backmost (i.e. outermost) morph."
+ stack := (aContainer morphsAt: anEvent position unlocked: true useFullBounds: true) select:
+ [ : each | each wantsHaloFromClick or: [ each isRenderer ] ].
+ "self assert: [ stack last == aContainer ]."
+ innermost := anEvent hand halo
+ ifNil: [ stack first ]
+ ifNotNil:
+ [ : existingHalo |
+ "self assert: [ existingHalo wantsHaloFromClick not ]. "
+ stack
+ detect: [ : each | each owner == aContainer
+ and: [ existingHalo bounds intersects: (existingHalo haloBoundsFor: each) ] ]
+ ifFound:
+ [ : topInContainer | "Is existingHalo's target part of the same topInContainer as the morph clicked?"
+ (existingHalo target withAllOwners includes: topInContainer)
+ ifTrue: [ "same hierarchy, let #transferHalo: continue to handle it for now." ^ false ]
+ ifFalse:
+ [ "different hierarchy, remove + add."
+ anEvent hand removeHalo.
+ anEvent shiftPressed
+ ifTrue: [ stack first ]
+ ifFalse: [ topInContainer ] ] ]
+ ifNone: [ "existingHalo is on the World, defer to #transferHalo: for now." ^ false ] ].
+
+ "If modifier key is pressed, start at innermost (the target), otherwise the outermost (direct child of the world (self))."
+ haloTarget := (innermost == aContainer or: [ anEvent shiftPressed ])
+ ifTrue: [ innermost ]
+ ifFalse:
+ [ "Find the outermost owner that wants it. Ignore containment above aContainer."
+ stack := innermost withAllOwners.
+ (stack first: (stack findFirst: [ : each | each owner == aContainer ])) reversed
+ detect: [ : each | each wantsHaloFromClick or: [ each isRenderer ] ]
+ ifNone: [ "haloTarget has its own mouseDown handler, don't halo." ^ false ] ].
+ "Now that we have the haloTarget, show the halo."
+ self invokeHaloOrMove: anEvent on: haloTarget.
+ ^ true!
Item was added:
+ ----- Method: MorphicHaloDispatcher>>dispatchHalo:transferFrom: (in category 'dispatching') -----
+ dispatchHalo: event transferFrom: morph
+ "Progressively transfer the halo to the next likely recipient"
+
+ ^ event shiftPressed
+ ifTrue: [self dispatchHalo: event transferOutwardsFrom: morph]
+ ifFalse: [self dispatchHalo: event transferInwardsFrom: morph]!
Item was added:
+ ----- Method: MorphicHaloDispatcher>>dispatchHalo:transferInwardsFrom: (in category 'dispatching') -----
+ dispatchHalo: event transferInwardsFrom: currentTarget
+
+ | localEvent world |
+ "Note that a halo usually attaches to the outermost (or top) renderer in a composition around the rendered morph. Thus, we have to lookup that inner (or rendered) morph first when transferring the halo inwards in the hierarchy of submorphs."
+ currentTarget renderedMorph submorphsDo: [:nextTarget |
+ localEvent := event transformedBy: (nextTarget transformedFrom: currentTarget).
+ (nextTarget fullContainsPoint: localEvent position) ifTrue: [
+ ^ nextTarget renderedMorph wantsHaloFromClick
+ ifTrue: [self invokeHalo: localEvent on: nextTarget]
+ ifFalse: [self dispatchHalo: localEvent transferInwardsFrom: nextTarget]]].
+
+ "We're at the bottom most level; throw the event back up to the root to find recipient"
+ event hand removeHalo.
+ Preferences maintainHalos ifFalse: [
+ (world := currentTarget world) ifNil: [ ^ false ].
+ localEvent := event transformedBy: (currentTarget transformedFrom: world) inverseTransformation.
+ world processEvent: localEvent resetHandlerFields].
+
+ ^ false!
Item was added:
+ ----- Method: MorphicHaloDispatcher>>dispatchHalo:transferOutwardsFrom: (in category 'dispatching') -----
+ dispatchHalo: event transferOutwardsFrom: currentTarget
+
+ | localEvent |
+ "Note that a halo usually handles composite renderers through the outermost (or top) renderer. So, we can directly use the renderer's owner to transfer a halo outwards in the hierarchy of morphs."
+ "self assert: [currentTarget == currentTarget topRendererOrSelf]."
+ currentTarget owner ifNotNil: [:nextTarget |
+ localEvent := event transformedBy: (currentTarget transformedFrom: nextTarget).
+ "Never transfer halo to top-most world"
+ ^ (nextTarget isWorldMorph not and: [nextTarget wantsHaloFromClick])
+ ifTrue: [self invokeHalo: localEvent on: nextTarget]
+ ifFalse: [self dispatchHalo: localEvent transferOutwardsFrom: nextTarget]].
+
+ "We're at the top level; throw the event back in to find recipient"
+ event hand removeHalo.
+ currentTarget isWorldMorph
+ ifTrue: [currentTarget processEvent: event copy resetHandlerFields].
+
+ ^ false!
Item was added:
+ ----- Method: MorphicHaloDispatcher>>dispatchHalo:with: (in category 'dispatching') -----
+ dispatchHalo: anEvent with: aMorph
+
+ | halo successful |
+ halo := anEvent hand halo.
+ successful := (halo isNil or: [halo target ~~ aMorph])
+ ifTrue: [self dispatchHalo: anEvent createFor: aMorph]
+ ifFalse: [self dispatchHalo: anEvent transferFrom: aMorph].
+ successful ifTrue: [
+ self assert: [halo ~~ anEvent hand halo].
+ anEvent hand halo setProperty: #lastHaloDispatcher toValue: self].
+ ^ successful!
Item was added:
+ ----- Method: MorphicHaloDispatcher>>invokeHalo:on: (in category 'invoking') -----
+ invokeHalo: anEvent on: aMorph
+
+ aMorph addHalo: anEvent.
+ ^ true!
Item was added:
+ ----- Method: MorphicHaloDispatcher>>invokeHaloOrMove:on: (in category 'invoking') -----
+ invokeHaloOrMove: anEvent on: aMorph
+ "Special gestures (cmd-mouse on the Macintosh; Alt-mouse on Windows and Unix) allow a mouse-sensitive morph to be moved or bring up a halo for the morph."
+ | h doNotDrag |
+ anEvent hand newMouseFocus: aMorph event: anEvent.
+ h := anEvent hand halo.
+ "Prevent wrap around halo transfers originating from throwing the event back in"
+ doNotDrag := false.
+ h ifNotNil:[
+ (h innerTarget == aMorph) ifTrue:[doNotDrag := true].
+ (h innerTarget hasOwner: aMorph) ifTrue:[doNotDrag := true].
+ (aMorph hasOwner: h target) ifTrue:[doNotDrag := true]].
+
+ h := aMorph addHalo: anEvent.
+ h setProperty: #lastHaloDispatcher toValue: self.
+ doNotDrag ifTrue:[^ true].
+ "Initiate drag transition if requested"
+ anEvent hand
+ waitForClicksOrDrag: h
+ event: anEvent
+ selectors: { nil. nil. nil. #startDragTarget:. }
+ threshold: HandMorph dragThreshold.
+ "Pass focus explicitly here"
+ anEvent hand newMouseFocus: h.
+ "Reset temporary cursors to make available halo interaction visible."
+ anEvent hand showTemporaryCursor: nil.
+ ^ true!
Item was changed:
----- Method: MorphicModel class>>acceptsLoggingOfCompilation (in category 'compiling') -----
acceptsLoggingOfCompilation
"Dont log sources for my automatically-generated subclasses. Can easily switch this back when it comes to deal with Versions, etc."
+ ^super acceptsLoggingOfCompilation
+ and:
+ [self == MorphicModel
+ or:
+ [(name last isDigit) not]]!
- ^ self == MorphicModel or: [(name last isDigit) not]!
Item was changed:
+ ----- Method: MorphicModel>>allKnownNames (in category 'submorphs - accessing') -----
- ----- Method: MorphicModel>>allKnownNames (in category 'submorphs-accessing') -----
allKnownNames
"Return a list of all known names based on the scope of the receiver. If the receiver is a member of a uniclass, incorporate the original 1997 logic that queries the known names of the values of all the instance variables."
| superNames |
superNames := super allKnownNames. "gather them from submorph tree"
^self belongsToUniClass
ifTrue:
[superNames , (self instanceVariableValues
select: [:e | e notNil and: [e knownName notNil]]
thenCollect: [:e | e knownName])]
ifFalse: [superNames]!
Item was changed:
+ ----- Method: MorphicModel>>delete (in category 'submorphs - add/remove') -----
- ----- Method: MorphicModel>>delete (in category 'submorphs-add/remove') -----
delete
(model isMorphicModel) ifFalse: [^super delete].
slotName ifNotNil:
[(UIManager default confirm: 'Shall I remove the slot ' , slotName
, '
along with all associated methods?')
ifTrue:
[(model class selectors select: [:s | s beginsWith: slotName])
do: [:s | model class removeSelector: s].
(model class instVarNames includes: slotName)
ifTrue: [model class removeInstVarName: slotName]]
ifFalse:
[(UIManager default
confirm: '...but should I at least dismiss this morph?
[choose no to leave everything unchanged]')
ifFalse: [^self]]].
super delete!
Item was changed:
----- Method: MorphicModel>>use:orMakeModelSelectorFor:in: (in category 'compilation') -----
use: cachedSelector orMakeModelSelectorFor: selectorBody in: selectorBlock
| selector |
model ifNil: [^ nil].
cachedSelector ifNil:
["Make up selector from slotname if any"
selector := (slotName ifNil: [selectorBody]
ifNotNil: [slotName , selectorBody]) asSymbol.
(model class canUnderstand: selector) ifFalse:
[(self confirm: 'Shall I compile a null response for'
, Character cr asString
, model class name , '>>' , selector)
ifFalse: [self halt].
model class compile: (String streamContents:
+ [:s | selector keywords withIndexDo:
- [:s | selector keywords doWithIndex:
[:k :i | s nextPutAll: k , ' arg' , i printString].
s cr; nextPutAll: '"Automatically generated null response."'.
s cr; nextPutAll: '"Add code below for appropriate behavior..."'.])
classified: 'input events'
notifying: nil]]
ifNotNil:
[selector := cachedSelector].
^ selectorBlock value: selector!
Item was changed:
Project subclass: #MorphicProject
instanceVariableNames: 'uiProcess'
+ classVariableNames: 'DefaultFill HarmonizeFonts ShowResizeGrips UseCompactButtons UseCompactLists UseCompactTextFields'
+ poolDictionaries: 'AbstractResizerMorph'
- classVariableNames: 'DefaultFill'
- poolDictionaries: ''
category: 'Morphic-Support'!
!MorphicProject commentStamp: 'dtl 7/13/2013 15:40' prior: 0!
An MorphicProject is a project with a Morphic user interface. Its world is a PasteUpMorph, and its UI manager is a MorphicUIManager. It uses a MorphicToolBuilder to create the views for various tools. It has a single uiProcess for its world, and Morph updates and user interaction occur in the context of that UI process.
!
Item was added:
+ ----- Method: MorphicProject class>>applyUserInterfaceTheme (in category 'preferences') -----
+ applyUserInterfaceTheme
+
+ self current addDeferredUIMessage: [
+ "After all immediate changes where applied, we can reset to values that match the current world configuration:"
+ self worldGridOrigin: nil.
+ self worldGridModulus: nil.
+ self worldGridEnabled
+ ifTrue: [self current world firstHand turnOnGridding]].!
Item was added:
+ ----- Method: MorphicProject class>>useCompactButtons (in category 'preferences - accessibility') -----
+ useCompactButtons
+ <preference: 'Compact button widgets'
+ categoryList: #('Morphic' 'Tools' 'Accessibility')
+ description: 'When true, make the buttons only as high as the current button font with the usual extra margins.'
+ type: #Boolean>
+
+ ^ UseCompactButtons ifNil: [false]!
Item was added:
+ ----- Method: MorphicProject class>>useCompactButtons: (in category 'preferences - accessibility') -----
+ useCompactButtons: aBooleanOrNil
+
+ UseCompactButtons = aBooleanOrNil ifTrue: [^ self].
+ UseCompactButtons := aBooleanOrNil.
+
+ " UserInterfaceTheme current basicApply."!
Item was added:
+ ----- Method: MorphicProject class>>useCompactLists (in category 'preferences - accessibility') -----
+ useCompactLists
+ <preference: 'Compact list/tree/menu widgets'
+ categoryList: #('Morphic' 'Tools' 'Accessibility')
+ description: 'When true, ignore the #lineGrid of the current list font when computing the list layout and other geometry properties. Does not interfere with the layout of text fields. Also makes the window title more compact.'
+ type: #Boolean>
+
+ ^ UseCompactLists ifNil: [false]!
Item was added:
+ ----- Method: MorphicProject class>>useCompactLists: (in category 'preferences') -----
+ useCompactLists: aBooleanOrNil
+
+ UseCompactLists = aBooleanOrNil ifTrue: [^ self].
+ UseCompactLists := aBooleanOrNil.
+
+ AbstractFont allSubInstancesDo: [:font | font reset "except glyph caches"].
+ UserInterfaceTheme current basicApply.!
Item was added:
+ ----- Method: MorphicProject class>>useCompactTextFields (in category 'preferences - accessibility') -----
+ useCompactTextFields
+ <preference: 'Compact text fields'
+ categoryList: #('Morphic' 'Tools' 'Accessibility')
+ description: 'When true, do not add extra spacing to better see the current theme''s keyboard-focus indication. Will be mostly noticeable in one-line text fields.'
+ type: #Boolean>
+
+ ^ UseCompactTextFields ifNil: [false]!
Item was added:
+ ----- Method: MorphicProject class>>useCompactTextFields: (in category 'preferences - accessibility') -----
+ useCompactTextFields: aBooleanOrNil
+
+ UseCompactTextFields = aBooleanOrNil ifTrue: [^ self].
+ UseCompactTextFields := aBooleanOrNil.
+
+ "Discard cached margins for text fields."
+ MorphicToolBuilder applyUserInterfaceTheme.
+ TheWorldMainDockingBar updateInstances.!
Item was added:
+ ----- Method: MorphicProject class>>worldGridEnabled (in category 'preferences') -----
+ worldGridEnabled
+ <preference: 'Snap Morphs to World Grid'
+ categoryList: #('Morphic' 'Tools')
+ description: 'When true, morphs placed in the world will align with a regular grid. This includes tool windows.'
+ type: #Boolean>
+
+ | world |
+ world := self current world.
+ ^ self current isMorphic and: [world layoutPolicy notNil and: [world layoutPolicy isGridLayout]]!
Item was added:
+ ----- Method: MorphicProject class>>worldGridEnabled: (in category 'preferences') -----
+ worldGridEnabled: aBooleanOrNil
+
+ (aBooleanOrNil ifNil: [false])
+ ifTrue: [self current world layoutPolicy: GridLayout new]
+ ifFalse: [self current world layoutPolicy: nil].
+
+ "Auto-configure origin and modulus to match world properties."
+ self worldGridOrigin: nil.
+ self worldGridModulus: nil.
+
+ "Snap to grid when dragging something."
+ self worldGridEnabled
+ ifTrue: [self current world firstHand turnOnGridding]
+ ifFalse: [self current world firstHand turnOffGridding].!
Item was added:
+ ----- Method: MorphicProject class>>worldGridModulus (in category 'preferences') -----
+ worldGridModulus
+ <preference: 'World Grid Modulus'
+ categoryList: #('Morphic' 'Tools')
+ description: 'Configures the cell extent of the world''s grid, which is useful to accommodate screen resolution and personal style.'
+ type: #String>
+
+ ^ self current isMorphic
+ ifFalse: [0@0]
+ ifTrue: [self current world gridModulus]!
Item was added:
+ ----- Method: MorphicProject class>>worldGridModulus: (in category 'preferences') -----
+ worldGridModulus: aPointOrCode
+
+ | value |
+ self current isMorphic ifFalse: [^ self].
+ value := (aPointOrCode isString ifTrue: [Compiler evaluate: aPointOrCode]) ifNil: [(self current world clearArea width // 60 "num cells") asPoint].
+ value isPoint ifFalse: [^ self].
+ self current world gridModulus: value.!
Item was added:
+ ----- Method: MorphicProject class>>worldGridOrigin (in category 'preferences') -----
+ worldGridOrigin
+ <preference: 'World Grid Origin'
+ categoryList: #('Morphic' 'Tools')
+ description: 'Configures the offset of the world''s grid, which is useful to accommodate docking bars and other edge-adhering morphs.'
+ type: #String>
+
+ ^ self current isMorphic
+ ifFalse: [0@0]
+ ifTrue: [self current world gridOrigin]!
Item was added:
+ ----- Method: MorphicProject class>>worldGridOrigin: (in category 'preferences') -----
+ worldGridOrigin: aPointOrCode
+
+ | value |
+ self current isMorphic ifFalse: [^ self].
+ value := (aPointOrCode isString ifTrue: [Compiler evaluate: aPointOrCode]) ifNil: [self current world clearArea origin].
+ value isPoint ifFalse: [^ self].
+ self current world gridOrigin: value. !
Item was changed:
----- 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 ifNotNil:
+ [details
+ at: 'projectname'
+ ifPresent: [ :newName | self renameTo: newName]]!
- details at: 'projectname' ifPresent: [ :newName |
- self renameTo: newName]!
Item was changed:
----- Method: MorphicProject>>canApplyUserInterfaceTheme (in category 'updating') -----
canApplyUserInterfaceTheme
+ ^ world notNil!
- ^ true!
Item was changed:
----- Method: MorphicProject>>chooseNaturalLanguage (in category 'language') -----
chooseNaturalLanguage
"Put up a menu allowing the user to choose the natural language for the project"
| aMenu availableLanguages |
aMenu := MenuMorph new defaultTarget: self.
aMenu addTitle: 'choose language' translated.
aMenu lastItem setBalloonText: 'This controls the human language in which tiles should be viewed. It is potentially extensible to be a true localization mechanism, but initially it only works in the classic tile scripting system. Each project has its own private language choice' translated.
Preferences noviceMode
ifFalse:[aMenu addStayUpItem].
availableLanguages := NaturalLanguageTranslator availableLanguageLocaleIDs
sorted:[:x :y | x displayName < y displayName].
availableLanguages do:
[:localeID |
+ aMenu addUpdating: #stringForLanguageNameIs: target: Locale selector: #switchToID: argumentList: {localeID}].
- aMenu addUpdating: #stringForLanguageNameIs: target: Locale selector: #switchAndInstallFontToID: argumentList: {localeID}].
aMenu popUpInWorld
"Project current chooseNaturalLanguage"!
Item was changed:
----- Method: MorphicProject>>clearGlobalState (in category 'enter') -----
clearGlobalState
+ "Clean up global state. This method may be removed if the use of global state variables is eliminated."
- "Clean up global state. The global variables World, ActiveWorld, ActiveHand
- and ActiveEvent provide convenient access to the state of the active project
- in Morphic. Clear their prior values when leaving an active project. This
- method may be removed if the use of global state variables is eliminated."
+ "If global World is defined, clear it now. The value is expected to be set again as a new project is entered."
+ Smalltalk globals at: #World ifPresent: [:w |
+ Smalltalk globals at: #World put: nil].!
- "If global World is defined, clear it now. The value is expected to be set
- again as a new project is entered."
- Smalltalk globals at: #World
- ifPresent: [ :w | Smalltalk globals at: #World put: nil ].
- ActiveWorld := ActiveHand := ActiveEvent := nil.
- !
Item was changed:
----- Method: MorphicProject>>createViewIfAppropriate (in category 'utilities') -----
createViewIfAppropriate
"Create a project view for the receiver and place it appropriately on the screen."
| aMorph requiredWidth existing proposedV proposedH despair |
ProjectViewOpenNotification signal ifTrue:
[Preferences projectViewsInWindows
ifTrue:
[(ProjectViewMorph newProjectViewInAWindowFor: self) openInWorld]
ifFalse:
[aMorph := ProjectViewMorph on: self.
requiredWidth := aMorph width + 10.
+ existing := self currentWorld submorphs
- existing := ActiveWorld submorphs
select: [:m | m isKindOf: ProjectViewMorph]
thenCollect: [:m | m fullBoundsInWorld].
proposedV := 85.
proposedH := 10.
despair := false.
[despair not and: [((proposedH @ proposedV) extent: requiredWidth) intersectsAny: existing]] whileTrue:
[proposedH := proposedH + requiredWidth.
+ proposedH + requiredWidth > self currentWorld right ifTrue:
- proposedH + requiredWidth > ActiveWorld right ifTrue:
[proposedH := 10.
proposedV := proposedV + 90.
+ proposedV > (self currentWorld bottom - 90)
- proposedV > (ActiveWorld bottom - 90)
ifTrue:
+ [proposedH := self currentWorld center x - 45.
+ proposedV := self currentWorld center y - 30.
- [proposedH := ActiveWorld center x - 45.
- proposedV := ActiveWorld center y - 30.
despair := true]]].
aMorph position: (proposedH @ proposedV).
aMorph openInWorld]]!
Item was changed:
----- Method: MorphicProject>>currentVocabulary (in category 'protocols') -----
currentVocabulary
+ ^ self world currentVocabulary!
- ^ActiveWorld currentVocabulary!
Item was added:
+ ----- Method: MorphicProject>>displayScaleChangedFrom:to: (in category 'display') -----
+ displayScaleChangedFrom: oldFactor to: newFactor
+ "Update Morphic-specific geometry. Try to be more efficient than UI theme's #applyUserInterfaceTheme."
+
+ super displayScaleChangedFrom: oldFactor to: newFactor.
+
+ "Switching UI themes involves updating geometry for different fonts anyway. Maybe we can speed up this at some point by avoiding to refresh non-geometry properties such as colors."
+ UserInterfaceTheme current
+ basicApply;
+ scaleMorphicToolsBy: newFactor / oldFactor.
+ !
Item was changed:
----- Method: MorphicProject>>finalEnterActions: (in category 'enter') -----
finalEnterActions: leavingProject
"Perform the final actions necessary as the receiver project is entered"
| navigator armsLengthCmd navType thingsToUnhibernate |
"If this image has a global World variable, update it now"
Smalltalk globals at: #World
ifPresent: [ :w | Smalltalk globals at: #World put: world ].
world install.
world transferRemoteServerFrom: leavingProject world.
"(revertFlag | saveForRevert | forceRevert) ifFalse: [
(Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [
self storeSomeSegment]]."
"Transfer event recorder to me."
leavingProject isMorphic ifTrue: [
leavingProject world pauseEventRecorder ifNotNil: [:rec |
rec resumeIn: world]].
world triggerOpeningScripts.
self initializeMenus.
self projectParameters
at: #projectsToBeDeleted
ifPresent: [ :projectsToBeDeleted |
self removeParameter: #projectsToBeDeleted.
projectsToBeDeleted do: [:each | each delete]].
+ Locale switchToID: self localeID.
- Locale switchAndInstallFontToID: self localeID.
thingsToUnhibernate := world valueOfProperty: #thingsToUnhibernate ifAbsent: [#()].
thingsToUnhibernate do: [:each | each unhibernate].
world removeProperty: #thingsToUnhibernate.
navType := ProjectNavigationMorph preferredNavigator.
armsLengthCmd := self parameterAt: #armsLengthCmd ifAbsent: [nil].
navigator := world findA: navType.
(Preferences classicNavigatorEnabled and: [Preferences showProjectNavigator and: [navigator isNil]]) ifTrue:
[(navigator := navType new)
bottomLeft: world bottomLeft;
openInWorld: world].
navigator notNil & armsLengthCmd notNil ifTrue:
[navigator color: Color lightBlue].
armsLengthCmd notNil ifTrue:
[Preferences showFlapsWhenPublishing
ifFalse:
[self flapsSuppressed: true.
navigator ifNotNil: [navigator visible: false]].
armsLengthCmd openInWorld: world].
world reformulateUpdatingMenus.
world presenter positionStandardPlayer.
self assureMainDockingBarPresenceMatchesPreference.
world repairEmbeddedWorlds.!
Item was changed:
----- Method: MorphicProject>>finalExitActions: (in category 'enter') -----
finalExitActions: enteringProject
world triggerClosingScripts.
"Pause sound players, subject to preference settings"
(world hasProperty: #letTheMusicPlay)
ifTrue: [world removeProperty: #letTheMusicPlay]
ifFalse: [SoundService stop].
world sleep.
(world findA: ProjectNavigationMorph)
ifNotNil: [:navigator | navigator retractIfAppropriate].
self clearGlobalState.
+ EventSensor default flushEvents.
- Sensor flushAllButDandDEvents.
self world submorphsDo: [:ea | ea removeProperty: #dropShadow].!
Item was changed:
----- Method: MorphicProject>>initialize (in category 'initialize') -----
initialize
"Initialize a new Morphic Project"
+
super initialize.
+
world := PasteUpMorph newWorldForProject: self.
self setWorldBackground: true.
+
Locale switchToID: CurrentProject localeID.
+ Preferences useVectorVocabulary ifTrue: [world installVectorVocabulary].
+
+ Project current isMorphic ifTrue: [
+ "Only trigger tool builders etc. if we are already in the same kind of project because there is global state that cannot yet be configured in a dynamic scope such as 'ToolBuilder default'."
+ self assureMainDockingBarPresenceMatchesPreference].!
- Preferences useVectorVocabulary ifTrue: [world installVectorVocabulary]!
Item was changed:
----- Method: MorphicProject>>interruptCleanUpFor: (in category 'scheduling & debugging') -----
interruptCleanUpFor: interruptedProcess
"Clean up things in case of a process interrupt."
super interruptCleanUpFor: interruptedProcess.
self uiProcess == interruptedProcess ifTrue: [
+ self currentHand ifNotNil: [:hand | hand interrupted].
+ world removeProperty: #shouldDisplayWorld.
+ Preferences eToyFriendly ifTrue: [world stopRunningAll]].!
- ActiveHand ifNotNil: [ActiveHand interrupted].
- ActiveWorld := world. "reinstall active globals"
- ActiveHand := world primaryHand.
- ActiveHand interrupted. "make sure this one's interrupted too"
- ActiveEvent := nil.
-
- Preferences eToyFriendly
- ifTrue: [Project current world stopRunningAll]].!
Item was added:
+ ----- Method: MorphicProject>>lastDeferredUIMessage (in category 'scheduling & debugging') -----
+ lastDeferredUIMessage
+ "Answer the most recently scheduled deferredUIMessage."
+
+ ^WorldState lastDeferredUIMessage!
Item was added:
+ ----- Method: MorphicProject>>launchSystemFiles:event: (in category 'utilities') -----
+ launchSystemFiles: fileStreams event: genericMorphicEvent
+ "Handle a number of files the singleton VM was invoked with again."
+
+ self flag: #todo. "Do something more useful with the image here, e. g. tell the VM to load it."
+ self inform: ('Cannot start a second instance of Squeak\with the image "{1}"\because the VM is configured as singleton application.' translated withCRs format: {fileStreams first localName}).!
Item was changed:
----- Method: MorphicProject>>loadFromServer: (in category 'file in/out') -----
loadFromServer: newerAutomatically
"If a newer version of me is on the server, load it."
| pair resp server |
self assureIntegerVersion.
self isCurrentProject ifTrue: ["exit, then do the command"
^ self armsLengthCommand: #loadFromServer withDescription: 'Loading' translated
].
server := self tryToFindAServerWithMe ifNil: [^ nil].
pair := self class mostRecent: self name onServer: server.
pair first ifNil: [^ self inform: ('can''t find file on server for {1}' translated format: {self name})].
self currentVersionNumber > pair second ifTrue: [
^ self inform: ('That server has an older version of the project.' translated)].
version = (Project parseProjectFileName: pair first) second ifTrue: [
resp := (UIManager default chooseFrom:
(Array with: 'Reload anyway' translated
with: 'Cancel' translated withCRs)
title: 'The only changes are the ones you made here.' translated).
resp ~= 1 ifTrue: [^ nil]
] ifFalse: [
newerAutomatically ifFalse: [
resp := (UIManager default
+ chooseFrom: {'Load it' translated. 'Cancel' translated}
+ title: 'A newer version exists on the server.' translated).
- chooseFrom: #('Load it' 'Cancel')
- title: 'A newer version exists on the server.').
resp ~= 1 ifTrue: [^ nil]
].
].
"let's avoid renaming the loaded change set since it will be replacing ours"
self projectParameters at: #loadingNewerVersion put: true.
ComplexProgressIndicator new
targetMorph: nil;
historyCategory: 'project loading';
withProgressDo: [
ProjectLoading
installRemoteNamed: pair first
from: server
named: self name
in: parentProject
+ ]!
- ]
- !
Item was changed:
----- Method: MorphicProject>>makeThumbnail (in category 'menu messages') -----
makeThumbnail
"Make a thumbnail image of this project from the Display."
world displayWorldSafely. "clean pending damage"
+ super makeThumbnail.
+ (Smalltalk at: #InternalThreadNavigationMorph) ifNotNil: [:tnMorph |
+ tnMorph cacheThumbnailFor: self].
+ ^ thumbnail!
- ^super makeThumbnail.!
Item was changed:
----- Method: MorphicProject>>previewImageForm (in category 'display') -----
previewImageForm
+ ^ self world imageForm scaledToSize: self viewSize!
- ^ self world imageForm!
Item was changed:
----- Method: MorphicProject>>setFlaps (in category 'flaps support') -----
setFlaps
| flapTabs flapIDs sharedFlapTabs navigationMorph |
self flag: #toRemove. "check if this method still used by Etoys"
+ flapTabs := self world flapTabs.
- flapTabs := ActiveWorld flapTabs.
flapIDs := flapTabs collect: [:tab | tab knownName].
flapTabs
do: [:tab | (tab isMemberOf: ViewerFlapTab)
ifFalse: [tab isGlobalFlap
ifTrue: [Flaps removeFlapTab: tab keepInList: false.
tab currentWorld reformulateUpdatingMenus]
ifFalse: [| referent |
referent := tab referent.
referent isInWorld
ifTrue: [referent delete].
tab delete]]].
sharedFlapTabs := Flaps classPool at: #SharedFlapTabs.
flapIDs
do: [:id |
id = 'Navigator' translated
ifTrue: [sharedFlapTabs add: Flaps newNavigatorFlap].
id = 'Widgets' translated
ifTrue: [sharedFlapTabs add: Flaps newWidgetsFlap].
id = 'Tools' translated
ifTrue: [sharedFlapTabs add: Flaps newToolsFlap].
id = 'Squeak' translated
ifTrue: [sharedFlapTabs add: Flaps newSqueakFlap].
id = 'Supplies' translated
ifTrue: [sharedFlapTabs add: Flaps newSuppliesFlap].
id = 'Stack Tools' translated
ifTrue: [sharedFlapTabs add: Flaps newStackToolsFlap].
id = 'Painting' translated
ifTrue: [sharedFlapTabs add: Flaps newPaintingFlap].
id = 'Objects' translated
ifTrue: [sharedFlapTabs add: Flaps newObjectsFlap ]].
2 timesRepeat: [flapIDs do: [:id | Flaps enableDisableGlobalFlapWithID: id]].
+ self world flapTabs
- ActiveWorld flapTabs
do: [:flapTab | flapTab isCurrentlyTextual
ifTrue: [flapTab changeTabText: flapTab knownName]].
Flaps positionNavigatorAndOtherFlapsAccordingToPreference.
+ navigationMorph := self currentWorld findDeeplyA: ProjectNavigationMorph preferredNavigator.
- navigationMorph := ActiveWorld findDeeplyA: ProjectNavigationMorph preferredNavigator.
navigationMorph isNil
ifTrue: [^ self].
navigationMorph allMorphs
do: [:morph | morph class == SimpleButtonDelayedMenuMorph
ifTrue: [(morph findA: ImageMorph) isNil
ifTrue: [| label |
label := morph label.
label isNil
ifFalse: [| name |
name := morph knownName.
name isNil
ifTrue: [morph name: label.
name := label].
morph label: name translated]]]]!
Item was changed:
----- Method: MorphicProject>>showWorldMainDockingBar (in category 'docking bars support') -----
showWorldMainDockingBar
^ self projectPreferenceFlagDictionary
at: #showWorldMainDockingBar
+ ifAbsent: [ true ]!
- ifAbsent: [ false ]!
Item was changed:
----- Method: MorphicProject>>showWorldMainDockingBar: (in category 'docking bars support') -----
+ showWorldMainDockingBar: aBooleanOrNil
- showWorldMainDockingBar: aBoolean
"Change the receiver to show the main docking bar"
+ aBooleanOrNil
+ ifNil: [self projectPreferenceFlagDictionary removeKey: #showWorldMainDockingBar ifAbsent: []]
+ ifNotNil: [self projectPreferenceFlagDictionary at: #showWorldMainDockingBar put: aBooleanOrNil].
- self projectPreferenceFlagDictionary at: #showWorldMainDockingBar put: aBoolean.
self assureMainDockingBarPresenceMatchesPreference!
Item was added:
+ ----- Method: MorphicProject>>topMorphicProject (in category 'accessing') -----
+ topMorphicProject
+ parentProject == self ifTrue: [^self].
+ parentProject ifNil: [self nilParentError].
+ ^parentProject isMorphic
+ ifTrue: [parentProject topMorphicProject]
+ ifFalse: [self]!
Item was changed:
----- Method: MorphicProject>>updateLocaleDependents (in category 'language') -----
updateLocaleDependents
"Set the project's natural language as indicated"
+ (self world respondsTo: #isTileScriptingElement) ifTrue: "Etoys present" [
+ self world allTileScriptingElements do: [:viewerOrScriptor |
- (self world respondsTo: #isTileScriptingElement) ifTrue: "Etoys present" [
- ActiveWorld allTileScriptingElements do: [:viewerOrScriptor |
viewerOrScriptor localeChanged]].
+
-
Flaps disableGlobalFlaps: false.
(Preferences eToyFriendly or: [
+ (Smalltalk classNamed: #SugarNavigatorBar) ifNotNil: [:c | c showSugarNavigator] ifNil: [false]])
- (Smalltalk classNamed: 'SugarNavigatorBar') ifNotNil: [:c | c showSugarNavigator] ifNil: [false]])
ifTrue: [
Flaps addAndEnableEToyFlaps.
+ self world addGlobalFlaps]
- ActiveWorld addGlobalFlaps]
ifFalse: [Flaps enableGlobalFlaps].
+ (self isFlapIDEnabled: 'Navigator' translated)
- (Project current isFlapIDEnabled: 'Navigator' translated)
ifFalse: [Flaps enableDisableGlobalFlapWithID: 'Navigator' translated].
+
-
ScrapBook default emptyScrapBook.
MenuIcons initializeTranslations.
super updateLocaleDependents.
+
-
"self setFlaps.
+ self setPaletteFor: aLanguageSymbol."!
- self setPaletteFor: aLanguageSymbol."
- !
Item was changed:
----- Method: MorphicProject>>wakeUpTopWindow (in category 'enter') -----
wakeUpTopWindow
"Image has been restarted, and the startUp list has been processed. Perform
any additional actions needed to restart the user interface."
+ SystemWindow wakeUpTopWindowUponStartup.
+ Preferences mouseOverForKeyboardFocus ifTrue:
+ [ "Allow global command keys to work upon re-entry without having to cause a focus change first."
+ self currentHand releaseKeyboardFocus ]!
- SystemWindow wakeUpTopWindowUponStartup!
Item was added:
+ ----- Method: MouseButtonEvent>>moveRightButtonChanged (in category 'accessing') -----
+ moveRightButtonChanged
+ "Answer if the move right mouse button has changed. This is the move left button on gaming mice."
+
+ ^ whichButton anyMask: 16!
Item was changed:
----- Method: MouseEvent class>>anyButton (in category 'constants') -----
anyButton
+
+ ^ EventSensor anyMouseButtonMask!
- ^ 7!
Item was added:
+ ----- Method: MouseEvent class>>numButtons (in category 'constants') -----
+ numButtons
+
+ ^ EventSensor numMouseButtons!
Item was changed:
----- Method: MouseEvent>>asMouseMove (in category 'converting') -----
asMouseMove
"Convert the receiver into a mouse move"
+ ^MouseMoveEvent new setType: #mouseMove startPoint: position endPoint: position trail: {position. position} buttons: buttons hand: source stamp: timeStamp!
- ^MouseMoveEvent new setType: #mouseMove startPoint: position endPoint: position trail: {position. position} buttons: buttons hand: source stamp: Time eventMillisecondClock!
Item was added:
+ ----- Method: MouseWheelEvent class>>convertScrollUnits:intoScrollDelta: (in category 'utility') -----
+ convertScrollUnits: scrollUnits intoScrollDelta: scrollDeltaPerMouseWheelNotch
+ "Convert the scrolling units provided by the VM into scrolling delta (increment) used by Morph.
+ The morph knows how many scroll delta it wants per single wheel notch.
+ I know how many scrolling units is generated by a single wheel notch."
+
+ ^scrollUnits abs * scrollDeltaPerMouseWheelNotch // self scrollUnitsPerMouseWheelNotch max: 1!
Item was added:
+ ----- Method: MouseWheelEvent class>>minimalScrollUnitsPerEvent (in category 'constants') -----
+ minimalScrollUnitsPerEvent
+ "Answer how many scroll units a single mouse wheel event can generate.
+ This reflects a value hardcoded in the VM.
+ The VM aggregate wheel events until this threshold is reached."
+
+ ^20!
Item was added:
+ ----- Method: MouseWheelEvent class>>scrollUnitsPerMouseWheelNotch (in category 'constants') -----
+ scrollUnitsPerMouseWheelNotch
+ "Answer how many scroll units a single mouse wheel notch does generate.
+ This reflects a value hardcoded in the VM.
+ The value is chosen high enough so as to enable:
+ - smoother scrolling on notch-less devices.
+ - while preserving Integer arithmetic
+ Interpretation (scaling) of scrolling units is left to the client morphs.
+ Typically, 120 units (1 notch) represents 3 lines of text."
+
+ ^120!
Item was added:
+ ----- Method: MouseWheelEvent>>horizontalScrollDelta: (in category 'accessing') -----
+ horizontalScrollDelta: scrollDeltaPerMouseWheelNotch
+ "Convert scrolling units into unsigned scrolling increment.
+ The morph knows how many scroll delta it wants per single wheel notch.
+ Note that returned increment value is always positive, regardless of direction."
+ ^self class convertScrollUnits: delta x intoScrollDelta: scrollDeltaPerMouseWheelNotch!
Item was added:
+ ----- Method: MouseWheelEvent>>setDirection (in category 'initialization') -----
+ setDirection
+ delta x > 0 ifTrue: [self setWheelRight].
+ delta x < 0 ifTrue: [self setWheelLeft].
+
+ delta y > 0 ifTrue: [self setWheelUp].
+ delta y < 0 ifTrue: [self setWheelDown].!
Item was added:
+ ----- Method: MouseWheelEvent>>setType:position:delta:buttons:hand:stamp: (in category 'private') -----
+ setType: evtType position: evtPos delta: evtDelta buttons: evtButtons hand: evtHand stamp: stamp
+ type := evtType.
+ position := evtPos.
+ buttons := evtButtons.
+ source := evtHand.
+ wasHandled := false.
+ direction := 2r0000.
+ delta := evtDelta.
+ timeStamp := stamp.
+ self setDirection!
Item was added:
+ ----- Method: MouseWheelEvent>>verticalScrollDelta: (in category 'accessing') -----
+ verticalScrollDelta: scrollDeltaPerMouseWheelNotch
+ "Convert scrolling units into unsigned scrolling increment.
+ The morph knows how many scroll delta it wants per single wheel notch.
+ Note that returned increment value is always positive, regardless of direction."
+ ^self class convertScrollUnits: delta y intoScrollDelta: scrollDeltaPerMouseWheelNotch!
Item was removed:
- Object subclass: #MouseWheelState
- instanceVariableNames: 'currentDelta'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Morphic-Events'!
Item was removed:
- ----- Method: MouseWheelState>>handleEvent:from: (in category 'event processing') -----
- handleEvent: aMouseWheelEvent from: aHand
- "Every 120 units, raise the wheel flags for convenient mouse wheel programming. We choose not to send multiple mouse-wheel events for multiples of 120 because applications can always react to the actual delta values if they want to do more scrolling or zooming."
-
- | sign |
- currentDelta := currentDelta + aMouseWheelEvent wheelDelta.
-
- sign := currentDelta sign.
- currentDelta := currentDelta abs.
-
- (currentDelta x // 120) > 0 ifTrue: [
- sign x = 1
- ifTrue: [aMouseWheelEvent setWheelRight]
- ifFalse: [aMouseWheelEvent setWheelLeft]].
-
- (currentDelta y // 120) > 0 ifTrue: [
- sign y = 1
- ifTrue: [aMouseWheelEvent setWheelUp]
- ifFalse: [aMouseWheelEvent setWheelDown]].
-
- currentDelta := currentDelta \\ 120.
- currentDelta := currentDelta * sign.
-
- "Finally, send the event."
- HandMorph sendMouseWheelToKeyboardFocus
- ifFalse: [aHand sendMouseEvent: aMouseWheelEvent]
- ifTrue: [aHand sendEvent: aMouseWheelEvent focus: aHand keyboardFocus clear: [aHand keyboardFocus: nil]].
- !
Item was removed:
- ----- Method: MouseWheelState>>initialize (in category 'initialize-release') -----
- initialize
-
- super initialize.
- currentDelta := 0@0.!
Item was changed:
----- Method: MultiWindowLabelButtonMorph>>performAction (in category 'accessing') -----
performAction
"Override to interpret the actionSelector as a menu accessor and to activate that menu."
+
+ actionSelector ifNil: [^ self].
+ (model perform: actionSelector) ifNotNil: [:menu |
+ menu
+ invokeModalAt: self position - (0@5)
+ in: self currentWorld
+ allowKeyboard: Preferences menuKeyboardControl]!
- actionSelector ifNotNil:
- [(model perform: actionSelector) ifNotNil:
- [:menu|
- menu
- invokeModalAt: self position - (0@5)
- in: ActiveWorld
- allowKeyboard: Preferences menuKeyboardControl]]!
Item was changed:
Morph subclass: #NewBalloonMorph
+ instanceVariableNames: 'balloonOwner textMorph orientation hasTail'
- instanceVariableNames: 'balloonOwner textMorph maximumWidth orientation hasTail'
classVariableNames: 'UseNewBalloonMorph'
poolDictionaries: ''
category: 'Morphic-Widgets'!
!NewBalloonMorph commentStamp: 'mt 3/31/2015 10:15' prior: 0!
A balloon is a bubble with an optional tail. It contains rich text, which describes something about its balloon-owner.!
Item was changed:
----- Method: NewBalloonMorph>>bubbleInset (in category 'geometry') -----
bubbleInset
+ ^ (5@3 * RealEstateAgent scaleFactor) truncated!
- ^ 5@2!
Item was changed:
----- Method: NewBalloonMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
+ self disableLayout: true.
+ self morphicLayerNumber: self class balloonLayer.
self setDefaultParameters.
textMorph := TextMorph new
+ hResizing: #shrinkWrap; vResizing: #shrinkWrap;
+ numCharactersPerLine: Preferences maxBalloonHelpLineLength;
- wrapFlag: false;
lock;
yourself.
self addMorph: textMorph.!
Item was removed:
- ----- Method: NewBalloonMorph>>maximumWidth (in category 'accessing') -----
- maximumWidth
-
- ^ maximumWidth ifNil: [
- maximumWidth := (self balloonOwner balloonFont widthOf: $m) * Preferences maxBalloonHelpLineLength]!
Item was removed:
- ----- Method: NewBalloonMorph>>maximumWidth: (in category 'accessing') -----
- maximumWidth: anInteger
-
- maximumWidth := anInteger.!
Item was removed:
- ----- Method: NewBalloonMorph>>morphicLayerNumber (in category 'WiW support') -----
- morphicLayerNumber
-
- "helpful for insuring some morphs always appear in front of or behind others.
- smaller numbers are in front"
-
- ^5 "Balloons are very front-like things"!
Item was changed:
----- Method: NewBalloonMorph>>setDefaultParameters (in category 'initialization') -----
setDefaultParameters
self
+ borderWidth: ((self userInterfaceTheme borderWidth ifNil: [1]) * RealEstateAgent scaleFactor) truncated;
- 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]).!
Item was changed:
----- Method: NewBalloonMorph>>setText: (in category 'initialization') -----
setText: stringOrText
| text |
text := stringOrText asText.
text hasColorAttribute ifFalse: [
text addAttribute: (TextColor color: (self userInterfaceTheme textColor ifNil: [Color black]))].
text hasFontAttribute ifFalse: [
text addAttribute: (TextFontReference toFont: (self userInterfaceTheme font ifNil: [TextStyle defaultFont]))].
- self textMorph wrapFlag: false.
self textMorph newContents: text.
- self textMorph fullBounds.
-
- (self maximumWidth > 0 and: [self textMorph width > self maximumWidth])
- ifTrue: [
- self textMorph
- wrapFlag: true;
- width: self maximumWidth].
-
self updateLayout.!
Item was changed:
----- Method: NewBalloonMorph>>tailHeight (in category 'geometry') -----
tailHeight
+ ^ (8 * RealEstateAgent scaleFactor) truncated!
- ^ 8!
Item was changed:
----- Method: NewBalloonMorph>>tailOffset (in category 'geometry') -----
tailOffset
+ ^ (((Dictionary newFrom: {
- ^ (Dictionary newFrom: {
#topLeft -> (5@0).
#topRight -> (-3@0).
#bottomLeft -> (1@ -1).
+ #bottomRight -> (-3 @ -3)}) at: self orientation) * RealEstateAgent scaleFactor) truncated!
- #bottomRight -> (-3 @ -3)}) at: self orientation!
Item was changed:
----- Method: NewBalloonMorph>>tailWidth (in category 'geometry') -----
tailWidth
+ ^ (15 * RealEstateAgent scaleFactor) truncated!
- ^ 15!
Item was changed:
----- Method: NewBalloonMorph>>verticesForTail (in category 'drawing') -----
verticesForTail
| offset factorX factorY tpos bpos |
+ offset := (5 * RealEstateAgent scaleFactor) rounded + (self wantsRoundedCorners
- offset := 5 + (self wantsRoundedCorners
ifTrue: [self cornerRadius]
ifFalse: [0]).
tpos := self tailPosition.
factorX := tpos x < self center x ifTrue: [1] ifFalse: [-1].
factorY := tpos y > self center y ifTrue: [1] ifFalse: [-1].
bpos := self bubbleBounds perform: self orientation.
^ {
tpos.
bpos + (((offset + self tailWidth) * factorX) @ (self borderStyle width negated * factorY)).
bpos + ((offset * factorX) @ (self borderStyle width negated * factorY)).}!
Item was added:
+ ----- Method: NewColorPickerMorph class>>on:colorSelector: (in category 'create') -----
+ on: objectToHaveItsColorSet colorSelector: colorSymbol
+ ^ self
+ on: objectToHaveItsColorSet
+ getColorSelector: colorSymbol
+ setColorSelector: colorSymbol asSimpleSetter!
Item was added:
+ ----- Method: NewColorPickerMorph class>>on:getColorSelector:setColorSelector: (in category 'create') -----
+ on: objectToHaveItsColorSet getColorSelector: colorGetterSymbol setColorSelector: colorSetterSymbol
+ ^ self
+ on: objectToHaveItsColorSet
+ originalColor: (colorGetterSymbol value: objectToHaveItsColorSet)
+ setColorSelector: colorSetterSymbol!
Item was changed:
+ ----- Method: NewHandleMorph>>delete (in category 'submorphs - add/remove') -----
- ----- Method: NewHandleMorph>>delete (in category 'submorphs-add/remove') -----
delete
hand ifNotNil:[
hand showTemporaryCursor: nil.
].
super delete.!
Item was removed:
- ----- Method: NewHandleMorph>>morphicLayerNumber (in category 'WiW support') -----
- morphicLayerNumber
-
- ^1 "handles are very front-like - e.g. the spawn reframe logic actually asks if the first submorph of the world is one of us before deciding to create one"!
Item was changed:
Object subclass: #NewParagraph
+ instanceVariableNames: 'text textStyle firstCharacterIndex container containerUnadjusted lines positionWhenComposed offsetToEnd maxRightX selectionStart selectionStop wantsColumnBreaks focused caretRect showCaret caretColor selectionColor unfocusedSelectionColor'
- instanceVariableNames: 'text textStyle firstCharacterIndex container lines positionWhenComposed offsetToEnd maxRightX selectionStart selectionStop wantsColumnBreaks focused caretRect showCaret caretColor selectionColor unfocusedSelectionColor'
classVariableNames: ''
poolDictionaries: ''
category: 'Morphic-Text Support'!
!NewParagraph commentStamp: '<historical>' prior: 0!
A Paragraph represents text that has been laid out, or composed, in some container.
text A Text with encoded per-character emphasis.
textStyle A TextStyle with font set, line height and horizontal alignment.
firstCharacterIndex The starting index in text for this paragraph, allowing
composition of a long text into a number of containers.
container A Rectangle or TextContainer that determines where text can go.
lines An Array of TextLines comprising the final layout of the text
after it has been composed within its container.
positionWhenComposed As its name implies. Allows display at new locations
without the need to recompose the text.
Lines are ordered vertically. However, for a given y, there may be several lines in left to right order. Lines must never be empty, even if text is empty.
Notes on yet another hack - 5 Feb 2001
We really need to clean up #composeLinesFrom:to:delta:into:priorLines:atY:!!!!!!
I added one more habdful of code to correct:
This is an annoying bug that's been around for a couple of years, but I finally figured out how to duplicate the problem, so I figured I'd just report it now. (It doesn't necessarily have to be fixed for 3.0 if it looks messy, but if it's a simple fix, it would be worth it.)
In Morphic, if you have the following text in a workspace:
This is line 1
This is line 2
**and** you have a return character after line 2, you will normally be able to click the mouse two times below line 2 in order to select all the text. If you edit line 2 (e.g. so that it reads "line number 2"), you can still select all the text by clicking below the second line. However, if you edit line 1, you will not be able to select all the text from the bottom in the same way. Things get messed up such that the last return character seems to be gone. In this state, if you position the cursor immediately after the 2, and press the right arrow, the cursor jumps to the beginning of line 2... oof. (report by Doug Way)
While I don't have a very deep understanding of the above mentioned method, I was able to determine that text ending in a CR worked better in the editor when the last entry in <lines> had a start of text size + 1 and a stop of text size. I have accordingly added code near the end to ensure this. It seems to have fixed the problem, but we do need to clean this baby up some day. - Bob
!
Item was changed:
----- Method: NewParagraph>>adjustRightX (in category 'private') -----
adjustRightX
+
+ self adjustRightXDownTo: 0.!
- | shrink |
- shrink := container right - maxRightX.
- lines do: [:line | line paddingWidth: (line paddingWidth - shrink)].
- container := container withRight: maxRightX + self caretWidth.!
Item was added:
+ ----- Method: NewParagraph>>adjustRightXDownTo: (in category 'private') -----
+ adjustRightXDownTo: minWidth
+ | shrink minRight |
+ minRight := container left + minWidth.
+ shrink := container right - (maxRightX max: minRight).
+ lines do: [:line | line paddingWidth: (line paddingWidth - shrink)].
+ containerUnadjusted := container.
+ container := container withRight: (maxRightX max: minRight).!
Item was added:
+ ----- Method: NewParagraph>>asText (in category 'converting') -----
+ asText
+ "Answer the receiver's text after being composed. Use #text if you want to retain the layout before composition."
+
+ ^ self asTextWithLineBreaks!
Item was added:
+ ----- Method: NewParagraph>>asTextWithLineBreaks (in category 'converting') -----
+ asTextWithLineBreaks
+ "Answer a text that has all soft line breaks converted to hard line breaks. Add the current style's default font as a text attribute only if a) the style is not the default and b) the first character has no other font set. See Text >> #asTextMorph."
+
+ | result |
+ result := Text streamContents: [:s | lines do: [:textLine |
+ | lastChar lastIndex break |
+ lastChar := text at: textLine last.
+ (break := CharacterSet separators includes: lastChar)
+ ifTrue: [lastIndex := textLine last - 1]
+ ifFalse: [lastIndex := textLine last].
+ "1) Copy text line, which may be due to a soft line break"
+ s nextPutAll: (text copyFrom: textLine first to: lastIndex).
+ "2) Add a hard line break."
+ break ifTrue: [s nextPutAll: (String cr asText
+ addAllAttributes: (text attributesAt: textLine last);
+ yourself)]]].
+
+ ((text fontAt: 1 withDefault: nil) isNil and: [
+ textStyle defaultFamilyName ~= TextStyle default defaultFamilyName])
+ ifTrue: [result addAttribute: (TextFontReference toFont: textStyle defaultFont)].
+
+ ^ result!
Item was changed:
----- Method: NewParagraph>>caretWidth (in category 'access') -----
caretWidth
+
^ Editor dumbbellCursor
+ ifTrue: [ | w |
+ w := (3 * RealEstateAgent scaleFactor) truncated.
+ w even ifTrue: [w := w + 1] ifFalse: [w] ]
+ ifFalse: [ (2 * RealEstateAgent scaleFactor) truncated ]!
- ifTrue: [ 3 ]
- ifFalse: [ 2 ]!
Item was changed:
----- Method: NewParagraph>>compose:style:from:in: (in category 'composition') -----
compose: t style: ts from: startingIndex in: textContainer
text := t.
textStyle := ts.
firstCharacterIndex := startingIndex.
offsetToEnd := text size - firstCharacterIndex.
container := textContainer.
+ containerUnadjusted := nil.
self composeAll!
Item was changed:
----- Method: NewParagraph>>displayDumbbellCursorOn:at:in: (in category 'display') -----
displayDumbbellCursorOn: aCanvas at: leftX in: line
+ "Draw a dumbbell-shaped cursor. Draw lines instead of a polygon to hopefully be faster."
+ | w wHalf b |
+ w := caretRect width.
+ wHalf := w // 2.
+ b := wHalf - 1.
+ b even ifTrue: [b := b - 1].
+ b := b max: 1.
- | w |
- w := 2.
- self focused ifFalse: [^ w].
-
- 1 to: w
- do:
- [:i |
- "Draw caret triangles at top and bottom"
+ 1 to: wHalf+1 do: [:i | "Draw caret triangles at top and bottom"
+ aCanvas
+ line: leftX + i - 1 @ (line top + i - 1)
+ to: leftX + w - i @ (line top + i - 1)
+ color: self caretColor.
+ aCanvas
+ line: leftX + i - 1 @ (line bottom - i)
+ to: leftX + w - i @ (line bottom - i)
+ color: self caretColor].
- aCanvas fillRectangle: ((leftX - w + i - 1) @ (line top + i - 1)
- extent: ((w - i) * 2 + 3) @ 1)
- color: self caretColor.
- aCanvas fillRectangle: ((leftX - w + i - 1) @ (line bottom - i)
- extent: ((w - i) * 2 + 3) @ 1)
- color: self caretColor].
+ b = 1
+ ifTrue: [
+ aCanvas
+ line: leftX + wHalf @ line top
+ to: leftX + wHalf @ (line bottom-1)
+ color: self caretColor]
+ ifFalse: [ | o |
+ o := leftX + wHalf - (b//2).
+ aCanvas
+ fillRectangle: (o @ line top corner: o + b @ line bottom)
+ color: self caretColor]!
- aCanvas
- line: leftX @ line top
- to: leftX @ (line bottom-1)
- color: self caretColor.
-
- ^ w!
Item was changed:
----- Method: NewParagraph>>displaySelectionInLine:on: (in category 'display') -----
displaySelectionInLine: line on: aCanvas
+ | leftX rightX |
- | 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
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: [ | w pos |
+ w := caretRect ifNotNil: [caretRect width] ifNil: [self caretWidth].
+ pos := leftX - (w // 2).
+ caretRect := pos @ line top corner: (pos + w) @ line bottom.
+ (self showCaret and: [self focused]) ifFalse: [^ self].
+ Editor dumbbellCursor
+ ifTrue: [self displayDumbbellCursorOn: aCanvas at: pos in: line]
+ ifFalse: [self displaySimpleCursorOn: aCanvas at: pos in: line]]
- 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>>displaySimpleCursorOn:at:in: (in category 'display') -----
displaySimpleCursorOn: aCanvas at: leftX in: line
+ | w aa |
+ w := caretRect width // 2 max: 1.
+ aa := caretRect width - w.
- self focused ifFalse: [^ 1].
-
- aCanvas
- line: leftX @ (line top+1)
- to: leftX @ (line bottom-1)
- color: self caretColor.
+ w = 1
+ ifFalse: [
+ aCanvas
+ fillRectangle: (leftX @ line top corner: leftX + w @ line bottom)
+ color: self caretColor]
+ ifTrue: [
+ aCanvas
+ line: leftX @ line top
+ to: leftX @ (line bottom-1)
+ color: self caretColor].
+
+ aa > 0 ifTrue: [
+ aa = 1
+ ifFalse: [
+ aCanvas
+ fillRectangle: (leftX+w @ line top rect: leftX+w +aa @ line bottom)
+ color: (self caretColor alpha: 0.3)]
+ ifTrue: [
+ aCanvas
+ line: leftX+w @ line top
+ to: leftX+w @ (line bottom-1)
+ color: (self caretColor alpha: 0.3)]].!
- aCanvas
- line: leftX+1 @ (line top+1)
- to: leftX+1 @ (line bottom-1)
- color: (self caretColor alpha: 0.3).
-
- ^ 1!
Item was changed:
----- Method: NewParagraph>>fastFindFirstLineSuchThat: (in category 'private') -----
fastFindFirstLineSuchThat: lineBlock
"Perform a binary search of the lines array and return the index
of the first element for which lineBlock evaluates as true.
This assumes the condition is one that goes from false to true for
increasing line numbers (as, eg, yval > somey or start char > somex).
If lineBlock is not true for any element, return size+1."
+ lines ifNil:
+ [self composeAll].
-
^lines
findBinaryIndex: [ :each |
(lineBlock value: each)
ifTrue: [ -1 ]
ifFalse: [ 1 ] ]
ifNone: [ :lower :upper | upper ]!
Item was removed:
- ----- Method: NewParagraph>>fixLastWithHeight: (in category 'composition') -----
- fixLastWithHeight: lineHeightGuess
- "This awful bit is to ensure that if we have scanned all the text and the last character is a CR that there is a null line at the end of lines. Sometimes this was not happening which caused anomalous selections when selecting all the text. This is implemented as a post-composition fixup because I coul;dn't figure out where to put it in the main logic."
-
- | oldLastLine newRectangle line |
-
- (text size > 1 and: [text last = Character cr]) ifFalse: [^self].
-
- oldLastLine := lines last.
- oldLastLine last - oldLastLine first >= 0 ifFalse: [^self].
- oldLastLine last = text size ifFalse: [^self].
-
- newRectangle := oldLastLine left @ oldLastLine bottom
- extent: 0@(oldLastLine bottom - oldLastLine top).
- "Even though we may be below the bottom of the container,
- it is still necessary to compose the last line for consistency..."
-
- line := TextLine start: text size+1 stop: text size internalSpaces: 0 paddingWidth: 0.
- line rectangle: newRectangle.
- line lineHeight: lineHeightGuess baseline: textStyle baseline.
- lines := lines, (Array with: line).
- !
Item was removed:
- ----- Method: NewParagraph>>lineIndexForCharacter: (in category 'private') -----
- lineIndexForCharacter: characterIndex
- "Deprecated"
-
- ^self lineIndexOfCharacterIndex: characterIndex !
Item was changed:
----- Method: NewParagraph>>recomposeFrom:to:delta: (in category 'composition') -----
recomposeFrom: start to: stop delta: delta
"Recompose this paragraph. The altered portion is between start and stop.
Recomposition may continue to the end of the text, due to a ripple effect.
Delta is the amount by which the current text is longer than it was
when its current lines were composed."
| startLine newLines |
+ containerUnadjusted ifNotNil: [
+ "Somebody called #adjustRightX. We must recompose everything to
+ avoid strange line breaks and clipping."
+ container := container topLeft extent: containerUnadjusted extent.
+ self composeAll; adjustRightX.
+ ^ self].
+
"Have to recompose line above in case a word-break was affected."
startLine := (self lineIndexOfCharacterIndex: start) - 1 max: 1.
[startLine > 1 and: [(lines at: startLine-1) top = (lines at: startLine) top]]
whileTrue: [startLine := startLine - 1]. "Find leftmost of line pieces"
newLines := OrderedCollection new: lines size + 1.
1 to: startLine-1 do: [:i | newLines addLast: (lines at: i)].
self composeLinesFrom: (lines at: startLine) first to: stop delta: delta
into: newLines priorLines: lines
atY: (lines at: startLine) top!
Item was removed:
- ----- Method: Object>>asDraggableMorph (in category '*morphic') -----
- asDraggableMorph
- "Converts the receiver into a Morph suitable for dragging"
- ^(StringMorph contents: (
- (self respondsTo: #dragLabel)
- ifTrue:[self dragLabel]
- ifFalse:[self printString]))
- color: ((self userInterfaceTheme get: #textColor for: #TransferMorph) ifNil: [Color black]);
- font: ((self userInterfaceTheme get: #font for: #TransferMorph) ifNil: [TextStyle defaultFont])
- yourself!
Item was changed:
+ ----- Method: Object>>currentEvent (in category '*Morphic-Kernel-accessing') -----
- ----- Method: Object>>currentEvent (in category '*Morphic-Kernel') -----
currentEvent
+ "Answer the current MorphicEvent. Provided that a morphic project is loaded, this method never returns nil."
+
+ ^ ActiveEventVariable value!
- "Answer the current Morphic event. This method never returns nil."
- ^ActiveEvent ifNil:[self currentHand lastEvent]!
Item was changed:
+ ----- Method: Object>>currentHand (in category '*Morphic-Kernel-accessing') -----
- ----- Method: Object>>currentHand (in category '*Morphic-Kernel') -----
currentHand
+ "Answer the current HandMorph. Provided that a morphic project is loaded, this method will never return nil."
- "Return a usable HandMorph -- the one associated with the object's current environment. This method will always return a hand, even if it has to conjure one up as a last resort. If a particular hand is actually handling events at the moment (such as a remote hand or a ghost hand), it will be returned."
+ ^ Project current isMorphic
+ ifTrue: [ActiveHandVariable value]
+ ifFalse: [Sensor "MVC/ST80 fallback"]!
- ^ActiveHand ifNil: [ self currentWorld primaryHand ]!
Item was changed:
+ ----- Method: Object>>currentWorld (in category '*Morphic-Kernel-accessing') -----
- ----- Method: Object>>currentWorld (in category '*Morphic-Kernel') -----
currentWorld
+ "Answer the current world. This method will never return nil."
+
+ ^ ActiveWorldVariable value!
- "Answer a morphic world that is the current UI focus."
- ^ActiveWorld ifNil:[Project current world]!
Item was changed:
ListItemWrapper subclass: #ObjectExplorerWrapper
+ instanceVariableNames: 'itemName parent balloonText'
- instanceVariableNames: 'itemName parent'
classVariableNames: 'ShowContentsInColumns'
poolDictionaries: ''
category: 'Morphic-Explorer'!
!ObjectExplorerWrapper commentStamp: 'pre 5/15/2017 21:23' prior: 0!
ObjectExplorerWrappers represent an item displayed in an object explorer tree. In addition to the common ListItemWrapper behavior it adds methods to refresh the list entry with updated values from the model. It is mostly used in #explorerContents methods to describe which instance variables of an object should be displayed in the explorer.
Additionally, the value displayed can be visualized with a small icon which is defined by the class of the value object through the method #iconOrThumbnailOfSize:.
Contributed by Bob Arning as part of the ObjectExplorer package.
!
Item was added:
+ ----- Method: ObjectExplorerWrapper class>>forError: (in category 'instance creation') -----
+ forError: message
+
+ ^ ObjectExplorerWrapper
+ with: message
+ name: '<error>' translated
+ model: nil!
Item was added:
+ ----- Method: ObjectExplorerWrapper class>>showClassIcons (in category 'preferences') -----
+ showClassIcons
+ ^ Browser showClassIcons!
Item was added:
+ ----- Method: ObjectExplorerWrapper class>>showClassIcons: (in category 'preferences') -----
+ showClassIcons: aBoolean
+ Browser showClassIcons: aBoolean.!
Item was changed:
----- Method: ObjectExplorerWrapper>>asString (in category 'converting') -----
asString
| explorerString label separator |
explorerString :=
+ [self objectString]
- [self object asExplorerString]
on: Error
+ do: ['<error: {1} in {2}: evaluate "{3}" to debug>' translated format: {self object class name. #asExplorerString. self itemName , ' asExplorerString'}].
- do: ['<error: ', self object class name, ' in asExplorerString: evaluate "' , self itemName , ' asExplorerString" to debug>'].
(explorerString includes: Character cr)
ifTrue: [explorerString := explorerString withSeparatorsCompacted].
label := self itemName ifNil: [''].
(label includes: Character cr)
ifTrue: [label := label withSeparatorsCompacted].
separator := self class showContentsInColumns
ifTrue: [String tab]
ifFalse: [label ifEmpty: [''] ifNotEmpty: [': ']].
^ '{1}{2}{3}' format: {label. separator. explorerString}!
Item was added:
+ ----- Method: ObjectExplorerWrapper>>balloonText (in category 'accessing') -----
+ balloonText
+
+ ^ balloonText!
Item was added:
+ ----- Method: ObjectExplorerWrapper>>balloonText: (in category 'accessing') -----
+ balloonText: stringOrNil
+
+ balloonText := stringOrNil.!
Item was changed:
----- Method: ObjectExplorerWrapper>>contents (in category 'accessing') -----
contents
+ ^ [self object explorerContents
- ^ self object explorerContents
do: [:wrapper | wrapper parent: self];
+ yourself] ifError: [:msg | {self class forError: msg}]!
- yourself!
Item was changed:
----- Method: ObjectExplorerWrapper>>icon (in category 'accessing') -----
icon
"Answer a form to be used as icon"
^ Preferences visualExplorer
ifTrue: [([self object iconOrThumbnailOfSize: 12] on: Error do: [nil])
+ ifNil: [self class showClassIcons
+ ifTrue: [ToolIcons iconNamed: self object class theNonMetaClass toolIcon]
+ ifFalse: [self class showContentsInColumns
+ ifTrue: [ToolIcons iconNamed: #blank]
+ ifFalse: [nil]]]]
- ifNil: [self class showContentsInColumns
- ifTrue: [ToolIcons iconNamed: #blank]
- ifFalse: [nil]]]
ifFalse: [nil]!
Item was added:
+ ----- Method: ObjectExplorerWrapper>>itemName: (in category 'accessing') -----
+ itemName: newName
+
+ self item key: newName.!
Item was added:
+ ----- Method: ObjectExplorerWrapper>>objectString (in category 'accessing') -----
+ objectString
+ "Answers a string representation of the object that well be combined with #itemName when requested from the tree model. Overwrite this in custom wrappers to modify parent-specific representations without having to modify #asExplorerString in the particular object."
+
+ ^ self object asExplorerString!
Item was changed:
BorderedMorph subclass: #PasteUpMorph
+ instanceVariableNames: 'presenter model cursor padding turtleTrailsForm turtlePen lastTurtlePositions isPartsBin indicateCursor wantsMouseOverHalos worldState'
+ classVariableNames: 'GlobalCommandKeysEnabled WindowEventHandler'
- instanceVariableNames: 'presenter model cursor padding backgroundMorph turtleTrailsForm turtlePen lastTurtlePositions isPartsBin indicateCursor wantsMouseOverHalos worldState griddingOn'
- classVariableNames: 'DisableDeferredUpdates GlobalCommandKeysEnabled MinCycleLapse StillAlive WindowEventHandler'
poolDictionaries: ''
category: 'Morphic-Worlds'!
!PasteUpMorph commentStamp: '<historical>' prior: 0!
A morph whose submorphs comprise a paste-up of rectangular subparts which "show through". Anything called a 'Playfield' is a PasteUpMorph.
Facilities commonly needed on pages of graphical presentations and on simulation playfields, such as the painting of new objects, turtle trails, gradient fills, background paintings, parts-bin behavior, collision-detection, etc., are (or will be) provided.
A World, the entire Smalltalk screen, is a PasteUpMorph. A World responds true to isWorld. Morph subclasses that have specialized menus (BookMorph) build them in the message addBookMenuItemsTo:hand:. A PasteUpMorph that is a world, builds its menu in HandMorph buildWorldMenu.
presenter A Presenter in charge of stopButton stepButton and goButton,
mouseOverHalosEnabled soundsEnabled fenceEnabled coloredTilesEnabled.
model <not used>
cursor ??
padding ??
backgroundMorph A Form that covers the background.
turtleTrailsForm Moving submorphs may leave trails on this form.
turtlePen Draws the trails.
lastTurtlePositions A Dictionary of (aPlayer -> aPoint) so turtle trails can be drawn
only once each step cycle. The point is the start of the current stroke.
isPartsBin If true, every object dragged out is copied.
autoLineLayout ??
indicateCursor ??
resizeToFit ??
wantsMouseOverHalos If true, simply moving the cursor over a submorph brings up its halo.
worldState If I am also a World, keeps the hands, damageRecorder, stepList etc.
griddingOn If true, submorphs are on a grid
!
Item was removed:
- ----- Method: PasteUpMorph class>>MinCycleLapse: (in category 'project') -----
- MinCycleLapse: milliseconds
- "set the minimum amount of time that may transpire between two calls to doOneCycle"
- MinCycleLapse := milliseconds ifNotNil: [ milliseconds rounded ].!
Item was removed:
- ----- Method: PasteUpMorph class>>disableDeferredUpdates (in category 'project') -----
- disableDeferredUpdates
-
- ^DisableDeferredUpdates ifNil: [DisableDeferredUpdates := false]
- !
Item was removed:
- ----- Method: PasteUpMorph class>>disableDeferredUpdates: (in category 'project') -----
- disableDeferredUpdates: aBoolean
- "If the argument is true, disable deferred screen updating."
- "Details: When deferred updating is used, Morphic performs double-buffered screen updates by telling the VM to de-couple the Display from the hardware display buffer, drawing directly into the Display, and then forcing the changed regions of the Display to be copied to the screen. This saves both time (an extra BitBlt is avoided) and space (an extra display buffer is avoided). However, on platforms on which the Display points directly to the hardware screen buffer, deferred updating can't be used (you'd see ugly flashing as the layers of the drawing were assembled). In this case, the drawing is composited into an offscreen FormCanvas and then copied to the hardware display buffer."
-
- DisableDeferredUpdates := aBoolean.
- !
Item was changed:
----- Method: PasteUpMorph class>>globalCommandKeysEnabled: (in category 'preferences') -----
globalCommandKeysEnabled: aBoolean
GlobalCommandKeysEnabled = aBoolean ifTrue: [^ self].
GlobalCommandKeysEnabled := aBoolean.
SystemWindow allSubInstancesDo: [:ea |
+ self globalCommandKeysEnabled
- aBoolean
ifTrue: [ea addKeyboardShortcuts]
ifFalse: [ea removeKeyboardShortcuts]].
PasteUpMorph allSubInstancesDo: [:ea |
+ self globalCommandKeysEnabled
- aBoolean
ifTrue: [ea addKeyboardShortcuts]
ifFalse: [ea removeKeyboardShortcuts]].!
Item was changed:
----- Method: PasteUpMorph>>acceptDroppingMorph:event: (in category 'dropping/grabbing') -----
acceptDroppingMorph: dropped event: evt
"The supplied morph, known to be acceptable to the receiver, is now to be assimilated; the precipitating event is supplied"
| aMorph |
+ (self isWorldMorph and: [dropped isTransferMorph]
+ and: [self hasTransferMorphConverter not])
+ ifTrue: [
+ dropped dragTransferType = #filesAndDirectories
+ ifTrue: [^ self dropFiles: dropped passenger event: evt].
+ dropped dragTransferType = #sourceCode
+ ifTrue: [^ self dropSourceCode: dropped passenger event: evt]].
+
aMorph := self morphToDropFrom: dropped.
self isWorldMorph
+ ifFalse: [super acceptDroppingMorph: aMorph event: evt]
+ ifTrue:
+ ["Add the given morph to this world and start stepping it if it wants to be."
+ aMorph isInWorld ifFalse: [aMorph position: evt position].
+ self addMorphFront: aMorph.
+ (aMorph fullBounds intersects: self viewBox) ifFalse:
+ [Beeper beep.
+ aMorph position: self bounds center]].
+
- ifTrue:["Add the given morph to this world and start stepping it if it wants to be."
- aMorph isInWorld not ifTrue: [aMorph position: evt position].
- self addMorphFront: aMorph.
- (aMorph fullBounds intersects: self viewBox) ifFalse:
- [Beeper beep. aMorph position: self bounds center]]
- ifFalse:[super acceptDroppingMorph: aMorph event: evt].
-
aMorph submorphsDo: [:m | (m isKindOf: HaloMorph) ifTrue: [m delete]].
aMorph allMorphsDo: "Establish any penDown morphs in new world"
[:m | | tfm mm |
m player ifNotNil:
[m player getPenDown ifTrue:
[((mm := m player costume) notNil and: [(tfm := mm owner transformFrom: self) notNil])
ifTrue: [self noteNewLocation: (tfm localPointToGlobal: mm referencePosition)
forPlayer: m player]]]].
+
-
self isPartsBin
ifTrue:
[aMorph isPartsDonor: true.
aMorph stopSteppingSelfAndSubmorphs.
aMorph suspendEventHandler]
ifFalse:
[self world startSteppingSubmorphsOf: aMorph].
+
-
" self presenter morph: aMorph droppedIntoPasteUpMorph: self."
- self griddingOn ifTrue: [aMorph position: (self gridPoint: aMorph position)].
self showingListView ifTrue:
[self sortSubmorphsBy: (self valueOfProperty: #sortOrder).
self currentWorld abandonAllHalos].
+
+ self bringTopmostsToFront.!
-
- self bringTopmostsToFront.
- !
Item was removed:
- ----- Method: PasteUpMorph>>activeHand (in category 'structure') -----
- activeHand
-
- ^ worldState
- ifNotNil: [:ws | ws activeHand ifNil: [ws hands first]]
- ifNil: [super activeHand]!
Item was removed:
- ----- Method: PasteUpMorph>>activeHand: (in category 'world state') -----
- activeHand: aHandMorph
- "temporarily retained for old main event loops"
-
- worldState activeHand: aHandMorph.
-
- !
Item was changed:
+ ----- Method: PasteUpMorph>>addAllMorphs: (in category 'submorphs - add/remove') -----
- ----- Method: PasteUpMorph>>addAllMorphs: (in category 'submorphs-add/remove') -----
addAllMorphs: array
super addAllMorphs: array.
self isWorldMorph
ifTrue: [array do: [:m | self startSteppingSubmorphsOf: m]].
!
Item was changed:
+ ----- Method: PasteUpMorph>>addMorphFront: (in category 'submorphs - add/remove') -----
- ----- Method: PasteUpMorph>>addMorphFront: (in category 'submorphs-add/remove') -----
addMorphFront: aMorph
+ "Overwritten to arrange submorphs in layers by default."
+ ^ self addMorphFrontInLayer: aMorph!
- ^self addMorphInFrontOfLayer: aMorph
- !
Item was changed:
+ ----- Method: PasteUpMorph>>allMorphsDo: (in category 'submorphs - accessing') -----
- ----- Method: PasteUpMorph>>allMorphsDo: (in category 'submorphs-accessing') -----
allMorphsDo: aBlock
"Enumerate all morphs in the world, including those held in hands."
super allMorphsDo: aBlock.
self isWorldMorph
ifTrue: [worldState handsReverseDo: [:h | h allMorphsDo: aBlock]].
!
Item was changed:
----- Method: PasteUpMorph>>becomeActiveDuring: (in category 'initialization') -----
becomeActiveDuring: aBlock
+ "Make the receiver the active world during the evaluation of aBlock."
- "Make the receiver the ActiveWorld during the evaluation of aBlock."
+ ^ ActiveWorldVariable value: self during: aBlock!
- | priorWorld |
- priorWorld := ActiveWorld.
- ActiveWorld := self.
- ^ aBlock ensure: [
- "check to support project switching."
- ActiveWorld == self ifTrue: [ActiveWorld := priorWorld]].!
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."
self currentWorld flapTabs do:
[:aTab | aTab referent == self ifTrue: [^ aTab]].
"Catch guys in embedded worldlets"
+ self currentWorld allMorphs do:
- ActiveWorld allMorphs do:
[:aTab | ((aTab isKindOf: FlapTab) and: [aTab referent == self]) ifTrue: [^ aTab]].
^ nil!
Item was changed:
----- Method: PasteUpMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
"Draw in order:
- background color
- - grid, if any
- - background sketch, if any
- Update and draw the turtleTrails form. See the comment in updateTrailsForm.
- cursor box if any
Later (in drawSubmorphsOn:) I will skip drawing the background sketch."
"draw background fill"
super drawOn: aCanvas.
- "draw grid"
- (self griddingOn and: [self gridVisible])
- ifTrue:
- [aCanvas fillRectangle: self bounds
- fillStyle: (self
- gridFormOrigin: self gridOrigin
- grid: self gridModulus
- background: nil
- line: Color lightGray)].
-
- "draw background sketch."
- backgroundMorph ifNotNil: [
- self clipSubmorphs ifTrue: [
- aCanvas clipBy: self clippingBounds
- during: [ :canvas | canvas fullDrawMorph: backgroundMorph ]]
- ifFalse: [ aCanvas fullDrawMorph: backgroundMorph ]].
-
"draw turtle trails"
(lastTurtlePositions isNil or: [lastTurtlePositions isEmpty]) ifFalse:[
self updateTrailsForm.
].
turtleTrailsForm
ifNotNil: [aCanvas paintImage: turtleTrailsForm at: self position].
"draw cursor"
(submorphs notEmpty and: [self indicateCursor])
ifTrue:
[aCanvas
frameRectangle: self selectedRect
width: 2
color: Color black]!
Item was removed:
- ----- Method: PasteUpMorph>>drawSubmorphsOn: (in category 'painting') -----
- drawSubmorphsOn: aCanvas
- "Display submorphs back to front, but skip my background sketch."
-
- | drawBlock |
- submorphs isEmpty ifTrue: [^self].
- drawBlock := [:canvas | submorphs reverseDo: [:m | m ~~ backgroundMorph ifTrue: [ canvas fullDrawMorph: m ]]].
- self clipSubmorphs
- ifTrue: [aCanvas clipBy: self clippingBounds during: drawBlock]
- ifFalse: [drawBlock value: aCanvas]!
Item was removed:
- ----- Method: PasteUpMorph>>dropFiles: (in category 'event handling') -----
- dropFiles: anEvent
- "Handle a number of dropped files from the OS.
- TODO:
- - use a more general mechanism for figuring out what to do with the file (perhaps even offering a choice from a menu)
- - remember the resource location or (when in browser) even the actual file handle
- "
- | numFiles |
- numFiles := anEvent contents.
- 1 to: numFiles do: [ :i |
- (FileDirectory requestDropDirectory: i)
- ifNotNil: [:directory | self handleDroppedItem: directory event: anEvent]
- ifNil: [(FileStream requestDropStream: i) ifNotNil: [:stream |
- [self handleDroppedItem: stream event: anEvent] ensure: [stream close]]]].
- !
Item was added:
+ ----- Method: PasteUpMorph>>dropFiles:event: (in category 'event handling') -----
+ dropFiles: filesAndDirectories event: anEvent
+ "Handle a number of dropped files from the OS."
+
+ filesAndDirectories do: [ :file |
+ self handleDroppedItem: file event: anEvent].!
Item was added:
+ ----- Method: PasteUpMorph>>dropSourceCode:event: (in category 'event handling') -----
+ dropSourceCode: anObject event: evt
+
+ (anObject isMethodReference and: [anObject isValid])
+ ifTrue: [^ self dropSourceCode: anObject compiledMethod event: evt].
+
+ (anObject isBehavior or: [anObject isCompiledMethod])
+ ifTrue: [
+ | tool window |
+ tool := anObject isBehavior
+ ifTrue: [Browser new
+ setClass: anObject]
+ ifFalse: [CodeHolder new
+ setClass: anObject methodClass
+ selector: anObject selector].
+ window := ToolBuilder open: tool.
+ window center: evt position.
+ window bounds: (window bounds translatedToBeWithin: self bounds)].
+
+ anObject isString
+ ifTrue: [anObject edit].!
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.
+ self currentHand showTemporaryCursor: nil.
- ActiveHand showTemporaryCursor: nil.
innerForm isAllWhite ifFalse:
[hand attachMorph: (self drawingClass withForm: innerForm)]!
Item was changed:
----- Method: PasteUpMorph>>flapTab (in category 'accessing') -----
flapTab
"Answer the tab affilitated with the receiver. Normally every flap tab is expected to have a PasteUpMorph which serves as its 'referent.'"
| ww |
+ self isFlap ifFalse: [^ nil].
+ ww := self presenter associatedMorph ifNil: [self].
+ ^ ww flapTabs
+ detect: [:any| any referent == self]
+ ifNone: [nil]!
- self isFlap ifFalse:[^nil].
- ww := self presenter associatedMorph ifNil: [ActiveWorld].
- ^ ww ifNotNil: [ww flapTabs detect:[:any| any referent == self] ifNone: [nil]]!
Item was removed:
- ----- Method: PasteUpMorph>>gridModulus (in category 'gridding') -----
- gridModulus
-
- ^ self gridSpec extent!
Item was removed:
- ----- Method: PasteUpMorph>>gridModulus: (in category 'gridding') -----
- gridModulus: newModulus
-
- self gridSpecPut: (self gridOrigin extent: newModulus).
- self changed!
Item was removed:
- ----- Method: PasteUpMorph>>gridOrigin (in category 'gridding') -----
- gridOrigin
-
- ^ self gridSpec origin!
Item was removed:
- ----- Method: PasteUpMorph>>gridOrigin: (in category 'gridding') -----
- gridOrigin: newOrigin
-
- ^ self gridSpecPut: (newOrigin extent: self gridModulus)!
Item was removed:
- ----- Method: PasteUpMorph>>gridPoint: (in category 'geometry') -----
- gridPoint: ungriddedPoint
-
- self griddingOn ifFalse: [^ ungriddedPoint].
- ^ (ungriddedPoint - self position - self gridOrigin grid: self gridModulus)
- + self position + self gridOrigin!
Item was removed:
- ----- Method: PasteUpMorph>>gridSpec (in category 'gridding') -----
- gridSpec
- "Gridding rectangle provides origin and modulus"
-
- ^ self valueOfProperty: #gridSpec ifAbsent: [0@0 extent: 8@8]!
Item was removed:
- ----- Method: PasteUpMorph>>gridSpecPut: (in category 'gridding') -----
- gridSpecPut: newSpec
- "Gridding rectangle provides origin and modulus"
-
- ^ self setProperty: #gridSpec toValue: newSpec!
Item was removed:
- ----- Method: PasteUpMorph>>gridVisible (in category 'gridding') -----
- gridVisible
-
- ^ self hasProperty: #gridVisible!
Item was removed:
- ----- Method: PasteUpMorph>>gridVisibleOnOff (in category 'gridding') -----
- gridVisibleOnOff
-
- self setProperty: #gridVisible toValue: self gridVisible not.
- self changed!
Item was removed:
- ----- 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!
Item was removed:
- ----- Method: PasteUpMorph>>griddingOn (in category 'gridding') -----
- griddingOn
-
- ^ griddingOn ifNil: [false]!
Item was removed:
- ----- Method: PasteUpMorph>>griddingOnOff (in category 'gridding') -----
- griddingOnOff
-
- griddingOn := self griddingOn not.
- self changed!
Item was removed:
- ----- Method: PasteUpMorph>>griddingString (in category 'gridding') -----
- griddingString
- "Answer a string to use in a menu offering the user the
- opportunity to start or stop using gridding"
- ^ (self griddingOn
- ifTrue: ['<yes>']
- ifFalse: ['<no>'])
- , 'use gridding' translated!
Item was changed:
----- Method: PasteUpMorph>>initializeDesktopCommandKeySelectors (in category 'world menu') -----
initializeDesktopCommandKeySelectors
"Provide the starting settings for desktop command key selectors. Answer the dictionary."
"ActiveWorld initializeDesktopCommandKeySelectors"
| dict |
dict := IdentityDictionary new.
+ self defaultDesktopCommandKeyTriplets do: [:trip |
+ | messageSend |
+ messageSend := MessageSend receiver: trip second selector: trip third.
+ dict at: trip first put: messageSend].
- self defaultDesktopCommandKeyTriplets do:
- [:trip | | messageSend |
- messageSend := MessageSend receiver: trip second selector: trip third.
- dict at: trip first put: messageSend].
self setProperty: #commandKeySelectors toValue: dict.
+ ^ dict!
- ^ dict
-
- !
Item was changed:
----- Method: PasteUpMorph>>install (in category 'world state') -----
install
+
owner := nil. "since we may have been inside another world previously"
+
- ActiveWorld := self.
- ActiveHand := self hands first. "default"
- ActiveEvent := nil.
submorphs do: [:ss | ss owner isNil ifTrue: [ss privateOwner: self]].
"Transcript that was in outPointers and then got deleted."
self viewBox: Display boundingBox.
+ EventSensor default flushEvents.
- Sensor flushAllButDandDEvents.
worldState handsDo: [:h | h initForEvents].
self installFlaps.
self borderWidth: 0. "default"
(Preferences showSecurityStatus
and: [SecurityManager default isInRestrictedMode])
ifTrue:
[self
borderWidth: 2;
borderColor: Color red].
self presenter allExtantPlayers do: [:player | player prepareToBeRunning].
SystemWindow noteTopWindowIn: self.!
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 changed.
- self displayWorld.
bar value: i / self localFlapTabs size]].
] ifFalse: [
localFlapTabs keysAndValuesDo: [:i :each |
each adaptToWorld.
each visible: true.
+ self changed]].
- self displayWorld]].
self assureFlapTabsFitOnScreen.
self bringTopmostsToFront!
Item was changed:
----- Method: PasteUpMorph>>morphToDropFrom: (in category 'dropping/grabbing') -----
morphToDropFrom: aMorph
+ "Given a morph being carried by the hand which the hand is about to drop, answer the actual morph to be deposited. Normally this would be just the morph itself, but several unusual cases arise, which this method is designed to service."
- "Given a morph being carried by the hand, which the hand is about to drop, answer the actual morph to be deposited. Normally this would be just the morph itself, but several unusual cases arise, which this method is designed to service."
| aNail representee handy posBlock |
+ handy := self isWorldMorph
+ ifTrue: [self primaryHand]
+ ifFalse: [self currentHand].
- handy := self primaryHand.
posBlock :=
[:z | | tempPos |
tempPos := handy position
- ((handy targetOffset - aMorph formerPosition)
* (z extent / aMorph extent)) rounded.
self pointFromWorld: tempPos].
self alwaysShowThumbnail
ifTrue:
[aNail := aMorph
representativeNoTallerThan: self maxHeightToAvoidThumbnailing
norWiderThan: self maximumThumbnailWidth
thumbnailHeight: self heightForThumbnails.
aNail == aMorph
ifFalse:
[aMorph formerPosition: aMorph position.
aNail position: (posBlock value: aNail)].
^aNail].
((aMorph isKindOf: MorphThumbnail)
and: [(representee := aMorph morphRepresented) owner isNil])
ifTrue:
[representee position: (posBlock value: representee).
^representee].
self showingListView
ifTrue:
[^aMorph
listViewLineForFieldList: (self valueOfProperty: #fieldListSelectors)].
(aMorph hasProperty: #newPermanentScript)
ifTrue: [^aMorph asEmptyPermanentScriptor].
((aMorph isPhraseTileMorph) or: [aMorph isSyntaxMorph])
ifFalse: [^aMorph morphToDropInPasteUp: self].
aMorph userScriptSelector isEmptyOrNil
ifTrue:
["non-user"
self automaticPhraseExpansion ifFalse: [^aMorph]].
^aMorph morphToDropInPasteUp: self!
Item was removed:
- ----- Method: PasteUpMorph>>morphicLayerNumber (in category 'WiW support') -----
- morphicLayerNumber
-
- self isFlap ifTrue:[^26]. "As navigators"
- ^super morphicLayerNumber.!
Item was changed:
+ ----- Method: PasteUpMorph>>morphsInFrontOf:overlapping:do: (in category 'submorphs - accessing') -----
- ----- Method: PasteUpMorph>>morphsInFrontOf:overlapping:do: (in category 'submorphs-accessing') -----
morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock
"Include hands if the receiver is the World"
self handsDo:[:m|
m == someMorph ifTrue:["Try getting out quickly"
owner ifNil:[^self].
^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock].
"The hand only overlaps if it's not the hardware cursor"
m needsToBeDrawn ifTrue:[
(m fullBoundsInWorld intersects: aRectangle)
ifTrue:[aBlock value: m]]].
^super morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock!
Item was added:
+ ----- Method: PasteUpMorph>>primaryHand (in category 'structure') -----
+ primaryHand
+
+ ^ self hands at: 1 ifAbsent: [nil]!
Item was removed:
- ----- Method: PasteUpMorph>>privateRemoveMorph: (in category 'private') -----
- privateRemoveMorph: aMorph
- backgroundMorph == aMorph ifTrue: [ backgroundMorph := nil ].
- ^super privateRemoveMorph: aMorph.
- !
Item was changed:
----- Method: PasteUpMorph>>processEvent:using: (in category 'events-processing') -----
processEvent: anEvent using: defaultDispatcher
+ "Reimplemented to install the receiver as the new active world if it is one"
+
+ self isWorldMorph ifFalse: [
+ ^ super processEvent: anEvent using: defaultDispatcher].
+
+ ^ self becomeActiveDuring: [
+ super processEvent: anEvent using: defaultDispatcher]!
- "Reimplemented to install the receiver as the new ActiveWorld if it is one"
- | priorWorld result |
- self isWorldMorph ifFalse:[^super processEvent: anEvent using: defaultDispatcher].
- priorWorld := ActiveWorld.
- ActiveWorld := self.
- [result := super processEvent: anEvent using: defaultDispatcher]
- ensure: [ActiveWorld := priorWorld].
- ^result
- !
Item was changed:
----- Method: PasteUpMorph>>putUpPenTrailsSubmenu (in category 'menu & halo') -----
putUpPenTrailsSubmenu
"Put up the pen trails menu"
| aMenu |
aMenu := MenuMorph new defaultTarget: self.
aMenu title: 'pen trails' translated.
aMenu addStayUpItem.
self addPenTrailsMenuItemsTo: aMenu.
+ ^ aMenu popUpInWorld: self!
- aMenu popUpInWorld: ActiveWorld!
Item was changed:
----- Method: PasteUpMorph>>putUpWorldMenuFromEscapeKey (in category 'world menu') -----
putUpWorldMenuFromEscapeKey
Preferences noviceMode
+ ifFalse: [self putUpWorldMenu: self currentEvent]!
- ifFalse: [self putUpWorldMenu: ActiveEvent]!
Item was changed:
----- Method: PasteUpMorph>>repositionFlapsAfterScreenSizeChange (in category 'world state') -----
repositionFlapsAfterScreenSizeChange
"Reposition flaps after screen size change"
+ (Flaps globalFlapTabsIfAny, self localFlapTabs) do:
- (Flaps globalFlapTabsIfAny, ActiveWorld localFlapTabs) do:
[:aFlapTab |
aFlapTab applyEdgeFractionWithin: self bounds].
Flaps doAutomaticLayoutOfFlapsIfAppropriate!
Item was changed:
----- Method: PasteUpMorph>>restoreMorphicDisplay (in category 'world state') -----
restoreMorphicDisplay
self removeProperty: #shouldDisplayWorld.
ThumbnailMorph recursionReset.
self
extent: Display extent;
viewBox: Display boundingBox;
handsDo: [:h | h visible: true; showTemporaryCursor: nil];
+ " restoreFlapsDisplay;
- restoreFlapsDisplay;
restoreMainDockingBarDisplay;
+ " fullRepaintNeeded.
- fullRepaintNeeded.
-
- WorldState
- addDeferredUIMessage: [Cursor normal show].
!
Item was changed:
----- Method: PasteUpMorph>>saveOnFile (in category 'objects from disk') -----
saveOnFile
"Ask the user for a filename and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. UniClasses will be filed out."
| aFileName fileStream |
self flag: #bob0302.
self isWorldMorph ifTrue: [^self project saveAs].
+ aFileName := ('my {1}' translated format: {self class name}) , '.project' asFileName. "do better?"
- aFileName := ('my {1}.project' translated format: {self class name}) asFileName. "do better?"
aFileName := UIManager default saveFilenameRequest: 'File name?' translated
initialAnswer: aFileName.
aFileName ifNil: [^ Beeper beep].
self allMorphsDo: [:m | m prepareToBeSaved].
fileStream := FileStream newFileNamed: aFileName.
fileStream fileOutClass: nil andObject: self. "Puts UniClass definitions out anyway"!
Item was removed:
- ----- Method: PasteUpMorph>>setGridSpec (in category 'gridding') -----
- setGridSpec
- "Gridding rectangle provides origin and modulus"
- | response result |
- response := UIManager default
- request: 'New grid origin (usually 0@0):' translated
- initialAnswer: self gridOrigin printString.
- response isEmpty ifTrue: [^ self].
- result := [Compiler evaluate: response] ifError: [^ self].
- (result isPoint and: [(result >= (0@0))])
- ifTrue: [self gridOrigin: result]
- ifFalse: [self inform: ('Must be a Point with coordinates (for example 10@10)' translated )].
-
- response := UIManager default
- request: 'New grid spacing:' translated
- initialAnswer: self gridModulus printString.
- response isEmpty ifTrue: [^ self].
- result := [Compiler evaluate: response] ifError: [^ self].
- (result isPoint and: [(result > (0@0)) ])
- ifTrue: [self gridModulus: result]
- ifFalse: [self inform: ('Must be a Point with coordinates (for example 10@10)' translated )].
-
- !
Item was changed:
----- Method: PasteUpMorph>>tryInvokeHalo: (in category 'events-processing') -----
tryInvokeHalo: aUserInputEvent
+
- "Invoke halos around the top-most world container at aUserInputEvent's #position. If it was already halo'd, zero-in on its next inward component morph at that position. Holding Shift during the click reverses this traversal order."
- | stack innermost haloTarget |
Preferences noviceMode ifTrue: [ ^ self ].
Morph haloForAll ifFalse: [ ^ self ].
+
+ (self transferHalo: aUserInputEvent)
+ ifTrue: "The event was handled, don't let it cause any further side-effects."
+ [ aUserInputEvent ignore ].!
- "the stack is the top-most morph to bottom-most."
- stack := (self morphsAt: aUserInputEvent position unlocked: true) select:
- [ : each | each wantsHaloFromClick or: [ each handlesMouseDown: aUserInputEvent ] ].
- innermost := aUserInputEvent hand halo
- ifNil: [ stack first ]
- ifNotNil:
- [ : existingHalo | (stack copyWithout: existingHalo) "No halos on halos"
- detect: [ : each | each owner == self ]
- ifFound:
- [ : worldContainer | "Is existingHalo's target part of the same worldContainer as the morph clicked?"
- (existingHalo target withAllOwners includes: worldContainer)
- ifTrue: [ "same hierarchy, let #transferHalo: continue to handle it for now." ^self ]
- ifFalse:
- [ "different hierarchy, remove + add."
- aUserInputEvent hand removeHalo.
- aUserInputEvent shiftPressed
- ifTrue: [ stack second "first is still the just removed halo" ]
- ifFalse: [ worldContainer ] ] ]
- ifNone: [ "existingHalo is on the World, defer to #transferHalo: for now." ^self ] ].
- "If modifier key is pressed, start at innermost (the target), otherwise the outermost (direct child of the world (self))."
- haloTarget := (innermost == self or: [aUserInputEvent shiftPressed])
- ifTrue: [ innermost ]
- ifFalse:
- [ "Find the outermost owner that wants it."
- innermost withAllOwners reversed allButFirst
- detect: [ : each | each wantsHaloFromClick ]
- ifNone: [ "haloTarget has its own mouseDown handler, don't halo." ^ self ] ].
- "Now that we have the haloTarget, show the halo."
- aUserInputEvent hand
- newMouseFocus: haloTarget
- event: aUserInputEvent.
- haloTarget invokeHaloOrMove: aUserInputEvent.
- "aUserInputEvent has been consumed, don't let it cause any further side-effects."
- aUserInputEvent ignore!
Item was changed:
----- Method: PasteUpMorph>>tryInvokeKeyboardShortcut: (in category 'events-processing') -----
tryInvokeKeyboardShortcut: aKeyboardEvent
aKeyboardEvent commandKeyPressed ifFalse: [^ self].
aKeyboardEvent keyCharacter caseOf: {
[$R] -> [Utilities browseRecentSubmissions].
[$L] -> [self findAFileList: aKeyboardEvent].
[$O] -> [self findAMonticelloBrowser].
[$P] -> [self findAPreferencesPanel: aKeyboardEvent].
"[$Z] -> [ChangeList browseRecentLog]."
+ [$]] -> [LegacyShortcutsFilter legacyShortcutsEnabled
+ ifTrue: [^ self "Keep going."]
+ ifFalse: [Smalltalk snapshot: true andQuit: false]].
- [$]] -> [Smalltalk snapshot: true andQuit: false].
} otherwise: [^ self "no hit"].
aKeyboardEvent ignore "hit!!".!
Item was removed:
- ----- Method: PasteUpMorph>>wantsDropFiles: (in category 'event handling') -----
- wantsDropFiles: anEvent
- ^self isWorldMorph!
Item was added:
+ ----- Method: PasteUpMorph>>wantsDroppedTransferMorph: (in category 'dropping/grabbing') -----
+ wantsDroppedTransferMorph: transferMorph
+
+ ^ self hasTransferMorphConverter
+ or: [transferMorph dragTransferType = #filesAndDirectories]
+ or: [transferMorph dragTransferType = #sourceCode]!
Item was changed:
----- Method: PasteUpMorph>>windowEvent: (in category 'event handling') -----
windowEvent: anEvent
self windowEventHandler
ifNotNil: [^self windowEventHandler windowEvent: anEvent].
+ anEvent type
+ caseOf: {
+ [#windowClose] -> [
+ Preferences eToyFriendly
+ ifTrue: [ProjectNavigationMorph basicNew quitSqueak]
+ ifFalse: [TheWorldMenu basicNew quitSession]].
+
+ [#windowDeactivated] -> [
+ "The host window has been deactivated. Until it regains the focus, honor the fact that we will not receive keyboard events again by changing the current keyboard focus morph. windowHostFocusMorph represents the host system which now holds the keyboard focus instead of the previousFocus. If enabled, disable #mouseOverForKeyboardFocus temporarily because when inactive, we *can't* set the keyboard focus."
+ (self valueOfProperty: #windowHostFocusMorph ifAbsentPut: [
+ Morph new
+ name: #windowHostFocusMorph;
+ yourself]) in: [:hostFocus |
+ hostFocus setProperty: #previousFocus toValue: anEvent hand keyboardFocus.
+ anEvent hand newKeyboardFocus: hostFocus.
+ Preferences mouseOverForKeyboardFocus ifTrue: [
+ hostFocus setProperty: #previousMouseOverForKeyboardFocus toValue: true.
+ Preferences setPreference: #mouseOverForKeyboardFocus toValue: false]]].
+ [#windowActivated] -> [
+ "Alright, the spook is over!! We have back control over the keyboard focus, delete the windowHostFocusMorph and restore the previous focus holder and the #mouseOverForKeyboardFocus preference."
+ self valueOfProperty: #windowHostFocusMorph ifPresentDo: [:hostFocus |
+ hostFocus abandon.
+ (hostFocus valueOfProperty: #previousFocus) ifNotNil: [:previousFocus |
+ anEvent hand newKeyboardFocus: previousFocus].
+ (hostFocus valueOfProperty: #previousMouseOverForKeyboardFocus) ifNotNil: [:value |
+ Preferences setPreference: #mouseOverForKeyboardFocus toValue: value].
+ self removeProperty: #windowHostFocusMorph]]. }
+ otherwise: []!
- anEvent type == #windowClose
- ifTrue: [
- ^Preferences eToyFriendly
- ifTrue: [ProjectNavigationMorph basicNew quitSqueak]
- ifFalse: [TheWorldMenu basicNew quitSession]].
- !
Item was changed:
Morph subclass: #PluggableButtonMorph
+ instanceVariableNames: 'model label font getStateSelector actionSelector getLabelSelector getMenuSelector shortcutCharacter askBeforeChanging triggerOnMouseDown offColor onColor feedbackColor showSelectionFeedback arguments argumentsProvider argumentsSelector style hoverColor borderColor textColor labelOffset wantsGradient'
- instanceVariableNames: 'model label font getStateSelector actionSelector getLabelSelector getMenuSelector shortcutCharacter askBeforeChanging triggerOnMouseDown offColor onColor feedbackColor showSelectionFeedback allButtons arguments argumentsProvider argumentsSelector style hoverColor borderColor textColor labelOffset wantsGradient'
classVariableNames: 'GradientButton RoundedButtonCorners'
poolDictionaries: ''
category: 'Morphic-Pluggable Widgets'!
!PluggableButtonMorph commentStamp: '<historical>' prior: 0!
A PluggableButtonMorph is a combination of an indicator for a boolean value stored in its model and an action button. The action of a button is often, but not always, to toggle the boolean value that it shows. Its pluggable selectors are:
getStateSelector fetch a boolean value from the model
actionSelector invoke this button's action on the model
getLabelSelector fetch this button's lable from the model
getMenuSelector fetch a pop-up menu for this button from the model
Any of the above selectors can be nil, meaning that the model does not supply behavior for the given action, and the default behavior should be used. For example, if getStateSelector is nil, then this button shows the state of a read-only boolean that is always false.
The model informs its view(s) of changes by sending #changed: to itself with getStateSelector as a parameter. The view tells the model when the button is pressed by sending actionSelector.
If the actionSelector takes one or more arguments, then the following are relevant:
arguments A list of arguments to provide when the actionSelector is called.
argumentsProvider The object that is sent the argumentSelector to obtain arguments, if dynamic
argumentsSelector The message sent to the argumentProvider to obtain the arguments.
Options:
askBeforeChanging have model ask user before allowing a change that could lose edits
triggerOnMouseDown do this button's action on mouse down (vs. up) transition
shortcutCharacter a place to record an optional shortcut key
!
Item was added:
+ ----- Method: PluggableButtonMorph class>>labelMargins (in category 'defaults') -----
+ labelMargins
+
+ | inset |
+ inset := (4 * RealEstateAgent scaleFactor) truncated.
+ ^ inset @ 0 corner: inset @ 0!
Item was added:
+ ----- Method: PluggableButtonMorph class>>themePriority (in category 'preferences') -----
+ themePriority
+
+ ^ 50!
Item was changed:
----- Method: PluggableButtonMorph>>browseImplementationOfActionSelector (in category 'debug menu') -----
browseImplementationOfActionSelector
| method |
+ self updateArguments.
+ method := self effectiveActionTarget class lookupSelector: self effectiveActionSelector.
- method := model class lookupSelector: actionSelector.
ToolSet browse: method methodClass selector: method selector.!
Item was changed:
----- Method: PluggableButtonMorph>>debugAction (in category 'debug menu') -----
debugAction
+ self updateArguments.
+
(Process
+ forBlock: [self doButtonAction]
+ runUntil: [:context | context selector = self effectiveActionSelector])
+ debugWithTitle: ('Debug button action "{1}" in model "{2}"' translated format: {self label. self target printString}).!
- forBlock: [self performAction]
- runUntil: [:context | context selector = self actionSelector])
- debugWithTitle: ('Debug button action "{1}" in model "{2}"' format: {self label. self target printString}).!
Item was added:
+ ----- Method: PluggableButtonMorph>>defaultLayoutInset (in category 'layout') -----
+ defaultLayoutInset
+
+ ^ self class labelMargins!
Item was added:
+ ----- Method: PluggableButtonMorph>>doButtonAction (in category 'button') -----
+ doButtonAction
+
+ ^ self performAction!
Item was added:
+ ----- Method: PluggableButtonMorph>>effectiveActionSelector (in category 'debug menu') -----
+ effectiveActionSelector
+
+ ^ self actionSelector = #perform:orSendTo:
+ ifTrue: [arguments first]
+ ifFalse: [self actionSelector]!
Item was added:
+ ----- Method: PluggableButtonMorph>>effectiveActionTarget (in category 'debug menu') -----
+ effectiveActionTarget
+
+ ^ (self actionSelector = #perform:orSendTo:
+ and: [(self target respondsTo: self effectiveActionSelector) not])
+ ifTrue: [arguments second]
+ ifFalse: [self target]!
Item was changed:
+ ----- Method: PluggableButtonMorph>>hResizing: (in category 'layout properties') -----
- ----- Method: PluggableButtonMorph>>hResizing: (in category 'layout-properties') -----
hResizing: aSymbol
"We adapt our minimum extent according to our resize behavior."
self hResizing == aSymbol ifTrue: [^ self].
super hResizing: aSymbol.
self updateMinimumExtent.!
Item was changed:
----- Method: PluggableButtonMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
"Layout properties."
self
extent: 20 @ 15;
+ clipSubmorphs: true.
+
+ "Set layout properties directly to avoid unnecessary calls to #updateMinimumExtent. Should be replaced with #assureLayoutProperties in the future."
+ self assureTableLayoutProperties
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
+ layoutInset: self defaultLayoutInset;
- layoutInset: (4@0 corner: 4@0);
- clipSubmorphs: true;
wrapCentering: #center;
cellPositioning: #topCenter.
"Initialize instance variables."
model := nil.
label := nil.
getStateSelector := nil.
actionSelector := nil.
getLabelSelector := nil.
getMenuSelector := nil.
shortcutCharacter := nil.
askBeforeChanging := false.
triggerOnMouseDown := false.
allButtons := nil.
argumentsProvider := nil.
argumentsSelector := nil.
self setDefaultParameters.
!
Item was added:
+ ----- Method: PluggableButtonMorph>>isButton (in category 'classification') -----
+ isButton
+
+ ^ true!
Item was changed:
----- Method: PluggableButtonMorph>>label: (in category 'accessing') -----
label: aStringOrTextOrMorph
label = aStringOrTextOrMorph ifTrue: [^ self].
label := aStringOrTextOrMorph isString
ifFalse: [aStringOrTextOrMorph asMorph]
ifTrue: [aStringOrTextOrMorph].
+
+ aStringOrTextOrMorph isText
+ ifTrue: [ "Allow custom formatting through clients. Fall back to button font."
+ label "aTextMorph" textStyle: self font asNewTextStyle].
+ aStringOrTextOrMorph isString
+ ifFalse: [ "Configure StringMorph with the correct font. See Object >> #asMorph."
+ (label respondsTo: #font:) ifTrue: [label font: self font]].
self updateMinimumExtent.
self changed.!
Item was changed:
----- Method: PluggableButtonMorph>>label:font: (in category 'accessing') -----
label: aStringOrTextOrMorph font: aFont
+ font := aFont. "Must set font first. See #label: and text support."
self label: aStringOrTextOrMorph.
+ !
- self font: aFont. !
Item was changed:
----- Method: PluggableButtonMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
- "Details: If this button is triggered on mouse down or the event is the menu gesture, handle it immediately. Otherwise, make a list of buttons (including the receiver) for mouseMove feedback. This allows a simple radio-button effect among the button submorphs of a given morph."
- allButtons := nil.
evt yellowButtonPressed ifTrue: [^ self invokeMenu: evt].
triggerOnMouseDown
ifTrue: [self performAction]
+ ifFalse: [self updateFillStyle: evt].
- ifFalse: [
- allButtons := owner submorphs select: [:m | m class = self class].
- self updateFillStyle: evt].
!
Item was changed:
----- Method: PluggableButtonMorph>>mouseMove: (in category 'event handling') -----
mouseMove: evt
+ self updateFillStyle: evt.!
- allButtons ifNil: [^ self].
- allButtons do: [:m | m updateFillStyle: evt].!
Item was changed:
----- Method: PluggableButtonMorph>>mouseUp: (in category 'event handling') -----
mouseUp: evt
self updateFillStyle: evt.
+ (self containsPoint: evt cursorPoint)
+ ifTrue: [self performAction].!
-
- allButtons ifNil: [^ self].
- allButtons do: [:m |
- (m containsPoint: evt cursorPoint) ifTrue: [m performAction]].
- allButtons := nil.
- self changed.
- !
Item was changed:
+ ----- Method: PluggableButtonMorph>>performAction (in category 'event handling') -----
- ----- Method: PluggableButtonMorph>>performAction (in category 'accessing') -----
performAction
"Inform the model that this button has been pressed. Sent by the controller when this button is pressed. If the button's actionSelector takes any arguments, they are obtained dynamically by sending the argumentSelector to the argumentsProvider"
askBeforeChanging ifTrue: [model okToChange ifFalse: [^ self]].
actionSelector ifNotNil:
[actionSelector numArgs = 0
ifTrue:
[model perform: actionSelector]
ifFalse:
+ [self updateArguments.
- [argumentsProvider ifNotNil:
- [arguments := argumentsProvider perform: argumentsSelector].
model perform: actionSelector withArguments: arguments]]!
Item was changed:
----- Method: PluggableButtonMorph>>setDefaultParameters (in category 'initialization') -----
setDefaultParameters
"change the receiver's appareance parameters"
self
color: (self userInterfaceTheme color ifNil: [Color gray: 0.91]);
borderStyle: (self userInterfaceTheme borderStyle ifNil: [BorderStyle default]) copy;
borderColor: (self userInterfaceTheme borderColor ifNil: [Color gray]);
+ borderWidth: ((self userInterfaceTheme borderWidth ifNil: [1]) * RealEstateAgent scaleFactor) truncated;
- borderWidth: (self userInterfaceTheme borderWidth ifNil: [1]);
font: (self userInterfaceTheme font ifNil: [TextStyle defaultFont]);
textColor: (self userInterfaceTheme textColor ifNil: [Color black]).
borderColor := self borderColor.
self offColor: self color.!
Item was added:
+ ----- Method: PluggableButtonMorph>>updateArguments (in category 'updating') -----
+ updateArguments
+
+ argumentsProvider ifNil: [^ self].
+ argumentsSelector ifNil: [^ self].
+ arguments := argumentsProvider perform: argumentsSelector.!
Item was changed:
----- Method: PluggableButtonMorph>>updateMinimumExtent (in category 'layout') -----
updateMinimumExtent
| hMin vMin |
self label isMorph
ifTrue: [^ self minimumExtent: self label minExtent].
hMin := vMin := 0.
self hResizing ~~ #spaceFill
+ ifTrue: [hMin := (self font widthOfString: self label) max: (self font widthOf: $x) * 3].
- ifTrue: [hMin := (self font widthOfString: self label)].
self vResizing ~~ #spaceFill
+ ifTrue: [vMin := self font lineGrid].
- ifTrue: [vMin := self font height].
hMin := hMin + (2* self borderStyle width).
vMin := vMin + (2* self borderStyle width).
self layoutInset isRectangle
ifTrue: [
hMin := hMin + self layoutInset left + self layoutInset right.
vMin := vMin + self layoutInset top + self layoutInset bottom]
ifFalse: [self layoutInset isPoint
ifTrue: [
hMin := hMin + (2* self layoutInset x).
vMin := vMin + (2* self layoutInset y)]
ifFalse: [
hMin := hMin + (2* self layoutInset).
vMin := vMin + (2* self layoutInset)]].
self minimumExtent: hMin @ vMin.
"Since we have no submorphs, we have to resize here if we want to shrink wrap."
self hResizing == #shrinkWrap ifTrue: [self width: hMin].
self vResizing == #shrinkWrap ifTrue: [self height: vMin].!
Item was changed:
+ ----- Method: PluggableButtonMorph>>vResizing: (in category 'layout properties') -----
- ----- Method: PluggableButtonMorph>>vResizing: (in category 'layout-properties') -----
vResizing: aSymbol
"We adapt our minimum extent according to our resize behavior."
self vResizing == aSymbol ifTrue: [^ self].
super vResizing: aSymbol.
self updateMinimumExtent.!
Item was added:
+ ----- Method: PluggableListMorph class>>listMargins (in category 'defaults') -----
+ listMargins
+
+ ^(3 * RealEstateAgent scaleFactor) truncated @0 corner: 0@0!
Item was changed:
+ ----- Method: PluggableListMorph>>allSubmorphNamesDo: (in category 'submorphs - accessing') -----
- ----- Method: PluggableListMorph>>allSubmorphNamesDo: (in category 'submorphs-accessing') -----
allSubmorphNamesDo: nameBlock
"Assume list morphs do not have named parts -- saves MUCH time"
^ self!
Item was changed:
----- Method: PluggableListMorph>>balloonText (in category 'accessing') -----
balloonText
"Overridden to send selector to model and not self. Do not use #perform:orSendTo: because super does more than just the send.."
self getHelpSelector ifNotNil: [:selector |
+ (self model respondsTo: selector) ifTrue: [
+ | modelIndex |
+ (modelIndex := self modelIndexFor: self hoverRow) > 0 ifTrue: [
+ ^ self model perform: selector with: modelIndex]]].
- ((self model respondsTo: selector) and: [self hoverRow > 0]) ifTrue: [
- ^ self model perform: selector with: (self modelIndexFor: self hoverRow)]].
^ super balloonText!
Item was changed:
----- Method: PluggableListMorph>>createListMorph (in category 'initialization') -----
createListMorph
^ self listMorphClass new
listSource: self;
+ cellInset: self class listMargins;
hResizing: #spaceFill;
vResizing: #shrinkWrap;
cellPositioning: #leftCenter;
setProperty: #indicateKeyboardFocus toValue: #never;
yourself.!
Item was changed:
----- Method: PluggableListMorph>>debugGetList (in category 'debug and other') -----
debugGetList
(Process
forBlock: [model perform: getListSelector]
runUntil: [:context | context selector = getListSelector])
+ debugWithTitle: ('Debug get-list invocation in model "{1}"' translated format: {model printString}).!
- debugWithTitle: ('Debug get-list invocation in model "{1}"' format: {model printString}).!
Item was added:
+ ----- Method: PluggableListMorph>>displayScaleChangedBy: (in category 'display scale') -----
+ displayScaleChangedBy: factor
+
+ | currentMargins |
+ super displayScaleChangedBy: factor.
+ (currentMargins := self listMorph cellInset) isRectangle
+ ifTrue: [self listMorph cellInset: ((currentMargins origin * factor) rounded corner: (currentMargins corner * factor) rounded)]
+ ifFalse: [self listMorph cellInset: (currentMargins * factor) rounded].!
Item was changed:
----- Method: PluggableListMorph>>filterList:matching: (in category 'filtering') -----
filterList: someItems matching: aPattern
"Filter someStrings according to aPattern. Prepend best matches in the result. Update the model-to-view map."
| frontMatching substringMatching tmp |
aPattern ifEmpty: [ ^ someItems ].
someItems ifEmpty: [ ^ someItems ].
frontMatching := OrderedCollection new.
substringMatching := OrderedCollection new.
+ self assert: modelToView isEmpty.
+ self assert: viewToModel isEmpty.
- modelToView := Dictionary new.
- viewToModel := Dictionary new.
tmp := OrderedCollection new.
+ someItems withIndexDo:
- someItems doWithIndex:
[ :each :n | | foundPos |
foundPos := self filterListItem: each matching: aPattern.
foundPos = 1
ifTrue:
[ frontMatching add: each.
modelToView at: n put: frontMatching size.
viewToModel at: frontMatching size put: n ]
ifFalse:
[ foundPos > 1 ifTrue:
[ substringMatching add: each.
tmp add: n; add: substringMatching size ] ] ].
tmp pairsDo: [:modelIndex :viewIndex |
modelToView at: modelIndex put: viewIndex + frontMatching size.
viewToModel at: viewIndex + frontMatching size put: modelIndex].
^ frontMatching, substringMatching!
Item was changed:
----- Method: PluggableListMorph>>handleMouseMove: (in category 'events-processing') -----
handleMouseMove: anEvent
+ anEvent wasHandled ifFalse: [self hoverRow: (self rowAtLocation: anEvent position)].
+ super handleMouseMove: anEvent.!
- "Reimplemented because we really want #mouseMove when a morph is dragged around"
- anEvent wasHandled ifTrue:[^self]. "not interested"
- self hoverRow: (self rowAtLocation: anEvent position).
- (anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self].
- anEvent wasHandled: true.
- self mouseMove: anEvent.
- (self handlesMouseStillDown: anEvent) ifTrue:[
- "Step at the new location"
- self startStepping: #handleMouseStillDown:
- at: Time millisecondClockValue
- arguments: {anEvent copy resetHandlerFields}
- stepTime: 1].
- !
Item was added:
+ ----- Method: PluggableListMorph>>handlesMouseMove: (in category 'event handling') -----
+ handlesMouseMove: anEvent
+ ^ anEvent anyButtonPressed and: [anEvent hand mouseFocus == self]!
Item was changed:
----- Method: PluggableListMorph>>initialize (in category 'initialization') -----
initialize
-
listMorph := self createListMorph.
super initialize.
-
self scroller
layoutPolicy: TableLayout new;
addMorph: listMorph.
+ self
+ minimumWidth: (self font widthOf: $m) * 5 ;
+ minimumHeight: self font height
- self minimumWidth: (self font widthOf: $m) * 5.
-
!
Item was changed:
----- Method: PluggableListMorph>>mouseDown: (in category 'event handling') -----
mouseDown: evt
| selectors row |
row := self rowAtLocation: evt position.
evt yellowButtonPressed "First check for option (menu) click"
ifTrue: [
+ ((self selectionIndex ~= row
+ and: [self class menuRequestUpdatesSelection])
+ and: [model okToChange]) ifTrue: [
+ "Models depend on the correct selection:"
+ self changeModelSelection: (self modelIndexFor: row)].
- (self class menuRequestUpdatesSelection and: [model okToChange]) ifTrue: [
- "Models depend on the correct selection:"
- self selectionIndex = row
- ifFalse: [self changeModelSelection: (self modelIndexFor: row)]].
^ self yellowButtonActivity: evt shiftPressed].
row = 0 ifTrue: [^super mouseDown: evt].
"self dragEnabled ifTrue: [aMorph highlightForMouseDown]."
selectors := Array
with: #click:
with: (doubleClickSelector ifNotNil:[#doubleClick:])
with: nil
with: (self dragEnabled ifTrue:[#startDrag:] ifFalse:[nil]).
evt hand waitForClicksOrDrag: self event: evt selectors: selectors threshold: HandMorph dragThreshold "pixels".!
Item was changed:
----- Method: PluggableListMorph>>mouseLeave: (in category 'event handling') -----
mouseLeave: event
super mouseLeave: event.
self hoverRow: nil.
+ self resetPotentialDropRow.
Preferences mouseOverForKeyboardFocus
ifTrue: [event hand releaseKeyboardFocus: self].!
Item was changed:
+ ----- Method: PluggableListMorph>>mouseLeaveDragging: (in category 'events') -----
- ----- Method: PluggableListMorph>>mouseLeaveDragging: (in category 'event handling') -----
mouseLeaveDragging: anEvent
self hoverRow: nil.
+ anEvent hand releaseMouseFocus: self.
(self dropEnabled and:[anEvent hand hasSubmorphs]) ifFalse: ["no d&d"
^ super mouseLeaveDragging: anEvent].
self resetPotentialDropRow.
- anEvent hand releaseMouseFocus: self.
"above is ugly but necessary for now"
!
Item was changed:
----- Method: PluggableListMorph>>mouseUp: (in category 'event handling') -----
mouseUp: event
| row |
model okToChange ifFalse: [^ self].
+ (self containsPoint: event position) ifFalse: [^ self].
row := self rowAtLocation: event position.
row = self selectionIndex
ifTrue: [(autoDeselect ifNil: [true]) ifTrue: [row = 0 ifFalse: [self changeModelSelection: 0] ]]
ifFalse: [self changeModelSelection: (self modelIndexFor: row)].
event hand newKeyboardFocus: self.
hasFocus := true.
Cursor normal show.!
Item was changed:
----- Method: PluggableListMorph>>selectionIndex: (in category 'selection') -----
selectionIndex: viewIndex
"Called internally to select the index-th item."
+ self selectionIndex = viewIndex ifTrue: [^ self].
+
self unhighlightSelection.
self listMorph selectedRow: (viewIndex min: self listSize).
self highlightSelection.
self scrollSelectionIntoView.!
Item was changed:
----- Method: PluggableListMorph>>specialKeyPressed: (in category 'model access - keystroke') -----
specialKeyPressed: asciiValue
"A special key with the given ascii-value was pressed; dispatch it"
| oldSelection nextSelection max howManyItemsShowing |
(#(8 13) includes: asciiValue) ifTrue:
[ "backspace key - clear the filter, restore the list with the selection"
model okToChange ifFalse: [^ self].
self removeFilter.
priorSelection ifNotNil:
[ | prior |
prior := priorSelection.
priorSelection := self getCurrentSelectionIndex.
asciiValue = 8 ifTrue: [ self changeModelSelection: prior ] ].
^ self ].
asciiValue = 27 ifTrue:
[" escape key"
+ ^ self currentEvent shiftPressed
- ^ ActiveEvent shiftPressed
ifTrue:
+ [self currentWorld putUpWorldMenuFromEscapeKey]
- [ActiveWorld putUpWorldMenuFromEscapeKey]
ifFalse:
[self yellowButtonActivity: false]].
max := self maximumSelection.
max > 0 ifFalse: [^ self].
nextSelection := oldSelection := self selectionIndex.
asciiValue = 31 ifTrue:
[" down arrow"
nextSelection := oldSelection + 1.
nextSelection > max ifTrue: [nextSelection := 1]].
asciiValue = 30 ifTrue:
[" up arrow"
nextSelection := oldSelection - 1.
nextSelection < 1 ifTrue: [nextSelection := max]].
asciiValue = 1 ifTrue:
[" home"
nextSelection := 1].
asciiValue = 4 ifTrue:
[" end"
nextSelection := max].
howManyItemsShowing := self numSelectionsInView.
asciiValue = 11 ifTrue:
[" page up"
nextSelection := 1 max: oldSelection - howManyItemsShowing].
asciiValue = 12 ifTrue:
[" page down"
nextSelection := oldSelection + howManyItemsShowing min: max].
model okToChange ifFalse: [^ self].
"No change if model is locked"
oldSelection = nextSelection ifTrue: [^ self flash].
^ self changeModelSelection: (self modelIndexFor: nextSelection)!
Item was changed:
----- Method: PluggableListMorph>>startDrag: (in category 'drag and drop') -----
startDrag: evt
| item itemMorph |
evt hand hasSubmorphs ifTrue: [^ self].
self model okToChange ifFalse: [^ self].
"Ensure selection to save additional click."
(self rowAtLocation: evt position) in: [:clickedRow |
self selectionIndex = clickedRow
ifFalse: [self changeModelSelection: (self modelIndexFor: clickedRow)]].
item := self selection ifNil: [^ self].
itemMorph := StringMorph contents: item asStringOrText.
[ "Initiate drag."
(self model dragPassengerFor: itemMorph inMorph: self) ifNotNil: [:passenger | | ddm |
ddm := (self valueOfProperty: #dragTransferClass ifAbsent: [TransferMorph]) withPassenger: passenger from: self.
ddm dragTransferType: (self model dragTransferTypeForMorph: self).
ddm updateFromUserInputEvent: evt.
self model dragStartedFor: itemMorph transferMorph: ddm.
+ evt hand grabMorph: ddm.
+ self mouseEnterDragging: evt "Enable internal move"]
+ ] ensure: [Cursor normal show].!
- evt hand grabMorph: ddm]
- ] ensure: [
- Cursor normal show.
- evt hand releaseMouseFocus: self].!
Item was removed:
- ----- Method: PluggableListMorph>>textHighlightColor (in category 'initialization') -----
- textHighlightColor
- "Answer my default text highlight color."
- ^self valueOfProperty: #textHighlightColor ifAbsent: [ self textColor negated ].
- !
Item was removed:
- ----- Method: PluggableListMorph>>textHighlightColor: (in category 'initialization') -----
- textHighlightColor: aColor
- "Set my default text highlight color."
- self setProperty: #textHighlightColor toValue: aColor.
- !
Item was changed:
----- Method: PluggableListMorph>>updateList: (in category 'updating') -----
updateList: modelList
"Keeps the current filter as it is."
fullList := modelList.
- self resetPotentialDropRow.
self updateListFilter.!
Item was changed:
----- Method: PluggableListMorph>>updateListFilter (in category 'updating') -----
updateListFilter
| selection |
selection := self selectionIndex = 0 "Avoid fetching #getList here."
ifTrue: [nil]
ifFalse: [self selection].
list := nil.
+ modelToView := Dictionary new.
+ viewToModel := Dictionary new.
+
- modelToView := nil.
- viewToModel := nil.
-
self getList.
"Try to restore the last selection."
selection ifNotNil: [self selection: selection].!
Item was changed:
----- Method: PluggableListMorphOfMany>>specialKeyPressed: (in category 'model access') -----
specialKeyPressed: asciiValue
"Toggle the selection on [space]."
asciiValue = Character space asciiValue
ifTrue: [ | index |
+ index := self getCurrentSelectionIndex.
+ index = 0 ifTrue: [^ self].
- index := self getCurrentSelectionIndex.
self
listSelectionAt: index
put: ((self listSelectionAt: index) not).
^ self].
super specialKeyPressed: asciiValue.!
Item was changed:
----- Method: PluggableMultiColumnListMorph>>getFullList (in category 'model access - cached') -----
getFullList
"The full list arranges all items column-first."
fullList ifNotNil: [^ fullList].
fullList := getListSelector
ifNotNil: [:selector | "A) Fetch the list column-first from the model."
model perform: selector]
ifNil: [
(getListSizeSelector notNil and: [getListElementSelector notNil])
ifFalse: ["X) We cannot fetch the list from the model. Make it empty."
#()]
ifTrue: [ "B) Fetch the list row-first from the model:"
| listSize |
listSize := self getListSize.
listSize = 0 ifTrue: [#() "Empty list"] ifFalse: [
| firstRow columns |
firstRow := self getListItem: 1.
columns := Array new: firstRow size.
1 to: columns size do: [:columnIndex |
"Initialize all columns."
columns at: columnIndex put: (Array new: listSize).
"Put the first row in."
(columns at: columnIndex) at: 1 put: (firstRow at: columnIndex)].
"Put all other rows in."
2 to: listSize do: [:rowIndex | (self getListItem: rowIndex)
+ withIndexDo: [:item :columnIndex |
- doWithIndex: [:item :columnIndex |
(columns at: columnIndex) at: rowIndex put: item]].
columns]]].
self updateColumns.
^ fullList!
Item was changed:
----- Method: PluggableMultiColumnListMorph>>selection: (in category 'selection') -----
selection: someObjects
| found |
someObjects size ~= self columnCount ifTrue: [^ self].
1 to: self listSize do: [:row |
found := true.
+ self getList withIndexDo: [:items :column |
- self getList doWithIndex: [:items :column |
found := found and: [(items at: row) = (someObjects at: column)]].
found ifTrue: [^ self selectionIndex: row]].!
Item was changed:
----- Method: PluggableMultiColumnListMorph>>selectionIndex: (in category 'selection') -----
selectionIndex: viewIndex
listMorphs do: [:listMorph | listMorph selectedRow: (viewIndex min: self listSize)].
+
+ "ct: As per the invariant defined in #setListParameters, listMorphs always includes listMorph. Subsequently, every super send in #selectionIndex: would be without effect because #selectionIndex already has been updated in the child class. Since selection highlighting is also not relevant for multi-column list morphs (this hook is only used by SimpleHierarchicalListMorph), we can refuse this bequest but send #scrollSelectionIntoView manually."
+ self scrollSelectionIntoView.!
- super selectionIndex: viewIndex.!
Item was changed:
----- Method: PluggableMultiColumnListMorph>>updateColumns (in category 'updating') -----
updateColumns
"The number of columns must match the number of list morphs."
| columnsChanged |
columnsChanged := self columnCount ~= listMorphs size.
[self columnCount < listMorphs size]
whileTrue: [
listMorphs removeLast delete].
[self columnCount > listMorphs size]
whileTrue: [
listMorphs addLast: self createListMorph.
self scroller addMorphBack: listMorphs last].
+ listMorphs withIndexDo: [:listMorph :columnIndex |
- listMorphs doWithIndex: [:listMorph :columnIndex |
listMorph
columnIndex: columnIndex;
color: self textColor;
cellPositioning: (self cellPositioningAtColumn: columnIndex);
cellInset: (self cellInsetAtColumn: columnIndex);
hResizing: (self hResizingAtColumn: columnIndex);
spaceFillWeight: (self spaceFillWeightAtColumn: columnIndex)].
columnsChanged ifTrue: [self setListParameters].!
Item was changed:
----- Method: PluggableMultiColumnListMorph>>verifyContents (in category 'updating') -----
verifyContents
"Verify the contents of the receiver, reconstituting if necessary. Called whenever window is reactivated, to react to possible structural changes. Also called periodically in morphic if the smartUpdating preference is true"
| changed currentList modelList modelIndex |
self flag: #performance. "mt: We do have changed/update. Why can't the tools communicate through an appropriate notifier such as the SystemChangeNotifier?"
"1) Is the list still up to date?"
currentList := fullList. fullList := nil.
modelList := self getFullList.
changed := false.
+ modelList withIndexDo: [:column :index |
- modelList doWithIndex: [:column :index |
changed := changed or: [(currentList at: index) ~= column]].
changed ifFalse: [^ self].
self updateList: modelList.
"2) Is the selection still up to date?"
modelIndex := self getCurrentSelectionIndex.
(self modelIndexFor: self selectionIndex) = modelIndex ifTrue: [^ self].
self updateListSelection: modelIndex.!
Item was changed:
----- Method: PluggableMultiColumnListMorphByItem>>getCurrentSelectionIndex (in category 'model access') -----
getCurrentSelectionIndex
"Answer the index of the current selection. Similar to #selection: but with the full list instead of the (maybe) filtered list."
getIndexSelector ifNil: [^ 0].
(model perform: getIndexSelector) in: [:row |
row ifNil: [^ 0].
row ifEmpty: [^ 0].
1 to: self fullListSize do: [:rowIndex |
| match |
match := true.
+ self getFullList withIndexDo: [:column :columnIndex |
- self getFullList doWithIndex: [:column :columnIndex |
match := match and: [(column at: rowIndex) = (row at: columnIndex)]].
match ifTrue: [^ rowIndex]]].
^ 0!
Item was added:
+ ----- Method: PluggableSystemWindowWithLabelButton>>replaceBoxes (in category 'initialization') -----
+ replaceBoxes
+
+ super replaceBoxes.
+ labelButton comeToFront.!
Item was changed:
ScrollPane subclass: #PluggableTextMorph
+ instanceVariableNames: 'textMorph getTextSelector setTextSelector getSelectionSelector hasUnacceptedEdits hasUserEdited askBeforeDiscardingEdits selectionInterval hasEditingConflicts editTextSelector wantsWrapBorder getFontSelector getTextStyleSelector'
+ classVariableNames: 'AdornmentCache SimpleFrameAdornments SoftLineWrap SoftLineWrapAtVisualWrapBorder VisualWrapBorder VisualWrapBorderLimit'
- instanceVariableNames: 'textMorph getTextSelector setTextSelector getSelectionSelector hasUnacceptedEdits hasUserEdited askBeforeDiscardingEdits selectionInterval hasEditingConflicts editTextSelector wantsWrapBorder'
- classVariableNames: 'AdornmentCache SimpleFrameAdornments SoftLineWrap VisualWrapBorder VisualWrapBorderLimit'
poolDictionaries: ''
category: 'Morphic-Pluggable Widgets'!
Item was changed:
----- Method: PluggableTextMorph class>>adornmentWithColor: (in category 'frame adornments') -----
adornmentWithColor: aColor
"Create and return a frame adornment with the given color"
| size box form fillStyle |
^self adornmentCache at: aColor ifAbsentPut:[
+ size := (16 * RealEstateAgent scaleFactor) rounded.
- size := 16.
box := 0@0 extent: size asPoint.
form := Form extent: size@size depth: 32.
fillStyle := MenuMorph gradientMenu ifFalse: [SolidFillStyle color: aColor] ifTrue: [
(GradientFillStyle ramp: {
0.0->(aColor alpha: 0.01).
0.8->aColor.
1.0->aColor})
origin: box topRight - (size@0);
direction: (size @ size negated) // 4;
radial: false].
form getCanvas drawPolygon: {
box topRight.
box topRight + (0@size).
box topRight - (size@0)
} fillStyle: fillStyle.
form].
!
Item was added:
+ ----- Method: PluggableTextMorph class>>applyUserInterfaceTheme (in category 'preferences') -----
+ applyUserInterfaceTheme
+
+ self flushAdornmentCache.!
Item was changed:
----- Method: PluggableTextMorph class>>softLineWrap (in category 'preferences') -----
softLineWrap
+ <preference: 'Use soft line wrap at widget border'
+ categoryList: #(scrolling editing Accessibility)
+ description: 'Wrap text lines to avoid horizontal scrolling in text widgets. This is the default for all kinds of multi-line text fields in a scrollable container, not only for source code.'
- <preference: 'Use soft line wrap'
- categoryList: #(scrolling editing)
- description: 'Wrap text lines to avoid horizontal scrolling.'
type: #Boolean>
^ SoftLineWrap ifNil: [true]!
Item was changed:
----- Method: PluggableTextMorph class>>softLineWrap: (in category 'preferences') -----
+ softLineWrap: aBooleanOrNil
- softLineWrap: aBoolean
+ aBooleanOrNil == SoftLineWrap ifTrue: [^ self].
+ SoftLineWrap := aBooleanOrNil.
- aBoolean == SoftLineWrap ifTrue: [^ self].
- SoftLineWrap := aBoolean.
PluggableTextMorph allSubInstancesDo: [:m |
+ m text lineCount > 1 ifTrue: [m wrapFlag: self softLineWrap]].!
- m text lineCount > 1 ifTrue: [m wrapFlag: aBoolean]].!
Item was added:
+ ----- Method: PluggableTextMorph class>>softLineWrapAtVisualWrapBorder (in category 'preferences') -----
+ softLineWrapAtVisualWrapBorder
+ <preference: 'Use soft line wrap at wrap border (in code panes)'
+ categoryList: #(scrolling editing Accessibility)
+ description: 'Wrap text lines at the (maybe visual) wrap border in code panes. See #visualWrapBorderLimit and #visualWrapBorder.'
+ type: #Boolean>
+ ^ SoftLineWrapAtVisualWrapBorder ifNil: [false]!
Item was added:
+ ----- Method: PluggableTextMorph class>>softLineWrapAtVisualWrapBorder: (in category 'preferences') -----
+ softLineWrapAtVisualWrapBorder: aBooleanOrNil
+
+ aBooleanOrNil == SoftLineWrapAtVisualWrapBorder ifTrue: [^ self].
+ SoftLineWrapAtVisualWrapBorder := aBooleanOrNil.
+ self updateCodePanes.!
Item was added:
+ ----- Method: PluggableTextMorph class>>textMargins (in category 'defaults') -----
+ textMargins
+
+ | horizontal vertical |
+ MorphicProject useCompactTextFields
+ ifTrue: [
+ horizontal := (3 * RealEstateAgent scaleFactor) truncated.
+ vertical := 0]
+ ifFalse: [
+ horizontal := vertical := (UserInterfaceTheme current get: #keyboardFocusWidth for: Morph) ifNil: [2].
+ vertical := (vertical * RealEstateAgent scaleFactor) truncated.
+ horizontal >= 3
+ ifTrue: [horizontal := vertical * 2]
+ ifFalse: [horizontal := (3 * RealEstateAgent scaleFactor) truncated] ].
+ ^ horizontal @ vertical corner: horizontal@ vertical!
Item was added:
+ ----- Method: PluggableTextMorph class>>updateCodePanes (in category 'preferences') -----
+ updateCodePanes
+
+
+ self flag: #todo. "mt Only for code panes!!"
+
+ self softLineWrapAtVisualWrapBorder
+ ifTrue: [
+ PluggableTextMorph allSubInstancesDo: [:m |
+ (m styler class = (TextStyler for: #Smalltalk)) ifTrue: [
+ m
+ wantsWrapBorder: self visualWrapBorder;
+ numCharactersPerLine: self visualWrapBorderLimit]]]
+ ifFalse: [
+ PluggableTextMorph allSubInstancesDo: [:m |
+ (m styler class = (TextStyler for: #Smalltalk)) ifTrue: [
+ m
+ wantsWrapBorder: self visualWrapBorder;
+ numCharactersPerLine: nil;
+ changed "redraw #visualWrapBorderLimit"]]].!
Item was changed:
----- Method: PluggableTextMorph class>>visualWrapBorder (in category 'preferences') -----
visualWrapBorder
+ <preference: 'Show wrap border in code panes'
+ categoryList: #(editing visuals performance Accessibility)
- <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.'
type: #Boolean>
^ VisualWrapBorder ifNil: [false]!
Item was changed:
----- Method: PluggableTextMorph class>>visualWrapBorder: (in category 'preferences') -----
+ visualWrapBorder: aBooleanOrNil
- visualWrapBorder: aBoolean
+ aBooleanOrNil == VisualWrapBorder ifTrue: [^ self].
+ VisualWrapBorder := aBooleanOrNil.
+ self updateCodePanes.!
- VisualWrapBorder := aBoolean.!
Item was changed:
----- Method: PluggableTextMorph class>>visualWrapBorderLimit (in category 'preferences') -----
visualWrapBorderLimit
+ <preference: 'Wrap border limit (in code panes)'
+ categoryList: #(editing visuals performance Accessibility)
+ description: 'In all code panes, indicate an expected wrapping border after a certain amount of characters. It will be a perfect fit for monospaced fonts and average over lines for proportional fonts. This border can be purely visual or also introduce soft line breaks. See #visualWrapBorder and #softLineWrapAtVisualWrapBorder.'
+ type: #String "Support negative values and floats">
- <preference: 'Wrap border limit'
- categoryList: #(editing visuals performance)
- description: 'Amount of characters after the border should be drawn.'
- type: #Number>
^ VisualWrapBorderLimit ifNil: [80]!
Item was changed:
----- Method: PluggableTextMorph class>>visualWrapBorderLimit: (in category 'preferences') -----
+ visualWrapBorderLimit: aNumberOrNil
- visualWrapBorderLimit: aNumber
+ aNumberOrNil == VisualWrapBorderLimit ifTrue: [^ self].
+ VisualWrapBorderLimit := aNumberOrNil ifNotNil: [:num | num asNumber].
+ self updateCodePanes.!
- VisualWrapBorderLimit := aNumber asInteger.!
Item was changed:
----- Method: PluggableTextMorph>>accept (in category 'menu commands') -----
accept
"Inform the model of text to be accepted, and return true if OK."
| priorSelection priorScrollerOffset |
(self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not])
ifTrue: [^ self flash].
self hasEditingConflicts ifTrue: [
+ (self confirm: 'Caution!! This method may have been\changed elsewhere since you started\editing it here. Accept anyway?' translated withCRs) ifFalse: [^ self flash]].
- (self confirm: 'Caution!! This method may have been\changed elsewhere since you started\editing it here. Accept anyway?' withCRs translated) ifFalse: [^ self flash]].
priorSelection := self selectionInterval copy.
priorScrollerOffset := scroller offset copy.
self acceptTextInModel == true
ifFalse: [^ self "something went wrong"].
self setText: self getText.
self hasUnacceptedEdits: false.
(model dependents
detect: [:dep | (dep isKindOf: PluggableTextMorph) and: [dep getTextSelector == #annotation]]
ifNone: [nil])
ifNotNil: [:aPane | model changed: #annotation].
"Update the model's internal caches. Note that this is specific to CodeHolder and the stepping it uses for updating. We have to trigger this here manually to avoid that the next step message destroys our selection and scrolling offset."
(model respondsTo: #updateCodePaneIfNeeded)
ifTrue: [model updateCodePaneIfNeeded].
"Restore prior selection:"
scroller offset: priorScrollerOffset.
selectionInterval := priorSelection.
self selectFrom: priorSelection first to: priorSelection last.!
Item was changed:
----- Method: PluggableTextMorph>>appendEntry (in category 'transcript') -----
appendEntry
"Append the text in the model's writeStream to the editable text. "
+ textMorph text size > model characterLimit ifTrue:
- textMorph asText size > model characterLimit ifTrue:
["Knock off first half of text"
+ self selectInvisiblyFrom: 1 to: textMorph text size // 2.
- self selectInvisiblyFrom: 1 to: textMorph asText size // 2.
self replaceSelectionWith: Text new].
+ self selectInvisiblyFrom: textMorph text size + 1 to: textMorph text size.
- self selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size.
self replaceSelectionWith: model contents asText.
+ self selectInvisiblyFrom: textMorph text size + 1 to: textMorph text size!
- self selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size!
Item was added:
+ ----- Method: PluggableTextMorph>>cancelSafely (in category 'menu commands') -----
+ cancelSafely
+ "Cancel all edits by replacing the content with the original contents. Retain the undo history. The model can intervene via #okToRevertChanges, which is beneficial if all edits have already be communicated via #textEdited: so that the model can cancel its internal caches."
+
+ (model respondsTo: #okToRevertChanges:) ==> [model okToRevertChanges: editTextSelector]
+ ifFalse: [^ self].
+
+ self handleEdit: [
+ textMorph editor replaceAllWith: self getText.
+ self selectInterval: self getSelection.
+ self hasUnacceptedEdits: false.
+ self hasUserEdited: false].!
Item was changed:
+ ----- Method: PluggableTextMorph>>copyHtml (in category 'menu commands') -----
- ----- Method: PluggableTextMorph>>copyHtml (in category 'html') -----
copyHtml
+
+ self handleEdit: [textMorph editor copyHtml].!
- "put the html representation of the receiver's text into the clipboard"
- Clipboard clipboardText: self text printHtmlString!
Item was added:
+ ----- Method: PluggableTextMorph>>copyHtmlSelection (in category 'menu commands') -----
+ copyHtmlSelection
+
+ self handleEdit: [textMorph editor copyHtmlSelection].!
Item was removed:
- ----- Method: PluggableTextMorph>>deselect (in category 'interactive error protocol') -----
- deselect
- ^ textMorph editor deselect!
Item was added:
+ ----- Method: PluggableTextMorph>>displayScaleChangedBy: (in category 'display scale') -----
+ displayScaleChangedBy: factor
+
+ | currentMargins |
+ super displayScaleChangedBy: factor.
+ (currentMargins := self textMorph margins) isRectangle
+ ifTrue: [self textMorph margins: ((currentMargins origin * factor) rounded corner: (currentMargins corner * factor) rounded)]
+ ifFalse: [self textMorph margins: (currentMargins * factor) rounded].!
Item was changed:
----- Method: PluggableTextMorph>>doIt (in category 'menu commands') -----
doIt
+ ^ self handleEdit: [textMorph editor doIt]!
- ^self handleEdit: [textMorph editor evaluateSelection]!
Item was changed:
----- Method: PluggableTextMorph>>drawWrapBorderOn: (in category 'drawing') -----
drawWrapBorderOn: aCanvas
+ | box offset rect |
- | offset rect |
self wantsWrapBorder ifFalse: [^ self].
textMorph ifNil: [^ self].
+ box := textMorph innerBounds.
+ textMorph margins ifNotNil: [:m | box := box insetBy: m].
- offset := textMorph margins isRectangle
- ifTrue: [textMorph margins left]
- ifFalse: [textMorph margins isPoint
- ifTrue: [textMorph margins x]
- ifFalse: [textMorph margins]].
- offset := offset + ((textMorph textStyle defaultFont widthOf: $x) * self class visualWrapBorderLimit).
- offset > self width ifTrue: [^ self].
+ offset := box left + (textMorph textStyle compositionWidthFor: self class
+ visualWrapBorderLimit).
+ self numCharactersPerLine ifNotNil: [
+ "Respect right margins only if we wrap at that border to not draw over glyphs."
+ offset := offset + (textMorph innerBounds right - box right) + self borderWidth].
+ offset > scroller width ifTrue: [^ self].
+
rect := scroller topLeft + (offset @ 0) corner: scroller bottomRight.
aCanvas
fillRectangle: rect
color: self wrapBorderColor.
aCanvas
line: rect topLeft
to: rect bottomLeft
+ width: self borderWidth
- width: self borderStyle width
color: (self wrapBorderColor muchDarker alpha: 0.5).!
Item was changed:
----- Method: PluggableTextMorph>>exploreIt (in category 'menu commands') -----
exploreIt
+ ^ self handleEdit: [textMorph editor exploreIt]!
-
-
- self handleEdit:
- [textMorph editor evaluateSelectionAndDo: [:result | result explore]].!
Item was changed:
+ ----- Method: PluggableTextMorph>>font: (in category 'model access') -----
- ----- Method: PluggableTextMorph>>font: (in category 'initialization') -----
font: aFont
+
+ self flag: #deprecated.
+ self setFont: aFont.!
- textMorph beAllFont: aFont!
Item was added:
+ ----- Method: PluggableTextMorph>>getFont (in category 'model access') -----
+ getFont
+ "Retrieve the current model text font"
+
+ | newFont |
+ getFontSelector ifNil: [^ TextStyle defaultFont].
+ newFont := model perform: getFontSelector.
+ newFont ifNil: [^ TextStyle defaultFont].
+ ^ newFont!
Item was added:
+ ----- Method: PluggableTextMorph>>getFontSelector (in category 'accessing') -----
+ getFontSelector
+
+ ^ getFontSelector!
Item was added:
+ ----- Method: PluggableTextMorph>>getFontSelector: (in category 'accessing') -----
+ getFontSelector: aSelector
+
+ getFontSelector := aSelector.!
Item was changed:
----- Method: PluggableTextMorph>>getSelection (in category 'model access') -----
getSelection
+ "Answer the model's selection interval. Default to the null selection if path to model unknown or model not initialized correctly."
- "Answer the model's selection interval."
+ ^ getSelectionSelector
+ ifNil: [1 to: 0]
+ ifNotNil: [(model perform: getSelectionSelector) ifNil: [1 to: 0]]!
- getSelectionSelector ifNil: [^1 to: 0]. "null selection"
- ^model perform: getSelectionSelector!
Item was added:
+ ----- Method: PluggableTextMorph>>getTextStyle (in category 'model access') -----
+ getTextStyle
+ "Retrieve the current model text style"
+
+ | newStyle |
+ getTextStyleSelector ifNil: [^ TextStyle default].
+ newStyle := model perform: getTextStyleSelector.
+ newStyle ifNil: [^ TextStyle default].
+ ^ newStyle!
Item was added:
+ ----- Method: PluggableTextMorph>>getTextStyleSelector (in category 'accessing') -----
+ getTextStyleSelector
+
+ ^ getTextStyleSelector!
Item was added:
+ ----- Method: PluggableTextMorph>>getTextStyleSelector: (in category 'accessing') -----
+ getTextStyleSelector: aSelector
+
+ getTextStyleSelector := aSelector.!
Item was changed:
----- Method: PluggableTextMorph>>initializeTextMorph (in category 'initialization') -----
initializeTextMorph
textMorph := self textMorphClass new
+ margins: self class textMargins;
- margins: (3@0 corner: 0@0);
setEditView: self;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
setProperty: #indicateKeyboardFocus toValue: #never;
+ yourself.
+
+ LegacyShortcutsFilter legacyShortcutsEnabled
+ ifTrue: [textMorph addKeyboardCaptureFilter: LegacyShortcutsFilter].!
- yourself.!
Item was changed:
----- Method: PluggableTextMorph>>inspectIt (in category 'menu commands') -----
inspectIt
+ ^ self handleEdit: [textMorph editor inspectIt]!
-
- self handleEdit:
- [textMorph editor evaluateSelectionAndDo: [:result | result inspect]]!
Item was added:
+ ----- Method: PluggableTextMorph>>makeProjectLink (in category 'menu commands') -----
+ makeProjectLink
+ self handleEdit: [textMorph editor makeProjectLink]!
Item was changed:
----- Method: PluggableTextMorph>>mouseEnter: (in category 'event handling') -----
mouseEnter: event
"Restore the selection in the text morph if there was a selection."
super mouseEnter: event.
selectionInterval ifNotNil: [:interval |
textMorph editor
selectInterval: selectionInterval;
setEmphasisHere].
Preferences mouseOverForKeyboardFocus
+ ifTrue: [event hand newKeyboardFocus: self].!
- ifTrue:[event hand newKeyboardFocus: self]!
Item was changed:
----- Method: PluggableTextMorph>>mouseLeave: (in category 'event handling') -----
mouseLeave: event
"Save the selection interval for later."
+ self rememberSelectionInterval.
- selectionInterval := textMorph editor selectionInterval.
super mouseLeave: event.
Preferences mouseOverForKeyboardFocus
ifTrue: [event hand releaseKeyboardFocus: self]!
Item was added:
+ ----- Method: PluggableTextMorph>>numCharactersPerLine (in category 'accessing') -----
+ numCharactersPerLine
+
+ ^ textMorph numCharactersPerLine!
Item was added:
+ ----- Method: PluggableTextMorph>>numCharactersPerLine: (in category 'accessing') -----
+ numCharactersPerLine: numCharsOrNil
+
+ textMorph numCharactersPerLine: numCharsOrNil.!
Item was added:
+ ----- Method: PluggableTextMorph>>plainTextOnly (in category 'accessing') -----
+ plainTextOnly
+
+ ^ textMorph plainTextOnly!
Item was added:
+ ----- Method: PluggableTextMorph>>plainTextOnly: (in category 'accessing') -----
+ plainTextOnly: aBoolean
+
+ textMorph plainTextOnly: aBoolean.!
Item was changed:
----- Method: PluggableTextMorph>>printIt (in category 'menu commands') -----
printIt
+ ^ self handleEdit: [textMorph editor printIt]!
- | oldEditor |
- textMorph editor selectFrom: selectionInterval first to: selectionInterval last;
- model: model. "For, eg, evaluateSelection"
- textMorph handleEdit: [(oldEditor := textMorph editor) evaluateSelectionAndDo:
- [:result |
- selectionInterval := oldEditor selectionInterval.
- textMorph installEditorToReplace: oldEditor.
- textMorph handleEdit: [oldEditor afterSelectionInsertAndSelect: result printString].
- selectionInterval := oldEditor selectionInterval.
-
- textMorph editor selectFrom: selectionInterval first to: selectionInterval last.
- self scrollSelectionIntoView]]!
Item was added:
+ ----- Method: PluggableTextMorph>>rememberSelectionInterval (in category 'private') -----
+ rememberSelectionInterval
+
+ self flag: #fixIntervalCache. "mt: We should find a better design for discarding unused text editors in text morphs and restoring them on demand."
+ selectionInterval := textMorph editor markIndex to: textMorph editor pointIndex - 1.!
Item was added:
+ ----- Method: PluggableTextMorph>>restoreSelectionInterval (in category 'editor access') -----
+ restoreSelectionInterval
+
+ selectionInterval ifNotNil: [
+ self selectionInterval: selectionInterval].!
Item was removed:
- ----- Method: PluggableTextMorph>>saveContentsInFile (in category 'menu commands') -----
- saveContentsInFile
- self handleEdit: [textMorph editor saveContentsInFile]!
Item was changed:
----- Method: PluggableTextMorph>>scrollSelectionIntoView: (in category 'editor access') -----
scrollSelectionIntoView: event
"Scroll my text into view. Due to line composition mechanism, we must never use the right of a character block because the lines last character block right value always comes from a global container and is *not* line specific."
+
+ self rememberSelectionInterval.
- selectionInterval := textMorph editor selectionInterval.
-
textMorph editor hasSelection
ifFalse: [self scrollToShow: (textMorph editor startBlock withWidth: 1)]
ifTrue: [
self scrollToShow: (textMorph editor startBlock topLeft corner: textMorph editor stopBlock bottomLeft).
self scrollToShow: (textMorph editor pointBlock withWidth: 1). "Ensure text cursor visibility."].
^ true!
Item was removed:
- ----- Method: PluggableTextMorph>>select (in category 'interactive error protocol') -----
- select
- ^ textMorph editor select!
Item was changed:
----- Method: PluggableTextMorph>>selectAll (in category 'editor access') -----
selectAll
- "Tell my textMorph to select all"
+ textMorph selectAll.
+ self rememberSelectionInterval.!
- textMorph selectAll.!
Item was changed:
----- Method: PluggableTextMorph>>selectFrom:to: (in category 'interactive error protocol') -----
selectFrom: start to: stop
+
+ textMorph selectFrom: start to: stop.
+ self rememberSelectionInterval.!
- ^ textMorph editor selectFrom: start to: stop!
Item was added:
+ ----- Method: PluggableTextMorph>>selectInterval: (in category 'editor access') -----
+ selectInterval: anInterval
+
+ textMorph selectInterval: anInterval.
+ self rememberSelectionInterval.!
Item was added:
+ ----- Method: PluggableTextMorph>>selectIntervalInvisibly: (in category 'interactive error protocol') -----
+ selectIntervalInvisibly: aSelectionInterval
+ ^ textMorph editor selectIntervalInvisibly: aSelectionInterval!
Item was changed:
+ ----- Method: PluggableTextMorph>>selectionInterval (in category 'editor access') -----
- ----- Method: PluggableTextMorph>>selectionInterval (in category 'interactive error protocol') -----
selectionInterval
+
+ ^ textMorph selectionInterval!
- ^ textMorph editor selectionInterval!
Item was changed:
+ ----- Method: PluggableTextMorph>>selectionInterval: (in category 'editor access') -----
+ selectionInterval: anInterval
+
+ textMorph selectionInterval: anInterval.
+ self rememberSelectionInterval.!
- ----- Method: PluggableTextMorph>>selectionInterval: (in category 'model access') -----
- selectionInterval: sel
- selectionInterval := sel!
Item was changed:
----- Method: PluggableTextMorph>>setDefaultParameters (in category 'initialization') -----
setDefaultParameters
super setDefaultParameters.
+ self textMorph textStyle defaultFont hasFixedWidth "mt: Law of Demeter ... Can we rely on text styles to only bundle similar fonts?"
+ ifFalse: [self setTextStyle: (self userInterfaceTheme textStyle ifNil: [TextStyle default]) copy]
+ ifTrue: [self setTextStyle: (self userInterfaceTheme textStyleFixed ifNil: [TextStyle defaultFixed]) copy].
- self
- font: (self userInterfaceTheme font ifNil: [TextStyle defaultFont]);
- setTextColor: (self userInterfaceTheme textColor ifNil: [Color black]).
+ self setTextColor: (self userInterfaceTheme textColor ifNil: [Color black]).
self wrapBorderColor: ((self userInterfaceTheme wrapBorderColorModifier ifNil: [ [:c | c muchLighter alpha: 0.3] ])
value: self borderColor).
self
setProperty: #adornmentReadOnly
toValue: (self userInterfaceTheme adornmentReadOnly ifNil: [Color black]);
setProperty: #adornmentRefuse
toValue: (self userInterfaceTheme adornmentRefuse ifNil: [Color tan]);
setProperty: #adornmentConflict
toValue: (self userInterfaceTheme adornmentConflict ifNil: [Color red]);
setProperty: #adornmentDiff
toValue: (self userInterfaceTheme adornmentDiff ifNil: [Color green]);
setProperty: #adornmentNormalEdit
toValue: (self userInterfaceTheme adornmentNormalEdit ifNil: [Color orange]);
setProperty: #adornmentDiffEdit
toValue: (self userInterfaceTheme adornmentDiffEdit ifNil: [Color yellow]).
self
setProperty: #frameAdornmentWidth
toValue: (self userInterfaceTheme frameAdornmentWidth ifNil: [1]).
textMorph
caretColor: (self userInterfaceTheme caretColor ifNil: [Color red]);
selectionColor: (self userInterfaceTheme selectionColor ifNil: [TranslucentColor r: 0.0 g: 0.0 b: 0.8 alpha: 0.2]);
unfocusedSelectionColor: ((self userInterfaceTheme unfocusedSelectionModifier ifNil: [ [:c | Color gray: 0.9] ])
value: textMorph selectionColor).!
Item was added:
+ ----- Method: PluggableTextMorph>>setFont: (in category 'model access') -----
+ setFont: aFont
+ textMorph font: aFont.!
Item was changed:
----- Method: PluggableTextMorph>>setText: (in category 'model access') -----
setText: aText
textMorph newContents: aText.
self hasUnacceptedEdits: false.
self setScrollDeltas.
+
+ self flag: #performance. "mt: Needed only to redraw overlays such as the help text."
+ self changed.!
- self changed. "Redraw the whole area. For example, it might not be necssary to draw the help text anymore."!
Item was changed:
----- Method: PluggableTextMorph>>setTextColor: (in category 'model access') -----
setTextColor: aColor
"Set the color of my text to the given color"
+ self flag: #todo. "See commentary in #font:. Maybe we cant to remove all current TextColor attributes here, too?"
textMorph textColor: aColor!
Item was added:
+ ----- Method: PluggableTextMorph>>setTextStyle: (in category 'model access') -----
+ setTextStyle: aTextStyle
+ "Always copy the argument to avoid messing up TextStyle >> #default."
+
+ textMorph textStyle: aTextStyle copy.!
Item was changed:
----- Method: PluggableTextMorph>>textEdited: (in category 'editor access') -----
textEdited: someText
"Tell the model about some edits in the text if interested. This is not #accept, which means that it will be send on every keystroke."
self editTextSelector ifNotNil: [:selector |
+ model perform: selector with: someText].
+
+ self flag: #performance. "mt: Needed only to redraw overlays such as the help text."
+ self changed.!
- model perform: selector with: someText].!
Item was changed:
----- Method: PluggableTextMorph>>update: (in category 'updating') -----
update: aSymbol
aSymbol ifNil: [^self].
aSymbol == #flash ifTrue: [^self flash].
aSymbol == getTextSelector
ifTrue: [
self setText: self getText.
getSelectionSelector
ifNotNil: [self setSelection: self getSelection].
^ self].
aSymbol == getSelectionSelector
ifTrue: [^self setSelection: self getSelection].
+
+ aSymbol == getTextStyleSelector
+ ifTrue: [^ self setTextStyle: self getTextStyle].
+ aSymbol == getFontSelector
+ ifTrue: [^ self setFont: self getFont].
aSymbol == #acceptChanges ifTrue: [^ self accept].
+ aSymbol == #revertChanges ifTrue: [^ self cancelSafely].
- aSymbol == #revertChanges ifTrue: [^ self cancel].
(aSymbol == #autoSelect and: [getSelectionSelector notNil])
ifTrue:
[self handleEdit:
[(textMorph editor)
abandonChangeText; "no replacement!!"
setSearch: model autoSelectString;
findAgainNow "do not reset search string"]].
aSymbol == #clearUserEdits ifTrue: [^self hasUnacceptedEdits: false].
aSymbol == #wantToChange
ifTrue:
[self canDiscardEdits ifFalse: [^self promptForCancel].
^self].
aSymbol == #appendEntry
ifTrue:
[self handleEdit: [self appendEntry].
^self refreshWorld].
aSymbol == #appendEntryLater
ifTrue: [self handleEdit: [self appendEntry]].
aSymbol == #clearText
ifTrue:
[self handleEdit: [self changeText: Text new].
^self refreshWorld].
aSymbol == #bs
ifTrue:
[self handleEdit: [self bsText].
^self refreshWorld].
aSymbol == #codeChangedElsewhere
ifTrue:
[self hasEditingConflicts: true.
^self changed].
aSymbol == #saveContents
ifTrue:
+ [^(self respondsTo: #saveContentsInFile) ifTrue: [self saveContentsInFile]].
- [^self saveContentsInFile].
aSymbol == #showContents
ifTrue:
[^ self scrollToTop].
!
Item was changed:
----- Method: PluggableTextMorph>>update:with: (in category 'updating') -----
update: aSymbol with: arg1
+ aSymbol == #editString
+ ifTrue: [
+ self editString: arg1.
+ self hasUnacceptedEdits: true.
+ ^ self].
- aSymbol == #editString ifTrue:[
- self editString: arg1.
- self hasUnacceptedEdits: true.
- ].
(aSymbol == #inputRequested and: [self getTextSelector == arg1 or: [self setTextSelector == arg1]])
+ ifTrue: [
+ self activeHand newKeyboardFocus: self.
+ ^ self].
- ifTrue: [self activeHand newKeyboardFocus: self].
+ aSymbol == #textStyle
+ ifTrue: [
+ self setTextStyle: arg1.
+ ^ self].
+
+ aSymbol == #font
+ ifTrue: [
+ self setFont: arg1.
+ ^ self].
+
+
^super update: aSymbol with: arg1!
Item was changed:
----- Method: PluggableTextMorph>>wantsWrapBorder: (in category 'accessing') -----
wantsWrapBorder: aBoolean
+ wantsWrapBorder = aBoolean ifTrue: [^ self].
+ wantsWrapBorder := aBoolean.
+ self changed.!
- wantsWrapBorder := aBoolean.!
Item was changed:
+ ----- Method: PluggableTextMorphWithModel>>delete (in category 'submorphs - add/remove') -----
- ----- Method: PluggableTextMorphWithModel>>delete (in category 'submorphs-add/remove') -----
delete
"Delete the receiver. Since I have myself as a dependent, I need to remove it. which is odd in itself. Also, the release of dependents will seemingly not be done if the *container* of the receiver is deleted rather than the receiver itself, a further problem"
self removeDependent: self.
super delete!
Item was changed:
----- Method: PolygonMorph>>addHandles (in category 'editing') -----
addHandles
"Put moving handles at the vertices. Put adding handles at
edge midpoints.
Moving over adjacent vertex and dropping will delete a
vertex. "
| tri |
self removeHandles.
handles := OrderedCollection new.
tri := Array
with: 0 @ -4
with: 4 @ 3
with: -3 @ 3.
+ tri := (tri * RealEstateAgent scaleFactor) truncated.
vertices
withIndexDo: [:vertPt :vertIndex |
| handle |
handle := EllipseMorph
+ newBounds: (Rectangle center: vertPt extent: (8@8) * RealEstateAgent scaleFactor)
- newBounds: (Rectangle center: vertPt extent: 8 @ 8)
color: (self handleColorAt: vertIndex) .
+ handle disableLayout: true.
handle
on: #mouseMove
send: #dragVertex:event:fromHandle:
to: self
withValue: vertIndex.
handle
on: #mouseUp
send: #dropVertex:event:fromHandle:
to: self
withValue: vertIndex.
handle
on: #click
send: #clickVertex:event:fromHandle:
to: self
withValue: vertIndex.
self addMorph: handle.
handles addLast: handle.
(closed
or: [1 = vertices size
"Give a small polygon a chance to grow.
-wiz"
or: [vertIndex < vertices size]])
ifTrue: [| newVert |
newVert := PolygonMorph
vertices: (tri
collect: [:p | p + (vertPt
+ (vertices atWrap: vertIndex + 1) // 2)])
color: Color green
borderWidth: 1
borderColor: Color black.
+ newVert disableLayout: true.
newVert
on: #mouseDown
send: #newVertex:event:fromHandle:
to: self
withValue: vertIndex.
self addMorph: newVert.
handles addLast: newVert]].
self isCurvy
ifTrue: [self updateHandles; layoutChanged].
self changed!
Item was removed:
- ----- Method: PolygonMorph>>boundsSignatureHash (in category 'attachments') -----
- boundsSignatureHash
- ^(vertices - (self positionInWorld)) hash
- !
Item was changed:
----- Method: PolygonMorph>>dragVertex:event:fromHandle: (in category 'editing') -----
dragVertex: ix event: evt fromHandle: handle
| p |
+ p := evt cursorPoint.
+ self flag: #workaround. "mt: Explicitely check for grid layout in owner to then let the vertex snap to that grid."
+ (self owner notNil and: [self owner layoutPolicy notNil and: [self owner layoutPolicy isGridLayout]])
+ ifTrue: [p := self owner layoutPolicy griddedPoint: p in: self owner].
- p := self isCurve
- ifTrue: [evt cursorPoint]
- ifFalse: [self griddedPoint: evt cursorPoint].
handle position: p - (handle extent//2).
self verticesAt: ix put: p.
!
Item was changed:
----- Method: PolygonMorph>>extent: (in category 'geometry') -----
extent: newExtent
"Not really advisable, but we can preserve most of the geometry if we don't
shrink things too small."
+ | safeExtent |
+ (self extent closeTo: newExtent) ifTrue: [^ self].
+ safeExtent := newExtent max: self minimumExtent.
- | safeExtent center |
- center := self referencePosition.
- safeExtent := newExtent max: 20@20.
self setVertices: (vertices collect:
+ [:p | p - self position * (safeExtent asFloatPoint / (bounds extent max: 1@1)) + self position])!
- [:p | p - center * (safeExtent asFloatPoint / (bounds extent max: 1@1)) + center])!
Item was added:
+ ----- Method: PolygonMorph>>heading (in category 'rotate scale and flex') -----
+ heading
+ "Overwritten to store the angle in #forwardDirection."
+
+ ^ self rotationDegrees!
Item was added:
+ ----- Method: PolygonMorph>>heading: (in category 'rotate scale and flex') -----
+ heading: newHeading
+ "Overwritten to store the angle in #forwardDirection."
+
+ self rotationDegrees: newHeading.!
Item was changed:
----- Method: PolygonMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ self minimumExtent: 20@20.
vertices := Array
with: 5 @ 0
with: 20 @ 10
with: 0 @ 20.
closed := true.
smoothCurve := false.
arrows := #none.
self computeBounds!
Item was removed:
- ----- Method: PolygonMorph>>justDroppedInto:event: (in category 'dropping/grabbing') -----
- justDroppedInto: newOwner event: evt
-
- | delta |
- (newOwner isKindOf: PasteUpMorph) ifTrue:
- ["Compensate for border width so that gridded drop
- is consistent with gridded drag of handles."
- delta := self borderWidth+1//2.
- self position: (newOwner gridPoint: self position + delta) - delta].
- ^ super justDroppedInto: newOwner event: evt!
Item was changed:
----- Method: PolygonMorph>>nextDuplicateVertexIndex (in category 'geometry') -----
nextDuplicateVertexIndex
vertices
+ withIndexDo: [:vert :index | ((index between: 2 and: vertices size - 1)
- doWithIndex: [:vert :index | ((index between: 2 and: vertices size - 1)
and: [| epsilon v1 v2 |
v1 := vertices at: index - 1.
v2 := vertices at: index + 1.
epsilon := ((v1 x - v2 x) abs max: (v1 y - v2 y) abs)
// 32 max: 1.
vert
onLineFrom: v1
to: v2
within: epsilon])
ifTrue: [^ index]].
^ 0!
Item was changed:
+ ----- Method: PolygonMorph>>rotationDegrees: (in category 'rotate scale and flex') -----
- ----- Method: PolygonMorph>>rotationDegrees: (in category 'halo control') -----
rotationDegrees: degrees
| flex center |
(center := self valueOfProperty: #referencePosition) ifNil:
[self setProperty: #referencePosition toValue: (center := self bounds center)].
flex := (MorphicTransform offset: center negated)
withAngle: (degrees - self forwardDirection) degreesToRadians.
self setVertices: (vertices collect: [:v | (flex transform: v) - flex offset]).
self forwardDirection: degrees.
!
Item was changed:
----- Method: PolygonMorph>>smoothOrSegmentedPhrase (in category 'access') -----
smoothOrSegmentedPhrase
- | lineName |
- lineName := (closed
- ifTrue: ['outline']
- ifFalse: ['line']) translated.
+ | lineName |
+ lineName := closed
+ ifTrue: ['outline' translated]
+ ifFalse: ['line' translated].
+
+ ^ self isCurve
+ ifTrue: ['make segmented {1}' translated format: {lineName}]
+ ifFalse: ['make smooth {1}' translated format: {lineName}]!
- ^ self isCurve
- ifTrue: ['make segmented {1}' translated format: {lineName}]
- ifFalse: ['make smooth {1}' translated format: {lineName}].!
Item was changed:
----- Method: PopUpMenu>>morphicStartUpWithCaption:icon:at:allowKeyboard: (in category '*Morphic-Menus') -----
morphicStartUpWithCaption: captionOrNil icon: aForm at: location allowKeyboard: aBoolean
"Display the menu, with caption if supplied. Wait for the mouse button to go down, then track the selection as long as the button is pressed. When the button is released,
Answer the index of the current selection, or zero if the mouse is not released over any menu item. Location specifies the desired topLeft of the menu body rectangle. The final argument indicates whether the menu should seize the keyboard focus in order to allow the user to navigate it via the keyboard."
selection := Cursor normal
showWhile: [| menuMorph |
menuMorph := MVCMenuMorph from: self title: nil.
(captionOrNil notNil
or: [aForm notNil])
ifTrue: [menuMorph addTitle: captionOrNil icon: aForm].
MenuIcons decorateMenu: menuMorph.
menuMorph
invokeAt: location
+ in: self currentWorld
- in: ActiveWorld
allowKeyboard: aBoolean].
^ selection!
Item was changed:
----- Method: ProjectViewMorph class>>newProjectViewInAWindowFor: (in category 'project window creation') -----
newProjectViewInAWindowFor: aProject
"Return an instance of me on a new Morphic project (in a SystemWindow)."
| window proj |
proj := self on: aProject.
window := (SystemWindow labelled: aProject name) model: aProject.
+ window extent: proj extent.
window
addMorph: proj
frame: (0@0 corner: 1.0(a)1.0).
proj borderWidth: 0.
^ window
!
Item was changed:
----- Method: ProjectViewMorph class>>openOn: (in category 'instance creation') -----
openOn: aProject
"Open a ProjectViewMorph for the project in question"
+ ProjectViewOpenNotification signal ifFalse: [^ self].
+
+ (Preferences projectViewsInWindows
+ ifTrue: [ (self newProjectViewInAWindowFor: aProject) ]
+ ifFalse: [ (self on: aProject) ])
+ openAsTool.!
- ProjectViewOpenNotification signal ifTrue: [
- Preferences projectViewsInWindows ifTrue: [
- (self newProjectViewInAWindowFor: aProject) openInWorld
- ] ifFalse: [
- (self on: aProject) openInWorld "but where??"
- ].
- ].
- !
Item was changed:
+ ----- Method: ProjectViewMorph>>abandon (in category 'submorphs - add/remove') -----
- ----- Method: ProjectViewMorph>>abandon (in category 'submorphs-add/remove') -----
abandon
"Home ViewMorph of project is going away."
project := nil.
super abandon.
!
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]].
+ (owner isSystemWindow) ifTrue: [project viewSize: self extent].
- (owner isSystemWindow) ifTrue: [project setViewSize: self extent].
self showMouseState: 3.
project
enter: false
revert: false
saveForRevert: false!
Item was changed:
----- Method: ProjectViewMorph>>enterAsActiveSubproject (in category 'events') -----
enterAsActiveSubproject
"Enter my project."
project class == DiskProxy
ifTrue:
["When target is not in yet"
[self enterWhenNotPresent "will bring it in"] on: ProjectEntryNotification
do: [:ex | ^ex projectToEnter enterAsActiveSubprojectWithin: self world].
project class == DiskProxy ifTrue: [self error: 'Could not find view']].
+ (owner isSystemWindow) ifTrue: [project viewSize: self extent].
- (owner isSystemWindow) ifTrue: [project setViewSize: self extent].
self showMouseState: 3.
project enterAsActiveSubprojectWithin: self world!
Item was added:
+ ----- Method: ProjectViewMorph>>initialExtent (in category 'geometry') -----
+ initialExtent
+
+ ^ 300 @ 200!
Item was changed:
----- Method: ProjectViewMorph>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver."
super initialize.
+ self extent: self initialExtent * RealEstateAgent scaleFactor.
"currentBorderColor := Color gray."
self addProjectNameMorphFiller.
self enableDragNDrop: true.
self isOpaque: true.
!
Item was changed:
----- Method: ProjectViewMorph>>on: (in category 'events') -----
on: aProject
project := aProject.
self addProjectNameMorphFiller.
lastProjectThumbnail := nil.
+ project viewSize ifNil: [project viewSize: self extent].
project thumbnail: project previewImageForm.
+ self extent: project thumbnail extent.!
- project thumbnail
- ifNil: [self extent: 100@80] "more like screen dimensions?"
- ifNotNil: [self extent: project thumbnail extent].!
Item was changed:
----- Method: ProportionalSplitterMorph class>>smartHorizontalSplitters: (in category 'preferences') -----
+ smartHorizontalSplitters: aBooleanOrNil
+ SmartHorizontalSplitters := aBooleanOrNil.
+ self preferenceChanged: self smartHorizontalSplitters.!
- smartHorizontalSplitters: aBoolean
- SmartHorizontalSplitters := aBoolean.
- self preferenceChanged: aBoolean!
Item was changed:
----- Method: ProportionalSplitterMorph class>>smartVerticalSplitters: (in category 'preferences') -----
+ smartVerticalSplitters: aBooleanOrNil
+ SmartVerticalSplitters := aBooleanOrNil.
+ self preferenceChanged: self smartHorizontalSplitters.!
- smartVerticalSplitters: aBoolean
- SmartVerticalSplitters := aBoolean.
- self preferenceChanged: aBoolean!
Item was changed:
----- Method: ProportionalSplitterMorph>>balanceOffsets (in category 'events') -----
balanceOffsets
| fdx fdy |
(self hasProperty: #fullDelta) ifFalse: [^ self].
fdx := (self valueOfProperty: #fullDelta) x.
fdy := (self valueOfProperty: #fullDelta) y.
self layoutFrame hasFixedHeight ifTrue: [
| otop obot ctop cbot topf |
otop := (owner submorphs detect: [:m |
m layoutFrame topFraction isZero] ifNone: [^ self]) in: [:tm |
+ tm top - (tm layoutFrame topOffset)].
- tm top - (tm layoutFrame topOffset ifNil: [0])].
obot := (owner submorphs detect: [:m |
m layoutFrame bottomFraction = 1] ifNone: [^ self]) in: [:tm |
+ tm bottom - (tm layoutFrame bottomOffset)].
- tm bottom - (tm layoutFrame bottomOffset ifNil: [0])].
ctop := (self layoutFrame topFraction * (obot - otop)) rounded
+ + otop + (self layoutFrame topOffset).
- + otop + (self layoutFrame topOffset ifNil: [0]).
cbot := (self layoutFrame bottomFraction * (obot - otop)) rounded
+ + otop + (self layoutFrame bottomOffset).
- + otop + (self layoutFrame bottomOffset ifNil: [0]).
topf := self layoutFrame topFraction.
self layoutFrame topFraction: ((ctop + cbot) * 0.5 - otop) / (obot - otop) asFloat.
self layoutFrame bottomFraction: self layoutFrame topFraction.
self layoutFrame topOffset: self layoutFrame topOffset - fdy.
self layoutFrame bottomOffset: self layoutFrame bottomOffset - fdy.
(leftOrTop copy union: rightOrBottom) do: [:m |
(m layoutFrame topFraction closeTo: topf) ifTrue: [
m layoutFrame topFraction: self layoutFrame topFraction.
m layoutFrame topOffset: m layoutFrame topOffset - fdy].
(m layoutFrame bottomFraction closeTo: topf) ifTrue: [
m layoutFrame bottomFraction: self layoutFrame topFraction.
m layoutFrame bottomOffset: m layoutFrame bottomOffset - fdy]]] .
self layoutFrame hasFixedWidth ifTrue: [
| oleft oright cleft cright leftf |
oleft := (owner submorphs detect: [:m |
m layoutFrame leftFraction isZero] ifNone: [^ self]) in: [:tm |
+ tm left - (tm layoutFrame leftOffset)].
- tm left - (tm layoutFrame leftOffset ifNil: [0])].
oright := (owner submorphs detect: [:m |
m layoutFrame rightFraction = 1] ifNone: [^ self]) in: [:tm |
+ tm right - (tm layoutFrame rightOffset)].
- tm right - (tm layoutFrame rightOffset ifNil: [0])].
cleft := (self layoutFrame leftFraction * (oright - oleft)) rounded
+ + oleft + (self layoutFrame leftOffset).
- + oleft + (self layoutFrame leftOffset ifNil: [0]).
cright := (self layoutFrame rightFraction * (oright - oleft)) rounded
+ + oleft + (self layoutFrame rightOffset).
- + oleft + (self layoutFrame rightOffset ifNil: [0]).
leftf := self layoutFrame leftFraction.
self layoutFrame leftFraction: ((cleft + cright) * 0.5 - oleft) / (oright - oleft) asFloat.
self layoutFrame rightFraction: self layoutFrame leftFraction.
self layoutFrame leftOffset: self layoutFrame leftOffset - fdx.
self layoutFrame rightOffset: self layoutFrame rightOffset - fdx.
(leftOrTop copy union: rightOrBottom) do: [:m |
(m layoutFrame leftFraction closeTo: leftf) ifTrue: [
m layoutFrame leftFraction: self layoutFrame leftFraction.
m layoutFrame leftOffset: m layoutFrame leftOffset - fdx].
(m layoutFrame rightFraction closeTo: leftf) ifTrue: [
m layoutFrame rightFraction: self layoutFrame leftFraction.
m layoutFrame rightOffset: m layoutFrame rightOffset - fdx.]]] .
self removeProperty: #fullDelta.
owner layoutChanged
!
Item was changed:
----- Method: ProportionalSplitterMorph>>mouseUp: (in category 'events') -----
mouseUp: anEvent
(self bounds containsPoint: anEvent cursorPoint) ifFalse: [ anEvent hand showTemporaryCursor: nil ].
self class fastSplitterResize ifTrue: [ self updateFromEvent: anEvent ].
traceMorph ifNotNil:
[ traceMorph delete.
traceMorph := nil ].
"balanceOffsets currently disrupts Smart Splitter behavior."
+ self isStepping ifTrue: [
+ (ProportionalSplitterMorph smartVerticalSplitters
+ or: [ ProportionalSplitterMorph smartHorizontalSplitters ])
+ ifFalse: [ self balanceOffsets ] ].!
- (ProportionalSplitterMorph smartVerticalSplitters or: [ ProportionalSplitterMorph smartHorizontalSplitters ]) ifFalse: [ self balanceOffsets ]!
Item was changed:
----- Method: ProportionalSplitterMorph>>repositionBy: (in category 'events') -----
repositionBy: delta
| selfTop selfBottom selfLeft selfRight |
self setProperty: #fullDelta toValue: ((self valueOfProperty: #fullDelta) ifNil: [0@0]) + delta.
leftOrTop do:
[ : each | | firstRight firstBottom firstLeft firstTop |
+ firstRight := each layoutFrame rightOffset.
+ firstBottom := each layoutFrame bottomOffset.
- firstRight := each layoutFrame rightOffset ifNil: [ 0 ].
- firstBottom := each layoutFrame bottomOffset ifNil: [ 0 ].
each layoutFrame rightOffset: firstRight + delta x.
each layoutFrame bottomOffset: firstBottom + delta y.
each layoutFrame hasFixedHeight ifTrue: [
+ firstTop := each layoutFrame topOffset.
- firstTop := each layoutFrame topOffset ifNil: [ 0 ].
each layoutFrame topOffset: firstTop + delta y ].
each layoutFrame hasFixedWidth ifTrue: [
+ firstLeft := each layoutFrame leftOffset.
- firstLeft := each layoutFrame leftOffset ifNil: [ 0 ].
each layoutFrame leftOffset: firstLeft + delta x. ] ].
rightOrBottom do:
[ : each | | secondLeft secondTop secondRight secondBottom |
+ secondLeft := each layoutFrame leftOffset.
+ secondTop := each layoutFrame topOffset.
- secondLeft := each layoutFrame leftOffset ifNil: [ 0 ].
- secondTop := each layoutFrame topOffset ifNil: [ 0 ].
each layoutFrame leftOffset: secondLeft + delta x.
each layoutFrame topOffset: secondTop + delta y.
each layoutFrame hasFixedHeight ifTrue: [
+ secondBottom := each layoutFrame bottomOffset.
- secondBottom := each layoutFrame bottomOffset ifNil: [ 0 ].
each layoutFrame bottomOffset: secondBottom + delta y. ].
each layoutFrame hasFixedWidth ifTrue: [
+ secondRight := each layoutFrame rightOffset.
- secondRight := each layoutFrame rightOffset ifNil: [ 0 ].
each layoutFrame rightOffset: secondRight + delta x. ] ].
+ selfTop := self layoutFrame topOffset.
+ selfBottom := self layoutFrame bottomOffset.
+ selfLeft := self layoutFrame leftOffset.
+ selfRight := self layoutFrame rightOffset.
- selfTop := self layoutFrame topOffset ifNil: [ 0 ].
- selfBottom := self layoutFrame bottomOffset ifNil: [ 0 ].
- selfLeft := self layoutFrame leftOffset ifNil: [ 0 ].
- selfRight := self layoutFrame rightOffset ifNil: [ 0 ].
self layoutFrame
topOffset: selfTop + delta y ;
bottomOffset: selfBottom + delta y ;
leftOffset: selfLeft + delta x ;
rightOffset: selfRight + delta x.
self owner layoutChanged.
self movements removeFirst; add: (splitsTopAndBottom ifTrue: [ delta y sign ] ifFalse: [ delta x sign ])!
Item was changed:
----- Method: ProportionalSplitterMorph>>stopStepping (in category 'smart splitters - stepping') -----
stopStepping
+
+ self isStepping ifFalse: [^ self].
super stopStepping.
(self class smartVerticalSplitters or: [ self class smartHorizontalSplitters ]) ifFalse: [ self balanceOffsets ]!
Item was changed:
----- Method: ProportionalSplitterMorph>>topBoundary (in category 'queries - geometry') -----
topBoundary
"Answer the topmost x position the receiver could be moved to."
| splitter morphs |
splitter := self splitterAbove.
morphs := self commonNeighbours: leftOrTop with: splitter.
-
^ (splitter
ifNil: [owner isSystemWindow ifTrue: [owner panelRect top]
ifFalse: [owner innerBounds top]]
ifNotNil: [splitter bottom])
+ (self minimumHeightOf: morphs)!
Item was changed:
----- Method: ProportionalSplitterMorph>>updateFromEvent: (in category 'events') -----
updateFromEvent: anEvent
| delta |
+ lastMouse ifNil: [ lastMouse := anEvent position - self position ].
- lastMouse ifNil: [ lastMouse := anEvent position ].
delta := splitsTopAndBottom
+ ifTrue: [ 0 @ ((self normalizedY: anEvent cursorPoint y) - (lastMouse y + self top)) ]
+ ifFalse: [ (self normalizedX: anEvent cursorPoint x) - (lastMouse x + self left) @ 0 ].
- ifTrue: [ 0 @ ((self normalizedY: anEvent cursorPoint y) - lastMouse y) ]
- ifFalse: [ (self normalizedX: anEvent cursorPoint x) - lastMouse x @ 0 ].
- lastMouse := splitsTopAndBottom
- ifTrue: [ lastMouse x @ (self normalizedY: anEvent cursorPoint y) ]
- ifFalse: [ (self normalizedX: anEvent cursorPoint x) @ lastMouse y ].
self repositionBy: delta!
Item was changed:
+ ----- Method: SVColorSelectorMorph>>extent: (in category 'geometry') -----
- ----- Method: SVColorSelectorMorph>>extent: (in category 'as yet unclassified') -----
extent: p
"Update the gradient directions."
super extent: p.
self updateGradients!
Item was changed:
----- Method: ScrollBar>>setDefaultParameters (in category 'initialize') -----
setDefaultParameters
"Compared to generic sliders, I am not my own paging area. Thus, make me transparent."
self
color: Color transparent;
borderWidth: 0.
pagingArea
color: (self userInterfaceTheme color ifNil: [Color veryVeryLightGray darker alpha: 0.35]);
borderWidth: 0. "no border for the paging area"
slider
color: (self userInterfaceTheme thumbColor ifNil: [Color veryVeryLightGray]);
borderColor: (self userInterfaceTheme thumbBorderColor ifNil: [Color gray: 0.6]);
+ borderWidth: ((self userInterfaceTheme thumbBorderWidth ifNil: [1]) * RealEstateAgent scaleFactor) truncated.
- borderWidth: (self userInterfaceTheme thumbBorderWidth ifNil: [1]).
self updateSliderCornerStyle.
sliderShadow
cornerStyle: slider cornerStyle;
borderWidth: slider borderWidth;
borderColor: Color transparent.
sliderColor := slider color.
self updateSliderColor: slider color.!
Item was changed:
MorphicModel subclass: #ScrollPane
instanceVariableNames: 'scrollBar scroller retractableScrollBar scrollBarOnLeft getMenuSelector getMenuTitleSelector hasFocus hScrollBar hScrollBarPolicy vScrollBarPolicy scrollBarThickness'
+ classVariableNames: 'HorizontalScrollDeltaPerMouseWheelNotch UseRetractableScrollBars VerticalScrollDeltaPerMouseWheelNotch'
- classVariableNames: 'UseRetractableScrollBars'
poolDictionaries: ''
category: 'Morphic-Windows'!
!ScrollPane commentStamp: 'mk 8/9/2005 10:34' prior: 0!
The scroller (a transform) of a scrollPane is driven by the scrollBar. The scroll values vary from 0.0, meaning zero offset to 1.0 meaning sufficient offset such that the bottom of the scrollable material appears 3/4 of the way down the pane. The total distance to achieve this range is called the totalScrollRange.
Basic clue about utilization of the ScrollPane class is given in:
ScrollPane example1.
ScrollPane example2.!
Item was added:
+ ----- Method: ScrollPane class>>horizontalScrollDeltaPerMouseWheelNotch (in category 'preferences') -----
+ horizontalScrollDeltaPerMouseWheelNotch
+
+ <preference: 'horizontal scroll increment per single mouse wheel'
+ category: #scrolling
+ description: 'How many horizontal scroll increments should be caused in response to a single mouse wheel notch.
+ Typically, the scroll panes increment are about 1 character width for list and text panes (see #scrollDeltaWidth).
+ The default setting is 3 so as to match the most widely used convention.'
+ type: #Number>
+ ^ HorizontalScrollDeltaPerMouseWheelNotch ifNil: [3]!
Item was added:
+ ----- Method: ScrollPane class>>horizontalScrollDeltaPerMouseWheelNotch: (in category 'preferences') -----
+ horizontalScrollDeltaPerMouseWheelNotch: anIntegerOrNil
+
+ HorizontalScrollDeltaPerMouseWheelNotch := anIntegerOrNil!
Item was changed:
----- Method: ScrollPane class>>scrollBarThickness (in category 'defaults') -----
scrollBarThickness
+ ^ ((Preferences scrollBarsNarrow ifTrue: [10] ifFalse: [14])
+ * RealEstateAgent scaleFactor) truncated!
- ^ Preferences scrollBarsNarrow
- ifTrue: [10]
- ifFalse: [14]!
Item was added:
+ ----- Method: ScrollPane class>>themePriority (in category 'preferences') -----
+ themePriority
+
+ ^ 40!
Item was changed:
----- Method: ScrollPane class>>useRetractableScrollBars: (in category 'preferences') -----
+ useRetractableScrollBars: aBooleanOrNil
- useRetractableScrollBars: aBoolean
+ UseRetractableScrollBars = aBooleanOrNil ifTrue: [^ self].
+ UseRetractableScrollBars := aBooleanOrNil.
- UseRetractableScrollBars = aBoolean ifTrue: [^ self].
- UseRetractableScrollBars := aBoolean.
ScrollPane allSubInstances do: [:pane |
+ pane retractable: self useRetractableScrollBars].!
- pane retractable: aBoolean].!
Item was added:
+ ----- Method: ScrollPane class>>verticalScrollDeltaPerMouseWheelNotch (in category 'preferences') -----
+ verticalScrollDeltaPerMouseWheelNotch
+
+ <preference: 'vertical scroll increment per single mouse wheel'
+ category: #scrolling
+ description: 'How many vertical scroll increments should be caused in response to a single mouse wheel notch.
+ Typically, the scroll panes increment are one line height for list and text panes (see #scrollDeltaHeight).
+ The default setting is 3 so as to match the most widely used convention.'
+ type: #Number>
+ ^ VerticalScrollDeltaPerMouseWheelNotch ifNil: [3]!
Item was added:
+ ----- Method: ScrollPane class>>verticalScrollDeltaPerMouseWheelNotch: (in category 'preferences') -----
+ verticalScrollDeltaPerMouseWheelNotch: anIntegerOrNil
+
+ VerticalScrollDeltaPerMouseWheelNotch := anIntegerOrNil!
Item was added:
+ ----- Method: ScrollPane>>displayScaleChangedBy: (in category 'display scale') -----
+ displayScaleChangedBy: factor
+ "Overwritten because the receiver's layout dictates some properties to its submorphs."
+
+ super displayScaleChangedBy: factor.
+ self scrollBarThickness: (self scrollBarThickness * factor) rounded.!
Item was changed:
----- Method: ScrollPane>>filterEvent:for: (in category 'event filtering') -----
filterEvent: aKeyboardEvent for: morphOrNil
"See #initialize. This filter should be installed as keyboard event filter during the capture phase."
+ (aKeyboardEvent isKeystroke
+ and: [self scrollByKeyboard: aKeyboardEvent])
+ ifTrue: [aKeyboardEvent ignore].
- aKeyboardEvent isKeystroke
- ifFalse: [^ aKeyboardEvent].
+ ^ aKeyboardEvent!
- ^ aKeyboardEvent
- wasIgnored: (self scrollByKeyboard: aKeyboardEvent);
- yourself!
Item was changed:
----- Method: ScrollPane>>keyStroke: (in category 'event handling') -----
keyStroke: evt
"If pane is not empty, pass the event to the last submorph,
assuming it is the most appropriate recipient (!!)"
+ scroller hasSubmorphs ifTrue:
+ [scroller lastSubmorph keyStroke: evt].!
- scroller submorphs last keyStroke: evt!
Item was changed:
----- Method: ScrollPane>>mouseWheel: (in category 'event handling') -----
mouseWheel: evt
+ evt isWheelUp ifTrue: [scrollBar scrollUp: (evt verticalScrollDelta: self class verticalScrollDeltaPerMouseWheelNotch)].
+ evt isWheelDown ifTrue: [scrollBar scrollDown: (evt verticalScrollDelta: self class verticalScrollDeltaPerMouseWheelNotch)].
+ evt isWheelLeft ifTrue: [hScrollBar scrollUp: (evt horizontalScrollDelta: self class horizontalScrollDeltaPerMouseWheelNotch)].
+ evt isWheelRight ifTrue: [hScrollBar scrollDown: (evt horizontalScrollDelta: self class horizontalScrollDeltaPerMouseWheelNotch)].!
- evt isWheelUp ifTrue: [scrollBar scrollUp: 3].
- evt isWheelDown ifTrue: [scrollBar scrollDown: 3].!
Item was changed:
----- Method: ScrollPane>>scrollToShow: (in category 'scrolling') -----
scrollToShow: aRectangle
| newOffset |
newOffset := self offsetToShow: aRectangle.
+ self hScrollBar setValue: newOffset x.
+ self vScrollBar setValue: newOffset y.!
- scroller offset = newOffset ifTrue: [^ self].
- scroller offset: newOffset.
- self layoutChanged.!
Item was changed:
----- Method: ScrollPane>>setDefaultParameters (in category 'initialization') -----
setDefaultParameters
"change the receiver's appareance parameters"
self
color: (self userInterfaceTheme color ifNil: [Color white]);
borderStyle: (self userInterfaceTheme borderStyle ifNil: [BorderStyle simple]) copy;
borderColor: (self userInterfaceTheme borderColor ifNil: [Color gray: 0.6]);
+ borderWidth: ((self userInterfaceTheme borderWidth ifNil: [1]) * RealEstateAgent scaleFactor) truncated.!
- borderWidth: (self userInterfaceTheme borderWidth ifNil: [1]).!
Item was changed:
----- Method: SearchBar>>buildWith: (in category 'toolbuilder') -----
buildWith: builder
^ (builder build: (builder pluggableInputFieldSpec new
model: self;
+ plainTextOnly: true;
getText: #searchTerm;
setText: #smartSearch:in:;
editText: #searchTermSilently:;
menu: #menu:shifted:;
selection: #selection;
indicateUnacceptedChanges: false;
help: 'Search or evaluate...' translated))
name: #searchBar;
wantsFrameAdornments: false;
yourself!
Item was added:
+ ----- Method: SearchBar>>okToRevertChanges: (in category 'user edits') -----
+ okToRevertChanges: aspect
+ "Clear caches since we use #textEdited: callback from view."
+
+ aspect = #searchTermSilently: ifTrue: [searchTerm := ''].
+ ^ true!
Item was changed:
----- Method: SearchBar>>smartSearch:in: (in category 'searching') -----
smartSearch: text in: morph
"Take the user input and perform an appropriate search"
| input newContents |
self removeResultsWidget.
input := text asString ifEmpty:[^self].
self class useSmartSearch ifFalse: [^ ToolSet default browseMessageNames: input].
+ (Symbol lookup: input) ifNotNil:
+ [:symbol| input := symbol].
"If it is a global or a full class name, browse that class."
+ (Smalltalk bindingOf: input) ifNotNil:
+ [:assoc| | class |
+ class := (assoc value isBehavior ifTrue:[assoc value] ifFalse:[assoc value class]) theNonMetaClass.
+ ^ToolSet browseClass: class].
- (Smalltalk bindingOf: input) ifNotNil:[:assoc| | global |
- global := assoc value.
- ^ToolSet browse: (global isBehavior ifTrue:[global] ifFalse:[global class]) selector: nil].
"If it is a symbol and there are implementors of it, browse those implementors."
+ input isSymbol ifTrue:
+ [(SystemNavigation new allImplementorsOf: input) ifNotEmpty:
+ [:list|
- Symbol hasInterned: input ifTrue: [:selector |
- (SystemNavigation new allImplementorsOf: selector) ifNotEmpty:[:list|
^SystemNavigation new
browseMessageList: list
name: 'Implementors of ' , input]].
"If it starts uppercase, browse classes if any. Otherwise, just search for messages."
+ input first isUppercase ifTrue:
+ [(UIManager default classFromPattern: input withCaption: '') ifNotNil:
+ [:aClass| ^ToolSet browse: aClass selector: nil].
+ newContents := input, ' -- not found.'.
+ self searchTerm: newContents.
+ self selection: (input size+1 to: newContents size).
+ self currentHand newKeyboardFocus: morph textMorph.
+ ^ self].
+
+ "Default to browse message names..."
+ ToolSet default browseMessageNames: input!
- input first isUppercase
- ifTrue: [
- (UIManager default classFromPattern: input withCaption: '')
- ifNotNil:[:aClass| ^ToolSet browse: aClass selector: nil]
- ifNil: [
- newContents := input, ' -- not found.'.
- self searchTerm: newContents.
- self selection: (input size+1 to: newContents size).
- self currentHand newKeyboardFocus: morph textMorph.
- ^ self]]
- ifFalse: [
- ToolSet default browseMessageNames: input].!
Item was removed:
- ----- Method: SelectionMorph>>aboutToBeGrabbedBy: (in category 'dropping/grabbing') -----
- aboutToBeGrabbedBy: aHand
- slippage := 0@0.
- ^ super aboutToBeGrabbedBy: aHand
- !
Item was changed:
+ ----- Method: SelectionMorph>>delete (in category 'submorphs - add/remove') -----
- ----- Method: SelectionMorph>>delete (in category 'submorphs-add/remove') -----
delete
self setProperty: #deleting toValue: true.
super delete.
!
Item was changed:
+ ----- Method: SelectionMorph>>dismissViaHalo (in category 'submorphs - add/remove') -----
- ----- Method: SelectionMorph>>dismissViaHalo (in category 'submorphs-add/remove') -----
dismissViaHalo
selectedItems do: [:m | m dismissViaHalo].
super dismissViaHalo.
!
Item was changed:
----- Method: SelectionMorph>>duplicate (in category 'halo commands') -----
duplicate
"Make a duplicate of the receiver and havbe the hand grab it"
selectedItems := self duplicateMorphCollection: selectedItems.
+ selectedItems reverseDo: [:m | (owner ifNil: [self currentWorld]) addMorph: m].
- selectedItems reverseDo: [:m | (owner ifNil: [ActiveWorld]) addMorph: m].
dupLoc := self position.
+ self currentHand grabMorph: self.
+ self currentWorld presenter flushPlayerListCache.!
- ActiveHand grabMorph: self.
- ActiveWorld presenter flushPlayerListCache!
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 world ifNil: [^ self])!
- self selectSubmorphsOf: (self pasteUpMorph ifNil: [^ self])!
Item was changed:
----- Method: SelectionMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
""
+ self disableLayout: true.
+ self morphicLayerNumber: self class haloLayer + 1.
-
selectedItems := OrderedCollection new.
+ itemsAlreadySelected := OrderedCollection new.!
- itemsAlreadySelected := OrderedCollection new.
- slippage := 0 @ 0!
Item was added:
+ ----- Method: SelectionMorph>>intoWorld: (in category 'initialization') -----
+ intoWorld: aWorld
+
+ selectedItems ifNotEmpty: [
+ "Restore selected items for #reintroduceIntoWorld:"
+ self flag: #ct. "Introduce separate hook for this - #reintroducedIntoWorld:?"
+ selectedItems do: [:morph |
+ aWorld reintroduceIntoWorld: morph].
+ ^ self delete].
+ super intoWorld: aWorld.!
Item was removed:
- ----- Method: SelectionMorph>>morphicLayerNumber (in category 'WiW support') -----
- morphicLayerNumber
- "helpful for insuring some morphs always appear in front of or
- behind others. smaller numbers are in front"
- ^ 8!
Item was changed:
----- Method: SelectionMorph>>privateFullMoveBy: (in category 'private') -----
privateFullMoveBy: delta
+ "Overridden to also move the currently encompassed morphs like they would be my submorphs."
+
+ super privateFullMoveBy: delta.
+ selectedItems do: [:m | m position: m position + delta].
-
- | griddedDelta griddingMorph |
- selectedItems isEmpty ifTrue: [^ super privateFullMoveBy: delta].
- griddingMorph := self pasteUpMorph.
- griddingMorph ifNil: [^ super privateFullMoveBy: delta].
- griddedDelta := (griddingMorph gridPoint: self position + delta + slippage) -
- (griddingMorph gridPoint: self position).
- slippage := slippage + (delta - griddedDelta). "keep track of how we lag the true movement."
- griddedDelta = (0@0) ifTrue: [^ self].
- super privateFullMoveBy: griddedDelta.
- selectedItems do:
- [:m | m position: (m position + griddedDelta) ]
!
Item was changed:
----- Method: SequenceableCollection>>segmentedSlopes (in category '*Morphic-NewCurves-cubic support') -----
segmentedSlopes
"For a collection of floats. Returns the slopes for straight
segments between vertices."
"last slope closes the polygon. Always return same size as
self. "
^ self
+ withIndexCollect: [:x :i | (self atWrap: i + 1)
- collectWithIndex: [:x :i | (self atWrap: i + 1)
- x]!
Item was changed:
+ ----- Method: SimpleButtonMorph>>actWhen (in category 'submorphs - add/remove') -----
- ----- Method: SimpleButtonMorph>>actWhen (in category 'submorphs-add/remove') -----
actWhen
"acceptable symbols: #buttonDown, #buttonUp, and #whilePressed"
^ actWhen!
Item was changed:
+ ----- Method: SimpleButtonMorph>>actWhen: (in category 'submorphs - add/remove') -----
- ----- Method: SimpleButtonMorph>>actWhen: (in category 'submorphs-add/remove') -----
actWhen: condition
"Accepts symbols: #buttonDown, #buttonUp, and #whilePressed, #startDrag"
actWhen := condition.
actWhen == #startDrag
ifFalse: [self on: #startDrag send: nil to: nil ]
ifTrue:[self on: #startDrag send: #doButtonAction to: self].!
Item was added:
+ ----- Method: SimpleButtonMorph>>browseImplementationOfActionSelector (in category 'debug menu') -----
+ browseImplementationOfActionSelector
+
+ ToolSet browseMethod: (self target class lookupSelector: self actionSelector).!
Item was added:
+ ----- Method: SimpleButtonMorph>>buildDebugMenu: (in category 'debug menu') -----
+ buildDebugMenu: aHandMorph
+
+ | aMenu |
+ aMenu := super buildDebugMenu: aHandMorph.
+ aMenu addLine.
+ aMenu add: 'browse action code' translated target: self action: #browseImplementationOfActionSelector.
+ aMenu add: 'debug action invocation' translated target: self action: #debugAction.
+ ^ aMenu!
Item was added:
+ ----- Method: SimpleButtonMorph>>debugAction (in category 'debug menu') -----
+ debugAction
+
+ (Process
+ forBlock: [self doButtonAction]
+ runUntil: [:context | context selector = self actionSelector])
+ debugWithTitle: ('Debug button action "{1}" in model "{2}"' translated format: {self label. self target printString}).!
Item was added:
+ ----- Method: SimpleButtonMorph>>isButton (in category 'classification') -----
+ isButton
+
+ ^ true!
Item was changed:
Morph subclass: #SimpleHaloMorph
+ instanceVariableNames: 'target positionOffset enclosesFullBounds'
- instanceVariableNames: 'target positionOffset'
classVariableNames: ''
poolDictionaries: ''
category: 'Morphic-Widgets'!
!SimpleHaloMorph commentStamp: 'mt 11/6/2015 09:59' prior: 0!
This is a simple base class for halos in the system. It represents the minimal interface used to implement custom halo morphs.
It provides:
- event handling code to invoke and transfer a halo when clicking the meta-button (blue)
- move the halo's target (morph) when click-hold-drag the meta-button
- one close button as a minimal handle (see #addHandles)
In general, the halo concept consists of one dedicated user interaction (meta-button click) to invoke an additional, interactive view (the halo) for any morph. This interactive view is itself a morph that can have submorphs (e.g. buttons or text fields) to enrich the target morph. Besides button-based interactions (e.g. resize, move, duplicate, etc.), this could also be used to show other, even domain-specific, information.
Use the halo concept to provide means to explore and modify interactive, graphical elements in Squeak and your application. You can benefit from this concept without wasting additional screen space. In non-Squeak applications, the meta-key (typically the mouse-wheel button) is often without real functionality for the user. There, it makes scrolling more convenient---at best. In Squeak, you can easily take advantage of this button click.
Notice that direct user input is very limited. Many keyboard shortcuts (such as [ctrl]+[c]) are already pre-defined and should not be remapped for your domain-specific applications to avoid user confusion. Key chords (such as [ctrl]+[alt]+[v], [a] from Visual Studio) have to be learned with great effort.
The left mouse click (red) selects something.
The right mouse click (yellow) invokes a context menu.
Only the middle click, the meta-key, the blue button, is unused in many environments.
This is where the halo concept comes in.
[For two- or single-button mice, the meta-key can be simulated.]!
Item was changed:
+ ----- Method: SimpleHaloMorph>>delete (in category 'submorphs - add/remove') -----
- ----- Method: SimpleHaloMorph>>delete (in category 'submorphs-add/remove') -----
delete
self target hasHalo: false.
super delete.!
Item was changed:
----- Method: SimpleHaloMorph>>doDragTarget: (in category 'dragging') -----
doDragTarget: event
self target
setConstrainedPosition: (self target point: (event position - self positionOffset) from: self owner)
hangOut: true.
+ self updateBounds.!
- self bounds: self target worldBoundsForHalo.!
Item was added:
+ ----- Method: SimpleHaloMorph>>enclosesFullBounds (in category 'accessing') -----
+ enclosesFullBounds
+
+ ^ enclosesFullBounds!
Item was added:
+ ----- Method: SimpleHaloMorph>>enclosesFullBounds: (in category 'accessing') -----
+ enclosesFullBounds: aBoolean
+
+ enclosesFullBounds := aBoolean.!
Item was added:
+ ----- Method: SimpleHaloMorph>>haloBoundsFor: (in category 'initialization') -----
+ haloBoundsFor: aMorph
+
+ | rect |
+ rect := self enclosesFullBounds
+ ifFalse: [aMorph boundsIn: nil]
+ ifTrue: [aMorph fullBoundsInWorld].
+
+ Preferences showBoundsInHalo ifFalse: [^ rect].
+ ^ rect outsetBy: 2!
Item was added:
+ ----- Method: SimpleHaloMorph>>initialize (in category 'initialization') -----
+ initialize
+
+ super initialize.
+ self morphicLayerNumber: self class haloLayer.
+
+ "Each halo is a (kind of global) overlay that should not be bothered with the world's current layout policy. For example, a halo must match the target's bounds, which can be any inner part of the graphical hierarchy."
+ self disableLayout: true.
+
+ self initializeEnclosesFullBounds.!
Item was added:
+ ----- Method: SimpleHaloMorph>>initializeEnclosesFullBounds (in category 'initialization') -----
+ initializeEnclosesFullBounds
+
+ ^ self updateEnclosesFullBounds: self currentEvent!
Item was changed:
----- Method: SimpleHaloMorph>>mouseDown: (in category 'events') -----
mouseDown: event
"Transfer the halo to the next likely recipient"
+ event hand obtainHalo: self.
+
((self containsPoint: event position) not or: [event blueButtonPressed not])
ifTrue: [
"Close this halo and give another morph the chance to react."
event hand removeHalo.
event resetHandlerFields.
event hand world processEvent: event.
^ self].
+ self target ifNil: [
+ event hand removeHalo.
+ ^self].
- self target ifNil: [^self delete].
- event hand obtainHalo: self.
self positionOffset: (event position - (self target point: self target position in: self owner)).
"wait for drags or transfer"
event hand
waitForClicksOrDrag: self
event: event
selectors: { #transferHalo:. nil. nil. #startDragTarget:. }
threshold: HandMorph dragThreshold.!
Item was changed:
----- Method: SimpleHaloMorph>>transferHalo: (in category 'pop up') -----
transferHalo: event
"Transfer the halo to the next likely recipient"
+ ^ self
+ transferHalo: event
+ using: (self
+ valueOfProperty: #lastHaloDispatcher
+ ifAbsent: [self target defaultHaloDispatcher])!
- self target
- transferHalo: (event transformedBy: (self target transformedFrom: self))
- from: self target.!
Item was removed:
- ----- Method: SimpleHaloMorph>>transferHalo:from: (in category 'halos and balloon help') -----
- transferHalo: event from: formerHaloOwner
- "If my world tries to open on me, pass it on to the next sibling after me."
-
- formerHaloOwner == self world ifTrue: [
- self world submorphsDo: [:m |
- (m ~~ self and: [m fullContainsPoint: event position]) ifTrue: [
- m comeToFront.
- ^ m transferHalo: event from: formerHaloOwner]]].!
Item was added:
+ ----- Method: SimpleHaloMorph>>transferHalo:using: (in category 'pop up') -----
+ transferHalo: event using: dispatcher
+ "Transfer the halo to the next likely recipient. Call the target again so that it may change the dispatcher."
+
+ self updateEnclosesFullBounds: event.
+ ^ self target
+ transferHalo: (event transformedBy: (self target transformedFrom: self))
+ using: dispatcher!
Item was added:
+ ----- Method: SimpleHaloMorph>>updateBounds (in category 'updating') -----
+ updateBounds
+
+ self bounds: (self haloBoundsFor: self target).!
Item was added:
+ ----- Method: SimpleHaloMorph>>updateEnclosesFullBounds: (in category 'updating') -----
+ updateEnclosesFullBounds: anEvent
+
+ self enclosesFullBounds: (Preferences haloEnclosesFullBounds xor: anEvent controlKeyPressed).!
Item was added:
+ ----- Method: SimpleHaloMorph>>wantsHaloFromClick (in category 'halos and balloon help') -----
+ wantsHaloFromClick
+
+ ^ false!
Item was changed:
ScrollPane subclass: #SimpleHierarchicalListMorph
instanceVariableNames: 'selectedMorph hoveredMorph getListSelector keystrokeActionSelector autoDeselect columns columnsCache sortingSelector getSelectionSelector setSelectionSelector potentialDropMorph lineColor font textColor'
+ classVariableNames: 'ExpandedForm NotExpandedForm WrappedNavigation'
- classVariableNames: 'WrappedNavigation'
poolDictionaries: ''
category: 'Morphic-Explorer'!
- SimpleHierarchicalListMorph class
- instanceVariableNames: 'expandedForm notExpandedForm'!
!SimpleHierarchicalListMorph commentStamp: 'ls 3/1/2004 12:15' prior: 0!
Display a hierarchical list of items. Each item should be wrapped with a ListItemWrapper.
For a simple example, look at submorphsExample. For beefier examples, look at ObjectExplorer or FileList2.!
- SimpleHierarchicalListMorph class
- instanceVariableNames: 'expandedForm notExpandedForm'!
Item was added:
+ ----- Method: SimpleHierarchicalListMorph class>>applyUserInterfaceTheme (in category 'preferences') -----
+ applyUserInterfaceTheme
+
+ ExpandedForm := nil.
+ NotExpandedForm := nil.!
Item was changed:
----- Method: SimpleHierarchicalListMorph class>>expandedForm (in category 'instance creation') -----
expandedForm
+ ExpandedForm
+ ifNotNil: [ExpandedForm depth ~= Display depth
+ ifTrue: [ExpandedForm := nil]].
+ ^ ExpandedForm
+ ifNil: [ExpandedForm := ((Form
- expandedForm
- ifNotNil: [expandedForm depth ~= Display depth
- ifTrue: [expandedForm := nil]].
- ^ expandedForm
- ifNil: [expandedForm := ((Form
extent: 10 @ 9
depth: 8
fromArray: #(4294967295 4294967295 4294901760 4294967295 4294967295 4294901760 4278255873 16843009 16842752 4294902089 1229539657 33488896 4294967041 1229539585 4294901760 4294967295 21561855 4294901760 4294967295 4278321151 4294901760 4294967295 4294967295 4294901760 4294967295 4294967295 4294901760 )
offset: 0 @ 0)
+ asFormOfDepth: Display depth)
+ replaceColor: Color white withColor: Color transparent;
+ scaleIconToDisplay]!
- asFormOfDepth: Display depth) replaceColor: Color white withColor: Color transparent;
- yourself]!
Item was changed:
----- Method: SimpleHierarchicalListMorph class>>notExpandedForm (in category 'instance creation') -----
notExpandedForm
+ NotExpandedForm
+ ifNotNil: [NotExpandedForm depth ~= Display depth
+ ifTrue: [NotExpandedForm := nil]].
+ ^ NotExpandedForm
+ ifNil: [NotExpandedForm := ((Form
- notExpandedForm
- ifNotNil: [notExpandedForm depth ~= Display depth
- ifTrue: [notExpandedForm := nil]].
- ^ notExpandedForm
- ifNil: [notExpandedForm := ((Form
extent: 10 @ 9
depth: 8
fromArray: #(4294967041 4294967295 4294901760 4294967041 33554431 4294901760 4294967041 1224867839 4294901760 4294967041 1229521407 4294901760 4294967041 1229539585 4294901760 4294967041 1229521407 4294901760 4294967041 1224867839 4294901760 4294967041 33554431 4294901760 4294967041 4294967295 4294901760 )
offset: 0 @ 0)
asFormOfDepth: Display depth)
replaceColor: Color white withColor: Color transparent;
+ scaleIconToDisplay]!
- yourself]!
Item was changed:
----- Method: SimpleHierarchicalListMorph>>addMorphsTo:from:allowSorting:withExpandedItems:atLevel: (in category 'private') -----
addMorphsTo: morphList from: aCollection allowSorting: sortBoolean withExpandedItems: expandedItems atLevel: newIndent
| priorMorph newCollection firstAddition |
priorMorph := nil.
newCollection := (sortBoolean and: [sortingSelector notNil]) ifTrue: [
aCollection sorted: [ :a :b |
(a perform: sortingSelector) <= (b perform: sortingSelector)]
] ifFalse: [
aCollection
].
firstAddition := nil.
newCollection do: [:item |
priorMorph := self indentingItemClass basicNew
initWithContents: item
prior: priorMorph
forList: self
indentLevel: newIndent.
priorMorph
+ initWithColor: self textColor
+ andFont: self font.
+ priorMorph
- color: self textColor;
- font: self font;
selectionColor: self selectionColor;
selectionTextColor: self selectionTextColor;
hoverColor: self hoverColor;
highlightTextColor: self highlightTextColor;
filterColor: self filterColor;
+ filterTextColor: self filterTextColor;
+ wantsYellowButtonMenu: false.
- filterTextColor: self filterTextColor.
firstAddition ifNil: [firstAddition := priorMorph].
morphList add: priorMorph.
((item hasEquivalentIn: expandedItems) or: [priorMorph isExpanded]) ifTrue: [
+ self flag: #bug. "mt: Endless recursion can happen for similar items in the tree."
priorMorph isExpanded: true.
priorMorph
addChildrenForList: self
addingTo: morphList
withExpandedItems: expandedItems.
].
].
^firstAddition
!
Item was changed:
----- Method: SimpleHierarchicalListMorph>>addSubmorphsAfter:fromCollection:allowSorting: (in category 'private') -----
addSubmorphsAfter: parentMorph fromCollection: aCollection allowSorting: sortBoolean
| priorMorph morphList newCollection |
priorMorph := nil.
newCollection := (sortBoolean and: [sortingSelector notNil]) ifTrue: [
aCollection sorted: [ :a :b |
(a perform: sortingSelector) <= (b perform: sortingSelector)]
] ifFalse: [
aCollection
].
morphList := OrderedCollection new.
newCollection do: [:item |
priorMorph := self indentingItemClass basicNew
initWithContents: item
prior: priorMorph
forList: self
indentLevel: parentMorph indentLevel + 1.
priorMorph
+ initWithColor: self textColor
+ andFont: self font.
+ priorMorph
- color: self textColor;
- font: self font;
selectionColor: self selectionColor;
selectionTextColor: self selectionTextColor;
hoverColor: self hoverColor;
highlightTextColor: self highlightTextColor;
filterColor: self filterColor;
+ filterTextColor: self filterTextColor;
+ wantsYellowButtonMenu: false.
- filterTextColor: self filterTextColor.
morphList add: priorMorph.
].
scroller addAllMorphs: morphList after: parentMorph.
+ ^morphList!
- ^morphList
-
- !
Item was changed:
----- Method: SimpleHierarchicalListMorph>>applyUserInterfaceTheme (in category 'updating') -----
applyUserInterfaceTheme
super applyUserInterfaceTheme.
+
+ scroller submorphsDo: [:ea | ea refreshIcon].
self adjustSubmorphPositions.!
Item was changed:
----- Method: SimpleHierarchicalListMorph>>handleMouseMove: (in category 'events-processing') -----
handleMouseMove: anEvent
+ anEvent wasHandled ifFalse: [self hoveredMorph: (self itemFromPoint: anEvent position)].
+ super handleMouseMove: anEvent.!
- "Reimplemented because we really want #mouseMove when a morph is dragged around"
- anEvent wasHandled ifTrue:[^self]. "not interested"
- self hoveredMorph: (self itemFromPoint: anEvent position).
- (anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self].
- anEvent wasHandled: true.
- self mouseMove: anEvent.
- (self handlesMouseStillDown: anEvent) ifTrue:[
- "Step at the new location"
- self startStepping: #handleMouseStillDown:
- at: Time millisecondClockValue
- arguments: {anEvent copy resetHandlerFields}
- stepTime: 1].
- !
Item was added:
+ ----- Method: SimpleHierarchicalListMorph>>handlesMouseMove: (in category 'event handling') -----
+ handlesMouseMove: anEvent
+ ^ anEvent anyButtonPressed and: [anEvent hand mouseFocus == self]!
Item was changed:
----- Method: SimpleHierarchicalListMorph>>initialize (in category 'initialization') -----
initialize
"initialize the state of the receiver"
super initialize.
self setProperty: #autoExpand toValue: false.
+ scroller wantsYellowButtonMenu: false.
self
on: #mouseMove
send: #mouseStillDown:onItem:
to: self!
Item was changed:
----- Method: SimpleHierarchicalListMorph>>specialKeyPressed: (in category 'event handling') -----
specialKeyPressed: asciiValue
(self arrowKey: asciiValue)
ifTrue: [^ true].
asciiValue = 27 "escape"
ifTrue: [
+ self currentEvent shiftPressed
+ ifTrue: [self currentWorld putUpWorldMenuFromEscapeKey]
- ActiveEvent shiftPressed
- ifTrue: [ActiveWorld putUpWorldMenuFromEscapeKey]
ifFalse: [self yellowButtonActivity: false].
^ true].
^ false!
Item was changed:
----- Method: SketchMorph>>collapse (in category 'menus') -----
collapse
"Replace the receiver with a collapsed rendition of itself."
+ | w collapsedVersion a ht |
+
+ (w := self world) ifNil: [^ self].
- | 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}).
+
-
self delete.
w addMorphFront: (
a := AlignmentMorph newRow
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
borderWidth: 4;
borderColor: Color white;
addMorph: collapsedVersion;
yourself).
a setNameTo: self externalName.
+ ht := (Smalltalk at: #SugarNavTab ifPresent: [:c | Project current world findA: c])
+ ifNotNil: [:tab | tab height]
+ ifNil: [80].
- ht := (tab := Smalltalk at: #SugarNavTab ifPresent: [:c | ActiveWorld findA: c])
- ifNotNil:
- [tab height]
- ifNil:
- [80].
a position: 0@ht.
collapsedVersion setProperty: #collapsedMorphCarrier toValue: a.
+ (self valueOfProperty: #collapsedPosition) ifNotNil: [:priorPosition |
+ a position: priorPosition].!
- (self valueOfProperty: #collapsedPosition) ifNotNil:
- [:priorPosition |
- a position: priorPosition]!
Item was changed:
----- Method: SketchMorph>>erasePixelsUsing: (in category 'menu') -----
erasePixelsUsing: evt
"Let the user specifiy a color such that all pixels of that color should be erased; then do the erasure"
self
changeColorTarget: self
selector: #rememberedColor:
originalColor: nil
hand: evt hand.
self rememberedColor "color to erase"
ifNil: [ ^ self ]
+ ifNotNil:
- ifNotNilDo:
[ : chosenColor | self erasePixelsOfColor: chosenColor ]!
Item was added:
+ ----- Method: SketchMorph>>heading: (in category 'rotate scale and flex') -----
+ heading: newHeading
+ "If not rotating normally, change forward direction rather than heading"
+ rotationStyle == #normal ifTrue:[^super heading: newHeading].
+ self isFlexed
+ ifTrue:[self forwardDirection: newHeading - owner rotationDegrees]
+ ifFalse:[self forwardDirection: newHeading].
+ self layoutChanged!
Item was changed:
----- Method: Slider>>computeSlider (in category 'geometry') -----
computeSlider
| r v |
r := self roomToMove.
v := self maximumValue = self minimumValue
ifTrue: [0]
ifFalse: [(value - self minimumValue) / (self maximumValue - self minimumValue)].
self descending
ifFalse:
+ [self moveSliderTo: (self orientation == #horizontal
- [slider position: (self orientation == #horizontal
ifTrue: [r topLeft + ((r width * v) asInteger @ 0)]
ifFalse: [r topLeft + (0 @ (r height * v) asInteger)])]
ifTrue:
+ [self moveSliderTo: (self orientation == #horizontal
- [slider position: (self orientation == #horizontal
ifTrue: [r bottomRight - ((r width * v) asInteger @ 0)]
ifFalse: [r bottomRight - ((0 @ (r height * v) asInteger))])].
+ self resizeSliderTo: self sliderExtent.!
- slider extent: self sliderExtent!
Item was added:
+ ----- Method: Slider>>moveSliderTo: (in category 'geometry') -----
+ moveSliderTo: newPosition
+ "Sliently move the slider (or thumb) to not trigger any #layoutChanged events."
+
+ | delta |
+ self flag: #codeDuplication. "mt: We need a better way to silently do position changes. See Morph >> #position:."
+
+ delta := (newPosition - slider position) rounded.
+ delta = (0@0) ifTrue: [^ self].
+
+ slider privateFullMoveBy: delta.
+ self changed.
+ !
Item was added:
+ ----- Method: Slider>>resizeSliderTo: (in category 'geometry') -----
+ resizeSliderTo: newExtent
+
+ slider extent: newExtent.!
Item was changed:
----- Method: Slider>>setDefaultParameters (in category 'initialization') -----
setDefaultParameters
"change the receiver's appareance parameters"
self
color: (self userInterfaceTheme color ifNil: [Color lightGray]);
borderColor: (self userInterfaceTheme borderColor ifNil: [Color gray]);
+ borderWidth: ((self userInterfaceTheme borderWidth ifNil: [1]) * RealEstateAgent scaleFactor) truncated.
- borderWidth: (self userInterfaceTheme borderWidth ifNil: [1]).
slider
color: (self userInterfaceTheme thumbColor ifNil: [Color veryVeryLightGray]);
borderColor: (self userInterfaceTheme thumbBorderColor ifNil: [Color gray: 0.6]);
borderWidth: (self userInterfaceTheme thumbBorderWidth ifNil: [0]).
sliderShadow
borderWidth: slider borderWidth;
borderColor: Color transparent.
sliderColor := slider color.
self updateSliderColor: slider color.!
Item was changed:
----- Method: Slider>>showSliderShadow (in category 'other events') -----
showSliderShadow
sliderShadow color: self sliderShadowColor.
sliderShadow cornerStyle: slider cornerStyle.
+ sliderShadow privateBounds: slider bounds. "mt: Avoid #layoutChanged. See #moveSliderTo:."
- sliderShadow bounds: slider bounds.
sliderShadow show.!
Item was changed:
----- Method: SmalltalkEditor>>changeEmphasis: (in category 'editing keys') -----
changeEmphasis: characterStream
+ "Change emphasis without styling if necessary. NOTE THAT [cmd]+[1..4] will insert the name of the method argument number n."
+
- "Change emphasis without styling if necessary"
self styler ifNil: [^super changeEmphasis: characterStream].
^ self styler evaluateWithoutStyling: [super changeEmphasis: characterStream].!
Item was changed:
----- Method: SmalltalkEditor>>emphasisExtras (in category 'editing keys') -----
emphasisExtras
^#(
'Do it'
'Print it'
'Style it'
'Link to comment of class'
'Link to definition of class'
'Link to hierarchy of class'
'Link to method'
+ 'URL Link...'
+ 'Custom attribute...'
- 'URL Link'
- 'Custom attribute'
).!
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].
[attribute := TextPrintIt new.
thisSel := attribute analyze: self selection].
[thisSel := self styleSelection].
[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].
+ [thisSel := self selection.
+ attribute := self requestAttribute].
- [| input |
- input := UIManager default request: 'Enter attribute expression:'.
- input isEmptyOrNil ifTrue: [^ false].
- attribute := Compiler evaluate: input.
- thisSel := self selection].
["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"
(thisSel isEmpty and: [attribute notNil])
ifTrue: [
| oldAttributes |
"only change emphasisHere while typing"
oldAttributes := paragraph text attributesAt: self pointIndex.
emphasisHere := Text addAttribute: attribute toArray: oldAttributes]
ifFalse: [
self replaceSelectionWith: (attribute ifNil: [thisSel] ifNotNil: [thisSel asText addAttribute: attribute]) ].
^ true!
Item was changed:
----- Method: SmalltalkEditor>>methodArgument: (in category 'private') -----
methodArgument: anInteger
^ (ReadStream on: self text asString) nextLine
ifNil: [ String empty ]
+ ifNotNil:
- ifNotNilDo:
[ : line |
line substrings
at: 2 * anInteger
ifAbsent: [ String empty ] ]!
Item was added:
+ ----- Method: SmalltalkEditor>>requestAttribute (in category 'editing keys') -----
+ requestAttribute
+
+ | attribute input |
+ input := ''.
+ [input := Project uiManager
+ request: (input
+ ifEmpty: ['Enter expression for text attribute:' translated]
+ ifNotEmpty: ['This expression does not answer a TextAttribute, please correct it:' translated])
+ initialAnswer: input.
+ input isEmptyOrNil ifTrue: [^ nil].
+ attribute := Compiler evaluate: input]
+ doWhileFalse: [attribute respondsTo: #emphasizeScanner:].
+ ^ attribute!
Item was removed:
- ----- Method: SmalltalkEditor>>select (in category 'compatibility') -----
- select
- "Sent by the parser when correcting variables etc. Ignored here."!
Item was changed:
----- Method: SmalltalkEditor>>styleSelection (in category 'do-its') -----
styleSelection
| styler |
self lineSelectAndEmptyCheck: [^ ''].
+ styler := self styler ifNil: [(TextStyler for: #Smalltalk) ifNotNil: [:c | c new]].
- styler := self styler ifNil: [(Smalltalk classNamed: #SHTextStylerST80) new].
^ styler styledTextFor: self selection!
Item was changed:
----- Method: SmalltalkEditor>>tallySelection (in category 'do-its') -----
tallySelection
"Treat the current selection as an expression; evaluate it and return the time took for this evaluation"
| code result rcvr ctxt v |
self lineSelectAndEmptyCheck: [^ self].
(model respondsTo: #doItReceiver)
ifTrue: [ rcvr := model doItReceiver.
ctxt := model doItContext]
ifFalse: [rcvr := ctxt := nil].
result := [ | cm |
code := self selectionAsStream.
cm := rcvr class evaluatorClass new
compiledMethodFor: code
in: ctxt
to: rcvr
notifying: self
ifFail: [morph flash. ^ self].
Time millisecondsToRun:
[v := cm valueWithReceiver: rcvr arguments: (ctxt ifNil: [#()] ifNotNil: [{ctxt}]) ].
]
on: OutOfScopeNotification
do: [ :ex | ex resume: true].
UIManager default
+ inform: ('<b>Expression</b>{1}<br>{2}<br><br><b>Time</b> (compile and execute)<br>{3} ms<br><br><b>Result</b><br>{4}' translated format: {
- inform: ('<b>Expression</b>{1}<br>{2}<br><br><b>Time</b> (compile and execute)<br>{3} ms<br><br><b>Result</b><br>{4}' format: {
rcvr ifNil: [''] ifNotNil: [' (', (rcvr printString truncateWithElipsisTo: 20), ')'].
(code contents truncateWithElipsisTo: 200) copyReplaceAll: String cr with: '<br>'.
result printString.
v printString truncateWithElipsisTo: 100}) asTextFromHtml.!
Item was added:
+ ----- Method: SparseLargeTable>>explorerContents (in category '*Morphic-Explorer') -----
+ explorerContents
+
+ ^ Array streamContents: [:stream |
+ stream nextPut: (ObjectExplorerWrapper
+ with: defaultValue
+ name: 'defaultValue'
+ model: self).
+ self sparseElementsAndIndicesDo: [:element :index |
+ stream nextPut: (ObjectExplorerWrapper
+ with: element
+ name: index printString
+ model: self)]]!
Item was changed:
----- Method: StringMorph>>acceptContents (in category 'editing') -----
acceptContents
+ "The message is sent when the user hits enter or Cmd-S. Accept the current contents and end editing. This default implementation updates the model's known window title for pluggable windows."
+
+ self containingWindow ifNotNil: [:wnd |
+ wnd setLabel: self contents. "Needed for models that do not accept changes."
+ (wnd respondsTo: #getLabelSelector) ifTrue: [
+ wnd getLabelSelector ifNotNil: [:selector |
+ | mutator |
+ mutator := selector asSimpleSetter.
+ (wnd model respondsTo: mutator) ifTrue: [
+ wnd model perform: mutator with: self contents]]]]!
- "The message is sent when the user hits enter or Cmd-S. Accept the current contents and end editing. This default implementation does nothing."
- !
Item was changed:
----- Method: StringMorph>>contents: (in category 'accessing') -----
contents: newContents
+ self flag: #todo. "mt: hasFocus == true means that the mini editor was launched. We should now ignore any external calls to this method to avoid visual glitches. However, #interimContents: does also use this callback. Figure something out."
+
newContents isText
ifTrue: [^ self initializeFromText: newContents].
contents = newContents
+ ifTrue: [^ self "No substantive change."].
- ifTrue: [^ self "no substantive change"].
contents := newContents.
+ self changed. "New contents need to be drawn."
+
+ self fitContents. "Resize if necessary."!
-
- self fitContents.!
Item was changed:
----- Method: StringMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
+ | drawBounds |
+ drawBounds := self innerBounds. "within border, no other (layout) inset"
+ drawBounds := drawBounds origin + (0 @ self fontToUse lineGapSliceForMorphs) corner: drawBounds corner.
+
aCanvas
drawString: self contents
+ in: drawBounds
- in: self bounds
font: self fontToUse
color: self color.!
Item was changed:
----- Method: StringMorph>>fitContents (in category 'layout') -----
fitContents
+ self extent: self measureContents.!
- | newBounds boundsChanged |
- newBounds := self measureContents.
- boundsChanged := bounds extent ~= newBounds.
- self extent: newBounds. "default short-circuits if bounds not changed"
- boundsChanged ifFalse: [self changed]!
Item was changed:
----- Method: StringMorph>>font: (in category 'accessing') -----
font: aFont
"Set the font my text will use. The emphasis remains unchanged."
- aFont = font ifTrue: [^ self].
-
self
setFont: (aFont emphasized: self emphasis)
emphasis: self emphasis.!
Item was changed:
----- Method: StringMorph>>font:emphasis: (in category 'accessing - convenience') -----
+ font: aFontOrNil emphasis: emphasisCodeOrNil
+ "For convenience only. Try to use #font: and #emphasis: instead.
+
+ Changes font and/or emphasis. If both are given, the font's current emphasis will be discarded. If only the emphasis is given, the system's default font will be used. If only the font is given, the font's emphasis will be cached so that future calls to #font: will keep the emphasis."
- font: aFont emphasis: emphasisCode
self
+ assert: aFontOrNil notNil | emphasisCodeOrNil notNil
+ description: 'Either font or emphasis must be non-nil.'.
+
+ self
+ setFont: ((aFontOrNil isNil or: [aFontOrNil emphasis = emphasisCodeOrNil] or: [emphasisCodeOrNil isNil])
+ ifTrue: [aFontOrNil]
+ ifFalse: [aFontOrNil emphasized: emphasisCodeOrNil])
+ emphasis: (emphasisCodeOrNil ifNil: [aFontOrNil emphasis]).
+
+ "self assert: self font emphasis = self emphasis. --- mt: Does not always work because of how StrikeFont treats emphasis 0 in #emphasized:."!
- setFont: ((aFont isNil or: [aFont emphasis = emphasisCode] or: [emphasisCode isNil])
- ifTrue: [aFont]
- ifFalse: [aFont emphasized: emphasisCode])
- emphasis: (emphasisCode ifNil: [aFont emphasis]).!
Item was changed:
----- Method: StringMorph>>initWithContents:font:emphasis: (in category 'initialization') -----
+ initWithContents: aStringOrText font: aFont emphasis: emphasisCode
- initWithContents: aString font: aFont emphasis: emphasisCode
self initialize.
+ self font: aFont emphasis: emphasisCode.
+ aStringOrText isText
+ ifTrue: [self initializeFromText: aStringOrText]
+ ifFalse: [self initializeFromString: aStringOrText].!
- contents := aString.
-
- self font: aFont emphasis: emphasisCode.!
Item was added:
+ ----- Method: StringMorph>>initializeFromString: (in category 'initialization') -----
+ initializeFromString: aString
+
+ contents := aString.
+ self fitContents.!
Item was changed:
----- Method: StringMorph>>initializeFromText: (in category 'initialization') -----
initializeFromText: aText
| scanner |
scanner := StringMorphAttributeScanner new initializeFromStringMorph: self.
(aText attributesAt: 1 forStyle: self font textStyle)
do: [:attr | attr emphasizeScanner: scanner].
+ font := scanner font emphasized: scanner emphasis.
emphasis := scanner emphasis.
- font := scanner font.
color := scanner textColor.
+
+ contents := aText string.
+ self fitContents.!
-
- self contents: aText string.!
Item was changed:
----- Method: StringMorph>>launchMiniEditor: (in category 'editing') -----
launchMiniEditor: evt
| textMorph |
hasFocus := true. "Really only means edit in progress for this morph"
textMorph := StringMorphEditor new contentsAsIs: contents.
+ textMorph font: self fontToUse.
+ textMorph color: self color.
+ textMorph plainTextOnly: true.
+ textMorph innerBounds: self innerBounds.
- textMorph beAllFont: self fontToUse.
- textMorph bounds: (self bounds expandBy: 0@2).
self addMorphFront: textMorph.
evt hand newKeyboardFocus: textMorph.
textMorph editor selectFrom: 1 to: textMorph paragraph text string size!
Item was changed:
----- Method: StringMorph>>measureContents (in category 'accessing - support') -----
measureContents
| f |
f := self fontToUse.
+ ^(((f widthOfString: contents) max: self minimumWidth) @ f lineGridForMorphs).!
- ^(((f widthOfString: contents) max: self minimumWidth) @ f height).!
Item was changed:
----- Method: StringMorph>>minHeight (in category 'layout') -----
minHeight
"Layout specific."
+ ^ super minHeight max: self fontToUse lineGridForMorphs!
- ^ super minHeight max: self fontToUse height!
Item was changed:
----- Method: StringMorph>>setWidth: (in category 'accessing - support') -----
setWidth: width
+ self extent: width @ self height!
- self extent: width @ (font ifNil: [TextStyle defaultFont]) height!
Item was changed:
----- Method: StringMorphAttributeScanner>>initializeFromStringMorph: (in category 'string morph') -----
initializeFromStringMorph: aStringMorph
actualFont := aStringMorph font ifNil: [ TextStyle defaultFont ].
+ emphasis := 0. "We must start with no emphasis."
+ fontNumber := (actualFont textStyleOrNil
+ ifNil: [1]
+ ifNotNil: [:style | style fontIndexOfPointSize: actualFont pointSize]).
- emphasis := actualFont emphasis.
- fontNumber := (actualFont textStyle ifNotNil: [:style | style fontIndexOf: actualFont]) ifNil: [ 1 ].
textColor := aStringMorph color.
!
Item was removed:
- ----- Method: StringMorphEditor>>drawOn: (in category 'drawing') -----
- drawOn: aCanvas
-
- aCanvas fillRectangle: self bounds color: Color yellow muchLighter.
- ^ super drawOn: aCanvas!
Item was changed:
----- Method: StringMorphEditor>>initialize (in category 'display') -----
initialize
"Initialize the receiver. Give it a white background"
super initialize.
+ self setDefaultParameters.!
- self backgroundColor: Color white.
- self textColor: Color red.!
Item was changed:
----- Method: StringMorphEditor>>keyStroke: (in category 'event handling') -----
keyStroke: evt
"This is hugely inefficient, but it seems to work, and it's unlikely it will ever need
to be any more efficient -- it's only intended to edit single-line strings."
| char priorEditor newSel |
(((char := evt keyCharacter) = Character enter) or: [(char = Character cr)
or: [char = $s and: [evt commandKeyPressed]]])
ifTrue: [owner doneWithEdits; acceptContents.
self flag: #arNote. "Probably unnecessary"
evt hand releaseKeyboardFocus.
^ self delete].
+ ((char := evt keyCharacter) = Character escape
+ or: [char = $l and: [evt commandKeyPressed]]) ifTrue: "cancel"
- (char = $l and: [evt commandKeyPressed]) ifTrue: "cancel"
[owner cancelEdits.
evt hand releaseKeyboardFocus.
^ self delete].
super keyStroke: evt.
owner ifNil: [^self].
owner interimContents: self contents asString.
newSel := self editor selectionInterval.
priorEditor := self editor. "Save editor state"
self releaseParagraph. "Release paragraph so it will grow with selection."
self paragraph. "Re-instantiate to set new bounds"
self installEditorToReplace: priorEditor. "restore editor state"
self editor selectFrom: newSel first to: newSel last.
!
Item was added:
+ ----- Method: StringMorphEditor>>setDefaultParameters (in category 'display') -----
+ setDefaultParameters
+ "Based on PluggableTextMorph >> #setDefaultParameters."
+
+ self
+ backgroundColor: ((UserInterfaceTheme current get: #color for: #ScrollPane) ifNil: [Color white]);
+ borderStyle: ((UserInterfaceTheme current get: #borderStyle for: #ScrollPane) ifNil: [BorderStyle simple]) copy;
+ borderColor: ((UserInterfaceTheme current get: #borderColor for: #ScrollPane) ifNil: [Color gray: 0.6]);
+ borderWidth: (((UserInterfaceTheme current get: #borderWidth for: #ScrollPane) ifNil: [1]) * RealEstateAgent scaleFactor) truncated.
+
+ self
+ caretColor: ((UserInterfaceTheme current get: #caretColor for: #PluggableTextMorph) ifNil: [Color red]);
+ selectionColor: ((UserInterfaceTheme current get: #selectionColor for: #PluggableTextMorph) ifNil: [TranslucentColor r: 0.0 g: 0.0 b: 0.8 alpha: 0.2]).
+
+ self setProperty: #indicateKeyboardFocus toValue: #never.!
Item was changed:
----- Method: SystemProgressMorph class>>applyUserInterfaceTheme (in category 'preferences') -----
applyUserInterfaceTheme
+ self initialize; reset.!
- self reset.!
Item was changed:
----- Method: SystemProgressMorph class>>initialize (in category 'class initialization') -----
initialize
"SystemProgressMorph initialize; reset"
+
+ BarHeight := (8 * RealEstateAgent scaleFactor) rounded.
+ BarWidth := (300 * RealEstateAgent scaleFactor) rounded.
+ Inset := ((30@30) * RealEstateAgent scaleFactor) rounded.!
- BarHeight := 8.
- BarWidth := 300.
- Inset := 30@30!
Item was changed:
----- Method: SystemProgressMorph class>>uniqueInstance (in category 'instance creation') -----
uniqueInstance
+
+ ^ UniqueInstance ifNil: [UniqueInstance := super new]!
- ^UniqueInstance ifNil:[super new]!
Item was changed:
+ ----- Method: SystemProgressMorph>>dismissViaHalo (in category 'submorphs - add/remove') -----
- ----- Method: SystemProgressMorph>>dismissViaHalo (in category 'submorphs-add/remove') -----
dismissViaHalo
self class reset!
Item was changed:
----- Method: SystemProgressMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
activeSlots := 0.
bars := Array new: 10.
labels := Array new: 10.
lock := Semaphore forMutualExclusion.
self setDefaultParameters;
+ morphicLayerNumber: self class progressLayer;
- setProperty: #morphicLayerNumber toValue: self morphicLayerNumber;
layoutPolicy: TableLayout new;
listDirection: #topToBottom;
cellPositioning: #topCenter;
cellGap: 5;
listCentering: #center;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
layoutInset: Inset;
minWidth: 150!
Item was removed:
- ----- Method: SystemProgressMorph>>morphicLayerNumber (in category 'initialization') -----
- morphicLayerNumber
- "progress morphs are behind menus and balloons, but in front of most other stuff"
- ^self valueOfProperty: #morphicLayerNumber ifAbsent: [12].
- !
Item was changed:
----- Method: SystemProgressMorph>>reposition (in category 'private') -----
reposition
+ "Put ourself in the requested position on the display, but ensure completely within the bounds of the display. Compute layout first via #fullBounds to get correct #center."
+
+ self fullBounds.
- "Put ourself in the requested position on the display, but ensure completely within the bounds of the display"
- | position |
self bounds:
+ ((self bounds
+ align: self center
+ with: (self requestedPosition ifNil: [ self center ]))
+ translatedToBeWithin: self currentWorld bounds).
+
+ "Check to see if labels are wider than progress bars. In that case do a centered instead of the default left aligned layout."
+ self cellPositioning:
+ (self layoutExtent x > BarWidth
+ ifTrue: [ #topCenter ]
+ ifFalse: [ #leftCenter ]).!
- ((self fullBounds
- align: self fullBounds center
- with: (self requestedPosition ifNil: [ self fullBounds center ])) translatedToBeWithin: Display boundingBox).
- "Check to see if labels are wider than progress bars. In that case do
- a centered instead of the default left aligned layout."
- position := self width > (Inset x * 2 + (self borderWidth * 2) + BarWidth)
- ifTrue: [ #topCenter ]
- ifFalse: [ #leftCenter ].
- self cellPositioning: position!
Item was changed:
----- Method: SystemProgressMorph>>requestedPosition: (in category 'accessing') -----
requestedPosition: anObject
+ "only change the progress bar position if this is an occasion when the progress bar is opening with a single active bar. After that we don't want to change the position and leap around the screen"
+ activeSlots < 1 ifTrue:[ requestedPosition := anObject]!
-
- requestedPosition := anObject!
Item was changed:
----- Method: SystemProgressMorph>>setDefaultParameters (in category 'initialization') -----
setDefaultParameters
"change the receiver's appareance parameters"
self
color: (self userInterfaceTheme color ifNil: [Color r: 0.9 g: 0.9 b: 0.9]);
borderStyle: (self userInterfaceTheme borderStyle ifNil: [BorderStyle simple]) copy;
borderColor: (self userInterfaceTheme borderColor ifNil: [Color gray]);
+ borderWidth: ((self userInterfaceTheme borderWidth ifNil: [1]) * RealEstateAgent scaleFactor) truncated.
- borderWidth: (self userInterfaceTheme borderWidth ifNil: [1]).
Preferences menuAppearance3d ifTrue: [self addDropShadow].
self
font: (self userInterfaceTheme font ifNil: [TextStyle defaultFont]);
textColor: (self userInterfaceTheme textColor ifNil: [Color black]).
self
updateColor: self
color: self color
intensity: 1.!
Item was changed:
----- Method: SystemWindow class>>boxExtent (in category 'preferences') -----
boxExtent
"answer the extent to use in all the buttons"
+ ^ ((Preferences alternativeWindowBoxesLook
- ^ (Preferences alternativeWindowBoxesLook
ifTrue: [18 @ 18]
+ ifFalse: [16 @ 16]) * RealEstateAgent scaleFactor) truncated!
- ifFalse: [16 @ 16])!
Item was changed:
----- Method: SystemWindow class>>moveMenuButtonRight: (in category 'preferences') -----
+ moveMenuButtonRight: aBooleanOrNil
- moveMenuButtonRight: aBoolean
+ | absLeftOffset moveToRight |
+ moveToRight := aBooleanOrNil ifNil: [true "default value"].
+ absLeftOffset := ((self hideExpandButton and: [moveToRight])
- | absLeftOffset |
- absLeftOffset := ((self hideExpandButton and: [aBoolean])
ifTrue: [absLeftOffset := self boxExtent x * 2]
ifFalse: [absLeftOffset := self boxExtent x]) + 3.
+ self menuBoxFrame leftOffset: (moveToRight
- self menuBoxFrame leftOffset: (aBoolean
ifTrue: [absLeftOffset negated]
ifFalse: [absLeftOffset]).
self refreshAllWindows.!
Item was added:
+ ----- Method: SystemWindow class>>themePriority (in category 'preferences') -----
+ themePriority
+
+ ^ 30!
Item was changed:
----- Method: SystemWindow class>>themeProperties (in category 'preferences') -----
themeProperties
^ super themeProperties, {
{ #borderColorModifier. 'Colors'. 'How to derive the borderColor from the window color.' }.
+ { #borderWidth. 'Borders'. 'Width of the window''s border.' }.
- { #borderWidth. 'Borders'. 'Width of the menu''s border.' }.
{ #titleFont. 'Fonts'. 'Font of the window title.' }.
{ #unfocusedWindowColorModifier. 'Colors'. 'A block with one argument that modifies a color to look unfocused.' }.
{ #unfocusedLabelColor. 'Colors'. 'Window title color when window has no focus.'}.
{ #focusedLabelColor. 'Colors'. 'Window title color when window has focus.'}.
{ #color. 'Colors'. 'Color to use if the model or the pane morphs do not provide one.' }.
+
+ { #closeBoxImage. 'Icons'. 'Icon to click on to close the window.' }.
+ { #collapseBoxImage. 'Icons'. 'Icon to click on to collapse the window.' }.
+ { #expandBoxImage. 'Icons'. 'Icon to click on to expand the window.' }.
+ { #menuBoxImage. 'Icons'. 'Icon to click on to show window/application menu.' }.
}!
Item was removed:
- ----- Method: SystemWindow>>addCornerGrips (in category 'initialization') -----
- addCornerGrips
- "When enabled via preference, also add edge grips"
- super addCornerGrips.
- self class resizeAlongEdges ifTrue:[self addEdgeGrips].!
Item was added:
+ ----- Method: SystemWindow>>addGrips (in category 'initialization') -----
+ addGrips
+ "Only when enabled via preference, also add edge grips."
+
+ self removeGrips.
+
+ self addCornerGrips.
+ self class resizeAlongEdges ifTrue:[self addEdgeGrips].!
Item was changed:
----- Method: SystemWindow>>addMorph:fullFrame: (in category 'panes') -----
addMorph: aMorph fullFrame: aLayoutFrame
+ "Overwritten to maintain custom paneMorphs cache."
- "Add aMorph according to aLayoutFrame."
+ self removeCellGapFromLayoutFrames.
- super addMorph: aMorph fullFrame: aLayoutFrame.
+ aMorph layoutFrame: aLayoutFrame.
+ aMorph hResizing: #spaceFill; vResizing: #spaceFill.
+ self addMorph: aMorph.
+
paneMorphs := paneMorphs copyReplaceFrom: 1 to: 0 with: (Array with: aMorph).
+ aMorph isImageMorph ifFalse: [aMorph adoptPaneColor: self paneColor].
+
+ self addCellGapToLayoutFrames.
+
+ self wantsPaneSplitters ifTrue: [
+ "Splitters and grips share a preference. Tweak via #resizeAlongEges."
+ self addPaneSplitters.
+ self addGrips].!
- aMorph isImageMorph ifFalse: [aMorph adoptPaneColor: self paneColor].!
Item was removed:
- ----- Method: SystemWindow>>addPaneSplitters (in category 'initialization') -----
- addPaneSplitters
-
- self removeCornerGrips.
-
- super addPaneSplitters.
-
- self addCornerGrips.!
Item was changed:
----- Method: SystemWindow>>anyOpenWindowLikeMeIn: (in category 'open/close') -----
anyOpenWindowLikeMeIn: aPasteUpMorph
+
+ | requestor context |
+ self class reuseWindows ifFalse: [ ^ Array empty ].
+ context := thisContext sender.
+ [ context notNil and: [ requestor isNil ] ]
+ whileTrue: "Search for the requesting window to ignore it later."
+ [ | receiver window |
+ ((receiver := context receiver) ~~ self
+ and: [ receiver isMorph
+ and: [ (window := receiver firstOwnerSuchThat: [ : m | m isSystemWindow ]) ~~ self
+ and: [ window notNil ] ] ])
+ ifTrue: [ requestor := window ]
+ ifFalse: [ context := context sender ] ].
+ ^ self class
- self class reuseWindows ifFalse: [ ^Array empty ].
- ^ SystemWindow
windowsIn: aPasteUpMorph
satisfying:
[ : each |
+ each ~~ requestor
+ and: [ each model class = self model class
- each model class = self model class
and: [ (each model respondsTo: #representsSameBrowseeAs:)
+ and: [ each model representsSameBrowseeAs: self model ] ] ] ]
- and: [ each model representsSameBrowseeAs: self model ] ] ]
!
Item was changed:
----- Method: SystemWindow>>applyUserInterfaceTheme (in category 'user interface') -----
applyUserInterfaceTheme
super applyUserInterfaceTheme.
self
setDefaultParameters;
+ replaceBoxes;
refreshWindowColor.
self isLookingFocused
ifTrue: [self lookUnfocused; lookFocused]
ifFalse: [self lookFocused; lookUnfocused].
self isCollapsed ifTrue: [self setProperty: #applyTheme toValue: true].!
Item was changed:
----- Method: SystemWindow>>beKeyWindow (in category 'top window') -----
beKeyWindow
"Let me be the most important window on the screen. I am at the top and I can have a shadow to get more attention by the user. I am the window that is responsible for window keyboard shortcuts. Also see #isKeyWindow, #activate, and #lookFocused."
| oldKeyWindow |
self isKeyWindow ifTrue: [^ self].
oldKeyWindow := TopWindow.
TopWindow := self.
self
unlockWindowDecorations; "here, because all windows might be active anyway"
activate; "if not already active, activate now"
comeToFront. "key windows are on top"
"Change appearance to get noticed."
self hasDropShadow: Preferences menuAppearance3d.
(self valueOfProperty: #borderWidthWhenActive)
ifNotNil: [:bw | self acquireBorderWidth: bw].
oldKeyWindow ifNotNil: [:wnd |
wnd passivateIfNeeded.
"Change appearance to not look prettier than the new key window."
wnd hasDropShadow: false.
(wnd valueOfProperty: #borderWidthWhenInactive)
ifNotNil: [:bw | wnd acquireBorderWidth: bw]].
+
+ self currentEvent isKeyboard ifTrue: [
+ self currentHand newKeyboardFocus: self defaultFocusMorph].
+
-
"Synchronize focus look with position of current hand because any call could have made this window the new key window."
self updateFocusLookAtHand.!
Item was added:
+ ----- Method: SystemWindow>>changeCellGapOfLayoutFrames: (in category 'layout') -----
+ changeCellGapOfLayoutFrames: delta
+ "Overwritten to adapt labelArea (not part of #paneMorphs), which has topFraction = 0 but still grows upwards. Thus, we have to negate the given delta."
+
+ labelArea ifNotNil: [labelArea layoutFrame ifNotNil: [:frame |
+ frame topOffset: frame topOffset - delta]].
+
+ super changeCellGapOfLayoutFrames: delta.!
Item was changed:
----- Method: SystemWindow>>closeBoxHit (in category 'open/close') -----
closeBoxHit
"The user clicked on the close-box control in the window title. For Mac users only, the Mac convention of option-click-on-close-box is obeyed if the mac option key is down."
Preferences dismissAllOnOptionClose ifTrue:
+ [self currentEvent optionKeyPressed ifTrue:
- [Sensor rawMacOptionKeyPressed ifTrue:
[^ self world closeUnchangedWindows]].
self delete
!
Item was changed:
----- Method: SystemWindow>>collapseOrExpand (in category 'resize/collapse') -----
collapseOrExpand
"Collapse or expand the window, depending on existing state"
| cf |
isCollapsed
ifTrue:
["Expand -- restore panes to morphics structure"
isCollapsed := false.
self beKeyWindow. "Bring to frint first"
Preferences collapseWindowsInPlace
ifTrue:
[fullFrame := fullFrame align: fullFrame topLeft with: self getBoundsWithFlex topLeft]
ifFalse:
[collapsedFrame := self getBoundsWithFlex].
collapseBox ifNotNil: [collapseBox setBalloonText: 'collapse this window' translated].
self setBoundsWithFlex: fullFrame.
paneMorphs reverseDo:
[:m | self addMorph: m unlock.
self world startSteppingSubmorphsOf: m].
self addPaneSplitters.
+ self addGrips.
(self hasProperty: #applyTheme) ifTrue: [
self removeProperty: #applyTheme.
self userInterfaceTheme applyTo: self allMorphs]]
ifFalse:
["Collapse -- remove panes from morphics structure"
isCollapsed := true.
fullFrame := self getBoundsWithFlex.
"First save latest fullFrame"
paneMorphs do: [:m | m delete; releaseCachedState].
self removePaneSplitters.
+ self removeGrips.
- self removeCornerGrips.
model modelSleep.
cf := self getCollapsedFrame.
(collapsedFrame isNil and: [Preferences collapseWindowsInPlace not]) ifTrue:
[collapsedFrame := cf].
self setBoundsWithFlex: cf.
collapseBox ifNotNil: [collapseBox setBalloonText: 'expand this window' translated ].
expandBox ifNotNil: [expandBox setBalloonText: 'expand this window' translated ].
self sendToBack].
self layoutChanged!
Item was changed:
----- Method: SystemWindow>>convertAlignment (in category 'layout') -----
convertAlignment
"Primarily Jesse Welton's code to convert old system windows to ones with modern layout scheme"
self layoutPolicy: ProportionalLayout new.
(paneMorphs isNil
or: [paneRects isNil or: [paneMorphs size ~= paneRects size]])
ifFalse:
[self addLabelArea.
self putLabelItemsInLabelArea.
self setFramesForLabelArea.
paneMorphs with: paneRects
do:
[:m :r |
| frame |
frame := LayoutFrame new.
frame
leftFraction: r left;
rightFraction: r right;
topFraction: r top;
bottomFraction: r bottom.
m layoutFrame: frame.
m
hResizing: #spaceFill;
vResizing: #spaceFill]].
labelArea isNil
ifTrue:
[self addLabelArea.
self putLabelItemsInLabelArea.
self setFramesForLabelArea.
paneMorphs ifNotNil:
[paneMorphs do:
[:m |
| frame |
frame := m layoutFrame ifNil: [LayoutFrame new].
+ frame topOffset: (frame topOffset) - self labelHeight.
- frame topOffset: (frame topOffset ifNil: [0]) - self labelHeight.
frame bottomFraction ~= 1.0
ifTrue:
+ [frame bottomOffset: (frame bottomOffset) - self labelHeight]]]].
- [frame bottomOffset: (frame bottomOffset ifNil: [0]) - self labelHeight]]]].
label ifNotNil:
[| frame |
frame := LayoutFrame new.
frame
leftFraction: 0.5;
topFraction: 0;
leftOffset: label width negated // 2.
label layoutFrame: frame].
collapseBox ifNotNil:
[| frame |
frame := LayoutFrame new.
frame
rightFraction: 1;
topFraction: 0;
rightOffset: -1;
topOffset: 1.
collapseBox layoutFrame: frame].
stripes ifNotNil:
[| frame |
frame := LayoutFrame new.
frame
leftFraction: 0;
topFraction: 0;
rightFraction: 1;
leftOffset: 1;
topOffset: 1;
rightOffset: -1.
stripes first layoutFrame: frame.
stripes first height: self labelHeight - 2.
stripes first hResizing: #spaceFill.
frame := LayoutFrame new.
frame
leftFraction: 0;
topFraction: 0;
rightFraction: 1;
leftOffset: 3;
topOffset: 3;
rightOffset: -3.
stripes last layoutFrame: frame.
stripes last height: self labelHeight - 6.
stripes last hResizing: #spaceFill].
menuBox ifNotNil:
[| frame |
frame := LayoutFrame new.
frame
leftFraction: 0;
leftOffset: 19;
topFraction: 0;
topOffset: 1.
menuBox layoutFrame: frame].
closeBox ifNotNil:
[| frame |
frame := LayoutFrame new.
frame
leftFraction: 0;
leftOffset: 4;
topFraction: 0;
topOffset: 1.
closeBox layoutFrame: frame]!
Item was changed:
----- Method: SystemWindow>>createCloseBox (in category 'initialization') -----
createCloseBox
+ ^ (self createBox: (self userInterfaceTheme closeBoxImage ifNil: [self class closeBoxImage]))
- ^ (self createBox: self class closeBoxImage)
actionSelector: #closeBoxHit;
setBalloonText: 'close this window' translated!
Item was changed:
----- Method: SystemWindow>>createCollapseBox (in category 'initialization') -----
createCollapseBox
+ ^ (self createBox: (self userInterfaceTheme collapseBoxImage ifNil: [self class collapseBoxImage]))
- ^ (self createBox: self class collapseBoxImage)
actionSelector: #collapseOrExpand;
setBalloonText: 'collapse this window' translated.
!
Item was changed:
----- Method: SystemWindow>>createExpandBox (in category 'initialization') -----
createExpandBox
+ ^ (self createBox: (self userInterfaceTheme expandBoxImage ifNil: [self class expandBoxImage]))
- ^ (self createBox: self class expandBoxImage)
actionSelector: #expandBoxHit;
setBalloonText: 'expand this window' translated!
Item was changed:
----- Method: SystemWindow>>createMenuBox (in category 'initialization') -----
createMenuBox
+ ^ (self createBox: (self userInterfaceTheme menuBoxImage ifNil: [self class menuBoxImage]))
- ^ (self createBox: self class menuBoxImage)
actionSelector: #offerWindowMenu;
+ setBalloonText: 'window menu' translated;
+ actWhen: #buttonDown;
+ yourself!
- setBalloonText: 'window menu' translated!
Item was added:
+ ----- Method: SystemWindow>>defaultFocusMorph (in category 'focus') -----
+ defaultFocusMorph
+
+ | predicate |
+ predicate := (self hasProperty: #defaultFocusMorph)
+ ifFalse: [ [:morph | morph wantsKeyboardFocus] ]
+ ifTrue: [ | anObject |
+ anObject := (self valueOfProperty: #defaultFocusMorph) value.
+ anObject isMorph ifTrue: [^ anObject].
+ [:morph | morph knownName = anObject] ].
+
+ self
+ allMorphsBreadthFirstDo: [:morph | (predicate value: morph) ifTrue: [^ morph]]
+ sorted: [:a :b | a top < b top or: [a top = b top and: [a left <= b left]]].
+
+ ^ nil!
Item was added:
+ ----- Method: SystemWindow>>defaultFocusMorph: (in category 'focus') -----
+ defaultFocusMorph: aMorphOrBlockOrNameOrNil
+
+ self setProperty: #defaultFocusMorph toValue: aMorphOrBlockOrNameOrNil.!
Item was added:
+ ----- Method: SystemWindow>>displayScaleChangedBy: (in category 'layout') -----
+ displayScaleChangedBy: factor
+ "Overwritten to also update the label area and reset the #cellGap (and #splitters)."
+
+ super displayScaleChangedBy: factor.
+
+ self cellGap: ProportionalSplitterMorph gripThickness.
+ self layoutInset: ProportionalSplitterMorph gripThickness.
+
+ self setFramesForLabelArea.
+ "self replaceBoxes."!
Item was changed:
----- Method: SystemWindow>>doFastFrameDrag: (in category 'events') -----
doFastFrameDrag: grabPoint
"Do fast frame dragging from the given point"
| offset newBounds outerWorldBounds clearArea |
outerWorldBounds := self boundsIn: nil.
offset := outerWorldBounds origin - grabPoint.
+ clearArea := self currentWorld clearArea.
- 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!
Item was changed:
----- Method: SystemWindow>>initialize (in category 'initialization') -----
initialize
"Initialize a system window. Add label, stripes, etc., if desired"
super initialize.
+ allowReframeHandles := true.
+ isCollapsed := false.
+ paneMorphs := Array new.
+ mustNotClose := false.
+ updatablePanes := Array new.
+
self layoutPolicy: ProportionalLayout new.
self wantsPaneSplitters: true.
+ self wantsGrips: true.
self layoutInset: ProportionalSplitterMorph gripThickness.
self cellGap: ProportionalSplitterMorph gripThickness.
self initializeLabelArea.
+ self addGrips.
- self addCornerGrips.
self setDefaultParameters.
- allowReframeHandles := true.
- isCollapsed := false.
- paneMorphs := Array new.
- mustNotClose := false.
- updatablePanes := Array new.
-
self initializeKeyboardShortcuts.!
Item was changed:
----- Method: SystemWindow>>initializeLabelArea (in category 'initialization') -----
initializeLabelArea
"Initialize the label area (titlebar) for the window."
labelString ifNil: [labelString := 'Untitled Window'].
+ label := StringMorph new
+ contents: labelString;
+ font: (self userInterfaceTheme titleFont ifNil: [TextStyle defaultFont]);
+ yourself.
- label := StringMorph new contents: labelString.
"Add collapse box so #labelHeight will work"
collapseBox := self createCollapseBox.
stripes := Array
with: (RectangleMorph newBounds: bounds)
with: (RectangleMorph newBounds: bounds).
"see extent:"
self addLabelArea.
self setLabelWidgetAllowance.
self addCloseBox.
self class moveMenuButtonRight
ifTrue: [self addLabel. self addMenuControl]
ifFalse: [self addMenuControl. self addLabel].
self addExpandBox.
labelArea addMorphBack: collapseBox.
self setFramesForLabelArea.
Preferences noviceMode
ifTrue: [closeBox
ifNotNil: [closeBox setBalloonText: 'close window'].
menuBox
ifNotNil: [menuBox setBalloonText: 'window menu'].
collapseBox
ifNotNil: [collapseBox setBalloonText: 'collapse/expand window']].
!
Item was changed:
----- Method: SystemWindow>>justDroppedInto:event: (in category 'geometry') -----
justDroppedInto: aMorph event: anEvent
isCollapsed
ifTrue: [self position: ((self position max: 0@0) grid: 8@8).
collapsedFrame := self bounds]
ifFalse: [fullFrame := self bounds].
self beKeyWindow.
self hasDropShadow: Preferences menuAppearance3d. "See #startDragFromLabel:."
aMorph == self world ifTrue: [self assureLabelAreaVisible].
(Project uiManager openToolsAttachedToMouseCursor and: (self hasProperty: #initialDrop))
ifTrue: [
self removeProperty: #initialDrop.
(self submorphs detect: [:m | m isKindOf: BottomRightGripMorph] ifNone: [])
ifNotNil: [:grip |
grip
+ referencePoint: anEvent position - grip position;
+ backupAndHideTargetDropShadows. "See MorphicToolBuilder >> #open:"
+ self lookFocused.
+ anEvent hand newMouseFocus: grip]].
- referencePoint: anEvent position;
- setProperty: #targetHadDropShadow toValue: true "See MorphicToolBuilder >> #open:".
- self
- hasDropShadow: false;
- lookFocused.
- anEvent hand newMouseFocus: grip.]].
^super justDroppedInto: aMorph event: anEvent!
Item was changed:
----- Method: SystemWindow>>labelHeight (in category 'label') -----
labelHeight
"Answer the height for the window label. The standard behavior is at bottom; a hook is provided so that models can stipulate other heights, in support of various less-window-looking demos."
| aHeight |
(model notNil and: [model respondsTo: #desiredWindowLabelHeightIn:]) ifTrue:
[(aHeight := model desiredWindowLabelHeightIn: self) ifNotNil: [^ aHeight]].
^ label ifNil: [0] ifNotNil:
+ [(label height + self cellInset + self cellGap) max:
- [(label height + self cellInset + self cellGap + self layoutInset) max:
(collapseBox ifNotNil: [collapseBox height] ifNil: [10])]!
Item was changed:
----- Method: SystemWindow>>relabel (in category 'label') -----
relabel
+
+ (Project uiManager
- | newLabel |
- newLabel := UIManager default
request: 'New title for this window' translated
+ initialAnswer: labelString)
+ ifNotEmpty: [:newLabel | self setLabel: newLabel].!
- initialAnswer: labelString.
- newLabel isEmpty ifTrue: [^self].
- (model windowReqNewLabel: newLabel)
- ifTrue: [self setLabel: newLabel]!
Item was changed:
----- Method: SystemWindow>>setDefaultParameters (in category 'initialization') -----
setDefaultParameters
Preferences menuAppearance3d
ifFalse: [self hasDropShadow: false]
ifTrue: [
self addDropShadow.
self hasDropShadow: self isKeyWindow. "maybe turn off again"].
+ self borderWidth: ((self userInterfaceTheme borderWidth ifNil: [1]) * RealEstateAgent scaleFactor) truncated.
- self borderWidth: (self userInterfaceTheme borderWidth ifNil: [1]).
label font: (self userInterfaceTheme titleFont ifNil: [TextStyle defaultFont]).!
Item was changed:
----- Method: SystemWindow>>setLabel: (in category 'label') -----
setLabel: aString
| frame |
+ (model windowReqNewLabel: aString) ifFalse: [^ self].
labelString := aString.
label ifNil: [^ self].
label contents: (aString ifNil: ['']).
self labelWidgetAllowance. "Sets it if not already"
self isCollapsed
ifTrue: [self extent: (label width + labelWidgetAllowance) @ (self labelHeight + 2)]
ifFalse: [label fitContents; setWidth: (label width min: self width - labelWidgetAllowance).
label align: label bounds topCenter with: self topCenter + (0@self borderWidth).
collapsedFrame ifNotNil:
[collapsedFrame := collapsedFrame withWidth: label width + labelWidgetAllowance]].
frame := LayoutFrame new.
frame leftFraction: 0.5;
topFraction: 0.5;
leftOffset: label width negated // 2;
topOffset: label height negated // 2.
label layoutFrame: frame.
!
Item was changed:
----- Method: SystemWindow>>setPaneRectsFromBounds (in category 'geometry') -----
setPaneRectsFromBounds
"Reset proportional specs from actual bounds, eg, after reframing panes"
| layoutBounds |
layoutBounds := self layoutBounds.
paneMorphs do:[:m| | box left bottom top frame right |
frame := m layoutFrame.
box := m bounds.
frame ifNotNil:[
+ left := box left - layoutBounds left - frame leftOffset.
+ right := box right - layoutBounds left - frame rightOffset.
+ top := box top - layoutBounds top - frame topOffset.
+ bottom := box bottom - layoutBounds top - frame bottomOffset.
- left := box left - layoutBounds left - (frame leftOffset ifNil:[0]).
- right := box right - layoutBounds left - (frame rightOffset ifNil:[0]).
- top := box top - layoutBounds top - (frame topOffset ifNil:[0]).
- bottom := box bottom - layoutBounds top - (frame bottomOffset ifNil:[0]).
frame leftFraction: (left / layoutBounds width asFloat).
frame rightFraction: (right / layoutBounds width asFloat).
frame topFraction: (top / layoutBounds height asFloat).
frame bottomFraction: (bottom / layoutBounds height asFloat).
].
].!
Item was changed:
----- Method: SystemWindow>>tryToRenameTo: (in category 'label') -----
tryToRenameTo: newLabel
"Triggered eg by typing a new name in the halo"
+ newLabel ifNotEmpty: [self setLabel: newLabel].
- newLabel isEmpty ifTrue: [^self].
- (model windowReqNewLabel: newLabel)
- ifTrue: [self setLabel: newLabel]
!
Item was changed:
----- Method: SystemWindow>>updateFocusLookForKeyboardFocus (in category 'focus') -----
updateFocusLookForKeyboardFocus
+ "Ensure that the window holding the current keyboard focus looks focused. Note that the focus window is not necessarily the receiver of this message."
| f w |
(((f := self activeHand keyboardFocus) notNil and: [(w := f containingWindow) notNil])
and: [w isActive])
ifTrue: [
(self class windowsIn: self world) do: [:window |
w ~~ window ifTrue: [window lookUnfocused]].
w lookFocused]!
Item was changed:
----- Method: TTFontDescription>>asMorph (in category '*Morphic-TrueType') -----
asMorph
+
+ ^ self asHandle font
+ browseAllGlyphs;
+ browseAllGlyphsByCategory;
+ browseAllSymbols;
+ yourself.
+
+ "^TTSampleFontMorph font: self"!
- ^TTSampleFontMorph font: self!
Item was changed:
----- Method: TableLayout>>computeExtraSpacing:in:horizontal:target: (in category 'layout') -----
computeExtraSpacing: arrangement in: newBounds horizontal: aBool target: aMorph
"Compute the required extra spacing for laying out the cells"
"match newBounds extent with arrangement's orientation"
| extent extra centering n extraPerCell cell last hFill vFill max amount allow |
extent := newBounds extent.
aBool ifFalse: [extent := extent transposed].
"figure out if we have any horizontal or vertical space fillers"
hFill := vFill := false.
max := 0 @ 0.
arrangement do:
[:c |
max := (max x max: c cellSize x) @ (max y + c cellSize y).
max := max max: c cellSize.
hFill := hFill or: [c hSpaceFill].
vFill := vFill or: [c vSpaceFill]].
"Take client's shrink wrap constraints into account.
Note: these are only honored when there are no #spaceFill children,
or when #rubberBandCells is set."
allow := properties rubberBandCells not.
aMorph hResizing == #shrinkWrap
ifTrue:
[aBool
ifTrue: [allow & hFill ifFalse: [extent := max x @ (max y max: extent y)]]
ifFalse: [allow & vFill ifFalse: [extent := (max x max: extent x) @ max y]]].
aMorph vResizing == #shrinkWrap
ifTrue:
[aBool
ifFalse: [allow & hFill ifFalse: [extent := max x @ (max y max: extent y)]]
ifTrue: [allow & vFill ifFalse: [extent := (max x max: extent x) @ max y]]].
"Now compute the extra v space"
extra := extent y
- (arrangement inject: 0 into: [:sum :c | sum + c cellSize y]).
extra > 0
ifTrue:
["Check if we have any #spaceFillers"
vFill
ifTrue:
["use only #spaceFillers"
n := arrangement inject: 0
into: [:sum :c | c vSpaceFill ifTrue: [sum + 1] ifFalse: [sum]].
n isZero ifFalse: [extraPerCell := extra asFloat / n asFloat].
extra := last := 0.
arrangement do:
[:c |
c vSpaceFill
ifTrue:
[extra := (last := extra) + extraPerCell.
amount := 0 @ (extra truncated - last truncated).
c do: [:cc | cc cellSize: cc cellSize + amount]]]]
ifFalse:
["no #spaceFillers; distribute regularly"
centering := properties wrapCentering.
"centering == #topLeft ifTrue:[]." "add all extra space to the last cell; e.g., do nothing"
centering == #bottomRight
ifTrue:
["add all extra space to the first cell"
+ arrangement ifNotEmpty: [arrangement first addExtraSpace: 0 @ extra]].
- arrangement first addExtraSpace: 0 @ extra].
centering == #center
ifTrue:
["add 1/2 extra space to the first and last cell"
+ arrangement ifNotEmpty: [arrangement first addExtraSpace: 0 @ (extra // 2)]].
- arrangement first addExtraSpace: 0 @ (extra // 2)].
centering == #justified
ifTrue:
["add extra space equally distributed to each cell"
n := arrangement size - 1 max: 1.
extraPerCell := extra asFloat / n asFloat.
extra := last := 0.
arrangement do:
[:c |
c addExtraSpace: 0 @ (extra truncated - last truncated).
extra := (last := extra) + extraPerCell]]]].
"Now compute the extra space for the primary direction"
centering := properties listCentering.
1 to: arrangement size
do:
[:i |
cell := arrangement at: i.
extra := extent x - cell cellSize x.
extra > 0
ifTrue:
["Check if we have any #spaceFillers"
cell := cell nextCell.
cell hSpaceFill
ifTrue:
["use only #spaceFillers"
n := cell inject: 0
into: [:sum :c | c hSpaceFill ifTrue: [sum + c target spaceFillWeight] ifFalse: [sum]].
n isZero ifFalse: [extraPerCell := extra asFloat / n asFloat].
extra := last := 0.
cell do:
[:c |
c hSpaceFill
ifTrue:
[extra := (last := extra) + (extraPerCell * c target spaceFillWeight).
amount := extra truncated - last truncated.
c cellSize: c cellSize + (amount @ 0)]]]
ifFalse:
["no #spaceFiller; distribute regularly"
"centering == #topLeft ifTrue:[]" "add all extra space to the last cell; e.g., do nothing"
centering == #bottomRight
ifTrue:
["add all extra space to the first cell"
cell addExtraSpace: extra @ 0].
centering == #center
ifTrue:
["add 1/2 extra space to the first and last cell"
cell addExtraSpace: (extra // 2) @ 0].
centering == #justified
ifTrue:
["add extra space equally distributed to each cell"
n := cell size - 1 max: 1.
extraPerCell := extra asFloat / n asFloat.
extra := last := 0.
cell do:
[:c |
c addExtraSpace: (extra truncated - last truncated) @ 0.
extra := (last := extra) + extraPerCell]]]]]!
Item was changed:
----- Method: TableLayout>>layout:in: (in category 'layout') -----
layout: aMorph in: box
"Compute the layout for the given morph based on the new bounds"
| cells arrangement horizontal newBounds |
aMorph hasSubmorphs ifFalse: [^self].
+ properties := aMorph assureTableLayoutProperties.
- properties := aMorph assureTableProperties.
newBounds := box origin asIntegerPoint corner: box corner asIntegerPoint.
(properties wrapDirection == #none and: [properties cellSpacing == #none])
ifTrue:
["get into the fast lane"
properties listCentering == #justified
ifFalse:
["can't deal with that"
properties listDirection == #leftToRight
ifTrue: [^self layoutLeftToRight: aMorph in: newBounds].
properties listDirection == #topToBottom
ifTrue: [^self layoutTopToBottom: aMorph in: newBounds]]].
horizontal := (properties listDirection == #topToBottom
or: [properties listDirection == #bottomToTop]) not.
"Step 1: Compute the minimum extent for all the children of aMorph"
cells := self
computeCellSizes: aMorph
in: (0 @ 0 corner: newBounds extent)
horizontal: horizontal.
"Step 2: Compute the arrangement of the cells for each row and column"
arrangement := self
computeCellArrangement: cells
in: newBounds
horizontal: horizontal
target: aMorph.
"Step 3: Compute the extra spacing for each cell"
self
computeExtraSpacing: arrangement
in: newBounds
horizontal: horizontal
target: aMorph.
"Step 4: Place the children within the cells accordingly"
self
placeCells: arrangement
in: newBounds
horizontal: horizontal
target: aMorph!
Item was changed:
----- Method: TableLayout>>minExtentOf:in: (in category 'layout') -----
minExtentOf: aMorph in: box
"Return the minimal size aMorph's children would require given the new bounds"
| cells arrangement horizontal newBounds minX minY dir |
minExtentCache isNil ifFalse: [^minExtentCache].
aMorph hasSubmorphs ifFalse: [^0 @ 0].
+ properties := aMorph assureTableLayoutProperties.
- properties := aMorph assureTableProperties.
(properties wrapDirection == #none and: [properties cellSpacing == #none])
ifTrue:
["Get into the fast lane"
dir := properties listDirection.
(dir == #leftToRight or: [dir == #rightToLeft])
ifTrue: [^self minExtentHorizontal: aMorph].
(dir == #topToBottom or: [dir == #bottomToTop])
ifTrue: [^self minExtentVertical: aMorph]].
newBounds := box origin asIntegerPoint corner: box corner asIntegerPoint.
horizontal := (properties listDirection == #topToBottom
or: [properties listDirection == #bottomToTop]) not.
"Step 1: Compute the minimum extent for all the children of aMorph"
cells := self
computeCellSizes: aMorph
in: (0 @ 0 corner: newBounds extent)
horizontal: horizontal.
"Step 2: Compute the arrangement of the cells for each row and column"
arrangement := self
computeCellArrangement: cells
in: newBounds
horizontal: horizontal
target: aMorph.
"Step 3: Extract the minimum size out of the arrangement"
minX := minY := 0.
arrangement do:
[:cell |
minX := minX max: cell cellSize x + cell extraSpace x.
minY := minY + cell cellSize y + cell extraSpace y].
minExtentCache := horizontal ifTrue: [minX @ minY] ifFalse: [minY @ minX].
^minExtentCache!
Item was changed:
+ ----- Method: TableLayoutProperties>>cellGap (in category 'accessing') -----
- ----- Method: TableLayoutProperties>>cellGap (in category 'table defaults') -----
cellGap
"ifNil is just for migration of old instances."
^ cellGap ifNil: [0]!
Item was changed:
+ ----- Method: TableLayoutProperties>>cellInset (in category 'accessing') -----
- ----- Method: TableLayoutProperties>>cellInset (in category 'table defaults') -----
cellInset
^cellInset!
Item was changed:
+ ----- Method: TableLayoutProperties>>cellPositioning (in category 'accessing') -----
- ----- Method: TableLayoutProperties>>cellPositioning (in category 'table defaults') -----
cellPositioning
^cellPositioning!
Item was changed:
+ ----- Method: TableLayoutProperties>>cellSpacing (in category 'accessing') -----
- ----- Method: TableLayoutProperties>>cellSpacing (in category 'table defaults') -----
cellSpacing
^cellSpacing!
Item was added:
+ ----- Method: TableLayoutProperties>>includesTableLayoutProperties (in category 'testing') -----
+ includesTableLayoutProperties
+
+ ^ true!
Item was removed:
- ----- Method: TableLayoutProperties>>includesTableProperties (in category 'testing') -----
- includesTableProperties
- ^true!
Item was changed:
+ ----- Method: TableLayoutProperties>>layoutInset (in category 'accessing') -----
- ----- Method: TableLayoutProperties>>layoutInset (in category 'table defaults') -----
layoutInset
+
+ self flag: #todo. "mt: Move up to LayoutProperties. Maybe also #cellInset and #cellPositioning because those seem rather independent from the way cells as computed."
+ ^ layoutInset!
- ^layoutInset!
Item was changed:
----- Method: TableLayoutProperties>>layoutInset: (in category 'accessing') -----
layoutInset: aNumber
+
+ self flag: #todo. "mt: Move up to LayoutProperties. Maybe also #cellInset and #cellPositioning because those seem rather independent from the way cells as computed."
+ layoutInset := aNumber.!
- layoutInset := aNumber!
Item was changed:
+ ----- Method: TableLayoutProperties>>listCentering (in category 'accessing') -----
- ----- Method: TableLayoutProperties>>listCentering (in category 'table defaults') -----
listCentering
^listCentering!
Item was changed:
+ ----- Method: TableLayoutProperties>>listDirection (in category 'accessing') -----
- ----- Method: TableLayoutProperties>>listDirection (in category 'table defaults') -----
listDirection
^listDirection!
Item was changed:
+ ----- Method: TableLayoutProperties>>listSpacing (in category 'accessing') -----
- ----- Method: TableLayoutProperties>>listSpacing (in category 'table defaults') -----
listSpacing
^listSpacing!
Item was changed:
+ ----- Method: TableLayoutProperties>>maxCellSize (in category 'accessing') -----
- ----- Method: TableLayoutProperties>>maxCellSize (in category 'table defaults') -----
maxCellSize
^maxCellSize!
Item was changed:
+ ----- Method: TableLayoutProperties>>minCellSize (in category 'accessing') -----
- ----- Method: TableLayoutProperties>>minCellSize (in category 'table defaults') -----
minCellSize
^minCellSize!
Item was changed:
+ ----- Method: TableLayoutProperties>>reverseTableCells (in category 'accessing') -----
- ----- Method: TableLayoutProperties>>reverseTableCells (in category 'table defaults') -----
reverseTableCells
^reverseTableCells!
Item was changed:
+ ----- Method: TableLayoutProperties>>rubberBandCells (in category 'accessing') -----
- ----- Method: TableLayoutProperties>>rubberBandCells (in category 'table defaults') -----
rubberBandCells
^rubberBandCells!
Item was changed:
+ ----- Method: TableLayoutProperties>>wrapCentering (in category 'accessing') -----
- ----- Method: TableLayoutProperties>>wrapCentering (in category 'table defaults') -----
wrapCentering
^wrapCentering!
Item was changed:
+ ----- Method: TableLayoutProperties>>wrapDirection (in category 'accessing') -----
- ----- Method: TableLayoutProperties>>wrapDirection (in category 'table defaults') -----
wrapDirection
^wrapDirection!
Item was removed:
- ----- Method: Text>>asDraggableMorph (in category '*Morphic-converting') -----
- asDraggableMorph
-
- ^ self copy
- addAttribute: (TextFontReference toFont: ((self userInterfaceTheme get: #font for: #TransferMorph) ifNil: [TextStyle defaultFont]));
- asMorph!
Item was changed:
----- Method: Text>>asTextMorph (in category '*Morphic-converting') -----
asTextMorph
+ "Install the receiver in a text morph. Derive an appropriate text style from the receiver's first-character attributes (e.g., to make tabs look correct)."
+
+ ^ TextMorph new
+ contentsAsIs: self;
+ textStyle: (self fontAt: 1 withStyle: TextStyle default)
+ asNewTextStyle;
+ yourself!
- ^ TextMorph new contentsAsIs: self!
Item was changed:
----- Method: TextAnchor class>>alignmentExamples (in category 'examples') -----
alignmentExamples
"self alignmentExamples"
| anchoredMorph textMorph text demoMorph |
demoMorph := Morph new
changeTableLayout;
color: Color white;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
yourself.
#(top center bottom) do: [:morphAlignment |
#(top center baseline bottom) do: [:textAlignment |
anchoredMorph := Morph new.
anchoredMorph textAnchorProperties verticalAlignment: {morphAlignment . textAlignment}.
anchoredMorph textAnchorProperties padding: (anchoredMorph textAnchorProperties padding top: 10).
text := Text streamContents: [ :stream |
stream
+ nextPutAll: ('Here is an {1}, {2} example: ' translated format: {morphAlignment . textAlignment});
- nextPutAll: ('Here is an {1}, {2} example: ' format: {morphAlignment . textAlignment});
nextPutAll: (Text
string: Character startOfHeader asString
attributes: {TextAnchor new anchoredMorph: anchoredMorph.
TextColor color: Color transparent});
+ nextPutAll: ' with the morph in the text.' translated].
- nextPutAll: ' with the morph in the text.'].
textMorph := text asMorph.
textMorph height: 100.
demoMorph addMorph: textMorph]].
demoMorph openInWorld!
Item was changed:
Editor subclass: #TextEditor
instanceVariableNames: 'model paragraph markBlock pointBlock beginTypeInIndex emphasisHere lastParenLocation otherInterval oldInterval typeAhead history'
+ classVariableNames: 'AutoEnclose AutoIndent ChangeText EncloseSelection FindText InteractivePrintIt'
- classVariableNames: 'AutoEnclose AutoIndent ChangeText EncloseSelection FindText'
poolDictionaries: ''
category: 'Morphic-Text Support'!
TextEditor class
instanceVariableNames: 'cmdActions shiftCmdActions yellowButtonMenu shiftedYellowButtonMenu'!
!TextEditor commentStamp: '<historical>' prior: 0!
See comment in Editor.
My instances edit Text, this is, they support multiple lines and TextAttributes.
They have no specific facilities for editing Smalltalk code. Those are found in SmalltalkEditor.!
TextEditor class
instanceVariableNames: 'cmdActions shiftCmdActions yellowButtonMenu shiftedYellowButtonMenu'!
Item was changed:
----- Method: TextEditor class>>autoEnclose (in category 'preferences') -----
autoEnclose
<preference: 'Auto enclose brackets () {} []'
categoryList: #('Morphic' 'editing')
description: 'When true, typing an opening parenthesis, bracket or square-bracket will also add its corresponding closing character after the cursor so you can type within the bracket.'
type: #Boolean>
+ ^ AutoEnclose ifNil: [ true ]!
- ^ AutoEnclose ifNil: [ false ]!
Item was changed:
----- Method: TextEditor class>>encloseSelection (in category 'preferences') -----
encloseSelection
<preference: 'Enclose selection with brackets () {} [] '''' "" || <>'
categoryList: #('Morphic' 'editing')
description: 'When true, selecting text and typing an opening parenthesis, bracket, square-bracket, single quote, or double quote will add corresponding character around the selection without requiring a cmd key.'
type: #Boolean>
+ ^ EncloseSelection ifNil: [ true ]!
- ^ EncloseSelection ifNil: [ false ]!
Item was changed:
----- Method: TextEditor class>>initializeCmdKeyShortcuts (in category 'keyboard shortcut tables') -----
initializeCmdKeyShortcuts
"Initialize the (unshifted) command-key (or alt-key) shortcut table."
"NOTE: if you don't know what your keyboard generates, use Sensor kbdTest"
"TextEditor initialize"
| cmdMap cmds |
cmdMap := Array new: 256 withAll: #noop:. "use temp in case of a crash"
cmdMap at: 1 + 1 put: #cursorHome:. "home key"
cmdMap at: 4 + 1 put: #cursorEnd:. "end key"
cmdMap at: 8 + 1 put: #backspace:. "ctrl-H or delete key"
cmdMap at: 11 + 1 put: #cursorPageUp:. "page up key"
cmdMap at: 12 + 1 put: #cursorPageDown:. "page down key"
cmdMap at: 13 + 1 put: #crWithIndent:. "cmd-Return"
cmdMap at: 27 + 1 put: #offerMenuFromEsc:. "escape key"
cmdMap at: 28 + 1 put: #cursorLeft:. "left arrow key"
cmdMap at: 29 + 1 put: #cursorRight:. "right arrow key"
cmdMap at: 30 + 1 put: #cursorUp:. "up arrow key"
cmdMap at: 31 + 1 put: #cursorDown:. "down arrow key"
cmdMap at: 32 + 1 put: #selectWord:. "space bar key"
cmdMap at: 127 + 1 put: #forwardDelete:. "del key"
+ '0123456789'
- '0123456789-='
do: [:char | cmdMap at: char asciiValue + 1 put: #changeEmphasis:].
-
- '([<{|"''' do: [:char | cmdMap at: char asciiValue + 1 put: #enclose:].
cmds := #($a #selectAll: $c #copySelection: $e #exchange: $f #find: $g #findAgain: $j #doAgain: $k #offerFontMenu: $u #align: $v #paste: $w #backWord: $x #cut: $y #swapChars: $z #undo:).
1 to: cmds size
by: 2
do: [:i | cmdMap at: (cmds at: i) asciiValue + 1 put: (cmds at: i + 1)].
cmdActions := cmdMap!
Item was changed:
----- Method: TextEditor class>>initializeShiftCmdKeyShortcuts (in category 'keyboard shortcut tables') -----
initializeShiftCmdKeyShortcuts
"Initialize the shift-command-key (or control-key) shortcut table."
"NOTE: if you don't know what your keyboard generates, use Sensor kbdTest"
"wod 11/3/1998: Fix setting of cmdMap for shifted keys to actually use the
capitalized versions of the letters.
TPR 2/18/99: add the plain ascii values back in for those VMs that don't return the shifted values."
"TextEditor initialize"
| cmdMap cmds |
"shift-command and control shortcuts"
cmdMap := Array new: 256 withAll: #noop:. "use temp in case of a crash"
cmdMap at: ( 1 + 1) put: #cursorHome:. "home key"
cmdMap at: ( 4 + 1) put: #cursorEnd:. "end key"
cmdMap at: ( 8 + 1) put: #forwardDelete:. "ctrl-H or delete key"
cmdMap at: (11 + 1) put: #cursorPageUp:. "page up key"
cmdMap at: (12 + 1) put: #cursorPageDown:. "page down key"
cmdMap at: (13 + 1) put: #crWithIndent:. "ctrl-Return"
cmdMap at: (27 + 1) put: #offerMenuFromEsc:. "escape key"
cmdMap at: (28 + 1) put: #cursorLeft:. "left arrow key"
cmdMap at: (29 + 1) put: #cursorRight:. "right arrow key"
cmdMap at: (30 + 1) put: #cursorUp:. "up arrow key"
cmdMap at: (31 + 1) put: #cursorDown:. "down arrow key"
cmdMap at: (32 + 1) put: #selectWord:. "space bar key"
cmdMap at: (45 + 1) put: #changeEmphasis:. "cmd-sh-minus"
cmdMap at: (61 + 1) put: #changeEmphasis:. "cmd-sh-plus"
cmdMap at: (127 + 1) put: #forwardDelete:. "del key"
- "On some keyboards, these characters require a shift"
- '([<{|"''9' do: [:char | cmdMap at: char asciiValue + 1 put: #enclose:].
-
- "NB: sw 12/9/2001 commented out the idiosyncratic line just below, which was grabbing shift-esc in the text editor and hence which argued with the wish to have shift-esc be a universal gesture for escaping the local context and calling up the desktop menu."
- "cmdMap at: (27 + 1) put: #shiftEnclose:." "ctrl-["
-
- "'""''(' do: [ :char | cmdMap at: (char asciiValue + 1) put: #enclose:]."
-
cmds := #(
$c compareToClipboard:
$h cursorTopHome:
$j doAgainUpToEnd:
$k changeStyle:
$m selectCurrentTypeIn:
$s findAgain:
$u changeLfToCr:
$x makeLowercase:
$y makeUppercase:
$z redo: "makeCapitalized:"
).
1 to: cmds size by: 2 do: [ :i |
cmdMap at: ((cmds at: i) asciiValue + 1) put: (cmds at: i + 1). "plain keys"
cmdMap at: ((cmds at: i) asciiValue - 32 + 1) put: (cmds at: i + 1). "shifted keys"
cmdMap at: ((cmds at: i) asciiValue - 96 + 1) put: (cmds at: i + 1). "ctrl keys"
].
shiftCmdActions := cmdMap!
Item was added:
+ ----- Method: TextEditor class>>interactivePrintIt (in category 'preferences') -----
+ interactivePrintIt
+ <preference: 'Interactive print-it'
+ categoryList: #('Tools' 'Morphic')
+ description: 'When true, print-it styles the inserted printString to work as interactive link to an inspector. Just click on it.'
+ type: #Boolean>
+
+ ^ InteractivePrintIt ifNil: [ true ]!
Item was added:
+ ----- Method: TextEditor class>>interactivePrintIt: (in category 'preferences') -----
+ interactivePrintIt: aBoolean
+
+ InteractivePrintIt := aBoolean.!
Item was changed:
----- Method: TextEditor>>afterSelectionInsertAndSelect: (in category 'new selection') -----
+ afterSelectionInsertAndSelect: aStringOrText
- afterSelectionInsertAndSelect: aString
+ self insertAndSelect: aStringOrText at: self stopIndex !
- self insertAndSelect: aString at: self stopIndex !
Item was changed:
----- Method: TextEditor>>autoEncloseFor: (in category 'typing support') -----
autoEncloseFor: typedChar
"Answer whether typeChar was handled by auto-enclosure. Caller should call normalCharacter if not."
+ | openers closers next |
- | openers closers |
openers := '([{'.
closers := ')]}'.
+ next := self string at: self startIndex ifAbsent: nil.
(closers includes: typedChar) ifTrue:
[ | pos |
+ (next isNil or: [next = typedChar]) ifFalse: [ ^ false ].
self blinkPrevParen: typedChar.
((pos := self indexOfNextNonwhitespaceCharacter) notNil and: [ (paragraph string at: pos) = typedChar ])
ifTrue:
[ self
moveCursor: [ : position | position + pos - pointBlock stringIndex + 1 ]
forward: true
select: false.
^ true ]
ifFalse: [ ^ false ] ].
(openers includes: typedChar) ifTrue:
+ [ (self hasSelection or: [next isNil or: [next isSeparator or: [closers includes: next]]]) ifFalse: [ ^ false ].
+ self
- [ self
openTypeIn;
addString: typedChar asString;
addString: (closers at: (openers indexOf: typedChar)) asString;
insertAndCloseTypeIn;
moveCursor: [ : position | position - 1 ]
forward: false
select: false.
^ true ].
^ false!
Item was changed:
----- Method: TextEditor>>browseIt (in category 'menu messages') -----
browseIt
+ "Launch a browser for the current selection, if appropriate."
- "Launch a browser for the current selection, if appropriate"
- | aSymbol anEntry maybeBrowseInstVar |
-
Preferences alternativeBrowseIt ifTrue: [^ self browseClassFromIt].
+ self lineSelectAndEmptyCheck: [^ morph flash].
- self lineSelectAndEmptyCheck: [^ self].
+ "First, try to show all accesses to instance or class variables."
+ self selectedInstanceVariable ifNotNil:
+ [:nameToClass | self systemNavigation
+ browseAllAccessesTo: nameToClass key
+ from: nameToClass value].
+ self selectedClassVariable ifNotNil:
+ [:binding | self model browseAllCallsOn: binding].
- maybeBrowseInstVar := [ | selectionString |
- selectionString := self selection asString.
- ([model selectedClass] on: Error do: [:ex|]) ifNotNil:
- [:class|
- (class allInstVarNames includes: selectionString) ifTrue:
- [self systemNavigation
- browseAllAccessesTo: selectionString
- from: (class classThatDefinesInstanceVariable: selectionString).
- ^nil]]].
+ "Then, either browse the class (from a binding) or all implementors of a selector."
+ self selectedBinding ifNotNil:
+ [:binding | ^ self systemNavigation browseClass: binding].
+ self selectedSelector ifNotNil:
+ [:selector | ^ self model browseAllImplementorsOf: selector requestor: morph].
+
+ morph flash!
- (aSymbol := self selectedSymbol) ifNil:
- [maybeBrowseInstVar value.
- ^morph flash].
-
- aSymbol first isUppercase
- ifTrue:
- [anEntry := (model environment
- valueOf: aSymbol
- ifAbsent:
- [ ([model selectedClass] on: Error do: [:ex|]) ifNotNil:
- [:class|
- (class bindingOf: aSymbol) ifNotNil: "e.g. a class var"
- [:binding|
- self systemNavigation browseAllCallsOn: binding.
- ^ nil]].
- self systemNavigation browseAllImplementorsOf: aSymbol.
- ^ nil]).
- anEntry ifNil: [^ morph flash].
- (anEntry isBehavior and: [anEntry name == aSymbol]) ifFalse: "When is this ever false?"
- [anEntry := anEntry class].
- self systemNavigation browseClass: anEntry]
- ifFalse:
- [self systemNavigation browseAllImplementorsOf: aSymbol.
- maybeBrowseInstVar value]!
Item was changed:
----- Method: TextEditor>>browseItHere (in category 'menu messages') -----
browseItHere
+ "Retarget the receiver's window to look at the selected class, if appropriate."
- "Retarget the receiver's window to look at the selected class, if appropriate. 3/1/96 sw"
- | aSymbol foundClass b |
- (((b := model) isKindOf: Browser) and: [b couldBrowseAnyClass])
- ifFalse: [^ morph flash].
- model okToChange ifFalse: [^ morph flash].
- self selectionInterval isEmpty ifTrue: [self selectWord].
- (aSymbol := self selectedSymbol) isNil ifTrue: [^ morph flash].
+ self wordSelectAndEmptyCheck: [^ morph flash].
+
+ ((model isKindOf: Browser) and: [model couldBrowseAnyClass])
+ ifFalse: [^ morph flash].
+ model okToChange
+ ifFalse: [^ morph flash].
+
+ self selectedSymbol ifNotNil: [:symbol |
+ (model environment classNamed: symbol) ifNotNil: [:class |
+ ^ model setClass: class]].
+
+ morph flash!
- foundClass := (Smalltalk at: aSymbol ifAbsent: [nil]).
- foundClass isNil ifTrue: [^ morph flash].
- (foundClass isKindOf: Class)
- ifTrue:
- [model selectSystemCategory: foundClass category.
- model classListIndex: (model classList indexOf: foundClass name)]!
Item was changed:
----- Method: TextEditor>>cancel (in category 'menu messages') -----
cancel
+ "Cancel the changes made so far to this text in a safe way, so that the user can undo this operation."
+
+ morph cancelEditsSafely.!
- "Cancel the changes made so far to this text"
- morph cancelEdits!
Item was changed:
----- Method: TextEditor>>changeEmphasis: (in category 'editing keys') -----
changeEmphasis: aKeyboardEvent
"Change the emphasis of the current selection or prepare to accept characters with the change in emphasis. Emphasis change amounts to a font change. Keeps typeahead."
+ "[cmd]+[0..9]"
- "control 0..9 -> 0..9"
| keyCode attribute oldAttributes index thisSel colors extras |
+ keyCode := ('0123456789' indexOf: aKeyboardEvent keyCharacter ifAbsent: [1]) - 1.
- keyCode := ('0123456789-=' indexOf: aKeyboardEvent keyCharacter ifAbsent: [1]) - 1.
oldAttributes := paragraph text attributesAt: self pointIndex.
thisSel := self selection.
+ "mt: Index-based font changes are not compatible with variable point sizes in text styles. Make room for other shortcuts.
+ (keyCode between: 1 and: 5) ifTrue: [attribute := TextFontChange fontNumber: keyCode]."
- "Decipher keyCodes for Command 0-9..."
- (keyCode between: 1 and: 5)
- ifTrue: [attribute := TextFontChange fontNumber: keyCode].
+ keyCode = 5
- keyCode = 6
ifTrue: [
colors := #(#black #magenta #red #yellow #green #blue #cyan #white).
extras := self emphasisExtras.
+ index := Project uiManager chooseFrom: colors , #('choose color...' ), extras.
- index := UIManager default chooseFrom:colors , #('choose color...' ), extras
- lines: (Array with: colors size + 1).
index = 0 ifTrue: [^true].
index <= colors size
ifTrue: [attribute := TextColor color: (Color perform: (colors at: index))]
ifFalse: [
index := index - colors size - 1. "Re-number!!!!!!"
index = 0
ifTrue: [attribute := self chooseColor]
ifFalse:[^self handleEmphasisExtra: index with: aKeyboardEvent] "handle an extra"]].
+ (keyCode between: 6 and: 9)
- (keyCode between: 7 and: 11)
ifTrue: [
aKeyboardEvent shiftPressed
+ ifTrue: [ "Cannot be reached bc. method entry is #keyCharacter based and thus dependent on keyboard layout."
+ keyCode = 6 ifTrue: [attribute := TextKern kern: -1].
+ keyCode = 7 ifTrue: [attribute := TextKern kern: 1]]
- ifTrue: [
- keyCode = 10 ifTrue: [attribute := TextKern kern: -1].
- keyCode = 11 ifTrue: [attribute := TextKern kern: 1]]
ifFalse: [
+ attribute := TextEmphasis
+ "And remember this: nine is fine for underline, obliter-eight it as you see fit, seven has been bold for ever'n, which leaves six as the obivous fix to emphasize your poetics."
+ perform: (#(italic bold struckOut underlined) at: keyCode - 5).
+ oldAttributes
- attribute := TextEmphasis
- perform: (#(#bold #italic #narrow #underlined #struckOut) at: keyCode - 6).
- oldAttributes
do: [:att | (att dominates: attribute) ifTrue: [attribute turnOff]]]].
keyCode = 0 ifTrue: [attribute := TextEmphasis normal].
attribute ifNotNil: [
thisSel size = 0
ifTrue: [
"only change emphasisHere while typing"
self insertTypeAhead.
emphasisHere := Text addAttribute: attribute toArray: oldAttributes ]
ifFalse: [
self replaceSelectionWith: (thisSel asText addAttribute: attribute) ]].
^true!
Item was changed:
----- Method: TextEditor>>changeEmphasisOrAlignment (in category 'attributes') -----
changeEmphasisOrAlignment
| aList reply code align menuList startIndex |
startIndex := self startIndex.
aList := #(normal bold italic narrow underlined struckOut leftFlush centered rightFlush justified).
align := paragraph text alignmentAt: startIndex
ifAbsent: [ paragraph textStyle alignment ].
code := paragraph text emphasisAt: startIndex.
menuList := WriteStream on: Array new.
menuList nextPut: (code isZero ifTrue:['<on>'] ifFalse:['<off>']), 'normal' translated.
menuList nextPutAll: (#(bold italic underlined struckOut) collect:[:emph|
(code anyMask: (TextEmphasis perform: emph) emphasisCode)
ifTrue: [ '<on>', emph asString translated ]
ifFalse: [ '<off>',emph asString translated ]]).
((paragraph text attributesAt: startIndex)
anySatisfy: [ :attr | attr isKern and: [attr kern < 0 ]])
ifTrue: [ menuList nextPut:'<on>', 'narrow' translated ]
ifFalse: [ menuList nextPut:'<off>', 'narrow' translated ].
+ menuList nextPutAll: (#(leftFlush centered rightFlush justified) withIndexCollect: [ :type :i |
- menuList nextPutAll: (#(leftFlush centered rightFlush justified) collectWithIndex: [ :type :i |
align = (i-1)
ifTrue: [ '<on>',type asString translated ]
ifFalse: [ '<off>',type asString translated ]]).
aList := #(normal bold italic underlined struckOut narrow leftFlush centered rightFlush justified).
reply := UIManager default chooseFrom: menuList contents values: aList lines: #(1 6).
reply notNil ifTrue: [
(#(leftFlush centered rightFlush justified) includes: reply)
ifTrue: [
self setAlignment: reply.
paragraph composeAll.
self recomputeSelection]
ifFalse: [
self setEmphasis: reply.
paragraph composeAll.
self recomputeSelection]].
^ true!
Item was changed:
----- Method: TextEditor>>changeSelectionFontTo: (in category 'attributes') -----
changeSelectionFontTo: aFont
| attr |
aFont ifNil: [ ^ self ].
attr := TextFontReference toFont: aFont.
self openTypeIn.
paragraph text
addAttribute: attr
+ from: (self hasSelection
+ ifTrue: [ self startIndex ]
+ ifFalse: [ 1 ])
- from: self startIndex
to:
(self hasSelection
ifTrue: [ self stopIndex - 1 min: paragraph text size ]
ifFalse: [ paragraph text size ]).
self closeTypeIn.
paragraph composeAll.
self recomputeSelection.
morph changed!
Item was changed:
----- Method: TextEditor>>changeStyle (in category 'attributes') -----
changeStyle
"Let user change styles for the current text pane."
- | names reply style current menuList |
+ | known knownTTCStyles knownLegacyStyles defaultStyles
+ newStyle current currentName menuList |
+ current := morph textStyle.
+ currentName := current defaultFamilyName.
+
+ knownTTCStyles := ((TextStyle actualTextStyles
+ select: [:ea | ea isTTCStyle
+ "No aliased text styles here..."
+ and: [(TextStyle named: ea defaultFamilyName) == ea]])
+ sorted: [:a :b | a defaultFamilyName <= b defaultFamilyName])
+ collect: [:ea | ea defaultFamilyName -> ea] as: OrderedDictionary.
+ knownLegacyStyles := ((TextStyle actualTextStyles reject: [:ea | ea isTTCStyle])
+ sorted: [:a :b | a defaultFamilyName <= b defaultFamilyName])
+ collect: [:ea | ea defaultFamilyName -> ea] as: OrderedDictionary.
+ defaultStyles := ((TextStyle defaultFamilyNames
+ collect: [:ea | ea -> (TextStyle named: ea)] as: OrderedDictionary)
+ reject: [:ea | ea isNil "undefined default styles"])
+ sorted: [:a :b | a key <= b key].
+
+ known := defaultStyles, {'---' -> nil}, knownTTCStyles, {'--- ' -> nil}, knownLegacyStyles.
+ menuList := Array streamContents: [:s |
+ known keysAndValuesDo: [ :knownName :knownStyle |
+ s nextPut: (((knownStyle notNil and: [knownStyle defaultFamilyName = currentName])
+ ifTrue: [ (' > ', knownName, ' (current)' translated) asText ]
+ ifFalse: [ knownName asText ]) addAttribute: (TextFontReference toFont: (knownStyle ifNil: [TextStyle default])defaultFont); yourself)]].
+ known := known values.
+ newStyle := Project uiManager chooseFrom: menuList values: known.
+ newStyle ifNotNil: [morph textStyle: newStyle copy].
- current := paragraph textStyle.
- names := TextStyle knownTextStyles.
- menuList := names collect: [ :styleName |
- styleName = current name
- ifTrue: [ '<on>', styleName ]
- ifFalse: [ '<off>', styleName ]].
- reply := UIManager default chooseFrom: menuList values: names.
- reply ifNotNil: [
- (style := TextStyle named: reply) ifNil: [Beeper beep. ^ true].
- paragraph textStyle: style.
- paragraph composeAll.
- self recomputeSelection].
^ true!
Item was changed:
----- Method: TextEditor>>closeTypeIn (in category 'typing support') -----
closeTypeIn
"See comment in openTypeIn. It is important to call closeTypeIn before executing
any non-typing key, making a new selection, etc. It is called automatically for
menu commands."
+ | begin start stop |
+ beginTypeInIndex ifNotNil:
+ [begin := beginTypeInIndex.
- | begin stop |
- beginTypeInIndex ifNotNil: [
- begin := beginTypeInIndex.
stop := self stopIndex.
+ start := self startIndex.
+ self history ifNotNil:
+ [:myHistory|
+ myHistory current
+ contentsAfter: (stop <= begin
+ ifTrue: [self nullText]
+ ifFalse: [paragraph text copyFrom: begin to: stop-1]);
+ intervalAfter: (start to: stop-1);
+ intervalBetween: (stop < begin
+ ifTrue: [stop to: stop-1]
+ ifFalse: [begin to: stop-1]);
+ messageToUndo: (Message selector: #undoAndReselect);
+ messageToRedo: (Message selector: #redoAndReselect).
+
+ myHistory finishRemember].
- self history current
- contentsAfter: (stop <= begin
- ifTrue: [self nullText]
- ifFalse: [paragraph text copyFrom: begin to: stop-1]);
- intervalAfter: (stop to: stop-1);
- intervalBetween: (stop < begin
- ifTrue: [stop to: stop-1]
- ifFalse: [begin to: stop-1]);
- messageToUndo: (Message selector: #undoAndReselect);
- messageToRedo: (Message selector: #redoAndReselect).
-
- self history finishRemember.
beginTypeInIndex := nil]!
Item was added:
+ ----- Method: TextEditor>>copyHtml (in category 'menu messages') -----
+ copyHtml
+ "Copy the paragraph as HTML representation and store it in the paste buffer."
+
+ self clipboardTextPut: self text printHtmlString.!
Item was added:
+ ----- Method: TextEditor>>copyHtmlSelection (in category 'menu messages') -----
+ copyHtmlSelection
+ "Copy the current selection as HTML representation and store it in the paste buffer, unless a caret."
+
+ self lineSelectAndEmptyCheck: [^ self].
+ self clipboardTextPut: self selection printHtmlString.!
Item was changed:
----- Method: TextEditor>>correctFrom:to:with: (in category 'new selection') -----
correctFrom: start to: stop with: aString
"Make a correction in the model that the user has authorised from somewhere else in the system (such as from the compilier). The user's selection is not changed, only corrected."
+ | userSelection delta loc |
- | userSelection delta loc wasShowing |
aString = '#insert period' ifTrue: [
loc := start.
[(loc := loc-1)>0 and: [(paragraph string at: loc) isSeparator]]
whileTrue: [loc := loc-1].
^ self correctFrom: loc+1 to: loc with: '.'].
- (wasShowing := selectionShowing) ifTrue: [ self reverseSelection ].
userSelection := self selectionInterval.
self selectInvisiblyFrom: start to: stop.
self replaceSelectionWith: aString.
delta := aString size - (stop - start + 1).
self
selectInvisiblyFrom: userSelection first + (userSelection first > start ifFalse: [ 0 ] ifTrue: [ delta ])
+ to: userSelection last + (userSelection last > start ifFalse: [ 0 ] ifTrue: [ delta ]).!
- to: userSelection last + (userSelection last > start ifFalse: [ 0 ] ifTrue: [ delta ]).
- wasShowing ifTrue: [ self reverseSelection ].
- !
Item was changed:
----- Method: TextEditor>>enclose: (in category 'editing keys') -----
enclose: aKeyboardEvent
"Insert or remove bracket characters around the current selection."
+ | character left right startIndex stopIndex oldSelection which closingBracket t |
+ character := aKeyboardEvent keyCharacter.
- | character left right startIndex stopIndex oldSelection which t |
- character := aKeyboardEvent shiftPressed
- ifTrue: ['{}|"<>' at: ('[]\'',.' indexOf: aKeyboardEvent keyCharacter) ifAbsent: [aKeyboardEvent keyCharacter]]
- ifFalse: [aKeyboardEvent keyCharacter].
self closeTypeIn.
startIndex := self startIndex.
stopIndex := self stopIndex.
oldSelection := self selection.
+ closingBracket := false.
+ which := '([<{|"''' indexOf: character ifAbsent: [
+ closingBracket := true.
+ ')]>}|"''' indexOf: character ifAbsent: [ ^ false ]].
+ left := '([<{|"''' at: which.
+ right := ')]>}|"''' at: which.
- which := '([<{|"''9' indexOf: character ifAbsent: [ ^ false ].
- "Allow Control key in lieu of Alt+Shift for (, {, and double-quote."
- left := ((Preferences cmdKeysInText and: [ aKeyboardEvent controlKeyPressed ])
- ifTrue: [ '({<{|""(' ]
- ifFalse: ['([<{|"''(']) at: which.
- right := ((Preferences cmdKeysInText and: [ aKeyboardEvent controlKeyPressed ])
- ifTrue: [ ')}>}|"")' ]
- ifFalse: [')]>}|"'')']) at: which.
t := self text.
((startIndex > 1 and: [stopIndex <= t size])
+ and: [ (t at: startIndex-1) = left and: [(t at: stopIndex) = right]]
+ and: [ closingBracket or: [left = right] ])
- and: [ (t at: startIndex-1) = left and: [(t at: stopIndex) = right]])
ifTrue:
+ ["already enclosed and character is a closing bracket; strip off brackets"
- ["already enclosed; strip off brackets"
self selectFrom: startIndex-1 to: stopIndex.
self replaceSelectionWith: oldSelection]
ifFalse:
+ ["not enclosed or character is an opening bracket; enclose by matching brackets"
+ closingBracket ifTrue: [ ^ false ] ifFalse:
+ [ self replaceSelectionWith:
- ["not enclosed; enclose by matching brackets"
- self replaceSelectionWith:
(Text string: (String with: left), oldSelection string, (String with: right) attributes: emphasisHere).
+ self selectFrom: startIndex+1 to: stopIndex] ].
- self selectFrom: startIndex+1 to: stopIndex].
^true!
Item was changed:
----- Method: TextEditor>>evaluateSelectionAndDo: (in category 'do-its') -----
evaluateSelectionAndDo: aBlock
"Treat the current selection as an expression; evaluate it and invoke aBlock with the result."
| result rcvr ctxt |
self lineSelectAndEmptyCheck: [^ nil].
+
+ (model respondsTo: #evaluateExpression:requestor:) ifTrue: [
+ ^ aBlock value: (model perform: #evaluateExpression:requestor: with: self selection with: self)].
-
(model respondsTo: #evaluateExpression:) ifTrue: [
^ aBlock value: (model perform: #evaluateExpression: with: self selection)].
+
-
(model respondsTo: #doItReceiver)
ifTrue: [ rcvr := model doItReceiver.
ctxt := model doItContext]
ifFalse: [rcvr := ctxt := nil].
result := [
rcvr class evaluatorClass new
evaluate: self selectionAsStream
in: ctxt
to: rcvr
environment: (model environment ifNil: [Smalltalk globals])
notifying: self
+ ifFail: [self flash. ^ nil]
- ifFail: [morph flash. ^ nil]
logged: true.
]
on: OutOfScopeNotification
do: [ :ex | ex resume: true].
(model respondsTo: #expressionEvaluated:result:) ifTrue: [
model perform: #expressionEvaluated:result: with: self selection with: result].
^aBlock value: result!
Item was changed:
----- Method: TextEditor>>explainAnySel: (in category 'explain') -----
explainAnySel: symbol
"Is this any message selector?"
| list reply |
list := self systemNavigation allClassesImplementing: symbol.
list size = 0 ifTrue: [^nil].
list size < 12
+ ifTrue: [reply := ' is a message selector which is defined in these classes: ' , list asArray printString]
- ifTrue: [reply := ' is a message selector which is defined in these classes ' , list printString]
ifFalse: [reply := ' is a message selector which is defined in many classes'].
^'"' , symbol , reply , '."' , '\' withCRs, 'SystemNavigation new browseAllImplementorsOf: #' , symbol!
Item was changed:
----- Method: TextEditor>>find (in category 'menu messages') -----
find
"Prompt the user for a string to search for, and search the receiver from the current selection onward for it. 1/26/96 sw"
self setSearchFromSelectionOrHistory.
+ (Project uiManager request: 'Find what to select?' translated initialAnswer: FindText)
- (UIManager default request: 'Find what to select? ' initialAnswer: FindText)
ifEmpty: [^ self]
ifNotEmpty: [:reply |
FindText := reply.
self findAgainNow].!
Item was changed:
----- Method: TextEditor>>findReplace (in category 'menu messages') -----
findReplace
self
setSearchFromSelectionOrHistory;
setReplacementFromHistory.
+ (Project uiManager
+ request: 'Find what to replace?' translated
+ initialAnswer: FindText)
+ ifNotEmpty: [:find |
+
+ (Project uiManager
+ request: ('Replace ''{1}'' with?' translated format: {find})
+ initialAnswer: (ChangeText ifEmpty: [find])
+ onCancelReturn: nil)
+ ifNotNil: [:replace |
+
+ FindText := find.
+ ChangeText := replace.
+ self findReplaceAgainNow]]!
- (UIManager default request: 'Find what to replace?' initialAnswer: FindText)
- ifEmpty: [^ self]
- ifNotEmpty: [:find |
- (UIManager default request: ('Replace ''{1}'' with?' format: {find}) initialAnswer: (ChangeText ifEmpty: [find]))
- ifEmpty: [^ self]
- ifNotEmpty: [:replace |
- FindText := find.
- ChangeText := replace.
- self findReplaceAgainNow]]!
Item was changed:
----- Method: TextEditor>>hasMultipleLinesSelected (in category 'typing support') -----
hasMultipleLinesSelected
+ ^ self selection includesAnyOf: CharacterSet crlf!
-
- ^ self hasSelection and: [self startBlock top < self stopBlock top]!
Item was changed:
----- Method: TextEditor>>implementorsOfIt (in category 'menu messages') -----
implementorsOfIt
"Open an implementors browser on the selected selector"
+
- | aSelector |
self lineSelectAndEmptyCheck: [^ self].
+ self selectedSelector ifNotNil:
+ [:aSelector| ^self model browseAllImplementorsOf: aSelector requestor: morph].
+ self selectedLiteral ifNotNil:
+ [:aLiteral| ^self model browseAllImplementorsOf: aLiteral requestor: morph].
+ morph flash.!
- (aSelector := self selectedSelector) == nil ifTrue: [^ morph flash].
- model browseAllImplementorsOf: aSelector!
Item was changed:
----- Method: TextEditor>>insertAndSelect:at: (in category 'new selection') -----
+ insertAndSelect: aStringOrText at: anInteger
- insertAndSelect: aString at: anInteger
+ | spacer |
self closeTypeIn.
-
self selectInvisiblyFrom: anInteger to: anInteger - 1.
self openTypeIn.
+ spacer := Text string: ' ' attributes: emphasisHere.
+
self
replace: self selectionInterval
+ with: (aStringOrText isString
+ ifTrue: [spacer, (Text string: aStringOrText attributes: emphasisHere)]
+ ifFalse: [spacer, aStringOrText, spacer "Extra spacer for type-in after insertion with current emphasis."])
- with: (Text string: (' ', aString) attributes: emphasisHere)
and: [].
-
self closeTypeIn.!
Item was changed:
----- Method: TextEditor>>inspectIt (in category 'do-its') -----
inspectIt
self evaluateSelectionAndDo: [:result |
(model respondsTo: #inspectIt:result:)
ifTrue: [model
perform: #inspectIt:result:
with: self selection
with: result]
+ ifFalse: [ToolSet inspect: result]].!
- ifFalse: [result inspect]].!
Item was changed:
----- Method: TextEditor>>keyStroke: (in category 'events') -----
keyStroke: anEvent
+ self resetTypeAhead.
- self resetTypeAhead; deselect.
(self dispatchOnKeyboardEvent: anEvent)
ifTrue: [
self closeTypeIn.
self storeSelectionInParagraph.
^self].
self openTypeIn.
self
zapSelectionWith: self typeAhead contents;
resetTypeAhead;
unselect;
storeSelectionInParagraph.!
Item was removed:
- ----- Method: TextEditor>>lineSelectAndEmptyCheck: (in category 'new selection') -----
- lineSelectAndEmptyCheck: returnBlock
- "If the current selection is an insertion point, expand it to be the entire current line; if after that's done the selection is still empty, then evaluate the returnBlock, which will typically consist of '[^ self]' in the caller -- check senders of this method to understand this."
-
- self selectLine. "if current selection is an insertion point, then first select the entire line in which occurs before proceeding"
- self hasSelection ifFalse: [morph flash. ^ returnBlock value]!
Item was added:
+ ----- Method: TextEditor>>makeProjectLink (in category 'menu commands') -----
+ makeProjectLink
+ | attribute thisSel |
+
+ thisSel := self selection.
+
+ attribute := TextSqkProjectLink new.
+ thisSel := attribute analyze: self selection asString.
+
+ thisSel ifNil: [^ true].
+ self replaceSelectionWith: (thisSel asText addAttribute: attribute).
+ ^ true!
Item was changed:
----- Method: TextEditor>>mouseDown: (in category 'events') -----
mouseDown: evt
"Either 1) handle text actions in the paragraph, 2) begin a text drag operation, or 3) modify the caret/selection."
| clickPoint b |
oldInterval := self selectionInterval.
clickPoint := evt cursorPoint.
b := paragraph characterBlockAtPoint: clickPoint.
(paragraph clickAt: clickPoint for: model controller: self) ifTrue: [
+ self flag: #note. "mt: Do not reset the current text selection for successful text actions. Leave markBlock and pointBlock as is. This behavior matches the one in web browsers when clicking on links."
- markBlock := b.
- pointBlock := b.
evt hand releaseKeyboardFocus: morph.
evt hand releaseMouseFocus: morph.
^ self ].
(morph dragEnabled and: [self isEventInSelection: evt]) ifTrue: [
evt hand
waitForClicksOrDrag: morph
event: evt
selectors: {#click:. nil. nil. #startDrag:}
threshold: HandMorph dragThreshold.
morph setProperty: #waitingForTextDrag toValue: true.
^ self].
evt shiftPressed
ifFalse: [
self closeTypeIn.
markBlock := b.
pointBlock := b ]
ifTrue: [
self closeTypeIn.
self mouseMove: evt ].
self storeSelectionInParagraph!
Item was changed:
----- Method: TextEditor>>offerMenuFromEsc: (in category 'menu commands') -----
offerMenuFromEsc: aKeyboardEvent
+ "The escape key was hit while the receiver has the keyboard focus; take action."
- "The escape key was hit while the receiver has the keyboard focus; take action"
+ aKeyboardEvent shiftPressed ifFalse: [
+ self raiseContextMenu: aKeyboardEvent].
+ ^ true!
- ActiveEvent shiftPressed ifFalse: [
- self raiseContextMenu: aKeyboardEvent ].
- ^true!
Item was changed:
----- Method: TextEditor>>openTypeInFor: (in category 'typing support') -----
openTypeInFor: editType
"Set up UndoSelection to null text (to be added to by readKeyboard and backTo:),
beginTypeInBlock to keep track of the leftmost backspace, and UndoParameter to tally
how many deleted characters were backspaced over rather than 'cut'.
You can't undo typing until after closeTypeIn."
+ beginTypeInIndex ifNil:
+ [beginTypeInIndex := self startIndex.
+ self history ifNotNil:
+ [:myHistory|
+ myHistory beginRemember:
+ (TextEditorCommand new
+ type: editType;
+ contentsBefore: (self hasSelection ifTrue: [self selection] ifFalse: [self nullText]);
+ intervalBefore: (beginTypeInIndex to: self stopIndex-1)
+ yourself)]]!
- beginTypeInIndex ifNil: [
- beginTypeInIndex := self startIndex.
- self history beginRemember: (TextEditorCommand new
- type: editType;
- contentsBefore: (self hasSelection ifTrue: [self selection] ifFalse: [self nullText]);
- intervalBefore: (beginTypeInIndex to: self stopIndex-1)
- yourself)].!
Item was changed:
----- Method: TextEditor>>prettyPrint: (in category 'menu messages') -----
prettyPrint: decorated
"Reformat the contents of the receiver's view (a Browser or Workspace)."
model selectedClassOrMetaClass
ifNil: [ "arbitrary text selection in a workspace, not directly associated with a class"
(Compiler new formatNoPattern: self selection environment: model environment)
+ ifNotNil: [:newText | self replaceSelectionWith: newText]]
- ifNotNilDo: [:newText | self replaceSelectionWith: newText]]
ifNotNil: [:selectedClass | "source for a method in the selected class"
(selectedClass newCompiler
format: self text
in: selectedClass
notifying: self
decorated: decorated)
+ ifNotNil: [ :newText |
+ self selectInvisiblyFrom: 1 to: paragraph text size.
- ifNotNilDo: [ :newText |
- self deselect; selectInvisiblyFrom: 1 to: paragraph text size.
self replaceSelectionWith: (selectedClass ifNil: [newText] ifNotNil: [newText asText makeSelectorBoldIn: selectedClass]).
self selectAt: self text size + 1 ]].
!
Item was changed:
----- Method: TextEditor>>printIt (in category 'do-its') -----
printIt
self evaluateSelectionAndDo: [:result |
(model respondsTo: #printIt:result:)
ifTrue: [model
perform: #printIt:result:
with: self selection
with: result]
+ ifFalse: [self afterSelectionInsertAndSelect: (self printItTextFor: result)]]!
- ifFalse: [self afterSelectionInsertAndSelect: result printString]]!
Item was added:
+ ----- Method: TextEditor>>printItTextFor: (in category 'do-its') -----
+ printItTextFor: anObject
+
+ self flag: #todo. "mt: Maybe reserve highlights for non-primitive structures only? Maybe skip ByteString, ByteSymbol, Number, Boolean, UndefinedObject? See discussion here: http://forum.world.st/The-Inbox-Morphic-ct-1586-mcz-tp5106774p5129065.html"
+
+ ^ self class interactivePrintIt
+ ifFalse: [anObject printString]
+ ifTrue: [Text string: anObject printString attribute: (TextInspectIt on: anObject)]!
Item was changed:
----- Method: TextEditor>>referencesToIt (in category 'menu messages') -----
referencesToIt
"Open a MessageSet with the references to the selected global or variable name."
+
+ self wordSelectAndEmptyCheck: [^ self].
+ self selectedInstanceVariable ifNotNil:
+ [:nameToClass | ^ self systemNavigation
+ browseAllAccessesTo: nameToClass key
+ from: nameToClass value].
+ self selectedBinding ifNotNil:
+ [:binding | ^ self systemNavigation browseAllCallsOnClass: binding].
+ morph flash.!
- | selection environment binding |
- self selection isEmpty ifTrue: [ self selectWord ].
- environment := (model respondsTo: #selectedClassOrMetaClass)
- ifTrue: [ model selectedClassOrMetaClass ifNil: [ model environment ] ]
- ifFalse: [ model environment ].
- selection := self selectedSymbol ifNil: [ self selection asString ].
- (environment isBehavior and:
- [ (environment
- instVarIndexFor: selection
- ifAbsent: [ 0 ]) ~= 0 ]) ifTrue: [ ^ self systemNavigation
- browseAllAccessesTo: selection
- from: environment ].
- selection isSymbol ifFalse: [ ^ morph flash ].
- binding := (environment bindingOf: selection) ifNil: [ ^ morph flash ].
-
- self systemNavigation browseAllCallsOnClass: binding.!
Item was changed:
----- Method: TextEditor>>replace:with:and: (in category 'undo') -----
replace: xoldInterval with: newText and: selectingBlock
"Replace the text in oldInterval with newText and execute selectingBlock to establish the new selection. Create an undoAndReselect:redoAndReselect: undoer to allow perfect undoing."
| undoInterval |
undoInterval := self selectionInterval.
+ undoInterval = xoldInterval ifFalse: [
+ self selectInvisiblyFrom: xoldInterval start to: xoldInterval stop].
- undoInterval = xoldInterval ifFalse: [self selectInterval: xoldInterval].
self zapSelectionWith: newText.
selectingBlock value.
otherInterval := self selectionInterval.!
Item was added:
+ ----- Method: TextEditor>>replaceAllWith: (in category 'undo') -----
+ replaceAllWith: aText
+ "Like #paste but replacing all contents with aText."
+
+ self closeTypeIn.
+
+ self selectInvisiblyFrom: 1 to: self text size.
+ self openTypeIn.
+ self zapSelectionWith: aText.
+ self closeTypeIn.!
Item was changed:
----- Method: TextEditor>>resetState (in category 'initialize-release') -----
resetState
"Establish the initial conditions for editing the paragraph: place caret
before first character, set the emphasis to that of the first character,
and save the paragraph for purposes of canceling."
pointBlock := markBlock := paragraph defaultCharacterBlock.
beginTypeInIndex := nil.
otherInterval := 1 to: 0.
+ self setEmphasisHere.!
- self setEmphasisHere.
- selectionShowing := false!
Item was removed:
- ----- Method: TextEditor>>reverseSelection (in category 'current selection') -----
- reverseSelection
- "Reverse the valence of the current selection highlighting."
- selectionShowing := selectionShowing not.
- paragraph reverseFrom: pointBlock to: markBlock!
Item was removed:
- ----- 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]]]].
- suggestedName ifNil: [suggestedName := labelToUse , '.text'].
- fileName := UIManager default saveFilenameRequest: 'File name?'
- initialAnswer: suggestedName.
- fileName isEmptyOrNil
- ifFalse:
- [(FileStream newFileNamed: fileName)
- nextPutAll: stringToSave;
- close]!
Item was changed:
----- Method: TextEditor>>selectFrom:to: (in category 'new selection') -----
selectFrom: start to: stop
+ self closeTypeIn.
"Select the specified characters inclusive."
self selectInvisiblyFrom: start to: stop.
- self closeTypeIn.
self storeSelectionInParagraph.
"Preserve current emphasis if selection is empty"
stop > start ifTrue: [
self setEmphasisHere ]!
Item was changed:
----- Method: TextEditor>>selectLine (in category 'new selection') -----
selectLine
"Make the receiver's selection, if it currently consists of an insertion point only, encompass the current line."
+
- self hasSelection ifTrue:[^self].
self selectInterval: (self encompassLine: self selectionInterval)!
Item was added:
+ ----- Method: TextEditor>>selectedBinding (in category 'menu messages') -----
+ selectedBinding
+ "Try to make a binding out of the current text selection. That binding can be a global or class."
+
+ ^ self selectedSymbol ifNotNil:
+ [ :symbol |
+ ((model respondsTo: #selectedClassOrMetaClass)
+ ifTrue: [ model selectedClassOrMetaClass ifNil: [ model environment ] ]
+ ifFalse: [ model environment ]) ifNotNil:
+ [ :environment | environment bindingOf: symbol ] ]!
Item was added:
+ ----- Method: TextEditor>>selectedClassVariable (in category 'menu messages') -----
+ selectedClassVariable
+ "Try to make a class-variable binding out of the current text selection."
+
+ (model respondsTo: #selectedClassOrMetaClass) ifFalse: [ ^ nil ].
+
+ ^ self selectedSymbol ifNotNil:
+ [ :symbol | model selectedClassOrMetaClass ifNotNil:
+ [ :classOrMetaClass | (classOrMetaClass theNonMetaClass allClassVarNames includes: symbol)
+ ifTrue: [ classOrMetaClass bindingOf: symbol ]
+ ifFalse: [ nil ] ] ]!
Item was added:
+ ----- Method: TextEditor>>selectedInstanceVariable (in category 'menu messages') -----
+ selectedInstanceVariable
+ "Try to make an association from an instance-variable name to the class where this variable is defined. Make the implementation robust for models that do not know about classes.
+
+ Note that inst-var names might not have symbol a representation, only via their accessors."
+
+ (model respondsTo: #selectedClassOrMetaClass) ifFalse: [ ^ nil ].
+
+ ^ self selection string ifNotNil:
+ [ :token | model selectedClassOrMetaClass ifNotNil:
+ [ :behavior |
+ (behavior instVarIndexFor: token ifAbsent: [ 0 ]) ~= 0
+ ifTrue: [ token -> behavior ]
+ ifFalse: [ nil ] ] ]!
Item was added:
+ ----- Method: TextEditor>>selectedLiteral (in category 'menu messages') -----
+ selectedLiteral
+ "Try to make a Smalltalk literal out of the current text selection."
+
+ ^ self selection string findLiteral!
Item was changed:
----- Method: TextEditor>>selectedSelector (in category 'menu messages') -----
selectedSelector
+ "Try to make a selector out of the current text selection."
+
+ ^ self selection string findSelector!
- "Try to make a selector out of the current text selection"
- ^self selection string findSelector!
Item was changed:
----- Method: TextEditor>>selectedSymbol (in category 'menu messages') -----
selectedSymbol
+ "Try to make a symbol out of the current text selection."
- "Return the currently selected symbol, or nil if none. Spaces, tabs and returns are ignored"
+ ^ self selection string findSymbol!
- | aString |
- self hasCaret ifTrue: [^ nil].
- aString := self selection string copyWithoutAll: CharacterSet separators.
- aString size = 0 ifTrue: [^ nil].
- Symbol hasInterned: aString ifTrue: [:sym | ^ sym].
-
- ^ nil!
Item was changed:
----- Method: TextEditor>>selection (in category 'accessing-selection') -----
selection
"Answer the text in the paragraph that is currently selected."
+ | result |
+ result := paragraph text copyFrom: self startIndex to: self stopIndex - 1.
+ result ifNotEmpty: [
+ result removeAttributesThat: [:attr | attr isOblivious]].
+ ^ result!
- ^paragraph text copyFrom: self startIndex to: self stopIndex - 1 !
Item was changed:
----- Method: TextEditor>>sendersOfIt (in category 'menu messages') -----
sendersOfIt
"Open a senders browser on the selected selector"
- | aSelector |
self lineSelectAndEmptyCheck: [^ self].
+ self selectedSelector ifNotNil: [:aSelector |
+ ^ self model browseAllCallsOn: aSelector requestor: morph].
+ self selectedLiteral ifNotNil: [:aLiteral |
+ ^ self model browseAllCallsOn: aLiteral requestor: morph].
+ morph flash.!
- (aSelector := self selectedSelector) == nil ifTrue: [^ morph flash].
- self systemNavigation browseAllCallsOn: aSelector!
Item was changed:
----- Method: TextEditor>>spawn (in category 'menu messages') -----
spawn
"Create and schedule a message browser for the code of the model's
selected message. Retain any edits that have not yet been accepted."
| code |
code := paragraph text string.
self cancel.
+ (model respondsTo: #spawn:)
+ ifTrue: [model spawn: code]
+ ifFalse: [Project uiManager edit: code].!
- model spawn: code.!
Item was changed:
----- Method: TextEditor>>stateArray (in category 'initialize-release') -----
stateArray
+ ^[ {ChangeText.
- ^ {ChangeText.
FindText.
history ifNil: [TextEditorCommandHistory new]. "Convert old instances"
+ self markIndex to: self pointIndex - 1.
- self selectionInterval.
self startOfTyping.
+ emphasisHere.
+ lastParenLocation}]
+ on: MessageNotUnderstood
+ do: [:ex| ex resume: nil]!
- emphasisHere}!
Item was changed:
----- Method: TextEditor>>stateArrayPut: (in category 'initialize-release') -----
stateArrayPut: stateArray
- | sel |
ChangeText := stateArray at: 1.
FindText := stateArray at: 2.
history := stateArray at: 3.
+ (stateArray at: 4) ifNotNil: [:sel| self selectFrom: sel first to: sel last].
- sel := stateArray at: 4.
- self selectFrom: sel first to: sel last.
beginTypeInIndex := stateArray at: 5.
+ emphasisHere := stateArray at: 6.
+ lastParenLocation := stateArray at: 7!
- emphasisHere := stateArray at: 6!
Item was removed:
- ----- Method: TextEditor>>systemNavigation (in category 'as yet unclassified') -----
- systemNavigation
- ^ SystemNavigation for: model environment!
Item was changed:
----- Method: TextEditor>>zapSelectionWith: (in category 'mvc compatibility') -----
zapSelectionWith: replacement
| start stop rep |
morph readOnly ifTrue: [^ self].
- self deselect.
start := self startIndex.
stop := self stopIndex.
(replacement isEmpty and: [stop > start]) ifTrue: [
"If deleting, then set emphasisHere from 1st character of the deletion"
emphasisHere := (self text attributesAt: start) select: [:att | att mayBeExtended]].
(start = stop and: [ replacement isEmpty ]) ifFalse: [
+ morph plainTextOnly
+ ifTrue: [
+ "We support TextAlignment but nothing else. Rely on emphasisHere."
+ rep := Text string: replacement asString attributes: emphasisHere ]
+ ifFalse: [ replacement isText
+ ifTrue: [ rep := replacement]
+ ifFalse: [ rep := Text string: replacement attributes: emphasisHere ] ].
+
- replacement isText
- ifTrue: [ rep := replacement]
- ifFalse: [ rep := Text string: replacement attributes: emphasisHere ].
self text replaceFrom: start to: stop - 1 with: rep.
paragraph
recomposeFrom: start
to: start + rep size - 1
delta: rep size - (stop-start).
self markIndex: start pointIndex: start + rep size.
otherInterval := self selectionInterval].
self userHasEdited " -- note text now dirty"!
Item was changed:
RectangleMorph subclass: #TextMorph
+ instanceVariableNames: 'textStyle text wrapFlag paragraph editor container predecessor successor backgroundColor margins readOnly autoFit plainTextOnly numCharactersPerLine'
- instanceVariableNames: 'textStyle text wrapFlag paragraph editor container predecessor successor backgroundColor margins readOnly autoFit'
classVariableNames: 'CaretForm DefaultEditorClass'
poolDictionaries: ''
category: 'Morphic-Basic'!
!TextMorph commentStamp: 'nice 3/24/2010 07:40' prior: 0!
TextMorphs support display of text with emphasis. They also support reasonable text-editing capabilities, as well as embedded hot links, and the ability to embed submorphs in the text.
Late in life, TextMorph was made a subclass of BorderedMorph to provide border and background color if desired. In order to keep things compatible, protocols have been redirected so that color (preferably textColor) relates to the text, and backgroundColor relates to the inner fill color.
Text display is clipped to the innerBounds of the rectangle, and text composition is normally performed within a rectangle which is innerBounds inset by the margins parameter.
If text has been embedded in another object, one can elect to fill the owner's shape, in which case the text will be laid out in the shape of the owner's shadow image (including any submorphs other than the text). One can also elect to have the text avoid occlusions, in which case it will avoid the bounds of any sibling morphs that appear in front of it. It may be necessary to update bounds in order for the text runaround to notice the presence of a new occluding shape.
The optional autoFitContents property enables the following feature: if the text contents changes, then the bounds of the morph will be adjusted to fit the minimum rectangle that encloses the text (plus any margins specified). Similarly, any attempt to change the size of the morph will be resisted if this parameter is set. Except...
If the wrapFlag parameter is true, then text will be wrapped at word boundaries based on the composition width (innerBounds insetBy: margins) width. Thus an attempt to resize the morph in autofit mode, if it changes the width, will cause the text to be recomposed with the new width, and then the bounds will be reset to the minimum enclosing rectangle. Similarly, if the text contents are changed with the wrapFlag set to true, word wrap will be performed based on the current compostion width, after which the bounds will be set (or not), based on the autoFitcontents property.
Note that fonts can only be applied to the TextMorph as a whole. While you can change the size, color, and emphasis of a subsection of the text and have it apply to only that subsection, changing the font changes the font for the entire contents of the TextMorph.
Still a TextMorph can be composed of several texts of different fonts
| font1 font2 t1 t2 tMorph|
tMorph := TextMorph new.
font1 := (TextFontReference toFont: (StrikeFont familyName: 'Atlanta' size: 22)).
font2 := (TextFontReference toFont: (StrikeFont familyName: 'Atlanta' size: 11)).
t1 := 'this is font1' asText addAttribute: font1.
t2 := ' and this is font2' asText addAttribute: font2.
tMorph contents: (t1,t2).
tMorph openInHand.
Yet to do:
Make a comprehensive control for the eyedropper, with border width and color, inner color and text color, and margin widths.!
Item was changed:
----- Method: TextMorph class>>initialize (in category 'class initialization') -----
initialize "TextMorph initialize"
"Initialize the default text editor class to use"
DefaultEditorClass := SmalltalkEditor.
"Initialize constants shared by classes associated with text display."
CaretForm := (ColorForm extent: 16@5
fromArray: #(2r001100e26 2r001100e26 2r011110e26 2r111111e26 2r110011e26)
offset: -2@0)
+ colors: (Array with: Color transparent with: (TranslucentColor r: 0.0 g: 0.0 b: 0.8 alpha: 0.2)).
- colors: (Array with: Color transparent with: Preferences textHighlightColor).
self registerInFlapsRegistry.
!
Item was changed:
+ ----- Method: TextMorph>>addMorphFront:fromWorldPosition: (in category 'submorphs - add/remove') -----
- ----- Method: TextMorph>>addMorphFront:fromWorldPosition: (in category 'submorphs-add/remove') -----
addMorphFront: aMorph fromWorldPosition: wp
"Overridden for more specific re-layout and positioning"
aMorph textAnchorProperties anchorLayout == #document
ifFalse:[^ self
anchorMorph: aMorph
at: wp
type: aMorph textAnchorProperties anchorLayout].
self addMorphFront: aMorph.
!
Item was changed:
+ ----- Method: TextMorph>>asText (in category 'converting') -----
- ----- Method: TextMorph>>asText (in category 'accessing') -----
asText
+
+ self flag: #todo. "mt: There are too many strange places were #asText is called but #text actually be accessed. Maybe change this after the release of Squeak 6.0."
+ ^ text
+
+ "Answer the receiver's text composed in a paragraph with additional line breaks. Use #text if you want to retain the original text layout."
+
+ "^ self paragraph asTextWithLineBreaks"!
- ^ text!
Item was changed:
----- Method: TextMorph>>beAllFont: (in category 'initialization') -----
beAllFont: aFont
+ "Change the receiver's default font, which is used to draw its contents. Also see commentary in #font:."
+ self font: aFont.!
- textStyle := TextStyle fontArray: (Array with: aFont).
- text ifNotNil: [text addAttribute: (TextFontReference toFont: aFont)].
- self releaseCachedState; changed!
Item was added:
+ ----- Method: TextMorph>>cancelEditsSafely (in category 'editing') -----
+ cancelEditsSafely
+ "Safe variation of #cancelEdits, where the undo history is not discarded and can thus be used to undo the cancel operation.
+ This default implementation does nothing."!
Item was added:
+ ----- Method: TextMorph>>caretColor (in category 'accessing') -----
+ caretColor
+ ^ self valueOfProperty: #caretColor ifAbsent: [Color red]!
Item was added:
+ ----- Method: TextMorph>>caretColor: (in category 'accessing') -----
+ caretColor: aColor
+ self
+ setProperty: #caretColor
+ toValue: aColor.!
Item was changed:
----- Method: TextMorph>>compositionRectangle (in category 'private') -----
compositionRectangle
+
+ | compRect minW minH |
- | compRect |
compRect := self innerBounds.
margins ifNotNil: [compRect := compRect insetBy: margins].
+ minW := self minCompositionWidth.
+ minH := self minCompositionHeight.
+ compRect width < minW ifTrue: [compRect := compRect withWidth: minW].
+ compRect height < minH ifTrue: [compRect := compRect withHeight: minH].
+ numCharactersPerLine ifNotNil: [
+ | preferredWidth |
+ preferredWidth := textStyle compositionWidthFor: numCharactersPerLine.
+ wrapFlag
+ ifTrue: [compRect := compRect withWidth: (compRect width min: preferredWidth)]
+ ifFalse: [compRect := compRect withWidth: preferredWidth]].
- compRect width < 9 ifTrue: [compRect := compRect withWidth: 9].
- compRect height < 16 ifTrue: [compRect := compRect withHeight: 16].
^ compRect!
Item was changed:
----- Method: TextMorph>>container (in category 'geometry') -----
container
"Return the container for composing this text. There are four cases:
1. container is specified as, eg, an arbitrary shape,
2. container is specified as the bound rectangle, because
this morph is linked to others,
3. container is nil, and wrap is true -- grow downward as necessary,
4. container is nil, and wrap is false -- grow in 2D as necessary."
+ container ifNil: [
+ successor ifNotNil: [^ self compositionRectangle].
+ ^ wrapFlag
+ ifTrue: [self compositionRectangle withHeight: self maximumContainerExtent y]
+ ifFalse: [
+ numCharactersPerLine
+ ifNil: [self compositionRectangle topLeft extent: self maximumContainerExtent]
+ ifNotNil: [self compositionRectangle withHeight: self maximumContainerExtent y]]].
- container ifNil:
- [successor ifNotNil: [^ self compositionRectangle].
- wrapFlag ifTrue: [^ self compositionRectangle withHeight: self maximumContainerExtent y].
- ^ self compositionRectangle topLeft extent: self maximumContainerExtent].
^ container!
Item was changed:
----- Method: TextMorph>>createParagraph (in category 'private') -----
createParagraph
self setProperty: #CreatingParagraph toValue: true.
[
self setDefaultContentsIfNil.
"...Code here to recreate the paragraph..."
paragraph := (self paragraphClass new textOwner: self owner).
paragraph wantsColumnBreaks: successor notNil.
paragraph
compose: text
+ style: textStyle
- style: textStyle copy
from: self startingIndex
in: self container.
wrapFlag ifFalse:
["Was given huge container at first... now adjust"
+ paragraph adjustRightXDownTo: self minCompositionWidth].
- paragraph adjustRightX].
paragraph focused: (self currentHand keyboardFocus == self).
+
+ paragraph
+ caretColor: self caretColor;
+ selectionColor: self selectionColor;
+ unfocusedSelectionColor: self unfocusedSelectionColor.
+
-
self fit.
] ensure: [self removeProperty: #CreatingParagraph].
^ paragraph!
Item was changed:
+ ----- Method: TextMorph>>delete (in category 'submorphs - add/remove') -----
- ----- Method: TextMorph>>delete (in category 'submorphs-add/remove') -----
delete
predecessor ifNotNil: [predecessor setSuccessor: successor].
successor ifNotNil: [successor setPredecessor: predecessor.
successor recomposeChain].
super delete!
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 |
+ self isAutoFit
+ ifTrue: "Adjust at least my height"
+ [wrapFlag
+ ifTrue: "Keep my width"
+ [ | box |
+ box := self innerBounds. "i.e, no borders"
+ margins ifNotNil: [box := box insetBy: margins].
+ newExtent := box width @ self paragraph extent y]
+ ifFalse: "Adjust my width"
+ [ newExtent := self paragraph extent ].
- self isAutoFit
- ifTrue:
- [
- newExtent := self paragraph extent max: 1 @ self defaultLineHeight.
newExtent := newExtent + (2 * self 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>>font: (in category 'accessing') -----
font: aFont
+ "Change the receiver's default font, which is used to draw its contents. Remove all custom font-face-related attributes from the current contents. For a less harsh approach, just use #textStyle: instead and rely on text attributes.
+
+ !! It is best practice to work with #textStyle: and rely on the text attributes TextFontChange and (sometimes) TextFontReference."
+
+ self text ifNotNil: [
+ self text removeAttributesThat: [:attr | attr isTextFontChange and: [attr canFontBeSubstituted]].
+
+ aFont emphasis ~= 0 ifTrue: [
+ self text addAttribute: (TextEmphasis new emphasisCode: aFont emphasis; yourself)]].
+
+ self textStyle: aFont asNewTextStyle.!
- | newTextStyle |
- newTextStyle := aFont textStyle copy ifNil: [ TextStyle fontArray: { aFont } ].
- textStyle := newTextStyle.
- text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOf: aFont)).
- paragraph ifNotNil: [paragraph textStyle: newTextStyle]!
Item was changed:
----- Method: TextMorph>>fontName:pointSize: (in category 'initialization') -----
fontName: fontName pointSize: fontSize
+ "Change the receiver's default font, which is used to draw its contents. Also see commentary in #font:."
- | newTextStyle |
- newTextStyle := ((TextStyle named: fontName asSymbol) ifNil: [ TextStyle default ]) copy.
- newTextStyle ifNil: [self error: 'font ', fontName, ' not found.'].
+ self font: (((TextStyle named: fontName asSymbol) ifNil: [TextStyle default]) fontOfPointSize: fontSize).!
- textStyle := newTextStyle.
- text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOfPointSize: fontSize)).
- self releaseParagraph.!
Item was changed:
----- Method: TextMorph>>fontName:size: (in category 'initialization') -----
+ fontName: fontName size: pixelSize
+ "Change the receiver's default font, which is used to draw its contents. Also see commentary in #font:."
+
+ self font: (((TextStyle named: fontName asSymbol) ifNil: [TextStyle default]) fontOfSize: pixelSize).!
- fontName: fontName size: fontSize
- | newTextStyle |
- newTextStyle := ((TextStyle named: fontName asSymbol) ifNil: [ TextStyle default ]) copy.
- textStyle := newTextStyle.
- text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOfSize: fontSize)).
- self releaseParagraph.!
Item was changed:
+ ----- Method: TextMorph>>goBehind (in category 'submorphs - add/remove') -----
- ----- Method: TextMorph>>goBehind (in category 'submorphs-add/remove') -----
goBehind
"We need to save the container, as it knows about fill and run-around"
| cont |
container ifNil: [^ super goBehind].
self releaseParagraph. "Cause recomposition"
cont := container. "Save the container"
super goBehind. "This will change owner, nilling the container"
container := cont. "Restore the container"
self changed!
Item was changed:
----- Method: TextMorph>>handleInteraction:fromEvent: (in category 'editing') -----
handleInteraction: interactionBlock fromEvent: evt
"Perform the changes in interactionBlock, noting any change in selection
and possibly a change in the size of the paragraph (ar 9/22/2001 - added for TextPrintIts)"
| oldEditor oldParagraph oldText oldSelection |
oldEditor := editor.
oldParagraph := paragraph.
oldText := oldParagraph text copy.
oldSelection := oldParagraph selectionRects. "already copy"
"Note old selection."
self selectionChanged: oldSelection.
interactionBlock value.
(oldParagraph == paragraph) ifTrue:[
"this will not work if the paragraph changed"
editor := oldEditor. "since it may have been changed while in block"
].
"Note new selection."
paragraph selectionRects in: [:newSelection |
newSelection ~= oldSelection ifTrue: [
self selectionChanged: newSelection]].
(oldText = paragraph text and: [ oldText runs = paragraph text runs ])
+ ifFalse: [ self updateFromParagraph ].
- ifFalse:[
- self paragraph composeAll.
- self updateFromParagraph ].
self flag: #ImmPlugin.
"self setCompositionWindow."!
Item was changed:
----- Method: TextMorph>>handleKeystroke: (in category 'events-processing') -----
handleKeystroke: anEvent
"Overwritten to support tab-among-fields preference."
| pasteUp |
anEvent wasHandled ifTrue:[^self].
(self handlesKeyboard: anEvent) ifFalse: [^ self].
+ (anEvent hand keyboardFocus ~~ self
+ and: [self handlesKeyboardOnlyOnFocus])
+ ifTrue: [^ self].
anEvent keyCharacter = Character tab ifTrue: [
"Allow passing through text morph inside pasteups"
(self wouldAcceptKeyboardFocusUponTab
and: [(pasteUp := self pasteUpMorphHandlingTabAmongFields) notNil])
ifTrue: [
anEvent wasHandled: true.
^ pasteUp tabHitWithEvent: anEvent]].
^ super handleKeystroke: anEvent!
Item was added:
+ ----- Method: TextMorph>>minCompositionHeight (in category 'layout') -----
+ minCompositionHeight
+
+ ^ (textStyle ifNil: [TextStyle default]) lineGrid!
Item was added:
+ ----- Method: TextMorph>>minCompositionWidth (in category 'layout') -----
+ minCompositionWidth
+
+ ^ ((textStyle ifNil: [TextStyle default]) defaultFont widthOf: $x) * 2!
Item was changed:
----- Method: TextMorph>>minHeight (in category 'layout') -----
minHeight
| result |
+ result := (paragraph
+ ifNil: [self minCompositionHeight]
+ ifNotNil: [paragraph lines first lineHeight])
+ + (self borderWidth*2).
- textStyle ifNil: [^ 16].
-
- result := (textStyle lineGrid + 2) + (self borderWidth*2).
margins ifNil: [^ result].
^ margins isRectangle
ifTrue: [result + margins top + margins bottom]
ifFalse: [margins isPoint
ifTrue: [result + margins y + margins y]
ifFalse: [result + (2*margins)]]!
Item was changed:
----- Method: TextMorph>>minWidth (in category 'layout') -----
minWidth
| result |
+ result := self minCompositionWidth + (self borderWidth*2).
- textStyle ifNil: [^ 9].
-
- result := 9 + (self borderWidth*2).
margins ifNil: [^ result].
^ margins isRectangle
ifTrue: [result + margins left + margins right]
ifFalse: [margins isPoint
ifTrue: [result + margins x + margins x]
ifFalse: [result + (2*margins)]]!
Item was changed:
----- Method: TextMorph>>newContents: (in category 'accessing') -----
newContents: stringOrText
"Accept new text contents."
| newText embeddedMorphs oldSelection |
newText := stringOrText isString
ifTrue: [Text fromString: stringOrText copy ]
ifFalse: [ stringOrText copy asText. "should be veryDeepCopy?" ].
+ self plainTextOnly ifTrue: [ newText removeAttributesThat: [:att | att isTextAlignment not] ].
(text = newText and: [text runs = newText runs]) ifTrue: [^ self]. "No substantive change"
text ifNotNil: [(embeddedMorphs := text embeddedMorphs)
ifNotNil:
[self removeAllMorphsIn: embeddedMorphs.
embeddedMorphs do: [:m | m delete]]].
oldSelection := editor ifNotNil: [:ed | ed selectionInterval].
text := newText.
"add all morphs off the visible region; they'll be moved into the right
place when they become visible. (this can make the scrollable area too
large, though)"
newText embeddedMorphs do:
[:m |
self addMorph: m.
m position: -1000 @ 0].
self releaseParagraph.
"update the paragraph cache"
self paragraph.
oldSelection ifNotNil: [:sel | self selectFrom: sel first to: sel last].
"re-instantiate to set bounds"
self world ifNotNil: [self world startSteppingSubmorphsOf: self]!
Item was added:
+ ----- Method: TextMorph>>numCharactersPerLine (in category 'layout') -----
+ numCharactersPerLine
+
+ ^ numCharactersPerLine!
Item was added:
+ ----- Method: TextMorph>>numCharactersPerLine: (in category 'layout') -----
+ numCharactersPerLine: numCharsOrNil
+ "Reset composition rectangle to approx. numChars per line. Will be a perfect fit for monospaced fonts, average over multiple lines for other fonts. See commentary in #withNoLineLongerThan: and TextStyle >> #compositionWidthFor:."
+
+ numCharactersPerLine = numCharsOrNil ifTrue: [^ self].
+ numCharactersPerLine := numCharsOrNil.
+ self releaseParagraph; changed.!
Item was added:
+ ----- Method: TextMorph>>plainTextOnly (in category 'accessing') -----
+ plainTextOnly
+
+ ^ plainTextOnly ifNil: [false]!
Item was added:
+ ----- Method: TextMorph>>plainTextOnly: (in category 'accessing') -----
+ plainTextOnly: aBoolean
+
+ plainTextOnly := aBoolean.!
Item was changed:
----- Method: TextMorph>>selectFrom:to: (in category 'accessing') -----
+ selectFrom: start to: stop
+
+ self selectionChanged.
+ self editor selectFrom: start to: stop.
+ self selectionChanged.
+ !
- selectFrom: a to: b
- self editor selectFrom: a to: b!
Item was added:
+ ----- Method: TextMorph>>selectInterval: (in category 'accessing') -----
+ selectInterval: anInterval
+
+ self selectionChanged.
+ self editor selectInterval: anInterval.
+ self selectionChanged.
+ !
Item was added:
+ ----- Method: TextMorph>>selectionColor (in category 'accessing') -----
+ selectionColor
+ ^ self valueOfProperty: #selectionColor ifAbsent: [Color blue muchLighter]!
Item was added:
+ ----- Method: TextMorph>>selectionColor: (in category 'accessing') -----
+ selectionColor: aColor
+
+ self
+ setProperty: #selectionColor
+ toValue: aColor.!
Item was added:
+ ----- Method: TextMorph>>selectionInterval (in category 'accessing') -----
+ selectionInterval
+
+ ^ self editor selectionInterval!
Item was added:
+ ----- Method: TextMorph>>selectionInterval: (in category 'accessing') -----
+ selectionInterval: anInterval
+
+ self selectInterval: anInterval.!
Item was changed:
----- Method: TextMorph>>setTextStyle: (in category 'initialization') -----
setTextStyle: aTextStyle
+ self flag: #deprecated.
+ self textStyle: aTextStyle.!
- textStyle := aTextStyle.
- self releaseCachedState; changed!
Item was added:
+ ----- Method: TextMorph>>textStyle: (in category 'accessing') -----
+ textStyle: aTextStyle
+ "Change the receiver's set of fonts to aTextStyle. You can access those fonts via the TextFontChange text attribute. If you want to enfore a specific font face or point size, use #font: instead. NOTE THAT you must provide either a freshly created instance of TextStyle or a copy of an existing one. NEVER use, for example, TextStyle class >> #default directly. Also see senders and implementors of #asNewTextStyle."
+
+ textStyle := aTextStyle.
+ self releaseParagraph; changed.!
Item was added:
+ ----- Method: TextMorph>>unfocusedSelectionColor (in category 'accessing') -----
+ unfocusedSelectionColor
+ ^ self valueOfProperty: #unfocusedSelectionColor ifAbsent: [Color blue muchLighter]!
Item was added:
+ ----- Method: TextMorph>>unfocusedSelectionColor: (in category 'accessing') -----
+ unfocusedSelectionColor: aColor
+
+ self
+ setProperty: #unfocusedSelectionColor
+ toValue: aColor.!
Item was changed:
----- Method: TextMorph>>updateFromParagraph (in category 'private') -----
updateFromParagraph
"A change has taken place in my paragraph, as a result of editing and I must be updated. If a line break causes recomposition of the current paragraph, or it the selection has entered a different paragraph, then the current editor will be released, and must be reinstalled with the resulting new paragraph, while retaining any editor state, such as selection, undo state, and current typing emphasis."
| newStyle sel oldLast oldEditor back |
paragraph ifNil: [^self].
wrapFlag ifNil: [wrapFlag := true].
editor ifNotNil:
[oldEditor := editor.
sel := editor selectionInterval.
editor storeSelectionInParagraph].
text := paragraph text.
paragraph textStyle = textStyle
ifTrue: [self fit]
ifFalse:
["Broadcast style changes to all morphs"
newStyle := paragraph textStyle.
(self firstInChain text: text textStyle: newStyle) recomposeChain.
editor ifNotNil: [self installEditorToReplace: editor]].
+ self layoutChanged.
- (self isAutoFit and: [self isWrapped not])
- ifTrue: [self extent: self paragraph extent; composeToBounds]
- ifFalse: [self layoutChanged].
sel ifNil: [^self].
"If selection is in top line, then recompose predecessor for possible ripple-back"
predecessor ifNotNil:
[sel first <= (self paragraph lines first last + 1)
ifTrue:
[oldLast := predecessor lastCharacterIndex.
predecessor paragraph
recomposeFrom: oldLast
to: text size
delta: 0.
oldLast = predecessor lastCharacterIndex
ifFalse:
[predecessor changed. "really only last line"
self predecessorChanged]]].
((back := predecessor notNil
and: [sel first <= self paragraph firstCharacterIndex]) or:
[successor notNil
and: [sel first > (self paragraph lastCharacterIndex + 1)]])
ifTrue:
["The selection is no longer inside this paragraph.
Pass focus to the paragraph that should be in control."
back ifTrue: [predecessor recomposeChain] ifFalse: [self recomposeChain].
self firstInChain withSuccessorsDo:
[:m |
(sel first between: m firstCharacterIndex and: m lastCharacterIndex + 1)
ifTrue:
[m installEditorToReplace: oldEditor.
^self passKeyboardFocusTo: m]].
self error: 'Inconsistency in text editor' "Must be somewhere in the successor chain"].
editor ifNil:
["Reinstate selection after, eg, style change"
self installEditorToReplace: oldEditor].
self flag: #ImmPlugin.
"self setCompositionWindow."
!
Item was added:
+ ----- Method: TextMorph>>withNoLineLongerThan: (in category 'converting') -----
+ withNoLineLongerThan: numChars
+ "Convenience only to establish this protocol across String, Text, and TextMorph."
+
+ self numCharactersPerLine: numChars.
+ ^ self paragraph asTextWithLineBreaks!
Item was changed:
----- Method: TextMorphForEditView class>>draggableTextSelection: (in category 'preferences') -----
+ draggableTextSelection: aBooleanOrNil
- draggableTextSelection: aBoolean
+ DraggableTextSelection := aBooleanOrNil.
- DraggableTextSelection := aBoolean.
+ self draggableTextSelection in: [:aBoolean |
+ TextMorphForEditView allInstancesDo: [:tm |
+ tm dragEnabled: aBoolean; dropEnabled: aBoolean]].!
- TextMorphForEditView allInstancesDo: [:tm |
- tm dragEnabled: aBoolean; dropEnabled: aBoolean].!
Item was changed:
----- Method: TextMorphForEditView>>cancelEdits (in category 'editing') -----
cancelEdits
"The message is sent when the user hits enter or Cmd-L.
Cancel the current contents and end editing."
+ super cancelEdits.
- self releaseParagraph.
editView cancel!
Item was added:
+ ----- Method: TextMorphForEditView>>cancelEditsSafely (in category 'editing') -----
+ cancelEditsSafely
+ "Safe variation of #cancelEdits, where the undo history is not discarded and can thus be used to undo the cancel operation."
+
+ editView cancelSafely.!
Item was removed:
- ----- Method: TextMorphForEditView>>caretColor (in category 'accessing') -----
- caretColor
- ^ self valueOfProperty: #caretColor ifAbsent: [Color red]!
Item was removed:
- ----- Method: TextMorphForEditView>>caretColor: (in category 'accessing') -----
- caretColor: aColor
- self
- setProperty: #caretColor
- toValue: aColor.!
Item was removed:
- ----- Method: TextMorphForEditView>>createParagraph (in category 'private') -----
- createParagraph
-
- super createParagraph.
-
- paragraph
- caretColor: self caretColor;
- selectionColor: self selectionColor;
- unfocusedSelectionColor: self unfocusedSelectionColor.
-
- ^ paragraph!
Item was added:
+ ----- Method: TextMorphForEditView>>doLayoutIn: (in category 'layout') -----
+ doLayoutIn: layoutBounds
+
+ | shouldRestoreSelection |
+ self flag: #workaround. "mt: The combination of 'releaseParagraph; paragraph' resets the selection. We should find a better way for this in the future. Sigh...."
+
+ shouldRestoreSelection := paragraph isNil.
+
+ super doLayoutIn: layoutBounds.
+
+ shouldRestoreSelection ifTrue: [
+ self editView ifNotNil: [:view |
+ view restoreSelectionInterval]].!
Item was removed:
- ----- Method: TextMorphForEditView>>selectionColor (in category 'accessing') -----
- selectionColor
- ^ self valueOfProperty: #selectionColor ifAbsent: [Color blue muchLighter]!
Item was removed:
- ----- Method: TextMorphForEditView>>selectionColor: (in category 'accessing') -----
- selectionColor: aColor
-
- self
- setProperty: #selectionColor
- toValue: aColor.!
Item was removed:
- ----- Method: TextMorphForEditView>>unfocusedSelectionColor (in category 'accessing') -----
- unfocusedSelectionColor
- ^ self valueOfProperty: #unfocusedSelectionColor ifAbsent: [Color blue muchLighter]!
Item was removed:
- ----- Method: TextMorphForEditView>>unfocusedSelectionColor: (in category 'accessing') -----
- unfocusedSelectionColor: aColor
-
- self
- setProperty: #unfocusedSelectionColor
- toValue: aColor.!
Item was changed:
----- Method: TextMorphForEditView>>wantsDroppedMorph:event: (in category 'dropping/grabbing') -----
wantsDroppedMorph: aMorph event: evt
^ ((super wantsDroppedMorph: aMorph event: evt)
+ and: [aMorph isTransferMorph])
- and: [aMorph isKindOf: TransferMorph])
and: [aMorph passenger isString or: [aMorph passenger isText]]!
Item was changed:
----- Method: TheWorldMainDockingBar class>>initialize (in category 'class initialization') -----
initialize
"self initialize"
- Locale addLocalChangedListener: self.
self updateInstances.!
Item was changed:
----- Method: TheWorldMainDockingBar class>>setMenuPreference:to: (in category 'preferences') -----
+ setMenuPreference: aPreferenceSymbol to: aBooleanOrNil
- setMenuPreference: aPreferenceSymbol to: aBoolean
| project |
(project := Project current) isMorphic ifTrue: [
+ aBooleanOrNil
+ ifNil: ["Reset to default value."
+ (Preferences preferenceAt: aPreferenceSymbol) ifNotNil: [:pref | pref restoreDefaultValue]]
+ ifNotNil: [
+ project projectPreferenceFlagDictionary at: aPreferenceSymbol put: aBooleanOrNil].
+ (aBooleanOrNil ~= (Preferences preferenceAt: aPreferenceSymbol))
+ ifTrue: [Preferences setPreference: aPreferenceSymbol toValue: aBooleanOrNil]].
- project projectPreferenceFlagDictionary at: aPreferenceSymbol put: aBoolean.
- (aBoolean ~= (Preferences preferenceAt: aPreferenceSymbol))
- ifTrue: [Preferences setPreference: aPreferenceSymbol toValue: aBoolean]].
self updateInstances.!
Item was changed:
----- Method: TheWorldMainDockingBar>>allVisibleWindows (in category 'submenu - windows') -----
allVisibleWindows
+ ^ self allVisibleWindowsIn: Project current world!
- ^SystemWindow windowsIn: Project current world satisfying: [ :w | w visible ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>allVisibleWindowsIn: (in category 'submenu - windows') -----
+ allVisibleWindowsIn: world
+ ^SystemWindow windowsIn: world satisfying: [ :w | w visible ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>browseChangeSet (in category 'submenu - changes') -----
+ browseChangeSet
+
+ ChangeSetBrowser openOnCurrent.!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>browseChangedMethods (in category 'submenu - changes') -----
+ browseChangedMethods
+
+ ChangedMessageSet openFor: ChangeSet current.!
Item was changed:
+ ----- Method: TheWorldMainDockingBar>>browseChanges (in category 'submenu - changes') -----
- ----- Method: TheWorldMainDockingBar>>browseChanges (in category 'right side') -----
browseChanges
ChangeSorter open.!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>browseChangesDual (in category 'submenu - changes') -----
+ browseChangesDual
+
+ DualChangeSorter open.!
Item was changed:
+ ----- Method: TheWorldMainDockingBar>>browseChangesLabel (in category 'submenu - changes') -----
- ----- Method: TheWorldMainDockingBar>>browseChangesLabel (in category 'right side') -----
browseChangesLabel
"The project name is the same as the current change set."
^ Project current name!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>changesMenuOn: (in category 'submenu - changes') -----
+ changesMenuOn: aDockingBar
+
+ aDockingBar addUpdatingItem: [:item |
+ item
+ help: 'Browse this project''s changes' translated;
+ wordingProvider: self
+ wordingSelector: #browseChangesLabel;
+ subMenuUpdater: self
+ selector: #listChangesOn:].!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>chooseCustomScaleFactor (in category 'submenu - extras') -----
+ chooseCustomScaleFactor
+
+ | result |
+ result := Project uiManager request: 'Please enter a scale factor in %' translated initialAnswer: '350'.
+ result ifEmpty: [^ self].
+ [result := result asInteger abs] ifError: [^ self].
+ result < 100 ifTrue: [^ self].
+ Display relativeUiScaleFactor: result / 100.!
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 * RealEstateAgent scaleFactor) truncated)
- ^(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: 2 color: Color transparent!
Item was changed:
----- Method: TheWorldMainDockingBar>>extrasMenuOn: (in category 'submenu - extras') -----
extrasMenuOn: aDockingBar
aDockingBar addItem: [ :it|
it contents: 'Extras' translated;
addSubMenu: [:menu|
menu addItem:[:item|
item
contents: 'Recover Changes' translated;
help: 'Recover changes after a crash' translated;
icon: MenuIcons smallDocumentClockIcon;
target: ChangeList;
selector: #browseRecentLog].
+ menu addItem:[:item|
+ item
+ contents: 'Recover Method Versions' translated;
+ help: 'Recover versions of deleted methods' translated;
+ target: ChangeList;
+ selector: #browseMethodVersions].
menu addLine.
menu addItem:[:item|
item
contents: 'Themes & Colors' translated;
subMenuUpdater: self
selector: #themesAndWindowColorsOn: ].
menu addItem:[:item|
item
+ contents: 'Scale Factor' translated;
+ subMenuUpdater: self
+ selector: #scaleFactorsOn:].
+ menu addItem:[:item|
+ item
contents: 'Language' translated;
subMenuUpdater: self
selector: #languageTranslatorsOn: ].
menu addItem:[:item|
item
contents: 'Set Author Initials' translated;
help: 'Sets the author initials' translated;
icon: MenuIcons smallUserQuestionIcon;
target: Utilities;
selector: #setAuthorInitials].
menu addItem:[:item|
item
contents: 'Restore Display (r)' translated;
help: 'Redraws the entire display' translated;
target: Project current;
selector: #restoreDisplay].
menu addItem:[:item|
item
contents: 'Rebuild Menus' translated;
help: 'Rebuilds the menu bar' translated;
target: TheWorldMainDockingBar;
selector: #updateInstances].
menu addLine.
menu addItem:[:item|
item
contents: 'Start Profiler' translated;
help: 'Starts the profiler' translated;
icon: MenuIcons smallTimerIcon;
target: self;
selector: #startMessageTally].
menu addItem:[:item|
item
contents: 'Collect Garbage' translated;
help: 'Run the garbage collector and report space usage' translated;
target: Utilities;
selector: #garbageCollectAndReport].
menu addItem:[:item|
item
contents: 'Purge Undo Records' translated;
help: 'Save space by removing all the undo information remembered in all projects' translated;
target: CommandHistory;
selector: #resetAllHistory].
menu addItem:[:item|
item
contents: 'VM statistics' translated;
help: 'Virtual Machine information' translated;
target: self;
selector: #vmStatistics].
menu addLine.
menu addItem:[:item|
item
contents: 'Graphical Imports' translated;
help: 'View the global repository called ImageImports; you can easily import external graphics into ImageImports via the FileList' translated;
target: (Imports default);
selector: #viewImages].
menu addItem:[:item|
item
contents: 'Standard Graphics Library' translated;
help: 'Lets you view and change the system''s standard library of graphics' translated;
target: ScriptingSystem;
selector: #inspectFormDictionary].
menu addItem:[:item|
item
contents: 'Annotation Setup' translated;
help: 'Click here to get a little window that will allow you to specify which types of annotations, in which order, you wish to see in the annotation panes of browsers and other tools' translated;
target: Preferences;
selector: #editAnnotations].
menu addItem:[:item|
item
contents: 'Browse My Changes' translated;
help: 'Browse all of my changes since the last time #condenseSources was run.' translated;
target: SystemNavigation new;
selector: #browseMyChanges].
] ]!
Item was changed:
----- Method: TheWorldMainDockingBar>>fillDockingBar: (in category 'construction') -----
fillDockingBar: aDockingBar
"Private - fill the given docking bar"
self menusOn: aDockingBar.
aDockingBar addSpacer.
+ self changesMenuOn: aDockingBar.
- self projectNameOn: aDockingBar.
aDockingBar addSpacer.
self rightSideOn: aDockingBar.
aDockingBar
setProperty: #mainDockingBarTimeStamp
toValue: self class timeStamp.!
Item was changed:
----- Method: TheWorldMainDockingBar>>installAndOpenGitBrowser (in category 'menu actions') -----
installAndOpenGitBrowser
(Smalltalk hasClassNamed: #SquitBrowser)
ifFalse: [ (UIManager default
+ confirm: 'The Git infrastructure and browser is not yet installed.\\Do you want to install the Git Browser?\\(Note that this step requires an internet connection and may take several minutes.)' translated withCRs
- confirm: 'The Git infrastructure and browser is not yet installed.\\Do you want to install the Git Browser?\\(Note that this step requires an internet connection and\may take several minutes.)' withCRs translated
title: 'Confirm Installation Request' )
ifTrue: [ Installer
ensureRecentMetacello;
installGitInfrastructure.
TheWorldMainDockingBar updateInstances ]
ifFalse: [ ^self ] ].
(Smalltalk classNamed: #SquitBrowser) open.
!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>installAndOpenSqueakInboxTalk (in category 'menu actions') -----
+ installAndOpenSqueakInboxTalk
+
+ (Smalltalk hasClassNamed: #TalkInboxBrowser)
+ ifFalse: [ (Project uiManager
+ confirm: 'Squeak Inbox Talk is not yet installed.\\Do you want to install it?\\(Note that this step requires an internet connection and may take several minutes.)' withCRs translated
+ title: 'Confirm Installation Request' )
+ ifTrue: [ Installer
+ ensureRecentMetacello;
+ installSqueakInboxTalk.
+ TheWorldMainDockingBar updateInstances ]
+ ifFalse: [ ^self ] ].
+ (Smalltalk classNamed: #TalkInboxBrowser) open.
+ !
Item was changed:
----- Method: TheWorldMainDockingBar>>languageTranslatorsOn: (in category 'submenu - extras') -----
languageTranslatorsOn: menu
| availableLanguages |
availableLanguages := NaturalLanguageTranslator availableLanguageLocaleIDs
sorted:[:x :y | x displayName < y displayName].
availableLanguages do: [:localeID |
+ menu addUpdating: #stringForLanguageNameIs: target: Locale selector: #switchToID: argumentList: {localeID}].
- menu addUpdating: #stringForLanguageNameIs: target: Locale selector: #switchAndInstallFontToID: argumentList: {localeID}].
!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>listChangesOn: (in category 'submenu - changes') -----
+ listChangesOn: menu
+
+ | fetchChangesBlock |
+ {
+ 'Browse current change set' translated. #browseChangeSet. nil.
+ 'Browse changed methods' translated. #browseChangedMethods. nil.
+ nil. nil. nil.
+ 'Simple Change Sorter' translated. #browseChanges. ChangeSorter.
+ 'Dual Change Sorter' translated. #browseChangesDual. DualChangeSorter.
+ nil. nil. nil.
+ } groupsDo: [:label :selector :modelClass |
+ label ifNil: [menu addLine] ifNotNil: [
+ menu addItem: [:item |
+ item
+ contents: label;
+ icon: ((modelClass ifNotNil: [self colorIcon: modelClass basicNew windowColorToUse])
+ ifNil: [MenuIcons blankIcon]);
+ target: self;
+ selector: selector]] ].
+
+ fetchChangesBlock := [ | latestMethodChanges latestClassChanges updateBlock |
+ self flag: #concurrency. "mt: Is this safe enough given the current update frequency of change sets and when this code is executed?"
+ latestMethodChanges := (Array streamContents: [:s |
+ ChangeSet current changedMethodsDo: [:method :changeType :dateAndTime :category |
+ s nextPut: { dateAndTime. method. changeType. category }]])
+ sorted: [:a :b | a first >= b first].
+ latestClassChanges := (Array streamContents: [:s |
+ ChangeSet current changedClassesDo: [:class :changeTypes :dateAndTime :category |
+ "We are not interested in classes whose method's did only change."
+ changeTypes ifNotEmpty: [s nextPut: { dateAndTime. class. changeTypes. category }]]])
+ sorted: [:a :b | a first >= b first].
+ updateBlock := [self listMethodChanges: latestMethodChanges andClassChanges: latestClassChanges on: menu].
+ Project current uiProcess == Processor activeProcess
+ ifTrue: updateBlock
+ ifFalse: [Project current addDeferredUIMessage: [
+ menu isInWorld ifTrue: [menu lastItem delete. updateBlock value]] ]].
+
+ ChangeSet current numberOfChanges <= 30
+ ifTrue: fetchChangesBlock ifFalse: [
+ "We have too much data to process. Do it in the background to keep the UI responsive."
+ menu add: '... fetching changes ...' translated action: nil.
+ menu lastItem isEnabled: false.
+ fetchChangesBlock forkAt: Processor userBackgroundPriority].!
Item was changed:
----- Method: TheWorldMainDockingBar>>listCommonRequestsOn: (in category 'submenu - do') -----
listCommonRequestsOn: aMenu
| strings |
+ aMenu add: 'edit this list' translated target: Utilities action: #editCommonRequestStrings.
+ aMenu addLine.
+
strings := Utilities commonRequestStrings contents.
-
strings asString linesDo: [:aString |
aString = '-'
ifTrue: [aMenu addLine]
+ ifFalse: [aMenu add: (aString ifEmpty: [' ']) target: Utilities selector: #eval: argument: aString]].!
- ifFalse: [aMenu add: (aString ifEmpty: [' ']) target: Utilities selector: #eval: argument: aString]].
-
- aMenu addLine.
- aMenu add: 'edit this list' translated target: Utilities action: #editCommonRequestStrings.!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>listMethodChanges:andClassChanges:on: (in category 'submenu - changes') -----
+ listMethodChanges: methodChanges andClassChanges: classChanges on: menu
+
+ | latestMethodChanges latestClassChanges |
+ latestMethodChanges := methodChanges.
+
+ 1 to: (10 min: latestMethodChanges size) do: [:index | | spec method |
+ spec := latestMethodChanges at: index.
+ method := spec second.
+ menu addItem: [:item |
+ item
+ contents: ('{1} {2} \{{3}\} \{{4}\}' format: {method methodClass. method selector. spec fourth. method methodClass category}) ;
+ target: ToolSet;
+ balloonText: spec third asString;
+ icon: ((#(remove addedThenRemoved) includes: spec third) ifTrue: [MenuIcons smallDeleteIcon] ifFalse: [
+ spec third = #add ifTrue: [MenuIcons smallNewIcon] ifFalse: [MenuIcons blankIcon]]);
+ selector: (method isInstalled ifTrue: [#browseMethod:] ifFalse: [#browseMethodVersion:]);
+ arguments: {method}]].
+
+ latestClassChanges := classChanges.
+
+ latestClassChanges ifNotEmpty: [menu addLine].
+ 1 to: (10 min: latestClassChanges size) do: [:index | | spec class |
+ spec := latestClassChanges at: index.
+ class := spec second.
+ menu addItem: [:item |
+ item
+ contents: ('{1} \{{2}\}' format: {class name. spec fourth }) ;
+ target: ToolSet;
+ balloonText: (spec third sorted joinSeparatedBy: Character space);
+ icon: ((spec third includesAnyOf: #(remove addedThenRemoved))
+ ifTrue: [MenuIcons smallDeleteIcon]
+ ifFalse: [
+ (spec third includes: #add)
+ ifTrue: [MenuIcons smallNewIcon]
+ ifFalse: [MenuIcons blankIcon]]);
+ selector: ((spec third includes: #remove) ifTrue: [#inspect:] ifFalse: [#browseClass:]);
+ arguments: {class}]]!
Item was changed:
----- Method: TheWorldMainDockingBar>>listWindowsOn: (in category 'submenu - windows') -----
listWindowsOn: menu
| windows |
+ menu
+ addLine;
+ add: 'Collapse all windows' target: (Project current world) selector: #collapseAllWindows;
+ addItem: [:item | item
+ contents: 'Find Workspace...';
+ subMenuUpdater: self
+ selector: #workspacesMenuFor:
+ arguments: #()];
+ addLine;
+ add: 'Close all windows' target: self selector: #closeAllWindowsUnsafe;
+ addItem: [:item | item
+ contents: 'Close all windows without changes';
+ target: self;
+ icon: MenuIcons smallBroomIcon;
+ selector: #closeAllWindows];
+ add: 'Close all windows but workspaces' target: self selector: #closeAllWindowsButWorkspaces;
+ addLine.
+
windows := self allVisibleWindows sorted: [:winA :winB |
((winA model isNil or: [winB model isNil]) or: [winA model name = winB model name])
ifTrue: [winA label < winB label]
ifFalse: [winA model name < winB model name]].
windows ifEmpty: [
menu addItem: [ :item |
item
contents: 'No Windows' translated;
isEnabled: false ] ].
windows do: [ :each |
| windowColor |
windowColor := (each model respondsTo: #windowColorToUse)
ifTrue: [each model windowColorToUse]
ifFalse: [UserInterfaceTheme current get: #uniformWindowColor for: Model].
menu addItem: [ :item |
item
contents: (self windowMenuItemLabelFor: each);
icon: (self colorIcon: windowColor);
target: each;
selector: #comeToFront;
subMenuUpdater: self
selector: #windowMenuFor:on:
arguments: { each };
+ action: [ each beKeyWindow; expand ] ] ].!
- action: [ each beKeyWindow; expand ] ] ].
- menu
- addLine;
- add: 'Collapse all windows' target: (Project current world) selector: #collapseAllWindows;
- add: 'Close all windows' target: self selector: #closeAllWindowsUnsafe;
- addItem: [:item | item
- contents: 'Close all windows without changes';
- target: self;
- icon: MenuIcons smallBroomIcon;
- selector: #closeAllWindows];
- add: 'Close all windows but workspaces' target: self selector: #closeAllWindowsButWorkspaces.!
Item was removed:
- ----- Method: TheWorldMainDockingBar>>openHelp:topic:styled: (in category 'submenu - help') -----
- openHelp: bookSymbol topic: topicSymbol styled: boolean
-
- | openSelector |
- openSelector := boolean ifTrue: [#openForCodeOn:] ifFalse: [#openOn:].
-
- (Smalltalk classNamed: 'HelpBrowser')
- ifNil: [self inform: 'Sorry, there is no help system installed.' translated]
- ifNotNil: [:helpClass |
- (Smalltalk classNamed: bookSymbol)
- ifNil: [self inform: 'Sorry, the help book you requested does not exist.']
- ifNotNil: [:book |
- topicSymbol
- ifNil: [(helpClass perform: openSelector with: book) model showFirstTopic]
- ifNotNil: [(helpClass perform: openSelector with: book) model showTopicNamed: topicSymbol]]].!
Item was removed:
- ----- Method: TheWorldMainDockingBar>>projectNameOn: (in category 'right side') -----
- projectNameOn: aDockingBar
-
- aDockingBar addUpdatingItem: [:item |
- item
- help: 'Browse this project''s changes';
- target: self;
- selector: #browseChanges;
- wordingProvider: self
- wordingSelector: #browseChangesLabel].!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>resetAllThemes (in category 'submenu - extras') -----
+ resetAllThemes
+
+ (Project uiManager confirm: 'Do you want to reset all UI themes to their original state?\\(The current theme and scale factor will be restored if possible.)' translated withCRs title: 'Reset All Themes')
+ ifTrue: [UserInterfaceTheme cleanUpAndReset].!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>scaleFactorsOn: (in category 'submenu - extras') -----
+ scaleFactorsOn: menu
+
+ | presets currentScaleFactor currentPlatformScaleFactor |
+ currentScaleFactor := (Display relativeUiScaleFactor * 100) rounded.
+ currentPlatformScaleFactor := Display platformScaleFactorKnown
+ ifTrue: [(Display platformScaleFactor * 100) rounded].
+ presets := 75 to: 300 by: 25.
+
+ presets do: [:scale |
+ scale = 100 ifTrue: [menu addLine]. "Normal scales."
+ scale = 175 ifTrue: [menu addLine]. "TTCFont used after this line..."
+ menu addItem: [:item|
+ item
+ contents: ('{1}{2}%{3}{4}' format: {
+ currentScaleFactor = scale ifTrue: ['<yes>'] ifFalse: ['<no>'].
+ scale.
+ DisplayScreen relativeScaleFactorEnabled
+ ifTrue: ['' "macOS"] ifFalse: [
+ scale = currentPlatformScaleFactor
+ ifTrue: [' (recommended)' translated] ifFalse: ['']].
+ scale = 75 ifTrue: [' (low ppi)' translated] ifFalse: ['']
+ });
+ target: Display;
+ selector: #relativeUiScaleFactor:;
+ arguments: {scale / 100}]].
+
+ menu addLine.
+ menu addItem: [:item |
+ item
+ contents: ((presets includes: currentScaleFactor) not ifTrue: ['<yes>' , 'Custom: ' translated, currentScaleFactor, '% ...'] ifFalse: ['<no>' , 'Other scale factor...' translated]);
+ target: self;
+ selector: #chooseCustomScaleFactor].!
Item was changed:
----- Method: TheWorldMainDockingBar>>searchBarOn: (in category 'right side') -----
searchBarOn: aDockingBar
aDockingBar
+ addMorphBack: (SearchBar build
+ hResizing: #rigid; vResizing: #rigid;
+ width: (TextStyle defaultFont widthOf: $x) * 30; "Optimized for #scaleFactor * (1024@764) -- thus not full-screen mode..."
+ height: ToolBuilder default inputFieldHeight;
+ yourself);
- addMorphBack: (SearchBar build vResizing: #spaceFill; width: 200);
addDefaultSpace!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>selectWorkspace:window:inProject:contents: (in category 'submenu - windows') -----
+ selectWorkspace: aWorkspace window: aSystemWindow inProject: aMorphicProject contents: contents
+ aMorphicProject
+ addDeferredUIMessage: [aSystemWindow comeToFront];
+ enter "Does nothing if already the current project..."
+ !
Item was added:
+ ----- Method: TheWorldMainDockingBar>>squeakInboxTalkMenuItemOn: (in category 'submenu - tools') -----
+ squeakInboxTalkMenuItemOn: menu
+
+ menu addItem: [:item |
+ item
+ contents: ((Smalltalk hasClassNamed: #TalkInboxBrowser)
+ ifTrue: ['Squeak Inbox Talk' translated]
+ ifFalse: ['Squeak Inbox Talk (click to install)' translated]);
+ help: 'Engage with our community from within Squeak using tools that integrate our mailing lists such as squeak-dev and vm-dev' translated;
+ icon: (self colorIcon: ((Smalltalk classNamed: #TalkInboxBrowser) ifNil: Model)
+ basicNew windowColorToUse);
+ target: self;
+ selector: #installAndOpenSqueakInboxTalk]!
Item was changed:
----- Method: TheWorldMainDockingBar>>themesAndWindowColorsOn: (in category 'submenu - extras') -----
themesAndWindowColorsOn: menu
| themes |
menu addItem:[:item|
item
+ contents: 'Fonts' translated;
+ subMenuUpdater: Preferences
+ selector: #fontConfigurationMenu:;
+ icon: MenuIcons smallFontsIcon].
+ menu addLine.
+ menu addItem:[:item|
+ item
contents: (Model useColorfulWindows ifTrue: ['<yes>'] ifFalse: ['<no>']), 'Colorful Windows' translated;
target: self;
selector: #toggleColorfulWindows].
menu addItem:[:item|
item
contents: (SystemWindow gradientWindow not ifTrue: ['<yes>'] ifFalse: ['<no>']), 'Flat Widget Look' translated;
target: self;
selector: #toggleGradients].
menu addLine.
menu addItem:[:item |
item
contents: (((Preferences valueOfFlag: #menuAppearance3d ifAbsent: [false]) and: [Morph useSoftDropShadow]) ifTrue: ['<yes>'] ifFalse: ['<no>']), 'Soft Shadows' translated;
target: self;
selector: #toggleSoftShadows].
menu addItem:[:item |
item
contents: (((Preferences valueOfFlag: #menuAppearance3d ifAbsent: [false]) and: [Morph useSoftDropShadow not]) ifTrue: ['<yes>'] ifFalse: ['<no>']), 'Hard Shadows' translated;
target: self;
selector: #toggleHardShadows].
menu addLine.
menu addItem:[:item |
item
+ contents: (SystemWindow roundedWindowCorners ifTrue: ['<yes>'] ifFalse: ['<no>']), 'Rounded Window/Dialog Look' translated;
- contents: (SystemWindow roundedWindowCorners ifTrue: ['<yes>'] ifFalse: ['<no>']), 'Rounded Window/Dialog/Menu Look' translated;
target: self;
selector: #toggleRoundedWindowLook].
menu addItem:[:item |
item
+ contents: (PluggableButtonMorph roundedButtonCorners ifTrue: ['<yes>'] ifFalse: ['<no>']), 'Rounded Button/Scrollbar/Menu Look' translated;
- contents: (PluggableButtonMorph roundedButtonCorners ifTrue: ['<yes>'] ifFalse: ['<no>']), 'Rounded Button/Scrollbar Look' translated;
target: self;
selector: #toggleRoundedButtonLook].
+ menu addLine.
+ themes := UserInterfaceTheme allThemes asArray sort: #name ascending.
+ themes := themes select: [ :each | each isGenuine].
- themes := UserInterfaceTheme allThemes asArray sort: #name ascending.
themes ifEmpty: [
menu addItem: [ :item |
item
contents: '(No UI themes found.)' translated;
isEnabled: false ] ].
themes do: [ :each |
menu addItem: [ :item |
item
+ contents: (UserInterfaceTheme current name = each name ifTrue: ['<yes>'] ifFalse: ['<no>']), each name;
- contents: (UserInterfaceTheme current == each ifTrue: ['<yes>'] ifFalse: ['<no>']), each name;
target: each;
+ selector: #applyScaled ] ].
+ menu
+ addLine;
+ add: 'Set Etoys Mode' translated target: ReleaseBuilderSqueakland selector: #setEtoysMode.
- selector: #apply ] ].
menu
- addLine ;
- add: 'Increase Font Size' translated target: Preferences selector: #increaseFontSize ;
- add: 'Decrease Font Size' translated target: Preferences selector: #decreaseFontSize ;
- addLine.
- menu
addLine;
+ add: 'Restore UI theme background' translated target: self selector: #restoreThemeBackground;
+ add: 'Reset all UI themes' translated target: self selector: #resetAllThemes;
+ add: 'Edit current UI theme...' translated target: self selector: #editCurrentTheme.!
- add: 'Restore UI Theme Background' translated target: self selector: #restoreThemeBackground;
- add: 'Edit Current UI Theme...' translated target: self selector: #editCurrentTheme.!
Item was changed:
----- Method: TheWorldMainDockingBar>>toggleFullScreenOn: (in category 'right side') -----
toggleFullScreenOn: aDockingBar
| toggleMorph onIcon offIcon box bgColor |
+ offIcon := (MenuIcons fullscreenWireframeIcon dyed:
+ (self userInterfaceTheme logoColor ifNil: [Color black])) scaleIconToDisplay.
+ onIcon := (MenuIcons fullscreenWireframeIcon dyed:
+ (self userInterfaceTheme selectionLogoColor ifNil: [Color white])) scaleIconToDisplay.
- offIcon := MenuIcons fullscreenWireframeIcon dyed:
- (self userInterfaceTheme logoColor ifNil: [Color black]).
- onIcon := MenuIcons fullscreenWireframeIcon dyed:
- (self userInterfaceTheme selectionLogoColor ifNil: [Color white]).
bgColor := (UserInterfaceTheme current get: #selectionColor for: #DockingBarItemMorph) ifNil: [Color blue].
toggleMorph := offIcon asMorph.
box := Morph new
color: Color transparent;
hResizing: #shrinkWrap;
vResizing: #spaceFill;
- listCentering: #center;
- width: toggleMorph width;
- changeTableLayout;
-
- borderWidth: 1;
- borderColor: Color transparent;
balloonText: 'toggle full screen mode' translated;
+ changeTableLayout;
+ listCentering: #center;
+ layoutInset: (ToolBuilder default inputFieldHeight "searchBar" - toggleMorph width // 2);
+
addMorph: toggleMorph.
toggleMorph setToAdhereToEdge: #rightCenter.
box
on: #mouseUp
send: #value
to:
[ DisplayScreen toggleFullScreen.
"toggleMorph image: MenuIcons smallFullscreenOffIcon" ] ;
on: #mouseEnter
send: #value
to: [
toggleMorph image: onIcon.
box color: bgColor; borderColor: bgColor];
on: #mouseLeave
send: #value
to: [
toggleMorph image: offIcon.
box color: Color transparent; borderColor: Color transparent].
aDockingBar addMorphBack: box!
Item was changed:
----- Method: TheWorldMainDockingBar>>toggleRoundedButtonLook (in category 'submenu - extras') -----
toggleRoundedButtonLook
| switch |
switch := PluggableButtonMorph roundedButtonCorners not.
PluggableButtonMorph roundedButtonCorners: switch.
+ ScrollBar roundedScrollBarLook: switch.
+ MenuMorph roundedMenuCorners: switch.!
- ScrollBar roundedScrollBarLook: switch.!
Item was changed:
----- Method: TheWorldMainDockingBar>>toggleRoundedWindowLook (in category 'submenu - extras') -----
toggleRoundedWindowLook
| switch |
switch := SystemWindow roundedWindowCorners not.
SystemWindow roundedWindowCorners: switch.
+ DialogWindow roundedDialogCorners: switch.!
- DialogWindow roundedDialogCorners: switch.
- MenuMorph roundedMenuCorners: switch.!
Item was changed:
----- Method: TheWorldMainDockingBar>>toolsMenuOn: (in category 'construction') -----
toolsMenuOn: aDockingBar
aDockingBar addItem: [ :item |
item
contents: 'Tools' translated;
addSubMenu: [ :menu |
self
browserMenuItemOn: menu;
workspaceMenuItemOn: menu;
transcriptMenuItemOn: menu;
testRunnerMenuItemOn: menu;
methodFinderMenuItemOn: menu;
messageNamesMenuItemOn: menu.
menu addLine.
self
simpleChangeSorterMenuItemOn: menu;
dualChangeSorterMenuItemOn: menu;
monticelloBrowserMenuItemOn: menu;
+ monticelloConfigurationsMenuItemOn: menu.
- monticelloConfigurationsMenuItemOn: menu ;
- gitInfrastructureMenuItemOn: menu.
menu addLine.
self
+ gitInfrastructureMenuItemOn: menu;
+ squeakInboxTalkMenuItemOn: menu.
+ menu addLine.
+ self
processBrowserMenuItemOn: menu;
preferenceBrowserMenuItemOn: menu;
fileListMenuItemOn: menu.
] ]!
Item was changed:
----- Method: TheWorldMainDockingBar>>updateMenuItemOn: (in category 'submenu - squeak') -----
updateMenuItemOn: menu
+ | firstCustomUpdater |
menu addItem: [ :item |
item
contents: 'Update Squeak' translated;
help: 'Load latest code updates via the internet' translated;
icon: MenuIcons smallChangesIcon;
target: self;
+ selector: #updateSqueak ].
+
+ firstCustomUpdater := true.
+ TheWorldMainDockingBar methodsDo: [:method |
+ (method pragmaAt: #updater:) ifNotNil: [:pragma |
+ firstCustomUpdater ifTrue: [
+ menu addLine.
+ firstCustomUpdater := false].
+ menu addItem: [ :item |
+ item
+ contents: (pragma argumentAt: 1) translated;
+ target: self;
+ selector: method selector]]].!
- selector: #updateSqueak ]!
Item was added:
+ ----- Method: TheWorldMainDockingBar>>workspacesMenuFor: (in category 'submenu - windows') -----
+ workspacesMenuFor: anUpdatingMenuMorph
+
+ | allWorkspaces |
+ allWorkspaces := Set new.
+ Project allMorphicProjects do:
+ [:project|
+ (self allVisibleWindowsIn: project world) do:
+ [:window|
+ (window model isKindOf: Workspace) ifTrue:
+ [allWorkspaces add:
+ { window model.
+ window.
+ project.
+ window model contents ifEmpty:
+ [(window model dependents detect: [:d| d isTextView] ifNone: nil) textMorph contents] }]]].
+ allWorkspaces isEmpty ifTrue:
+ [^anUpdatingMenuMorph addItem:
+ [:item | item
+ contents: 'no workspaces found']].
+ "Sort workspaces with non-empty ones first..."
+ (allWorkspaces sorted:
+ [:t1 :t2|
+ t1 last isEmpty == t2 last isEmpty
+ ifTrue: [t1 second label <= t2 second label]
+ ifFalse: [t1 last notEmpty]]) do:
+ [:tuple|
+ anUpdatingMenuMorph addItem:
+ [:item | item
+ contents: tuple second label, ': ', ((tuple last asString contractTo: 128) ifEmpty: ['(empty)']);
+ target: self;
+ selector: #selectWorkspace:window:inProject:contents:;
+ arguments: tuple]]!
Item was changed:
----- Method: TheWorldMenu>>appearanceMenu (in category 'construction') -----
appearanceMenu
"Build the appearance menu for the world."
^self fillIn: (self menu: 'appearance...') from: {
{'preferences...' . { self . #openPreferencesBrowser} . 'Opens a "Preferences Browser" which allows you to alter many settings' } .
{'choose set of preferences...' . { Preferences . #offerThemesMenu} . 'Presents you with a menu of sets or preferences; each item''s balloon-help will tell you about the particular set. If you choose one, many different preferences that come along are set at the same time; you can subsequently change any settings by using a Preferences Panel'} .
nil .
{'system fonts...' . { self . #standardFontDo} . 'Choose the standard fonts to use for code, lists, menus, window titles, etc.'}.
- {'text highlight color...' . { Preferences . #chooseTextHighlightColor} . 'Choose which color should be used for text highlighting in Morphic.'}.
- {'insertion point color...' . { Preferences . #chooseInsertionPointColor} . 'Choose which color to use for the text insertion point in Morphic.'}.
- {'keyboard focus color' . { Preferences . #chooseKeyboardFocusColor} . 'Choose which color to use for highlighting which pane has the keyboard focus'}.
nil.
{#menuColorString . { self . #toggleMenuColorPolicy} . 'Governs whether menu colors should be derived from the desktop color.'}.
{#roundedCornersString . { self . #toggleRoundedCorners} . 'Governs whether morphic windows and menus should have rounded corners.'}.
nil.
{'full screen on' . { DisplayScreen . #fullScreenOn} . 'puts you in full-screen mode, if not already there.'}.
{'full screen off' . { DisplayScreen . #fullScreenOff} . 'if in full-screen mode, takes you out of it.'}.
nil.
{'set display depth...' . {self. #setDisplayDepth} . 'choose how many bits per pixel.'}.
{'set desktop color...' . {self. #changeBackgroundColor} . 'choose a uniform color to use as desktop background.'}.
{'set gradient color...' . {self. #setGradientColor} . 'choose second color to use as gradient for desktop background.'}.
{'use texture background' . { #myWorld . #setStandardTexture} . 'apply a graph-paper-like texture background to the desktop.'}.
nil.
{'clear turtle trails from desktop' . { #myWorld . #clearTurtleTrails} . 'remove any pigment laid down on the desktop by objects moving with their pens down.'}.
{'pen-trail arrowhead size...' . { Preferences. #setArrowheads} . 'choose the shape to be used in arrowheads on pen trails.'}.
}!
Item was changed:
----- Method: TheWorldMenu>>fillIn:from: (in category 'construction') -----
fillIn: aMenu from: dataForMenu
"A menu constructor utility by RAA. dataForMenu is a list of items which mean:
nil Indicates to add a line
first element is symbol Add updating item with the symbol as the wording selector
second element is a list second element has the receiver and selector
first element is a string Add menu item with the string as its wording
second element is a list second element has the receiver and selector
a third element exists Use it as the balloon text
a fourth element exists Use it as the enablement selector (updating case only)"
dataForMenu do: [ :itemData | | item |
itemData ifNil: [aMenu addLine] ifNotNil:
+ [item := itemData first isSymbol
- [item := (itemData first isKindOf: Symbol)
ifTrue:
[aMenu
addUpdating: itemData first
target: self
selector: #doMenuItem:with:
argumentList: {itemData second}]
ifFalse:
[aMenu
add: itemData first translated
target: self
selector: #doMenuItem:with:
argumentList: {itemData second}].
itemData size >= 3 ifTrue:
[aMenu balloonTextForLastItem: itemData third translated.
itemData size >= 4 ifTrue:
[item enablementSelector: itemData fourth]]]].
^ aMenu!
Item was changed:
----- Method: ThreePhaseButtonMorph class>>checkBox (in category 'instance creation') -----
checkBox
"Answer a button pre-initialized with checkbox images."
| f |
^self new
+ onImage: (f := (MenuIcons checkBoxOn dyed: Color red) scaleIconToDisplay);
+ pressedImage: (MenuIcons checkBoxPressed dyed: Color black) scaleIconToDisplay;
+ offImage: (MenuIcons checkBoxOff dyed: Color black) scaleIconToDisplay;
- onImage: (f := MenuIcons checkBoxOn dyed: Color red);
- pressedImage: (MenuIcons checkBoxPressed dyed: Color black);
- offImage: (MenuIcons checkBoxOff dyed: Color black);
extent: f extent + (2@0);
setDefaultParameters;
yourself
!
Item was changed:
----- Method: ThreePhaseButtonMorph class>>radioButton (in category 'instance creation') -----
radioButton
"Answer a button pre-initialized with radiobutton images."
| f |
^self new
+ onImage: (f := (MenuIcons radioButtonOn dyed: Color black) scaleIconToDisplay);
+ pressedImage: (MenuIcons radioButtonPressed dyed: Color black) scaleIconToDisplay;
+ offImage: (MenuIcons radioButtonOff dyed: Color black) scaleIconToDisplay;
- onImage: (f := MenuIcons radioButtonOn dyed: Color black);
- pressedImage: (MenuIcons radioButtonPressed dyed: Color black);
- offImage: (MenuIcons radioButtonOff dyed: Color black);
extent: f extent + (2@0);
setDefaultParameters;
yourself
!
Item was changed:
+ ----- Method: ThreePhaseButtonMorph>>actWhen: (in category 'submorphs - add/remove') -----
- ----- Method: ThreePhaseButtonMorph>>actWhen: (in category 'submorphs-add/remove') -----
actWhen: condition
"Accepts symbols: #buttonDown, #buttonUp, and #whilePressed"
actWhen := condition!
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: self currentEvent]
+ ifFalse: [arguments].
+ Cursor normal showWhile: [
+ target perform: actionSelector withArguments: args].
+ target isMorph ifTrue: [target changed]].!
- (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].
- target isMorph ifTrue: [target changed]]!
Item was added:
+ ----- Method: ThreePhaseButtonMorph>>isButton (in category 'classification') -----
+ isButton
+
+ ^ true
+ !
Item was changed:
----- Method: TopGripMorph>>apply: (in category 'target resize') -----
apply: delta
| oldBounds |
oldBounds := self target bounds.
self target
+ bounds: (oldBounds origin + (0 @ delta y) corner: oldBounds corner).
+ self flag: #workaround. "mt: Due to a layout-specific 'let us start in the top-left corner of a layout cell'-behavior, we have to go up the owner chain and propagate the delta. See Morph >> #layoutInBounds:positioning: and there section 1.2."
+ self target allOwnersDo:
+ [:anOwner |
+ (anOwner layoutPolicy notNil and: [anOwner ~~ Project current world])
+ ifTrue: [anOwner top: anOwner top + delta y]].!
- bounds: (oldBounds origin + (0 @ delta y) corner: oldBounds corner)!
Item was changed:
----- Method: TopLeftGripMorph>>apply: (in category 'target resize') -----
apply: delta
| oldBounds |
oldBounds := self target bounds.
self target
+ bounds: (oldBounds origin + delta corner: oldBounds corner).
+ self flag: #workaround. "mt: Due to a layout-specific 'let us start in the top-left corner of a layout cell'-behavior, we have to go up the owner chain and propagate the delta. See Morph >> #layoutInBounds:positioning: and there section 1.2."
+ self target allOwnersDo:
+ [:anOwner |
+ (anOwner layoutPolicy notNil and: [anOwner ~~ Project current world])
+ ifTrue: [anOwner topLeft: anOwner topLeft + delta]].!
- bounds: (oldBounds origin + delta corner: oldBounds corner)!
Item was changed:
----- Method: TopRightGripMorph>>apply: (in category 'target resize') -----
apply: delta
| oldBounds |
oldBounds := self target bounds.
self target
+ bounds: (oldBounds origin + (0@delta y) corner: oldBounds corner + (delta x @ 0)).
+ self flag: #workaround. "mt: Due to a layout-specific 'let us start in the top-left corner of a layout cell'-behavior, we have to go up the owner chain and propagate the delta. See Morph >> #layoutInBounds:positioning: and there section 1.2."
+ self target allOwnersDo:
+ [:anOwner |
+ (anOwner layoutPolicy notNil and: [anOwner ~~ Project current world])
+ ifTrue: [anOwner top: anOwner top + delta y]].!
- bounds: (oldBounds origin + (0@delta y) corner: oldBounds corner + (delta x @ 0))!
Item was changed:
Morph subclass: #TransferMorph
+ instanceVariableNames: 'transferType passenger draggedMorph source copy'
- instanceVariableNames: 'transferType passenger draggedMorph source dropNotifyRecipient resultRecipient copy'
classVariableNames: 'CopyPlusIcon'
poolDictionaries: ''
category: 'Morphic-Support'!
!TransferMorph commentStamp: 'nk 6/16/2003 16:52' prior: 0!
This is a Morph that is used to visually indicate the progress of a drag operation, and also as a container for various bits of drag state information.
It polls the shift state in its step method to update its copy state (shift pressed = should copy).
And if you hit the Escape key while dragging, it aborts the drag operation.!
Item was added:
+ ----- Method: TransferMorph>>createDraggableMorph: (in category 'initialization') -----
+ createDraggableMorph: anObject
+
+ (anObject respondsTo: #asDraggableMorph)
+ ifTrue: [^ anObject asDraggableMorph].
+
+ anObject isMorph
+ ifTrue: ["Huge or complex morphs have a serious impact on performance while being dragged. Use the thumbnail version."
+ ^ anObject thumbnail asMorph].
+
+ anObject isText
+ ifTrue: [
+ ^ anObject copy
+ addAttribute: (TextFontReference toFont: (self userInterfaceTheme font ifNil: [TextStyle defaultFont]));
+ asMorph].
+
+ ^ ((anObject respondsTo: #dragLabel) ifTrue: [anObject dragLabel] ifFalse: [anObject printString]) asMorph
+ color: (self userInterfaceTheme textColor ifNil: [Color black]);
+ font: (self userInterfaceTheme font ifNil: [TextStyle defaultFont])
+ yourself
+ !
Item was changed:
----- Method: TransferMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
self
changeTableLayout;
+ disableLayout: true;
listDirection: #leftToRight;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
layoutInset: 3;
cellGap: 3;
wrapCentering: #center;
cellPositioning: #leftCenter;
setProperty: #indicateKeyboardFocus toValue: #never.
self doMove.
self on: #keyStroke send: #keyStroke: to: self.
self on: #keyUp send: #updateFromUserInputEvent: to: self.
self on: #keyDown send: #updateFromUserInputEvent: to: self.
self setDefaultParameters.!
Item was added:
+ ----- Method: TransferMorph>>isTransferMorph (in category 'testing') -----
+ isTransferMorph
+
+ ^ true!
Item was changed:
----- Method: TransferMorph>>passenger: (in category 'accessing') -----
passenger: anObject
passenger := anObject.
self
removeAllMorphs;
+ addMorph: (self createDraggableMorph: passenger);
- addMorph: passenger asDraggableMorph;
updateCopyIcon;
setDefaultParameters.!
Item was changed:
----- Method: TransferMorph>>setDefaultParameters (in category 'initialization') -----
setDefaultParameters
self
+ borderWidth: ((self userInterfaceTheme borderWidth ifNil: [1]) * RealEstateAgent scaleFactor) truncated;
- 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]);
cornerStyle: (MenuMorph roundedMenuCorners ifTrue: [#rounded] ifFalse: [#square]).
self updateGradient.!
Item was changed:
----- Method: TransferMorph>>wantsToBeDroppedInto: (in category 'dropping/grabbing') -----
wantsToBeDroppedInto: aMorph
+
^ aMorph isWorldMorph
+ ifTrue: [aMorph wantsDroppedTransferMorph: self]
+ ifFalse: [super wantsToBeDroppedInto: aMorph]!
- ifTrue: [ aMorph hasTransferMorphConverter ]
- ifFalse: [ super wantsToBeDroppedInto: aMorph ]!
Item was added:
+ ----- Method: TransformMorph>>innocuousName (in category 'naming') -----
+ innocuousName
+
+ | r |
+ ^ (r := self renderedMorph) == self
+ ifTrue: [super innocuousName]
+ ifFalse: [r innocuousName]!
Item was added:
+ ----- Method: TransformMorph>>isRenderer (in category 'classification') -----
+ isRenderer
+
+ ^ submorphs size = 1
+ !
Item was added:
+ ----- Method: TransformMorph>>morphicLayerNumber (in category 'submorphs - layers') -----
+ morphicLayerNumber
+
+ ^ self isRenderer
+ ifTrue: [self renderedMorph morphicLayerNumber]
+ ifFalse: [super morphicLayerNumber]
+ !
Item was added:
+ ----- Method: TransformMorph>>morphicLayerNumber: (in category 'submorphs - layers') -----
+ morphicLayerNumber: aNumber
+
+ ^ self hasSubmorphs
+ ifFalse: [super morphicLayerNumber: aNumber]
+ ifTrue: [self firstSubmorph morphicLayerNumber: aNumber]!
Item was changed:
----- Method: TransformMorph>>offset: (in category 'accessing') -----
offset: newOffset
+ self offset = newOffset ifTrue: [^ self].
transform := transform withOffset: newOffset - self innerBounds topLeft.
+ self changed.!
- self changed!
Item was added:
+ ----- Method: TransformMorph>>renderedMorph (in category 'classification') -----
+ renderedMorph
+ "We are a renderer. Answer appropriately."
+
+ ^ self isRenderer
+ ifTrue: [self firstSubmorph renderedMorph]
+ ifFalse: [super renderedMorph]!
Item was changed:
----- Method: TransformMorph>>wantsHaloFromClick (in category 'halos and balloon help') -----
wantsHaloFromClick
+
+ ^ self hasSubmorphs not!
- ^ false!
Item was added:
+ ----- Method: TransformationMorph>>addFlexShellIfNecessary (in category 'rotate scale and flex') -----
+ addFlexShellIfNecessary
+ "I already am a flex shell."!
Item was removed:
- ----- Method: TransformationMorph>>degreesOfFlex (in category 'geometry eToy') -----
- degreesOfFlex
- "Return any rotation due to flexing"
- ^ self rotationDegrees!
Item was changed:
+ ----- Method: TransformationMorph>>forwardDirection (in category 'rotate scale and flex') -----
- ----- Method: TransformationMorph>>forwardDirection (in category 'accessing') -----
forwardDirection
"Return the rendee's forward direction.
If I have no rendee then return 0.0 degrees "
| rendee |
( rendee := self renderedMorph) == self ifTrue: [ ^ 0.0 ] .
^ rendee forwardDirection!
Item was changed:
+ ----- Method: TransformationMorph>>forwardDirection: (in category 'rotate scale and flex') -----
- ----- Method: TransformationMorph>>forwardDirection: (in category 'geometry eToy') -----
forwardDirection: degrees
"If we have a rendee set its forward direction. Else do nothing."
| rendee |
( rendee := self renderedMorph) == self ifTrue: [ ^ self ] .
^rendee forwardDirection: degrees!
Item was changed:
+ ----- Method: TransformationMorph>>heading (in category 'rotate scale and flex') -----
- ----- Method: TransformationMorph>>heading (in category 'geometry eToy') -----
heading
"End recusion when necessary."
| rendee |
(rendee := self renderedMorph) == self ifTrue: [ ^0.0 ] .
^ rendee heading!
Item was changed:
+ ----- Method: TransformationMorph>>heading: (in category 'rotate scale and flex') -----
- ----- Method: TransformationMorph>>heading: (in category 'geometry eToy') -----
heading: newHeading
"If we have a rendee set its heading. Else do nothing."
| rendee |
( rendee := self renderedMorph) == self ifTrue: [ ^ self ] .
^rendee heading: newHeading!
Item was removed:
- ----- Method: TransformationMorph>>innocuousName (in category 'naming') -----
- innocuousName
- | r |
- ^ (r := self renderedMorph) == self
- ifTrue: [super innocuousName] ifFalse: [r innocuousName]!
Item was removed:
- ----- Method: TransformationMorph>>isRenderer (in category 'classification') -----
- isRenderer
-
- ^ true
- !
Item was removed:
- ----- Method: TransformationMorph>>renderedMorph (in category 'classification') -----
- renderedMorph
- "We are a renderer. Answer appropriately."
-
- submorphs isEmpty ifTrue: [^self].
- ^self firstSubmorph renderedMorph!
Item was changed:
+ ----- Method: TransformationMorph>>replaceSubmorph:by: (in category 'submorphs - add/remove') -----
- ----- Method: TransformationMorph>>replaceSubmorph:by: (in category 'submorphs-add/remove') -----
replaceSubmorph: oldMorph by: newMorph
| t b |
t := transform.
b := bounds.
super replaceSubmorph: oldMorph by: newMorph.
transform := t.
bounds := b.
self layoutChanged!
Item was changed:
----- Method: TransformationMorph>>rotationDegrees (in category 'rotate scale and flex') -----
rotationDegrees
+ "Overwritten because we can directly inform about the rotation."
+
^ self angle radiansToDegrees negated!
Item was changed:
+ ----- Method: TransformationMorph>>rotationDegrees: (in category 'rotate scale and flex') -----
- ----- Method: TransformationMorph>>rotationDegrees: (in category 'accessing') -----
rotationDegrees: degrees
+ "Overwritten because we know how to rotate our submorphs."
+
self adjustAfter:[self angle: degrees degreesToRadians negated]!
Item was changed:
+ ----- Method: TransformationMorph>>setDirectionFrom: (in category 'rotate scale and flex') -----
- ----- Method: TransformationMorph>>setDirectionFrom: (in category 'geometry eToy') -----
setDirectionFrom: aPoint
| delta degrees inner |
inner := self renderedMorph.
inner == self ifTrue:[^self].
delta := (inner transformFromWorld globalPointToLocal: aPoint) - inner referencePosition.
degrees := delta degrees + 90.0.
self forwardDirection: (degrees \\ 360) rounded.
!
Item was removed:
- ----- Method: TransformationMorph>>wantsHaloFromClick (in category 'halos and balloon help') -----
- wantsHaloFromClick
-
- ^ self renderedMorph == self!
Item was added:
+ ----- Method: TranslucentProgessMorph>>initialize (in category 'initialization') -----
+ initialize
+
+ super initialize.
+ self morphicLayerNumber: self class progressLayer. !
Item was removed:
- ----- Method: TranslucentProgessMorph>>morphicLayerNumber (in category 'WiW support') -----
- morphicLayerNumber
-
- "helpful for insuring some morphs always appear in front of or behind others.
- smaller numbers are in front"
-
- ^self valueOfProperty: #morphicLayerNumber ifAbsent: [12].
-
- "progress morphs are behind menus and balloons, but in front of most other stuff"!
Item was changed:
----- Method: UpdatingStringMorph>>fitContents (in category 'layout') -----
fitContents
+ "Overridden to respect minimum and maximum widfth."
+
-
| newExtent |
+ newExtent := self measureContents.
+ self extent: ((newExtent x max: self minimumWidth) min: self maximumWidth) @ newExtent y.!
- newExtent := self measureContents.
- newExtent := ((newExtent x max: self minimumWidth) min: self maximumWidth) @ newExtent y.
- (self extent = newExtent) ifFalse:
- [self extent: newExtent.
- self changed]
- !
Item was changed:
----- Method: UpdatingStringMorph>>updateContentsFrom: (in category 'stepping') -----
updateContentsFrom: aValue
self growable
ifTrue:
+ [self contentsFitted: aValue]
- [self contents: aValue]
ifFalse:
[self contentsClipped: aValue]!
Item was changed:
----- Method: UserDialogBoxMorph class>>confirm:title:trueChoice:falseChoice:at: (in category 'utilities') -----
confirm: aString title: titleString trueChoice: trueChoice falseChoice: falseChoice at: aPointOrNil
"UserDialogBoxMorph confirm: 'Make your choice carefully' withCRs title: 'Do you like chocolate?' trueChoice: 'Oh yessir!!' falseChoice: 'Not so much...'"
^self new
title: titleString;
message: aString;
createButton: trueChoice translated value: true;
createButton: falseChoice translated value: false;
createCancelButton: 'Cancel' translated translated value: nil;
selectedButtonIndex: 1;
registerKeyboardShortcuts;
+ preferredPosition: (aPointOrNil ifNil: [Project current world center]);
- preferredPosition: (aPointOrNil ifNil: [ActiveWorld center]);
getUserResponse!
Item was changed:
----- Method: UserDialogBoxMorph class>>confirm:title:trueChoice:falseChoice:default:triggerAfter:at: (in category 'utilities') -----
confirm: aString title: titleString trueChoice: trueChoice falseChoice: falseChoice default: default triggerAfter: seconds at: aPointOrNil
"UserDialogBoxMorph confirm: 'I like hot java' title: 'What do you say?' trueChoice: 'You bet!!' falseChoice: 'Nope' default: false triggerAfter: 12 at: 121@212"
^self new
title: titleString;
message: aString;
createButton: trueChoice translated value: true;
createButton: falseChoice translated value: false;
createCancelButton: 'Cancel' translated translated value: nil;
selectedButtonIndex: (default ifTrue: [1] ifFalse: [2]);
registerKeyboardShortcuts;
+ preferredPosition: (aPointOrNil ifNil: [Project current world center]);
- preferredPosition: (aPointOrNil ifNil: [ActiveWorld center]);
getUserResponseAfter: seconds!
Item was changed:
----- Method: UserInputEvent>>anyModifierKeyPressed (in category 'modifier state') -----
anyModifierKeyPressed
+ "ignore, however, the shift keys 'cause that's not REALLY a modifier key "
- "ignore, however, the shift keys 'cause that's not REALLY a command key "
+ ^ self buttons anyMask: (2r1110 "cmd | opt | ctrl" bitShift: MouseEvent numButtons)!
- ^ self buttons anyMask: 16r70 "cmd | opt | ctrl"!
Item was changed:
----- Method: UserInputEvent>>commandKeyPressed (in category 'modifier state') -----
commandKeyPressed
"Answer true if the command key on the keyboard was being held down when this event occurred."
+ ^ self buttons anyMask: (2r1000 "cmd" bitShift: MouseEvent numButtons)!
- ^ buttons anyMask: 64!
Item was changed:
----- Method: UserInputEvent>>controlKeyPressed (in category 'modifier state') -----
controlKeyPressed
+ "Answer if the control key on the keyboard was being held down when this event occurred."
- "Answer true if the control key on the keyboard was being held down when this event occurred."
+ ^ self buttons anyMask: (2r0010 "ctrl" bitShift: MouseEvent numButtons)!
- ^ buttons anyMask: 16!
Item was changed:
----- Method: UserInputEvent>>modifierString (in category 'printing') -----
modifierString
"Return a string identifying the currently pressed modifiers"
| string |
string := ''.
+ self controlKeyPressed ifTrue:[string := string,'CTRL '].
+ self optionKeyPressed ifTrue:[string := string,'OPT '].
self commandKeyPressed ifTrue:[string := string,'CMD '].
self shiftPressed ifTrue:[string := string,'SHIFT '].
- self controlKeyPressed ifTrue:[string := string,'CTRL '].
^string!
Item was added:
+ ----- Method: UserInputEvent>>modifiers (in category 'accessing') -----
+ modifiers
+
+ ^ Array streamContents: [:s |
+ self controlKeyPressed ifTrue: [s nextPut: #ctrl].
+ self optionKeyPressed ifTrue:[s nextPut: #opt].
+ self commandKeyPressed ifTrue:[s nextPut: #cmd].
+ self shiftPressed ifTrue:[s nextPut: #shift]]!
Item was added:
+ ----- Method: UserInputEvent>>optionKeyPressed (in category 'modifier state') -----
+ optionKeyPressed
+ "Answer if the option key on the keyboard was being held down when this event occurred."
+
+ ^ self buttons anyMask: (2r0100 "opt" bitShift: MouseEvent numButtons)!
Item was changed:
----- Method: UserInputEvent>>shiftPressed (in category 'modifier state') -----
shiftPressed
"Answer true if the shift key on the keyboard was being held down when this event occurred."
+ ^ self buttons anyMask: (2r0001 "shift" bitShift: MouseEvent numButtons)!
- ^ buttons anyMask: 8
- !
Item was changed:
----- Method: WindowEvent>>type (in category 'accessing') -----
type
"This should match the definitions in sq.h"
^#(
windowMetricChange
windowClose
windowIconise
windowActivated
windowPaint
+ windowChangedScreen
+ windowDeactivated
) at: action ifAbsent: [#windowEventUnknown]!
Item was changed:
Object subclass: #WorldState
+ instanceVariableNames: 'hands viewBox canvas damageRecorder stepList lastStepTime lastStepMessage lastCycleTime commandHistory alarms lastAlarmTime remoteServer multiCanvas interCycleDelay'
- instanceVariableNames: 'hands activeHand viewBox canvas damageRecorder stepList lastStepTime lastStepMessage lastCycleTime commandHistory alarms lastAlarmTime remoteServer multiCanvas interCycleDelay'
classVariableNames: 'CanSurrenderToOS DeferredUIMessages DisableDeferredUpdates LastCycleTime MinCycleLapse'
poolDictionaries: ''
category: 'Morphic-Worlds'!
!WorldState commentStamp: 'ls 7/10/2003 19:30' prior: 0!
The state of a Morphic world. (This needs some serious commenting!!!!)
The MinCycleLapse variable holds the minimum amount of time that a morphic cycle is allowed to take. If a cycle takes less than this, then interCyclePause: will wait until the full time has been used up.!
Item was removed:
- ----- Method: WorldState class>>cleanUp (in category 'class initialization') -----
- cleanUp
- "Reset command histories"
-
- self allInstances do: [ :ea | ea clearCommandHistory ].!
Item was added:
+ ----- Method: WorldState class>>cleanUp: (in category 'class initialization') -----
+ cleanUp: aggressive
+
+ self allInstancesDo: [:worldState | worldState cleanUp: aggressive].!
Item was added:
+ ----- Method: WorldState class>>disableDeferredUpdates (in category 'accessing') -----
+ disableDeferredUpdates
+
+ ^DisableDeferredUpdates ifNil: [DisableDeferredUpdates := false]
+ !
Item was added:
+ ----- Method: WorldState class>>disableDeferredUpdates: (in category 'accessing') -----
+ disableDeferredUpdates: aBoolean
+ "If the argument is true, disable deferred screen updating."
+ "Details: When deferred updating is used, Morphic performs double-buffered screen updates by telling the VM to de-couple the Display from the hardware display buffer, drawing directly into the Display, and then forcing the changed regions of the Display to be copied to the screen. This saves both time (an extra BitBlt is avoided) and space (an extra display buffer is avoided). However, on platforms on which the Display points directly to the hardware screen buffer, deferred updating can't be used (you'd see ugly flashing as the layers of the drawing were assembled). In this case, the drawing is composited into an offscreen FormCanvas and then copied to the hardware display buffer."
+
+ DisableDeferredUpdates := aBoolean.
+ !
Item was added:
+ ----- Method: WorldState class>>lastDeferredUIMessage (in category 'class initialization') -----
+ lastDeferredUIMessage
+ "Answer the most recently scheduled deferredUIMessage."
+
+ ^self deferredUIMessages peekLast!
Item was removed:
- ----- Method: WorldState>>activeHand (in category 'hands') -----
- activeHand
-
- ^ ActiveHand!
Item was added:
+ ----- Method: WorldState>>cleanUp: (in category 'initialization') -----
+ cleanUp: aggressive
+
+ self clearCommandHistory.
+ self handsDo: [:hand | hand cleanUp: aggressive].!
Item was changed:
----- Method: WorldState>>doDeferredUpdatingFor: (in category 'update cycle') -----
doDeferredUpdatingFor: aWorld
"If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, do nothing and answer false. One can set the class variable DisableDeferredUpdates to true to completely disable the deferred updating feature."
| properDisplay |
+ DisableDeferredUpdates ifTrue: [^ false].
- PasteUpMorph disableDeferredUpdates ifTrue: [^ false].
(Display deferUpdates: true) ifNil: [^ false]. "deferred updates not supported"
remoteServer ifNotNil:[
self assuredCanvas.
^true].
properDisplay := canvas notNil and: [canvas form == Display].
aWorld == Project current world ifTrue: [ "this world fills the entire Display"
properDisplay ifFalse: [
aWorld viewBox: Display boundingBox. "do first since it may clear canvas"
self canvas: (Display getCanvas copyClipRect: Display boundingBox).
]
].
^ true
!
Item was changed:
----- Method: WorldState>>doOneCycleNowFor: (in category 'update cycle') -----
doOneCycleNowFor: aWorld
"Immediately do one cycle of the interaction loop.
This should not be called directly, but only via doOneCycleFor:"
| capturingGesture |
+ DisplayScreen checkForNewScreenScaleFactor; checkForNewScreenSize.
- DisplayScreen checkForNewScreenSize.
capturingGesture := false.
"self flag: #bob. " "need to consider remote hands in lower worlds"
+
-
"process user input events"
LastCycleTime := Time millisecondClockValue.
+ self handsDo: [:hand |
+ hand becomeActiveDuring: [
+ hand processEvents.
+ capturingGesture := capturingGesture or: [hand isCapturingGesturePoints]]].
+
- self handsDo: [:h |
- ActiveHand := h.
- h processEvents.
- capturingGesture := capturingGesture or: [ h isCapturingGesturePoints ].
- ActiveHand := nil
- ].
-
- "the default is the primary hand"
- ActiveHand := self hands first.
-
"The gesture recognizer needs enough points to be accurate.
Therefore morph stepping is disabled while capturing points for the recognizer"
+ capturingGesture ifFalse: [
+ aWorld runStepMethods. "there are currently some variations here"
+ self displayWorldSafely: aWorld].!
- capturingGesture ifFalse:
- [aWorld runStepMethods. "there are currently some variations here"
- self displayWorldSafely: aWorld].
- !
Item was changed:
----- Method: WorldState>>doOneSubCycleFor: (in category 'update cycle') -----
doOneSubCycleFor: aWorld
- "Like doOneCycle, but preserves activeHand."
+ self flag: #deprecate. "ct: Historically, global state was preserved here. Since the introduction of ActiveHandVariable, this is no longer necessary, so this is equivalent to #doOneCycleFor:. However, let's keep this possibly valuable hook for now."
+
+ ^ self doOneCycleFor: aWorld!
- | currentHand |
- currentHand := ActiveHand.
- self doOneCycleFor: aWorld.
- ActiveHand := currentHand!
Item was added:
+ ----- Method: WorldState>>primaryHand (in category 'hands') -----
+ primaryHand
+
+ self flag: #deprecated. "ct: Send #primaryHand to #currentWorld instead."
+ ^ self currentWorld primaryHand!
Item was changed:
----- Method: WorldState>>removeHand: (in category 'hands') -----
removeHand: aHandMorph
"Remove the given hand from the list of hands for this world."
+ (hands includes: aHandMorph) ifFalse: [^ self].
+ self currentHand == aHandMorph ifTrue: [
+ self flag: #invalidate. "ct: Should we try to clear ActiveHandVariable here or doesn't this matter? In past, ActiveHand was set to nil at this point."].
+ hands := hands copyWithout: aHandMorph.!
- (hands includes: aHandMorph) ifFalse: [^self].
- hands := hands copyWithout: aHandMorph.
- ActiveHand == aHandMorph ifTrue: [ActiveHand := nil].
- !
Item was changed:
----- Method: WorldState>>runLocalStepMethodsIn: (in category 'stepping') -----
runLocalStepMethodsIn: aWorld
"Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world.
ar 3/13/1999: Remove buggy morphs from the step list so that they don't raise repeated errors."
+ | now morphToStep stepTime |
- | now morphToStep stepTime priorWorld |
now := Time millisecondClockValue.
+
+ aWorld becomeActiveDuring: [
+ self triggerAlarmsBefore: now.
+
+ stepList ifEmpty: [^ self].
+
+ (now < lastStepTime or: [now - lastStepTime > 5000]) ifTrue: [
+ self adjustWakeupTimes: now]. "clock slipped"
+
+ [stepList notEmpty and: [stepList first scheduledTime < now]] whileTrue: [
+ lastStepMessage := stepList removeFirst.
- priorWorld := ActiveWorld.
- ActiveWorld := aWorld.
- self triggerAlarmsBefore: now.
- stepList isEmpty
- ifTrue:
- [ActiveWorld := priorWorld.
- ^self].
- (now < lastStepTime or: [now - lastStepTime > 5000])
- ifTrue: [self adjustWakeupTimes: now]. "clock slipped"
- [stepList isEmpty not and: [stepList first scheduledTime < now]]
- whileTrue:
- [lastStepMessage := stepList removeFirst.
morphToStep := lastStepMessage receiver.
+ (morphToStep shouldGetStepsFrom: aWorld) ifTrue: [
+ lastStepMessage value: now.
+ lastStepMessage ifNotNil: [
+ stepTime := lastStepMessage stepTime ifNil: [morphToStep stepTime].
+ lastStepMessage scheduledTime: now + (stepTime max: 1).
+ stepList add: lastStepMessage]].
- (morphToStep shouldGetStepsFrom: aWorld)
- ifTrue:
- [lastStepMessage value: now.
- lastStepMessage ifNotNil:
- [stepTime := lastStepMessage stepTime ifNil: [morphToStep stepTime].
- lastStepMessage scheduledTime: now + (stepTime max: 1).
- stepList add: lastStepMessage]].
lastStepMessage := nil].
+
+ lastStepTime := now].!
- lastStepTime := now.
- ActiveWorld := priorWorld!
Item was changed:
+ (PackageInfo named: 'Morphic') postscript: 'Preferences maxBalloonHelpLineLength: 45.'!
- (PackageInfo named: 'Morphic') postscript: 'PluggableListMorph allSubInstancesDo: [:m |
- m scroller layoutPolicy: TableLayout new.
- m listMorph
- cellPositioning: #leftCenter;
- cellInset: 3@0;
- vResizing: #shrinkWrap;
- removeProperty: #errorOnDraw. "Just in case."
- m updateList.
- m hScrollBarPolicy: #never].
- '!
1
0
Christoph Thiede uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-ct.1587.mcz
==================== Summary ====================
Name: Morphic-ct.1587
Author: ct
Time: 10 November 2019, 7:45:50.611559 pm
UUID: 8e927769-03b3-2946-be0e-f116cbd279a8
Ancestors: Morphic-mt.1584
Proposal: Add ultimative emphasisExtra "Custom attribute"
=============== Diff against Morphic-mt.1584 ===============
Item was changed:
----- Method: SmalltalkEditor>>emphasisExtras (in category 'editing keys') -----
emphasisExtras
^#(
'Do it'
'Print it'
'Style it'
'Link to comment of class'
'Link to definition of class'
'Link to hierarchy of class'
'Link to method'
'URL Link'
+ 'Custom attribute'
).!
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].
[attribute := TextPrintIt new.
thisSel := attribute analyze: self selection].
[thisSel := self styleSelection].
[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].
+ [| input |
+ input := UIManager default request: 'Enter attribute expression:'.
+ input isEmptyOrNil ifTrue: [^ false].
+ attribute := Compiler evaluate: input.
+ thisSel := self selection].
["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"
(thisSel isEmpty and: [attribute notNil])
ifTrue: [
| oldAttributes |
"only change emphasisHere while typing"
oldAttributes := paragraph text attributesAt: self pointIndex.
emphasisHere := Text addAttribute: attribute toArray: oldAttributes]
ifFalse: [
self replaceSelectionWith: (attribute ifNil: [thisSel] ifNotNil: [thisSel asText addAttribute: attribute]) ].
^ true!
1
0