The Trunk: Morphic-mt.1178.mcz

Marcel Taeumel uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-mt.1178.mcz

==================== Summary ====================

Name: Morphic-mt.1178
Author: mt
Time: 15 June 2016, 7:58:44.282664 am
UUID: 2cf2827f-2599-f84c-a054-ea09942951c4
Ancestors: Morphic-mt.1177

Appendix to Kernel-mt.1028.

Support #wheelDelta in MouseWheelEvent instances for fine-granular scrolling. Do only raise flags for, e.g., #isWheelUp and #isWheelDown if the delta is above 120 units. Accumulate this in MouseWheelState. Wheel-up is every +120 and wheel-down is every -120.

=============== Diff against Morphic-mt.1177 ===============

Item was changed:
  Morph subclass: #HandMorph
+ instanceVariableNames: 'mouseFocus keyboardFocus eventListeners mouseListeners keyboardListeners eventCaptureFilters mouseCaptureFilters keyboardCaptureFilters mouseClickState mouseOverHandler mouseWheelState lastMouseEvent targetOffset damageRecorder cacheCanvas cachedCanvasHasHoles temporaryCursor temporaryCursorOffset hardwareCursor hasChanged savedPatch userInitials lastEventBuffer genieGestureProcessor keyboardInterpreter'
- instanceVariableNames: 'mouseFocus keyboardFocus eventListeners mouseListeners keyboardListeners eventCaptureFilters mouseCaptureFilters keyboardCaptureFilters mouseClickState mouseOverHandler lastMouseEvent targetOffset damageRecorder cacheCanvas cachedCanvasHasHoles temporaryCursor temporaryCursorOffset hardwareCursor hasChanged savedPatch userInitials lastEventBuffer genieGestureProcessor keyboardInterpreter'
  classVariableNames: 'CompositionWindowManager DoubleClickTime DragThreshold EventStats NewEventRules NormalCursor PasteBuffer SendMouseWheelToKeyboardFocus ShowEvents SynthesizeMouseWheelEvents'
  poolDictionaries: 'EventSensorConstants'
  category: 'Morphic-Kernel'!
 
  !HandMorph commentStamp: '<historical>' prior: 0!
  The cursor may be thought of as the HandMorph.  The hand's submorphs hold anything being carried by dragging.  
 
  There is some minimal support for multiple hands in the same world.!

