[Pkg] The Trunk: Morphic-nice.276.mcz
commits at source.squeak.org
commits at source.squeak.org
Sun Dec 27 19:24:18 UTC 2009
Nicolas Cellier uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-nice.276.mcz
==================== Summary ====================
Name: Morphic-nice.276
Author: nice
Time: 27 December 2009, 8:22:38 am
UUID: 5f5ab052-6b01-4888-a5ee-81ab371c7763
Ancestors: Morphic-nice.275
Cosmetic: move or remove a few temps inside closures
=============== Diff against Morphic-nice.275 ===============
Item was changed:
----- Method: TableLayout>>indexForInserting:inList:horizontal:target: (in category 'utilities') -----
indexForInserting: aPoint inList: morphList horizontal: aBool target: aMorph
+ | cmp1 cmp2 cmp3 noWrap |
- | box cmp1 cmp2 cmp3 noWrap |
properties := aMorph layoutProperties.
noWrap := properties wrapDirection == #none.
aBool
ifTrue:
["horizontal"
properties listDirection == #rightToLeft
ifTrue: [cmp1 := [:rect | aPoint x > rect left]]
ifFalse: [cmp1 := [:rect | aPoint x < rect right]].
properties wrapDirection == #bottomToTop
ifTrue:
[cmp2 := [:rect | aPoint y > rect top].
cmp3 := [:rect | aPoint y > rect bottom]]
ifFalse:
[cmp2 := [:rect | aPoint y < rect bottom].
cmp3 := [:rect | aPoint y < rect top]]]
ifFalse:
["vertical"
properties listDirection == #bottomToTop
ifTrue: [cmp1 := [:rect | aPoint y > rect top]]
ifFalse: [cmp1 := [:rect | aPoint y < rect bottom]].
properties wrapDirection == #rightToLeft
ifTrue:
[cmp2 := [:rect | aPoint x > rect left].
cmp3 := [:rect | aPoint x > rect right]]
ifFalse:
[cmp2 := [:rect | aPoint x < rect right].
cmp3 := [:rect | aPoint x < rect left]]].
morphList keysAndValuesDo:
+ [:index :m | | box |
- [:index :m |
self flag: #arNote. "it is not quite clear if we can really use #fullBounds here..."
box := m fullBounds.
noWrap
ifTrue:
["Only in one direction"
(cmp1 value: box) ifTrue: [^index]]
ifFalse:
["Check for inserting before current row"
(cmp3 value: box) ifTrue: [^index].
"Check for inserting before current cell"
((cmp1 value: box) and: [cmp2 value: box]) ifTrue: [^index]]].
^morphList size + 1!
Item was changed:
----- Method: MenuItemMorph>>invokeWithEvent: (in category 'events') -----
invokeWithEvent: evt
"Perform the action associated with the given menu item."
+ | w |
- | selArgCount w |
self isEnabled ifFalse: [^ self].
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."
(w := self world) ifNotNil:[
owner deleteIfPopUp: evt.
"Repair damage before invoking the action for better feedback"
w displayWorldSafely]]].
selector ifNil:[^self].
+ Cursor normal showWhile: [ | selArgCount | "show cursor in case item opens a new MVC window"
- Cursor normal showWhile: [ "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: PasteUpMorph>>releaseSqueakPages (in category 'project') -----
releaseSqueakPages
+
- | uu |
"If this world has a book with SqueakPages, then clear the SqueakPageCache"
+ submorphs do: [:sub | | uu |
+ (sub isKindOf: BookMorph) ifTrue: [
- submorphs do: [:sub | (sub isKindOf: BookMorph) ifTrue: [
uu := sub valueOfProperty: #url ifAbsent: [nil].
uu ifNotNil: [(SqueakPageCache pageCache includesKey: uu) ifTrue: [
SqueakPageCache initialize]]]]. "wipe the cache"!
Item was changed:
----- Method: PasteUpMorph>>pauseEventRecorder (in category 'world state') -----
pauseEventRecorder
"Suspend any event recorder, and return it if found"
+
+ worldState handsDo: [:h | | er | (er := h pauseEventRecorderIn: self) ifNotNil: [^ er]].
- | er |
- worldState handsDo: [:h | (er := h pauseEventRecorderIn: self) ifNotNil: [^ er]].
^ nil!
Item was changed:
----- Method: PasteUpMorph>>findAPreferencesPanel: (in category 'world menu') -----
findAPreferencesPanel: evt
"Locate a Preferences Panel, open it, and bring it to the front. Create one if necessary"
- | aPanel |
self findAWindowSatisfying:
[:aWindow | aWindow model isKindOf: PreferenceBrowser] orMakeOneUsing:
+ [ | aPanel |
+ aPanel := PreferenceBrowserMorph withModel: PreferenceBrowser new.
- [aPanel := PreferenceBrowserMorph withModel: PreferenceBrowser new.
"Note -- we don't really want the openInHand -- but owing to some annoying
difficulty, if we don't, we get the wrong width. Somebody please clean this up"
^ aPanel openInHand]!
Item was changed:
----- Method: PasteUpMorph>>updateTrailsForm (in category 'pen') -----
updateTrailsForm
"Update the turtle-trails form using the current positions of all pens.
Only used in conjunction with Preferences batchPenTrails."
"Details: The positions of all morphs with their pens down are recorded each time the draw method is called. If the list from the previous display cycle isn't empty, then trails are drawn from the old to the new positions of those morphs on the turtle-trails form. The turtle-trails form is created on demand when the first pen is put down and removed (to save space) when turtle trails are cleared."
+ | removals |
- | morph oldPoint newPoint removals player tfm |
self flag: #bob. "transformations WRONG here"
(lastTurtlePositions isNil or: [lastTurtlePositions isEmpty])
ifTrue: [^self].
removals := OrderedCollection new.
lastTurtlePositions associationsDo:
+ [:assoc | | player oldPoint newPoint morph tfm |
- [:assoc |
player := assoc key.
morph := player costume.
(player getPenDown and: [morph trailMorph == self])
ifTrue:
[oldPoint := assoc value.
tfm := morph owner transformFrom: self.
newPoint := tfm localPointToGlobal: morph referencePosition.
newPoint = oldPoint
ifFalse:
[assoc value: newPoint.
self
drawPenTrailFor: morph
from: oldPoint
to: newPoint]]
ifFalse: [removals add: player]].
removals do: [:key | lastTurtlePositions removeKey: key ifAbsent: []]!
Item was changed:
----- Method: PluggableListMorph>>list: (in category 'initialization') -----
list: listOfStrings
"lex doesn't think this is used any longer, but is not yet brave enough to remove it. It should be removed eventually"
"Set the receiver's list as specified"
+ | morphList h index converter aSelector textColor font loc |
- | morphList h loc index converter item aSelector textColor font |
scroller removeAllMorphs.
list := listOfStrings ifNil: [Array new].
list isEmpty ifTrue: [self setScrollDeltas. ^ self selectedMorph: nil].
"NOTE: we will want a quick StringMorph init message, possibly even
combined with event install and positioning"
font ifNil: [font := Preferences standardListFont].
converter := self valueOfProperty: #itemConversionMethod.
converter ifNil: [converter := #asStringOrText].
textColor := self valueOfProperty: #textColor.
+ morphList := list collect: [:each | | stringMorph item |
- morphList := list collect: [:each | | stringMorph |
item := each.
item := item perform: converter.
stringMorph := item isText
ifTrue: [StringMorph contents: item font: font emphasis: (item emphasisAt: 1)]
ifFalse: [StringMorph contents: item font: font].
textColor ifNotNil: [ stringMorph color: textColor ].
stringMorph
].
(aSelector := self valueOfProperty: #balloonTextSelectorForSubMorphs)
ifNotNil:
[morphList do: [:m | m balloonTextSelector: aSelector]].
self highlightSelector ifNotNil:
[model perform: self highlightSelector with: list with: morphList].
"Lay items out vertically and install them in the scroller"
h := morphList first height "self listItemHeight".
loc := 0 at 0.
morphList do: [:m | m bounds: (loc extent: 9999 at h). loc := loc + (0 at h)].
scroller addAllMorphs: morphList.
index := self getCurrentSelectionIndex.
self selectedMorph: ((index = 0 or: [index > morphList size]) ifTrue: [nil] ifFalse: [morphList at: index]).
self setScrollDeltas.
scrollBar setValue: 0.0!
Item was changed:
----- Method: PluggableTextMorph>>tileForIt (in category 'menu commands') -----
tileForIt
"Return a tile referring to the object resulting form evaluating my current selection. Not currently threaded in, but useful in earlier demos and possibly still of value."
+
- | result |
self handleEdit:
+ [ | result |
+ result := textMorph editor evaluateSelection.
- [result := textMorph editor evaluateSelection.
((result isKindOf: FakeClassPool) or: [result == #failedDoit])
ifTrue: [self flash]
ifFalse: [self currentHand attachMorph: result tileToRefer]]!
Item was changed:
----- Method: Morph>>completeModificationHash (in category 'testing') -----
completeModificationHash
"World completeModificationHash"
+ | resultSize result |
- | resultSize result here i |
resultSize := 10.
result := ByteArray new: resultSize.
+ self allMorphsDo: [ :each | | here |
- self allMorphsDo: [ :each |
here := each modificationHash.
+ here withIndexDo: [ :ch :index | | i |
- here withIndexDo: [ :ch :index |
i := index \\ resultSize + 1.
result at: i put: ((result at: i) bitXor: ch asciiValue)
].
].
^result!
Item was changed:
----- Method: WorldState>>convertStepList (in category 'object fileIn') -----
convertStepList
"Convert the old-style step list (an Array of Arrays) into the new-style StepMessage heap"
+ | newList |
- | newList wakeupTime morphToStep |
(stepList isKindOf: Heap)
ifTrue:
[^stepList sortBlock: self stepListSortBlock "ensure that we have a cleaner block"].
newList := Heap sortBlock: self stepListSortBlock.
stepList do:
+ [:entry | | wakeupTime morphToStep |
- [:entry |
wakeupTime := entry second.
morphToStep := entry first.
newList add: (StepMessage
scheduledAt: wakeupTime
stepTime: nil
receiver: morphToStep
selector: #stepAt:
arguments: nil)].
stepList := newList!
Item was changed:
----- Method: ProportionalLayout>>minExtentOf:in: (in category 'layout') -----
minExtentOf: aMorph in: newBounds
"Return the minimal size aMorph's children would require given the new bounds"
+ | min |
- | min extent frame |
min := 0 at 0.
+ aMorph submorphsDo:[:m| | extent frame |
- aMorph submorphsDo:[:m|
"Map the minimal size of the child through the layout frame.
Note: This is done here and not in the child because its specific
for proportional layouts. Perhaps we'll generalize this for table
layouts but I'm not sure how and when."
extent := m minExtent.
frame := m layoutFrame.
frame ifNotNil:[extent := frame minExtentFrom: extent].
min := min max: extent].
^min!
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 messageSend |
dict := IdentityDictionary new.
self defaultDesktopCommandKeyTriplets do:
+ [:trip | | messageSend |
- [:trip |
messageSend := MessageSend receiver: trip second selector: trip third.
dict at: trip first put: messageSend].
self setProperty: #commandKeySelectors toValue: dict.
^ dict
!
Item was changed:
----- Method: MorphicModel class>>removeUninstantiatedModels (in category 'housekeeping') -----
removeUninstantiatedModels
"With the user's permission, remove the classes of any models that have neither instances nor subclasses."
"MorphicModel removeUninstantiatedModels"
+ | candidatesForRemoval |
- | candidatesForRemoval ok |
Smalltalk garbageCollect.
candidatesForRemoval :=
MorphicModel subclasses select: [:c |
(c instanceCount = 0) and: [c subclasses size = 0]].
+ candidatesForRemoval do: [:c | | ok |
- candidatesForRemoval do: [:c |
ok := self confirm: 'Are you certain that you
want to delete the class ', c name, '?'.
ok ifTrue: [c removeFromSystem]].
!
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 m |
index := (submorphs indexOf: selectedItem ifAbsent: [1-direction]) + direction.
submorphs do: "Ensure finite"
+ [:unused | | m |
+ m := submorphs atWrap: index.
- [:unused | 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: PolygonMorph>>nudgeForLabel: (in category 'attachments') -----
nudgeForLabel: aRectangle
"Try to move the label off me. Prefer labels on the top and right."
| i flags nudge |
(self bounds intersects: aRectangle) ifFalse: [^ 0 at 0 ].
flags := 0.
nudge := 0 at 0.
i := 1.
+ aRectangle lineSegmentsDo: [ :rp1 :rp2 | | rectSeg |
- aRectangle lineSegmentsDo: [ :rp1 :rp2 | | rectSeg int |
rectSeg := LineSegment from: rp1 to: rp2.
+ self straightLineSegmentsDo: [ :lp1 :lp2 | | polySeg int |
- self straightLineSegmentsDo: [ :lp1 :lp2 | | polySeg |
polySeg := LineSegment from: lp1 to: lp2.
int := polySeg intersectionWith: rectSeg.
int ifNotNil: [ flags := flags bitOr: i ].
].
i := i * 2.
].
"Now flags has bitflags for which sides"
nudge := flags caseOf: {
"no intersection"
[ 0 ] -> [ 0 at 0 ].
"2 adjacent sides only"
[ 9 ] -> [ 1 at 1 ].
[ 3 ] -> [ -1 at 1 ].
[ 12 ] -> [ 1 at -1 ].
[ 6 ] -> [ -1 at -1 ].
"2 opposite sides only"
[ 10 ] -> [ 0 at -1 ].
[ 5 ] -> [ 1 at 0 ].
"only 1 side"
[ 8 ] -> [ -1 at 0 ].
[ 1 ] -> [ 0 at -1 ].
[ 2 ] -> [ 1 at 0 ].
[ 4 ] -> [ 0 at 1 ].
"3 sides"
[ 11 ] -> [ 0 at 1 ].
[ 13 ] -> [ 1 at 0 ].
[ 14 ] -> [ 0 at -1 ].
[ 7 ] -> [ -1 at 0 ].
"all sides"
[ 15 ] -> [ 1 at -1 "move up and to the right" ].
}.
^nudge!
Item was changed:
----- Method: PasteUpMorph>>relaunchAllViewers (in category 'scripting') -----
relaunchAllViewers
"Relaunch all the viewers in the project"
+
- | aViewer |
(self submorphs select: [:m | m isKindOf: ViewerFlapTab]) do:
+ [:aTab | | aViewer |
- [:aTab |
aViewer := aTab referent submorphs
detect: [:sm | sm isStandardViewer]
ifNone: [nil].
aViewer ifNotNil: [aViewer relaunchViewer]
"ActiveWorld relaunchAllViewers"]!
Item was changed:
----- Method: FileList2 class>>addFullPanesTo:from: (in category 'utility') -----
addFullPanesTo: window from: aCollection
+
- | frame |
+ aCollection do: [ :each | | frame |
- aCollection do: [ :each |
frame := LayoutFrame
fractions: each second
offsets: each third.
window addMorph: each first fullFrame: frame.
]!
Item was changed:
----- 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 |
- | isBack found 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 |
- [:m |
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: HandMorph>>nonCachingFullDrawOn: (in category 'drawing') -----
nonCachingFullDrawOn: aCanvas
+
- | shadowForm |
"A HandMorph has unusual drawing requirements:
1. the hand itself (i.e., the cursor) appears in front of its submorphs
2. morphs being held by the hand cast a shadow on the world/morphs below
The illusion is that the hand plucks up morphs and carries them above the world."
"Note: This version does not cache an image of the morphs being held by the hand.
Thus, it is slower for complex morphs, but consumes less space."
submorphs isEmpty ifTrue: [^ self drawOn: aCanvas]. "just draw the hand itself"
aCanvas asShadowDrawingCanvas
+ translateBy: self shadowOffset during:[:shadowCanvas| | shadowForm |
- translateBy: self shadowOffset during:[:shadowCanvas|
"Note: We use a shadow form here to prevent drawing
overlapping morphs multiple times using the transparent
shadow color."
shadowForm := self shadowForm.
"
shadowForm displayAt: shadowForm offset negated. Display forceToScreen: (0 at 0 extent: shadowForm extent).
"
shadowCanvas paintImage: shadowForm at: shadowForm offset. "draw shadows"
].
"draw morphs in front of shadows"
self drawSubmorphsOn: aCanvas.
self drawOn: aCanvas. "draw the hand itself in front of morphs"
!
Item was changed:
----- Method: FileList2 class>>endingSpecs (in category 'blue ui') -----
endingSpecs
"Answer a collection of specs to build the selective 'find anything' tool called by the Navigator. This version uses the services registry to do so."
"FileList2 morphicViewGeneralLoaderInWorld: World"
+ | categories specs rejects |
- | categories services specs rejects |
rejects := #(addFileToNewZip: compressFile: openInZipViewer: extractAllFrom: openOn:).
categories := #(
('Art' ('bmp' 'gif' 'jpg' 'jpeg' 'form' 'png' 'pcx' 'xbm' 'xpm' 'ppm' 'pbm'))
('Morphs' ('morph' 'morphs' 'sp'))
('Projects' ('extseg' 'project' 'pr'))
('MIDI' ('mid' 'midi'))
('Music' ('mp3'))
('Movies' ('movie' 'mpg' 'mpeg' 'qt' 'mov'))
('Flash' ('swf'))
).
"('Books' ('bo'))"
"('Code' ('st' 'cs'))"
"('TrueType' ('ttf'))"
"('3ds' ('3ds'))"
"('Tape' ('tape'))"
"('Wonderland' ('wrl'))"
"('HTML' ('htm' 'html'))"
categories first at: 2 put: ImageReadWriter allTypicalFileExtensions.
specs := OrderedCollection new.
+ categories do: [ :cat | | catSpecs catServices okExtensions services |
- categories do: [ :cat | | catSpecs catServices okExtensions |
services := Dictionary new.
catSpecs := Array new: 3.
catServices := OrderedCollection new.
okExtensions := Set new.
cat second do: [ :ext | (FileList itemsForFile: 'fred.',ext) do: [ :i |
(rejects includes: i selector) ifFalse: [
okExtensions add: ext.
services at: i label put: i ]]].
services do: [ :svc | catServices add: svc ].
services isEmpty ifFalse: [
catSpecs at: 1 put: cat first;
at: 2 put: okExtensions;
at: 3 put: catServices.
specs add: catSpecs ]
].
^specs
!
Item was changed:
----- Method: MatrixTransformMorph>>computeBounds (in category 'geometry') -----
computeBounds
+ | box |
- | subBounds box |
(submorphs isNil or:[submorphs isEmpty]) ifTrue:[^self].
box := nil.
+ submorphs do:[:m| | subBounds |
- submorphs do:[:m|
subBounds := self transform localBoundsToGlobal: m bounds.
box
ifNil:[box := subBounds]
ifNotNil:[box := box quickMerge: subBounds].
].
box ifNil:[box := 0 at 0 corner: 20 at 20].
fullBounds := bounds := box!
Item was changed:
----- Method: SystemProgressMorph>>nextSlotFor: (in category 'private') -----
nextSlotFor: shortDescription
+
+ lock critical: [ | label bar slots |
- | bar slots label |
- lock critical: [
slots := labels size.
activeSlots = slots ifTrue: [^0].
activeSlots := activeSlots + 1.
1 to: slots do: [:index |
label := (labels at: index).
label ifNil: [
bar := bars at: index put: (SystemProgressBarMorph new extent: BarWidth at BarHeight).
label := labels at: index put: (StringMorph contents: shortDescription font: font).
self
addMorphBack: label;
addMorphBack: bar.
^index].
label owner ifNil: [
bar := bars at: index.
label := labels at: index.
self
addMorphBack: (label contents: shortDescription);
addMorphBack: (bar barSize: 0).
^index]]]
!
Item was changed:
----- Method: ColorPickerMorph class>>colorPaletteForDepth:extent: (in category 'class initialization') -----
colorPaletteForDepth: depth extent: chartExtent
"Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively."
"Note: It is slow to build this palette, so it should be cached for quick access."
"(Color colorPaletteForDepth: 16 extent: 190 at 60) display"
+ | startHue palette transHt vSteps transCaption grayWidth hSteps y c x |
- | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps |
palette := Form extent: chartExtent depth: depth.
transCaption := "(DisplayText text: 'no color' asText textStyle: (TextConstants at: #ComicPlain)) form storeString"
(Form extent: 34 at 9 depth: 1
fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0)
offset: 0 at 0).
transHt := transCaption height.
palette fillWhite: (0 at 0 extent: palette width at transHt).
palette fillBlack: (0 at transHt extent: palette width at 1).
transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0).
grayWidth := 10.
startHue := 338.0.
vSteps := palette height - transHt // 2.
hSteps := palette width - grayWidth.
x := 0.
+ startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | | basicHue |
- startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h |
basicHue := Color h: h asFloat s: 1.0 v: 1.0.
y := transHt+1.
0 to: vSteps do: [:n |
c := basicHue mixed: (n asFloat / vSteps asFloat) with: Color white.
palette fill: (x at y extent: 1 at 1) fillColor: c.
y := y + 1].
1 to: vSteps do: [:n |
c := Color black mixed: (n asFloat / vSteps asFloat) with: basicHue.
palette fill: (x at y extent: 1 at 1) fillColor: c.
y := y + 1].
x := x + 1].
y := transHt + 1.
1 to: vSteps * 2 do: [:n |
c := Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white.
palette fill: (x at y extent: 10 at 1) fillColor: c.
y := y + 1].
^ palette
!
Item was changed:
----- Method: ThreePhaseButtonMorph>>doButtonAction: (in category 'event handling') -----
doButtonAction: evt
+
- | moreArgs |
"Perform the action of this button. Subclasses may override this method. The default behavior is to send the button's actionSelector to its target object with its arguments."
target ifNil: [^self].
actionSelector ifNil: [^self].
+ Cursor normal showWhile: [ | moreArgs |
- Cursor normal showWhile: [
moreArgs := actionSelector numArgs > arguments size ifTrue: [
arguments copyWith: evt
] ifFalse: [
arguments
].
target perform: actionSelector withArguments: moreArgs
]!
Item was changed:
----- Method: FileList2>>initialDirectoryList (in category 'initialization') -----
initialDirectoryList
+ | dirList |
- | dir nameToShow dirList |
dirList := (FileDirectory on: '') directoryNames collect: [ :each |
FileDirectoryWrapper with: (FileDirectory on: each) name: each model: self].
dirList isEmpty ifTrue:[
dirList := Array with: (FileDirectoryWrapper
with: FileDirectory default
name: FileDirectory default localName
model: self)].
dirList := dirList,(
+ ServerDirectory serverNames collect: [ :n | | nameToShow dir |
- ServerDirectory serverNames collect: [ :n |
dir := ServerDirectory serverNamed: n.
nameToShow := n.
(dir directoryWrapperClass with: dir name: nameToShow model: self)
balloonText: dir realUrl
]
).
^dirList!
Item was changed:
----- Method: PasteUpMorph>>optimumExtentFromAuthor (in category 'world state') -----
optimumExtentFromAuthor
+
- | opt |
^self
valueOfProperty: #optimumExtentFromAuthor
+ ifAbsent: [ | opt |
- ifAbsent: [
opt := bounds extent.
self setProperty: #optimumExtentFromAuthor toValue: opt.
^opt
]
!
Item was changed:
----- Method: SystemWindow>>setUpdatablePanesFrom: (in category 'panes') -----
setUpdatablePanesFrom: getSelectors
+ | aList possibles |
- | aList aPane possibles |
"Set my updatablePanes inst var to the list of panes which are list panes with the given get-list selectors. Order is important here!! Note that the method is robust in the face of panes not found, but a warning is printed in the transcript in each such case"
aList := OrderedCollection new.
possibles := OrderedCollection new.
self allMorphsDo: [ :pane |
(pane isKindOf: PluggableListMorph) ifTrue: [
possibles add: pane.
].
].
+ getSelectors do: [:sel | | aPane |
- getSelectors do: [:sel |
aPane := possibles detect: [ :pane | pane getListSelector == sel] ifNone: [nil].
aPane
ifNotNil:
[aList add: aPane]
ifNil:
[Transcript cr; show: 'Warning: pane ', sel, ' not found.']].
updatablePanes := aList asArray!
Item was changed:
----- Method: FileList2 class>>projectOnlySelectionMethod: (in category 'as yet unclassified') -----
projectOnlySelectionMethod: incomingEntries
+ | versionsAccepted |
- | versionsAccepted basicInfoTuple basicName basicVersion |
"this shows only the latest version of each project"
versionsAccepted := Dictionary new.
+ incomingEntries do: [ :entry | | basicInfoTuple basicVersion basicName |
- incomingEntries do: [ :entry |
entry isDirectory ifFalse: [
(#('*.pr' '*.pr.gz' '*.project') anySatisfy: [ :each | each match: entry name]) ifTrue: [
basicInfoTuple := Project parseProjectFileName: entry name.
basicName := basicInfoTuple first.
basicVersion := basicInfoTuple second.
((versionsAccepted includesKey: basicName) and:
[(versionsAccepted at: basicName) first > basicVersion]) ifFalse: [
versionsAccepted at: basicName put: {basicVersion. entry}
].
]
]
].
^versionsAccepted asArray collect: [ :each | each second]!
Item was changed:
----- Method: SystemProgressMorph>>label:min:max: (in category 'private') -----
label: shortDescription min: minValue max: maxValue
+ | slot range barSize lastRefresh |
- | slot range newBarSize barSize lastRefresh |
((range := maxValue - minValue) < 0 or: [(slot := self nextSlotFor: shortDescription) = 0])
ifTrue: [^[:barVal| 0 ]].
range <= 0 ifTrue: [self removeMorph: (bars at: slot)].
self recenter.
self openInWorld.
barSize := -1. "Enforces a inital draw of the morph"
lastRefresh := 0.
+ ^[:barVal | | newBarSize |
- ^[:barVal |
barVal isString ifTrue: [
self setLabel: barVal at: slot.
self currentWorld displayWorld].
(barVal isNumber and: [range >= 1 and: [barVal between: minValue and: maxValue]]) ifTrue: [
newBarSize := (barVal - minValue / range * BarWidth) truncated.
newBarSize = barSize ifFalse: [
barSize := newBarSize.
(bars at: slot) barSize: barSize.
Time primMillisecondClock - lastRefresh > 25 ifTrue: [
self currentWorld displayWorld.
lastRefresh := Time primMillisecondClock]]].
slot]
!
Item was changed:
----- Method: MorphicProject>>findProjectView: (in category 'utilities') -----
findProjectView: projectDescription
"In this world, find the morph that holds onto the project described by projectDescription.
projectDescription can be a project, or the name of a project. The project may be
represented by a DiskProxy. The holder morph may be at any depth in the world.."
+ | pName |
- | pName dpName |
pName := (projectDescription isString)
ifTrue: [projectDescription]
ifFalse: [projectDescription name].
+ world allMorphsDo: [:pvm | | dpName |
- world allMorphsDo: [:pvm |
pvm class == ProjectViewMorph ifTrue: [
(pvm project class == Project and:
[pvm project name = pName]) ifTrue: [^ pvm].
pvm project class == DiskProxy ifTrue: [
dpName := pvm project constructorArgs first.
dpName := (dpName findTokens: '/') last.
dpName := (Project parseProjectFileName: dpName unescapePercents) first.
dpName = pName ifTrue: [^ pvm]]]].
^ nil!
Item was changed:
----- Method: MVCMenuMorph class>>from:title: (in category 'instance creation') -----
from: aPopupMenu title: titleStringOrNil
"Answer a MenuMorph constructed from the given PopUpMenu. Used to simulate MVC-style menus in a Morphic-only world."
+ | menu items lines selections labelString j |
- | menu items lines selections labelString j emphasis |
menu := self new.
titleStringOrNil ifNotNil: [
titleStringOrNil isEmpty ifFalse: [menu addTitle: titleStringOrNil]].
labelString := aPopupMenu labelString.
items := labelString asString findTokens: String cr.
labelString isText ifTrue:
["Pass along text emphasis if present"
j := 1.
items := items collect:
+ [:item | | emphasis |
+ j := labelString asString findString: item startingAt: j.
- [:item | j := labelString asString findString: item startingAt: j.
emphasis := TextEmphasis new emphasisCode: (labelString emphasisAt: j).
item asText addAttribute: emphasis]].
lines := aPopupMenu lineArray.
lines ifNil: [lines := #()].
menu cancelValue: 0.
menu defaultTarget: menu.
selections := (1 to: items size) asArray.
1 to: items size do: [:i |
menu add: (items at: i) selector: #selectMVCItem: argument: (selections at: i).
(lines includes: i) ifTrue: [menu addLine]].
^ menu
!
Item was changed:
----- Method: FileList2 class>>enableTypeButtons:info:forDir: (in category 'blue ui') -----
enableTypeButtons: typeButtons info: fileTypeInfo forDir: aDirectory
+ | foundSuffixes firstEnabled |
- | foundSuffixes fileSuffixes firstEnabled enableIt |
firstEnabled := nil.
foundSuffixes := (aDirectory ifNil: [ #()] ifNotNil: [ aDirectory fileNames]) collect: [ :each | (each findTokens: '.') last asLowercase].
foundSuffixes := foundSuffixes asSet.
+ fileTypeInfo with: typeButtons do: [ :info :button | | enableIt fileSuffixes |
- fileTypeInfo with: typeButtons do: [ :info :button |
fileSuffixes := info second.
enableIt := fileSuffixes anySatisfy: [ :patt | foundSuffixes includes: patt].
button
setProperty: #enabled
toValue: enableIt.
enableIt ifTrue: [firstEnabled ifNil: [firstEnabled := button]].
].
firstEnabled ifNotNil: [^firstEnabled mouseUp: nil].
typeButtons do: [ :each | each color: Color gray].
!
Item was changed:
----- Method: FileList>>selectedPath (in category 'directory tree') -----
selectedPath
+ | top here |
- | top here next |
top := FileDirectory root.
here := directory.
+ ^(Array streamContents:[:s| | next |
- ^(Array streamContents:[:s|
s nextPut: here.
[next := here containingDirectory.
top pathName = next pathName] whileFalse:[
s nextPut: next.
here := next.
]]) reversed.!
Item was changed:
----- Method: TransformationMorph>>extent: (in category 'geometry') -----
extent: newExtent
+
- | scaleFactor |
self adjustAfter:
+ [ | scaleFactor |
+ scaleFactor := (self scale * newExtent r / self fullBounds extent r) max: 0.1.
- [scaleFactor := (self scale * newExtent r / self fullBounds extent r) max: 0.1.
self scale: (scaleFactor detentBy: 0.1 atMultiplesOf: 1.0 snap: false)]!
Item was changed:
----- Method: TableLayout>>minExtentHorizontal: (in category 'optimized') -----
minExtentHorizontal: aMorph
"Return the minimal size aMorph's children would require given the new bounds"
+ | inset minX minY maxX maxY n size width height |
- | inset n size width height minX minY maxX maxY sizeX sizeY |
size := properties minCellSize asPoint.
minX := size x.
minY := size y.
size := properties maxCellSize asPoint.
maxX := size x.
maxY := size y.
inset := properties cellInset asPoint.
n := 0.
width := height := 0.
aMorph submorphsDo:
+ [:m | | sizeX sizeY |
- [:m |
m disableTableLayout
ifFalse:
[n := n + 1.
size := m minExtent.
sizeX := size x.
sizeY := size y.
sizeX < minX
ifTrue: [sizeX := minX]
ifFalse: [sizeX := sizeX min: maxX].
sizeY < minY
ifTrue: [sizeY := minY]
ifFalse: [sizeY := sizeY min: maxY].
width := width + sizeX.
sizeY > height ifTrue: [height := sizeY]]].
n > 1 ifTrue: [width := width + ((n - 1) * inset x)].
^minExtentCache := width @ height!
Item was changed:
----- Method: ScriptEditorMorph>>createThreadShowing (in category 'menu commands') -----
createThreadShowing
+ | vertices |
- | vertices b |
self deleteThreadShowing.
vertices := OrderedCollection new.
+ self tileRows do: [:row | | b |
- self tileRows do: [:row |
row first isTurtleRow ifTrue: [
b := row first bounds.
vertices add: ((b topLeft + (4 at 0)) + ((0 * 0.1 * b width)@0)).
0 to: 9 do: [:i |
vertices add: ((b topLeft + (4 at 4))+ ((i * 0.1 * b width )@0)).
vertices add: ((b bottomLeft + (4 at -4)) + ((i * 0.1 * b width)@0)).
].
vertices add: ((b bottomLeft + (4 at 0)) + ((9 * 0.1 * b width)@0)).
] ifFalse: [
b := row first bounds.
vertices add: ((b origin x + b corner x)//2)@(b origin y).
vertices add: ((b origin x + b corner x)//2)@(b origin y + 4).
vertices add: ((b origin x + b corner x)//2)@(b corner y - 4).
vertices add: ((b origin x + b corner x)//2)@(b corner y).
].
].
threadPolygon := PolygonMorph vertices: vertices color: Color black borderWidth: 2 borderColor: Color black.
threadPolygon makeOpen.
threadPolygon openInWorld.
!
Item was changed:
----- Method: SystemWindow>>setPaneRectsFromBounds (in category 'geometry') -----
setPaneRectsFromBounds
"Reset proportional specs from actual bounds, eg, after reframing panes"
+ | layoutBounds |
- | layoutBounds box frame left right top bottom |
layoutBounds := self layoutBounds.
+ paneMorphs do:[:m| | box left bottom top frame right |
- paneMorphs do:[:m|
frame := m layoutFrame.
box := m bounds.
frame ifNotNil:[
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: PasteUpMorph>>updateSubmorphThumbnails (in category 'options') -----
updateSubmorphThumbnails
+ | thumbsUp heightForThumbnails maxHeightToAvoidThumbnailing maxWidthForThumbnails |
- | thumbsUp itsThumbnail heightForThumbnails maxHeightToAvoidThumbnailing maxWidthForThumbnails |
thumbsUp := self alwaysShowThumbnail.
heightForThumbnails := self heightForThumbnails.
maxHeightToAvoidThumbnailing := self maxHeightToAvoidThumbnailing.
maxWidthForThumbnails := self maximumThumbnailWidth.
self submorphs do:
+ [:aMorph | | itsThumbnail |
+ thumbsUp
- [:aMorph | thumbsUp
ifTrue:
[itsThumbnail := aMorph representativeNoTallerThan: maxHeightToAvoidThumbnailing norWiderThan: maxWidthForThumbnails thumbnailHeight: heightForThumbnails.
(aMorph == itsThumbnail)
ifFalse:
[self replaceSubmorph: aMorph by: itsThumbnail]]
ifFalse:
[(aMorph isKindOf: MorphThumbnail)
ifTrue:
[self replaceSubmorph: aMorph by: aMorph morphRepresented]]]!
Item was changed:
----- Method: Morph>>showDesignationsOfObjects (in category 'card in a stack') -----
showDesignationsOfObjects
"Momentarily show the designations of objects on the receiver"
+ | colorToUse |
- | colorToUse aLabel |
self isStackBackground ifFalse: [^self].
self submorphsDo:
+ [:aMorph | | aLabel |
- [:aMorph |
aLabel :=aMorph renderedMorph holdsSeparateDataForEachInstance
ifTrue:
[colorToUse := Color orange.
aMorph externalName]
ifFalse:
[colorToUse := aMorph isShared ifFalse: [Color red] ifTrue: [Color green].
nil].
Display
border: (aMorph fullBoundsInWorld insetBy: -6)
width: 6
rule: Form over
fillColor: colorToUse.
aLabel ifNotNil:
[aLabel asString
displayOn: Display
at: aMorph fullBoundsInWorld bottomLeft + (0 @ 5)
textColor: Color blue]].
Sensor anyButtonPressed
ifTrue: [Sensor waitNoButton]
ifFalse: [Sensor waitButton].
World fullRepaintNeeded!
Item was changed:
----- Method: FileList2>>limitedSuperSwikiDirectoryList (in category 'initialization') -----
limitedSuperSwikiDirectoryList
+ | dirList localDirName localDir |
- | dir nameToShow dirList localDirName localDir |
dirList := OrderedCollection new.
+ ServerDirectory serverNames do: [ :n | | dir nameToShow |
- ServerDirectory serverNames do: [ :n |
dir := ServerDirectory serverNamed: n.
dir isProjectSwiki ifTrue: [
nameToShow := n.
dirList add: ((dir directoryWrapperClass with: dir name: nameToShow model: self)
balloonText: dir realUrl)
].
].
ServerDirectory localProjectDirectories do: [ :each |
dirList add: (FileDirectoryWrapper with: each name: each localName model: self)
].
"Make sure the following are always shown, but not twice"
localDirName := SecurityManager default untrustedUserDirectory.
localDir := FileDirectory on: localDirName.
((ServerDirectory localProjectDirectories collect: [:each | each pathName]) includes: localDirName)
ifFalse: [dirList add: (FileDirectoryWrapper with: localDir name: localDir localName model: self)].
FileDirectory default pathName = localDirName
ifFalse: [dirList add: (FileDirectoryWrapper with: FileDirectory default name: FileDirectory default localName model: self)].
(dirList anySatisfy: [:each | each withoutListWrapper acceptsUploads])
ifFalse: [dirList add: (FileDirectoryWrapper with: FileDirectory default name: FileDirectory default localName model: self)].
^dirList!
Item was changed:
----- Method: TTSampleStringMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
+ | xStart |
- | xStart glyph |
(font isNil or:[string isNil or:[string isEmpty]])
ifTrue:[^aCanvas frameRectangle: bounds color: Color black].
xStart := 0.
aCanvas asBalloonCanvas preserveStateDuring:[:balloonCanvas|
balloonCanvas transformBy: self transform.
balloonCanvas aaLevel: self smoothing.
+ string do:[:char| | glyph |
- string do:[:char|
glyph := font at: char.
balloonCanvas preserveStateDuring:[:subCanvas|
subCanvas transformBy: (MatrixTransform2x3 withOffset: xStart at 0).
subCanvas
drawGeneralBezierShape: glyph contours
color: color
borderWidth: borderWidth
borderColor: borderColor].
xStart := xStart + glyph advanceWidth.
].
].!
Item was changed:
----- 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"
+
- | sub args |
self submorphs do: [:p | p knownName = aName ifTrue: [^p]].
self submorphs do:
+ [:button | | sub args |
- [:button |
(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: PolygonMorph>>closestSegmentTo: (in category 'geometry') -----
closestSegmentTo: aPoint
"Answer the starting index of my (big) segment nearest to aPoint"
+ | closestPoint minDist vertexIndex closestVertexIndex |
- | curvePoint closestPoint dist minDist vertexIndex closestVertexIndex |
vertexIndex := 0.
closestVertexIndex := 0.
closestPoint := minDist := nil.
self lineSegmentsDo:
+ [:p1 :p2 | | dist curvePoint |
- [:p1 :p2 |
(p1 = (self vertices at: vertexIndex + 1))
ifTrue: [ vertexIndex := vertexIndex + 1 ].
curvePoint := aPoint nearestPointOnLineFrom: p1 to: p2.
dist := curvePoint dist: aPoint.
(closestPoint == nil or: [dist < minDist])
ifTrue: [closestPoint := curvePoint.
minDist := dist.
closestVertexIndex := vertexIndex. ]].
^ closestVertexIndex!
Item was changed:
----- Method: PasteUpMorph>>repairEmbeddedWorlds (in category 'world state') -----
repairEmbeddedWorlds
+ | toDoList |
- | transform eWorld toDoList |
toDoList := OrderedCollection new.
+ self allMorphsDo: [ :each | | transform eWorld |
- self allMorphsDo: [ :each |
(each isKindOf: EmbeddedWorldBorderMorph) ifTrue: [
transform := each submorphs at: 1 ifAbsent: [nil].
transform ifNotNil: [
eWorld := transform submorphs at: 1 ifAbsent: [nil].
eWorld ifNotNil: [
toDoList add: {transform. eWorld}.
].
].
"Smalltalk at: #Q put: {self. each. transform. eWorld}."
].
].
toDoList do: [ :each |
each first addMorph: each second.
].!
Item was changed:
----- Method: TransformationMorph>>removeFlexShell (in category 'menu') -----
removeFlexShell
"Remove the shell used to make a morph rotatable and scalable."
+ | oldHalo unflexed pensDown myWorld refPos aPosition |
- | oldHalo unflexed pensDown player myWorld refPos aPosition |
refPos := self referencePosition.
myWorld := self world.
oldHalo := self halo.
submorphs isEmpty ifTrue: [^ self delete].
aPosition := (owner submorphIndexOf: self) ifNil: [1].
unflexed := self firstSubmorph.
pensDown := OrderedCollection new.
self allMorphsDo: "Note any pens down -- must not be down during the move"
+ [:m | | player |
+ ((player := m player) notNil and: [player getPenDown]) ifTrue:
- [:m | ((player := m player) notNil and: [player getPenDown]) ifTrue:
[m == player costume ifTrue:
[pensDown add: player.
player setPenDown: false]]].
self submorphs do: [:m |
m position: self center - (m extent // 2).
owner addMorph: m asElementNumber: aPosition].
unflexed absorbStateFromRenderer: self.
pensDown do: [:p | p setPenDown: true].
oldHalo ifNotNil: [oldHalo setTarget: unflexed].
myWorld ifNotNil: [myWorld startSteppingSubmorphsOf: unflexed].
self delete.
unflexed referencePosition: refPos.
^ unflexed!
Item was changed:
----- Method: Morph>>morphsAt:unlocked:do: (in category 'submorphs-accessing') -----
morphsAt: aPoint unlocked: aBool 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."
+
- | tfm |
(self fullBounds containsPoint: aPoint) ifFalse:[^self].
(aBool and:[self isLocked or:[self visible not]]) ifTrue:[^self].
+ self submorphsDo:[:m| | tfm |
- self submorphsDo:[:m|
tfm := m transformedFrom: self.
m morphsAt: (tfm globalPointToLocal: aPoint) unlocked: aBool do: aBlock].
(self containsPoint: aPoint) ifTrue:[aBlock value: self].!
Item was changed:
----- Method: TableLayout>>layoutTopToBottom:in: (in category 'optimized') -----
layoutTopToBottom: aMorph in: newBounds
"An optimized top-to-bottom list layout"
+ | inset extent block posX posY centering extraPerCell amount minX minY maxX maxY n height extra last cell size width sum vFill first |
- | inset n size extent width height block sum vFill posX posY extra centering extraPerCell last amount minX minY maxX maxY sizeX sizeY first cell props |
size := properties minCellSize asPoint.
minX := size x.
minY := size y.
size := properties maxCellSize asPoint.
maxX := size x.
maxY := size y.
inset := properties cellInset asPoint y.
extent := newBounds extent.
n := 0.
vFill := false.
sum := 0.
width := height := 0.
first := last := nil.
block :=
+ [:m | | sizeY sizeX props |
- [:m |
props := m layoutProperties ifNil: [m].
props disableTableLayout
ifFalse:
[n := n + 1.
cell := LayoutCell new target: m.
props vResizing == #spaceFill
ifTrue:
[cell vSpaceFill: true.
extra := m spaceFillWeight.
cell extraSpace: extra.
sum := sum + extra]
ifFalse: [cell vSpaceFill: false].
props hResizing == #spaceFill ifTrue: [vFill := true].
size := m minExtent.
sizeX := size x.
sizeY := size y.
sizeX < minX ifTrue: [sizeX := minX] ifFalse: [sizeX := sizeX min: maxX].
sizeY < minY ifTrue: [sizeY := minY] ifFalse: [sizeY := sizeY min: maxY].
cell cellSize: sizeY.
first ifNil: [first := cell] ifNotNil: [last nextCell: cell].
last := cell.
height := height + sizeY.
sizeX > width ifTrue: [width := sizeX]]].
properties reverseTableCells
ifTrue: [aMorph submorphsReverseDo: block]
ifFalse: [aMorph submorphsDo: block].
n > 1 ifTrue: [height := height + ((n - 1) * inset)].
(properties vResizing == #shrinkWrap
and: [properties rubberBandCells or: [sum isZero]])
ifTrue: [extent := (extent x max: width) @ height].
(properties hResizing == #shrinkWrap
and: [properties rubberBandCells or: [vFill not]])
ifTrue: [extent := width @ (extent y max: height)].
posX := newBounds left.
posY := newBounds top.
"Compute extra horizontal space"
extra := extent x - width.
extra := extra max: 0.
extra > 0
ifTrue:
[vFill
ifTrue: [width := extent x]
ifFalse:
[centering := properties wrapCentering.
centering == #bottomRight ifTrue: [posX := posX + extra].
centering == #center ifTrue: [posX := posX + (extra // 2)]]].
"Compute extra vertical space"
extra := extent y - height.
extra := extra max: 0.
extraPerCell := 0.
extra > 0
ifTrue:
[sum isZero
ifTrue:
["extra space but no #spaceFillers"
centering := properties listCentering.
centering == #bottomRight ifTrue: [posY := posY + extra].
centering == #center ifTrue: [posY := posY + (extra // 2)]]
ifFalse: [extraPerCell := extra asFloat / sum asFloat]].
n := 0.
extra := last := 0.
cell := first.
[cell isNil] whileFalse:
[n := n + 1.
height := cell cellSize.
(extraPerCell > 0 and: [cell vSpaceFill])
ifTrue:
[extra := (last := extra) + (extraPerCell * cell extraSpace).
amount := extra truncated - last truncated.
height := height + amount].
cell target layoutInBounds: (posX @ posY extent: width @ height).
posY := posY + height + inset.
cell := cell nextCell]!
Item was changed:
----- Method: PasteUpMorph>>imposeListViewSortingBy:retrieving: (in category 'viewing') -----
imposeListViewSortingBy: sortOrderSymbol retrieving: fieldListSelectors
"Establish a list view of the receiver's contents, sorting the contents by the criterion represented by sortOrderSymbol, and displaying readouts as indicated by the list of field selectors."
+
- | rep |
self setProperty: #sortOrder toValue: sortOrderSymbol.
self setProperty: #fieldListSelectors toValue: fieldListSelectors.
self showingListView ifFalse:
[self autoLineLayout ifFalse: [self saveBoundsOfSubmorphs].
self setProperty: #showingListView toValue: true.
self layoutPolicy: TableLayout new.
self layoutInset: 2; cellInset: 2.
self listDirection: #topToBottom.
self wrapDirection: #none].
self submorphs "important that it be a copy" do:
+ [:aMorph | | rep |
- [:aMorph |
rep := aMorph listViewLineForFieldList: fieldListSelectors.
rep hResizing: #spaceFill.
self replaceSubmorph: aMorph by: rep].
self sortSubmorphsBy: (self valueOfProperty: #sortOrder).!
Item was changed:
----- Method: TableLayout>>computeCellSizes:in:horizontal: (in category 'layout') -----
computeCellSizes: aMorph in: newBounds horizontal: aBool
"Step 1: Compute the minimum extent for all the children of aMorph"
+ | cells block minSize maxSize maxCell |
- | cells cell size block maxCell minSize maxSize |
cells := WriteStream on: (Array new: aMorph submorphCount).
minSize := properties minCellSize asPoint.
maxSize := properties maxCellSize asPoint.
aBool ifTrue:[
minSize := minSize transposed.
maxSize := maxSize transposed].
maxCell := 0 at 0.
+ block := [:m| | size cell |
- block := [:m|
m disableTableLayout ifFalse:[
size := m minExtent asIntegerPoint.
cell := LayoutCell new target: m.
aBool ifTrue:[
cell hSpaceFill: m hResizing == #spaceFill.
cell vSpaceFill: m vResizing == #spaceFill.
] ifFalse:[
cell hSpaceFill: m vResizing == #spaceFill.
cell vSpaceFill: m hResizing == #spaceFill.
size := size transposed.
].
size := (size min: maxSize) max: minSize.
cell cellSize: size.
maxCell := maxCell max: size.
cells nextPut: cell]].
properties reverseTableCells
ifTrue:[aMorph submorphsReverseDo: block]
ifFalse:[aMorph submorphsDo: block].
^maxCell -> cells contents!
Item was changed:
----- Method: Morph>>submorphBounds (in category 'layout') -----
submorphBounds
"Private. Compute the actual full bounds of the receiver"
+ | box |
+ submorphs do: [:m | | subBox |
- | box subBox |
- submorphs do: [:m |
(m visible) ifTrue: [
subBox := m fullBounds.
box
ifNil:[box := subBox copy]
ifNotNil:[box := box quickMerge: subBox]]].
box ifNil:[^self bounds]. "e.g., having submorphs but not visible"
^ box origin asIntegerPoint corner: box corner asIntegerPoint
!
Item was changed:
----- Method: Morph>>convertAugust1998:using: (in category 'object fileIn') -----
convertAugust1998: varDict using: smartRefStrm
"These variables are automatically stored into the new instance
('bounds' 'owner' 'submorphs' 'fullBounds' 'color' ).
This method is for additional changes. Use statements like (foo :=
varDict at: 'foo')."
"Be sure to to fill in ('extension' ) and deal with the information
in ('eventHandler' 'properties' 'costumee' )"
"This method moves all property variables as well as
eventHandler, and costumee into a morphicExtension."
"Move refs to eventhandler and costumee into extension"
+
- | propVal |
(varDict at: 'eventHandler') isNil
ifFalse: [self eventHandler: (varDict at: 'eventHandler')].
(varDict at: 'costumee') isNil
ifFalse: [self player: (varDict at: 'costumee')].
(varDict at: 'properties') isNil
ifFalse:
[(varDict at: 'properties') keys do:
+ [:key | | propVal |
- [:key |
"Move property extensions into extension"
propVal := (varDict at: 'properties') at: key.
propVal ifNotNil:
[key == #possessive
ifTrue: [propVal == true ifTrue: [self bePossessive]]
ifFalse:
[key ifNotNil: [self assureExtension convertProperty: key toValue: propVal]]]]]!
Item was changed:
----- Method: SystemWindow class>>windowsIn:satisfying: (in category 'top window') -----
windowsIn: aWorld satisfying: windowBlock
+ | windows |
- | windows s |
windows := OrderedCollection new.
aWorld ifNil: [^windows]. "opening MVC in Morphic - WOW!!"
aWorld submorphs do:
+ [:m | | s |
- [:m |
((m isSystemWindow) and: [windowBlock value: m])
ifTrue: [windows addLast: m]
ifFalse: [((m isKindOf: TransformationMorph) and: [m submorphs size = 1])
ifTrue: [s := m firstSubmorph.
((s isSystemWindow) and: [windowBlock value: s])
ifTrue: [windows addLast: s]]]].
^ windows!
Item was changed:
----- Method: PasteUpMorph>>findAWindowSatisfying:orMakeOneUsing: (in category 'world menu') -----
findAWindowSatisfying: qualifyingBlock orMakeOneUsing: makeBlock
"Locate a window satisfying a block, open it, and bring it to the front. Create one if necessary, by using the makeBlock"
+
- | aWindow |
submorphs do:
+ [:aMorph | | aWindow |
- [:aMorph |
(((aWindow := aMorph renderedMorph) isSystemWindow)
and: [qualifyingBlock value: aWindow])
ifTrue:
[aWindow isCollapsed ifTrue: [aWindow expand].
aWindow activateAndForceLabelToShow.
^self]].
"None found, so create one"
makeBlock value!
Item was changed:
----- Method: MorphicEvent>>convertToCurrentVersion:refStream: (in category 'objects from disk') -----
convertToCurrentVersion: varDict refStream: smartRefStrm
+
- | answer |
"ar 10/25/2000: This method is used to convert OLD MorphicEvents into new ones."
+ varDict at: 'cursorPoint' ifPresent: [ :x | | answer |
- varDict at: 'cursorPoint' ifPresent: [ :x |
answer := self convertOctober2000: varDict using: smartRefStrm.
varDict removeKey: 'cursorPoint'. "avoid doing this again"
^answer
].
^super convertToCurrentVersion: varDict refStream: smartRefStrm.
!
Item was changed:
----- Method: TextContainer>>computeShadow (in category 'private') -----
computeShadow
+ | canvas bounds theText |
- | canvas back bounds theText |
bounds := self bounds.
theText := textMorph.
canvas := (Display defaultCanvasClass extent: bounds extent depth: 1)
shadowColor: Color black.
+ canvas translateBy: bounds topLeft negated during:[:tempCanvas| | back |
- canvas translateBy: bounds topLeft negated during:[:tempCanvas|
self fillsOwner
ifTrue: [tempCanvas fullDrawMorph: (theText owner copyWithoutSubmorph: theText)]
ifFalse: [tempCanvas fillRectangle: textMorph bounds color: Color black].
self avoidsOcclusions ifTrue:
[back := tempCanvas form deepCopy.
tempCanvas form fillWhite.
theText owner submorphsInFrontOf: theText do:
[:m | (textMorph isLinkedTo: m)
ifTrue: []
ifFalse: [tempCanvas fullDrawMorph: m]].
back displayOn: tempCanvas form at: 0 at 0 rule: Form reverse].
].
shadowForm := canvas form offset: bounds topLeft.
vertProfile := shadowForm yTallyPixelValue: 1 orNot: false.
rectangleCache := Dictionary new.
^ shadowForm!
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 |
- | delta tryToPlace selectedOffset |
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 |
- tryToPlace := [:where :mustFit |
self position: where - selectedOffset.
delta := self fullBoundsInWorld amountToTranslateWithin: sourceItem worldBounds.
(delta x = 0
or: [mustFit])
ifTrue: [delta = (0 @ 0)
ifFalse: [self position: self position + delta].
sourceItem owner owner addMorphFront: self.
^ self]].
tryToPlace value: rightOrLeftPoint first value: false;
value: rightOrLeftPoint last - (self width @ 0) value: false;
value: rightOrLeftPoint first value: true!
Item was changed:
----- Method: PolygonMorph>>drawBorderOn:usingEnds: (in category 'drawing') -----
drawBorderOn: aCanvas usingEnds: anArray
"Display my border on the canvas."
"NOTE: Much of this code is also copied in
drawDashedBorderOn:
(should be factored)"
+ | bigClipRect style |
- | bigClipRect p1i p2i style |
borderDashSpec
ifNotNil: [^ self drawDashedBorderOn: aCanvas usingEnds: anArray].
style := self borderStyle.
bigClipRect := aCanvas clipRect expandBy: self borderWidth + 1 // 2.
self
+ lineSegmentsDo: [:p1 :p2 | | p2i p1i |
- lineSegmentsDo: [:p1 :p2 |
p1i := p1 asIntegerPoint.
p2i := p2 asIntegerPoint.
self hasArrows
ifTrue: ["Shorten line ends so as not to interfere with tip
of arrow."
((arrows == #back
or: [arrows == #both])
and: [p1 = vertices first])
ifTrue: [p1i := anArray first asIntegerPoint].
((arrows == #forward
or: [arrows == #both])
and: [p2 = vertices last])
ifTrue: [p2i := anArray last asIntegerPoint]].
(closed
or: ["bigClipRect intersects: (p1i rect: p2i)
optimized:"
((p1i min: p2i)
max: bigClipRect origin)
<= ((p1i max: p2i)
min: bigClipRect corner)])
ifTrue: [style
drawLineFrom: p1i
to: p2i
on: aCanvas]]!
Item was changed:
----- Method: WorldState>>stepListSortBlock (in category 'initialization') -----
stepListSortBlock
- "Please pardon the hackery below. Since the block provided by this method is retained elsewhere, it is possible that the block argument variables would retain references to objects that were no longer really needed. In one case, this feature resulted in doubling the size of a published project."
-
^[ :stepMsg1 :stepMsg2 |
+ stepMsg1 scheduledTime <= stepMsg2 scheduledTime.
- | answer |
- answer := stepMsg1 scheduledTime <= stepMsg2 scheduledTime.
- stepMsg1 := stepMsg2 := nil.
- answer
]!
Item was changed:
----- Method: TableLayout>>layoutLeftToRight:in: (in category 'optimized') -----
layoutLeftToRight: aMorph in: newBounds
"An optimized left-to-right list layout"
+ | inset extent block posX posY centering extraPerCell amount minX minY maxX maxY n width extra last cell size height sum vFill first |
- | inset n size extent width height block sum vFill posX posY extra centering extraPerCell last amount minX minY maxX maxY sizeX sizeY first cell props |
size := properties minCellSize asPoint.
minX := size x.
minY := size y.
size := properties maxCellSize asPoint.
maxX := size x.
maxY := size y.
inset := properties cellInset asPoint x.
extent := newBounds extent.
n := 0.
vFill := false.
sum := 0.
width := height := 0.
first := last := nil.
block :=
+ [:m | | sizeX props sizeY |
- [:m |
props := m layoutProperties ifNil: [m].
props disableTableLayout
ifFalse:
[n := n + 1.
cell := LayoutCell new target: m.
props hResizing == #spaceFill
ifTrue:
[cell hSpaceFill: true.
extra := m spaceFillWeight.
cell extraSpace: extra.
sum := sum + extra]
ifFalse: [cell hSpaceFill: false].
props vResizing == #spaceFill ifTrue: [vFill := true].
size := m minExtent.
size := m minExtent.
sizeX := size x.
sizeY := size y.
sizeX < minX ifTrue: [sizeX := minX] ifFalse: [sizeX := sizeX min: maxX].
sizeY < minY ifTrue: [sizeY := minY] ifFalse: [sizeY := sizeY min: maxY].
cell cellSize: sizeX.
last ifNil: [first := cell] ifNotNil: [last nextCell: cell].
last := cell.
width := width + sizeX.
sizeY > height ifTrue: [height := sizeY]]].
properties reverseTableCells
ifTrue: [aMorph submorphsReverseDo: block]
ifFalse: [aMorph submorphsDo: block].
n > 1 ifTrue: [width := width + ((n - 1) * inset)].
(properties hResizing == #shrinkWrap
and: [properties rubberBandCells or: [sum isZero]])
ifTrue: [extent := width @ (extent y max: height)].
(properties vResizing == #shrinkWrap
and: [properties rubberBandCells or: [vFill not]])
ifTrue: [extent := (extent x max: width) @ height].
posX := newBounds left.
posY := newBounds top.
"Compute extra vertical space"
extra := extent y - height.
extra := extra max: 0.
extra > 0
ifTrue:
[vFill
ifTrue: [height := extent y]
ifFalse:
[centering := properties wrapCentering.
centering == #bottomRight ifTrue: [posY := posY + extra].
centering == #center ifTrue: [posY := posY + (extra // 2)]]].
"Compute extra horizontal space"
extra := extent x - width.
extra := extra max: 0.
extraPerCell := 0.
extra > 0
ifTrue:
[sum isZero
ifTrue:
["extra space but no #spaceFillers"
centering := properties listCentering.
centering == #bottomRight ifTrue: [posX := posX + extra].
centering == #center ifTrue: [posX := posX + (extra // 2)]]
ifFalse: [extraPerCell := extra asFloat / sum asFloat]].
n := 0.
extra := last := 0.
cell := first.
[cell isNil] whileFalse:
[n := n + 1.
width := cell cellSize.
(extraPerCell > 0 and: [cell hSpaceFill])
ifTrue:
[extra := (last := extra) + (extraPerCell * cell extraSpace).
amount := extra truncated - last truncated.
width := width + amount].
cell target layoutInBounds: (posX @ posY extent: width @ height).
posX := posX + width + inset.
cell := cell nextCell]!
Item was changed:
----- Method: MenuMorph>>displayFiltered: (in category 'keyboard control') -----
displayFiltered: evt
+ | matchStr allItems matches feedbackMorph |
- | matchStr allItems isMatch matches feedbackMorph |
matchStr := self valueOfProperty: #matchString.
allItems := self submorphs select: [:m | m isKindOf: MenuItemMorph].
+ matches := allItems select: [:m | | isMatch |
- matches := allItems select: [:m |
isMatch :=
matchStr isEmpty or: [
m contents includesSubstring: matchStr caseSensitive: false].
m isEnabled: isMatch.
isMatch].
feedbackMorph := self valueOfProperty: #feedbackMorph.
feedbackMorph ifNil: [
feedbackMorph :=
TextMorph new
autoFit: true;
color: Color darkGray.
self
addLine;
addMorphBack: feedbackMorph lock.
self setProperty: #feedbackMorph toValue: feedbackMorph.
self fullBounds. "Lay out for submorph adjacency"].
feedbackMorph contents: '<', matchStr, '>'.
matchStr isEmpty ifTrue: [
feedbackMorph delete.
self submorphs last delete.
self removeProperty: #feedbackMorph].
"matches size >= 1 ifTrue: [
self selectItem: matches first event: evt]"!
Item was changed:
----- Method: TableLayout>>minExtentVertical: (in category 'optimized') -----
minExtentVertical: aMorph
"Return the minimal size aMorph's children would require given the new bounds"
+ | inset minX minY maxX maxY n size width height |
- | inset n size width height minX minY maxX maxY sizeX sizeY |
size := properties minCellSize asPoint.
minX := size x.
minY := size y.
size := properties maxCellSize asPoint.
maxX := size x.
maxY := size y.
inset := properties cellInset asPoint.
n := 0.
width := height := 0.
aMorph submorphsDo:
+ [:m | | sizeY sizeX |
- [:m |
m disableTableLayout
ifFalse:
[n := n + 1.
size := m minExtent.
sizeX := size x.
sizeY := size y.
sizeX < minX
ifTrue: [sizeX := minX]
ifFalse: [sizeX := sizeX min: maxX].
sizeY < minY
ifTrue: [sizeY := minY]
ifFalse: [sizeY := sizeY min: maxY].
height := height + sizeY.
sizeX > width ifTrue: [width := sizeX]]].
n > 1 ifTrue: [height := height + ((n - 1) * inset y)].
^minExtentCache := width @ height!
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 |
- | mm tfm aMorph |
aMorph := self morphToDropFrom: dropped.
self isWorldMorph
ifTrue:["Add the given morph to this world and start stepping it if it wants to be."
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 | 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 showingListView ifTrue:
[self sortSubmorphsBy: (self valueOfProperty: #sortOrder).
self currentWorld abandonAllHalos].
self bringTopmostsToFront.
!
Item was changed:
----- Method: PasteUpMorph>>makeNewDrawing:at: (in category 'world menu') -----
makeNewDrawing: evt at: aPoint
"make a new drawing, triggered by the given event, with the painting area centered around the given point"
+ | w newSketch newPlayer sketchEditor aPalette rect aPaintBox aPaintTab aWorld |
- | w newSketch newPlayer sketchEditor aPaintBox aPalette tfx whereToPresent rect ownerBeforeHack aPaintTab aWorld |
w := self world.
w assureNotPaintingElse: [^ self].
rect := self paintingBoundsAround: aPoint.
aPalette := self standardPalette.
aPalette ifNotNil: [aPalette showNoPalette; layoutChanged].
w prepareToPaint.
newSketch := self drawingClass new player: (newPlayer := UnscriptedPlayer newUserInstance).
newPlayer costume: newSketch.
newSketch nominalForm: (Form extent: rect extent depth: w assuredCanvas depth).
newSketch bounds: rect.
sketchEditor := SketchEditorMorph new.
w addMorphFront: sketchEditor.
sketchEditor initializeFor: newSketch inBounds: rect pasteUpMorph: self.
sketchEditor
+ afterNewPicDo: [:aForm :aRect | | tfx ownerBeforeHack whereToPresent |
- afterNewPicDo: [:aForm :aRect |
whereToPresent := self presenter.
newSketch form: aForm.
tfx := self transformFrom: w.
newSketch position: (tfx globalPointToLocal: aRect origin).
newSketch rotationStyle: sketchEditor rotationStyle.
newSketch forwardDirection: sketchEditor forwardDirection.
ownerBeforeHack := newSketch owner. "about to break the invariant!!!!"
newSketch privateOwner: self. "temp for halo access"
newPlayer setHeading: sketchEditor forwardDirection.
(aPaintTab := (aWorld := self world) paintingFlapTab)
ifNotNil:[aPaintTab hideFlap]
ifNil:[(aPaintBox := aWorld paintBox) ifNotNil:[aPaintBox delete]].
"Includes newSketch rotationDegrees: sketchEditor forwardDirection."
newSketch privateOwner: ownerBeforeHack. "probably nil, but let's be certain"
self addMorphFront: newPlayer costume.
w startSteppingSubmorphsOf: newSketch.
whereToPresent drawingJustCompleted: newSketch]
ifNoBits:[
(aPaintTab := (aWorld := self world) paintingFlapTab)
ifNotNil:[aPaintTab hideFlap]
ifNil:[(aPaintBox := aWorld paintBox) ifNotNil:[aPaintBox delete]].
aPalette ifNotNil: [aPalette showNoPalette].]!
Item was changed:
----- Method: FileList>>servicesFromSelectorSpecs: (in category 'own services') -----
servicesFromSelectorSpecs: symbolArray
"Answer an array of services represented by the incoming symbols, eliminating any that do not have a currently-registered service. Pass the symbol #- along unchanged to serve as a separator between services"
"FileList new servicesFromSelectorSpecs: #(fileIn: fileIntoNewChangeSet: browseChangesFile:)"
+ | services col |
- | res services col |
col := OrderedCollection new.
services := self class allRegisteredServices, (self myServicesForFile: #dummy suffix: '*').
symbolArray do:
+ [:sel | | res |
- [:sel |
sel == #-
ifTrue:
[col add: sel]
ifFalse:
[res := services
detect: [:each | each selector = sel] ifNone: [nil].
res notNil
ifTrue: [col add: res]]].
^ col!
Item was changed:
----- Method: ComplexProgressIndicator>>withProgressDo: (in category 'as yet unclassified') -----
withProgressDo: aBlock
+ | safetyFactor totals trialRect delta targetOwner |
- | safetyFactor totals trialRect delta stageCompletedString targetOwner |
Smalltalk isMorphic ifFalse: [^aBlock value].
formerProject := Project current.
formerWorld := World.
formerProcess := Processor activeProcess.
targetMorph
ifNil: [targetMorph := ProgressTargetRequestNotification signal].
targetMorph ifNil: [
trialRect := Rectangle center: Sensor cursorPoint extent: 80 at 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
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 |
- ] on: ProgressNotification do: [ :note |
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: FontChooserTool>>buildWindowWith:specs: (in category 'toolbuilder') -----
buildWindowWith: builder specs: specs
+ | windowSpec |
- | windowSpec rect action widgetSpec |
windowSpec := self buildWindowWith: builder.
+ specs do:[:assoc| | action widgetSpec rect |
- specs do:[:assoc|
rect := assoc key.
action := assoc value.
widgetSpec := action value.
widgetSpec ifNotNil:[
widgetSpec frame: rect.
windowSpec children add: widgetSpec]].
^windowSpec!
Item was changed:
----- Method: PluggableTextMorph>>toggleAnnotationPaneSize (in category 'menu commands') -----
toggleAnnotationPaneSize
+ | handle origin aHand siblings |
- | handle origin aHand siblings newHeight lf prevBottom m ht |
self flag: #bob. "CRUDE HACK to enable changing the size of the annotations pane"
owner ifNil: [^self].
siblings := owner submorphs.
siblings size > 3 ifTrue: [^self].
siblings size < 2 ifTrue: [^self].
aHand := self primaryHand.
origin := aHand position.
(handle := HandleMorph new)
+ forEachPointDo: [:newPoint | | lf ht prevBottom newHeight m |
- forEachPointDo: [:newPoint |
handle removeAllMorphs.
newHeight := (newPoint - origin) y asInteger min: owner height - 50 max: 16.
lf := siblings last layoutFrame.
lf bottomOffset: newHeight.
prevBottom := newHeight.
siblings size - 1 to: 1 by: -1 do: [ :index |
m := siblings at: index.
lf := m layoutFrame.
ht := lf bottomOffset - lf topOffset.
lf topOffset: prevBottom.
lf bottomOffset = 0 ifFalse: [
lf bottomOffset: (prevBottom + ht).
].
prevBottom := prevBottom + ht.
].
owner layoutChanged.
]
lastPointDo:
[:newPoint | handle deleteBalloon.
self halo ifNotNil: [:halo | halo addHandles].
].
aHand attachMorph: handle.
handle setProperty: #helpAtCenter toValue: true.
handle showBalloon:
'Move cursor farther from
this point to increase pane.
Click when done.' hand: aHand.
handle startStepping
!
Item was changed:
----- Method: MenuMorph>>itemWithWording: (in category 'accessing') -----
itemWithWording: wording
"If any of the receiver's items or submenu items have the given wording (case-blind comparison done), then return it, else return nil."
+
+ self items do:[:anItem | | found |
- | found |
- self items do:[:anItem |
found := anItem itemWithWording: wording.
found ifNotNil:[^found]].
^ nil!
Item was changed:
----- Method: TheWorldMenu class>>loadSqueakMap (in category 'open-menu registry') -----
loadSqueakMap
"Load the externally-maintained SqueakMap package if it is not already loaded. Based on code by Göran Hultgren"
+ | server |
- | server addr answer |
Socket initializeNetwork.
server := #('map1.squeakfoundation.org' 'map2.squeakfoundation.org' 'map.squeak.org' 'map.bluefish.se' 'marvin.bluefish.se:8000')
+ detect: [:srv | | addr answer |
- detect: [:srv |
addr := NetNameResolver addressForName: (srv upTo: $:) timeout: 5.
addr notNil and: [
answer := HTTPSocket httpGet: ('http://', srv, '/sm/ping').
answer isString not and: [answer contents = 'pong']]]
ifNone: [^ self inform: 'Sorry, no SqueakMap master server responding.'].
server ifNotNil: ["Ok, found an SqueakMap server"
ChangeSet newChangesFromStream:
((('http://', server, '/sm/packagebyname/squeakmap/downloadurl')
asUrl retrieveContents content) asUrl retrieveContents content unzipped
readStream)
named: 'SqueakMap']!
Item was changed:
----- Method: SimpleHierarchicalListMorph>>hUnadjustedScrollRange (in category 'scrolling') -----
hUnadjustedScrollRange
"Return the width of the widest item in the list"
+ | max count |
- | max right stringW count |
max := 0.
count := 0.
+ scroller submorphsDo: [ :each | | stringW right |
- scroller submorphsDo: [ :each |
stringW := each font widthOfStringOrText: each contents.
right := (each toggleRectangle right + stringW + 10).
max := max max: right.
"NOTE: need to optimize this method by caching list item morph widths (can init that cache most efficiently in the #list: method before the item widths are reset to 9999). For now, just punt on really long lists"
((count := count + 1) > 200) ifTrue:[ ^max * 3].
].
^max
!
Item was changed:
----- Method: Morph>>privateAddAllMorphs:atIndex: (in category 'private') -----
privateAddAllMorphs: aCollection atIndex: index
"Private. Add aCollection of morphs to the receiver"
+ | myWorld otherSubmorphs |
- | myWorld itsWorld otherSubmorphs |
myWorld := self world.
otherSubmorphs := submorphs copyWithoutAll: aCollection.
(index between: 0 and: otherSubmorphs size)
ifFalse: [^ self error: 'index out of range'].
index = 0
ifTrue:[ submorphs := aCollection asArray, otherSubmorphs]
ifFalse:[ index = otherSubmorphs size
ifTrue:[ submorphs := otherSubmorphs, aCollection]
ifFalse:[ submorphs := otherSubmorphs copyReplaceFrom: index + 1 to: index with: aCollection ]].
+ aCollection do: [:m | | itsOwner itsWorld |
- aCollection do: [:m | | itsOwner |
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: SystemWindow>>paneWithLongestSide:near: (in category 'resize/collapse') -----
paneWithLongestSide: sideBlock near: aPoint
+ | thePane theSide theLen |
- | thePane theSide theLen box |
theLen := 0.
paneMorphs do:
+ [:pane | | box |
+ box := pane bounds.
- [:pane | box := pane bounds.
box forPoint: aPoint closestSideDistLen:
[:side :dist :len |
(dist <= 5 and: [len > theLen]) ifTrue:
[thePane := pane.
theSide := side.
theLen := len]]].
sideBlock value: theSide.
^ thePane!
Item was changed:
----- Method: MorphicEvent class>>readFromObsolete: (in category 'instance creation') -----
readFromObsolete: aStream
"Read one of those old and now obsolete events from the stream"
+ | type x y buttons keyValue typeString |
- | type x y buttons keyValue typeString c |
typeString := String streamContents:
+ [:s | | c | [(c := aStream next) isLetter] whileTrue: [s nextPut: c]].
- [:s | [(c := aStream next) isLetter] whileTrue: [s nextPut: c]].
typeString = 'mouseMove'
ifTrue: [type := #mouseMove "fast treatment of common case"]
ifFalse: [type := typeString asSymbol].
x := Integer readFrom: aStream.
aStream skip: 1.
y := Integer readFrom: aStream.
aStream skip: 1.
buttons := Integer readFrom: aStream.
aStream skip: 1.
keyValue := Integer readFrom: aStream.
typeString = 'mouseMove' ifTrue:[
^MouseMoveEvent new
setType: #mouseMove
startPoint: x at y
endPoint: x at y
trail: #()
buttons: buttons
hand: nil
stamp: nil].
(typeString = 'mouseDown') | (typeString = 'mouseUp') ifTrue:[
^MouseButtonEvent new
setType: type
position: x at y
which: 0
buttons: buttons
hand: nil
stamp: nil].
(typeString = 'keystroke') | (typeString = 'keyDown') | (typeString = 'keyUp') ifTrue:[
^KeyboardEvent new
setType: type
buttons: buttons
position: x at y
keyValue: keyValue
hand: nil
stamp: nil].
^nil!
Item was changed:
----- Method: PasteUpMorph>>flashRects:color: (in category 'world state') -----
flashRects: rectangleList color: aColor
"For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work."
"Details: Uses two reverses so that the display is restored to its original state. This is necessary when in deferred update mode."
+ | blt |
- | blt screenRect |
blt := (BitBlt current toForm: Display)
sourceForm: nil;
sourceOrigin: 0 at 0;
clipRect: self viewBox;
combinationRule: Form reverse.
+ rectangleList do: [:r | | screenRect |
- rectangleList do: [:r |
screenRect := r translateBy: self viewBox origin.
blt destRect: screenRect; copyBits.
Display forceToScreen: screenRect; forceDisplayUpdate.
(Delay forMilliseconds: 15) wait.
blt destRect: screenRect; copyBits.
Display forceToScreen: screenRect; forceDisplayUpdate].
!
Item was changed:
----- Method: SmalltalkEditor>>handleEmphasisExtra:with: (in category 'editing keys') -----
handleEmphasisExtra: index with: characterStream
"Handle an extra emphasis menu item"
+ | action attribute thisSel |
- | action attribute thisSel oldAttributes |
action := {
[attribute := TextDoIt new.
thisSel := attribute analyze: self selection asString].
[attribute := TextPrintIt new.
thisSel := attribute analyze: self selection asString].
[attribute := TextLink new.
thisSel := attribute analyze: self selection asString with: 'Comment'].
[attribute := TextLink new.
thisSel := attribute analyze: self selection asString with: 'Definition'].
[attribute := TextLink new.
thisSel := attribute analyze: self selection asString with: 'Hierarchy'].
[attribute := TextLink new.
thisSel := attribute analyze: self selection asString].
[attribute := TextURL new.
thisSel := attribute analyze: self selection asString].
["Edit hidden info"
thisSel := self hiddenInfo. "includes selection"
attribute := TextEmphasis normal].
["Copy hidden info"
self copyHiddenInfo.
^true]. "no other action"
} at: index.
action value.
thisSel ifNil: [^true]. "Could not figure out what to link to"
attribute ifNotNil: [
+ thisSel ifEmpty:[ | oldAttributes |
- thisSel ifEmpty:[
"only change emphasisHere while typing"
oldAttributes := paragraph text attributesAt: self pointIndex.
self insertTypeAhead: characterStream.
emphasisHere _ Text addAttribute: attribute toArray: oldAttributes.
] ifNotEmpty: [
self replaceSelectionWith: (thisSel asText addAttribute: attribute).
]
].
^true!
Item was changed:
----- Method: MatrixTransformMorph>>fullBounds (in category 'layout') -----
fullBounds
+
- | subBounds |
fullBounds ifNil:[
fullBounds := self bounds.
+ submorphs do:[:m| | subBounds |
- submorphs do:[:m|
subBounds := (self transform localBoundsToGlobal: m fullBounds).
fullBounds := fullBounds quickMerge: subBounds.
].
].
^fullBounds!
Item was changed:
----- Method: SimpleHierarchicalListMorph>>selectionOneOf: (in category 'selection') -----
selectionOneOf: aListOfItems
"Set the selection to the first item in the list which is represented by one of my submorphs"
+
+ aListOfItems do: [ :item | | index |
- | index |
- aListOfItems do: [ :item |
index := scroller submorphs findFirst: [:m |
m withoutListWrapper = item withoutListWrapper
].
index > 0 ifTrue: [^self selectionIndex: index].
].
self selectionIndex: 0.!
Item was changed:
----- Method: Morph class>>morphsUnknownToTheirOwners (in category 'misc') -----
morphsUnknownToTheirOwners
"Return a list of all morphs (other than HandMorphs) whose owners do not contain them in their submorph lists"
"Morph morphsUnknownToTheirOwners"
+ | problemMorphs |
- | problemMorphs itsOwner |
problemMorphs := OrderedCollection new.
self allSubInstances do:
+ [:m | | itsOwner |
+ (m isHandMorph not and: [((itsOwner := m owner) ~~ nil and: [(itsOwner submorphs includes: m) not])])
- [:m | (m isHandMorph not and: [((itsOwner := m owner) ~~ nil and: [(itsOwner submorphs includes: m) not])])
ifTrue:
[problemMorphs add: m]].
^ problemMorphs!
Item was changed:
----- Method: Morph>>installAsCurrent: (in category 'card in a stack') -----
installAsCurrent: anInstance
"Install anInstance as the one currently viewed in the receiver. Dock up all the morphs in the receiver which contain data rooted in the player instance to the instance data. Run any 'opening' scripts that pertain."
+ | fieldList |
- | fieldList itsFocus |
self player == anInstance ifTrue: [^ self].
fieldList := self allMorphs select:
[:aMorph | (aMorph wouldAcceptKeyboardFocusUponTab) and: [aMorph isLocked not]].
self currentWorld hands do:
+ [:aHand | | itsFocus |
+ (itsFocus := aHand keyboardFocus) notNil ifTrue:
- [:aHand | (itsFocus := aHand keyboardFocus) notNil ifTrue:
[(fieldList includes: itsFocus) ifTrue: [aHand newKeyboardFocus: nil]]].
self player uninstallFrom: self. "out with the old"
anInstance installPrivateMorphsInto: self.
self changed.
anInstance costume: self.
self player: anInstance.
self player class variableDocks do:
[:aVariableDock | aVariableDock dockMorphUpToInstance: anInstance].
self currentWorld startSteppingSubmorphsOf: self!
Item was changed:
----- Method: Morph class>>allSketchMorphForms (in category 'testing') -----
allSketchMorphForms
"Answer a Set of forms of SketchMorph (sub) instances, except those
used as button images, ones being edited, and those with 0 extent."
+ | reasonableForms |
- | reasonableForms form |
reasonableForms := Set new.
Morph allSketchMorphClasses do:
[:cls | cls allInstances do:
+ [:m | | form |
+ (m owner isKindOf: SketchEditorMorph orOf: IconicButton)
- [:m | (m owner isKindOf: SketchEditorMorph orOf: IconicButton)
ifFalse:
[form := m form.
((form width > 0) and: [form height > 0]) ifTrue: [reasonableForms add: form]]]].
^ reasonableForms!
Item was changed:
----- Method: MorphicModel>>compilePropagationMethods (in category 'compilation') -----
compilePropagationMethods
+
- | varName |
(self class organization listAtCategoryNamed: 'private - propagation' asSymbol)
+ do: [:sel | | varName |
+ varName := sel allButLast.
- do: [:sel | varName := sel allButLast.
model class compilePropagationForVarName: varName slotName: slotName]!
Item was changed:
----- Method: TextEditor>>explain (in category 'menu messages') -----
explain
"Try to shed some light on what kind of entity the current selection is.
The selection must be a single token or construct. Insert the answer after
the selection. Send private messages whose names begin with 'explain'
that return a string if they recognize the selection, else nil."
+
- | string tiVars cgVars selectors delimitors numbers sorry reply symbol |
Cursor execute showWhile:
+ [ | string numbers delimitors cgVars reply selectors tiVars symbol sorry |
+ sorry := '"Sorry, I can''t explain that. Please select a single
- [sorry _ '"Sorry, I can''t explain that. Please select a single
token, construct, or special character.'.
+ sorry := sorry , (morph canDiscardEdits
- sorry _ sorry , (morph canDiscardEdits
ifFalse: [' Also, please cancel or accept."']
ifTrue: ['"']).
+ (string := self selection asString) isEmpty
+ ifTrue: [reply := '']
+ ifFalse: [string := self explainScan: string.
- (string _ self selection asString) isEmpty
- ifTrue: [reply _ '']
- ifFalse: [string _ self explainScan: string.
"Remove space, tab, cr"
"Temps and Instance vars need only test strings that are all letters"
(string detect: [:char | (char isLetter or: [char isDigit]) not]
ifNone: []) ifNil:
+ [tiVars := self explainTemp: string.
+ tiVars == nil ifTrue: [tiVars := self explainInst: string]].
- [tiVars _ self explainTemp: string.
- tiVars == nil ifTrue: [tiVars _ self explainInst: string]].
(tiVars == nil and: [model respondsTo: #explainSpecial:])
+ ifTrue: [tiVars := model explainSpecial: string].
- ifTrue: [tiVars _ model explainSpecial: string].
tiVars == nil
+ ifTrue: [tiVars := '']
+ ifFalse: [tiVars := tiVars , '\' withCRs].
- ifTrue: [tiVars _ '']
- ifFalse: [tiVars _ tiVars , '\' withCRs].
"Context, Class, Pool, and Global vars, and Selectors need
only test symbols"
+ (Symbol hasInterned: string ifTrue: [:s | symbol := s])
+ ifTrue: [cgVars := self explainCtxt: symbol.
- (Symbol hasInterned: string ifTrue: [:s | symbol _ s])
- ifTrue: [cgVars _ self explainCtxt: symbol.
cgVars == nil
+ ifTrue: [cgVars := self explainClass: symbol.
+ cgVars == nil ifTrue: [cgVars := self explainGlobal: symbol]].
- ifTrue: [cgVars _ self explainClass: symbol.
- cgVars == nil ifTrue: [cgVars _ self explainGlobal: symbol]].
"See if it is a Selector (sent here or not)"
+ selectors := self explainMySel: symbol.
- selectors _ self explainMySel: symbol.
selectors == nil
ifTrue:
+ [selectors := self explainPartSel: string.
- [selectors _ self explainPartSel: string.
selectors == nil ifTrue: [
+ selectors := self explainAnySel: symbol]]]
+ ifFalse: [selectors := self explainPartSel: string].
- selectors _ self explainAnySel: symbol]]]
- ifFalse: [selectors _ self explainPartSel: string].
cgVars == nil
+ ifTrue: [cgVars := '']
+ ifFalse: [cgVars := cgVars , '\' withCRs].
- ifTrue: [cgVars _ '']
- ifFalse: [cgVars _ cgVars , '\' withCRs].
selectors == nil
+ ifTrue: [selectors := '']
+ ifFalse: [selectors := selectors , '\' withCRs].
- ifTrue: [selectors _ '']
- ifFalse: [selectors _ selectors , '\' withCRs].
string size = 1
ifTrue: ["single special characters"
+ delimitors := self explainChar: string]
- delimitors _ self explainChar: string]
ifFalse: ["matched delimitors"
+ delimitors := self explainDelimitor: string].
+ numbers := self explainNumber: string.
+ numbers == nil ifTrue: [numbers := ''].
+ delimitors == nil ifTrue: [delimitors := ''].
+ reply := tiVars , cgVars , selectors , delimitors , numbers].
+ reply size = 0 ifTrue: [reply := sorry].
- delimitors _ self explainDelimitor: string].
- numbers _ self explainNumber: string.
- numbers == nil ifTrue: [numbers _ ''].
- delimitors == nil ifTrue: [delimitors _ ''].
- reply _ tiVars , cgVars , selectors , delimitors , numbers].
- reply size = 0 ifTrue: [reply _ sorry].
self afterSelectionInsertAndSelect: reply]!
Item was changed:
----- Method: Morph>>allStringsAfter: (in category 'debug and other') -----
allStringsAfter: aSubmorph
"return an OrderedCollection of strings of text in my submorphs. If aSubmorph is non-nil, begin with that container."
+ | list ok |
- | list string ok |
list := OrderedCollection new.
ok := aSubmorph isNil.
self allMorphsDo:
+ [:sub | | string |
- [:sub |
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 changed:
----- Method: Morph>>abstractAModel (in category 'card in a stack') -----
abstractAModel
"Find data-containing fields in me. Make a new class, whose instance variables are named for my fields, and whose values are the values I am showing. Use a CardPlayer for now. Force the user to name the fields. Make slots for text, Number Watchers, SketchMorphs, and ImageMorphs."
+ | unnamed ans player twoListsOfMorphs holdsSepData docks oldPlayer instVarNames |
- | instVarNames unnamed ans player twoListsOfMorphs holdsSepData docks oldPlayer iVarName |
(oldPlayer := self player) ifNotNil:
[oldPlayer belongsToUniClass
ifTrue:
["Player"
oldPlayer class instVarNames notEmpty
ifTrue:
[self
inform: 'I already have a regular Player, so I can''t have a CardPlayer'.
^true]]].
twoListsOfMorphs := StackMorph discoverSlots: self.
holdsSepData := twoListsOfMorphs first.
instVarNames := ''.
holdsSepData do:
+ [:ea | | iVarName |
- [:ea |
iVarName := Scanner wellFormedInstanceVariableNameFrom: ea knownName.
iVarName = ea knownName ifFalse: [ea name: iVarName].
instVarNames := instVarNames , iVarName , ' '].
unnamed := twoListsOfMorphs second. "have default names"
instVarNames isEmpty
ifTrue:
[self
inform: 'No named fields were found.
Please get a halo on each field and give it a name.
Labels or non-data fields should be named "shared xxx".'.
^false].
unnamed notEmpty
ifTrue:
[ans := (UIManager default
chooseFrom: #(
'All other fields are non-data fields'.
'Stop. Let me give a name to some more fields'.
) title: 'Data fields are ' , instVarNames printString
, ('\Some fields are not named. Are they labels or non-data fields?'
, '\Please get a halo on each data field and give it a name.') withCRs) = 1.
ans ifFalse: [^false]].
unnamed
withIndexDo: [:mm :ind | mm setName: 'shared label ' , ind printString].
"Make a Player with instVarNames. Make me be the costume"
player := CardPlayer instanceOfUniqueClassWithInstVarString: instVarNames
andClassInstVarString: ''.
self player: player.
player costume: self.
"Fill in the instance values. Make docks first."
docks := OrderedCollection new.
holdsSepData do:
[:morph |
morph setProperty: #shared toValue: true. "in case it is deeply embedded"
morph setProperty: #holdsSeparateDataForEachInstance toValue: true.
player class compileInstVarAccessorsFor: morph knownName.
morph isSyntaxMorph ifTrue: [morph setTarget: player]. "hookup the UpdatingString!!"
docks addAll: morph variableDocks].
player class newVariableDocks: docks.
docks do: [:dd | dd storeMorphDataInInstance: player].
"oldPlayer class mdict do: [:assoc | move to player]. move methods to new class?"
"oldPlayer become: player."
^true "success"!
Item was changed:
----- Method: PluggableTextMorph>>exploreIt (in category 'menu commands') -----
exploreIt
+
+ self handleEdit: [ | result |
- | result |
- self handleEdit: [
result := textMorph editor evaluateSelection.
((result isKindOf: FakeClassPool) or: [result == #failedDoit])
ifTrue: [self flash]
ifFalse: [result explore]].!
Item was changed:
----- Method: WorldState>>displayWorld:submorphs: (in category 'update cycle') -----
displayWorld: aWorld submorphs: submorphs
"Update this world's display."
+ | deferredUpdateMode handsToDraw allDamage |
- | deferredUpdateMode worldDamageRects handsToDraw handDamageRects allDamage |
submorphs do: [:m | m fullBounds]. "force re-layout if needed"
self checkIfUpdateNeeded ifFalse: [^ self]. "display is already up-to-date"
deferredUpdateMode := self doDeferredUpdatingFor: aWorld.
deferredUpdateMode ifFalse: [self assuredCanvas].
+ canvas roundCornersOf: aWorld during:[ | handDamageRects worldDamageRects |
- canvas roundCornersOf: aWorld during:[
worldDamageRects := self drawWorld: aWorld submorphs: submorphs invalidAreasOn: canvas. "repair world's damage on canvas"
"self handsDo:[:h| h noticeDamageRects: worldDamageRects]."
handsToDraw := self selectHandsToDrawForDamage: worldDamageRects.
handDamageRects := handsToDraw collect: [:h | h savePatchFrom: canvas].
allDamage := worldDamageRects, handDamageRects.
handsToDraw reverseDo: [:h | canvas fullDrawMorph: h]. "draw hands onto world canvas"
].
"*make this true to flash damaged areas for testing*"
Preferences debugShowDamage ifTrue: [aWorld flashRects: allDamage color: Color black].
canvas finish.
"quickly copy altered rects of canvas to Display:"
deferredUpdateMode
ifTrue: [self forceDamageToScreen: allDamage]
ifFalse: [canvas showAt: aWorld viewBox origin invalidRects: allDamage].
handsToDraw do: [:h | h restoreSavedPatchOn: canvas]. "restore world canvas under hands"
Display deferUpdates: false; forceDisplayUpdate.
!
Item was changed:
----- Method: PasteUpMorph>>replaceTallSubmorphsByThumbnails (in category 'options') -----
replaceTallSubmorphsByThumbnails
"Any submorphs that seem to tall get replaced by thumbnails; their balloon text is copied over to the thumbnail"
+ | heightForThumbnails maxHeightToAvoidThumbnailing maxWidthForThumbnails |
- | itsThumbnail heightForThumbnails maxHeightToAvoidThumbnailing maxWidthForThumbnails existingHelp |
heightForThumbnails := self heightForThumbnails.
maxHeightToAvoidThumbnailing := self maxHeightToAvoidThumbnailing.
maxWidthForThumbnails := self maximumThumbnailWidth.
self submorphs do:
+ [:aMorph | | existingHelp itsThumbnail |
- [:aMorph |
itsThumbnail := aMorph representativeNoTallerThan: maxHeightToAvoidThumbnailing norWiderThan: maxWidthForThumbnails thumbnailHeight: heightForThumbnails.
(aMorph == itsThumbnail)
ifFalse:
[existingHelp := aMorph balloonText.
self replaceSubmorph: aMorph by: itsThumbnail.
existingHelp ifNotNil:
[itsThumbnail setBalloonText: existingHelp]]]!
Item was changed:
----- Method: TheWorldMenu>>worldMenuHelp (in category 'commands') -----
worldMenuHelp
+ | explanation aList |
- | aList aMenu cnts explanation |
"self currentWorld primaryHand worldMenuHelp"
aList := OrderedCollection new.
#(helpMenu changesMenu openMenu debugMenu projectMenu scriptingMenu windowsMenu playfieldMenu appearanceMenu flapsMenu)
with:
#('help' 'changes' 'open' 'debug' 'projects' 'authoring tools' 'windows' 'playfield options' 'appearance' 'flaps') do:
+ [:sel :title | | aMenu |
+ aMenu := self perform: sel.
- [:sel :title | aMenu := self perform: sel.
aMenu items do:
+ [:it | | cnts |
+ (((cnts := it contents) = 'keep this menu up') or: [cnts isEmpty])
- [:it | (((cnts := it contents) = 'keep this menu up') or: [cnts isEmpty])
ifFalse: [aList add: (cnts, ' - ', title translated)]]].
aList := aList asSortedCollection: [:a :b | a asLowercase < b asLowercase].
explanation := String streamContents: [:aStream | aList do:
[:anItem | aStream nextPutAll: anItem; cr]].
(StringHolder new contents: explanation)
openLabel: 'Where in the world menu is...' translated!
Item was changed:
----- Method: ComplexProgressIndicator class>>historyReport (in category 'as yet unclassified') -----
historyReport
"
ComplexProgressIndicator historyReport
"
| answer |
History ifNil: [^Beeper beep].
answer := String streamContents: [ :strm |
- | data |
(History keys asArray sort: [ :a :b | a asString <= b asString]) do: [ :k |
+ | data |
strm nextPutAll: k printString; cr.
data := History at: k.
(data keys asArray sort: [ :a :b | a asString <= b asString]) do: [ :dataKey |
strm tab; nextPutAll: dataKey printString,' ',
(data at: dataKey) asArray printString; cr.
].
strm cr.
].
].
StringHolder new
contents: answer contents;
openLabel: 'Progress History'!
Item was changed:
----- Method: PolygonMorph>>lineSegmentsDo: (in category 'smoothing') -----
lineSegmentsDo: endPointsBlock
"Emit a sequence of segment endpoints into endPointsBlock."
"Unlike the method this one replaces we expect the curve
coefficents not the dirivatives"
"Also unlike the replaced method the smooth closed curve
does
not need an extra vertex.
We take care of the extra endpoint here. Just like for
segmented curves."
+ | cs x y beginPoint |
- | n t x y x1 x2 x3 y1 y2 y3 beginPoint endPoint cs |
vertices size < 1
ifTrue: [^ self].
"test too few vertices first"
self isCurvy
ifFalse: [beginPoint := nil.
"smoothCurve
ifTrue: [cs := self coefficients]."
"some things still depend on smoothCurves having
curveState"
vertices
do: [:vert |
beginPoint
ifNotNil: [endPointsBlock value: beginPoint value: vert].
beginPoint := vert].
(closed
or: [vertices size = 1])
ifTrue: [endPointsBlock value: beginPoint value: vertices first].
^ self].
"For curves we include all the interpolated sub segments."
"self assert: [(vertices size > 2 )]. "
cs := self coefficients.
beginPoint := (x := cs first first) @ (y := cs fifth first).
(closed
ifTrue: [1 to: cs first size]
ifFalse: [1 to: cs first size - 1])
+ do: [:i | | x1 y1 endPoint n y2 t x3 y3 x2 |
- do: [:i |
"taylor series coefficients"
x1 := cs second at: i.
y1 := cs sixth at: i.
x2 := cs third at: i.
y2 := cs seventh at: i.
x3 := cs fourth at: i.
y3 := cs eighth at: i.
n := cs ninth at: i.
"guess n
n := 5 max: (x2 abs + y2 abs * 2.0 + (cs third atWrap:
i
+ 1) abs + (cs seventh atWrap: i + 1) abs / 100.0)
rounded."
1
to: n - 1
do: [:j |
t := j asFloat / n asFloat.
endPoint := x3 * t + x2 * t + x1 * t + x @ (y3 * t + y2 * t + y1 * t + y).
endPointsBlock value: beginPoint value: endPoint.
beginPoint := endPoint].
endPoint := (x := cs first atWrap: i + 1) @ (y := cs fifth atWrap: i + 1).
endPointsBlock value: beginPoint value: endPoint.
beginPoint := endPoint]!
Item was changed:
----- Method: ProportionalSplitterMorph>>updateFromEvent: (in category 'as yet unclassified') -----
updateFromEvent: anEvent
+ | delta selfTop selfBottom selfLeft selfRight |
- | delta firstRight firstBottom secondLeft secondTop selfTop selfBottom selfLeft selfRight |
delta := splitsTopAndBottom
ifTrue: [0 @ ((self normalizedY: anEvent cursorPoint y) - lastMouse y)]
ifFalse: [(self normalizedX: anEvent cursorPoint x) - lastMouse x @ 0].
splitsTopAndBottom
ifTrue: [lastMouse := lastMouse x @ (self normalizedY: anEvent cursorPoint y)]
ifFalse: [lastMouse := (self normalizedX: anEvent cursorPoint x) @ lastMouse y].
leftOrTop
+ do: [:each | | firstRight firstBottom |
- do: [:each |
firstRight := each layoutFrame rightOffset
ifNil: [0].
firstBottom := each layoutFrame bottomOffset
ifNil: [0].
each layoutFrame rightOffset: firstRight + delta x.
each layoutFrame bottomOffset: firstBottom + delta y].
rightOrBottom
+ do: [:each | | secondLeft secondTop |
- do: [:each |
secondLeft := each layoutFrame leftOffset
ifNil: [0].
secondTop := each layoutFrame topOffset
ifNil: [0].
each layoutFrame leftOffset: secondLeft + delta x.
each layoutFrame topOffset: secondTop + delta y].
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.
self layoutFrame bottomOffset: selfBottom + delta y.
self layoutFrame leftOffset: selfLeft + delta x.
self layoutFrame rightOffset: selfRight + delta x.
self owner layoutChanged!
Item was changed:
----- Method: WorldState>>drawWorld:submorphs:invalidAreasOn: (in category 'update cycle') -----
drawWorld: aWorld submorphs: submorphs invalidAreasOn: aCanvas
"Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that
were redrawn."
+ | rectList n morphs rects validList |
- | rectList c i n mm morphs rects rectToFill remnants rect validList |
rectList := damageRecorder invalidRectsFullBounds: aWorld viewBox.
"sort by areas to draw largest portions first"
rectList := rectList asArray sort: [:r1 :r2 | r1 area > r2 area].
damageRecorder reset.
n := submorphs size.
morphs := OrderedCollection new: n * 2.
rects := OrderedCollection new: n * 2.
validList := OrderedCollection new: n * 2.
rectList do:
[:dirtyRect |
dirtyRect allAreasOutsideList: validList
do:
+ [:r | | mm rectToFill remnants c rect i |
- [:r |
"Experimental top-down drawing --
Traverses top to bottom, stopping if the entire area is filled.
If only a single rectangle remains, then continue with the reduced rectangle."
rectToFill := r.
i := 1.
[rectToFill isNil or: [i > n]] whileFalse:
[mm := submorphs at: i.
((mm fullBounds intersects: r) and: [mm visible])
ifTrue:
[morphs addLast: mm.
rects addLast: rectToFill.
remnants := mm areasRemainingToFill: rectToFill.
remnants size = 1 ifTrue: [rectToFill := remnants first].
remnants isEmpty ifTrue: [rectToFill := nil]].
i := i + 1].
"Now paint from bottom to top, but using the reduced rectangles."
rectToFill
ifNotNil: [aWorld drawOn: (c := aCanvas copyClipRect: rectToFill)].
[morphs isEmpty] whileFalse:
[(rect := rects removeLast) == rectToFill
ifFalse: [c := aCanvas copyClipRect: (rectToFill := rect)].
c fullDrawMorph: morphs removeLast].
morphs reset.
rects reset.
validList add: r]].
^validList!
Item was changed:
----- Method: Morph>>addMorphInFrontOfLayer: (in category 'WiW support') -----
addMorphInFrontOfLayer: aMorph
+ | targetLayer |
- | targetLayer layerHere |
targetLayer := aMorph morphicLayerNumberWithin: self.
+ submorphs do: [ :each | | layerHere |
- submorphs do: [ :each |
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: SimpleHierarchicalListMorph>>adjustSubmorphPositions (in category 'private') -----
adjustSubmorphPositions
+ | p |
- | p h |
p := 0 at 0.
+ scroller submorphsDo: [ :each | | h |
- scroller submorphsDo: [ :each |
h := each height.
each privateBounds: (p extent: 9999 at h).
p := p + (0 at h)
].
self
changed;
layoutChanged;
setScrollDeltas.
!
Item was changed:
----- Method: PolygonMorph>>drawDashedBorderOn:usingEnds: (in category 'drawing') -----
drawDashedBorderOn: aCanvas usingEnds: anArray
"Display my border on the canvas. NOTE: mostly copied from
drawBorderOn:"
+ | bevel topLeftColor bottomRightColor bigClipRect lineColor segmentOffset |
- | lineColor bevel topLeftColor bottomRightColor bigClipRect p1i p2i segmentOffset |
(borderColor isNil
or: [borderColor isColor
and: [borderColor isTransparent]])
ifTrue: [^ self].
lineColor := borderColor.
bevel := false.
"Border colors for bevelled effects depend on CW ordering of
vertices"
borderColor == #raised
ifTrue: [topLeftColor := color lighter.
bottomRightColor := color darker.
bevel := true].
borderColor == #inset
ifTrue: [topLeftColor := owner colorForInsets darker.
bottomRightColor := owner colorForInsets lighter.
bevel := true].
bigClipRect := aCanvas clipRect expandBy: self borderWidth + 1 // 2.
segmentOffset := self borderDashOffset.
self
+ lineSegmentsDo: [:p1 :p2 | | p1i p2i |
- lineSegmentsDo: [:p1 :p2 |
p1i := p1 asIntegerPoint.
p2i := p2 asIntegerPoint.
self hasArrows
ifTrue: ["Shorten line ends so as not to interfere with tip
of arrow."
((arrows == #back
or: [arrows == #both])
and: [p1 = vertices first])
ifTrue: [p1i := anArray first asIntegerPoint].
((arrows == #forward
or: [arrows == #both])
and: [p2 = vertices last])
ifTrue: [p2i := anArray last asIntegerPoint]].
(closed
or: ["bigClipRect intersects: (p1i rect: p2i)
optimized:"
((p1i min: p2i)
max: bigClipRect origin)
<= ((p1i max: p2i)
min: bigClipRect corner)])
ifTrue: [bevel
ifTrue: [lineColor := (p1i quadrantOf: p2i)
> 2
ifTrue: [topLeftColor]
ifFalse: [bottomRightColor]].
segmentOffset := aCanvas
line: p1i
to: p2i
width: borderWidth
color: lineColor
dashLength: borderDashSpec first
secondColor: borderDashSpec third
secondDashLength: borderDashSpec second
startingOffset: segmentOffset]]!
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)"
+
- | item |
+ dataForMenu do: [ :itemData | | item |
- dataForMenu do: [ :itemData |
itemData ifNil: [aMenu addLine] ifNotNil:
[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: SketchMorph>>editDrawingIn:forBackground: (in category 'menu') -----
editDrawingIn: aPasteUpMorph forBackground: forBackground
"Edit an existing sketch."
+ | w bnds sketchEditor rotCenter aPaintTab aWorld aPaintBox |
- | w bnds sketchEditor pal aPaintTab aWorld aPaintBox tfx rotCenter |
self world assureNotPaintingElse: [^self].
w := aPasteUpMorph world.
w prepareToPaint.
w displayWorld.
self visible: false.
bnds := forBackground
ifTrue: [aPasteUpMorph boundsInWorld]
ifFalse:
[bnds := self boundsInWorld expandBy: 60 @ 60.
(aPasteUpMorph paintingBoundsAround: bnds center) merge: bnds].
sketchEditor := SketchEditorMorph new.
forBackground
ifTrue: [sketchEditor setProperty: #background toValue: true].
w addMorphFront: sketchEditor.
sketchEditor
initializeFor: self
inBounds: bnds
pasteUpMorph: aPasteUpMorph.
rotCenter := self rotationCenter.
sketchEditor afterNewPicDo:
+ [:aForm :aRect | | tfx |
- [:aForm :aRect |
self visible: true.
self form: aForm.
tfx := aPasteUpMorph transformFrom: aPasteUpMorph world.
self topRendererOrSelf position: (tfx globalPointToLocal: aRect origin).
self rotationStyle: sketchEditor rotationStyle.
self forwardDirection: sketchEditor forwardDirection.
(rotCenter notNil and: [(rotCenter = (0.5 @ 0.5)) not]) ifTrue:
[self rotationCenter: rotCenter].
(aPaintTab := (aWorld := self world) paintingFlapTab)
ifNotNil: [aPaintTab hideFlap]
ifNil: [(aPaintBox := aWorld paintBox) ifNotNil: [aPaintBox delete]].
self presenter drawingJustCompleted: self.
forBackground ifTrue: [self goBehind "shouldn't be necessary"]]
ifNoBits:
+ [ | pal |"If no bits drawn. Must keep old pic. Can't have no picture"
- ["If no bits drawn. Must keep old pic. Can't have no picture"
self visible: true.
aWorld := self currentWorld.
"sometimes by now I'm no longer in a world myself, but we still need
to get ahold of the world so that we can deal with the palette"
((pal := aPasteUpMorph standardPalette) notNil and: [pal isInWorld])
ifTrue:
[(aPaintBox := aWorld paintBox) ifNotNil: [aPaintBox delete].
pal viewMorph: self]
ifFalse:
[(aPaintTab := (aWorld := self world) paintingFlapTab)
ifNotNil: [aPaintTab hideFlap]
ifNil: [(aPaintBox := aWorld paintBox) ifNotNil: [aPaintBox delete]]]]!
Item was changed:
----- Method: ColorPickerMorph>>locationIndicator (in category 'accessing') -----
locationIndicator
+
+ ^self valueOfProperty: #locationIndicator ifAbsent:[ | loc |
- | loc |
- ^self valueOfProperty: #locationIndicator ifAbsent:[
loc := EllipseMorph new.
loc color: Color transparent;
borderWidth: 1;
borderColor: Color red;
extent: 6 at 6.
self setProperty: #locationIndicator toValue: loc.
self addMorphFront: loc.
loc]!
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"
+ | result rcvr ctxt valueAsString v |
- | result rcvr ctxt cm v valueAsString |
self lineSelectAndEmptyCheck: [^ -1].
(model respondsTo: #doItReceiver)
ifTrue: [FakeClassPool adopt: model selectedClass. "Include model pool vars if any"
rcvr := model doItReceiver.
ctxt := model doItContext]
ifFalse: [rcvr := ctxt := nil].
+ result := [ | cm |
- result := [
cm := rcvr class evaluatorClass new
compiledMethodFor: self selectionAsStream
in: ctxt
to: rcvr
notifying: self
ifFail: [FakeClassPool adopt: nil. ^ #failedDoit]
logged: false.
Time millisecondsToRun:
[v := cm valueWithReceiver: rcvr arguments: (Array with: ctxt)].
]
on: OutOfScopeNotification
do: [ :ex | ex resume: true].
FakeClassPool adopt: nil.
"We do not want to have large result displayed"
valueAsString := v printString.
(valueAsString size > 30) ifTrue: [valueAsString := (valueAsString copyFrom: 1 to: 30), '...'].
PopUpMenu
inform: 'Time to compile and execute: ', result printString, 'ms res: ', valueAsString.
!
Item was changed:
----- Method: MorphicEvent class>>readFrom: (in category 'instance creation') -----
readFrom: aStream
"Read a MorphicEvent from the given stream."
+ | typeString |
- | typeString c |
typeString := String streamContents:
+ [:s | | c | [(c := aStream next) isLetter] whileTrue: [s nextPut: c]].
- [:s | [(c := aStream next) isLetter] whileTrue: [s nextPut: c]].
typeString = 'mouseMove' ifTrue:[^MouseMoveEvent type: #mouseMove readFrom: aStream].
typeString = 'mouseDown' ifTrue:[^MouseButtonEvent type: #mouseDown readFrom: aStream].
typeString = 'mouseUp' ifTrue:[^MouseButtonEvent type: #mouseUp readFrom: aStream].
typeString = 'keystroke' ifTrue:[^KeyboardEvent type: #keystroke readFrom: aStream].
typeString = 'keyDown' ifTrue:[^KeyboardEvent type: #keyDown readFrom: aStream].
typeString = 'keyUp' ifTrue:[^KeyboardEvent type: #keyUp readFrom: aStream].
typeString = 'mouseOver' ifTrue:[^MouseEvent type: #mouseOver readFrom: aStream].
typeString = 'mouseEnter' ifTrue:[^MouseEvent type: #mouseEnter readFrom: aStream].
typeString = 'mouseLeave' ifTrue:[^MouseEvent type: #mouseLeave readFrom: aStream].
typeString = 'unknown' ifTrue:[^MorphicUnknownEvent type: #unknown readFrom: aStream].
^nil
!
Item was changed:
----- Method: Morph>>reassessBackgroundShape (in category 'card in a stack') -----
reassessBackgroundShape
"A change has been made which may affect the instance structure of the Card uniclass that holds the instance state, which can also be thought of as the 'card data'."
"Caution: still to be done: the mechanism so that when a new instance variable is added, it gets initialized in all subinstances of the receiver's player, which are the cards of this shape. One needs to take into account here the instance variable names coming in; those that are unchanged should keep their values, but those that have newly arrived should obtain their default values from the morphs on whose behalf they are being maintained in the model"
+ | requestedName |
- | takenNames uniqueName requestedName variableDocks docks sepDataMorphs sorted existing name1 name2 |
self isStackBackground ifFalse: [^Beeper beep]. "bulletproof against deconstruction"
Cursor wait showWhile:
+ [ | variableDocks takenNames sepDataMorphs sorted existing |variableDocks := OrderedCollection new. "This will be stored in the uniclass's
- [variableDocks := OrderedCollection new. "This will be stored in the uniclass's
class-side inst var #variableDocks"
takenNames := OrderedCollection new.
sepDataMorphs := OrderedCollection new. "fields, holders of per-card data"
self submorphs do:
[:aMorph |
aMorph renderedMorph holdsSeparateDataForEachInstance
ifTrue: [sepDataMorphs add: aMorph renderedMorph]
ifFalse:
["look for buried fields, inside a frame"
aMorph renderedMorph isShared
ifTrue:
[aMorph allMorphs do:
[:mm |
mm renderedMorph holdsSeparateDataForEachInstance
ifTrue: [sepDataMorphs add: mm renderedMorph]]]]].
sorted := SortedCollection new
sortBlock: [:a :b | (a valueOfProperty: #cardInstance) notNil]. "puts existing ones first"
sorted addAll: sepDataMorphs.
sorted do:
+ [:aMorph | | docks |
- [:aMorph |
docks := aMorph variableDocks.
"Each morph can request multiple variables.
This complicates matters somewhat but creates a generality for Fabrk-like uses.
Each spec is an instance of VariableDock, and it provides a point of departure
for the negotiation between the PasteUp and its constitutent morphs"
docks do:
+ [:aVariableDock | | uniqueName |
- [:aVariableDock |
uniqueName := self player
uniqueInstanceVariableNameLike: (requestedName := aVariableDock
variableName)
excluding: takenNames.
uniqueName ~= requestedName
ifTrue:
[aVariableDock variableName: uniqueName.
aMorph noteNegotiatedName: uniqueName for: requestedName].
takenNames add: uniqueName].
variableDocks addAll: docks].
existing := self player class instVarNames.
variableDocks := (variableDocks asSortedCollection:
+ [:dock1 :dock2 | | name2 name1 |
- [:dock1 :dock2 |
name1 := dock1 variableName.
name2 := dock2 variableName.
(existing indexOf: name1 ifAbsent: [0])
< (existing indexOf: name2 ifAbsent: [variableDocks size])])
asOrderedCollection.
self player class setNewInstVarNames: (variableDocks
collect: [:info | info variableName asString]).
"NB: sets up accessors, and removes obsolete ones"
self player class newVariableDocks: variableDocks]!
Item was changed:
----- Method: EventHandler>>printOn: (in category 'printing') -----
printOn: aStream
+ | recipients |
- | aVal recipients |
super printOn: aStream.
#('mouseDownSelector' 'mouseStillDownSelector' 'mouseUpSelector' 'mouseEnterSelector' 'mouseLeaveSelector' 'mouseEnterDraggingSelector' 'mouseLeaveDraggingSelector' 'doubleClickSelector' 'keyStrokeSelector')
do:
+ [:aName | | aVal |
- [:aName |
(aVal := self instVarNamed: aName) notNil
ifTrue: [aStream nextPutAll: '; ' , aName , '=' , aVal]].
(recipients := self allRecipients) notEmpty
ifTrue:
[aStream nextPutAll: ' recipients: '.
recipients printOn: aStream]!
Item was changed:
----- Method: PasteUpMorph>>localFlapTabs (in category 'flaps') -----
localFlapTabs
"Answer a list of local flap tabs in the current project"
+ | globalList aList |
- | globalList aList aFlapTab |
globalList := Flaps globalFlapTabsIfAny.
aList := OrderedCollection new.
submorphs do:
+ [:m | | aFlapTab |
+ ((m isFlapTab) and: [(globalList includes: m) not])
- [:m | ((m isFlapTab) and: [(globalList includes: m) not])
ifTrue:
[aList add: m]
ifFalse:
[((m isFlap) and:
[(aFlapTab := m submorphs detect: [:n | n isFlapTab] ifNone: [nil]) notNil])
ifTrue:
[aList add: aFlapTab]]].
^ aList!
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."
+ | aNail representee handy posBlock |
- | aNail representee handy posBlock tempPos |
handy := self primaryHand.
posBlock :=
+ [:z | | tempPos |
- [:z |
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 isKindOf: PhraseTileMorph) or: [aMorph isSyntaxMorph])
ifFalse: [^aMorph].
aMorph userScriptSelector isEmptyOrNil
ifTrue:
["non-user"
self automaticPhraseExpansion ifFalse: [^aMorph]].
^aMorph morphToDropInPasteUp: self!
Item was changed:
----- Method: TextEditor>>saveContentsInFile (in category 'menu messages') -----
saveContentsInFile
"Save the receiver's contents string to a file, prompting the user for a file-name. Suggest a reasonable file-name."
+ | fileName stringToSave parentWindow labelToUse suggestedName |
- | fileName stringToSave parentWindow labelToUse suggestedName lastIndex |
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 |
- [:leaderTrailer |
"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: $. ifAbsent: [0].
(lastIndex = 0 or: [lastIndex = 1])
ifFalse: [suggestedName := suggestedName copyFrom: 1 to: lastIndex - 1]]]].
suggestedName ifNil: [suggestedName := labelToUse , '.text'].
fileName := UIManager default request: 'File name?'
initialAnswer: suggestedName.
fileName isEmptyOrNil
ifFalse:
[(FileStream newFileNamed: fileName)
nextPutAll: stringToSave;
close]!
Item was changed:
----- Method: PluggableTextMorph>>inspectIt (in category 'menu commands') -----
inspectIt
+
- | result |
self handleEdit:
+ [ | result |
+ result := textMorph editor evaluateSelection.
- [result := textMorph editor evaluateSelection.
((result isKindOf: FakeClassPool) or: [result == #failedDoit])
ifTrue: [self flash]
ifFalse: [result inspect]]!
Item was changed:
----- Method: NewParagraph>>clickAt:for:controller: (in category 'editing') -----
clickAt: clickPoint for: model controller: editor
"Give sensitive text a chance to fire. Display flash: (100 at 100 extent: 100 at 100)."
+ | startBlock action |
- | startBlock action target range boxes box |
action := false.
startBlock := self characterBlockAtPoint: clickPoint.
(text attributesAt: startBlock stringIndex forStyle: textStyle)
+ do: [:att | | range target box boxes |
+ att mayActOnClick ifTrue:
- do: [:att | att mayActOnClick ifTrue:
[(target := model) ifNil: [target := editor morph].
range := text rangeOf: att startingAt: startBlock stringIndex.
boxes := self selectionRectsFrom: (self characterBlockForIndex: range first)
to: (self characterBlockForIndex: range last+1).
box := boxes detect: [:each | each containsPoint: clickPoint] ifNone: [nil].
box ifNotNil:
[ box := (editor transformFrom: nil) invertBoundsRect: box.
editor morph allOwnersDo: [ :m | box := box intersect: (m boundsInWorld) ].
Utilities awaitMouseUpIn: box
repeating: []
ifSucceed: [(att actOnClickFor: target in: self at: clickPoint editor: editor) ifTrue: [action := true]].
Cursor currentCursor == Cursor webLink ifTrue:[Cursor normal show].
]]].
^ action!
Item was changed:
----- Method: Morph>>makeSiblings: (in category 'meta-actions') -----
makeSiblings: count
"Make multiple sibling, and return the list"
+ | listOfNewborns aPosition |
- | aPosition anInstance listOfNewborns |
aPosition := self position.
listOfNewborns := (1 to: count asInteger) asArray collect:
+ [:anIndex | | anInstance |
- [:anIndex |
anInstance := self usableSiblingInstance.
owner addMorphFront: anInstance.
aPosition := aPosition + (10 at 10).
anInstance position: aPosition.
anInstance].
self currentWorld startSteppingSubmorphsOf: self topRendererOrSelf owner.
^ listOfNewborns!
Item was changed:
----- Method: PluggableListMorph>>startDrag: (in category 'drag and drop') -----
startDrag: evt
+
- | ddm draggedItem draggedItemMorph passenger |
evt hand hasSubmorphs
ifTrue: [^ self].
+ [ | draggedItem draggedItemMorph passenger ddm |
+ (self dragEnabled and: [model okToChange])
- [(self dragEnabled
- and: [model okToChange])
ifFalse: [^ self].
(draggedItem := self selection)
ifNil: [^ self].
draggedItemMorph := StringMorph contents: draggedItem asStringOrText.
passenger := self model dragPassengerFor: draggedItemMorph inMorph: self.
passenger
ifNil: [^ self].
ddm := TransferMorph withPassenger: passenger from: self.
ddm
dragTransferType: (self model dragTransferTypeForMorph: self).
Preferences dragNDropWithAnimation
ifTrue: [self model dragAnimationFor: draggedItemMorph transferMorph: ddm].
evt hand grabMorph: ddm]
ensure: [Cursor normal show.
evt hand releaseMouseFocus: self]!
Item was changed:
----- Method: PolygonMorph>>closestPointTo: (in category 'geometry') -----
closestPointTo: aPoint
+ | closestPoint minDist |
- | curvePoint closestPoint dist minDist |
closestPoint := minDist := nil.
self lineSegmentsDo:
+ [:p1 :p2 | | dist curvePoint |
- [:p1 :p2 |
curvePoint := aPoint nearestPointOnLineFrom: p1 to: p2.
dist := curvePoint dist: aPoint.
(closestPoint isNil or: [dist < minDist])
ifTrue:
[closestPoint := curvePoint.
minDist := dist]].
^closestPoint!
Item was changed:
----- Method: FileList2>>publishingServers (in category 'initialization') -----
publishingServers
+ | dirList |
- | dir nameToShow dirList |
dirList := OrderedCollection new.
+ ServerDirectory serverNames do: [ :n | | dir nameToShow |
- ServerDirectory serverNames do: [ :n |
dir := ServerDirectory serverNamed: n.
(dir isProjectSwiki and: [dir acceptsUploads])
ifTrue: [
nameToShow := n.
dirList add: ((dir directoryWrapperClass with: dir name: nameToShow model: self)
balloonText: dir realUrl)]].
^dirList!
Item was changed:
----- Method: PolygonMorph>>updateHandles (in category 'editing') -----
updateHandles
+ | newVert |
- | newVert oldVert |
self isCurvy
ifTrue: [handles first center: vertices first.
handles last center: vertices last.
self midVertices
withIndexDo: [:midPt :vertIndex | (closed
or: [vertIndex < vertices size])
ifTrue: [newVert := handles atWrap: vertIndex * 2.
newVert position: midPt - (newVert extent // 2)]]]
ifFalse: [vertices
+ withIndexDo: [:vertPt :vertIndex | | oldVert |
- withIndexDo: [:vertPt :vertIndex |
oldVert := handles at: vertIndex * 2 - 1.
oldVert position: vertPt - (oldVert extent // 2).
(closed
or: [vertIndex < vertices size])
ifTrue: [newVert := handles at: vertIndex * 2.
newVert position: vertPt
+ (vertices atWrap: vertIndex + 1) - newVert extent // 2 + (1 @ -1)]]]!
Item was changed:
----- Method: Morph>>addHandlesTo:box: (in category 'halos and balloon help') -----
addHandlesTo: aHaloMorph box: box
"Add halo handles to the halo. Apply the halo filter if appropriate"
+
- | wantsIt aSelector |
aHaloMorph haloBox: box.
Preferences haloSpecifications do:
+ [:aSpec | | wantsIt aSelector |
- [:aSpec |
aSelector := aSpec addHandleSelector.
wantsIt := Preferences selectiveHalos
ifTrue:
[self wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph]
ifFalse:
[true].
wantsIt ifTrue:
[(#(addMakeSiblingHandle: addDupHandle:) includes: aSelector) ifTrue:
[wantsIt := self preferredDuplicationHandleSelector = aSelector].
wantsIt ifTrue:
[aHaloMorph perform: aSelector with: aSpec]]].
aHaloMorph innerTarget addOptionalHandlesTo: aHaloMorph box: box!
Item was changed:
----- Method: WorldState>>alarmSortBlock (in category 'alarms') -----
alarmSortBlock
-
- | answer |
-
- "Please pardon the hackery below. Since the block provided by this method is retained elsewhere, it is possible that the block argument variables would retain references to objects that were no longer really needed. In one case, this feature resulted in doubling the size of a published project."
-
^[ :alarm1 :alarm2 |
+ alarm1 scheduledTime < alarm2 scheduledTime.
- answer := alarm1 scheduledTime < alarm2 scheduledTime.
- alarm1 := alarm2 := nil.
- answer
]!
More information about the Packages
mailing list