--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ThumbWheel.st Fri Jan 15 20:46:41 2016 +0100
@@ -0,0 +1,771 @@
+"
+ COPYRIGHT (c) 1996 by eXept Software AG / Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+"{ Package: 'stx:libwidg2' }"
+
+View subclass:#ThumbWheel
+ instanceVariableNames:'orientation synchronousOperation thumbPosition thumbColor
+ thumbShadowColor thumbLightColor thumbEnteredColor tallyLevel
+ tallyAngle rangeStart rangeEnd rangeStep angleRange
+ unitsPerRotation entered press pressPos scrollAction
+ endlessRotation startMoveAction endMoveAction keyboardStep'
+ classVariableNames:'DefaultViewBackground DefaultThumbColor DefaultThumbShadowColor
+ DefaultThumbLightColor DefaultTallyMarks DefaultTallyLevel
+ DefaultLevel DefaultBorderWidth'
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+!ThumbWheel class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1996 by eXept Software AG / Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+
+
+!
+
+documentation
+"
+ A thumbWheel is like a slider, but looks different ...
+ ThumbWheels are useful with 3D applications, to control
+ things like rotation, translation and magnification.
+
+ [author:]
+ Claus Gittinger
+
+ [see also:]
+ Slider ScrollBar StepSlider
+"
+!
+
+examples
+"
+ basic setup:
+ [exBegin]
+ |top wheel|
+
+ top := StandardSystemView new.
+ top extent:200@200.
+
+ wheel := ThumbWheel in:top.
+ wheel orientation:#vertical.
+ wheel level:1.
+
+ wheel origin:0.0@0.0; extent:(wheel preferredExtent).
+
+ top open.
+ [exEnd]
+
+ two of them:
+ [exBegin]
+ |top wheel1 wheel2|
+
+ top := StandardSystemView new.
+ top extent:200@200.
+
+ wheel1 := ThumbWheel in:top.
+ wheel1 orientation:#vertical.
+ wheel1 level:1.
+
+ wheel1 origin:0.0@0.0; extent:(wheel1 preferredExtent).
+
+ wheel2 := ThumbWheel in:top.
+ wheel2 orientation:#horizontal.
+ wheel2 level:1.
+
+ wheel2 origin:0.0@1.0; extent:(wheel2 preferredExtent).
+ wheel2 topInset:(wheel2 preferredExtent y negated).
+ wheel2 bottomInset:(wheel2 preferredExtent y).
+ top open.
+ [exEnd]
+
+ performing an action:
+ [exBegin]
+ |top wheel|
+
+ top := StandardSystemView new.
+ top extent:200@200.
+
+ wheel := ThumbWheel in:top.
+ wheel orientation:#vertical.
+ wheel level:1.
+
+ wheel origin:0.0@0.0; extent:(wheel preferredExtent).
+ wheel scrollAction:[:value | Transcript showCR:value rounded].
+ top open.
+ [exEnd]
+ operating on a model:
+ [exBegin]
+ |top wheel model|
+
+ model := ValueHolder new.
+ model
+ onChangeSend:#value
+ to:[Transcript show:'value now: '; showCR:model value rounded].
+
+ top := StandardSystemView new.
+ top extent:200@200.
+
+ wheel := ThumbWheel in:top.
+ wheel orientation:#vertical.
+ wheel level:1.
+
+ wheel origin:0.0@0.0; extent:(wheel preferredExtent).
+ wheel model:model.
+ top open.
+ [exEnd]
+ endless rotation:
+ [exBegin]
+ |top wheel model|
+
+ model := ValueHolder new.
+ model
+ onChangeSend:#value
+ to:[Transcript show:'value now: '; showCR:model value rounded].
+
+ top := StandardSystemView new.
+ top extent:200@200.
+
+ wheel := ThumbWheel in:top.
+ wheel orientation:#vertical.
+ wheel level:1.
+ wheel endlessRotation:true.
+
+ wheel origin:0.0@0.0; extent:(wheel preferredExtent).
+ wheel model:model.
+ top open.
+ [exEnd]
+ concrete example:
+ [exBegin]
+ |top wheel1 wheel2 image magX magY hHolder vHolder imageView|
+
+ magX := magY := 1.
+
+ hHolder := ValueHolder new.
+ hHolder
+ onChangeSend:#value
+ to:[
+ magX := hHolder value * 2 / 360.
+ magX = 0 ifTrue:[magX := 0.01].
+ Transcript show:'magX now '; showCR:magX.
+ imageView clear.
+ imageView magnification:magX@magY].
+
+ vHolder := ValueHolder new.
+ vHolder
+ onChangeSend:#value
+ to:[
+ magY := vHolder value * 2 / 360.
+ magY = 0 ifTrue:[magY := 0.01].
+ Transcript show:'magY now '; showCR:magY.
+ imageView clear.
+ imageView magnification:magX@magY].
+
+ top := StandardSystemView new.
+ top extent:200@200.
+
+ wheel1 := ThumbWheel in:top.
+ wheel1 orientation:#vertical.
+ wheel1 level:1.
+ wheel1 origin:0.0@0.0; extent:(wheel1 preferredExtent).
+ wheel1 model:vHolder.
+
+ wheel2 := ThumbWheel in:top.
+ wheel2 orientation:#horizontal.
+ wheel2 level:1.
+ wheel2 origin:0.0@1.0; extent:(wheel2 preferredExtent).
+ wheel2 topInset:(wheel2 preferredExtent y negated).
+ wheel2 bottomInset:(wheel2 preferredExtent y).
+ wheel2 model:hHolder.
+
+ imageView := ImageEditView in:top.
+ imageView level:1.
+ imageView origin:0.0@0.0 corner:1.0@1.0.
+ imageView leftInset:(wheel1 preferredExtent x).
+ imageView bottomInset:(wheel2 preferredExtent y).
+ imageView image:(Image fromFile:'bitmaps/garfield.gif').
+ top open.
+ [exEnd]
+
+"
+! !
+
+!ThumbWheel methodsFor:'accessing'!
+
+keyboardStep
+ "return the scrollers keyboard step. If non-nil,
+ thats the stepping value used with cursorUp/cursorDown keys.
+ (not used with Scrollers, but provided for subclasses)"
+
+ ^ keyboardStep
+
+!
+
+keyboardStep:aNumber
+ "set the scrollers keyboard step. If non-nil,
+ thats the stepping value used with cursorUp/cursorDown keys.
+ (not used with Scrollers, but provided for subclasses)"
+
+ keyboardStep := aNumber
+
+!
+
+start
+ "return the wheels range minimum."
+
+ ^ rangeStart
+
+ "Created: 1.4.1997 / 12:30:04 / cg"
+ "Modified: 1.4.1997 / 12:52:31 / cg"
+!
+
+start:aNumber
+ "set the wheels range minimum."
+
+ rangeStart := aNumber
+
+ "Created: 1.4.1997 / 12:30:54 / cg"
+ "Modified: 1.4.1997 / 12:52:36 / cg"
+!
+
+start:start stop:stop
+ "set the wheels range minimum."
+
+ rangeStart := start.
+ rangeEnd := stop.
+
+ "Modified: / 1.4.1997 / 12:52:36 / cg"
+ "Created: / 23.1.1998 / 15:06:04 / cg"
+!
+
+step
+ "return the wheels range step."
+
+ ^ rangeStep
+
+ "Created: 1.4.1997 / 12:30:15 / cg"
+ "Modified: 1.4.1997 / 12:53:05 / cg"
+!
+
+step:aNumber
+ "set the wheels range step."
+
+ rangeStep := aNumber
+
+ "Created: 1.4.1997 / 12:30:32 / cg"
+ "Modified: 1.4.1997 / 12:52:49 / cg"
+!
+
+stop
+ "return the wheels range end."
+
+ ^ rangeEnd
+
+ "Created: 1.4.1997 / 12:30:09 / cg"
+ "Modified: 1.4.1997 / 12:52:59 / cg"
+!
+
+stop:aNumber
+ "set the wheels range end."
+
+ rangeEnd := aNumber
+
+ "Created: 1.4.1997 / 12:30:47 / cg"
+ "Modified: 1.4.1997 / 12:52:54 / cg"
+!
+
+thumbOrigin:pos
+ "same as thumbPosition (for protocol compatibility with sliders)"
+
+ self thumbPosition:pos
+
+ "Created: / 21.4.1998 / 20:57:20 / cg"
+ "Modified: / 21.4.1998 / 20:58:43 / cg"
+!
+
+thumbPosition
+ "sreturn the position"
+
+ ^ thumbPosition
+
+ "Created: / 21.4.1998 / 20:58:15 / cg"
+!
+
+thumbPosition:pos
+ "set the wheels position; the argument should be in the start..stop
+ interval."
+
+ |newPos delta|
+
+ delta := (rangeEnd-rangeStart).
+
+ newPos := pos.
+ endlessRotation ifTrue:[
+ [newPos < rangeStart] whileTrue:[
+ newPos := newPos + delta
+ ].
+ [newPos > rangeEnd] whileTrue:[
+ newPos := newPos - delta
+ ].
+ ].
+ newPos := (newPos max:rangeStart) min:rangeEnd.
+
+ rangeStep notNil ifTrue:[
+ newPos := newPos roundTo:rangeStep.
+ rangeStep isInteger ifTrue:[
+ newPos := newPos asInteger
+ ]
+ ].
+
+ newPos ~= thumbPosition ifTrue:[
+ thumbPosition := newPos.
+ shown ifTrue:[
+ self invalidate.
+ ]
+ ].
+
+ "Created: / 27.9.1996 / 18:10:57 / cg"
+ "Modified: / 6.6.1998 / 23:29:28 / cg"
+! !
+
+!ThumbWheel methodsFor:'accessing-behavior'!
+
+endMoveAction
+ "set the endMoveAction, a block which is evaluated when the wheel
+ stops to move (i.e. the user releases the mouse).
+ The default is nil (i.e. no action)"
+
+ ^ endMoveAction
+
+ "Created: / 18.8.1998 / 16:29:40 / cg"
+ "Modified: / 18.8.1998 / 16:31:41 / cg"
+!
+
+endMoveAction:aBlock
+ "set the endMoveAction, a block which is evaluated when the wheel
+ stops to move (i.e. the user releases the mouse)."
+
+ endMoveAction := aBlock.
+
+ "Created: / 18.8.1998 / 16:30:40 / cg"
+!
+
+endlessRotation:aBoolean
+ "if true, rotation wraps and endless rotation is permitted.
+ If false (the default), rotation ends at rangeStart/rangeEnd."
+
+ endlessRotation := aBoolean
+
+ "Created: / 5.2.1998 / 22:20:28 / cg"
+!
+
+scrollAction
+ "return the scrollAction, a block which is evaluated when the wheel
+ is turned (i.e. for every change)."
+
+ ^ scrollAction
+
+ "Modified: / 18.8.1998 / 16:31:59 / cg"
+!
+
+scrollAction:aBlock
+ "set the scrollAction, a block which is evaluated when the wheel
+ is turned (i.e. for every change)."
+
+ scrollAction := aBlock.
+
+ "Modified: / 18.8.1998 / 16:31:52 / cg"
+!
+
+startMoveAction
+ "return the startMoveAction, a block which is evaluated when the wheel
+ starts to turn (i.e. the user clicks on it).
+ The default is nil (i.e. no action)"
+
+ ^ startMoveAction
+
+ "Created: / 18.8.1998 / 16:29:36 / cg"
+ "Modified: / 18.8.1998 / 16:31:16 / cg"
+!
+
+startMoveAction:aBlock
+ "set the startMoveAction, a block which is evaluated when the wheel
+ starts to turn (i.e. the user clicks on it)."
+
+ startMoveAction := aBlock.
+
+ "Modified: / 18.8.1998 / 16:30:53 / cg"
+! !
+
+!ThumbWheel methodsFor:'accessing-look'!
+
+orientation
+ "return the wheels orientation; #horizontal or #vertical"
+
+ ^ orientation
+
+ "Created: 1.4.1997 / 12:29:46 / cg"
+!
+
+orientation:aSymbol
+ "set the wheels orientation; the argument may be one of
+ #horizontal or #vertical"
+
+ orientation := aSymbol.
+ shown ifTrue:[
+ self invalidate
+ ]
+
+ "Created: 27.9.1996 / 16:02:14 / cg"
+ "Modified: 1.4.1997 / 12:50:22 / cg"
+! !
+
+!ThumbWheel methodsFor:'drawing'!
+
+redrawX:x y:y width:w height:h
+ "redraw the thumbWheel.
+ Q: is it worth the effort - or should we simply use some bitmap ?"
+
+ |halfHeight y0 y1 halfWidth x0 x1 thumbColor|
+
+ halfHeight := height // 2.
+ halfWidth := width // 2.
+ y0 := 4.
+ y1 := height - 4.
+ x0 := 4.
+ x1 := width - 4.
+
+ self paint:viewBackground. "/ View defaultViewBackgroundColor.
+ self fillRectangleX:x y:y width:w height:h.
+
+ thumbColor := View defaultViewBackgroundColor.
+ thumbColor ~= viewBackground ifTrue:[
+ self paint:thumbColor.
+ orientation == #vertical ifTrue:[
+ self fillRectangleX:3 y:y0 width:width-6 height:height-8.
+ ] ifFalse:[
+ self fillRectangleX:x0 y:3 width:width-8 height:height-6.
+ ]
+ ].
+
+ ((thumbPosition truncateTo:tallyAngle))
+ to:((thumbPosition + angleRange truncateTo:tallyAngle)+tallyAngle) by:tallyAngle do:[:a |
+ |yT pA xT d|
+
+ pA := a - thumbPosition.
+ d := (pA degreesToRadians cos).
+ yT := halfHeight + (d * (halfHeight - 4)) - 1.
+ xT := halfWidth + (d * (halfWidth - 4)) - 1.
+
+ xT := xT min:x1.
+ yT := yT min:y1.
+
+ (pA > (angleRange * 7 // 8)) ifTrue:[
+ self paint:shadowColor
+ ] ifFalse:[
+ self paint:Color black.
+ ].
+
+ orientation == #vertical ifTrue:[
+ self displayLineFromX:3 y:yT toX:width-4 y:yT.
+ ] ifFalse:[
+ self displayLineFromX:xT y:3 toX:xT y:height-4.
+ ].
+
+ (pA between:(angleRange * 4 // 8) and:(angleRange * 7 // 8)) ifTrue:[
+ self paint:Color white.
+ orientation == #vertical ifTrue:[
+ self displayLineFromX:3 y:yT-1 toX:width-5 y:yT-1.
+ ] ifFalse:[
+ self displayLineFromX:xT-1 y:3 toX:xT-1 y:height-5.
+ ].
+
+ (pA between:(angleRange * 4 // 8) and:(angleRange * 6 // 8)) ifTrue:[
+ self paint:Color white.
+ orientation == #vertical ifTrue:[
+ self displayLineFromX:3 y:yT-2 toX:width-5 y:yT-2.
+ ] ifFalse:[
+ self displayLineFromX:xT-2 y:3 toX:xT-2 y:height-5.
+ ]
+ ]
+ ]
+ ].
+
+ self paint:Color white. "/lightColor.
+ orientation == #vertical ifTrue:[
+ self displayLineFromX:2 y:y0 toX:2 y:y1.
+ ] ifFalse:[
+ self displayLineFromX:x0 y:2 toX:x1 y:2.
+ ].
+
+ self paint:shadowColor.
+ orientation == #vertical ifTrue:[
+ self displayLineFromX:width-4 y:y0 toX:width-4 y:y1.
+ ] ifFalse:[
+ self displayLineFromX:x0 y:height-4 toX:x1 y:height-4.
+ ].
+ self displayLineFromX:width-4 y:y0-1 toX:width-4 y:y1+1.
+
+ orientation == #vertical ifTrue:[
+ self displayLineFromX:width-4 y:y0 toX:width-4 y:y1.
+ ] ifFalse:[
+ self displayLineFromX:x0 y:height-4 toX:x1 y:height-4.
+ ].
+
+ "Created: / 27.9.1996 / 16:04:49 / cg"
+ "Modified: / 6.6.1998 / 23:30:38 / cg"
+! !
+
+!ThumbWheel methodsFor:'events'!
+
+buttonMotion:state x:x y:y
+ |deltaY deltaX d oldPos newPos|
+
+ (state == 0 or:[press isNil]) ifTrue:[
+ ^ self
+ ].
+ deltaY := y - press y.
+ deltaX := x - press x.
+
+ "/scale acc. to angleRange
+ orientation == #vertical ifTrue:[
+ d := deltaY / height * angleRange.
+ ] ifFalse:[
+ d := deltaX / width * angleRange
+ ].
+ rangeStep notNil ifTrue:[
+ d := d * (rangeStep * 3)
+ ].
+
+ oldPos := thumbPosition.
+ newPos := pressPos + d.
+
+"/ newPos > rangeEnd ifTrue:[
+"/ newPos := rangeEnd
+"/ ].
+"/ newPos < rangeStart ifTrue:[
+"/ newPos := rangeStart
+"/ ].
+
+ newPos ~= oldPos ifTrue:[
+ self thumbPosition:newPos.
+ self repairDamage.
+
+ synchronousOperation ifTrue: [
+ self tellOthers.
+ ].
+ ].
+
+ "Created: / 27.9.1996 / 17:38:57 / cg"
+ "Modified: / 16.6.1998 / 10:24:40 / cg"
+!
+
+buttonPress:button x:x y:y
+ press := x@y.
+
+ "/ fetch the current value; to avoid a jump.
+ model notNil ifTrue:[
+ thumbPosition := (model value ? 0).
+ ].
+ pressPos := thumbPosition.
+ startMoveAction notNil ifTrue:[
+ startMoveAction value
+ ].
+
+ "Created: / 27.9.1996 / 17:37:57 / cg"
+ "Modified: / 18.8.1998 / 16:32:21 / cg"
+!
+
+buttonRelease:button x:x y:y
+ synchronousOperation ifFalse: [
+ self tellOthers.
+ ].
+ endMoveAction notNil ifTrue:[
+ endMoveAction value
+ ].
+
+ "Created: / 27.9.1996 / 18:13:35 / cg"
+ "Modified: / 18.8.1998 / 16:32:30 / cg"
+!
+
+keyPress:key x:x y:y
+ <resource: #keyboard (#CursorRight #CursorUp #CursorLeft #CursorDown #+ #-)>
+
+ |step|
+
+ step := self verticalScrollStep.
+
+ (key == #CursorRight
+ or:[key == #CursorDown
+ or:[key == $+]]) ifTrue:[
+ self scrollStep:step.
+ ^ self
+ ].
+
+ (key == #CursorLeft
+ or:[key == #CursorUp
+ or:[key == $-]]) ifTrue:[
+ self scrollStep:step negated.
+ ^ self
+ ].
+
+ super keyPress:key x:x y:y
+
+ "Modified: / 21.4.1998 / 20:49:32 / cg"
+ "Created: / 21.4.1998 / 20:55:29 / cg"
+!
+
+sizeChanged:how
+ super sizeChanged:how.
+ shown ifTrue:[
+ self invalidate
+ ]
+
+ "Created: / 18.4.1998 / 02:36:04 / cg"
+ "Modified: / 18.4.1998 / 14:10:16 / cg"
+!
+
+update:something with:aParameter from:changedObject
+ "handle update from a model (if any)"
+
+ (changedObject == model
+ "and:[something == aspectMsg]") ifTrue:[
+ self thumbPosition:(model value ? 0).
+ ^ self
+ ].
+ super update:something with:aParameter from:changedObject
+
+ "Modified: / 16.6.1998 / 10:25:42 / cg"
+! !
+
+!ThumbWheel methodsFor:'forced scroll'!
+
+scrollDown:amountToScroll
+ "compatibility with SimpleView. This allows mouse wheel actions on Scrollers
+ Note: this is used for horizontal scrollers, too (scrollRight)"
+
+ self scrollStep:amountToScroll
+!
+
+scrollStep:delta
+ "step by some delta"
+
+ |oldOrg newOrg|
+
+ oldOrg := thumbPosition.
+ newOrg := ((oldOrg + delta) max:rangeStart) min:rangeEnd.
+ oldOrg ~= newOrg ifTrue:[
+ self thumbOrigin:newOrg.
+ self tellOthers.
+ ]
+
+ "Created: / 21.4.1998 / 20:56:15 / cg"
+ "Modified: / 21.4.1998 / 20:59:25 / cg"
+!
+
+scrollUp:amountToScroll
+ "compatibility with SimpleView. This allows mouse wheel actions on Scrollers
+ Note: this is used for horizontal scrollers, too (scrollLeft)"
+
+ self scrollStep:amountToScroll negated
+! !
+
+!ThumbWheel methodsFor:'initialization'!
+
+initialize
+ "initialize - setup instvars from defaults"
+
+ super initialize.
+
+ orientation isNil ifTrue:[orientation := #vertical].
+
+ entered := false.
+ synchronousOperation := true.
+ endlessRotation := false.
+
+ thumbPosition := 0.
+
+ rangeStart := 0.
+ rangeEnd := 360.
+ rangeStep := nil. "/ meaning: arbitrary precision
+
+ angleRange := 150. "/ 180 degrees are visible
+ tallyAngle := 10. "/ tally every 10 degrees
+ unitsPerRotation := 360.
+
+ "Modified: / 5.2.1998 / 22:20:39 / cg"
+! !
+
+!ThumbWheel methodsFor:'private'!
+
+tellOthers
+ "notify others of a change"
+
+ "
+ the ST/X way of notifying scrolls
+ "
+ scrollAction notNil ifTrue:[
+ scrollAction value:thumbPosition
+ ].
+ "
+ the ST-80 way of notifying scrolls
+ "
+ self sendChangeMessageWith:thumbPosition.
+ self changed:#scrollerPosition.
+
+ "Created: 27.9.1996 / 18:14:02 / cg"
+ "Modified: 28.5.1997 / 16:04:16 / cg"
+! !
+
+!ThumbWheel methodsFor:'queries'!
+
+preferredExtent
+ "return a useful default extent"
+
+ |ppmm|
+
+ preferredExtent isNil ifTrue:[
+ ppmm := self graphicsDevice pixelPerMillimeter.
+ orientation == #vertical ifTrue:[
+ preferredExtent := (ppmm * (5 @ 30)) rounded
+ ] ifFalse:[
+ preferredExtent := (ppmm * (30 @ 5)) rounded
+ ].
+ ].
+
+ ^ preferredExtent
+
+ "Modified: 28.5.1997 / 16:03:55 / cg"
+!
+
+verticalScrollStep
+ "mouse wheel: scroll step
+ Note: this is used for horizontal scrollers, too"
+
+ ^ keyboardStep ? (rangeEnd - rangeStart / 10)
+! !
+
+!ThumbWheel class methodsFor:'documentation'!
+
+version
+ ^ '$Header$'
+! !