[squeak-dev] The Trunk: Morphic-mt.842.mczcommits at source.squeak.org commits at source.squeak.orgWed Apr 8 18:27:11 UTC 2015
Marcel Taeumel uploaded a new version of Morphic to project The Trunk: http://source.squeak.org/trunk/Morphic-mt.842.mcz ==================== Summary ==================== Name: Morphic-mt.842 Author: mt Time: 8 April 2015, 8:26:35.712 pm UUID: 69b4e9ef-0563-9748-a5bf-fe69528f37b8 Ancestors: Morphic-mt.841 Made Slider more pluggable and thus removed PluggableSliderMorph from the system. The code that was not moved upwards into Slider was moved downwards into its sole subclass: BracketSliderMorph. It was verified that the "new color picker morph", which is the sole user of that BracketSliderMorph, stays functional. Why? The Slider should support custom min/max values whenever the default (floats with 0.0 to 1.0) is not appropriate. Truncation is supported, too. Everything was already present in the (removed) PluggableSliderMorph, but we need that behavior in ScrollBar. Note: There is still the SimpleSliderMorph, which duplicates some behavior of Slider but is a base class of slider. E-Toys uses it. We may want to remove that duplicated code later. =============== Diff against Morphic-mt.841 =============== Item was changed: + Slider subclass: #BracketSliderMorph + instanceVariableNames: 'getEnabledSelector enabled' - PluggableSliderMorph subclass: #BracketSliderMorph - instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets'! !BracketSliderMorph commentStamp: 'gvc 5/18/2007 13:39' prior: 0! Abstract superclass for morphs that are used to select a component (R, G, B or A) of a colour.! Item was added: + ----- Method: BracketSliderMorph>>adoptPaneColor: (in category 'accessing - ui') ----- + adoptPaneColor: paneColor + "Pass on to the border too." + super adoptPaneColor: paneColor. + paneColor ifNil: [ ^ self ]. + self + fillStyle: self fillStyleToUse ; + borderStyle: + (BorderStyle inset + width: 1 ; + baseColor: self color twiceDarker) ; + sliderColor: + (self enabled + ifTrue: [ paneColor twiceDarker ] + ifFalse: [ self paneColor twiceDarker paler ])! Item was added: + ----- Method: BracketSliderMorph>>borderStyleToUse (in category 'accessing - ui') ----- + borderStyleToUse + "Answer the borderStyle that should be used for the receiver." + + ^self enabled + ifTrue: [self theme sliderNormalBorderStyleFor: self] + ifFalse: [self theme sliderDisabledBorderStyleFor: self]! Item was added: + ----- Method: BracketSliderMorph>>defaultColor (in category 'accessing - ui') ----- + defaultColor + "Answer the default color/fill style for the receiver." + + ^Color white! Item was changed: + ----- Method: BracketSliderMorph>>defaultFillStyle (in category 'accessing - ui') ----- - ----- Method: BracketSliderMorph>>defaultFillStyle (in category 'as yet unclassified') ----- defaultFillStyle "Answer the defauolt fill style." ^Color gray! Item was added: + ----- Method: BracketSliderMorph>>disable (in category 'as yet unclassified') ----- + disable + "Disable the receiver." + + self enabled: false! Item was added: + ----- Method: BracketSliderMorph>>enable (in category 'as yet unclassified') ----- + enable + "Enable the receiver." + + self enabled: true! Item was added: + ----- Method: BracketSliderMorph>>enabled (in category 'accessing') ----- + enabled + "Answer the value of enabled" + + ^ enabled! Item was added: + ----- Method: BracketSliderMorph>>enabled: (in category 'accessing') ----- + enabled: anObject + "Set the value of enabled" + + enabled = anObject ifTrue: [^self]. + enabled := anObject. + self changed: #enabled. + self + adoptPaneColor: self color; + changed! Item was changed: + ----- Method: BracketSliderMorph>>extent: (in category 'geometry') ----- - ----- Method: BracketSliderMorph>>extent: (in category 'as yet unclassified') ----- extent: aPoint "Update the gradient directions." super extent: aPoint. self updateFillStyle! Item was changed: + ----- Method: BracketSliderMorph>>fillStyleToUse (in category 'accessing - ui') ----- - ----- Method: BracketSliderMorph>>fillStyleToUse (in category 'as yet unclassified') ----- fillStyleToUse "Answer the fillStyle that should be used for the receiver." ^self fillStyle! Item was added: + ----- Method: BracketSliderMorph>>getEnabledSelector (in category 'accessing') ----- + getEnabledSelector + "Answer the value of getEnabledSelector" + + ^ getEnabledSelector! Item was added: + ----- Method: BracketSliderMorph>>getEnabledSelector: (in category 'accessing') ----- + getEnabledSelector: aSymbol + "Set the value of getEnabledSelector" + + getEnabledSelector := aSymbol. + self updateEnabled! Item was changed: + ----- Method: BracketSliderMorph>>gradient (in category 'accessing - ui') ----- - ----- Method: BracketSliderMorph>>gradient (in category 'as yet unclassified') ----- gradient "Answer the gradient." self subclassResponsibility! Item was added: + ----- Method: BracketSliderMorph>>handlesMouseDown: (in category 'event handling') ----- + handlesMouseDown: evt + "Answer true." + + ^true! Item was changed: + ----- Method: BracketSliderMorph>>initialize (in category 'initialization') ----- - ----- Method: BracketSliderMorph>>initialize (in category 'as yet unclassified') ----- initialize "Initialize the receiver." super initialize. self + enabled: true; fillStyle: self defaultFillStyle; borderStyle: (BorderStyle inset baseColor: self color; width: 1); sliderColor: Color black; clipSubmorphs: true! Item was changed: + ----- Method: BracketSliderMorph>>initializeSlider (in category 'initialization') ----- - ----- Method: BracketSliderMorph>>initializeSlider (in category 'as yet unclassified') ----- initializeSlider "Make the slider raised." slider :=( BracketMorph newBounds: self totalSliderArea) horizontal: self bounds isWide; color: self thumbColor; borderStyle: (BorderStyle raised baseColor: Color white; width: 1). sliderShadow := (BracketMorph newBounds: self totalSliderArea) horizontal: self bounds isWide; color: self pagingArea color; borderStyle: (BorderStyle inset baseColor: (Color white alpha: 0.6); width: 1). slider on: #mouseMove send: #scrollAbsolute: to: self. slider on: #mouseDown send: #mouseDownInSlider: to: self. slider on: #mouseUp send: #mouseUpInSlider: to: self. "(the shadow must have the pagingArea as its owner to highlight properly)" self pagingArea addMorph: sliderShadow. sliderShadow hide. self addMorph: slider. self computeSlider. ! Item was changed: + ----- Method: BracketSliderMorph>>layoutBounds: (in category 'layout') ----- - ----- Method: BracketSliderMorph>>layoutBounds: (in category 'as yet unclassified') ----- layoutBounds: aRectangle "Set the bounds for laying out children of the receiver. Note: written so that #layoutBounds can be changed without touching this method" super layoutBounds: aRectangle. + self computeSlider! - self updateFillStyle. - slider horizontal: self bounds isWide. - sliderShadow horizontal: self bounds isWide! Item was added: + ----- Method: BracketSliderMorph>>minHeight (in category 'layout') ----- + minHeight + "Answer the receiver's minimum height. + Give it a bit of a chance..." + + ^8 max: super minHeight! Item was added: + ----- Method: BracketSliderMorph>>mouseDown: (in category 'event handling') ----- + mouseDown: anEvent + "Set the value directly." + + self enabled ifTrue: [ + self + scrollPoint: anEvent; + computeSlider]. + super mouseDown: anEvent. + self enabled ifFalse: [^self]. + anEvent hand newMouseFocus: slider event: anEvent. + slider + mouseEnter: anEvent copy; + mouseDown: anEvent copy + ! Item was added: + ----- Method: BracketSliderMorph>>mouseDownInSlider: (in category 'other events') ----- + mouseDownInSlider: event + "Ignore if disabled." + + self enabled ifFalse: [^self]. + ^super mouseDownInSlider: event! Item was changed: + ----- Method: BracketSliderMorph>>roomToMove (in category 'geometry') ----- - ----- Method: BracketSliderMorph>>roomToMove (in category 'as yet unclassified') ----- roomToMove "Allow to run off the edges a bit." ^self bounds isWide ifTrue: [self totalSliderArea insetBy: ((self sliderThickness // 2 at 0) negated corner: (self sliderThickness // 2 + 1)@0)] ifFalse: [self totalSliderArea insetBy: (0@(self sliderThickness // 2) negated corner: 0@(self sliderThickness // 2 - (self sliderThickness \\ 2) + 1))]! Item was added: + ----- Method: BracketSliderMorph>>scrollAbsolute: (in category 'scrolling') ----- + scrollAbsolute: event + "Ignore if disabled." + + self enabled ifFalse: [^self]. + ^super scrollAbsolute: event! Item was added: + ----- Method: BracketSliderMorph>>scrollPoint: (in category 'event handling') ----- + scrollPoint: event + "Scroll to the event position." + + | r p | + r := self roomToMove. + bounds isWide + ifTrue: [r width = 0 ifTrue: [^ self]] + ifFalse: [r height = 0 ifTrue: [^ self]]. + p := event position - (self sliderThickness // 2) adhereTo: r. + self descending + ifFalse: + [self setValue: (bounds isWide + ifTrue: [(p x - r left) asFloat / r width] + ifFalse: [(p y - r top) asFloat / r height])] + ifTrue: + [self setValue: (bounds isWide + ifTrue: [(r right - p x) asFloat / r width] + ifFalse: [(r bottom - p y) asFloat / r height])]! Item was changed: + ----- Method: BracketSliderMorph>>sliderColor: (in category 'accessing - ui') ----- - ----- Method: BracketSliderMorph>>sliderColor: (in category 'as yet unclassified') ----- sliderColor: newColor "Set the slider colour." super sliderColor: (self enabled ifTrue: [Color black] ifFalse: [self sliderShadowColor]). slider ifNotNil: [slider borderStyle baseColor: Color white]! Item was changed: + ----- Method: BracketSliderMorph>>sliderShadowColor (in category 'accessing - ui') ----- - ----- Method: BracketSliderMorph>>sliderShadowColor (in category 'as yet unclassified') ----- sliderShadowColor "Answer the color for the slider shadow." ^Color black alpha: 0.6! Item was changed: + ----- Method: BracketSliderMorph>>sliderThickness (in category 'geometry') ----- - ----- Method: BracketSliderMorph>>sliderThickness (in category 'as yet unclassified') ----- sliderThickness "Answer the thickness of the slider." ^((self bounds isWide ifTrue: [self height] ifFalse: [self width]) // 2 max: 8) // 2 * 2 + 1! Item was added: + ----- Method: BracketSliderMorph>>update: (in category 'updating') ----- + update: aSymbol + "Update the value." + + super update: aSymbol. + aSymbol == self getEnabledSelector ifTrue: [ + ^self updateEnabled].! Item was added: + ----- Method: BracketSliderMorph>>updateEnabled (in category 'testing') ----- + updateEnabled + "Update the enablement state." + + self model ifNotNil: [ + self getEnabledSelector ifNotNil: [ + self enabled: (self model perform: self getEnabledSelector)]]! Item was changed: + ----- Method: BracketSliderMorph>>updateFillStyle (in category 'initialization') ----- - ----- Method: BracketSliderMorph>>updateFillStyle (in category 'as yet unclassified') ----- updateFillStyle "Update the fill style directions." |b fs| fs := self fillStyle. fs isOrientedFill ifTrue: [ b := self innerBounds. fs origin: b topLeft. fs direction: (b isWide ifTrue: [b width at 0] ifFalse: [0 at b height])]! Item was removed: - Slider subclass: #PluggableSliderMorph - instanceVariableNames: 'getValueSelector getEnabledSelector enabled min max quantum' - classVariableNames: '' - poolDictionaries: '' - category: 'Morphic-Widgets'! - - !PluggableSliderMorph commentStamp: 'gvc 7/16/2007 13:57' prior: 0! - A pluggable slider (rather than one that auto-generates access selectors). Needs to be themed...! Item was removed: - ----- Method: PluggableSliderMorph class>>on:getValue:setValue: (in category 'as yet unclassified') ----- - on: anObject getValue: getSel setValue: setSel - "Answer a new instance of the receiver with - the given selectors as the interface." - - ^self new - on: anObject - getValue: getSel - setValue: setSel! Item was removed: - ----- Method: PluggableSliderMorph class>>on:getValue:setValue:min:max:quantum: (in category 'as yet unclassified') ----- - on: anObject getValue: getSel setValue: setSel min: min max: max quantum: quantum - "Answer a new instance of the receiver with - the given selectors as the interface." - - ^self new - min: min; - max: max; - quantum: quantum; - on: anObject - getValue: getSel - setValue: setSel! Item was removed: - ----- Method: PluggableSliderMorph>>adoptPaneColor: (in category 'as yet unclassified') ----- - adoptPaneColor: paneColor - "Pass on to the border too." - super adoptPaneColor: paneColor. - paneColor ifNil: [ ^ self ]. - self - fillStyle: self fillStyleToUse ; - borderStyle: - (BorderStyle inset - width: 1 ; - baseColor: self color twiceDarker) ; - sliderColor: - (self enabled - ifTrue: [ paneColor twiceDarker ] - ifFalse: [ self paneColor twiceDarker paler ])! Item was removed: - ----- Method: PluggableSliderMorph>>borderStyleToUse (in category 'as yet unclassified') ----- - borderStyleToUse - "Answer the borderStyle that should be used for the receiver." - - ^self enabled - ifTrue: [self theme sliderNormalBorderStyleFor: self] - ifFalse: [self theme sliderDisabledBorderStyleFor: self]! Item was removed: - ----- Method: PluggableSliderMorph>>defaultColor (in category 'as yet unclassified') ----- - defaultColor - "Answer the default color/fill style for the receiver." - - ^Color white! Item was removed: - ----- Method: PluggableSliderMorph>>disable (in category 'as yet unclassified') ----- - disable - "Disable the receiver." - - self enabled: false! Item was removed: - ----- Method: PluggableSliderMorph>>enable (in category 'as yet unclassified') ----- - enable - "Enable the receiver." - - self enabled: true! Item was removed: - ----- Method: PluggableSliderMorph>>enabled (in category 'accessing') ----- - enabled - "Answer the value of enabled" - - ^ enabled! Item was removed: - ----- Method: PluggableSliderMorph>>enabled: (in category 'accessing') ----- - enabled: anObject - "Set the value of enabled" - - enabled = anObject ifTrue: [^self]. - enabled := anObject. - self changed: #enabled. - self - adoptPaneColor: self color; - changed! Item was removed: - ----- Method: PluggableSliderMorph>>fillStyleToUse (in category 'as yet unclassified') ----- - fillStyleToUse - "Answer the fillStyle that should be used for the receiver." - - ^self enabled - ifTrue: [self theme sliderNormalFillStyleFor: self] - ifFalse: [self theme sliderDisabledFillStyleFor: self]! Item was removed: - ----- Method: PluggableSliderMorph>>getEnabledSelector (in category 'accessing') ----- - getEnabledSelector - "Answer the value of getEnabledSelector" - - ^ getEnabledSelector! Item was removed: - ----- Method: PluggableSliderMorph>>getEnabledSelector: (in category 'accessing') ----- - getEnabledSelector: aSymbol - "Set the value of getEnabledSelector" - - getEnabledSelector := aSymbol. - self updateEnabled! Item was removed: - ----- Method: PluggableSliderMorph>>getValueSelector (in category 'as yet unclassified') ----- - getValueSelector - "Answer the value of getValueSelector" - - ^ getValueSelector! Item was removed: - ----- Method: PluggableSliderMorph>>getValueSelector: (in category 'as yet unclassified') ----- - getValueSelector: anObject - "Set the value of getValueSelector" - - getValueSelector := anObject! Item was removed: - ----- Method: PluggableSliderMorph>>handlesMouseDown: (in category 'as yet unclassified') ----- - handlesMouseDown: evt - "Answer true." - - ^true! Item was removed: - ----- Method: PluggableSliderMorph>>initialize (in category 'as yet unclassified') ----- - initialize - "Initialize the receiver." - - min := 0. - max := 1. - super initialize. - self enabled: true! Item was removed: - ----- Method: PluggableSliderMorph>>initializeSlider (in category 'as yet unclassified') ----- - initializeSlider - "Make the slider raised." - - super initializeSlider. - slider borderStyle: (BorderStyle raised baseColor: slider color; width: 1)! Item was removed: - ----- Method: PluggableSliderMorph>>layoutBounds: (in category 'as yet unclassified') ----- - layoutBounds: aRectangle - "Set the bounds for laying out children of the receiver. - Note: written so that #layoutBounds can be changed without touching this method" - - super layoutBounds: aRectangle. - self computeSlider! Item was removed: - ----- Method: PluggableSliderMorph>>max (in category 'accessing') ----- - max - "Answer the value of max" - - ^ max! Item was removed: - ----- Method: PluggableSliderMorph>>max: (in category 'accessing') ----- - max: anObject - "Set the value of max" - - max := anObject. - self setValue: self value! Item was removed: - ----- Method: PluggableSliderMorph>>min (in category 'accessing') ----- - min - "Answer the value of min" - - ^ min! Item was removed: - ----- Method: PluggableSliderMorph>>min: (in category 'accessing') ----- - min: anObject - "Set the value of min" - - min := anObject. - self setValue: self value! Item was removed: - ----- Method: PluggableSliderMorph>>minHeight (in category 'as yet unclassified') ----- - minHeight - "Answer the receiver's minimum height. - Give it a bit of a chance..." - - ^8 max: super minHeight! Item was removed: - ----- Method: PluggableSliderMorph>>mouseDown: (in category 'as yet unclassified') ----- - mouseDown: anEvent - "Set the value directly." - - self enabled ifTrue: [ - self - scrollPoint: anEvent; - computeSlider]. - super mouseDown: anEvent. - self enabled ifFalse: [^self]. - anEvent hand newMouseFocus: slider event: anEvent. - slider - mouseEnter: anEvent copy; - mouseDown: anEvent copy - ! Item was removed: - ----- Method: PluggableSliderMorph>>mouseDownInSlider: (in category 'as yet unclassified') ----- - mouseDownInSlider: event - "Ignore if disabled." - - self enabled ifFalse: [^self]. - ^super mouseDownInSlider: event! Item was removed: - ----- Method: PluggableSliderMorph>>on:getValue:setValue: (in category 'as yet unclassified') ----- - on: anObject getValue: getSel setValue: setSel - "Use the given selectors as the interface." - - self - model: anObject; - getValueSelector: getSel; - setValueSelector: setSel; - updateValue! Item was removed: - ----- Method: PluggableSliderMorph>>quantum (in category 'accessing') ----- - quantum - "Answer the value of quantum" - - ^ quantum! Item was removed: - ----- Method: PluggableSliderMorph>>quantum: (in category 'accessing') ----- - quantum: anObject - "Set the value of quantum" - - quantum := anObject. - self setValue: self value! Item was removed: - ----- Method: PluggableSliderMorph>>scaledValue (in category 'as yet unclassified') ----- - scaledValue - "Answer the scaled value." - - |val| - val := self value * (self max - self min) + self min. - self quantum ifNotNil: [:q | - val := val roundTo: q]. - ^(val max: self min) min: self max! Item was removed: - ----- Method: PluggableSliderMorph>>scaledValue: (in category 'as yet unclassified') ----- - scaledValue: newValue - "Set the scaled value." - - |val| - val := newValue. - self quantum ifNotNil: [:q | - val := val roundTo: q]. - self value: newValue - self min / (self max - self min)! Item was removed: - ----- Method: PluggableSliderMorph>>scrollAbsolute: (in category 'as yet unclassified') ----- - scrollAbsolute: event - "Ignore if disabled." - - self enabled ifFalse: [^self]. - ^super scrollAbsolute: event! Item was removed: - ----- Method: PluggableSliderMorph>>scrollPoint: (in category 'as yet unclassified') ----- - scrollPoint: event - "Scroll to the event position." - - | r p | - r := self roomToMove. - bounds isWide - ifTrue: [r width = 0 ifTrue: [^ self]] - ifFalse: [r height = 0 ifTrue: [^ self]]. - p := event position - (self sliderThickness // 2) adhereTo: r. - self descending - ifFalse: - [self setValue: (bounds isWide - ifTrue: [(p x - r left) asFloat / r width] - ifFalse: [(p y - r top) asFloat / r height])] - ifTrue: - [self setValue: (bounds isWide - ifTrue: [(r right - p x) asFloat / r width] - ifFalse: [(r bottom - p y) asFloat / r height])]! Item was removed: - ----- Method: PluggableSliderMorph>>setValue: (in category 'as yet unclassified') ----- - setValue: newValue - "Called internally for propagation to model." - - |scaled| - value := newValue. - self scaledValue: (scaled := self scaledValue). - self model ifNotNil: [ - self setValueSelector ifNotNil: [:sel | - self model perform: sel with: scaled]]! Item was removed: - ----- Method: PluggableSliderMorph>>setValueSelector (in category 'as yet unclassified') ----- - setValueSelector - "Answer the set selector." - - ^setValueSelector! Item was removed: - ----- Method: PluggableSliderMorph>>setValueSelector: (in category 'as yet unclassified') ----- - setValueSelector: aSymbol - "Directly set the selector to make more flexible." - - setValueSelector := aSymbol! Item was removed: - ----- Method: PluggableSliderMorph>>sliderColor: (in category 'as yet unclassified') ----- - sliderColor: newColor - "Set the slider colour." - - super sliderColor: newColor. - slider ifNotNil: [slider borderStyle baseColor: newColor]! Item was removed: - ----- Method: PluggableSliderMorph>>update: (in category 'as yet unclassified') ----- - update: aSymbol - "Update the value." - - super update: aSymbol. - aSymbol == self getEnabledSelector ifTrue: [ - ^self updateEnabled]. - aSymbol = self getValueSelector ifTrue: [ - ^self updateValue]! Item was removed: - ----- Method: PluggableSliderMorph>>updateEnabled (in category 'as yet unclassified') ----- - updateEnabled - "Update the enablement state." - - self model ifNotNil: [ - self getEnabledSelector ifNotNil: [ - self enabled: (self model perform: self getEnabledSelector)]]! Item was removed: - ----- Method: PluggableSliderMorph>>updateValue (in category 'as yet unclassified') ----- - updateValue - "Update the value." - - self model ifNotNil: [ - self getValueSelector ifNotNil: [ - self scaledValue: (self model perform: self getValueSelector)]]! Item was changed: ----- Method: ScrollBar>>doScrollByPage (in category 'scrolling') ----- doScrollByPage "Scroll automatically while mouse is down" (self waitForDelay1: 300 delay2: 100) ifFalse: [^ self]. nextPageDirection + ifTrue: [self setValue: value + pageDelta] + ifFalse: [self setValue: value - pageDelta] - ifTrue: [self setValue: (value + pageDelta min: 1.0)] - ifFalse: [self setValue: (value - pageDelta max: 0.0)] ! Item was changed: ----- Method: ScrollBar>>doScrollDown (in category 'scrolling') ----- doScrollDown "Scroll automatically while mouse is down" (self waitForDelay1: 200 delay2: 40) ifFalse: [^ self]. + self setValue: value + scrollDelta.! - self setValue: (value + scrollDelta + 0.000001 min: 1.0)! Item was changed: ----- Method: ScrollBar>>doScrollUp (in category 'scrolling') ----- doScrollUp "Scroll automatically while mouse is down" (self waitForDelay1: 200 delay2: 40) ifFalse: [^ self]. + self setValue: value - scrollDelta.! - self setValue: (value - scrollDelta - 0.000001 max: 0.0)! Item was changed: ----- Method: ScrollBar>>initialize (in category 'initialize') ----- initialize + interval := 0.2. + super initialize. scrollDelta := 0.02. pageDelta := 0.2. self color: Color transparent. self class roundedScrollBarLook ifFalse: [self borderWidth: 0] ifTrue:[self borderStyle: ((BorderStyle complexFramed width: 2) "baseColor: Color gray")].! Item was changed: ----- Method: ScrollBar>>initializeSlider (in category 'initialize') ----- initializeSlider self initializeMenuButton; initializeUpButton; initializeDownButton; initializePagingArea. super initializeSlider. + self expandSlider. + self class roundedScrollBarLook ifTrue: [slider cornerStyle: #rounded. slider borderStyle: (BorderStyle complexRaised width: 3). sliderShadow cornerStyle: #rounded]. self sliderColor: self sliderColor! Item was added: + ----- Method: ScrollBar>>interval (in category 'access') ----- + interval + + ^ interval! Item was changed: ----- Method: ScrollBar>>mouseDownInSlider: (in category 'other events') ----- mouseDownInSlider: event + interval = self maximumValue ifTrue: - interval = 1.0 ifTrue: ["make the entire scrollable area visible if a full scrollbar is clicked on" self setValue: 0. self model hideOrShowScrollBars.]. " super mouseDownInSlider: event" ! Item was changed: ----- Method: ScrollBar>>scrollDown: (in category 'scrolling') ----- scrollDown: count + self setValue: value + (scrollDelta * count).! - self setValue: (value + (scrollDelta * count) + 0.000001 min: 1.0)! Item was changed: ----- Method: ScrollBar>>scrollUp: (in category 'scrolling') ----- scrollUp: count + self setValue: value - (scrollDelta * count).! - self setValue: (value - (scrollDelta * count) - 0.000001 max: 0.0)! Item was removed: - ----- Method: ScrollBar>>setValue: (in category 'model access') ----- - setValue: newValue - "Using roundTo: instead of truncateTo: ensures that scrollUp will scroll the same distance as scrollDown." - ^ super setValue: (newValue roundTo: scrollDelta)! Item was changed: MorphicModel subclass: #Slider + instanceVariableNames: 'slider value setValueSelector getValueSelector sliderShadow sliderColor descending minimumValue maximumValue quantum getMinimumValueSelector getMaximumValueSelector' - instanceVariableNames: 'slider value setValueSelector sliderShadow sliderColor descending' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Windows'! Item was added: + ----- Method: Slider class>>on:getValue:setValue: (in category 'instance creation') ----- + on: anObject getValue: getSel setValue: setSel + "Answer a new instance of the receiver with + the given selectors as the interface." + + ^self new + on: anObject + getValue: getSel + setValue: setSel! Item was added: + ----- Method: Slider class>>on:getValue:setValue:min:max:quantum: (in category 'instance creation') ----- + on: anObject getValue: getSel setValue: setSel min: min max: max quantum: quantum + "Answer a new instance of the receiver with + the given selectors as the interface." + + | instance | + instance := self new + quantum: quantum; + on: anObject + getValue: getSel + setValue: setSel. + min isSymbol + ifTrue: [instance getMinimumValueSelector: min] + ifFalse: [instance minimumValue: min]. + max isSymbol + ifTrue: [instance getMaximumValueSelector: max] + ifFalse: [instance maximumValue: max]. + ^ instance! Item was added: + ----- Method: Slider>>adoptPaneColor: (in category 'accessing - ui') ----- + adoptPaneColor: paneColor + + super adoptPaneColor: paneColor. + + paneColor ifNotNil: [:c | + self color: c. + self thumb color: c].! Item was changed: ----- Method: Slider>>computeSlider (in category 'geometry') ----- computeSlider + | r v | - | r | r := self roomToMove. + v := self maximumValue = self minimumValue + ifTrue: [0] + ifFalse: [(value - self minimumValue) / (self maximumValue - self minimumValue)]. self descending ifFalse: [slider position: (bounds isWide + ifTrue: [r topLeft + ((r width * v) asInteger @ 0)] + ifFalse: [r topLeft + (0 @ (r height * v) asInteger)])] - ifTrue: [r topLeft + ((r width * value) asInteger @ 0)] - ifFalse: [r topLeft + (0 @ (r height * value) asInteger)])] ifTrue: [slider position: (bounds isWide + ifTrue: [r bottomRight - ((r width * v) asInteger @ 0)] + ifFalse: [r bottomRight - ((0 @ (r height * v) asInteger))])]. - ifTrue: [r bottomRight - ((r width * value) asInteger @ 0)] - ifFalse: [r bottomRight - ((0 @ (r height * value) asInteger))])]. slider extent: self sliderExtent! Item was changed: + ----- Method: Slider>>descending (in category 'accessing') ----- - ----- Method: Slider>>descending (in category 'access') ----- descending + + ^ descending! - ^ descending == true! Item was changed: + ----- Method: Slider>>descending: (in category 'accessing') ----- - ----- Method: Slider>>descending: (in category 'access') ----- descending: aBoolean + descending := aBoolean. + self computeSlider.! - self value: value! Item was added: + ----- Method: Slider>>getMaximumValue (in category 'model access') ----- + getMaximumValue + + self getMaximumValueSelector ifNotNil: [:selector | + self maximumValue: (model perform: selector)]. + ^ self maximumValue! Item was added: + ----- Method: Slider>>getMaximumValueSelector (in category 'accessing - model') ----- + getMaximumValueSelector + + ^ getMaximumValueSelector! Item was added: + ----- Method: Slider>>getMaximumValueSelector: (in category 'accessing - model') ----- + getMaximumValueSelector: aSymbol + + getMaximumValueSelector := aSymbol.! Item was added: + ----- Method: Slider>>getMinimumValue (in category 'model access') ----- + getMinimumValue + + self getMinimumValueSelector ifNotNil: [:selector | + self minimumValue: (model perform: selector)]. + ^ self minimumValue! Item was added: + ----- Method: Slider>>getMinimumValueSelector (in category 'accessing - model') ----- + getMinimumValueSelector + + ^ getMinimumValueSelector! Item was added: + ----- Method: Slider>>getMinimumValueSelector: (in category 'accessing - model') ----- + getMinimumValueSelector: aSymbol + + getMinimumValueSelector := aSymbol.! Item was added: + ----- Method: Slider>>getValue (in category 'model access') ----- + getValue + "Updates internal value with model data if possible. Returns the updated value or the current one." + + self getValueSelector ifNotNil: [:selector | + self value: (model perform: selector)]. + ^ self value! Item was added: + ----- Method: Slider>>getValueSelector (in category 'accessing - model') ----- + getValueSelector + + ^ getValueSelector! Item was added: + ----- Method: Slider>>getValueSelector: (in category 'accessing - model') ----- + getValueSelector: aSymbol + + getValueSelector := aSymbol.! Item was added: + ----- Method: Slider>>maximumValue (in category 'accessing') ----- + maximumValue + + ^ maximumValue ifNil: [1.0]! Item was added: + ----- Method: Slider>>maximumValue: (in category 'accessing') ----- + maximumValue: aNumber + + maximumValue := aNumber. + self setValue: self value.! Item was added: + ----- Method: Slider>>minimumValue (in category 'accessing') ----- + minimumValue + ^ minimumValue ifNil: [0.0]! Item was added: + ----- Method: Slider>>minimumValue: (in category 'accessing') ----- + minimumValue: aNumber + + minimumValue := aNumber. + self setValue: self value.! Item was added: + ----- Method: Slider>>on:getValue:setValue: (in category 'initialization') ----- + on: anObject getValue: getSel setValue: setSel + + self + model: anObject; + getValueSelector: getSel; + setValueSelector: setSel; + getValue.! Item was changed: + ----- Method: Slider>>pagingArea (in category 'accessing - ui') ----- - ----- Method: Slider>>pagingArea (in category 'access') ----- pagingArea ^self! Item was added: + ----- Method: Slider>>quantum (in category 'accessing') ----- + quantum + + ^ quantum! Item was added: + ----- Method: Slider>>quantum: (in category 'accessing') ----- + quantum: aNumber + + quantum := aNumber. + self setValue: self value.! Item was changed: ----- Method: Slider>>scrollAbsolute: (in category 'scrolling') ----- scrollAbsolute: event | r p | r := self roomToMove. bounds isWide ifTrue: [r width = 0 ifTrue: [^ self]] ifFalse: [r height = 0 ifTrue: [^ self]]. p := event targetPoint adhereTo: r. self descending ifFalse: + [self setValueFraction: (bounds isWide - [self setValue: (bounds isWide ifTrue: [(p x - r left) asFloat / r width] ifFalse: [(p y - r top) asFloat / r height])] ifTrue: + [self setValueFraction: (bounds isWide - [self setValue: (bounds isWide ifTrue: [(r right - p x) asFloat / r width] ifFalse: [(r bottom - p y) asFloat / r height])]! Item was added: + ----- Method: Slider>>scrollBy: (in category 'scrolling') ----- + scrollBy: delta + + self setValue: self value + delta.! Item was changed: ----- Method: Slider>>setValue: (in category 'model access') ----- setValue: newValue + "Either changes the value directly or tries to go the loop through the model. See #update:." + + self setValueSelector ifNotNil: [:selector | + | trimmedValue | + trimmedValue := self trimmedValue: newValue. + "Only notify about changed values." + trimmedValue ~= self value ifTrue: [ + model perform: selector with: trimmedValue]]. + + (self setValueSelector isNil or: [self getValueSelector isNil]) + ifTrue: [self value: newValue].! - "Called internally for propagation to model" - self value: newValue. - self use: setValueSelector orMakeModelSelectorFor: 'Value:' - in: [:sel | setValueSelector := sel. model perform: sel with: value]! Item was added: + ----- Method: Slider>>setValueFraction: (in category 'support') ----- + setValueFraction: newValueFraction + + self setValue: (newValueFraction * (self maximumValue - self minimumValue)) + self minimumValue.! Item was added: + ----- Method: Slider>>setValueSelector (in category 'accessing - model') ----- + setValueSelector + + ^ setValueSelector! Item was added: + ----- Method: Slider>>setValueSelector: (in category 'accessing - model') ----- + setValueSelector: aSymbol + + setValueSelector := aSymbol.! Item was changed: + ----- Method: Slider>>sliderColor (in category 'accessing - ui') ----- - ----- Method: Slider>>sliderColor (in category 'access') ----- sliderColor "color scheme for the whole slider widget" sliderColor ifNil: [^ (color alphaMixed: 0.7 with: Color white) slightlyLighter]. ^ sliderColor! Item was changed: + ----- Method: Slider>>sliderColor: (in category 'accessing - ui') ----- - ----- Method: Slider>>sliderColor: (in category 'access') ----- sliderColor: newColor sliderColor := newColor. slider ifNotNil: [slider color: sliderColor]! Item was changed: + ----- Method: Slider>>sliderShadowColor (in category 'accessing - ui') ----- - ----- Method: Slider>>sliderShadowColor (in category 'access') ----- sliderShadowColor ^ self sliderColor alphaMixed: 0.2 with: self pagingArea color! Item was added: + ----- Method: Slider>>thumb (in category 'accessing - ui') ----- + thumb + + ^ slider! Item was changed: + ----- Method: Slider>>thumbColor (in category 'accessing - ui') ----- - ----- Method: Slider>>thumbColor (in category 'access') ----- thumbColor "Color of the draggable 'thumb'" ^ self sliderColor! Item was added: + ----- Method: Slider>>trimValue: (in category 'support') ----- + trimValue: aValue + + | trimmedValue | + trimmedValue := aValue min: self maximumValue max: self minimumValue. + self quantum ifNotNil: [:q | trimmedValue := trimmedValue roundTo: q]. + ^ trimmedValue + ! Item was added: + ----- Method: Slider>>trimmedValue: (in category 'support') ----- + trimmedValue: aValue + + | trimmedValue | + trimmedValue := aValue min: self maximumValue max: self minimumValue. + self quantum ifNotNil: [:q | trimmedValue := trimmedValue roundTo: q]. + ^ trimmedValue + ! Item was added: + ----- Method: Slider>>truncate (in category 'accessing') ----- + truncate + + ^ self quantum == 1! Item was added: + ----- Method: Slider>>truncate: (in category 'accessing') ----- + truncate: aBoolean + + self quantum: (aBoolean ifTrue: [1] ifFalse: [nil]).! Item was added: + ----- Method: Slider>>update: (in category 'updating') ----- + update: aSymbol + "Update the value." + + super update: aSymbol. + + aSymbol = self getValueSelector ifTrue: [self getValue. ^ self]. + aSymbol = self getMinimumValueSelector ifTrue: [self getMinimumValue. ^ self]. + aSymbol = self getMaximumValueSelector ifTrue: [self getMaximumValue. ^ self].! Item was changed: + ----- Method: Slider>>value (in category 'accessing') ----- - ----- Method: Slider>>value (in category 'access') ----- value + ^ value! Item was changed: + ----- Method: Slider>>value: (in category 'accessing') ----- - ----- Method: Slider>>value: (in category 'model access') ----- value: newValue + + | t | + t := self trimmedValue: newValue. + t = value ifTrue: [^ self]. + + value := t. + self computeSlider.! - "Drive the slider position externally..." - value := newValue min: 1.0 max: 0.0. - self computeSlider! Item was changed: + ----- Method: Slider>>wantsSlot (in category 'testing') ----- - ----- Method: Slider>>wantsSlot (in category 'access') ----- wantsSlot "For now do it the old way, until we sort this out" ^ true!
More information about the Squeak-dev mailing list |