The Trunk: Morphic-cmm.481.mcz
Locked
 
|
Chris Muller uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-cmm.481.mcz ==================== Summary ==================== Name: Morphic-cmm.481 Author: cmm Time: 4 December 2010, 3:45:10.134 pm UUID: b564a079-c058-403c-962a-91f4ef716434 Ancestors: Morphic-fbs.480 Introducing NewColorPickerMorph. To use, set "Use the new color-picker" preference to true. =============== Diff against Morphic-fbs.480 =============== Item was added: + BracketSliderMorph subclass: #AColorSelectorMorph + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-Widgets'! + + !AColorSelectorMorph commentStamp: 'gvc 5/18/2007 13:52' prior: 0! + ColorComponentSelector showing an alpha gradient over a hatched background.! Item was added: + ----- Method: AColorSelectorMorph>>color: (in category 'accessing') ----- + color: aColor + "Set the gradient colors." + + super color: aColor asNontranslucentColor. + self fillStyle: self defaultFillStyle! Item was added: + ----- Method: AColorSelectorMorph>>defaultFillStyle (in category 'as yet unclassified') ----- + defaultFillStyle + "Answer the hue gradient." + + ^(GradientFillStyle colors: {self color alpha: 0. self color}) + origin: self topLeft; + direction: (self bounds isWide + ifTrue: [self width@0] + ifFalse: [0@self height])! Item was added: + ----- Method: AColorSelectorMorph>>drawOn: (in category 'drawing') ----- + drawOn: aCanvas + "Draw a hatch pattern first." + aCanvas + fillRectangle: self innerBounds + fillStyle: (InfiniteForm with: ColorPresenterMorph hatchForm). + super drawOn: aCanvas! Item was added: + ----- Method: AColorSelectorMorph>>fillStyle: (in category 'visual properties') ----- + fillStyle: fillStyle + "If it is a color then override with gradient." + + fillStyle isColor + ifTrue: [self color: fillStyle] + ifFalse: [super fillStyle: fillStyle]! Item was added: + ----- Method: AColorSelectorMorph>>initialize (in category 'initialization') ----- + initialize + "Initialize the receiver." + + super initialize. + self + value: 1.0; + color: Color black! Item was added: + Morph subclass: #BracketMorph + instanceVariableNames: 'orientation' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-Widgets'! + + !BracketMorph commentStamp: 'gvc 5/18/2007 13:48' prior: 0! + Morph displaying opposing arrows.! Item was added: + ----- Method: BracketMorph>>drawOn: (in category 'drawing') ----- + drawOn: aCanvas + "Draw triangles at the edges." + + |r| + r := self horizontal + ifTrue: [self bounds insetBy: (2@1 corner: 2@1)] + ifFalse: [self bounds insetBy: (1@2 corner: 1@2)]. + aCanvas + drawPolygon: (self leftOrTopVertices: self bounds) + fillStyle: self borderColor; + drawPolygon: (self leftOrTopVertices: r) + fillStyle: self fillStyle; + drawPolygon: (self rightOrBottomVertices: self bounds) + fillStyle: self borderColor; + drawPolygon: (self rightOrBottomVertices: r) + fillStyle: self fillStyle! Item was added: + ----- Method: BracketMorph>>horizontal (in category 'accessing') ----- + horizontal + "Answer whether horizontal or vertical." + + ^self orientation == #horizontal! Item was added: + ----- Method: BracketMorph>>horizontal: (in category 'accessing') ----- + horizontal: aBoolean + "Set whether horizontal or vertical." + + ^self orientation: (aBoolean ifTrue: [#horizontal] ifFalse: [#vertical])! Item was added: + ----- Method: BracketMorph>>initialize (in category 'initialization') ----- + initialize + "Initialize the receiver." + + super initialize. + self + orientation: #horizontal! Item was added: + ----- Method: BracketMorph>>leftOrTopVertices: (in category 'geometry') ----- + leftOrTopVertices: r + "Answer the vertices for a left or top bracket in the given rectangle." + + ^self orientation == #vertical + ifTrue: [{r topLeft - (0@1). r left + (r height // 2 + (r height \\ 2))@(r center y - (r height + 1 \\ 2)). + r left + (r height // 2 + (r height \\ 2))@(r center y). r bottomLeft}] + ifFalse: [{r topLeft. (r center x - (r width + 1 \\ 2))@(r top + (r width // 2 + (r width \\ 2))). + r center x@(r top + (r width // 2 + (r width \\ 2))). r topRight}]! Item was added: + ----- Method: BracketMorph>>orientation (in category 'accessing') ----- + orientation + "Answer the value of orientation" + + ^ orientation! Item was added: + ----- Method: BracketMorph>>orientation: (in category 'accessing') ----- + orientation: anObject + "Set the value of orientation" + + orientation := anObject. + self changed! Item was added: + ----- Method: BracketMorph>>rightOrBottomVertices: (in category 'geometry') ----- + rightOrBottomVertices: r + "Answer the vertices for a right or bottom bracket in the given rectangle." + + ^self orientation == #vertical + ifTrue: [{r topRight - (0@1). r right - (r height // 2 + (r height \\ 2))@(r center y - (r height + 1 \\ 2)). + r right - (r height // 2 + (r height \\ 2))@(r center y). r bottomRight}] + ifFalse: [{(r center x)@(r bottom - 1 - (r width // 2 + (r width \\ 2))). + r center x @(r bottom - 1 - (r width // 2 + (r width \\ 2))). r bottomRight. r bottomLeft - (1@0)}]! Item was added: + 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>>defaultFillStyle (in category 'as yet unclassified') ----- + defaultFillStyle + "Answer the defauolt fill style." + + ^Color gray! Item was added: + ----- Method: BracketSliderMorph>>extent: (in category 'as yet unclassified') ----- + extent: aPoint + "Update the gradient directions." + + super extent: aPoint. + self updateFillStyle! Item was added: + ----- 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>>gradient (in category 'as yet unclassified') ----- + gradient + "Answer the gradient." + + self subclassResponsibility! Item was added: + ----- Method: BracketSliderMorph>>initialize (in category 'as yet unclassified') ----- + initialize + "Initialize the receiver." + + super initialize. + self + fillStyle: self defaultFillStyle; + borderStyle: (BorderStyle inset baseColor: self color; width: 1); + sliderColor: Color black; + clipSubmorphs: true! Item was added: + ----- 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 added: + ----- 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 updateFillStyle. + slider horizontal: self bounds isWide. + sliderShadow horizontal: self bounds isWide! Item was added: + ----- 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@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>>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 added: + ----- Method: BracketSliderMorph>>sliderShadowColor (in category 'as yet unclassified') ----- + sliderShadowColor + "Answer the color for the slider shadow." + + ^Color black alpha: 0.6! Item was added: + ----- 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>>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@0] + ifFalse: [0@b height])]! Item was added: + MorphicModel subclass: #ColorPresenterMorph + instanceVariableNames: 'contentMorph labelMorph solidLabelMorph getColorSelector' + classVariableNames: 'HatchForm' + poolDictionaries: '' + category: 'Morphic-Widgets'! + + !ColorPresenterMorph commentStamp: 'gvc 5/18/2007 13:38' prior: 0! + Displays a colour with alpha against a white, hatched and black background.! Item was added: + ----- Method: ColorPresenterMorph classSide>>hatchForm (in category 'graphics constants') ----- + hatchForm + "Answer a form showing a grid hatch pattern." + + ^HatchForm ifNil: [HatchForm := self newHatchForm]! Item was added: + ----- Method: ColorPresenterMorph classSide>>newHatchForm (in category 'graphics constants') ----- + newHatchForm + "Answer a new hatch form." + + ^(Form + extent: 8@8 + depth: 1 + fromArray: #( 4026531840 4026531840 4026531840 4026531840 251658240 251658240 251658240 251658240) + offset: 0@0)! Item was added: + ----- Method: ColorPresenterMorph classSide>>on:color: (in category 'instance creation') ----- + on: anObject color: getSel + "Answer a new instance of the receiver on the given model using + the given selectors as the interface." + + "(ColorPresenterMorph on: (BorderedMorph new) color: #color) openInWorld" + + ^self new + on: anObject + color: getSel! Item was added: + ----- Method: ColorPresenterMorph>>contentMorph (in category 'accessing') ----- + contentMorph + "The outer, containing Morph." + ^ contentMorph! Item was added: + ----- Method: ColorPresenterMorph>>contentMorph: (in category 'accessing') ----- + contentMorph: aMorph + "The outer, containing Morph." + contentMorph := aMorph! Item was added: + ----- Method: ColorPresenterMorph>>getColorSelector (in category 'accessing') ----- + getColorSelector + "The selector symbol used to retrieve the color from my model." + ^ getColorSelector! Item was added: + ----- Method: ColorPresenterMorph>>getColorSelector: (in category 'accessing') ----- + getColorSelector: aSymbol + "The selector symbol used to retrieve the color from my model." + getColorSelector := aSymbol! Item was added: + ----- Method: ColorPresenterMorph>>initialize (in category 'initializing') ----- + initialize + "Initialize the receiver." + + super initialize. + self + borderWidth: 0; + changeTableLayout; + labelMorph: self newLabelMorph; + solidLabelMorph: self newLabelMorph; + contentMorph: self newContentMorph; + addMorphBack: self contentMorph! Item was added: + ----- Method: ColorPresenterMorph>>labelMorph (in category 'accessing') ----- + labelMorph + "The morph that renders the actual color being presented." + ^ labelMorph! Item was added: + ----- Method: ColorPresenterMorph>>labelMorph: (in category 'accessing') ----- + labelMorph: aMorph + "The morph that renders the actual color being presented." + labelMorph := aMorph! Item was added: + ----- Method: ColorPresenterMorph>>newContentMorph (in category 'initializing') ----- + newContentMorph + "Answer a new content morph" + + ^Morph new + color: Color transparent; + changeTableLayout; + borderStyle: (BorderStyle inset width: 1); + vResizing: #spaceFill; + hResizing: #spaceFill; + addMorph: self newHatchMorph; + yourself! Item was added: + ----- Method: ColorPresenterMorph>>newHatchMorph (in category 'initializing') ----- + newHatchMorph + "Answer a new morph showing the three backgrounds; white, hatch pattern, and black, against which my labelMorph is displayed." + ^ Morph new + color: Color transparent ; + changeProportionalLayout ; + vResizing: #spaceFill ; + hResizing: #spaceFill ; + minWidth: 48 ; + minHeight: 12 ; + + addMorph: (Morph new color: Color white) + fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 0.3 @ 1)) ; + + addMorph: (Morph new fillStyle: (InfiniteForm with: self class hatchForm)) + fullFrame: (LayoutFrame fractions: (0.3 @ 0 corner: 0.7 @ 1)) ; + + addMorph: self solidLabelMorph + fullFrame: (LayoutFrame fractions: (0.7 @ 0 corner: 1 @ 1)) ; + + addMorph: self labelMorph + fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 1 @ 1))! Item was added: + ----- Method: ColorPresenterMorph>>newLabelMorph (in category 'initializing') ----- + newLabelMorph + "Answer a new label morph" + + ^Morph new! Item was added: + ----- Method: ColorPresenterMorph>>on:color: (in category 'initializing') ----- + on: anObject color: getColSel + "Set the receiver to the given model parameterized by the given message selectors." + + self + model: anObject; + getColorSelector: getColSel; + updateColor! Item was added: + ----- Method: ColorPresenterMorph>>setColor: (in category 'initializing') ----- + setColor: aColor + "Update the colour of the labels." + + self labelMorph color: aColor. + self solidLabelMorph color: aColor asNontranslucentColor! Item was added: + ----- Method: ColorPresenterMorph>>solidLabelMorph (in category 'accessing') ----- + solidLabelMorph + "Answer the value of solidLabelMorph" + + ^ solidLabelMorph! Item was added: + ----- Method: ColorPresenterMorph>>solidLabelMorph: (in category 'accessing') ----- + solidLabelMorph: anObject + "Set the value of solidLabelMorph" + + solidLabelMorph := anObject! Item was added: + ----- Method: ColorPresenterMorph>>update: (in category 'initializing') ----- + update: aSymbol + "Refer to the comment in View|update:." + + aSymbol == self getColorSelector ifTrue: + [self updateColor. + ^ self]! Item was added: + ----- Method: ColorPresenterMorph>>updateColor (in category 'initializing') ----- + updateColor + "Update the color state." + + |col| + self getColorSelector ifNotNil: [ + col := (self model perform: self getColorSelector) ifNil: [Color transparent]. + self setColor: col]! Item was changed: ----- Method: GradientFillStyle>>changeColorSelector:hand:morph:originalColor: (in category '*Morphic-Balloon') ----- + changeColorSelector: aSymbol hand: aHand morph: aMorph originalColor: originalColor - changeColorSelector: aSymbol hand: aHand morph: aMorph originalColor: originalColor "Change either the firstColor or the lastColor (depending on aSymbol). Put up a color picker to hande it. We always use a modal picker so that the user can adjust both colors concurrently." + NewColorPickerMorph useIt + ifTrue: + [ (NewColorPickerMorph + on: self + originalColor: originalColor + setColorSelector: aSymbol) openNear: aMorph fullBoundsInWorld ] + ifFalse: + [ ColorPickerMorph new + initializeModal: false ; + sourceHand: aHand ; + target: self ; + selector: aSymbol ; + argument: aMorph ; + originalColor: originalColor ; + + putUpFor: aMorph + near: aMorph fullBoundsInWorld ]! - - ColorPickerMorph new - initializeModal: false; - sourceHand: aHand; - target: self; - selector: aSymbol; - argument: aMorph; - originalColor: originalColor; - putUpFor: aMorph near: aMorph fullBoundsInWorld! Item was added: + BracketSliderMorph subclass: #HColorSelectorMorph + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-Widgets'! + + !HColorSelectorMorph commentStamp: 'gvc 5/18/2007 12:58' prior: 0! + ColorComponentSelector showing a hue rainbow palette.! Item was added: + ----- Method: HColorSelectorMorph>>color: (in category 'as yet unclassified') ----- + color: aColor + "Ignore to preserve fill style." + ! Item was added: + ----- Method: HColorSelectorMorph>>defaultFillStyle (in category 'as yet unclassified') ----- + defaultFillStyle + "Answer the hue gradient." + + ^(GradientFillStyle colors: ((0.0 to: 359.9 by: 0.1) collect: [:a | Color h: a s: 1.0 v: 1.0])) + origin: self topLeft; + direction: (self bounds isWide + ifTrue: [self width@0] + ifFalse: [0@self height])! Item was added: + Morph subclass: #HSVAColorSelectorMorph + instanceVariableNames: 'hsvMorph aMorph' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-Widgets'! + + !HSVAColorSelectorMorph commentStamp: 'gvc 5/18/2007 12:55' prior: 0! + Colour selector featuring a saturation/volume area, hue selection strip and alpha selection strip.! Item was added: + ----- Method: HSVAColorSelectorMorph>>aMorph (in category 'accessing') ----- + aMorph + "The alpha-selector morph." + ^ aMorph! Item was added: + ----- Method: HSVAColorSelectorMorph>>aMorph: (in category 'accessing') ----- + aMorph: anAColorSelectorMorph + "The alpha-selector morph." + aMorph := anAColorSelectorMorph! Item was added: + ----- Method: HSVAColorSelectorMorph>>alphaSelected: (in category 'as yet unclassified') ----- + alphaSelected: aFloat + "The alpha has changed." + + self triggerSelectedColor! Item was added: + ----- Method: HSVAColorSelectorMorph>>colorSelected: (in category 'as yet unclassified') ----- + colorSelected: aColor + "A color has been selected. Set the base color for the alpha channel." + + self aMorph color: aColor. + self triggerSelectedColor! Item was added: + ----- Method: HSVAColorSelectorMorph>>defaultColor (in category 'as yet unclassified') ----- + defaultColor + "Answer the default color/fill style for the receiver." + + ^Color transparent + ! Item was added: + ----- Method: HSVAColorSelectorMorph>>hsvMorph (in category 'accessing') ----- + hsvMorph + "Answer the value of hsvMorph" + + ^ hsvMorph! Item was added: + ----- Method: HSVAColorSelectorMorph>>hsvMorph: (in category 'accessing') ----- + hsvMorph: anObject + "Set the value of hsvMorph" + + hsvMorph := anObject! Item was added: + ----- Method: HSVAColorSelectorMorph>>initialize (in category 'as yet unclassified') ----- + initialize + "Initialize the receiver." + + super initialize. + self + extent: 180@168; + changeTableLayout; + cellInset: 4; + aMorph: self newAColorMorph; + hsvMorph: self newHSVColorMorph; + addMorphBack: self hsvMorph; + addMorphBack: self aMorph. + self aMorph color: self hsvMorph selectedColor! Item was added: + ----- Method: HSVAColorSelectorMorph>>newAColorMorph (in category 'as yet unclassified') ----- + newAColorMorph + "Answer a new alpha color morph." + + ^AColorSelectorMorph new + model: self; + hResizing: #spaceFill; + vResizing: #rigid; + setValueSelector: #alphaSelected:; + extent: 24@24! Item was added: + ----- Method: HSVAColorSelectorMorph>>newHSVColorMorph (in category 'as yet unclassified') ----- + newHSVColorMorph + "Answer a new hue/saturation/volume color morph." + + ^HSVColorSelectorMorph new + hResizing: #spaceFill; + vResizing: #spaceFill; + when: #colorSelected send: #colorSelected: to: self! Item was added: + ----- Method: HSVAColorSelectorMorph>>selectedColor (in category 'as yet unclassified') ----- + selectedColor + "Answer the selected color." + + ^self hsvMorph selectedColor alpha: self aMorph value! Item was added: + ----- Method: HSVAColorSelectorMorph>>selectedColor: (in category 'as yet unclassified') ----- + selectedColor: aColor + "Set the hue and sv components." + + self aMorph value: aColor alpha. + self hsvMorph selectedColor: aColor asNontranslucentColor! Item was added: + ----- Method: HSVAColorSelectorMorph>>triggerSelectedColor (in category 'as yet unclassified') ----- + triggerSelectedColor + "Trigger the event for the selected colour" + self + triggerEvent: #selectedColor + with: self selectedColor. + self changed: #selectedColor! Item was added: + Morph subclass: #HSVColorSelectorMorph + instanceVariableNames: 'svMorph hMorph' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-Widgets'! + + !HSVColorSelectorMorph commentStamp: 'gvc 5/18/2007 12:55' prior: 0! + Colour selector featuring a saturation/volume area and a hue selection strip.! Item was added: + ----- Method: HSVColorSelectorMorph>>colorSelected: (in category 'as yet unclassified') ----- + colorSelected: aColor + "A color has been selected. Make the hue match." + + "self hMorph value: aColor hue / 360. + self svMorph basicColor: (Color h: aColor hue s: 1.0 v: 1.0)." + self triggerEvent: #colorSelected with: aColor! Item was added: + ----- Method: HSVColorSelectorMorph>>defaultColor (in category 'as yet unclassified') ----- + defaultColor + "Answer the default color/fill style for the receiver." + + ^Color transparent + ! Item was added: + ----- Method: HSVColorSelectorMorph>>hMorph (in category 'accessing') ----- + hMorph + "Answer the value of hMorph" + + ^ hMorph! Item was added: + ----- Method: HSVColorSelectorMorph>>hMorph: (in category 'accessing') ----- + hMorph: anObject + "Set the value of hMorph" + + hMorph := anObject! Item was added: + ----- Method: HSVColorSelectorMorph>>hue: (in category 'as yet unclassified') ----- + hue: aFloat + "Set the hue in the range 0.0 - 1.0. Update the SV morph and hMorph." + + self hMorph value: aFloat. + self svMorph color: (Color h: aFloat * 359.9 s: 1.0 v: 1.0)! Item was added: + ----- Method: HSVColorSelectorMorph>>initialize (in category 'as yet unclassified') ----- + initialize + "Initialize the receiver." + + super initialize. + self + borderWidth: 0; + changeTableLayout; + cellInset: 4; + listDirection: #leftToRight; + cellPositioning: #topLeft; + svMorph: self newSVColorMorph; + hMorph: self newHColorMorph; + addMorphBack: self svMorph; + addMorphBack: self hMorph; + extent: 192@152; + hue: 0.5! Item was added: + ----- Method: HSVColorSelectorMorph>>newHColorMorph (in category 'as yet unclassified') ----- + newHColorMorph + "Answer a new hue color morph." + + ^HColorSelectorMorph new + model: self; + setValueSelector: #hue:; + hResizing: #rigid; + vResizing: #spaceFill; + extent: 36@36! Item was added: + ----- Method: HSVColorSelectorMorph>>newSVColorMorph (in category 'as yet unclassified') ----- + newSVColorMorph + "Answer a new saturation/volume color morph." + + ^SVColorSelectorMorph new + extent: 152@152; + hResizing: #spaceFill; + vResizing: #spaceFill; + when: #colorSelected send: #colorSelected: to: self! Item was added: + ----- Method: HSVColorSelectorMorph>>selectedColor (in category 'as yet unclassified') ----- + selectedColor + "Answer the selected color." + + ^self svMorph selectedColor! Item was added: + ----- Method: HSVColorSelectorMorph>>selectedColor: (in category 'as yet unclassified') ----- + selectedColor: aColor + "Set the hue and sv components." + + self hue: aColor hue / 360. + self svMorph selectedColor: aColor! Item was added: + ----- Method: HSVColorSelectorMorph>>svMorph (in category 'accessing') ----- + svMorph + "Answer the value of svMorph" + + ^ svMorph! Item was added: + ----- Method: HSVColorSelectorMorph>>svMorph: (in category 'accessing') ----- + svMorph: anObject + "Set the value of svMorph" + + svMorph := anObject! Item was changed: ----- Method: Morph>>changeColor (in category 'menus') ----- changeColor "Change the color of the receiver -- triggered, e.g. from a menu" + NewColorPickerMorph useIt + ifTrue: [ (NewColorPickerMorph on: self) openNear: self fullBoundsInWorld ] + ifFalse: + [ ColorPickerMorph new + choseModalityFromPreference ; + sourceHand: self activeHand ; + target: self ; + selector: #fillStyle: ; + originalColor: self color ; + + putUpFor: self + near: self fullBoundsInWorld ]! - - ColorPickerMorph new - choseModalityFromPreference; - sourceHand: self activeHand; - target: self; - selector: #fillStyle:; - originalColor: self color; - putUpFor: self near: self fullBoundsInWorld! Item was changed: ----- Method: Morph>>changeColorTarget:selector:originalColor:hand: (in category 'meta-actions') ----- + changeColorTarget: anObject selector: aSymbol originalColor: aColor hand: aHand - changeColorTarget: anObject selector: aSymbol originalColor: aColor hand: aHand "Put up a color picker for changing some kind of color. May be modal or modeless, depending on #modalColorPickers setting" + | desiredLoc | + self flag: #arNote. + "Simplify this due to anObject == self for almost all cases" + desiredLoc := anObject isMorph + ifTrue: + [ Rectangle + center: self position + extent: 20 ] + ifFalse: + [ anObject == self world + ifTrue: [ anObject viewBox bottomLeft + (20 @ -20) extent: 200 ] + ifFalse: [ anObject fullBoundsInWorld ] ]. + ^ NewColorPickerMorph useIt + ifTrue: + [ (NewColorPickerMorph + on: anObject + originalColor: aColor + setColorSelector: aSymbol) openNear: desiredLoc ] + ifFalse: + [ ColorPickerMorph new + choseModalityFromPreference ; + sourceHand: aHand ; + target: anObject ; + selector: aSymbol ; + originalColor: aColor ; + + putUpFor: anObject + near: desiredLoc ; + yourself ]! - self flag: #arNote. "Simplify this due to anObject == self for almost all cases" - ^ ColorPickerMorph new - choseModalityFromPreference; - sourceHand: aHand; - target: anObject; - selector: aSymbol; - originalColor: aColor; - putUpFor: anObject near: (anObject isMorph - ifTrue: [Rectangle center: self position extent: 20] - ifFalse: [anObject == self world - ifTrue: [anObject viewBox bottomLeft + (20@-20) extent: 200] - ifFalse: [anObject fullBoundsInWorld]]); - yourself! Item was changed: ----- Method: Morph>>changeShadowColor (in category 'drop shadows') ----- changeShadowColor "Change the shadow color of the receiver -- triggered, e.g. from a menu" + NewColorPickerMorph useIt + ifTrue: + [ (NewColorPickerMorph + on: self + originalColor: self shadowColor + setColorSelector: #shadowColor:) openNearMorph: self ] + ifFalse: + [ ColorPickerMorph new + choseModalityFromPreference ; + sourceHand: self activeHand ; + target: self ; + selector: #shadowColor: ; + originalColor: self shadowColor ; + + putUpFor: self + near: self fullBoundsInWorld ]! - - ColorPickerMorph new - choseModalityFromPreference; - sourceHand: self activeHand; - target: self; - selector: #shadowColor:; - originalColor: self shadowColor; - putUpFor: self near: self fullBoundsInWorld! Item was added: + ----- Method: Morph>>openNear: (in category 'initialization') ----- + openNear: aRectangle + self + openNear: aRectangle + in: World! Item was added: + ----- Method: Morph>>openNear:in: (in category 'initialization') ----- + openNear: aRectangle in: aWorld + | wb leftOverlap rightOverlap topOverlap bottomOverlap best | + wb := aWorld bounds. + self fullBounds. + leftOverlap := self width - (aRectangle left - wb left). + rightOverlap := self width - (wb right - aRectangle right). + topOverlap := self height - (aRectangle top - wb top). + bottomOverlap := self height - (wb bottom - aRectangle bottom). + best := nil. + { + {leftOverlap. #topRight:. #topLeft}. + {rightOverlap. #topLeft:. #topRight}. + {topOverlap. #bottomLeft:. #topLeft}. + {bottomOverlap. #topLeft:. #bottomLeft}. + } do: [ :tuple | + (best isNil or: [tuple first < best first]) ifTrue: [best := tuple]. + ]. + self perform: best second with: (aRectangle perform: best third). + self bottom: (self bottom min: wb bottom) rounded. + self right: (self right min: wb right) rounded. + self top: (self top max: wb top) rounded. + self left: (self left max: wb left) rounded. + self openInWorld: aWorld.! Item was added: + ----- Method: Morph>>openNearMorph: (in category 'initialization') ----- + openNearMorph: aMorph + self + openNear: aMorph boundsInWorld + in: (aMorph world ifNil: [ World ])! Item was added: + Morph subclass: #NewColorPickerMorph + instanceVariableNames: 'target setColorSelector hsvaMorph colorPresenter' + classVariableNames: 'UseIt' + poolDictionaries: '' + category: 'Morphic-Widgets'! + + !NewColorPickerMorph commentStamp: 'cmm 12/3/2010 13:36' prior: 0! + A NewColorPickerMorph is a new widget for choosing colors in Morphic. Instantiate a NewColorPickerMorph: + + (NewColorPickerMorph + on: objectToHaveItsColorSet + getColorSelector: itsColorGetterSymbol + setColorSelector: itsColorSetterSymbol) openInWorld + + ! Item was added: + ----- Method: NewColorPickerMorph classSide>>on: (in category 'create') ----- + on: anObject + ^ self + on: anObject + originalColor: anObject color + setColorSelector: #color:! Item was added: + ----- Method: NewColorPickerMorph classSide>>on:originalColor:setColorSelector: (in category 'create') ----- + on: objectToHaveItsColorSet originalColor: originalColor setColorSelector: colorSetterSymbol + ^ self new + setTarget: objectToHaveItsColorSet + originalColor: originalColor + setColorSelector: colorSetterSymbol! Item was added: + ----- Method: NewColorPickerMorph classSide>>useIt (in category 'accessing') ----- + useIt + <preference: 'Use the new color-picker' + category: 'colors' + description: 'When true, a newly-enhanced color-picker is used.' + type: #Boolean> + ^ UseIt ifNil: [ false ]! Item was added: + ----- Method: NewColorPickerMorph classSide>>useIt: (in category 'accessing') ----- + useIt: aBoolean + UseIt := aBoolean! Item was added: + ----- Method: NewColorPickerMorph>>closeButtonLabel (in category 'initialize-release') ----- + closeButtonLabel + ^ 'Close' translated! Item was added: + ----- Method: NewColorPickerMorph>>colorExpression (in category 'accessing') ----- + colorExpression + "A Smalltalk which can create this color." + ^ self selectedColor printString! Item was added: + ----- Method: NewColorPickerMorph>>colorExpression: (in category 'accessing') ----- + colorExpression: aString + "Set my color by evaluating aString, a Smalltalk expression which results in a Color instance." + | col | + {aString. + 'Color ' , aString} + detect: + [ : each | ([ col := Compiler evaluate: each ] + on: Error + do: + [ : err | nil ]) notNil ] + ifNone: [ nil ]. + col ifNotNil: [ self selectedColor: col ]! Item was added: + ----- Method: NewColorPickerMorph>>colorSelected: (in category 'model') ----- + colorSelected: aColor + self targetColor: aColor. + self changed: #colorExpression! Item was added: + ----- Method: NewColorPickerMorph>>initialize (in category 'initialize-release') ----- + initialize + super initialize. + self initializeHsvaMorph! Item was added: + ----- Method: NewColorPickerMorph>>initializeHsvaMorph (in category 'initialize-release') ----- + initializeHsvaMorph + hsvaMorph := HSVAColorSelectorMorph new + hResizing: #spaceFill ; + vResizing: #spaceFill ; + yourself. + hsvaMorph + when: #selectedColor + send: #colorSelected: + to: self! Item was added: + ----- Method: NewColorPickerMorph>>newBottomRow (in category 'initialize-release') ----- + newBottomRow + ^ Morph new + color: Color transparent ; + changeTableLayout ; + listDirection: #leftToRight ; + hResizing: #spaceFill; vResizing: #shrinkWrap ; + height: 20 ; + cellInset: 4 ; + addMorph: (StringMorph contents: 'Current selection:' translated) ; + addMorphBack: self newColorPresenterMorph ; + addMorphBack: self newCloseButton! Item was added: + ----- Method: NewColorPickerMorph>>newCloseButton (in category 'initialize-release') ----- + newCloseButton + ^ (PluggableButtonMorph + on: self + getState: nil + action: #delete + label: #closeButtonLabel) + vResizing: #spaceFill ; + yourself! Item was added: + ----- Method: NewColorPickerMorph>>newColorExpressionMorph (in category 'initialize-release') ----- + newColorExpressionMorph + | pluggable | + pluggable := (PluggableTextMorph + on: self + text: #colorExpression + accept: #colorExpression:) + hResizing: #spaceFill ; + vResizing: #rigid ; + height: 20 ; + acceptOnCR: true ; + retractableOrNot ; + yourself. + pluggable textMorph autoFit: false. + ^ pluggable! Item was added: + ----- Method: NewColorPickerMorph>>newColorPresenterMorph (in category 'initialize-release') ----- + newColorPresenterMorph + ^ (ColorPresenterMorph + on: hsvaMorph + color: #selectedColor) + vResizing: #rigid ; height: 20 ; + hResizing: #spaceFill ; + yourself! Item was added: + ----- Method: NewColorPickerMorph>>selectedColor (in category 'accessing') ----- + selectedColor + "The color selected." + ^ hsvaMorph selectedColor! Item was added: + ----- Method: NewColorPickerMorph>>selectedColor: (in category 'accessing') ----- + selectedColor: aColor + "The color selected." + hsvaMorph selectedColor: aColor! Item was added: + ----- Method: NewColorPickerMorph>>setColorSelector (in category 'model') ----- + setColorSelector + "Answer the value of setColorSelector" + + ^ setColorSelector! Item was added: + ----- Method: NewColorPickerMorph>>setTarget:originalColor:setColorSelector: (in category 'initialize-release') ----- + setTarget: objectToHaveItsColorSet originalColor: aColor setColorSelector: colorSetterSymbol + target := objectToHaveItsColorSet. + setColorSelector := colorSetterSymbol. + hsvaMorph selectedColor: aColor. + self setup! Item was added: + ----- Method: NewColorPickerMorph>>setup (in category 'initialize-release') ----- + setup + self + color: (Color white slightlyDarker alpha: 0.88) ; + cornerStyle: #rounded ; + changeTableLayout ; + hResizing: #rigid ; + vResizing: #rigid ; + extent: 240@240 ; + addMorphBack: hsvaMorph ; + addMorphBack: self newColorExpressionMorph ; + addMorphBack: self newBottomRow ; + layoutInset: 4 ; + cellInset: 0! Item was added: + ----- Method: NewColorPickerMorph>>target (in category 'model') ----- + target + "Answer the object whose color will be controlled." + ^ target! Item was added: + ----- Method: NewColorPickerMorph>>targetColor: (in category 'accessing') ----- + targetColor: aColor + "The color of my target." + target ifNotNil: + [ target + perform: setColorSelector + with: aColor ]! Item was added: + 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 added: + ----- Method: PluggableSliderMorph classSide>>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 added: + ----- Method: PluggableSliderMorph classSide>>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 added: + ----- 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 added: + ----- 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 added: + ----- Method: PluggableSliderMorph>>defaultColor (in category 'as yet unclassified') ----- + defaultColor + "Answer the default color/fill style for the receiver." + + ^Color white! Item was added: + ----- Method: PluggableSliderMorph>>disable (in category 'as yet unclassified') ----- + disable + "Disable the receiver." + + self enabled: false! Item was added: + ----- Method: PluggableSliderMorph>>enable (in category 'as yet unclassified') ----- + enable + "Enable the receiver." + + self enabled: true! Item was added: + ----- Method: PluggableSliderMorph>>enabled (in category 'accessing') ----- + enabled + "Answer the value of enabled" + + ^ enabled! Item was added: + ----- 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 added: + ----- 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 added: + ----- Method: PluggableSliderMorph>>getEnabledSelector (in category 'accessing') ----- + getEnabledSelector + "Answer the value of getEnabledSelector" + + ^ getEnabledSelector! Item was added: + ----- Method: PluggableSliderMorph>>getEnabledSelector: (in category 'accessing') ----- + getEnabledSelector: aSymbol + "Set the value of getEnabledSelector" + + getEnabledSelector := aSymbol. + self updateEnabled! Item was added: + ----- Method: PluggableSliderMorph>>getValueSelector (in category 'as yet unclassified') ----- + getValueSelector + "Answer the value of getValueSelector" + + ^ getValueSelector! Item was added: + ----- Method: PluggableSliderMorph>>getValueSelector: (in category 'as yet unclassified') ----- + getValueSelector: anObject + "Set the value of getValueSelector" + + getValueSelector := anObject! Item was added: + ----- Method: PluggableSliderMorph>>handlesMouseDown: (in category 'as yet unclassified') ----- + handlesMouseDown: evt + "Answer true." + + ^true! Item was added: + ----- Method: PluggableSliderMorph>>initialize (in category 'as yet unclassified') ----- + initialize + "Initialize the receiver." + + min := 0. + max := 1. + super initialize. + self enabled: true! Item was added: + ----- 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 added: + ----- 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 added: + ----- Method: PluggableSliderMorph>>max (in category 'accessing') ----- + max + "Answer the value of max" + + ^ max! Item was added: + ----- Method: PluggableSliderMorph>>max: (in category 'accessing') ----- + max: anObject + "Set the value of max" + + max := anObject. + self setValue: self value! Item was added: + ----- Method: PluggableSliderMorph>>min (in category 'accessing') ----- + min + "Answer the value of min" + + ^ min! Item was added: + ----- Method: PluggableSliderMorph>>min: (in category 'accessing') ----- + min: anObject + "Set the value of min" + + min := anObject. + self setValue: self value! Item was added: + ----- 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 added: + ----- 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 added: + ----- Method: PluggableSliderMorph>>mouseDownInSlider: (in category 'as yet unclassified') ----- + mouseDownInSlider: event + "Ignore if disabled." + + self enabled ifFalse: [^self]. + ^super mouseDownInSlider: event! Item was added: + ----- 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 added: + ----- Method: PluggableSliderMorph>>quantum (in category 'accessing') ----- + quantum + "Answer the value of quantum" + + ^ quantum! Item was added: + ----- Method: PluggableSliderMorph>>quantum: (in category 'accessing') ----- + quantum: anObject + "Set the value of quantum" + + quantum := anObject. + self setValue: self value! Item was added: + ----- 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 added: + ----- 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 added: + ----- Method: PluggableSliderMorph>>scrollAbsolute: (in category 'as yet unclassified') ----- + scrollAbsolute: event + "Ignore if disabled." + + self enabled ifFalse: [^self]. + ^super scrollAbsolute: event! Item was added: + ----- 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 added: + ----- 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 added: + ----- Method: PluggableSliderMorph>>setValueSelector (in category 'as yet unclassified') ----- + setValueSelector + "Answer the set selector." + + ^setValueSelector! Item was added: + ----- Method: PluggableSliderMorph>>setValueSelector: (in category 'as yet unclassified') ----- + setValueSelector: aSymbol + "Directly set the selector to make more flexible." + + setValueSelector := aSymbol! Item was added: + ----- 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 added: + ----- 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 added: + ----- 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 added: + ----- 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 added: + Morph subclass: #SVColorSelectorMorph + instanceVariableNames: 'selectedColor locationMorph' + classVariableNames: '' + poolDictionaries: '' + category: 'Morphic-Widgets'! + + !SVColorSelectorMorph commentStamp: 'gvc 8/8/2007 14:36' prior: 0! + A colour selector that displays an area with saturation on the x axis and volume on the y axis. Provides interactive selection of colour by mouse. For the moment it is event rather than model based. + Setting the color will specify the hue and setting the selectedColor will specify the saturation and volume (may have a different hue to that displayed if not in sync).! Item was added: + ----- Method: SVColorSelectorMorph>>adoptPaneColor: (in category 'as yet unclassified') ----- + adoptPaneColor: paneColor + "Pass on to the border too." + + super adoptPaneColor: paneColor. + self borderStyle baseColor: paneColor twiceDarker! Item was added: + ----- Method: SVColorSelectorMorph>>basicColor: (in category 'as yet unclassified') ----- + basicColor: aColor + "Set the gradient colors." + + super color: aColor asNontranslucentColor. + self + fillStyle: self gradient! Item was added: + ----- Method: SVColorSelectorMorph>>blackGradient (in category 'as yet unclassified') ----- + blackGradient + "Answer the black gradient. Top to bottom, transparent to black." + + ^(InterpolatedGradientFillStyle colors: {Color black alpha: 0. Color black}) + origin: self innerBounds topLeft; + direction: 0@self innerBounds height! Item was added: + ----- Method: SVColorSelectorMorph>>blackGradientMorph (in category 'as yet unclassified') ----- + blackGradientMorph + "Answer the black gradient morph." + + ^Morph new + hResizing: #spaceFill; + vResizing: #spaceFill; + fillStyle: self blackGradient! Item was added: + ----- Method: SVColorSelectorMorph>>borderWidth: (in category 'as yet unclassified') ----- + borderWidth: anInteger + "Update the gradients after setting." + + super borderWidth: anInteger. + self updateGradients! Item was added: + ----- Method: SVColorSelectorMorph>>color: (in category 'as yet unclassified') ----- + color: aColor + "Set the gradient colors." + + self + basicColor: aColor; + selectedColor: (Color h: aColor hue s: self selectedColor saturation v: self selectedColor brightness)! Item was added: + ----- Method: SVColorSelectorMorph>>colorAt: (in category 'as yet unclassified') ----- + colorAt: aPoint + "Answer the color in the world at the given point." + + ^self isInWorld + ifTrue: [(Display colorAt: aPoint) asNontranslucentColor ] + ifFalse: [Color black]! Item was added: + ----- Method: SVColorSelectorMorph>>extent: (in category 'as yet unclassified') ----- + extent: p + "Update the gradient directions." + + super extent: p. + self updateGradients! Item was added: + ----- Method: SVColorSelectorMorph>>fillStyle: (in category 'as yet unclassified') ----- + fillStyle: fillStyle + "If it is a color then override with gradient." + + fillStyle isColor + ifTrue: [self color: fillStyle] + ifFalse: [super fillStyle: fillStyle]! Item was added: + ----- Method: SVColorSelectorMorph>>gradient (in category 'as yet unclassified') ----- + gradient + "Answer the base gradient." + + |b| + b := self innerBounds. + ^(GradientFillStyle colors: {Color white. self color}) + origin: b topLeft; + direction: (b width@0)! Item was added: + ----- Method: SVColorSelectorMorph>>handlesMouseDown: (in category 'as yet unclassified') ----- + handlesMouseDown: evt + "Yes for down and move.." + + ^true! Item was added: + ----- Method: SVColorSelectorMorph>>handlesMouseOverDragging: (in category 'as yet unclassified') ----- + handlesMouseOverDragging: evt + "Yes, make the location morph visible when leaving." + + ^true! Item was added: + ----- Method: SVColorSelectorMorph>>hideLocation (in category 'as yet unclassified') ----- + hideLocation + "Hide the location morph and update the display." + + self locationMorph visible: false. + World displayWorldSafely.! Item was added: + ----- Method: SVColorSelectorMorph>>initialize (in category 'as yet unclassified') ----- + initialize + "Initialize the receiver." + + super initialize. + self locationMorph: self newLocationMorph. + self + clipSubmorphs: true; + color: Color blue; + borderStyle: (BorderStyle inset width: 1); + addMorphBack: self locationMorph; + addMorphBack: self blackGradientMorph! Item was added: + ----- Method: SVColorSelectorMorph>>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 updateGradients! Item was added: + ----- Method: SVColorSelectorMorph>>locationMorph (in category 'accessing') ----- + locationMorph + "Answer the value of locationMorph" + + ^ locationMorph! Item was added: + ----- Method: SVColorSelectorMorph>>locationMorph: (in category 'accessing') ----- + locationMorph: anObject + "Set the value of locationMorph" + + locationMorph := anObject! Item was added: + ----- Method: SVColorSelectorMorph>>mouseDown: (in category 'as yet unclassified') ----- + mouseDown: evt + "Handle a mouse down event. Select the color at the mouse position." + + evt redButtonPressed + ifFalse: [^super mouseDown: evt]. + evt hand showTemporaryCursor: (Cursor crossHair copy offset: -9 @ -9). + self hideLocation. + self selectColorAt: evt position. + ^super mouseDown: evt! Item was added: + ----- Method: SVColorSelectorMorph>>mouseEnterDragging: (in category 'as yet unclassified') ----- + mouseEnterDragging: evt + "Make the location morph invisible when entering." + + self hideLocation. + evt hand showTemporaryCursor: (Cursor crossHair copy offset: -9 @ -9).! Item was added: + ----- Method: SVColorSelectorMorph>>mouseLeaveDragging: (in category 'as yet unclassified') ----- + mouseLeaveDragging: evt + "Make the location morph visible when leaving." + + evt hand showTemporaryCursor: nil. + self showLocation! Item was added: + ----- Method: SVColorSelectorMorph>>mouseMove: (in category 'as yet unclassified') ----- + mouseMove: evt + "Handle a mouse move event. Select the color at the mouse position." + + evt redButtonPressed + ifFalse: [^super mouseMove: evt]. + self selectColorAt: evt position. + ^super mouseMove: evt! Item was added: + ----- Method: SVColorSelectorMorph>>mouseUp: (in category 'as yet unclassified') ----- + mouseUp: evt + "Handle a up event. Show the location morph again." + + evt hand showTemporaryCursor: nil. + self updateSelectedLocation. + self locationMorph visible: true! Item was added: + ----- Method: SVColorSelectorMorph>>newLocationMorph (in category 'as yet unclassified') ----- + newLocationMorph + "Answer a new morph indicating the location of the selected color." + + ^ImageMorph new + image: Cursor crossHair withMask asCursorForm! Item was added: + ----- Method: SVColorSelectorMorph>>selectColorAt: (in category 'as yet unclassified') ----- + selectColorAt: aPoint + "Set the color at the given position." + + |b p| + b := self innerBounds. + p := (b containsPoint: aPoint) + ifTrue: [aPoint] + ifFalse: [b pointNearestTo: aPoint]. + p := p - b topLeft / b extent. + self selectedColor: (Color + h: self color hue + s: p x + v: 1.0 - p y)! Item was added: + ----- Method: SVColorSelectorMorph>>selectedColor (in category 'accessing') ----- + selectedColor + "Answer the value of selectedColor" + + ^selectedColor ifNil: [self color]! Item was added: + ----- Method: SVColorSelectorMorph>>selectedColor: (in category 'accessing') ----- + selectedColor: aColor + "Set the value of selectedColor." + + selectedColor := aColor. + self locationMorph visible ifTrue: [self updateSelectedLocation]. + self triggerEvent: #colorSelected with: aColor! Item was added: + ----- Method: SVColorSelectorMorph>>selectedLocation (in category 'as yet unclassified') ----- + selectedLocation + "Answer the location within the receiver of the selected colour + relative to the receiver's top left." + + |b c x y| + b := self innerBounds. + c := self selectedColor. + x := c saturation * (b width - 1). + y := 1 - c brightness * (b height - 1). + ^(x truncated @ y truncated) + b topLeft! Item was added: + ----- Method: SVColorSelectorMorph>>showLocation (in category 'as yet unclassified') ----- + showLocation + "Show the location morph and update the display." + + self locationMorph visible: true. + World displayWorldSafely.! Item was added: + ----- Method: SVColorSelectorMorph>>updateGradients (in category 'as yet unclassified') ----- + updateGradients + "Update the gradient directions." + + |bgm b| + b := self innerBounds. + bgm := self submorphs last. + bgm bounds: b. + bgm fillStyle + origin: b topLeft; + direction: 0@b height. + self fillStyle + origin: b topLeft; + direction: (b width@0). + self updateSelectedLocation! Item was added: + ----- Method: SVColorSelectorMorph>>updateSelectedLocation (in category 'as yet unclassified') ----- + updateSelectedLocation + "Position the location morph to indicate the selected colour." + + self locationMorph + position: (self selectedLocation - (self locationMorph extent // 2 + (self locationMorph extent \\ 2)))! Item was changed: ----- Method: SystemWindow>>changeColor (in category 'menu') ----- changeColor "Change the color of the receiver -- triggered, e.g. from a menu. This variant allows the recolor triggered from the window's halo recolor handle to have the same result as choosing change-window-color from the window-title menu" + NewColorPickerMorph useIt + ifTrue: + [ (NewColorPickerMorph + on: self + originalColor: self color + setColorSelector: #setWindowColor:) openNear: self fullBoundsInWorld ] + ifFalse: + [ ColorPickerMorph new + choseModalityFromPreference ; + sourceHand: self activeHand ; + target: self ; + selector: #setWindowColor: ; + originalColor: self color ; + + putUpFor: self + near: self fullBoundsInWorld ]! - - ColorPickerMorph new - choseModalityFromPreference; - sourceHand: self activeHand; - target: self; - selector: #setWindowColor:; - originalColor: self color; - putUpFor: self near: self fullBoundsInWorld! Item was changed: ----- Method: SystemWindow>>setWindowColor (in category 'menu') ----- setWindowColor "Allow the user to select a new basic color for the window" + NewColorPickerMorph useIt + ifTrue: + [ (NewColorPickerMorph + on: self + originalColor: self paneColorToUse + setColorSelector: #setWindowColor:) openNear: self fullBounds ] + ifFalse: + [ ColorPickerMorph new + choseModalityFromPreference ; + sourceHand: self activeHand ; + target: self ; + selector: #setWindowColor: ; + originalColor: self paneColorToUse ; + + putUpFor: self + near: self fullBounds ]! - - ColorPickerMorph new - choseModalityFromPreference; - sourceHand: self activeHand; - target: self; - selector: #setWindowColor:; - originalColor: self paneColorToUse; - putUpFor: self - near: self fullBounds! Item was changed: ----- Method: TextEditor>>chooseColor (in category 'editing keys') ----- chooseColor "Make a new Text Color Attribute, let the user pick a color, and return the attribute" - | attribute | + attribute := TextColor color: Color black. + NewColorPickerMorph useIt + ifTrue: + [ (NewColorPickerMorph on: attribute) openNear: morph fullBoundsInWorld ] + ifFalse: + [ ColorPickerMorph new + choseModalityFromPreference ; + sourceHand: morph activeHand ; + target: attribute ; + selector: #color: ; + originalColor: Color black ; + + putUpFor: morph + near: morph fullBoundsInWorld ]. + ^ attribute! - (ColorPickerMorph new) - choseModalityFromPreference; - sourceHand: morph activeHand; - target: (attribute := TextColor color: Color black); - selector: #color:; - originalColor: Color black; - putUpFor: morph near: morph fullBoundsInWorld. "default" - ^attribute! Item was changed: ----- Method: TextMorphEditor>>chooseColor (in category 'editing keys') ----- chooseColor | attribute | + attribute := TextColor color: Color black. "default" "Make a new Text Color Attribute, let the user pick a color, and return the attribute" + NewColorPickerMorph useIt + ifTrue: [ (NewColorPickerMorph on: attribute) openNear: morph fullBoundsInWorld ] + ifFalse: + [ ColorPickerMorph new + choseModalityFromPreference ; + sourceHand: morph activeHand ; + target: attribute ; + selector: #color: ; + originalColor: Color black ; + + putUpFor: morph + near: morph fullBoundsInWorld ]. + ^ attribute! - - ColorPickerMorph new - choseModalityFromPreference; - sourceHand: morph activeHand; - target: (attribute := TextColor color: Color black "default"); - selector: #color:; - originalColor: Color black; - putUpFor: morph near: morph fullBoundsInWorld. - ^ attribute - ! |
«
Return to Squeak - Dev
|
1 view|%1 views
| Free forum by Nabble | Edit this page |