|
Pharo /
WorldState
'From Pharo1.3a of ''18 January 2011'' [Latest update: #13144] on 15 April 2011 at 1:23:28 pm'!
Object subclass: #WorldState
instanceVariableNames: 'hands viewBox canvas damageRecorder stepList lastStepTime lastStepMessage lastCycleTime alarms lastAlarmTime menuBuilder'
classVariableNames: 'CanSurrenderToOS DebugShowDamage DeferredUIMessages DesktopMenuPragmaKeyword DesktopMenuTitle EasySelectingWorld LastCycleTime MinCycleLapse ServerMode ShowUpdateOptionInWorldMenu'
poolDictionaries: ''
category: 'Morphic-Worlds'!
!WorldState commentStamp: 'ls 7/10/2003 19:30' prior: 0!
The state of a Morphic world. (This needs some serious commenting!!!!)
The MinCycleLapse variable holds the minimum amount of time that a morphic cycle is allowed to take. If a cycle takes less than this, then interCyclePause: will wait until the full time has been used up.!
!WorldState methodsFor: 'alarms' stamp: 'ar 9/11/2000 16:43'!
addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime
"Add a new alarm with the given set of parameters"
self alarms add:
(MorphicAlarm
scheduledAt: scheduledTime
receiver: aTarget
selector: aSelector
arguments: argArray).! !
!WorldState methodsFor: 'alarms' stamp: 'ar 9/11/2000 17:11'!
adjustAlarmTimes: nowTime
"Adjust the alarm times after some clock weirdness (such as roll-over, image-startup etc)"
| deltaTime |
deltaTime := nowTime - lastAlarmTime.
self alarms do:[:alarm| alarm scheduledTime: alarm scheduledTime + deltaTime].! !
!WorldState methodsFor: 'alarms' stamp: 'nice 4/16/2009 19:03'!
alarmSortBlock
^[ :alarm1 :alarm2 |
alarm1 scheduledTime < alarm2 scheduledTime.
]! !
!WorldState methodsFor: 'alarms' stamp: 'RAA 1/5/2001 10:46'!
alarms
^alarms ifNil: [alarms := Heap sortBlock: self alarmSortBlock]! !
!WorldState methodsFor: 'alarms' stamp: 'dgd 2/22/2003 13:31'!
removeAlarm: aSelector for: aTarget
"Remove the alarm with the given selector"
| alarm |
alarm := self alarms
detect: [:any | any receiver == aTarget and: [any selector == aSelector]]
ifNone: [nil].
alarm isNil ifFalse: [self alarms remove: alarm]! !
!WorldState methodsFor: 'alarms' stamp: 'ar 10/22/2000 16:55'!
triggerAlarmsBefore: nowTime
"Trigger all pending alarms that are to be executed before nowTime."
| pending |
lastAlarmTime ifNil:[lastAlarmTime := nowTime].
(nowTime < lastAlarmTime or:[nowTime - lastAlarmTime > 10000])
ifTrue:[self adjustAlarmTimes: nowTime].
pending := self alarms.
[pending isEmpty not and:[pending first scheduledTime < nowTime]]
whileTrue:[pending removeFirst value: nowTime].
lastAlarmTime := nowTime.! !
!WorldState methodsFor: 'canvas' stamp: 'stephane.ducasse 9/25/2008 18:10'!
assuredCanvas
(canvas isNil or: [(canvas extent ~= viewBox extent) or: [canvas form depth ~= Display depth]])
ifTrue:
["allocate a new offscreen canvas the size of the window"
self canvas: (Display defaultCanvasClass extent: viewBox extent)].
^ self canvas! !
!WorldState methodsFor: 'canvas' stamp: 'di 6/7/1999 17:44'!
canvas
^ canvas! !
!WorldState methodsFor: 'canvas' stamp: 'dgd 2/22/2003 13:29'!
canvas: x
canvas := x.
damageRecorder isNil
ifTrue: [damageRecorder := DamageRecorder new]
ifFalse: [damageRecorder doFullRepaint]! !
!WorldState methodsFor: 'canvas' stamp: 'RAA 5/25/2000 15:12'!
doFullRepaint
damageRecorder doFullRepaint
! !
!WorldState methodsFor: 'canvas' stamp: 'ar 1/30/2001 23:25'!
recordDamagedRect: damageRect
damageRecorder ifNotNil: [damageRecorder recordInvalidRect: damageRect truncated]
! !
!WorldState methodsFor: 'canvas' stamp: 'RAA 5/25/2000 15:10'!
resetDamageRecorder
damageRecorder reset
! !
!WorldState methodsFor: 'canvas' stamp: 'di 6/7/1999 17:44'!
viewBox
^ viewBox! !
!WorldState methodsFor: 'canvas' stamp: 'di 6/7/1999 17:58'!
viewBox: x
viewBox := x! !
!WorldState methodsFor: 'hands' stamp: 'ar 1/22/2001 14:26'!
activeHand
^ ActiveHand! !
!WorldState methodsFor: 'hands' stamp: 'ar 10/26/2000 14:51'!
addHand: aHandMorph
"Add the given hand to the list of hands for this world."
hands := (hands copyWithout: aHandMorph) copyWith: aHandMorph.
! !
!WorldState methodsFor: 'hands' stamp: 'di 6/7/1999 17:40'!
hands
^ hands! !
!WorldState methodsFor: 'hands' stamp: 'RAA 5/24/2000 10:13'!
handsDo: aBlock
^ hands do: aBlock! !
!WorldState methodsFor: 'hands' stamp: 'RAA 5/24/2000 12:09'!
handsReverseDo: aBlock
^ hands reverseDo: aBlock! !
!WorldState methodsFor: 'hands' stamp: 'ar 1/22/2001 14:26'!
removeHand: aHandMorph
"Remove the given hand from the list of hands for this world."
(hands includes: aHandMorph) ifFalse: [^self].
hands := hands copyWithout: aHandMorph.
ActiveHand == aHandMorph ifTrue: [ActiveHand := nil].
! !
!WorldState methodsFor: 'hands' stamp: 'nice 1/5/2010 15:59'!
selectHandsToDrawForDamage: damageList
"Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle."
| result |
result := OrderedCollection new.
hands do: [:h | | hBnds |
h needsToBeDrawn ifTrue: [
h hasChanged
ifTrue: [result add: h]
ifFalse: [
hBnds := h fullBounds.
(damageList detect: [:r | r intersects: hBnds] ifNone: [nil])
ifNotNil: [result add: h]]]].
^ result
! !
!WorldState methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 11:16'!
initialize
super initialize.
hands := Array new.
damageRecorder:= DamageRecorder new.
stepList := Heap sortBlock: self stepListSortBlock.
lastStepTime := 0.
lastAlarmTime := 0.! !
!WorldState methodsFor: 'initialization' stamp: 'sw 9/5/2000 06:39'!
stepListSize
^ stepList size! !
!WorldState methodsFor: 'object filein' stamp: 'RAA 1/5/2001 10:51'!
convertAlarms
alarms ifNotNil: [alarms sortBlock: self alarmSortBlock]. "ensure cleaner block"
! !
!WorldState methodsFor: 'object filein' stamp: 'nice 1/5/2010 15:59'!
convertStepList
"Convert the old-style step list (an Array of Arrays) into the new-style StepMessage heap"
| newList |
(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 |
wakeupTime := entry second.
morphToStep := entry first.
newList add: (StepMessage
scheduledAt: wakeupTime
stepTime: nil
receiver: morphToStep
selector: #stepAt:
arguments: nil)].
stepList := newList! !
!WorldState methodsFor: 'settings' stamp: 'HilaireFernandes 9/9/2010 15:13'!
desktopMenuPragmaKeyword
^ self class desktopMenuPragmaKeyword! !
!WorldState methodsFor: 'settings' stamp: 'AlainPlantec 12/20/2009 00:04'!
desktopMenuTitle
^ self class desktopMenuTitle! !
!WorldState methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 11:37'!
isEasySelecting
^ self class easySelectingWorld! !
!WorldState methodsFor: 'settings' stamp: 'AlainPlantec 12/14/2009 14:01'!
serverMode
^ self class serverMode! !
!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:23'!
adjustWakeupTimes: now
"Fix the wakeup times in my step list. This is necessary when this world has been restarted after a pause, say because some other view had control, after a snapshot, or because the millisecond clock has wrapped around. (The latter is a rare occurence with a 32-bit clock!!)"
| deltaTime |
deltaTime := now - lastStepTime.
stepList do:[:entry| entry scheduledTime: entry scheduledTime + deltaTime].
lastStepTime := now.
! !
!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 15:22'!
adjustWakeupTimesIfNecessary
"Fix the wakeup times in my step list if necessary. This is needed after a snapshot, after a long pause (say because some other view had control or because the user was selecting from an MVC-style menu) or when the millisecond clock wraps around (a very rare occurence with a 32-bit clock!!)."
| now |
now := Time millisecondClockValue.
((now < lastStepTime) or: [(now - lastStepTime) > 5000])
ifTrue: [self adjustWakeupTimes: now]. "clock slipped"
! !
!WorldState methodsFor: 'stepping' stamp: 'AlainPlantec 10/17/2009 19:02'!
cleanseStepListForWorld: aWorld
"Remove morphs from the step list that are not in this World"
| deletions morphToStep |
deletions := nil.
stepList do: [:entry |
morphToStep := entry receiver.
morphToStep world == aWorld ifFalse:[
deletions ifNil: [deletions := OrderedCollection new].
deletions addLast: entry]].
deletions ifNotNil:[
deletions do: [:entry|
self stopStepping: entry receiver]].
self alarms copy do:[:entry|
morphToStep := entry receiver.
(morphToStep isMorph and:[morphToStep world == aWorld])
ifFalse:[self removeAlarm: entry selector for: entry receiver]].! !
!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:09'!
isStepping: aMorph
"Return true if the given morph is in the step list."
lastStepMessage ifNotNil:[(lastStepMessage receiver == aMorph) ifTrue:[^true]].
stepList do:[:entry| entry receiver == aMorph ifTrue:[^true]].
^ false! !
!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:09'!
isStepping: aMorph selector: aSelector
"Return true if the given morph is in the step list."
lastStepMessage ifNotNil:[
(lastStepMessage receiver == aMorph and:[lastStepMessage selector == aSelector])
ifTrue:[^true]].
stepList do:[:entry| (entry receiver == aMorph and:[entry selector == aSelector]) ifTrue:[^true]].
^ false! !
!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:05'!
listOfSteppingMorphs
^stepList collect:[:entry| entry receiver].
! !
!WorldState methodsFor: 'stepping' stamp: 'dgd 2/22/2003 13:31'!
runLocalStepMethodsIn: aWorld
"Run morph 'step' methods (LOCAL TO THIS WORLD) whose time has come. Purge any morphs that are no longer in this world.
ar 3/13/1999: Remove buggy morphs from the step list so that they don't raise repeated errors."
| now morphToStep stepTime priorWorld |
now := Time millisecondClockValue.
priorWorld := ActiveWorld.
ActiveWorld := aWorld.
self triggerAlarmsBefore: now.
stepList isEmpty
ifTrue:
[ActiveWorld := priorWorld.
^self].
(now < lastStepTime or: [now - lastStepTime > 5000])
ifTrue: [self adjustWakeupTimes: now]. "clock slipped"
[stepList isEmpty not and: [stepList first scheduledTime < now]]
whileTrue:
[lastStepMessage := stepList removeFirst.
morphToStep := lastStepMessage receiver.
(morphToStep shouldGetStepsFrom: aWorld)
ifTrue:
[lastStepMessage value: now.
lastStepMessage ifNotNil:
[stepTime := lastStepMessage stepTime ifNil: [morphToStep stepTime].
lastStepMessage scheduledTime: now + (stepTime max: 1).
stepList add: lastStepMessage]].
lastStepMessage := nil].
lastStepTime := now.
ActiveWorld := priorWorld! !
!WorldState methodsFor: 'stepping' stamp: 'StephaneDucasse 1/31/2011 16:51'!
runStepMethodsIn: aWorld
"Perform periodic activity inbetween event cycles"
| queue nextInQueue|
"If available dispatch some deferred UI Message"
queue := self class deferredUIMessages.
[(nextInQueue := queue nextOrNil) isNil]
whileFalse: [ nextInQueue value].
self runLocalStepMethodsIn: aWorld.! !
!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:36'!
startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime
"Add the given morph to the step list. Do nothing if it is already being stepped."
self stopStepping: aMorph selector: aSelector.
self adjustWakeupTimesIfNecessary.
stepList add:(
StepMessage
scheduledAt: scheduledTime
stepTime: stepTime
receiver: aMorph
selector: aSelector
arguments: args)! !
!WorldState methodsFor: 'stepping' stamp: 'nice 4/16/2009 19:03'!
stepListSortBlock
^[ :stepMsg1 :stepMsg2 |
stepMsg1 scheduledTime <= stepMsg2 scheduledTime
]! !
!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:10'!
stopStepping: aMorph
"Remove the given morph from the step list."
lastStepMessage ifNotNil:[
(lastStepMessage receiver == aMorph) ifTrue:[lastStepMessage := nil]].
stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph]).
! !
!WorldState methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:10'!
stopStepping: aMorph selector: aSelector
"Remove the given morph from the step list."
lastStepMessage ifNotNil:[
(lastStepMessage receiver == aMorph and:[lastStepMessage selector == aSelector])
ifTrue:[lastStepMessage := nil]].
stepList removeAll: (stepList select:[:stepMsg| stepMsg receiver == aMorph and:[stepMsg selector == aSelector]]).! !
!WorldState methodsFor: 'update cycle' stamp: 'RAA 5/24/2000 13:13'!
checkIfUpdateNeeded
damageRecorder updateIsNeeded ifTrue: [^true].
hands do: [:h | (h hasChanged and: [h needsToBeDrawn]) ifTrue: [^true]].
^false "display is already up-to-date"
! !
!WorldState methodsFor: 'update cycle' stamp: 'nice 1/5/2010 15:59'!
displayWorld: aWorld submorphs: submorphs
"Update this world's display."
| deferredUpdateMode handsToDraw 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:[ | worldDamageRects handDamageRects |
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*"
self class 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.
! !
!WorldState methodsFor: 'update cycle' stamp: 'ar 6/28/2003 01:07'!
displayWorldSafely: aWorld
"Update this world's display and keep track of errors during draw methods."
[aWorld displayWorld] ifError: [:err :rcvr |
"Handle a drawing error"
| errCtx errMorph |
errCtx := thisContext.
[
errCtx := errCtx sender.
"Search the sender chain to find the morph causing the problem"
[errCtx notNil and:[(errCtx receiver isMorph) not]]
whileTrue:[errCtx := errCtx sender].
"If we're at the root of the context chain then we have a fatal drawing problem"
errCtx ifNil:[^self handleFatalDrawingError: err].
errMorph := errCtx receiver.
"If the morph causing the problem has already the #drawError flag set,
then search for the next morph above in the caller chain."
errMorph hasProperty: #errorOnDraw
] whileTrue.
errMorph setProperty: #errorOnDraw toValue: true.
"Install the old error handler, so we can re-raise the error"
rcvr error: err.
].! !
!WorldState methodsFor: 'update cycle' stamp: 'stephane.ducasse 10/18/2008 21:51'!
doDeferredUpdatingFor: aWorld
"If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, do nothing and answer false. One can set the class variable DisableDeferredUpdates to true to completely disable the deferred updating feature."
| properDisplay |
PasteUpMorph disableDeferredUpdates ifTrue: [^ false].
(Display deferUpdates: true) ifNil: [^ false]. "deferred updates not supported"
properDisplay := canvas notNil and: [canvas form == Display].
aWorld == World ifTrue: [ "this world fills the entire Display"
properDisplay ifFalse: [
aWorld viewBox: Display boundingBox. "do first since it may clear canvas"
self canvas: (Display getCanvas copyClipRect: Display boundingBox).
]
] ifFalse: [ "this world is inside an MVC window"
(properDisplay and: [canvas clipRect = aWorld viewBox]) ifFalse: [
self canvas:
(Display getCanvas copyOffset: 0@0 clipRect: aWorld viewBox)
]
].
^ true
! !
!WorldState methodsFor: 'update cycle' stamp: 'adrian_lienhard 7/18/2009 15:30'!
doOneCycleFor: aWorld
"Do one cycle of the interaction loop. This method is called repeatedly when the world is running. This is a moderately private method; a better alternative is usually either to wait for events or to check the state of things from #step methods."
self interCyclePause: MinCycleLapse.
self doOneCycleNowFor: aWorld.! !
!WorldState methodsFor: 'update cycle' stamp: 'md 4/30/2008 16:33'!
doOneCycleNowFor: aWorld
"Immediately do one cycle of the interaction loop.
This should not be called directly, but only via doOneCycleFor:"
DisplayScreen checkForNewScreenSize.
"process user input events"
LastCycleTime := Time millisecondClockValue.
self handsDo: [:h |
ActiveHand := h.
h processEvents.
ActiveHand := nil
].
"the default is the primary hand"
ActiveHand := self hands first.
aWorld runStepMethods. "there are currently some variations here"
self displayWorldSafely: aWorld.! !
!WorldState methodsFor: 'update cycle' stamp: 'ar 1/22/2001 14:26'!
doOneSubCycleFor: aWorld
"Like doOneCycle, but preserves activeHand."
| currentHand |
currentHand := ActiveHand.
self doOneCycleFor: aWorld.
ActiveHand := currentHand! !
!WorldState methodsFor: 'update cycle' stamp: 'nice 1/5/2010 15:59'!
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 := 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 rect i c remnantIntersects remnants rectToFill |
"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.
remnants := OrderedCollection with: r.
i := 1.
[remnants isEmpty or: [i > n]] whileFalse:
[mm := submorphs at: i.
((remnantIntersects := remnants select: [:each | (mm fullBounds intersects: each)]) notEmpty and: [mm visible])
ifTrue:
[morphs addLast: mm.
rects addLast: (Rectangle merging: (remnantIntersects collect: [:each | mm fullBounds intersect: each])).
remnants removeAll: remnantIntersects.
remnantIntersects do: [:eachIntersect | remnants addAll: (mm areasRemainingToFill: eachIntersect)].
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! !
!WorldState methodsFor: 'update cycle' stamp: 'stephane.ducasse 9/25/2008 18:11'!
forceDamageToScreen: allDamage
Display forceDamageToScreen: allDamage.
! !
!WorldState methodsFor: 'update cycle' stamp: 'alain.plantec 6/2/2008 08:45'!
handleFatalDrawingError: errMsg
"Handle a fatal drawing error."
Display deferUpdates: false. "Just in case"
self primitiveError: errMsg.
"Hm... we should jump into a 'safe' worldState here, but how do we find it?!!"! !
!WorldState methodsFor: 'update cycle' stamp: 'AlainPlantec 1/7/2010 22:54'!
interCyclePause: milliSecs
"delay enough that the previous cycle plus the amount of delay will equal milliSecs. If the cycle is already expensive, then no delay occurs. However, if the system is idly waiting for interaction from the user, the method will delay for a proportionally long time and cause the overall CPU usage of Squeak to be low.
If self serverMode returns true then, always do a complete delay of 50ms, independant of my argument. This prevents the freezing problem described in Mantis #6581"
| currentTime wait |
self serverMode
ifFalse: [
(lastCycleTime notNil and: [CanSurrenderToOS ~~ false]) ifTrue: [
currentTime := Time millisecondClockValue.
wait := lastCycleTime + milliSecs - currentTime.
(wait > 0 and: [ wait <= milliSecs ] ) ifTrue: [
(Delay forMilliseconds: wait) wait ] ] ]
ifTrue: [ (Delay forMilliseconds: 50) wait ].
lastCycleTime := Time millisecondClockValue.
CanSurrenderToOS := true.! !
!WorldState methodsFor: 'worldmenu building' stamp: 'HilaireFernandes 9/9/2010 15:08'!
discoveredWorldMenu
^ self menuBuilder menuEntitled: self desktopMenuTitle! !
!WorldState methodsFor: 'worldmenu building' stamp: 'AlainPlantec 2/16/2010 23:41'!
discoveredWorldMenuAt: anItemName
^ self menuBuilder menuAt: anItemName! !
!WorldState methodsFor: 'worldmenu building' stamp: 'AlainPlantec 2/15/2010 14:04'!
fallbackMenuExplanations
(Workspace openContents: 'Something is wrong with the world menu.
To investigate just debug following expression:
World discoveredWorldMenu') label: 'Fallback worldmenu explanations'
! !
!WorldState methodsFor: 'worldmenu building' stamp: 'StephaneDucasse 2/25/2011 17:58'!
fallbackWorldMenu
"Build the menu that is put up if something is going wrong with the menubuilder"
| menu |
menu := UIManager default newMenuIn: self world for: self.
menu commandKeyHandler: self.
menu addTitle: 'Fallback world menu'.
menu addStayUpItem.
menu add: 'Why you see this menu'
target: self
selector: #fallbackMenuExplanations.
menu addLine.
menu
defaultTarget: ToolSet default;
addList: ToolSet default mainMenuItems.
menu addLine.
menu add: 'Save'
target: Smalltalk
selector: #saveSession.
menu add: 'Save as...'
target: self class
selector: #saveAs.
menu add: 'Save and quit'
target: Smalltalk
selector: #snapshot:andQuit:
argumentList: {true. true}.
menu add: 'Quit'
target: self class
selector: #quitSession.
^ menu! !
!WorldState methodsFor: 'worldmenu building' stamp: 'HilaireFernandes 9/9/2010 15:14'!
menuBuilder
^ menuBuilder ifNil: [menuBuilder := PragmaMenuBuilder pragmaKeyword: self desktopMenuPragmaKeyword model: self]! !
!WorldState methodsFor: 'worldmenu building' stamp: 'HilaireFernandes 9/9/2010 14:55'!
resetWorldMenu
menuBuilder
ifNotNil: [menuBuilder reset.
menuBuilder := nil]! !
!WorldState methodsFor: 'worldmenu building' stamp: 'AlainPlantec 2/15/2010 14:17'!
worldMenu
^ [self discoveredWorldMenu]
on: Error
do: [menuBuilder := nil.
^ self fallbackWorldMenu] ! !
!WorldState methodsFor: 'worldmenu building' stamp: 'AlainPlantec 2/16/2010 23:40'!
worldMenuAt: anMenuItemName
^ [self discoveredWorldMenuAt: anMenuItemName]
on: Error
do: [menuBuilder := nil.
^ self fallbackWorldMenu] ! !
!WorldState methodsFor: 'worldmenu building' stamp: 'AlainPlantec 2/17/2010 00:35'!
worldMenuPragmaKeyword
^ 'worldMenu'! !
!WorldState methodsFor: 'worldmenu building' stamp: 'AlainPlantec 2/15/2010 11:57'!
worldMenuTitle
^ 'World'! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!
WorldState class
instanceVariableNames: ''!
!WorldState class methodsFor: 'accessing' stamp: 'AlainPlantec 12/6/2009 21:40'!
MinCycleLapse: milliseconds
"set the minimum amount of time that may transpire between two calls to doOneCycle"
MinCycleLapse := milliseconds ifNotNil: [ milliseconds rounded ].! !
!WorldState class methodsFor: 'accessing' stamp: 'RAA 1/7/2001 16:32'!
classVersion
^1 "force cleanup of alarms and stepList"! !
!WorldState class methodsFor: 'accessing' stamp: 'AlainPlantec 12/6/2009 21:42'!
debugShowDamage
^ DebugShowDamage ifNil: [DebugShowDamage := false]! !
!WorldState class methodsFor: 'accessing' stamp: 'AlainPlantec 12/6/2009 21:42'!
debugShowDamage: aBoolean
DebugShowDamage := aBoolean! !
!WorldState class methodsFor: 'as yet unclassified' stamp: 'RAA 8/14/2000 16:40'!
canSurrenderToOS: aBoolean
CanSurrenderToOS := aBoolean! !
!WorldState class methodsFor: 'as yet unclassified' stamp: 'RAA 7/23/2000 17:28'!
lastCycleTime
^LastCycleTime! !
!WorldState class methodsFor: 'initialization' stamp: 'RAA 7/15/2000 12:58'!
addDeferredUIMessage: valuableObject
self deferredUIMessages nextPut: valuableObject.
! !
!WorldState class methodsFor: 'initialization' stamp: 'MarcusDenker 12/8/2009 17:55'!
deferredUIMessages
^DeferredUIMessages ifNil: [DeferredUIMessages := SharedQueue new].
! !
!WorldState class methodsFor: 'initialization' stamp: 'MarcusDenker 12/8/2009 17:54'!
initialize
"WorldState initialize"
MinCycleLapse := 20. "allows 50 frames per second..."
DeferredUIMessages := SharedQueue new.! !
!WorldState class methodsFor: 'settings' stamp: 'HilaireFernandes 9/9/2010 15:25'!
defaultWorldMenu
self desktopMenuTitle: 'World'.
self desktopMenuPragmaKeyword: 'worldMenu'.! !
!WorldState class methodsFor: 'settings' stamp: 'HilaireFernandes 9/9/2010 15:12'!
desktopMenuPragmaKeyword
^ DesktopMenuPragmaKeyword ifNil: [DesktopMenuPragmaKeyword := 'worldMenu']! !
!WorldState class methodsFor: 'settings' stamp: 'HilaireFernandes 9/9/2010 15:25'!
desktopMenuPragmaKeyword: aString
DesktopMenuPragmaKeyword := aString.
World resetWorldMenu.
! !
!WorldState class methodsFor: 'settings' stamp: 'AlainPlantec 12/19/2009 23:55'!
desktopMenuTitle
^ DesktopMenuTitle ifNil: [DesktopMenuTitle := 'World']! !
!WorldState class methodsFor: 'settings' stamp: 'AlainPlantec 12/19/2009 23:56'!
desktopMenuTitle: aString
DesktopMenuTitle := aString! !
!WorldState class methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 11:34'!
easySelectingWorld
^ EasySelectingWorld ifNil: [EasySelectingWorld := false]! !
!WorldState class methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 11:34'!
easySelectingWorld: aBoolean
EasySelectingWorld := aBoolean! !
!WorldState class methodsFor: 'settings' stamp: 'AlainPlantec 12/14/2009 14:02'!
serverMode
^ ServerMode ifNil: [ServerMode := false]! !
!WorldState class methodsFor: 'settings' stamp: 'AlainPlantec 12/14/2009 14:07'!
serverMode: aBoolean
(aBoolean = true or: [aBoolean = false or: [aBoolean isNil]])
ifTrue: [ServerMode := aBoolean]! !
!WorldState class methodsFor: 'settings' stamp: 'AlainPlantec 4/15/2010 15:59'!
showUpdateOptionInWorldMenu
^ ShowUpdateOptionInWorldMenu ifNil: [ShowUpdateOptionInWorldMenu := true]! !
!WorldState class methodsFor: 'settings' stamp: 'AlainPlantec 4/15/2010 15:59'!
showUpdateOptionInWorldMenu: aBoolean
ShowUpdateOptionInWorldMenu := aBoolean! !
!WorldState class methodsFor: 'world menu items' stamp: 'AlainPlantec 2/17/2010 00:31'!
clearHaltOnce
super clearHaltOnce.
World resetWorldMenu! !
!WorldState class methodsFor: 'world menu items' stamp: 'StephaneDucasse 4/4/2011 23:02'!
helpOn: aBuilder
<worldMenu>
(aBuilder item: #Help)
order: 4.0;
icon: UITheme current smallHelpIcon;
withSeparatorAfter
! !
!WorldState class methodsFor: 'world menu items' stamp: 'AdrianLienhard 6/7/2010 12:04'!
mostUsedToolsOn: aBuilder
<worldMenu>
(aBuilder group: #MostUsedTools)
withSeparatorAfter;
order: 0;
with: [
(aBuilder item: #'System Browser') action: [ToolSet default openClassBrowser]; icon: Browser taskbarIcon.
(aBuilder item: #Workspace) action: [ToolSet default openWorkspace]; icon: Workspace taskbarIcon.
Smalltalk globals at: #TestRunner ifPresent: [ :class |
(aBuilder item: #'Test Runner') action: [ToolSet default openTestRunner]; icon: class taskbarIcon.
].
(aBuilder item: #'Monticello Browser') action: [ToolSet default openMonticelloBrowser]; icon: MCWorkingCopyBrowser taskbarIcon]! !
!WorldState class methodsFor: 'world menu items' stamp: 'StephaneDucasse 3/17/2010 21:25'!
quitItemsOn: aBuilder
<worldMenu>
(aBuilder group: #QuitPharo)
order: 9999;
with: [{
{'Save'. {Smalltalk . #saveSession}. 'save the current version of the image on disk'}.
{'Save as...'. {self. #saveAs}. 'save the current version of the image on disk under a new name.'}.
{'Save and quit'. {self. #saveAndQuit}. 'save the current image on disk, and quit Pharo.'}.
{'Quit'. {self. #quitSession}. 'quit Pharo.'}
} do: [:triplet |
(aBuilder item: triplet first asSymbol)
target: triplet second first;
selector: triplet second second;
help: (triplet size > 2 ifTrue: [triplet third] ifFalse: [nil])]]! !
!WorldState class methodsFor: 'world menu items' stamp: 'StephaneDucasse 3/17/2010 21:24'!
quitSession
Smalltalk
snapshot: (self confirm: 'Save changes before quitting?' translated orCancel: [ ^ self ])
andQuit: true! !
!WorldState class methodsFor: 'world menu items' stamp: 'StephaneDucasse 3/17/2010 21:24'!
saveAndQuit
Smalltalk snapshot: true andQuit: true! !
!WorldState class methodsFor: 'world menu items' stamp: 'StephaneDucasse 3/17/2010 21:24'!
saveAs
| imageName index |
imageName := FileDirectory baseNameFor: (FileDirectory default localNameFor: Smalltalk imageName).
index := imageName lastIndexOf: FileDirectory extensionDelimiter ifAbsent: [ nil ].
(index notNil and: [ (imageName copyFrom: index + 1 to: imageName size) isAllDigits ])
ifTrue: [ imageName := imageName copyFrom: 1 to: index - 1 ].
imageName := FileDirectory default nextNameFor: imageName extension: FileDirectory imageSuffix.
imageName := UIManager default
request: 'Please enter the name for the new image:'
initialAnswer: imageName.
imageName isEmptyOrNil
ifTrue: [ ^ self ].
Smalltalk saveAs: imageName! !
!WorldState class methodsFor: 'world menu items' stamp: 'AlainPlantec 10/24/2010 21:28'!
screenShotCommandOn: aBuilder
<worldMenu>
(aBuilder item: #Screenshot) parent: #Tools;
target: World;
selector: #makeAScreenshot;
label: 'Screenshot' translated;
icon: UITheme current smallScreenshotIcon! !
!WorldState class methodsFor: 'world menu items' stamp: 'AlainPlantec 2/17/2010 00:31'!
setHaltOnce
super setHaltOnce.
World resetWorldMenu! !
!WorldState class methodsFor: 'world menu items' stamp: 'AlainPlantec 2/17/2010 00:24'!
startMessageTally
(self confirm: 'MessageTally will start now,
and stop when the cursor goes
to the top of the screen' translated)
ifTrue: [MessageTally spyAllOn: [[Sensor peekMousePt y > 0]
whileTrue: [World doOneCycle]]]! !
!WorldState class methodsFor: 'world menu items' stamp: 'AlainPlantec 2/17/2010 00:24'!
startThenBrowseMessageTally
"Tally only the UI process"
(self confirm: 'MessageTally the UI process until the
mouse pointer goes to the top of the screen')
ifTrue: [TimeProfileBrowser
onBlock: [[Sensor peekMousePt y > 10]
whileTrue: [World doOneCycle]]]! !
!WorldState class methodsFor: 'world menu items' stamp: 'StephaneDucasse 4/4/2011 23:02'!
systemOn: aBuilder
<worldMenu>
(aBuilder item: #System)
order: 3.0;
icon: UITheme current smallConfigurationIcon;
with: [
(aBuilder item: #'About...')
order: 0;
icon: UITheme current smallLanguageIcon;
action: [Smalltalk aboutThisSystem].
(aBuilder item: #'Software update')
order: 2;
icon: UITheme current smallUpdateIcon;
action: [UpdateStreamer new updateFromServer ];
help: 'Load latest code updates via the internet';
withSeparatorAfter.
(aBuilder item: #'Vm statistics')
action: [(StringHolder new contents: Smalltalk vmStatisticsReportString) openLabel: 'VM Statistics'].
(aBuilder item: #'Start profiling all Processes')
action: [self startMessageTally].
(aBuilder item: #'Start profiling UI ')
action: [self startThenBrowseMessageTally].
(aBuilder item: #'Space left')
action: [Smalltalk garbageCollectAndReport];
withSeparatorAfter.
(aBuilder item: #'Start drawing again')
action: [World resumeAfterDrawError].
(aBuilder item: #'Start stepping again')
action: [World resumeAfterStepError];
withSeparatorAfter.
(aBuilder item: #'Restore display (r)')
action: [World restoreMorphicDisplay].
self haltOnceEnabled
ifTrue: [(aBuilder item: 'Disable halt/inspect once') action: [self clearHaltOnce]]
ifFalse: [(aBuilder item: 'Enable halt/inspect once') action: [self setHaltOnce]]].! !
!WorldState class methodsFor: 'world menu items' stamp: 'StephaneDucasse 4/4/2011 23:01'!
windowsOn: aBuilder
<worldMenu>
(aBuilder item: #Windows)
order: 4.0;
withSeparatorAfter ;
icon: UITheme current smallWindowIcon;
with: [
(aBuilder item: # 'Collapse all windows')
action: [World collapseAll];
help: 'Reduce all open windows to collapsed forms that only show titles' translated.
(aBuilder item: # 'Expand all windows')
action: [World expandAll];
help: 'Expand all collapsed windows back to their expanded forms' translated.
(aBuilder item: # 'Fit all windows')
action: [World fitAll];
help: 'Fit all open windows as visible in World' translated.
(aBuilder item: #'Close all debuggers')
action: [Debugger closeAllDebuggers].
(aBuilder item: # 'Send top window to back (\)')
action: [SystemWindow sendTopWindowToBack];
help: 'Make the topmost window become the backmost one, and activate the window just beneath it.' translated.
(aBuilder item: # 'Move windows onscreen')
action: [World bringWindowsFullOnscreen];
help: 'Make all windows fully visible on the screen' translated.
(aBuilder item: # 'Delete unchanged windows')
action: [World closeUnchangedWindows];
help: 'Deletes all windows that do not have unsaved text edits.' translated]! !
WorldState initialize!
|