"
COPYRIGHT (c) 1995 by eXept Software AG
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
"{ Package: 'stx:libtool2' }"
SimpleDialog subclass:#ColorEditDialog
instanceVariableNames:'red green blue hue light saturation colorNameHolder
htmlColorNameHolder previewBox'
classVariableNames:''
poolDictionaries:''
category:'Interface-UIPainter'
!
!ColorEditDialog class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1995 by eXept Software AG
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
!
documentation
"
An edit-dialog for colors.
"
!
examples
"
[exBegin]
|editor color|
editor := ColorEditDialog new.
editor color:(Color green).
editor open.
editor accepted ifTrue:[
editor color inspect.
]
[exEnd]
"
! !
!ColorEditDialog class methodsFor:'help specs'!
flyByHelpSpec
"This resource specification was automatically generated
by the UIHelpTool of ST/X."
"Do not manually edit this!! If it is corrupted,
the UIHelpTool may not be able to read the specification."
"
UIHelpTool openOnClass:ColorEditDialog
"
<resource: #help>
^ super flyByHelpSpec addPairsFrom:#(
#pickColor
'Pick a Color from the Screen'
)
!
helpSpec
"This resource specification was automatically generated
by the UIHelpTool of ST/X."
"Do not manually edit this!! If it is corrupted,
the UIHelpTool may not be able to read the specification."
"
UIHelpTool openOnClass:ColorEditDialog
"
<resource: #help>
^ super helpSpec addPairsFrom:#(
#copyToClipboard
'Copy the color to the clipboard'
#hlsMixer
'Mix color from hls (hue-light-saturation) components'
#pasteFromClipboard
'Paste color from the Clipboard'
#rgbMixer
'Mix color from rgb (red-green-blue) components'
)
! !
!ColorEditDialog class methodsFor:'image specs'!
pickColorIcon
^ ToolbarIconLibrary pipette16x16Icon
! !
!ColorEditDialog class methodsFor:'interface specs'!
windowSpec
"This resource specification was automatically generated
by the UIPainter of ST/X."
"Do not manually edit this!! If it is corrupted,
the UIPainter may not be able to read the specification."
"
UIPainter new openOnClass:ColorEditDialog andSelector:#windowSpec
ColorEditDialog new openInterface:#windowSpec
ColorEditDialog open
"
<resource: #canvas>
^
#(FullSpec
name: windowSpec
window:
(WindowSpec
label: 'Define Color'
name: 'Define Color'
min: (Point 440 300)
max: (Point 440 300)
bounds: (Rectangle 0 0 440 300)
)
component:
(SpecCollection
collection: (
(VerticalPanelViewSpec
name: 'RGBLabelPanel'
layout: (LayoutFrame 0 0 0 0 70 0 76 0)
horizontalLayout: fit
verticalLayout: spreadSpace
horizontalSpace: 3
verticalSpace: 3
component:
(SpecCollection
collection: (
(LabelSpec
label: 'Red:'
name: 'RedLabel'
translateLabel: true
adjust: right
useDefaultExtent: true
)
(LabelSpec
label: 'Green:'
name: 'GreenLabel'
translateLabel: true
adjust: right
useDefaultExtent: true
)
(LabelSpec
label: 'Blue:'
name: 'BlueLabel'
translateLabel: true
adjust: right
useDefaultExtent: true
)
)
)
)
(VerticalPanelViewSpec
name: 'RGBSliderPanel'
layout: (LayoutFrame 70 0 0 0 -177 1 76 0)
horizontalLayout: fit
verticalLayout: spreadSpace
horizontalSpace: 3
verticalSpace: 3
component:
(SpecCollection
collection: (
(SliderSpec
name: 'RedSlider'
tabable: false
model: red
orientation: horizontal
stop: 255
step: 1
backgroundColor: (Color 100.0 0.0 0.0)
extent: (Point 193 16)
)
(SliderSpec
name: 'GreenSlider'
tabable: false
model: green
orientation: horizontal
stop: 255
step: 1
backgroundColor: (Color 0.0 100.0 0.0)
extent: (Point 193 16)
)
(SliderSpec
name: 'BlueSlider'
tabable: false
model: blue
orientation: horizontal
stop: 255
step: 1
backgroundColor: (Color 0.0 0.0 100.0)
extent: (Point 193 16)
)
)
)
)
(VerticalPanelViewSpec
name: 'RGBFieldPanel'
layout: (LayoutFrame -173 1 0 0 -143 1 76 0)
horizontalLayout: fit
verticalLayout: spreadSpace
horizontalSpace: 3
verticalSpace: 3
component:
(SpecCollection
collection: (
(InputFieldSpec
name: 'RedField'
model: red
type: numberInRange
numChars: 3
minValue: 0
maxValue: 255
acceptOnPointerLeave: false
extent: (Point 30 20)
)
(InputFieldSpec
name: 'GreenField'
model: green
type: numberInRange
numChars: 3
minValue: 0
maxValue: 255
acceptOnPointerLeave: false
extent: (Point 30 20)
)
(InputFieldSpec
name: 'BlueField'
model: blue
type: numberInRange
numChars: 3
minValue: 0
maxValue: 255
acceptOnPointerLeave: false
extent: (Point 30 20)
)
)
)
)
(VerticalPanelViewSpec
name: 'RGBFieldPanelHex'
layout: (LayoutFrame -141 1 0 0 -119 1 76 0)
horizontalLayout: fit
verticalLayout: spreadSpace
horizontalSpace: 3
verticalSpace: 3
component:
(SpecCollection
collection: (
(InputFieldSpec
name: 'EntryField4'
model: red
type: hexIntegerInRange
numChars: 3
minValue: 0
maxValue: 255
acceptOnPointerLeave: false
extent: (Point 22 20)
)
(InputFieldSpec
name: 'EntryField5'
model: green
type: hexIntegerInRange
numChars: 3
minValue: 0
maxValue: 255
acceptOnPointerLeave: false
extent: (Point 22 20)
)
(InputFieldSpec
name: 'EntryField6'
model: blue
type: hexIntegerInRange
numChars: 3
minValue: 0
maxValue: 255
acceptOnPointerLeave: false
extent: (Point 22 20)
)
)
)
)
(VerticalPanelViewSpec
name: 'HLSLabelPanel'
layout: (LayoutFrame 0 0 86 0 70 0 163 0)
horizontalLayout: fit
verticalLayout: spreadSpace
horizontalSpace: 3
verticalSpace: 3
component:
(SpecCollection
collection: (
(LabelSpec
label: 'Hue:'
name: 'Label1'
translateLabel: true
adjust: right
useDefaultExtent: true
)
(LabelSpec
label: 'Light:'
name: 'Label2'
translateLabel: true
adjust: right
useDefaultExtent: true
)
(LabelSpec
label: 'Saturation:'
name: 'Label3'
translateLabel: true
adjust: right
useDefaultExtent: true
)
)
)
)
(VerticalPanelViewSpec
name: 'HLSSliderPanel'
layout: (LayoutFrame 70 0 86 0 -177 1 163 0)
horizontalLayout: fit
verticalLayout: spreadSpace
horizontalSpace: 3
verticalSpace: 3
component:
(SpecCollection
collection: (
(SliderSpec
name: 'Slider1'
tabable: false
model: hue
orientation: horizontal
stop: 359
step: 1
keyboardStep: 1
extent: (Point 193 16)
)
(SliderSpec
name: 'Slider2'
tabable: false
model: light
orientation: horizontal
step: 1
backgroundColor: (Color 66.999313344015 66.999313344015 66.999313344015)
keyboardStep: 1
extent: (Point 193 16)
)
(SliderSpec
name: 'Slider3'
tabable: false
model: saturation
orientation: horizontal
step: 1
backgroundColor: (Color 66.999313344015 66.999313344015 66.999313344015)
keyboardStep: 1
extent: (Point 193 16)
)
)
)
)
(VerticalPanelViewSpec
name: 'HLSFieldPanel'
layout: (LayoutFrame -173 1 86 0 -143 1 163 0)
horizontalLayout: fit
verticalLayout: spreadSpace
horizontalSpace: 3
verticalSpace: 3
component:
(SpecCollection
collection: (
(InputFieldSpec
name: 'EntryField1'
model: hue
type: numberInRange
numChars: 3
minValue: 0
maxValue: 359
acceptOnPointerLeave: false
extent: (Point 30 20)
)
(InputFieldSpec
name: 'EntryField2'
model: light
type: numberInRange
numChars: 3
minValue: 0
maxValue: 100
acceptOnPointerLeave: false
extent: (Point 30 20)
)
(InputFieldSpec
name: 'EntryField3'
model: saturation
type: numberInRange
numChars: 3
minValue: 0
maxValue: 100
acceptOnPointerLeave: false
extent: (Point 30 20)
)
)
)
)
(ViewSpec
name: 'PreviewBoxFrame'
layout: (LayoutFrame -117 1 4 0.0 -3 1.0 -39 1.0)
level: 1
component:
(SpecCollection
collection: (
(LabelSpec
label: 'Preview'
name: 'PreviewBox'
layout: (LayoutFrame 2 0.0 2 0.0 -2 1.0 -2 1.0)
level: -1
translateLabel: true
postBuildCallback: postBuildPreviewBox:
)
)
)
)
(LabelSpec
label: 'Color Name:'
name: 'ColorNameLabel'
layout: (LayoutFrame 0 0 176 0 106 0 198 0)
translateLabel: true
adjust: right
)
(InputFieldSpec
name: 'ColorNameField'
layout: (LayoutFrame 108 0 176 0 -162 1 198 0)
model: colorNameHolder
immediateAccept: false
acceptOnReturn: true
acceptOnTab: true
acceptOnLostFocus: true
acceptOnPointerLeave: true
)
(LabelSpec
label: 'HTML Color Name:'
name: 'HTMLColorNameLabel'
layout: (LayoutFrame 4 0 204 0 110 0 226 0)
translateLabel: true
adjust: right
)
(InputFieldSpec
name: 'MLHTColorNameFieldField'
layout: (LayoutFrame 108 0 204 0 -162 1 226 0)
model: htmlColorNameHolder
immediateAccept: false
acceptOnReturn: true
acceptOnTab: true
acceptOnLostFocus: true
acceptOnPointerLeave: true
)
(ActionButtonSpec
label: 'Copy Color'
name: 'CopyColor'
layout: (LayoutFrame 12 0 236 0 100 0 258 0)
activeHelpKey: hlsMixer
translateLabel: true
resizeForLabel: true
tabable: true
model: copyColor
)
(ActionButtonSpec
label: 'Paste Color'
name: 'PasteColor'
layout: (LayoutFrame 108 0 236 0 196 0 258 0)
translateLabel: true
resizeForLabel: true
tabable: true
model: pasteColor
)
(ActionButtonSpec
label: 'pickColorIcon'
name: 'Button1'
layout: (LayoutFrame 285 0 236 0 312 0 263 0)
activeHelpKey: pickColor
hasCharacterOrientedLabel: false
translateLabel: true
resizeForLabel: true
tabable: true
model: pickColor
)
(HorizontalPanelViewSpec
name: 'HorizontalPanel1'
layout: (LayoutFrame 0 0.0 -32 1 0 1.0 0 1.0)
horizontalLayout: fitSpace
verticalLayout: centerMax
horizontalSpace: 3
verticalSpace: 3
reverseOrderIfOKAtLeft: true
component:
(SpecCollection
collection: (
(ActionButtonSpec
label: 'Cancel'
name: 'CancelButton'
translateLabel: true
resizeForLabel: false
tabable: true
model: cancel
useDefaultExtent: true
)
(ActionButtonSpec
label: 'OK'
name: 'OKButton'
translateLabel: true
resizeForLabel: false
tabable: true
model: accept
isDefault: true
defaultable: true
useDefaultExtent: true
)
)
)
)
)
)
)
! !
!ColorEditDialog class methodsFor:'startup'!
openOn:aColor
^ self new
color:aColor;
open;
yourself
"
self openOn:Color red
"
! !
!ColorEditDialog methodsFor:'accessing'!
color
|colorName|
colorName := self colorName.
colorName notEmptyOrNil ifTrue:[
^ Color name:(colorName asSymbol)
].
^ Color redByte:(red value) greenByte:(green value) blueByte:(blue value)
!
color:aColor
aColor isNil ifTrue:[
^ self
].
aColor isSymbol ifTrue:[
self colorNameHolder value:aColor
] ifFalse:[
self red value:aColor redByte.
self green value:aColor greenByte.
self blue value:aColor blueByte.
]
!
colorName
^ colorNameHolder value
!
colorNameOrColor
|colorName|
colorName := self colorName.
colorName notEmptyOrNil ifTrue:[
"/ ^ Color name:(colorName asSymbol)
^ colorName asSymbol
].
^ Color redByte:(red value) greenByte:(green value) blueByte:(blue value)
!
htmlColorName
^ htmlColorNameHolder value
! !
!ColorEditDialog methodsFor:'actions'!
colorChanged
|clr|
clr := self colorNameOrColor.
clr isColor ifTrue:[
"not a symbol"
self setPreview:clr.
self htmlColorNameHolder value:(clr htmlPrintString) withoutNotifying:self.
].
!
colorChangedTo:clr
"compute rgb and hls (if possible)"
|h|
self red value:clr redByte withoutNotifying:self.
self green value:clr greenByte withoutNotifying:self.
self blue value:clr blueByte withoutNotifying:self.
h := clr hue.
h notNil ifTrue:[
self hue value:(h rounded) withoutNotifying:self.
].
self light value:(clr light rounded) withoutNotifying:self.
self saturation value:(clr saturation rounded) withoutNotifying:self.
self colorChanged
!
colorNameChanged
"compute rgb and hls (if possible)"
|clr|
clr := Color name:colorNameHolder value ifIllegal:nil.
clr isNil ifTrue:[
^ self
].
self colorChangedTo:clr.
!
copyColor
self window setClipboardObject:self color
!
copyColorName
self window setClipboardText:self htmlColorName
!
hlsSliderChanged
"compute rgb"
Color withRGBFromHue:hue value light:light value saturation:saturation value do:[:r :g :b |
red value:(r * 255 / 100) rounded withoutNotifying:self.
green value:(g * 255 / 100) rounded withoutNotifying:self.
blue value:(b * 255 / 100) rounded withoutNotifying:self.
].
colorNameHolder value:'' withoutNotifying:self.
self colorChanged
!
htmlColorNameChanged
"compute rgb and hls (if possible)"
|clr|
htmlColorNameHolder value isEmptyOrNil ifTrue:[
^ self.
].
clr := Color rgbValue:(Integer
readFrom:(htmlColorNameHolder value copyFrom:2)
radix:16
onError:nil).
clr isNil ifTrue:[
^ self
].
self colorNameHolder value:'' withoutNotifying:self.
self colorChangedTo:clr.
!
pasteColor
|copyBufferColor|
copyBufferColor := self window getClipboardObject.
copyBufferColor isColor ifFalse:[
UserPreferences current beepInEditor ifTrue:[
self window beep.
].
^ self
].
self color:copyBufferColor
!
pickColor
|color|
color := Color fromUserWithFeedBack:[:clr | self setPreview:clr].
color notNil ifTrue:[
self color:color.
]
!
rgbSliderChanged
"compute hls"
|r g b|
r := self red value.
g := self green value.
b := self blue value.
Color withHLSFromRed:(r * 100 / 255) green:(g * 100 / 255) blue:(b * 100 / 255) do:[:h :l :s |
h isNil ifTrue:[
"/ achromatic
] ifFalse:[
self hue value:(h rounded) withoutNotifying:self.
].
self light value:(l rounded) withoutNotifying:self.
self saturation value:(s rounded) withoutNotifying:self.
].
self colorNameHolder value:'' withoutNotifying:self.
self colorChanged
!
setPreview:color
previewBox isNil ifTrue:[^ self "called before setup"].
previewBox backgroundColor:color.
previewBox foregroundColor:(color brightness < 0.5
ifTrue:[Color white]
ifFalse:[Color black]).
! !
!ColorEditDialog methodsFor:'aspects'!
blue
blue isNil ifTrue:[
blue := 0 asValue.
blue addDependent:self.
].
^blue
!
colorNameHolder
colorNameHolder isNil ifTrue:[
colorNameHolder := '' asValue.
colorNameHolder addDependent:self.
].
^colorNameHolder
!
green
green isNil ifTrue:[
green := 0 asValue.
green addDependent:self.
].
^green
!
htmlColorNameHolder
htmlColorNameHolder isNil ifTrue:[
htmlColorNameHolder := '' asValue.
htmlColorNameHolder addDependent:self.
].
^htmlColorNameHolder
!
hue
hue isNil ifTrue:[
hue := 0 asValue.
hue addDependent:self.
].
^hue
!
light
light isNil ifTrue:[
light := 0 asValue.
light addDependent:self.
].
^light
!
red
red isNil ifTrue:[
red := 0 asValue.
red addDependent:self.
].
^red
!
saturation
saturation isNil ifTrue:[
saturation := 0 asValue.
saturation addDependent:self.
].
^saturation
! !
!ColorEditDialog methodsFor:'change & update'!
update:something with:aParameter from:changedObject
(changedObject == red
or:[changedObject == green
or:[changedObject == blue]]) ifTrue:[
self rgbSliderChanged.
^ self
].
(changedObject == hue
or:[changedObject == light
or:[changedObject == saturation]]) ifTrue:[
self hlsSliderChanged.
^ self
].
(changedObject == colorNameHolder) ifTrue:[
self colorNameChanged.
^ self
].
(changedObject == htmlColorNameHolder) ifTrue:[
self htmlColorNameChanged.
^ self
].
super update:something with:aParameter from:changedObject
! !
!ColorEditDialog methodsFor:'startup & release'!
postBuildPreviewBox:aView
previewBox := aView
!
postBuildWith:aBuilder
super postBuildWith:aBuilder.
self colorChanged.
"Modified: / 6.9.1998 / 22:55:25 / cg"
! !
!ColorEditDialog class methodsFor:'documentation'!
version
^ '$Header$'
! !