Item was changed:
  ----- Method: HandMorph>>filterEvent:for: (in category 'events-filtering') -----
  filterEvent: aKeyboardEvent for: aMorphOrNil
  "Fixes VM behavior. Usually, there are no mouse wheel events generated by the VM but CTRL+UP/DOWN. Convert these into mouse wheel events.
 
  We installed ourself as keyboard filter only!! No need to check whether this is a keyboard event or not!! See HandMorph >> #initForEvents.
 
  Might be removed in the future if this mapping gets obsolete."
 
  HandMorph synthesizeMouseWheelEvents ifFalse: [^ aKeyboardEvent].
 
  (aKeyboardEvent isKeystroke and: [aKeyboardEvent controlKeyPressed]) ifTrue: [
  aKeyboardEvent keyCharacter caseOf: {
+ [Character arrowUp] -> [^ self generateMouseWheelEvent: aKeyboardEvent direction: 2r1000].
+ [Character arrowDown] -> [^ self generateMouseWheelEvent: aKeyboardEvent direction: 2r0100].
- [Character arrowUp] -> [^ self generateMouseWheelEvent: aKeyboardEvent direction: #up].
- [Character arrowDown] -> [^ self generateMouseWheelEvent: aKeyboardEvent direction: #down].
  } otherwise: [^ aKeyboardEvent]].
 
  ^ aKeyboardEvent!

Item was added:
+ ----- Method: HandMorph>>generateMouseWheelEvent: (in category 'private events') -----
+ generateMouseWheelEvent: evtBuf
+ "Generate the appropriate mouse wheel event for the given raw event buffer"
+
+ | buttons modifiers deltaX deltaY stamp |
+ stamp := evtBuf second.
+ stamp = 0 ifTrue: [stamp := Time eventMillisecondClock].
+ deltaX := evtBuf third.
+ deltaY := evtBuf fourth.
+ modifiers := evtBuf fifth.
+ buttons := (modifiers bitShift: 3) bitOr: (lastMouseEvent buttons bitAnd: 7).
+ ^ MouseWheelEvent new
+ setType: #mouseWheel
+ position: self position
+ delta: deltaX@deltaY
+ direction: 2r0000
+ buttons: buttons
+ hand: self
+ stamp: stamp!

Item was changed:
  ----- Method: HandMorph>>generateMouseWheelEvent:direction: (in category 'private events') -----
+ generateMouseWheelEvent: keystrokeEvent direction: direction
+ "Generate the appropriate mouse wheel event from the keystrokeEvent. Before calling this, ensure that the control key is pressed.
- generateMouseWheelEvent: keystrokeEvent direction: directionSymbol
- "Generate the appropriate mouse wheel event from the keystrokeEvent. Before calling this, ensure that the control key is pressed."
 
+ This method can be discarded once the VM produces real mouse wheel events."
+
  ^ MouseWheelEvent new
  setType: #mouseWheel
  position: keystrokeEvent position
+ delta: 0 @ ((direction anyMask: 2r1000 "wheel up") ifTrue: [120] ifFalse: [-120])
+ direction: direction
- direction: directionSymbol
  buttons: (keystrokeEvent buttons bitAnd: 2r01111) "drop control key pressed for this conversion"
  hand: keystrokeEvent hand
  stamp: keystrokeEvent timeStamp!

Item was changed:
  ----- Method: HandMorph>>handleEvent: (in category 'events-processing') -----
  handleEvent: unfilteredEvent
 
  | filteredEvent |
  owner ifNil: [^ unfilteredEvent  "not necessary but good style -- see Morph >> #handleEvent:"].
 
  self logEvent: unfilteredEvent.
 
  "Mouse-over events occur really, really, really often. They are kind of the heart beat of the Morphic UI process."
  unfilteredEvent isMouseOver ifTrue: [^ self sendMouseEvent: unfilteredEvent].
 
  self showEvent: unfilteredEvent.
  self sendListenEvents: unfilteredEvent.
 
  filteredEvent := self sendFilterEventCapture: unfilteredEvent for: nil.
  "filteredEvent := unfilteredEvent" " <-- use this to disable global capture filters"
 
  filteredEvent wasIgnored ifTrue: [
  self mouseOverHandler processMouseOver: lastMouseEvent.
  ^ filteredEvent].
 
  filteredEvent isWindowEvent ifTrue: [
  self sendEvent: filteredEvent focus: nil.
  self mouseOverHandler processMouseOver: lastMouseEvent.
  ^ filteredEvent].
 
  filteredEvent isKeyboard ifTrue:[
  self sendKeyboardEvent: filteredEvent.
  self mouseOverHandler processMouseOver: lastMouseEvent.
  ^ filteredEvent].
 
  filteredEvent isDropEvent ifTrue:[
  self sendEvent: filteredEvent focus: nil.
  self mouseOverHandler processMouseOver: lastMouseEvent.
  ^ filteredEvent].
 
  filteredEvent isMouse ifFalse: [
  self mouseOverHandler processMouseOver: lastMouseEvent.
  ^ filteredEvent].
 
  " ********** MOUSE EVENT *********** "
 
  lastMouseEvent := filteredEvent.
 
  "Check for pending drag or double click operations."
  mouseClickState ifNotNil:[
  (mouseClickState handleEvent: filteredEvent from: self) ifFalse:[
  "Possibly dispatched #click: or something and will not re-establish otherwise"
  self mouseOverHandler processMouseOver: lastMouseEvent.
  ^ filteredEvent]].
 
+ filteredEvent isMouseWheel ifTrue: [
+ mouseWheelState ifNil: [mouseWheelState := MouseWheelState new].
+ mouseWheelState handleEvent: filteredEvent from: self.
+ self mouseOverHandler processMouseOver: lastMouseEvent.
+ ^ filteredEvent].
+
  filteredEvent isMove ifTrue:[
  self position: filteredEvent position.
  self sendMouseEvent: filteredEvent.
  self mouseOverHandler processMouseOver: lastMouseEvent.
  ^ filteredEvent].
 
  "Issue a synthetic move event if we're not at the position of the event"
  filteredEvent position = self position
  ifFalse: [self moveToEvent: filteredEvent].
 
  "Drop submorphs on button events"
  self hasSubmorphs
  ifTrue:[self dropMorphs: filteredEvent]
+ ifFalse:[self sendMouseEvent: filteredEvent].
- ifFalse:[
- "This check is here and not in #sendMouseEvent: to avoid unnecessary comparisons for mouse-over events."
- (HandMorph sendMouseWheelToKeyboardFocus and: [filteredEvent isMouseWheel])
- ifFalse: [self sendMouseEvent: filteredEvent]
- ifTrue: [self sendEvent: filteredEvent focus: self keyboardFocus clear: [self keyboardFocus: nil]]].
 
  self mouseOverHandler processMouseOver: lastMouseEvent.
  ^ filteredEvent "not necessary but good style -- see Morph >> #handleEvent:" !

Item was changed:
  ----- Method: HandMorph>>processEvents (in category 'event handling') -----
  processEvents
  "Process user input events from the local input devices."
 
  | evt evtBuf type hadAny |
  ActiveEvent ifNotNil:
  ["Meaning that we were invoked from within an event response.
  Make sure z-order is up to date"
 
  self mouseOverHandler processMouseOver: lastMouseEvent].
  hadAny := false.
  [(evtBuf := Sensor nextEvent) isNil] whileFalse:
  [evt := nil. "for unknown event types"
  type := evtBuf first.
+ type = EventTypeMouse
+ ifTrue: [evt := self generateMouseEvent: evtBuf].
+ type = EventTypeMouseWheel
+ ifTrue: [evt := self generateMouseWheelEvent: evtBuf].
- type = EventTypeMouse ifTrue: [evt := self generateMouseEvent: evtBuf].
  type = EventTypeKeyboard
  ifTrue: [evt := self generateKeyboardEvent: evtBuf].
  type = EventTypeDragDropFiles
  ifTrue: [evt := self generateDropFilesEvent: evtBuf].
  type = EventTypeWindow
  ifTrue:[evt := self generateWindowEvent: evtBuf].
  "All other events are ignored"
  (type ~= EventTypeDragDropFiles and: [evt isNil]) ifTrue: [^self].
  evt isNil
  ifFalse:
  ["Finally, handle it"
 
  self handleEvent: evt.
  hadAny := true.
 
  "For better user feedback, return immediately after a mouse event has been processed."
  evt isMouse ifTrue: [^self]]].
  "note: if we come here we didn't have any mouse events"
  mouseClickState notNil
  ifTrue:
  ["No mouse events during this cycle. Make sure click states time out accordingly"
 
  mouseClickState handleEvent: lastMouseEvent asMouseMove from: self].
  hadAny
  ifFalse:
  ["No pending events. Make sure z-order is up to date"
 
  self mouseOverHandler processMouseOver: lastMouseEvent]!

Item was changed:
  Object subclass: #MouseClickState
  instanceVariableNames: 'clickClient clickState firstClickDown firstClickUp firstClickTime clickSelector dblClickSelector dblClickTime dblClickTimeoutSelector dragSelector dragThreshold'
  classVariableNames: ''
  poolDictionaries: ''
+ category: 'Morphic-Events'!
- category: 'Morphic-Kernel'!
 
  !MouseClickState commentStamp: '<historical>' prior: 0!
  MouseClickState is a simple class managing the distinction between clicks, double clicks, and drag operations. It has been factored out of HandMorph due to the many instVars.
 
  Instance variables:
  clickClient <Morph> The client wishing to receive #click:, #dblClick:, or #drag messages
  clickState <Symbol> The internal state of handling the last event (#firstClickDown, #firstClickUp, #firstClickTimedOut)
  firstClickDown <MorphicEvent> The #mouseDown event after which the client wished to receive #click: or similar messages
  firstClickUp <MorphicEvent> The first mouse up event which came in before the double click time out was exceeded (it is sent if there is a timout after the first mouse up event occured)
  firstClickTime <Integer> The millisecond clock value of the first event
  clickSelector <Symbol> The selector to use for sending #click: messages
  dblClickSelector <Symbol> The selector to use for sending #doubleClick: messages
  dblClickTime <Integer> Timout in milliseconds for a double click operation
  dragSelector <Symbol> The selector to use for sending #drag: messages
  dragThreshold <Integer> Threshold used for determining if a #drag: message is sent (pixels!!)
  !

Item was changed:
  MouseEvent subclass: #MouseWheelEvent
+ instanceVariableNames: 'delta direction'
- instanceVariableNames: 'direction'
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Morphic-Events'!

Item was removed:
- ----- Method: MouseWheelEvent>>direction (in category 'accessing') -----
- direction
- ^ direction!

Item was added:
+ ----- Method: MouseWheelEvent>>initialize (in category 'initialization') -----
+ initialize
+
+ super initialize.
+ direction := 2r0000.
+ delta := 0@0.!

Item was changed:
  ----- Method: MouseWheelEvent>>isWheelDown (in category 'testing') -----
  isWheelDown
+ ^ direction anyMask: 2r0100!
- ^ self direction == #down!

Item was changed:
  ----- Method: MouseWheelEvent>>isWheelLeft (in category 'testing') -----
  isWheelLeft
+ ^ direction anyMask: 2r0010!
- ^ self direction == #left!

Item was changed:
  ----- Method: MouseWheelEvent>>isWheelRight (in category 'testing') -----
  isWheelRight
+ ^ direction anyMask: 2r0001!
- ^ self direction == #right!

Item was changed:
  ----- Method: MouseWheelEvent>>isWheelUp (in category 'testing') -----
  isWheelUp
+ ^ direction anyMask: 2r1000!
- ^ self direction == #up!

Item was changed:
  ----- Method: MouseWheelEvent>>printOn: (in category 'printing') -----
  printOn: aStream
 
  aStream nextPut: $[.
  aStream nextPutAll: self cursorPoint printString; space.
  aStream nextPutAll: type; space.
+ aStream nextPutAll: self wheelString.
+ aStream nextPutAll: self wheelDelta printString; space.
- aStream print: self direction; space.
  aStream nextPutAll: self modifierString.
  aStream nextPutAll: self buttonString.
  aStream nextPutAll: timeStamp printString; space.
  aStream nextPut: $].!

Item was added:
+ ----- Method: MouseWheelEvent>>setType:position:delta:direction:buttons:hand:stamp: (in category 'private') -----
+ setType: evtType position: evtPos delta: evtDelta direction: dirFlags buttons: evtButtons hand: evtHand stamp: stamp
+ type := evtType.
+ position := evtPos.
+ buttons := evtButtons.
+ source := evtHand.
+ wasHandled := false.
+ direction := dirFlags.
+ delta := evtDelta.
+ timeStamp := stamp.!

Item was removed:
- ----- Method: MouseWheelEvent>>setType:position:direction:buttons:hand:stamp: (in category 'private') -----
- setType: evtType position: evtPos direction: dirSymbol buttons: evtButtons hand: evtHand stamp: stamp
- type := evtType.
- position := evtPos.
- buttons := evtButtons.
- source := evtHand.
- wasHandled := false.
- direction := dirSymbol.
- timeStamp := stamp.!

Item was added:
+ ----- Method: MouseWheelEvent>>setWheelDown (in category 'initialization') -----
+ setWheelDown
+
+ direction := direction bitOr: 2r0100.!

Item was added:
+ ----- Method: MouseWheelEvent>>setWheelLeft (in category 'initialization') -----
+ setWheelLeft
+
+ direction := direction bitOr: 2r0010.!

Item was added:
+ ----- Method: MouseWheelEvent>>setWheelRight (in category 'initialization') -----
+ setWheelRight
+
+ direction := direction bitOr: 2r0001.!

Item was added:
+ ----- Method: MouseWheelEvent>>setWheelUp (in category 'initialization') -----
+ setWheelUp
+
+ direction := direction bitOr: 2r1000.!

Item was changed:
  ----- Method: MouseWheelEvent>>storeOn: (in category 'printing') -----
  storeOn: aStream
+ "Note: We generate the same array as provided by the VM. BUT we are a subclass of MouseEvent now even if we cannot store the position right now. This is awkward. But we still store the position and the wheel delta. *sign*"
+
-
  super storeOn: aStream.
  aStream space.
+ delta x storeOn: aStream.
+ aStream space.
+ delta y storeOn: aStream.
+ aStream space.
+ direction storeOn: aStream.
+ !
- self direction storeOn: aStream.!

Item was changed:
  ----- Method: MouseWheelEvent>>type:readFrom: (in category 'initialization') -----
  type: eventType readFrom: aStream
 
+ | deltaX deltaY |
  super type: eventType readFrom: aStream.
  aStream skip: 1.
+ deltaX := Integer readFrom: aStream.
+ aStream skip: 1.
+ deltaY := Integer readFrom: aStream.
+ aStream skip: 1.
+ direction := Integer readFrom: aStream.
+ delta := deltaX @ deltaY.
- direction := Symbol readFrom: aStream.
  !

Item was added:
+ ----- Method: MouseWheelEvent>>wheelDelta (in category 'accessing') -----
+ wheelDelta
+
+ ^ delta!

Item was added:
+ ----- Method: MouseWheelEvent>>wheelString (in category 'printing') -----
+ wheelString
+ "Return a string identifying the wheel state"
+
+ ^ String streamContents: [:stream |
+ self isWheelUp ifTrue: [stream nextPutAll: 'up '].
+ self isWheelDown ifTrue: [stream nextPutAll: 'down '].
+ self isWheelLeft ifTrue: [stream nextPutAll: 'left '].
+ self isWheelRight ifTrue: [stream nextPutAll: 'right ']]!

Item was added:
+ Object subclass: #MouseWheelState
+ instanceVariableNames: 'currentDelta'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Events'!

Item was added:
+ ----- Method: MouseWheelState>>handleEvent:from: (in category 'event processing') -----
+ handleEvent: aMouseWheelEvent from: aHand
+ "Every 120 units, raise the wheel flags for convenient mouse wheel programming. We choose not to send multiple mouse-wheel events for multiples of 120 because applications can always react to the actual delta values if they want to do more scrolling or zooming."
+
+ | sign |
+ currentDelta := currentDelta + aMouseWheelEvent wheelDelta.
+
+ sign := currentDelta sign.
+ currentDelta := currentDelta abs.
+
+ (currentDelta x // 120) > 0 ifTrue: [
+ sign x = 1
+ ifTrue: [aMouseWheelEvent setWheelRight]
+ ifFalse: [aMouseWheelEvent setWheelLeft]].
+
+ (currentDelta y // 120) > 0 ifTrue: [
+ sign y = 1
+ ifTrue: [aMouseWheelEvent setWheelUp]
+ ifFalse: [aMouseWheelEvent setWheelDown]].
+
+ currentDelta := currentDelta \\ 120.
+ currentDelta := currentDelta * sign.
+
+ "Finally, send the event."
+ HandMorph sendMouseWheelToKeyboardFocus
+ ifFalse: [aHand sendMouseEvent: aMouseWheelEvent]
+ ifTrue: [aHand sendEvent: aMouseWheelEvent focus: aHand keyboardFocus clear: [aHand keyboardFocus: nil]].
+ !

Item was added:
+ ----- Method: MouseWheelState>>initialize (in category 'initialize-release') -----
+ initialize
+
+ super initialize.
+ currentDelta := 0@0.!