[Cuis-dev] [IMPROV] Mouse Wheel Events
Gerald Klix
cuis.01 at klix.ch
Wed Aug 18 12:28:57 PDT 2021
Hi all, Hi Juan,
Please find attached a change set that
implements and enables mouse-wheel-events for
Cuis.
HTH and Best Regards,
Gerald
-------------- next part --------------
'From Haver 5.0 [latest update: #4768] on 18 August 2021 at 9:24:57 pm'!
"Change Set: 4770-MouseWheelSupport-GeraldKlix-2021Aug18-21h24m
Date: 18 August 2021
Author: Gerald Klix
I provide native support for mice with wheels"!
!EventSensor methodsFor: 'private-I/O' stamp: 'KLG 8/12/2021 20:23:55'!
processMouseSensorWheelEvent: evt
"Process a mouse wheel event, updating EventSensor state.
Ported from Squeak 5.3."
| modifiers buttons mapped |
"Only used by #peekWheelDelta in Squeak, which has no senders.
Can be added in the future."
"F: mouseWheelDelta := (evt at: 3) @ (evt at: 4)."
buttons _ evt at: 5.
modifiers _ evt at: 6.
mapped _ self mapButtons: buttons modifiers: modifiers.
mouseButtons _ mapped bitOr: (modifiers bitShift: 3).! !
!EventSensor methodsFor: 'private-I/O' stamp: 'KLG 8/12/2021 21:58:09'!
processSensorEvent: evt discardingMouseEvents: discardMouseEvents
"Process a single event. This method is run at high priority."
| type |
type _ evt at: 1.
"Check if the event is a user interrupt"
(type = EventSensor eventTypeKeyboard and: [ (evt at: 4) = 0 and: [
((evt at: 3) bitOr: (((evt at: 5) bitAnd: 8) bitShift: 8)) = interruptKey]])
ifTrue: [
"interrupt key is meta - not reported as event"
^interruptSemaphore signal].
"Store the event in the queue if there's any"
type = EventSensor eventTypeMouse ifTrue: [
"Only swap secondary and tertiary buttons if there is no command or option modifier keys.
This swap is done so a 3-button mouse is
left -> mouseButton1 (select)
center -> mouseButton3 (halo)
right -> mouseButton2 (menu).
This is only needed on the Mac, Window VM does this mapping by default.
We avoid ding the swap if there are modifier keys, because in that case the buttons were generated by the VM as follows:
left -> mouseButton1
macOption + left -> mouseButton3
command + left -> mouseButton2,
but Mac users are already used to
macOption + left -> menu
command + left -> halo.
See #installMouseDecodeTable"
((evt at: 6) anyMask: 12) ifFalse: [
evt at: 5 put: (ButtonDecodeTable at: (evt at: 5) + 1)]].
(discardMouseEvents and: [ type = EventSensor eventTypeMouse ]) ifFalse: [
self queueEvent: evt ].
"Update state for InputSensor."
"KLG: Why not `self class` instead of `EventSensor`?"
type = EventSensor eventTypeMouse ifTrue: [
self processMouseSensorEvent: evt ].
type = EventSensor eventTypeKeyboard ifTrue: [
self processKeyboardSensorEvent: evt ].
type = EventSensor eventTypeMouseScroll ifTrue: [
self processMouseSensorWheelEvent: evt ]! !
!EventSensor methodsFor: 'test' stamp: 'KLG 8/14/2021 19:42:35'!
printEventBuffer: evtBuf
"Print the event buffer, currently only used by the method `test`."
| type buttons macRomanCode modifiers pressType stamp unicodeCodePoint |
type _ evtBuf first.
stamp _ evtBuf second.
stamp = 0 ifTrue: [ stamp := Time millisecondClockValue ]. "VMs report events using #millisecondClockValue"
type = EventSensor eventTypeMouse
ifTrue: [ | position |
position _ evtBuf third @ evtBuf fourth.
buttons _ evtBuf fifth.
modifiers _ evtBuf sixth.
Transcript
newLine;
show: 'Mouse';
show: ' position:', position printString;
show: ' buttons:', buttons printString;
show: ' modifiers:', modifiers printString.
].
type = EventSensor eventTypeMouseScroll
ifTrue: [ | delta |
delta _ evtBuf third @ evtBuf fourth.
buttons _ evtBuf fifth.
modifiers _ evtBuf sixth.
Transcript
newLine;
show: 'Scroll';
show: ' delta:', delta printString;
show: ' buttons:', buttons printString;
show: ' modifiers:', modifiers printString.
].
type = EventSensor eventTypeKeyboard
ifTrue: [
macRomanCode _ evtBuf third.
unicodeCodePoint _ evtBuf sixth.
pressType _ evtBuf fourth.
modifiers _ evtBuf fifth.
pressType = EventSensor eventKeyDown ifTrue: [
type _ #keyDown].
pressType = EventSensor eventKeyUp ifTrue: [
type _ #keyUp].
pressType = EventSensor eventKeyChar ifTrue: [
type _ #keystroke].
Transcript
newLine;
show: type;
show: ' macRomanCode:', macRomanCode printString, '-',
(Character numericValue: (Character macRomanToLatin1: macRomanCode)) asString, '-';
show: ' unicodeCodePoint:', unicodeCodePoint printString.
(Character iso8859s15CodeForUnicodeCodePoint: unicodeCodePoint) ifNotNil: [ :latin15 |
Transcript show: '-', (Character numericValue: latin15) asString, '-' ].
Transcript
show: ' modifiers:', modifiers printString.
(modifiers anyMask: 8) ifTrue: [ Transcript show: ' [commandWinAlt]' ].
(modifiers anyMask: 4) ifTrue: [ Transcript show: ' [macOption]' ].
(modifiers anyMask: 2) ifTrue: [ Transcript show: ' [control]' ].
(modifiers anyMask: 1) ifTrue: [ Transcript show: ' [shift]' ].
].! !
!EventSensor class methodsFor: 'constants' stamp: 'KLG 8/12/2021 21:58:09'!
eventTypeMouseScroll
"Types of events,
I am a mouse wheel event."
^7! !
!SystemDictionary methodsFor: 'vm parameters' stamp: 'KLG 8/12/2021 18:50:26'!
sendMouseWheelEvents
"The Cog VM can be instructed to deliver mouse wheel events as mouse wheel events.
By default mouse wheel events are mapped to arrow events.
This flag persists across snapshots, stored in the image header.
This implementation was copied from Squeak 5.3."
^(self vmParameterAt: 48) anyMask: 32! !
!SystemDictionary methodsFor: 'vm parameters' stamp: 'KLG 8/12/2021 18:50:12'!
sendMouseWheelEvents: aBoolean
"The Cog VM can be instructed to deliver mouse wheel events as mouse wheel events.
By default mouse wheel events are mapped to arrow events.
This flag persists across snapshots, stored in the image header.
This implementation was copied from Squeak 5.3."
self vmParameterAt: 48 put: ((self vmParameterAt: 48) bitClear: 32) + (aBoolean ifTrue: [32] ifFalse: [0])! !
!HandMorph methodsFor: 'event handling' stamp: 'KLG 8/12/2021 21:58:09'!
createEventFrom: eventBuffer ofType: type
type = EventSensor eventTypeMouse ifTrue: [ ^self generateMouseEvent: eventBuffer ].
type = EventSensor eventTypeMouseScroll ifTrue: [ ^self generateMouseScrollEvent: eventBuffer ].
type = EventSensor eventTypeKeyboard ifTrue: [ ^self generateKeyboardEvent: eventBuffer ].
type = EventSensor eventTypeWindow ifTrue: [ ^self generateWindowEvent: eventBuffer ].
type = EventSensor eventTypeDragDropFiles ifTrue: [ ^self generateDropFilesEvent: eventBuffer ].
"All other events are ignored"
^nil ! !
!HandMorph methodsFor: 'private events' stamp: 'KLG 8/14/2021 21:44:15'!
generateMouseScrollEvent: evtBuf
"Generate the appropriate mouse wheel event for the given raw event buffer
Copied from Sqeak 5.3 and modifed."
| buttons modifiers stamp deltaX deltaY direction oldButtons |
stamp _ evtBuf second.
stamp = 0 ifTrue: [stamp := Time millisecondClockValue ].
deltaX _ evtBuf third.
deltaY _ evtBuf fourth.
"This implementation deliberatly ignores movements in both dimensions:"
direction _
deltaY negative
ifTrue: [ #down ]
ifFalse: [ deltaY strictlyPositive
ifTrue: [ #up ]
ifFalse: [ deltaX negative
ifTrue: [ #left ]
ifFalse: [ deltaX strictlyPositive
ifTrue: [ #right ]
ifFalse: [ ^ nil "No movement, bailing out" ] ] ] ].
modifiers _ evtBuf fifth.
buttons _ (modifiers bitShift: 3) bitOr: (lastMouseEvent buttons bitAnd: 7).
oldButtons _ lastEventBuffer fifth
bitOr: (lastEventBuffer sixth bitShift: 3).
lastEventBuffer := evtBuf.
^ MouseScrollEvent new
setType: #mouseScroll
position: self morphPosition
direction: direction
buttons: (oldButtons bitXor: buttons)
hand: self
stamp: stamp! !
!MouseScrollEvent methodsFor: 'dispatching' stamp: 'KLG 8/16/2021 21:27:23'!
dispatchWith: aMorph
"Find the appropriate receiver for the event and let it handle it. Default rules:
* The top-most chain of visible, unlocked morphs containing the event position will get a chance to handle the event.
* When travelling down the hierarchy a prospective handler for the event is installed. This prospective handler can be used by submorphs wishing to handle the mouse down for negotiating who the receiver is.
* When travelling up, the prospective handler is always executed. The handler needs to check if the event was handled before as well as checking if somebody else's handler has been installed.
* If another handler has been installed but the event was not handled it means that somebody up in the hierarchy wants to handle the event.
"
"Try to get out quickly"
| aMorphHandlesIt handledByInner |
"FIXME - this works in all tested cases but one: when the window directly under the mouse doesn't have keyboard focus (i.e. a Transcript window)"
aMorph fullContainsGlobalPoint: position :: ifFalse: [ ^ #rejected ].
"Install the prospective handler for the receiver"
aMorphHandlesIt _ false.
(aMorph handlesMouseScroll: self) ifTrue: [
eventHandler _ aMorph.
aMorphHandlesIt _ true ].
"Now give submorphs a chance to handle the event"
handledByInner _ false.
aMorph submorphsDo: [ :eachChild |
handledByInner ifFalse: [
(eachChild dispatchEvent: self) == #rejected ifFalse: [
"Some child did contain the point so aMorph is part of the top-most chain."
handledByInner _ true ]]].
(handledByInner or: [
(aMorph rejectsEvent: self) not and: [aMorph fullContainsGlobalPoint: position]]) ifTrue: [
"aMorph is in the top-most unlocked, visible morph in the chain."
aMorphHandlesIt ifTrue: [ ^ self sendEventTo: aMorph ]].
handledByInner ifTrue: [ ^ self ].
"Mouse was not on aMorph nor any of its children"
^ #rejected.! !
!EventSensor reorganize!
('accessing' eventTicklerProcess flushAllButDandDEvents flushEvents nextEvent peekButtons peekEvent peekMousePt peekPosition)
('mouse' createMouseEvent)
('private' eventTickler flushNonKbdEvents installEventTickler isKbdEvent: lastEventPoll primInterruptSemaphore: primKbdNext primKbdPeek primMouseButtons primMousePt primSetInterruptKey:)
('private-I/O' fetchMoreEvents fetchMoreEventsDiscardingMouseEvents: mapButtons:modifiers: primGetNextEvent: primSetInputSemaphore: processKeyboardSensorEvent: processMouseSensorEvent: processMouseSensorWheelEvent: processSensorEvent:discardingMouseEvents: queueEvent:)
('test' printEventBuffer: test)
('initialization' initialize shutDownSensor)
!
!EventSensor class reorganize!
('class initialization' eventPollPeriod install)
('constants' commandAltKey controlKey eventKeyChar eventKeyDown eventKeyUp eventTypeDragDropFiles eventTypeKeyboard eventTypeMenu eventTypeMouse eventTypeMouseScroll eventTypeNone eventTypeWindow macOptionKey shiftKey)
!
!SystemDictionary reorganize!
('accessing' classes description name organization summary)
('class names' classNamed: fillCaches flushClassNameCache forgetClass:logged: hasClassNamed: prepareToRenameClass:as: prepareToRenameClass:from:to: removeClassNamed: removeClassNamedIfInBaseSystem: renameAndUpdateReferences:as: renameClassNamed:as: renamedClass:from:)
('dictionary access' associationOrUndeclaredAt: at:put:)
('housekeeping' browseEqEqSentToSmallIntegerConstants browseObsoleteMethodReferences browseUndeclaredReferences cleanCompactObsoleteClasses cleanOutUndeclared condenseChanges condenseSources macroBenchmark1 macroBenchmark3 obsoleteBehaviors obsoleteClasses obsoleteMethodReferences recompileAllFrom: removeEmptyMessageCategories testDecompiler testFormatter testFormatter2 verifyChanges)
('image, changes name' alternativeSourcesName changeImageNameTo: currentChangesName currentSourcesName defaultChangesName defaultSourcesName defaultUserChangesName fullNameForChangesNamed: fullNameForImageNamed: imageName imageName: imagePath primImageName primVmPath vmPath)
('memory space' bytesLeft bytesLeft: bytesLeftString createStackOverflow garbageCollect garbageCollectMost growMemoryByAtLeast: installLowSpaceWatcher lowSpaceThreshold lowSpaceWatcher lowSpaceWatcherProcess okayToProceedEvenIfSpaceIsLow primBytesLeft primLowSpaceSemaphore: primSignalAtBytesLeft: primitiveGarbageCollect signalLowSpace stopLowSpaceWatcher useUpMemory useUpMemoryWithArrays useUpMemoryWithContexts useUpMemoryWithTinyObjects)
('code authors' allContributors contributionsOf: knownInitialsAndNames unknownContributors)
('miscellaneous' cogitClass detectBuiltInModule: exitToDebugger extraVMMemory extraVMMemory: getCurrentWorkingDirectory getSystemAttribute: getVMParameters handleUserInterrupt interpreterClass isDevelopmentEnvironmentPresent isHeadless isModuleAvailable: listBuiltinModule: listBuiltinModules listLoadedModule: listLoadedModules logError:inContext:to: maxExternalSemaphores maxExternalSemaphores: osVersion platformName platformSubtype primGetCurrentWorkingDirectoryUnix primGetCurrentWorkingDirectoryWindows primVmFileName unloadModule: vmFileName vmOptionsDo: vmVersion voidCogVMState)
('object serialization' objectForDataStream: storeDataOn:)
('printing' printElementsOn: printOn:)
('profiling' clearProfile dumpProfile profile: startProfiling stopProfiling)
('retrieving' allBehaviorsDo: allCallsOn: allCallsOn:and: allClasses allClassesDo: allClassesImplementing: allGlobalRefs allGlobalRefsWithout: allImplementedMessages allImplementedMessagesWithout: allImplementorsOf: allImplementorsOf:localTo: allMethodsInCategory: allMethodsSourceStringMatching: allMethodsWithSourceString:matchCase: allMethodsWithString: allObjects allObjectsDo: allObjectsOrNil allPrimitiveMessages allPrimitiveMethodsInCategories: allReferencesToLiteral: allSelect: allSentMessages allSentMessagesWithout: allUnSentMessages allUnSentMessagesIn: allUnSentMessagesWithout: allUnimplementedCalls allUnusedClassesWithout: hierachySortedAllClassesDo: isThereAReferenceTo: isThereAnImplementorOf: isThereAnImplementorOf:exceptFor: numberOfImplementorsOf: numberOfSendersOf: pointersTo: pointersTo:except: poolUsers unimplemented)
('shrinking' abandonSources presumedSentMessages reduceCuis removeAllUnSentMessages removeSelector: removedUnusedClassesAndMethods reportClassAndMethodRemovalsFor: unusedClasses unusedClassesAndMethodsWithout:)
('snapshot and quit' add:toList:after: addToShutDownList: addToShutDownList:after: addToStartUpList: addToStartUpList:after: lastQuitLogPosition logSnapshot:andQuit: nopTag okayToDiscardUnsavedCode okayToSave printStuffToCleanOnImageSave processShutDownList: processStartUpList: quitNoSaveTag quitPrimitive quitPrimitive: quitTag removeFromShutDownList: removeFromStartUpList: saveAs saveAs:andQuit:clearAllClassState: saveAsNewVersion saveSession send:toClassesNamedIn:with: setGCParameters setPlatformPreferences snapshot:andQuit: snapshot:andQuit:clearAllClassState: snapshot:andQuit:embedded: snapshot:andQuit:embedded:clearAllClassState: snapshotEmbeddedPrimitive snapshotMessageFor:andQuit: snapshotPrimitive snapshotTag snapshotTagFor:andQuit: storeOn: tagHeader tagTail unbindExternalPrimitives)
('sources, change log' aboutThisSystem assureStartupStampLogged calcEndianness classRemoved:fromCategory: closeSourceFiles endianness evaluated:context: externalizeSources forceChangesToDisk internalizeChangeLog internalizeSources isBigEndian isLittleEndian lastUpdateString logChange: logChange:preamble: methodRemoved:selector:inProtocol:class: openSourceFiles openSourcesAndChanges systemInformationString timeStamp: version)
('special objects' clearExternalObjects compactClassesArray compactClassesArrayIncludes: externalObjects hasSpecialSelector:ifTrueSetByte: primitiveErrorTable recreateSpecialObjectsArray registerExternalObject: specialNargsAt: specialObjectsArray specialSelectorAt: specialSelectorSize specialSelectors unregisterExternalObject:)
('toDeprecate')
('ui' beep confirmRemovalOf:on: globals inspectGlobals primitiveBeep systemCategoryFromUserWithPrompt:)
('browsing' browseAllAccessesTo:from: browseAllCallsOn: browseAllCallsOn:and: browseAllCallsOn:localTo: browseAllCallsOnClass: browseAllImplementorsOf: browseAllImplementorsOf:localTo: browseAllImplementorsOfList: browseAllImplementorsOfList:title: browseAllMethodsInCategory: browseAllPrimitives browseAllReferencesToLiteral: browseAllSelect: browseAllSelect:name:autoSelect: browseAllStoresInto:from: browseAllUnSentMessages browseAllUnimplementedCalls browseClassCommentsWithString: browseClassesWithNamesContaining:caseSensitive: browseEqSmallConstant browseInstVarDefs: browseInstVarRefs: browseLikelyUnnededRedefinitions browseMessageList:name: browseMessageList:name:autoSelect: browseMessageListUnsorted:name:autoSelect: browseMethodsWithSourceString: browseMethodsWithString: browseMethodsWithString:matchCase: browseMyChanges browseObsoleteReferences browseViewReferencesFromNonViews showMenuOf:withFirstItem:ifChosenDo: showMenuOf:withFirstItem:ifChosenDo:withCaption:)
('private' allSymbolsIn:do: baseLabel)
('Closure measurements' browseMethodsWithClosuresThatAccessOuterTemps browseMethodsWithClosuresThatOnlyReadOuterTemps browseMethodsWithClosuresThatWriteOuterTemps browseMethodsWithClosuresThatWriteOuterTempsButCleanOtherwise browseMethodsWithEmptyClosures browseMethodsWithMoreThanOneClosure browseMethodsWithOnlyCleanClosures closuresInfoStringForClass:selector: eliotsClosureMeasurements eliotsClosureMeasurements2 eliotsClosureMeasurements2On: eliotsClosureMeasurementsOn:over:)
('removing' removeKey:ifAbsent:)
('system attributes' flagInterpretedMethods: isRunningCog isRunningCogit isSpur maxIdentityHash processHasThreadIdInstVar: processPreemptionYields processPreemptionYields:)
('query' hierarchySorted:do: methodsWithUnboundGlobals unusedBlocks)
('testing' hasBindingThatBeginsWith: isLiveSmalltalkImage isLiveTypingInstalled)
('classes and traits' classNames nonClassNames)
('image format' imageFormatVersion imageFormatVersionFromFile imageFormatVersionFromFileAsIs)
('AndreasProfiler-profiling' interruptChecksPerMSec longRunningPrimitive longRunningPrimitiveSemaphore: profilePrimitive profileSample profileSemaphore: profileStart:)
('startup' doStartUp: processCommandLineArgument:storeStartUpScriptArgsOn: processCommandLineArguments readCommandLineArguments setStartupStamp startUpArguments startUpScriptArguments)
('startup - restore lost changes' hasToRestoreChanges hasToRestoreChangesFrom: isQuitNoSaveRecord: isQuitRecord: isSnapshotQuitOrQuitNoSaveRecord: isSnapshotRecord: lostChangesDetectedCaption restoreLostChanges restoreLostChangesAutomatically restoreLostChangesAutomaticallyFrom: restoreLostChangesIfNecessary restoreLostChangesManually restoreLostChangesOptions restoringChangesHasErrorsCaption shouldShowFileInErrors withChangesFileDo:)
('image' wordSize)
('vm parameters' doMixedArithmetic doMixedArithmetic: sendMouseWheelEvents sendMouseWheelEvents: vmParameterAt: vmParameterAt:put:)
('environment support')
!
!HandMorph reorganize!
('accessing' lastMouseEvent lastMouseEventTime mouseOverHandler)
('balloon help' balloonHelp balloonHelp: deleteBalloonTarget: removePendingBalloonFor: spawnBalloonFor: triggerBalloonFor:after:)
('caching' releaseCachedState)
('classification' is:)
('double click support' dontWaitForMoreClicks waitForClicksOrDrag:event:clkSel:dblClkSel: waitForClicksOrDrag:event:dragSel:clkSel: waitForClicksOrDragOrSimulatedMouseButton2:event:clkSel:clkNHalf:dblClkSel:dblClkNHalfSel:tripleClkSel: waitForClicksOrDragOrSimulatedMouseButton2:event:clkSel:clkNHalf:dblClkSel:dblClkNHalfSel:tripleClkSel:dragSel: waitingForMoreClicks)
('drawing' drawOn: fullDrawHandOn: needsToBeDrawn restoreSavedPatchOn: savePatchFrom:appendDamageTo:)
('event handling' createEventFrom:ofType: flushEvents noticeMouseOver:event: processEventQueue)
('events-processing' startDropEventDispatch: startDropFilesEventDispatch: startEventDispatch: startKeyboardDispatch: startMouseDispatch: startWindowEventDispatch:)
('focus handling' activateNextWindow activatePreviousWindow keyboardFocus keyboardFocusNext keyboardFocusPrevious mouseFocus newKeyboardFocus: newMouseFocus: nextFocusMorph nextFocusWindow previousFocusMorph previousFocusWindow releaseAllFoci releaseKeyboardFocus releaseKeyboardFocus: releaseMouseFocus releaseMouseFocus:)
('geometry' basicDisplayBounds displayFullBoundsForPatch)
('geometry testing' submorphsMightProtrude)
('grabbing/dropping' attachMorph: attachMorphBeside: dropMorph:event: dropMorphs: grabMorph: grabMorph:delta: grabMorph:moveUnderHand:)
('halo handling' halo: obtainHalo: releaseHalo: removeHaloFromClick:on:)
('halos and balloon help' halo)
('initialization' initForEvents initialize)
('testing' isIncludedInTaskbar)
('objects from disk' objectForDataStream:)
('paste buffer' pasteMorph)
('updating')
('private' forgetGrabMorphDataFor: grabMorphDataFor: rememberGrabMorphDataFor:)
('private events' generateDropFilesEvent: generateKeyboardEvent: generateMouseEvent: generateMouseScrollEvent: generateWindowEvent: mouseTrailFrom: shouldControlEmulateAltFor:)
!
!MouseScrollEvent reorganize!
('private' setType:position:direction:buttons:hand:stamp:)
('comparing' = hash)
('dispatching' dispatchWith: sendEventTo:)
('accessing' direction)
!
"PostScript:
Initialization code follows:"
Smalltalk sendMouseWheelEvents: true!
More information about the Cuis-dev
mailing list