"
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
Object subclass:#Color
instanceVariableNames:'red green blue device colorId ditherForm replacementColor
writable'
classVariableNames:'MaxValue Lobby Cells Black White LightGrey Grey DarkGrey Pseudo0
Pseudo1 PseudoAll Red Green Blue RetryAllocation DitherBits
ColorAllocationFailSignal InvalidColorNameSignal'
poolDictionaries:''
category:'Graphics-Support'
!
!Color class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
!
documentation
"
Color represents colors in a device independent manner, main info I keep about
mySelf are the red, green and blue components scaled into 0 .. MaxValue.
The device specific color can be aquired by sending a color the 'on:aDevice' message,
which will return a color with the same rgb values as the receiver but specific
for that device.
Colors can be pure or dithered, depending on the capabilities of the device.
For plain colors, the colorId-instvar is a handle (usually lookup-table entry) for that
device. For dithered colors, the colorId is nil and ditherForm specifies the form
used to dither that color. The ditherForm can be either a depth-1 bitmap or a pixmap
with the devices depth. The plain colors needed by the ditherForm are found in its
colormap (as usual for bitmaps).
The default algorithm for color allocation is to ask the display for colors as
new colors are created. When running out of colors, dithered colors will be used,
using existing nearest colors and a dither pattern to aproximate the color.
There could be situations, where no good colors are available for the dither, leading
to ugly looking dither colors.
This can be avoided by preallocating a set of colors over the complete range, which
makes certain that appropriate colors are later available for the dither process.
To do so, add a statement like: 'Color getColors5x5x5' to the startup.rc file.
(beside 5x5x5, there are various other size combinations available).
However, doing so may make things worse when displaying bitmap images, since this
preallocated table may steal colors from the image ...
[Instance variables:]
red <Integer> the red component (0..MaxValue)
green <Integer> the green component (0..MaxValue)
blue <Integer> the blue component (0..MaxValue)
device <Device> the device I am on, or nil
colorId <Object> some device dependent identifier (or nil if dithered)
ditherForm <Form> the Form to dither this color (if non-nil)
writable <Boolean> true if this is for a writable color cell
[Class variables:]
MaxValue <Integer> r/g/b components are scaled relative to this maximum
Lobby <Registry> all colors in use - keeps track of already allocated
colors for reuse and finalization.
(dont use it: this will be moved to the device)
Cells <Registry> keeps track of allocated writable color cells
(dont use it: this will be moved to the device)
FixColors <Array> preallocated colors for dithering on Display
NumRedFix <Integer> number of distinct red values in FixColors
NumGreenFix <Integer> number of distinct green values in FixColors
NumBlueFix <Integer> number of distinct blue values in FixColors
Black <Color> for fast return of black
White <Color> for fast return of white
Grey <Color> for fast return of grey
LightGrey <Color> for fast return of lightGrey
DarkGrey <Color> for fast return of darkGrey
Pseudo0 <Color> a color with 0 as handle (for forms and bitblit)
Pseudo1 <Color> a color with 1 as handle (for forms)
PseudoAll <Color> a color with allPlanes as handle (for bitblit)
Red <Color> red, needed for dithering
Green <Color> green, for dithering
Blue <Color> blue, for dithering
DitherColors <Collection> some preallocated colors for dithering
(kept, so they are available when needed)
RetryAllocation <Boolean> this flag controls how a request for a
color should be handled which failed previously.
I.e. a color is asked for, which was dithered
the last time. Since it could happen, that in
the meantime more colors became free, the request
might succeed this time - however, your screen may
look a bit funny, due to having both dithered and
undithered versions around.
The default is true, which means: do retry
compatibility issues:
ST-80 seems to represent colors internally with scaled smallInteger
components (this can be guessed from uses of
scaledRed:scaledGreen:scaledBlue:). The main instance creation method is
via 'ColorValue red:green:blue:', passing components in 0..1.
In ST/X, component are internally represented as percent.
For more compatibility (when subclassing color), these internals may
change in the near future. For migration, a compatibility subclass
called ColorValue is provided.
After the change, Color will be renamed to ColorValue and Color
be made a subclass of ColorValue (offering the 0..100 interface for
backward compatibility).
[see also:]
DeviceWorkstation
GraphicsContext DeviceDrawable Form Image Colormap
Font Cursor
[author:]
Claus Gittinger
"
! !
!Color class methodsFor:'initialization'!
flushDeviceColors
"unassign all colors from their device"
"if all colors are registered in Lobby, use:"
"
Lobby do:[:aColor |
aColor restored.
Lobby unregister:aColor
].
"
"if only device colors are registered, use"
self allInstances do:[:aColor |
aColor restored
].
Lobby do:[:aColor |
Lobby unregister:aColor
]
!
getColors6x6x4
"preallocates a 6x6x4 (144) colorMap and later uses those colors only.
Doing so has the advantage that the system will never run out of colors,
however, colors may be either inexact or dithered."
self getColorsRed:6 green:6 blue:4
"
Color getColors6x6x4
"
!
getColors6x6x5
"preallocates a 6x6x5 (180) colorMap and later uses those colors only.
Doing so has the advantage that the system will never run out of colors,
however, colors may be either inexact or dithered."
self getColorsRed:6 green:6 blue:5
"
Color getColors6x6x5
"
!
getColors6x6x6
"preallocates a 6x6x6 (196) colorMap and later uses those colors only.
Doing so has the advantage that the system will never run out of colors,
however, colors may be either inexact or dithered."
self getColorsRed:6 green:6 blue:6
"
Color getColors6x6x6
"
!
getColors6x7x4
"preallocates a 6x7x4 (168) colorMap and later uses those colors only.
Doing so has the advantage that the system will never run out of colors,
however, colors may be either inexact or dithered."
self getColorsRed:6 green:7 blue:4
"
Color getColors6x7x4
"
"Created: 12.6.1996 / 17:41:57 / cg"
!
getColors7x8x4
"preallocates a 7x8x4 (224) colorMap and later uses those colors only.
Doing so has the advantage that the system will never run out of colors,
however, colors may be either inexact or dithered."
self getColorsRed:7 green:8 blue:4
"
Color getColors7x8x4
"
!
getColorsRed:nRed green:nGreen blue:nBlue
"preallocates a nR x nG x nB colorMap for later use in dithering.
Doing so has the advantage that the system will never run out of colors,
however, colors may be either inexact or dithered."
self getColorsRed:nRed green:nGreen blue:nBlue on:Display
"
Color getColorsRed:2 green:2 blue:2
"
"Modified: 11.7.1996 / 17:58:09 / cg"
!
getColorsRed:nRed green:nGreen blue:nBlue on:aDevice
"preallocates a nR x nG x nB colorMap for later use in dithering.
Doing so has the advantage that the system will never run out of colors,
however, colors may be either inexact or dithered."
|nR "{Class: SmallInteger }"
nG "{Class: SmallInteger }"
nB "{Class: SmallInteger }"
dR dG dB red green blue dstIndex clr round
fixColors|
aDevice visualType == #TrueColor ifTrue:[^ self].
nR := nRed.
nG := nGreen.
nB := nBlue.
dR := 100.0 / (nR - 1).
dG := 100.0 / (nG - 1).
dB := 100.0 / (nB - 1).
fixColors := Array new:(nR * nG * nB).
round := 0.
dstIndex := 1.
1 to:nR do:[:sR |
red := dR * (sR - 1).
1 to:nG do:[:sG |
green := dG * (sG - 1).
1 to:nB do:[:sB |
blue := dB * (sB - 1).
clr := (self red:red green:green blue:blue) exactOn:aDevice.
clr isNil ifTrue:[
round == 0 ifTrue:[
'Color [info]: scavenge to reclaim colors' infoPrintCR.
ObjectMemory scavenge.
round := 1.
clr := (self red:red green:green blue:blue) exactOn:aDevice.
].
].
clr isNil ifTrue:[
round == 1 ifTrue:[
'Color [info]: collect garbage to reclaim colors' infoPrintCR.
ObjectMemory performLowSpaceCleanup.
ObjectMemory garbageCollect.
round := 2.
clr := (self red:red green:green blue:blue) exactOn:aDevice.
].
].
clr isNil ifTrue:[
ColorAllocationFailSignal raiseErrorString:'failed to allocate fix color'.
^ self
].
fixColors at:dstIndex put:clr.
dstIndex := dstIndex + 1
]
]
].
aDevice setFixColors:fixColors
numRed:nR numGreen:nG numBlue:nB
"
Color getColorsRed:2 green:2 blue:2 on:Display
"
"Created: 11.7.1996 / 17:55:32 / cg"
"Modified: 10.1.1997 / 15:37:13 / cg"
!
getPrimaryColors
"preallocate the primary colors.
Doing so during early startup prevents us from running out
of (at least those required) colors later.
This guarantees, that at least some colors are available
for dithering."
self getPrimaryColorsOn:Display
"Modified: 11.7.1996 / 18:12:17 / cg"
!
getPrimaryColorsOn:aDevice
"preallocate the primary colors.
Doing so during early startup prevents us from running out
of (at least those required) colors later.
This guarantees, that at least some colors are available
for dithering (although, with only black, white, red, green and blue,
dithered images look very poor)."
|colors white black red green blue|
(aDevice notNil and:[aDevice ditherColors isNil]) ifTrue:[
white := (self red:100 green:100 blue:100) exactOn:aDevice.
black := (self red:0 green:0 blue:0) exactOn:aDevice.
aDevice hasColors ifTrue:[
red := (self red:100 green:0 blue:0) exactOn:aDevice.
green := (self red:0 green:100 blue:0) exactOn:aDevice.
blue := (self red:0 green:0 blue:100) exactOn:aDevice.
].
aDevice == Display ifTrue:[
"/ keep those around for the main display
White := white.
Black := black.
Red := red.
Green := green.
Blue := blue
].
aDevice visualType ~~ #TrueColor ifTrue:[
aDevice hasColors ifTrue:[
"preallocate some colors for dithering
- otherwise, they may not be available when we need them ...
these are: black, white, grey50,
red, green, blue, yellow, cyan and magenta.
"
colors := OrderedCollection new.
colors add:((self gray:50) exactOn:aDevice).
colors add:white; add:black; add:red; add:green; add:blue.
colors add:((self red:100 green:100 blue:0) exactOn:aDevice).
colors add:((self red:100 green:0 blue:100) exactOn:aDevice).
colors add:((self red:0 green:100 blue:100) exactOn:aDevice).
colors := colors select:[:clr | clr notNil].
].
aDevice hasGreyscales ifTrue:[
aDevice hasColors ifFalse:[
colors := OrderedCollection new.
colors add:((self gray:50) exactOn:aDevice).
colors add:white; add:black.
].
colors add:((self gray:25) exactOn:aDevice).
colors add:((self gray:33) exactOn:aDevice).
colors add:((self gray:67) exactOn:aDevice).
colors add:((self gray:75) exactOn:aDevice).
colors := colors select:[:clr | clr notNil].
].
colors notNil ifTrue:[
aDevice setDitherColors:(colors asArray).
]
]
]
"Created: 11.7.1996 / 18:09:28 / cg"
"Modified: 11.7.1996 / 18:27:39 / cg"
!
initialize
"setup tracker of known colors and initialize classvars with
heavily used colors"
ColorAllocationFailSignal isNil ifTrue:[
ColorAllocationFailSignal := ErrorSignal newSignalMayProceed:true.
ColorAllocationFailSignal nameClass:self message:#colorAllocationFailSignal.
ColorAllocationFailSignal notifierString:'color allocation failed'.
InvalidColorNameSignal := ErrorSignal newSignalMayProceed:true.
InvalidColorNameSignal nameClass:self message:#invalidColorNameSignal.
InvalidColorNameSignal notifierString:'invalid color name'.
].
Lobby isNil ifTrue:[
MaxValue := 16rFFFF.
Lobby := Registry new.
self getPrimaryColors.
"want to be informed when returning from snapshot"
ObjectMemory addDependent:self.
RetryAllocation := true.
DitherBits := self ditherBits
].
"Modified: 24.1.1997 / 13:37:30 / cg"
!
update:something with:aParameter from:changedObject
"handle image restarts and flush any device resource handles"
(something == #restarted) ifTrue:[
self flushDeviceColors
].
(something == #returnFromSnapshot) ifTrue:[
self getPrimaryColors.
Display visualType == #TrueColor ifTrue:[
Display releaseFixColors
] ifFalse:[
Display fixColors notNil ifTrue:[
ColorAllocationFailSignal handle:[:ex |
ex return
] do:[
|nR nG nB|
nR := Display numFixRed.
nG := Display numFixGreen.
nB := Display numFixBlue.
Display releaseFixColors.
self getColorsRed:nR
green:nG
blue:nB
on:Display
]
]
]
]
"Created: 15.6.1996 / 15:14:03 / cg"
"Modified: 11.7.1996 / 18:03:38 / cg"
! !
!Color class methodsFor:'instance creation'!
allColor
"return a special color which, when used for bit-blitting will
behave like a all-1-color (i.e. have a device-pixel value of all-1s)"
PseudoAll isNil ifTrue:[
PseudoAll := self basicNew setColorId:-1
].
^ PseudoAll
"Modified: 17.1.1997 / 00:05:36 / cg"
!
brightness:brightness
"create a gray color with given brightness (0..1).
ST-80 compatibility."
^ self scaledGray:(brightness * MaxValue)
!
colorId:id
"return a color for a specific colorid without associating it to a
specific device. Use this only for bitmaps which want 0- or 1-color,
or for bitblits if you want to manipulate a specific colorplane."
id == 0 ifTrue:[
^ self noColor
].
id == 1 ifTrue:[
Pseudo1 isNil ifTrue:[
Pseudo1 := self basicNew setColorId:1
].
^ Pseudo1
].
id == -1 ifTrue:[
^ self allColor
].
"look if already known"
Lobby do:[:aColor |
aColor scaledRed isNil ifTrue:[
(aColor colorId == id) ifTrue:[
^ aColor
]
]
].
^ self basicNew setColorId:id
"Modified: 17.1.1997 / 00:06:41 / cg"
!
cyan:c magenta:m yellow:y
"return a color from cyan, magenta and yellow values.
all values are given in percent (0..100)"
^ self
red:(100 - c)
green:(100 - m)
blue:(100 - y)
"
Color cyan:100 magenta:0 yellow:0 - cyan
Color cyan:100 magenta:100 yellow:0 - blue
Color cyan:100 magenta:0 yellow:100 - green
Color cyan:100 magenta:100 yellow:100 - black
"
"Modified: 11.6.1996 / 18:29:15 / cg"
!
fromUser
"let user point on a screen pixel.
Return an instance for that pixels color"
|p img|
p := Screen current pointFromUser.
img := Image fromScreen:(p corner:p+1).
^ img at:0@0
"
Color fromUser
"
"Modified: 31.8.1995 / 01:34:22 / claus"
!
hue:h light:l saturation:s
"return a color from hue, light and saturation values.
Hue is in degrees (0..360); light and sturation are
in percent (0..100)"
self withRGBFromHue:h light:l saturation:s do:[:r :g :b |
^ self red:r green:g blue:b
]
"
Color hue:0 light:50 saturation:100 - red
Color hue:60 light:50 saturation:100 - yellow
Color hue:120 light:50 saturation:100 - green
Color hue:120 light:75 saturation:100 - bright green
Color hue:120 light:25 saturation:100 - dark green
Color hue:120 light:50 saturation:50 - greyish dark green
Color hue:120 light:50 saturation:0 - b&w television dark green
"
"Modified: 23.4.1996 / 13:22:22 / cg"
!
name:colorName
"Return a named color (either exact or dithered).
Report an error, if aString is not a valid color name.
We hereby only guarantee that the 8 basic colors are supported
on every device (X uses the Xcolor database, so it supports more
names - other devices use a builtIn name table containing only the
common names) - use with special names (such as 'mediumGoldenRod'
is not recommended). Better use: #name:ifIllegal: and provide a fallBack."
^ self
name:colorName
ifIllegal:[InvalidColorNameSignal
raiseRequestWith:colorName
errorString:'invalid colorName: ']
"
Color name:'brown'
Color name:'foo'
Color name:'snow'
"
"Modified: 24.1.1997 / 13:39:25 / cg"
!
name:colorName ifIllegal:errorBlock
"Return a named color (either exact or dithered).
If aString is not a valid color name,
return the result from evaluating errorBlock."
|r g b|
Display
getScaledRGBFromName:colorName
into:[:rr :gg :bb |
r := rr.
g := gg.
b := bb
].
r notNil ifTrue:[
^ self scaledRed:r scaledGreen:g scaledBlue:b
].
^ errorBlock value
"
Color name:'brown' ifIllegal:[Color black]
Color name:'foo' ifIllegal:[Color black]
"
"Modified: 16.1.1997 / 22:59:24 / cg"
!
noColor
"return a special color which, when used for bit-blitting will
behave like a 0-color (i.e. have a device-pixel value of all-0s)"
Pseudo0 isNil ifTrue:[
Pseudo0 := self basicNew setColorId:0
].
^ Pseudo0
"Modified: 17.1.1997 / 00:06:49 / cg"
!
red:r green:g blue:b
"return a color from red, green and blue values;
the arguments, r, g and b are interpreted as percent (0..100)"
^ self scaledRed:(r * MaxValue // 100)
scaledGreen:(g * MaxValue // 100)
scaledBlue:(b * MaxValue // 100)
!
redByte:r greenByte:g blueByte:b
"return a color from red, green and blue values;
the arguments, r, g and b are interpreted as byte values (0..255)"
^ self scaledRed:(r * MaxValue // 255)
scaledGreen:(g * MaxValue // 255)
scaledBlue:(b * MaxValue // 255)
"
(Color redByte:255 greenByte:0 blueByte:0) inspect
(Color redByte:255 greenByte:255 blueByte:255) inspect
(Color redByte:0 greenByte:0 blueByte:0) inspect
"
"Modified: 16.1.1997 / 23:32:43 / cg"
!
scaledGray:aGrayValue
"return a gray color with a scaled gray value (0..MaxValue)"
^ self scaledRed:aGrayValue scaledGreen:aGrayValue scaledBlue:aGrayValue
"Modified: 11.6.1996 / 16:31:42 / cg"
!
scaledRed:r scaledGreen:g scaledBlue:b
"return a color from red, green and blue values;
the arguments, r, g and b are interpreted as (0..MaxValue)"
|newColor|
"look if already known"
Lobby do:[:aColor |
(r == aColor scaledRed) ifTrue:[
(g == aColor scaledGreen) ifTrue:[
(b == aColor scaledBlue) ifTrue:[
^ aColor
]
]
]
].
newColor := self basicNew setScaledRed:r scaledGreen:g scaledBlue:b device:nil.
^ newColor
"
(Color red:100 green:0 blue:0) inspect
(Color red:100 green:50 blue:50) inspect
(Color red:50 green:0 blue:0) inspect
"
"Modified: 23.4.1996 / 13:32:36 / cg"
"Modified: 2.5.1996 / 13:40:51 / stefan"
!
variableColorOn:aDevice
"return a variable color (i.e. allocate a writable colorcell) on
aDevice. The returned color is not shared and its rgb components
are initially undefined. The components can be set to any value
using Color>>red:green:blue. Care should be taken, since this call
fails on static color or b&w displays (i.e. it depends on the device
being a pseudocolor device using colormaps).
Returns nil, if no more colorCells are available, or the display
uses a fix colormap (i.e. is a directColor or staticColor pr b&w device).
Because of this, you should not write your application to depend on
writable colors to be available (i.e. add fallBack code to redraw
things in another color)"
|c lutIndex|
lutIndex := aDevice colorCell.
lutIndex isNil ifTrue:[^ nil].
c := self new.
c setDevice:aDevice colorId:lutIndex.
c setWritable:true.
Cells isNil ifTrue:[
Cells := Registry new.
].
Cells register:c.
^ c
"
|l cell|
l := Label new.
l label:('hello' asText allBold).
cell := Color variableColorOn:(Screen current).
l foregroundColor:cell.
[
1 to:40 do:[:i|
i odd ifTrue:[
cell red:100 green:0 blue:0
] ifFalse:[
cell red:0 green:0 blue:0
].
Display flush.
(Delay forSeconds:0.4) wait
].
l destroy.
] fork.
l open
"
"Modified: 13.5.1996 / 12:41:53 / cg"
! !
!Color class methodsFor:'Signal constants'!
colorAllocationFailSignal
"return the signal raised when a color allocation failed."
^ ColorAllocationFailSignal
"Created: 12.6.1996 / 17:44:49 / cg"
!
invalidColorNameSignal
"return the signal raised when an invalid color name is encountered"
^ InvalidColorNameSignal
"Created: 24.1.1997 / 13:36:25 / cg"
! !
!Color class methodsFor:'accessing'!
allocatedColorsOn:aDevice
"return a collection of colors available on aDevice"
|colors|
colors := OrderedCollection new.
Lobby do:[:clr |
(clr graphicsDevice == aDevice and:[clr colorId notNil]) ifTrue:[
colors add:clr
]
].
^ colors asArray
"
Color allocatedColorsOn:Display
"
"Modified: 5.7.1996 / 17:58:23 / cg"
! !
!Color class methodsFor:'cleanup'!
releaseResourcesOnDevice:aDevice
"this is sent when a display connection is closed,
to release all cached Colors from that device"
Lobby unregisterAllForWhich:[:aColor | aColor graphicsDevice == aDevice]
"Modified: 16.1.1997 / 16:41:12 / cg"
"Created: 16.1.1997 / 16:44:20 / cg"
! !
!Color class methodsFor:'color space conversions'!
withHLSFromRed:r green:g blue:b do:aBlock
"compute hls form rgb, evaluate aBlock with h,l and s as arguments"
|max min r1 g1 b1 delta h l s|
"compute hls; h in 0..360; l 0..100; s 0..100"
r1 := r / 100. "scale to 0..1"
g1 := g / 100.
b1 := b / 100.
max := (r1 max:g1) max:b1.
min := (r1 min:g1) min:b1.
l := (max + min) / 2.
max = min ifTrue:[
"achromatic, r=g=b"
s := 0.
h := nil
] ifFalse:[
l < 0.5 ifTrue:[
s := (max - min) / (max + min)
] ifFalse:[
s := (max - min) / (2 - max - min)
].
"calc hue"
delta := max - min.
r1 = max ifTrue:[
h := (g1 - b1) / delta
] ifFalse:[
g1 = max ifTrue:[
h := 2 + ((b1 - r1) / delta)
] ifFalse:[
h := 4 + ((r1 - g1) / delta)
]
].
h := h * 60.
h < 0 ifTrue:[
h := h + 360
].
].
aBlock value:h value:(l * 100) value:(s * 100)
!
withHLSFromScaledRed:r scaledGreen:g scaledBlue:b do:aBlock
"compute hls form rgb, evaluate aBlock with h,l and s as arguments"
^ self withHLSFromRed:(r * 100.0 / MaxValue)
green:(g * 100.0 / MaxValue)
blue:(b * 100.0 / MaxValue)
do:aBlock
"Created: 11.6.1996 / 17:23:47 / cg"
!
withRGBFromHue:h light:l saturation:s do:aBlock
"compute rgb form hls, evaluate aBlock with r,g and b as arguments"
|valueFunc s1 l1 r g b m1 m2|
valueFunc := [:n1 :n2 :hIn |
|hue|
hue := hIn.
hue > 360 ifTrue:[
hue := hue - 360
] ifFalse:[
hue < 0 ifTrue:[
hue := hue + 360
].
].
hue < 60 ifTrue:[
n1 + ((n2 - n1) * hue / 60)
] ifFalse:[
hue < 180 ifTrue:[
n2
] ifFalse:[
hue < 240 ifTrue:[
n1 + ((n2 - n1) * (240 - hue) / 60)
] ifFalse:[
n1
]
]
]
].
"compute hls; h in 0..360; l 0..100; s 0..100"
s1 := s / 100.0. "scale to 0..1"
l1 := l / 100.0.
l1 <= 0.5 ifTrue:[
m2 := l1 * (1 + s1)
] ifFalse:[
m2 := l1 + s1 - (l1 * s1)
].
m1 := 2 * l1 - m2.
s1 = 0 ifTrue:[
"achromatic, ignore hue"
r := g := b := l1
] ifFalse:[
r := valueFunc value:m1 value:m2 value:h + 120.
g := valueFunc value:m1 value:m2 value:h.
b := valueFunc value:m1 value:m2 value:h - 120.
].
aBlock value:r*100 value:g*100 value:b*100
! !
!Color class methodsFor:'constant colors'!
black
"return the black color"
Black isNil ifTrue:[
Black := (self red:0 green:0 blue:0) exactOn:Display
].
^ Black
"
Color black inspect
"
"Modified: 11.6.1996 / 15:55:31 / cg"
!
blue
"return the blue color"
Blue isNil ifTrue:[
Blue := self red:0 green:0 blue:100
].
^ Blue
"
Color blue inspect
"
"Modified: 23.4.1996 / 13:15:51 / cg"
!
cyan
"return the cyan color - ST-80 compatibility"
^ self red:0 green:100 blue:100
"
Color cyan inspect
"
"Modified: 23.4.1996 / 13:16:07 / cg"
!
darkGray
"return the dark grey color (English version ;-)"
DarkGrey isNil ifTrue:[
DarkGrey := self gray:33
].
^ DarkGrey
"
Color darkGray inspect
"
"Modified: 28.5.1996 / 20:53:57 / cg"
!
darkGrey
"return the darkGrey color (US version ;-)"
^ self darkGray
"
Color darkGrey inspect
"
"Modified: 28.5.1996 / 20:47:14 / cg"
!
gray
"return a medium grey color (US version ;-)"
Grey isNil ifTrue:[
Grey := self gray:50
].
^ Grey
"
Color gray inspect
"
"Modified: 28.5.1996 / 20:48:36 / cg"
!
gray:gray
"return a gray color (US version).
The argument, gray is interpreted as percent (0..100)."
^ self red:gray green:gray blue:gray
"
Color gray:25
"
"Modified: 28.5.1996 / 20:49:51 / cg"
!
green
"return green"
Green isNil ifTrue:[
Green := self red:0 green:100 blue:0
].
^ Green
"
Color green inspect
"
"Modified: 23.4.1996 / 13:23:08 / cg"
!
grey
"return the grey color (English version ;-)"
^ self gray
"
Color grey inspect
"
"Modified: 28.5.1996 / 20:48:26 / cg"
!
grey:grey
"return a grey color (English version).
The argument, grey is interpreted as percent (0..100)."
^ self gray:grey
"
Color grey:25
Color grey:12.5
"
"Modified: 28.5.1996 / 20:50:34 / cg"
!
lightGray
"return the lightGrey color (US version ;-)"
LightGrey isNil ifTrue:[
LightGrey := self gray:67
].
^ LightGrey
"
Color lightGray inspect
"
"Modified: 28.5.1996 / 20:54:00 / cg"
!
lightGrey
"return the lightGrey color (English version ;-)"
^ self lightGray
"
Color lightGrey inspect
"
"Modified: 28.5.1996 / 20:51:11 / cg"
!
magenta
"return the magenta color - ST-80 compatibility"
^ self red:100 green:0 blue:100
"
Color magenta inspect
"
"Modified: 23.4.1996 / 13:23:41 / cg"
!
mediumGray
"return medium-grey color (US version ;-)"
^ self gray
"
Color mediumGray inspect
"
"Created: 23.4.1996 / 13:24:17 / cg"
"Modified: 28.5.1996 / 20:51:21 / cg"
!
mediumGrey
"return medium-grey color (English version ;-)"
^ self gray
"
Color mediumGrey inspect
"
"Modified: 28.5.1996 / 20:51:24 / cg"
!
orange
"return the orange color - ST-80 compatibility"
^ self red:75 green:50 blue:0
"Modified: 23.4.1996 / 13:29:32 / cg"
!
pink
"return the pink color - ST-80 compatibility"
^ self red:100 green:0 blue:100
"Modified: 23.4.1996 / 13:29:38 / cg"
!
red
"return the red color"
Red isNil ifTrue:[
Red := self red:100 green:0 blue:0.
].
^ Red
"Modified: 23.4.1996 / 13:29:44 / cg"
!
veryDarkGray
"return a very dark-grey color (US version ;-)"
^ self gray:13
"Created: 23.4.1996 / 13:33:14 / cg"
"Modified: 28.5.1996 / 20:51:41 / cg"
!
veryDarkGrey
"return a very dark-grey color (English version ;-)"
^ self veryDarkGray
"Modified: 28.5.1996 / 20:52:49 / cg"
!
veryLightGray
"return a very light-grey color (US version ;-)"
^ self gray:87
"Created: 23.4.1996 / 13:33:46 / cg"
"Modified: 28.5.1996 / 20:51:59 / cg"
!
veryLightGrey
"return a very light-grey color (English version ;-)"
^ self veryLightGray
"Modified: 28.5.1996 / 20:52:03 / cg"
!
white
"return the white-color"
White isNil ifTrue:[
White := (self red:100 green:100 blue:100) exactOn:Display
].
^ White
!
yellow
"return the yellow color - ST-80 compatibility"
^ self red:100 green:100 blue:0
"Modified: 23.4.1996 / 13:33:56 / cg"
! !
!Color class methodsFor:'obsolete'!
nameOrDither:colorName
"return a named color - if the exact color is not available,
return a dithered color. Report an error, if the colorname is
illegal."
self obsoleteMethodWarning:'use #name:'.
^ self name:colorName
"Modified: 16.1.1997 / 23:01:03 / cg"
!
nameOrDither:colorName ifIllegal:errorBlock
"return a named color - if the exact color is not available,
return a dithered color. If the colorname is illegal, return
the value of evaluating errorBlock."
self obsoleteMethodWarning:'use #name:ifIllegal:'.
^ self name:colorName ifIllegal:errorBlock
"Modified: 16.1.1997 / 23:01:32 / cg"
!
nameOrNearest:colorName
"return a named color - or its nearest match"
self obsoleteMethodWarning:'use #name:'.
^ self name:colorName
"Modified: 16.1.1997 / 23:02:18 / cg"
! !
!Color class methodsFor:'private'!
colorNearRed:r green:g blue:b on:aDevice
"return a device color on aDevice with rgb values
almost matching. If there is one, nil otherwise.
This is tried as a last chance before dithering.
The algorithm needs rework, the color components
should be weighted according some theory :-)"
|bestColor minDelta diff rr rg rb dRed|
"/ rr := (r * 3.0) rounded / 3.0.
"/ rg := (g * 3.0) rounded / 3.0.
"/ rb := (b * 3.0) rounded / 3.0.
rr := r rounded. "round to 1%"
rg := (g * 2.0) rounded / 2.0. "round to 0.5%"
rb := (b / 2) rounded * 2. "round to 2%"
minDelta := 100*100*100.
Lobby do:[:aColor |
(aColor graphicsDevice == aDevice) ifTrue:[
"/ (aColor colorId notNil) ifTrue:[
dRed := rr - aColor red.
dRed < 10 ifTrue:[
diff := dRed asInteger squared
+ (rg - aColor green) asInteger squared
+ (rb - aColor blue) asInteger squared.
diff < minDelta ifTrue:[
diff = 0 ifTrue:[
"got it"
^ aColor
].
bestColor := aColor.
minDelta := diff
]
]
"/ ]
]
].
"allow an error of 10% per component"
minDelta < (100+100+100) ifTrue:[ ^ bestColor ].
^ nil
"Modified: 5.7.1996 / 17:58:19 / cg"
!
ditherBits
"return a dither pattern for x/64; x in 1..63"
^ #(
"/ 1in64
#[2r10000000
2r00000000
2r00000000
2r00000000
2r00000000
2r00000000
2r00000000
2r00000000]
"/ 2in64
#[2r10000000
2r00000000
2r00000000
2r00000000
2r00001000
2r00000000
2r00000000
2r00000000]
"/ 3in64
#[2r10000000
2r00000000
2r00000000
2r00000000
2r10001000
2r00000000
2r00000000
2r00000000]
"/ 4in64
#[2r10001000
2r00000000
2r00000000
2r00000000
2r10001000
2r00000000
2r00000000
2r00000000]
"/ 5in64
#[2r10001000
2r00000000
2r00000000
2r00000000
2r10001000
2r00000000
2r00000010
2r00000000]
"/ 6in64
#[2r10001000
2r00000000
2r00100000
2r00000000
2r10001000
2r00000000
2r00000010
2r00000000]
"/ 7in64
#[2r10001000
2r00000000
2r00100010
2r00000000
2r10001000
2r00000000
2r00000010
2r00000000]
"/ 8in64
#[2r10001000
2r00000000
2r00100010
2r00000000
2r10001000
2r00000000
2r00100010
2r00000000]
"/ 9in64
#[2r10001000
2r00000000
2r00100010
2r00000000
2r10001000
2r00000000
2r10100010
2r00000000]
"/ 10in64
#[2r10001000
2r00000000
2r00101010
2r00000000
2r10001000
2r00000000
2r10100010
2r00000000]
"/ 11in64
#[2r10001000
2r00000000
2r00101010
2r00000000
2r10001000
2r00000000
2r10101010
2r00000000]
"/ 12in64
#[2r10001000
2r00000000
2r10101010
2r00000000
2r10001000
2r00000000
2r10101010
2r00000000]
"/ 13in64
#[2r10001000
2r00000000
2r10101010
2r00000000
2r10101000
2r00000000
2r10101010
2r00000000]
"/ 14in64
#[2r10001010
2r00000000
2r10101010
2r00000000
2r10101000
2r00000000
2r10101010
2r00000000]
"/ 15in64
#[2r10001010
2r00000000
2r10101010
2r00000000
2r10101010
2r00000000
2r10101010
2r00000000]
"/ 16in64
#[2r10101010
2r00000000
2r10101010
2r00000000
2r10101010
2r00000000
2r10101010
2r00000000]
"/ 17in64
#[2r10101010
2r01000000
2r10101010
2r00000000
2r10101010
2r00000000
2r10101010
2r00000000]
"/ 18in64
#[2r10101010
2r01000000
2r10101010
2r00000000
2r10101010
2r00000100
2r10101010
2r00000000]
"/ 19in64
#[2r10101010
2r01000000
2r10101010
2r00000000
2r10101010
2r01000100
2r10101010
2r00000000]
"/ 20in64
#[2r10101010
2r01000100
2r10101010
2r00000000
2r10101010
2r01000100
2r10101010
2r00000000]
"/ 21in64
#[2r10101010
2r01000100
2r10101010
2r00000000
2r10101010
2r01000100
2r10101010
2r00000001]
"/ 22in64
#[2r10101010
2r01000100
2r10101010
2r00010000
2r10101010
2r01000100
2r10101010
2r00000001]
"/ 23in64
#[2r10101010
2r01000100
2r10101010
2r00010001
2r10101010
2r01000100
2r10101010
2r00000001]
"/ 24in64
#[2r10101010
2r01000100
2r10101010
2r00010001
2r10101010
2r01000100
2r10101010
2r00010001]
"/ 25in64
#[2r10101010
2r01000100
2r10101010
2r00010001
2r10101010
2r01000100
2r10101010
2r01010001]
"/ 26in64
#[2r10101010
2r01000100
2r10101010
2r00010101
2r10101010
2r01000100
2r10101010
2r01010001]
"/ 27in64
#[2r10101010
2r01000100
2r10101010
2r00010101
2r10101010
2r01000100
2r10101010
2r01010101]
"/ 28in64
#[2r10101010
2r01000100
2r10101010
2r01010101
2r10101010
2r01000100
2r10101010
2r01010101]
"/ 29in64
#[2r10101010
2r01000100
2r10101010
2r01010101
2r10101010
2r01010100
2r10101010
2r01010101]
"/ 30in64
#[2r10101010
2r01000101
2r10101010
2r01010101
2r10101010
2r01010100
2r10101010
2r01010101]
"/ 31in64
#[2r10101010
2r01000101
2r10101010
2r01010101
2r10101010
2r01010101
2r10101010
2r01010101]
"/ 32in64
#[2r10101010
2r01010101
2r10101010
2r01010101
2r10101010
2r01010101
2r10101010
2r01010101]
"/ 33in64
#[2r11101010
2r01010101
2r10101010
2r01010101
2r10101010
2r01010101
2r10101010
2r01010101]
"/ 34in64
#[2r11101010
2r01010101
2r10101010
2r01010101
2r10101110
2r01010101
2r10101010
2r01010101]
"/ 35in64
#[2r11101010
2r01010101
2r10101010
2r01010101
2r11101110
2r01010101
2r10101010
2r01010101]
"/ 36in64
#[2r11101110
2r01010101
2r10101010
2r01010101
2r11101110
2r01010101
2r10101010
2r01010101]
"/ 37in64
#[2r11101110
2r01010101
2r10101010
2r01010101
2r11101110
2r01010101
2r10101011
2r01010101]
"/ 38in64
#[2r11101110
2r01010101
2r10111010
2r01010101
2r11101110
2r01010101
2r10101011
2r01010101]
"/ 39in64
#[2r11101110
2r01010101
2r10111011
2r01010101
2r11101110
2r01010101
2r10101011
2r01010101]
"/ 40in64
#[2r11101110
2r01010101
2r10111011
2r01010101
2r11101110
2r01010101
2r10111011
2r01010101]
"/ 41in64
#[2r11101110
2r01010101
2r10111011
2r01010101
2r11101110
2r01010101
2r11111011
2r01010101]
"/ 42in64
#[2r11101110
2r01010101
2r10111111
2r01010101
2r11101110
2r01010101
2r11111011
2r01010101]
"/ 43in64
#[2r11101110
2r01010101
2r10111111
2r01010101
2r11101110
2r01010101
2r11111111
2r01010101]
"/ 44in64
#[2r11101110
2r01010101
2r11111111
2r01010101
2r11101110
2r01010101
2r11111111
2r01010101]
"/ 45in64
#[2r11101110
2r01010101
2r11111111
2r01010101
2r11111110
2r01010101
2r11111111
2r01010101]
"/ 46in64
#[2r11101111
2r01010101
2r11111111
2r01010101
2r11111110
2r01010101
2r11111111
2r01010101]
"/ 47in64
#[2r11101111
2r01010101
2r11111111
2r01010101
2r11111111
2r01010101
2r11111111
2r01010101]
"/ 48in64
#[2r11111111
2r01010101
2r11111111
2r01010101
2r11111111
2r01010101
2r11111111
2r01010101]
"/ 49in64
#[2r11111111
2r01110101
2r11111111
2r01010101
2r11111111
2r01010101
2r11111111
2r01010101]
"/ 50in64
#[2r11111111
2r01110101
2r11111111
2r01010101
2r11111111
2r01010111
2r11111111
2r01010101]
"/ 51in64
#[2r11111111
2r01110101
2r11111111
2r01010101
2r11111111
2r01110111
2r11111111
2r01010101]
"/ 52in64
#[2r11111111
2r01110111
2r11111111
2r01010101
2r11111111
2r01110111
2r11111111
2r01010101]
"/ 53in64
#[2r11111111
2r01110111
2r11111111
2r01010101
2r11111111
2r01110111
2r11111111
2r11010101]
"/ 54in64
#[2r11111111
2r01110111
2r11111111
2r01011101
2r11111111
2r01110111
2r11111111
2r11010101]
"/ 55in64
#[2r11111111
2r01110111
2r11111111
2r11011101
2r11111111
2r01110111
2r11111111
2r11010101]
"/ 56in64
#[2r11111111
2r01110111
2r11111111
2r11011101
2r11111111
2r01110111
2r11111111
2r11011101]
"/ 57in64
#[2r11111111
2r01110111
2r11111111
2r11011101
2r11111111
2r01110111
2r11111111
2r11111101]
"/ 58in64
#[2r11111111
2r01110111
2r11111111
2r11011111
2r11111111
2r01110111
2r11111111
2r11111101]
"/ 59in64
#[2r11111111
2r01110111
2r11111111
2r11011111
2r11111111
2r01110111
2r11111111
2r11111111]
"/ 60in64
#[2r11111111
2r01110111
2r11111111
2r11111111
2r11111111
2r01110111
2r11111111
2r11111111]
"/ 61in64
#[2r11111111
2r01110111
2r11111111
2r11111111
2r11111111
2r01111111
2r11111111
2r11111111]
"/ 62in64
#[2r11111111
2r11110111
2r11111111
2r11111111
2r11111111
2r01111111
2r11111111
2r11111111]
"/ 63in64
#[2r11111111
2r11110111
2r11111111
2r11111111
2r11111111
2r11111111
2r11111111
2r11111111]
)
"Modified: 23.4.1996 / 13:31:50 / cg"
"Created: 11.6.1996 / 15:34:29 / cg"
!
existingColorRed:r green:g blue:b on:aDevice
"return a device color on aDevice with rgb values
if there is one, nil otherwise."
^ self existingColorScaledRed:(r * MaxValue // 100)
scaledGreen:(g * MaxValue // 100)
scaledBlue:(b * MaxValue // 100)
!
existingColorScaledRed:r scaledGreen:g scaledBlue:b on:aDevice
"return a device color on aDevice with rgb values
if there is one, nil otherwise."
Lobby do:[:aColor |
(r == aColor scaledRed) ifTrue:[
(g == aColor scaledGreen) ifTrue:[
(b == aColor scaledBlue) ifTrue:[
(aColor graphicsDevice == aDevice) ifTrue:[
^ aColor
]
]
]
]
].
^ nil
"Modified: 5.7.1996 / 17:58:15 / cg"
! !
!Color class methodsFor:'queries'!
constantNames
"return names known as instance creation messages"
^ #(white black
grey mediumGrey veryLightGrey lightGrey darkGrey veryDarkGrey
red green blue cyan yellow pink orange magenta)
"Modified: 2.5.1996 / 11:34:05 / cg"
!
scalingValue
"ST-80 compatibility"
^ MaxValue
"Created: 2.5.1996 / 11:30:09 / cg"
"Modified: 11.7.1996 / 21:42:26 / cg"
! !
!Color class methodsFor:'special instance creation'!
nearestColorRed:r green:g blue:b on:aDevice in:colors
"return the nearest color on aDevice with RGB values
same or near r/g/b in a collection of colors.
If there is one, return it; nil otherwise.
Near is defined as having an error less than the argument
error (in percent). The error is computed by the color
vector distance (which may not be the best possible solution)."
^ self
nearestColorScaledRed:(r * MaxValue // 100)
scaledGreen:(g * MaxValue // 100)
scaledBlue:(b * MaxValue // 100)
on:aDevice
in:colors
"Modified: 11.6.1996 / 18:04:55 / cg"
"Created: 14.6.1996 / 20:05:13 / cg"
!
nearestColorScaledRed:r scaledGreen:g scaledBlue:b inCube:aColorCube numRed:nRed numGreen:nGreen numBlue:nBlue
"return a color with rgb values same or near r/g/b in a given
collection, containing colors from a colorCube.
This is used with preallocated fixColors and is quite fast
(no need to search)"
|sR "{ Class: SmallInteger }"
sG "{ Class: SmallInteger }"
sB "{ Class: SmallInteger }"
idx "{ Class: SmallInteger }"
nR "{ Class: SmallInteger }"
nG "{ Class: SmallInteger }"
nB "{ Class: SmallInteger }"
rI "{ Class: SmallInteger }"
gI "{ Class: SmallInteger }"
bI "{ Class: SmallInteger }"|
"
round to the step given by FixColors
"
nR := nRed.
nG := nGreen.
nB := nBlue.
sR := MaxValue // (nR - 1).
sG := MaxValue // (nG - 1).
sB := MaxValue // (nB - 1).
rI := (r + (sR // 2)) // sR.
gI := (g + (sG // 2)) // sG.
bI := (b + (sB // 2)) // sB.
idx := (((rI * nG) + gI) * nB + bI) + 1.
^ aColorCube at:idx
"Modified: 11.7.1996 / 17:52:46 / cg"
"Created: 11.7.1996 / 18:20:13 / cg"
!
nearestColorScaledRed:r scaledGreen:g scaledBlue:b on:aDevice
"return a device color on aDevice with RGB values
same or near r/g/b, if there is one, nil otherwise.
Near is defined as having an error less than the argument
error (in percent). The error is computed by the color
vector distance (which may not be the best possible solution)."
|cube|
"
if there are preallocated colors, things are much easier ...
"
(cube := aDevice fixColors) notNil ifTrue:[
^ self
nearestColorScaledRed:r
scaledGreen:g
scaledBlue:b
inCube:cube
numRed:(aDevice numFixRed)
numGreen:(aDevice numFixGreen)
numBlue:(aDevice numFixBlue)
].
"
search in existing colors ...
"
^ self
nearestColorScaledRed:r
scaledGreen:g
scaledBlue:b
on:aDevice
in:Lobby
"Created: 14.6.1996 / 20:11:18 / cg"
"Modified: 11.7.1996 / 18:20:50 / cg"
!
nearestColorScaledRed:r scaledGreen:g scaledBlue:b on:aDevice in:colors
"return the nearest color on aDevice with RGB values
same or near r/g/b in a collection of colors.
If there is one, return it; nil otherwise."
|delta minDelta bestSoFar|
minDelta := 9999999.
colors do:[:aColor |
|cr cg cb|
(aColor graphicsDevice == aDevice) ifTrue:[
aColor colorId notNil ifTrue:[
delta := aColor deltaFromScaledRed:r scaledGreen:g scaledBlue:b.
delta < minDelta ifTrue:[
"
an exact fit - no need to continue search
"
delta == 0 ifTrue:[^ aColor].
bestSoFar := aColor.
minDelta := delta
]
]
]
].
^ bestSoFar
"Created: 11.6.1996 / 18:02:12 / cg"
"Modified: 5.7.1996 / 17:58:09 / cg"
!
quickNearestColorScaledRed:r scaledGreen:g scaledBlue:b on:aDevice
"return a device color on aDevice with rgb values
same or near r/g/b.
Near is defined as having an error less than the argument
error (in percent). The error is computed by the color
vector distance (which may not be the best possible solution).
This looks for primary colors only and is thus faster
than the general nearestColor search (slightly uglier though)."
|cube|
"
if there are preallocated colors, thungs are much easier ...
"
(cube := aDevice fixColors) ifTrue:[
^ self
nearestColorScaledRed:r
scaledGreen:g
scaledBlue:b
inCube:cube
numRed:(aDevice numFixRed)
numGreen:(aDevice numFixGreen)
numBlue:(aDevice numFixBlue)
].
"
search in existing colors ...
"
^ self nearestColorScaledRed:r
scaledGreen:g
scaledBlue:b
on:aDevice
in:aDevice availableDitherColors
"Created: 14.6.1996 / 20:13:22 / cg"
"Modified: 11.7.1996 / 18:20:14 / cg"
! !
!Color methodsFor:'accessing'!
blue
"return the blue component in percent [0..100]"
(blue isNil and:[colorId notNil]) ifTrue:[
device getRGBFrom:colorId into:[:r :g :b | ^ b].
].
^ blue * 100.0 / MaxValue
!
blueByte
"return the blue components value mapped to 0..255"
^ blue * 255 // MaxValue
"
Color red blueByte
Color blue blueByte
Color green blueByte
Color black blueByte
Color grey blueByte
Color white blueByte
"
"Created: 7.6.1996 / 18:30:25 / cg"
"Modified: 7.6.1996 / 18:32:03 / cg"
!
colorId
"return the device-dependent color-id"
colorId notNil ifTrue:[^ colorId].
replacementColor notNil ifTrue:[^ replacementColor colorId].
^ nil
"Modified: 17.1.1997 / 00:03:18 / cg"
!
cyan
"return the cyan component in percent [0..100] in cmy color space"
^ 100 - self red
"Modified: 11.6.1996 / 17:20:07 / cg"
"Created: 11.6.1996 / 18:30:00 / cg"
!
device
"return the device I am associated to"
^ device
"Modified: 23.4.1996 / 13:36:42 / cg"
!
deviceBlue
"return the actual value of the blue component in percent."
|v|
device getRGBFrom:colorId into:[:r :g :b | v := b].
^ v
!
deviceGreen
"return the actual value of the green component in percent.
(usually 16bit in X; but could be different on other systems)"
|v|
device getRGBFrom:colorId into:[:r :g :b | v := g].
^ v
!
deviceRed
"return the actual value of the red component in percent."
|v|
device getRGBFrom:colorId into:[:r :g :b | v := r].
^ v
"
(Color yellow on:Display) deviceRedValue
(Color yellow on:aPrinterPage) deviceRedValue
"
!
ditherForm
"return the form to dither the color"
^ ditherForm
!
graphicsDevice
"same as #device, for ST-80 compatibility naming.
Return the device I am associated with."
^ device
"Created: 28.5.1996 / 18:39:27 / cg"
!
green
"return the green component in percent [0..100]"
(green isNil and:[colorId notNil]) ifTrue:[
device getRGBFrom:colorId into:[:r :g :b | ^ g].
].
^ green * 100.0 / MaxValue
!
greenByte
"return the green components value mapped to 0..255"
^ green * 255 // MaxValue
"
Color red greenByte
Color blue greenByte
Color green greenByte
Color black greenByte
Color grey greenByte
Color white greenByte
"
"Modified: 7.6.1996 / 18:31:30 / cg"
!
hue
"return the hue (in hue/light/saturation model) in degrees [0..360]"
|r g b h|
(red isNil and:[colorId notNil]) ifTrue:[
device getRGBFrom:colorId into:[:xr :xg :xb |
r := xr.
g := xg.
b := xb.
]
] ifFalse:[
r := self red.
g := self green.
b := self blue.
].
self class withHLSFromRed:r green:g blue:b do:[:xh :xl :xs |
h := xh
].
^ h
"
Color yellow hue
"
"Modified: 11.6.1996 / 17:14:51 / cg"
!
light
"return the light (in hue/light/saturation model) in percent [0..100].
This corresponds to the brightness of the color (if displayed on
a b&w television screen)"
|r g b l|
(red isNil and:[colorId notNil]) ifTrue:[
device getRGBFrom:colorId into:[:xr :xg :xb |
r := xr.
g := xg.
b := xb.
]
] ifFalse:[
r := self red.
g := self green.
b := self blue.
].
self class withHLSFromRed:r green:g blue:b do:[:xh :xl :xs |
l := xl
].
^ l
"
Color yellow light
Color yellow darkened light
"
"Modified: 11.6.1996 / 17:15:24 / cg"
!
magenta
"return the magenta component in percent [0..100] in cmy color space"
^ 100 - self green
"Modified: 11.6.1996 / 17:20:07 / cg"
"Created: 11.6.1996 / 18:30:11 / cg"
!
red
"return the red component in percent [0..100]"
(red isNil and:[colorId notNil]) ifTrue:[
device getRGBFrom:colorId into:[:r :g :b | ^ r].
].
red isNil ifTrue:[^ 0].
^ red * 100.0 / MaxValue
"Modified: 11.6.1996 / 17:20:07 / cg"
!
red:r green:g blue:b
"set r/g/b components in percent. This method will change the color lookup
table in pseudocolor devices.
This is only allowed for writable colors (i.e. those allocated with
Color>>variableColorOn: on pseudoColor displays).
Using this may make your code unportable, since it depends on a display
using palettes (i.e. it will not work on greyScale or b&w displays)."
^ self scaledRed:(r * MaxValue // 100)
scaledGreen:(g * MaxValue // 100)
scaledBlue:(b * MaxValue // 100)
"
|c|
c := Color variableColorOn:Display.
c inspect.
(Delay forSeconds:5) wait.
c red:100 green:0 blue:0.
(Delay forSeconds:5) wait.
c red:0 green:100 blue:0.
(Delay forSeconds:5) wait.
c red:0 green:0 blue:100.
"
!
redByte
"return the red components value mapped to 0..255"
^ red * 255 // MaxValue
"
Color red redByte
Color blue redByte
Color green redByte
Color black redByte
Color grey redByte
Color white redByte
"
"Modified: 7.6.1996 / 18:31:51 / cg"
!
saturation
"return the saturation (in hue/light/saturation model) in percent [0..100].
This corresponds to the saturation setting of a color TV"
|r g b s|
(red isNil and:[colorId notNil]) ifTrue:[
device getRGBFrom:colorId into:[:xr :xg :xb |
r := xr.
g := xg.
b := xb.
]
] ifFalse:[
r := self red.
g := self green.
b := self blue.
].
self class withHLSFromRed:r green:g blue:b do:[:xh :xl :xs |
s := xs
].
^ s
"
Color yellow saturation
"
"Modified: 11.6.1996 / 17:15:47 / cg"
!
scaledBlue
"ST-80 compatibility:
return the blue components value mapped to 0..MaxValue"
^ blue
"
Color blue scaledBlue
Color black scaledBlue
Color grey scaledBlue
"
"Modified: 7.6.1996 / 18:32:30 / cg"
!
scaledGray
"return the grey intensity scaled to 0..MaxValue"
^ ((red * 3) + (green * 6) + blue) // 10
"
Color blue scaledGray
Color black scaledGray
Color white scaledGray
Color grey scaledGray
"
"Modified: 11.6.1996 / 14:43:51 / cg"
!
scaledGreen
"ST-80 compatibility:
return the green components value mapped to 0..MaxValue"
^ green
"
Color green scaledRed
Color black scaledRed
Color grey scaledRed
"
"Modified: 7.6.1996 / 18:32:38 / cg"
!
scaledRed
"ST-80 compatibility:
return the red components value mapped to 0..MaxValue"
^ red
"
Color red scaledRed
Color black scaledRed
Color grey scaledRed
"
"Modified: 7.6.1996 / 18:32:43 / cg"
!
scaledRed:r scaledGreen:g scaledBlue:b
"set r/g/b components in 0..MaxValue.
This method will change the color lookup table in pseudocolor devices.
This is only allowed for writable colors (i.e. those allocated with
Color>>variableColorOn: on pseudoColor displays).
Using this may make your code unportable, since it depends on a display
using palettes (i.e. it will not work on greyScale or b&w displays)."
(colorId isNil or:[red notNil]) ifTrue:[
^ self error:'operation is not allowed for shared colors'
].
device setColor:colorId scaledRed:r scaledGreen:g scaledBlue:b
!
writable
"return true, if this is a writable colorcell"
^ writable == true
!
yellow
"return the yellow component in percent [0..100] in cmy color space"
^ 100 - self blue
"Modified: 11.6.1996 / 17:20:07 / cg"
"Created: 11.6.1996 / 18:30:20 / cg"
! !
!Color methodsFor:'binary storage'!
readBinaryContentsFrom: stream manager: manager
"tell the newly restored Color about restoration"
super readBinaryContentsFrom:stream manager:manager.
self postCopy
! !
!Color methodsFor:'comparing'!
= aColor
"two colors are considered equal, if the color components are;
independent of the device, the color is on"
aColor == self ifTrue:[^ self].
aColor isColor ifTrue:[
(red == aColor scaledRed) ifTrue:[
(green == aColor scaledGreen) ifTrue:[
(blue == aColor scaledBlue) ifTrue:[
^ true
]
]
]
].
^ false
!
hash
"return an integer useful as hash key for the receiver.
Redefined since = is redefined"
^ red + green + blue
! !
!Color methodsFor:'converting'!
fromLiteralArrayEncoding:encoding
"read my values from an encoding.
The encoding is supposed to be of the form:
(#Color redPart greenPart bluePart)
This is the reverse operation to #literalArrayEncoding."
red := ((encoding at:2) / 100.0 * MaxValue) rounded.
green := ((encoding at:3) / 100.0 * MaxValue) rounded.
blue := ((encoding at:4) / 100.0 * MaxValue) rounded.
"
Color new fromLiteralArrayEncoding:#(#Color 50 25 25)
"
!
literalArrayEncoding
"encode myself as an array, from which a copy of the receiver
can be reconstructed with #decodeAsLiteralArray.
The encoding is:
(#Color redPart greenPart bluePart)
"
^ Array
with:self class name asSymbol
with:(red * 100.0 / MaxValue)
with:(green * 100.0 / MaxValue)
with:(blue * 100.0 / MaxValue)
"
Color new fromLiteralArrayEncoding:#(#Color 50 25 25)
(Color red:25 green:30 blue:70) literalArrayEncoding
"
"Modified: 22.4.1996 / 13:00:11 / cg"
! !
!Color methodsFor:'copying'!
postCopy
"redefined to clear out any device handles in the copy"
device := colorId := ditherForm := replacementColor := nil
"Modified: 17.1.1997 / 00:03:42 / cg"
! !
!Color methodsFor:'getting a device color'!
exactOn:aDevice
"create a new Color representing the same color as
myself on aDevice; if one already exists, return the one.
Do not dither or otherwise approximate the color, but return
nil, if the exact color is not available.
Used to aquire primary colors for dithering, during startup."
|newColor id r g b|
"if Iam already assigned to that device ..."
(device == aDevice and:[ditherForm isNil]) ifTrue:[^ self].
r := red.
g := green.
b := blue.
"first look if not already there"
newColor := Color existingColorScaledRed:r scaledGreen:g scaledBlue:b on:aDevice.
(newColor notNil and:[newColor ditherForm isNil]) ifTrue:[^ newColor].
r := (r bitAnd:16rFF00) bitOr:(r bitShift:-8).
g := (g bitAnd:16rFF00) bitOr:(g bitShift:-8).
b := (b bitAnd:16rFF00) bitOr:(b bitShift:-8).
"ask that device for the color"
id := aDevice colorScaledRed:r scaledGreen:g scaledBlue:b.
id isNil ifTrue:[
"/ this is a kludge: scavenge to free unused colors
"/ and try again ...
ObjectMemory scavenge; finalize.
id := aDevice colorScaledRed:r scaledGreen:g scaledBlue:b
].
id isNil ifTrue:[
"no such color - fail"
"/ 'COLOR: no color for ' infoPrint. self displayString infoPrintCR.
^ nil
].
"receiver was not associated - do it now"
device isNil ifTrue:[
device := aDevice.
colorId := id.
aDevice visualType ~~ #TrueColor ifTrue:[
Lobby register:self.
].
^ self
].
"receiver was already associated to another device - need a new color"
newColor := (self class basicNew) setScaledRed:r scaledGreen:g scaledBlue:b device:aDevice.
newColor setColorId:id.
aDevice visualType ~~ #TrueColor ifTrue:[
Lobby register:newColor.
].
^ newColor
"Modified: 17.1.1997 / 00:15:35 / cg"
!
nearestOn:aDevice
"create a new Color representing the same color as myself on aDevice;
if one already exists, return the one. If no exact match is found,
search for the nearest match"
|newColor id|
"if I'am already assigned to that device ..."
(device == aDevice) ifTrue:[^ self].
"first look if not already there"
newColor := Color nearestColorScaledRed:red scaledGreen:green scaledBlue:blue on:aDevice.
newColor notNil ifTrue:[^ newColor].
"ask that device for the color"
id := aDevice colorScaledRed:red scaledGreen:green scaledBlue:blue.
id isNil ifTrue:[
"this is a kludge:
scavenge to possuby free unused colors and try again ...
this is a compromise: actually a full GC is required here,
but that is too expensive.
"
" "
ObjectMemory scavenge; finalize.
id := aDevice colorScaledRed:red scaledGreen:green scaledBlue:blue
" "
].
id isNil ifTrue:[
"no color - fail"
^ nil
].
"receiver was not associated - do it now"
device isNil ifTrue:[
device := aDevice.
colorId := id.
aDevice visualType ~~ #TrueColor ifTrue:[
Lobby register:self.
].
^ self
].
"receiver was already associated to another device - need a new color"
newColor := (self class basicNew) setScaledRed:red scaledGreen:green sclaedBlue:blue device:aDevice.
newColor setColorId:id.
aDevice visualType ~~ #TrueColor ifTrue:[
Lobby register:newColor.
].
^ newColor
"Modified: 17.1.1997 / 00:06:56 / cg"
!
on:aDevice
"create a new Color representing the same color as
myself on aDevice; if one already exists, return the one"
|newColor id grey form
greyV "{ Class: SmallInteger }"
rV "{ Class: SmallInteger }"
gV "{ Class: SmallInteger }"
bV "{ Class: SmallInteger }"
deviceVisual deviceFixColors|
"/ the most common cases (already allocated) first
colorId notNil ifTrue:[
"/ is someone validating me before drawing on aDevice ?
aDevice notNil ifTrue:[
aDevice == device ifTrue:[
^ self
]
].
"/ a special case for pseudo-colors (0 and 1 in bitmaps)
"/ those have nil r/g/b values, but a nonNil colorId
red isNil ifTrue:[^ self].
"/ want to release color ?
(aDevice isNil and:[device notNil]) ifTrue:[
"/ trueColor device-colors are not registered
device visualType ~~ #TrueColor ifTrue:[
Lobby unregister:self.
device freeColor:colorId
].
device := nil.
colorId := nil.
^ self
].
].
"/ on high-resolution true-color systems, dont care for dithering and/or
"/ especially freeing colors
"/ (no need to remember in Lobby)
(deviceVisual := aDevice visualType) == #TrueColor ifTrue:[
aDevice depth >= 15 ifTrue:[
id := aDevice colorScaledRed:red scaledGreen:green scaledBlue:blue.
id notNil ifTrue:[
device isNil ifTrue:[
colorId := id.
ditherForm := nil.
^ self
].
newColor := (self class basicNew)
setScaledRed:red
scaledGreen:green
scaledBlue:blue
device:aDevice.
newColor setColorId:id.
^ newColor
]
]
].
"/ round a bit within 1% in red & green, 2% in blue
rV := red.
gV := green.
bV := blue.
"/ rV := (red / 100.0) rounded * 100.
"/ gV := (green / 100.0) rounded * 100.
"/ bV := (blue / 50.0) rounded * 50.
"/ if I am already assigned to that device ...
((device == aDevice) and:[ditherForm notNil]) ifTrue:[
"/ mhmh - if I was dithered the last time (not enough colors then)
"/ try again - maybe some colors were reclaimed in the meanwhile
deviceFixColors := aDevice fixColors.
(deviceFixColors isNil
and:[RetryAllocation]) ifTrue:[
"
but there is no chance on b&w displays - so don't try
"
aDevice depth > 2 ifTrue:[
id := aDevice colorScaledRed:rV scaledGreen:gV scaledBlue:bV.
id notNil ifTrue:[
colorId := id.
ditherForm := nil.
Lobby register:self
]
]
].
^ self
].
newColor := Color existingColorScaledRed:rV scaledGreen:gV scaledBlue:bV on:aDevice.
newColor notNil ifTrue:[^ newColor].
"/
"/ ok, we are going to dither that color.
"/ if its 'almost' grey, make it grey and round it a bit (1%)
"/
greyV := (3 * red) + (6 * green) + (1 * blue).
greyV := (greyV / 1000.0) rounded * 10.
"/ allow an error of 1% in red & green, 2% in blue
((rV - greyV) abs <= 655 "/ MaxValue // 100
and:[(gV - greyV) abs <= 655 "/ MaxValue // 100
and:[(bV - greyV) abs <= 1310]]) ifTrue:[ "/ MaxValue // 100 * 2
rV := gV := bV := greyV.
] ifFalse:[
rV := red. gV := green. bV := blue.
].
aDevice hasColors ifTrue:[
deviceFixColors isNil ifTrue:[
"/ ask that device for the exact color
id := aDevice colorScaledRed:rV scaledGreen:gV scaledBlue:bV.
id isNil ifTrue:[
"/ this is a kludge: scavenge to free unused colors
"/ and try again ...
ObjectMemory scavenge; finalize.
id := aDevice colorScaledRed:rV scaledGreen:gV scaledBlue:bV
].
id isNil ifTrue:[
"/ no such color - try color dithers
self ditherRed:rV green:gV blue:bV on:aDevice
into:[:c :f | newColor := c. form := f].
newColor notNil ifTrue:[^ newColor].
].
].
"/ none found ? -> do a hard dither using fixColors
(id isNil and:[form isNil]) ifTrue:[
(deviceFixColors notNil "and:[aDevice == Display]") ifTrue:[
self fixDitherRed:rV green:gV blue:bV on:aDevice
into:[:c :f | newColor := c. form := f].
newColor notNil ifTrue:[^ newColor].
]
].
"/ still none found ? -> do a very hard dither using existing colors
(id isNil and:[form isNil]) ifTrue:[
self complexDitherRed:rV green:gV blue:bV on:aDevice
into:[:c :f | newColor := c. form := f].
newColor notNil ifTrue:[^ newColor].
].
].
(id isNil and:[form isNil]) ifTrue:[
"still no result - try greying"
greyV == 0 ifTrue:[
id := aDevice blackpixel
] ifFalse:[
greyV == MaxValue ifTrue:[
id := aDevice whitepixel
] ifFalse:[
aDevice hasGrayscales ifTrue:[
self ditherGrayFor:(greyV / MaxValue)
on:aDevice
into:[:c :f | newColor := c. form := f].
newColor notNil ifTrue:[^ newColor].
].
]
].
].
device isNil ifTrue:[
"/ receiver was not associated - do it now & return mySelf
device := aDevice.
id isNil ifTrue:[
ditherForm := form
].
colorId := id.
"/ have to tell Lobby - otherwise it keeps old info around
id notNil ifTrue:[
deviceVisual ~~ #TrueColor ifTrue:[
Lobby register:self
]
].
^ self
].
"/ receiver was already associated to another device
"/ - need a new color and return it
newColor := (self class basicNew)
setScaledRed:red
scaledGreen:green
scaledBlue:blue
device:aDevice.
id isNil ifTrue:[
newColor setDitherForm:form
] ifFalse:[
newColor setColorId:id.
"/ trueColor device-colors are not registered
deviceVisual ~~ #TrueColor ifTrue:[
Lobby register:newColor.
]
].
^ newColor
"Created: 16.11.1995 / 20:16:42 / cg"
"Modified: 17.1.1997 / 00:15:19 / cg"
! !
!Color methodsFor:'inspecting'!
inspectorClass
"return the class of an appropriate inspector.
ST/X has a specialized ColorInspectorView for that"
^ ColorInspectorView
"Modified: 23.4.1996 / 13:39:50 / cg"
! !
!Color methodsFor:'instance creation'!
asHiliteColor
"same as lightened - for ST-80 compatibility"
^ self lightened
!
asShadowColor
"same as darkened - for ST-80 compatibility"
^ self darkened
!
blendWith:aColor
"create a new color from equally mixing the receiver
and the argument, aColor.
Mixing is done by adding components
(which is different from mixing colors on paper ..)"
red isNil ifTrue:[
^ aColor
].
^ (self class)
scaledRed:(red + aColor scaledRed) // 2
scaledGreen:(green + aColor scaledGreen) // 2
scaledBlue:(blue + aColor scaledBlue) // 2
"
(Color red) blendWith:(Color yellow)
(Color red) blendWith:(Color blue)
"
"Modified: 11.6.1996 / 18:12:07 / cg"
!
darkened
"return a new color, which is slightly darker than the receiver"
^ self blendWith:Black
"
(Color red) darkened
(Color red) darkened darkened
"
"Modified: 11.6.1996 / 18:10:37 / cg"
!
lightened
"return a new color, which is slightly lighter than the receiver"
^ self blendWith:White
"
(Color red) lightened
(Color red) lightened lightened
"
"Modified: 11.6.1996 / 18:10:49 / cg"
! !
!Color methodsFor:'instance release'!
shallowCopyForFinalization
"redefined, since for finalization only device and colorIndex
are needed - thus a faster copy is possible here"
|aCopy|
aCopy := DeviceColorHandle basicNew.
aCopy setDevice:device colorId:colorId.
^ aCopy
! !
!Color methodsFor:'printing & storing'!
printOn:aStream
"append a string representing of the receiver
to the argument, aStream"
self storeOn:aStream
!
storeOn:aStream
"append a string representing an expression to reconstruct the receiver
to the argument, aStream"
red isNil ifTrue:[
colorId notNil ifTrue:[
aStream nextPutAll:'(Color colorId:'.
colorId storeOn:aStream.
aStream nextPut:$).
^ self
]
].
(red == green and:[red == blue]) ifTrue:[
red == 0 ifTrue:[
aStream nextPutAll:'(Color black)'.
] ifFalse:[
red == MaxValue ifTrue:[
aStream nextPutAll:'(Color white)'.
] ifFalse:[
aStream nextPutAll:'(Color grey:'.
(self red) storeOn:aStream.
aStream nextPut:$).
]
].
^ self
].
aStream nextPutAll:'(Color red:'.
(self red) storeOn:aStream.
aStream nextPutAll:' green:'.
(self green) storeOn:aStream.
aStream nextPutAll:' blue:'.
(self blue) storeOn:aStream.
aStream nextPut:$).
! !
!Color methodsFor:'private'!
complexDitherRed:red green:green blue:blue on:aDevice into:aBlock
"get a deep dither form for an rgb value.
Use all available colors for error dithering into a form."
|errR errG errB f wantR wantG wantB clr
dir "{ Class: SmallInteger }"
start "{ Class: SmallInteger }"
end "{ Class: SmallInteger }"
map|
errR := 0.
errG := 0.
errB := 0.
"get a form and clear it"
f := Form width:4 height:4 depth:(aDevice depth) on:aDevice.
map := IdentityDictionary new.
0 to:3 do:[:x |
x even ifTrue:[
dir := 1.
start := 0.
end := 3.
] ifFalse:[
dir := -1.
start := 3.
end := 0.
].
start to:end by:dir do:[:y |
wantR := red + errR.
wantR > MaxValue ifTrue:[
wantR := MaxValue
] ifFalse:[ wantR < 0 ifTrue:[
wantR := 0
]].
wantG := green + errG.
wantG > MaxValue ifTrue:[
wantG := MaxValue
] ifFalse:[ wantG < 0 ifTrue:[
wantG := 0
]].
wantB := blue + errB.
wantB > MaxValue ifTrue:[
wantB := MaxValue
] ifFalse:[ wantB < 0 ifTrue:[
wantB := 0
]].
"find the nearest color"
" "
clr := Color quickNearestColorScaledRed:wantR scaledGreen:wantG scaledBlue:wantB on:aDevice.
" "
"
clr := Color nearestColorScaledRed:wantR green:wantG blue:wantB on:aDevice.
"
clr isNil ifTrue:[
clr := Color scaledRed:wantR scaledGreen:wantG scaledBlue:wantB.
clr brightness > 0.5 ifTrue:[
clr := Color white on:aDevice
] ifFalse:[
clr := Color black on:aDevice
]
"
^ aBlock value:nil value:nil
"
].
f paint:clr.
f displayPointX:x y:y.
map at:clr colorId + 1 put:clr.
"compute the new error"
errR := wantR - clr scaledRed.
errG := wantG - clr scaledGreen.
errB := wantB - clr scaledBlue.
].
].
f colorMap:map.
"
'hard dither' printNewline.
"
^ aBlock value:nil value:f
"Modified: 14.6.1996 / 20:13:39 / cg"
!
ditherGrayFor:fraction on:aDevice into:aBlock
"get a dither form or colorId for a brightness value.
Returns 2 values (either color or ditherForm) through aBlock."
|d nGray grayBelow scaledGrey scaledGray1 scaledGray2 clr1 clr2 newFraction step|
d := aDevice depth.
"/ special code for b&w displays
d == 1 ifTrue:[
aDevice blackpixel == 0 ifTrue:[
clr1 := Black.
clr2 := White.
newFraction := fraction.
] ifFalse:[
clr1 := White.
clr2 := Black.
newFraction := 1 - fraction
]
] ifFalse:[
"/ special code for 2-plane displays (NeXT)
d == 2 ifTrue:[
fraction <= 0.01 ifTrue:[
clr1 := Black exactOn:aDevice
] ifFalse:[
(fraction between:0.32 and:0.34) ifTrue:[
clr1 := (Color gray:33) exactOn:aDevice
] ifFalse:[
(fraction between:0.66 and:0.68) ifTrue:[
clr1 := (Color gray:67) exactOn:aDevice
] ifFalse:[
fraction >= 0.99 ifTrue:[
clr1 := White exactOn:aDevice
]
]
]
].
clr1 notNil ifTrue:[
^ aBlock value:clr1 value:nil
].
(fraction between:0 and:0.33) ifTrue:[
clr1 := Black.
clr2 := Color gray:33.
] ifFalse:[
(fraction between:0.34 and:0.66) ifTrue:[
clr1 := Color gray:33.
clr2 := Color gray:67.
] ifFalse:[
clr1 := Color gray:67.
clr2 := White.
]
].
scaledGray1 := clr1 scaledRed.
scaledGray2 := clr2 scaledRed.
scaledGrey := (MaxValue * fraction) rounded.
newFraction := (scaledGrey - scaledGray1) asFloat / (scaledGray2 - scaledGray1).
] ifFalse:[
nGray := (1 bitShift:d) - 1.
"/ scale greyValue into grey levels
grayBelow := (fraction * nGray) truncated.
grayBelow < 0 ifTrue:[
^ Color black exactOn:aDevice
].
grayBelow >= nGray ifTrue:[
^ Color white exactOn:aDevice
].
scaledGrey := (MaxValue * fraction) rounded.
step := MaxValue // nGray.
scaledGray1 := grayBelow * step.
scaledGray2 := scaledGray1 + step.
clr1 := Color scaledGray:scaledGray1.
clr2 := Color scaledGray:scaledGray2.
"/ scale remainder in between low..high
newFraction := (scaledGrey - scaledGray1) asFloat / (scaledGray2 - scaledGray1).
"/ dither between those two colors
].
].
clr1 := clr1 exactOn:aDevice.
clr2 := clr2 exactOn:aDevice.
^ self monoDitherFor:newFraction
between:clr1 and:clr2
on:aDevice into:aBlock
"
Color basicNew
ditherGrayFor:0.5
on:Display
into:[:clr :form | clr notNil ifTrue:[clr inspect].
form notNil ifTrue:[(form magnifiedBy:16) inspect].]
"
"
Color basicNew
ditherGrayFor:0.25
on:Display
into:[:clr :form | clr notNil ifTrue:[clr inspect].
form notNil ifTrue:[(form magnifiedBy:16) inspect].]
"
"Modified: 11.6.1996 / 17:08:14 / cg"
!
ditherRed:rV green:gV blue:bV on:aDevice into:aBlock
"get a dither form or colorId for an rgb value.
Returns 2 values (either color or ditherForm) through
aBlock.
This code is just a minimum of what is really needed,
and needs much more work. Currently only some special cases
are handled"
|rh rl rs
lowL hiL lowValL hiValL lowS hiS lowValS hiValS lowH hiH lowValH hiValH d|
"get hls (since we dither anyway, round them a bit"
Color withHLSFromScaledRed:rV scaledGreen:gV scaledBlue:bV do:[:h :l :s |
h notNil ifTrue:[
rh := (h * 3.0) rounded / 3.0.
].
rl := (l * 3.0) rounded / 3.0.
rs := (s * 3.0) rounded / 3.0.
].
rh isNil ifTrue:[
"achromatic, dither between achromatic colors"
lowL := nil.
hiL := nil.
"find the 2 bounding colors"
Lobby do:[:aColor |
aColor colorId notNil ifTrue:[
Color withHLSFromRed:aColor red green:aColor green blue:aColor blue do:[:h :l :s |
| cl |
h isNil ifTrue:[
cl := (l * 3.0) rounded / 3.0.
cl > rl ifTrue:[
hiL isNil ifTrue:[
hiL := aColor.
hiValL := cl.
] ifFalse:[
cl < hiValL ifTrue:[
hiL := aColor.
hiValL := cl.
]
]
] ifFalse:[
lowL isNil ifTrue:[
lowL := aColor.
lowValL := cl
] ifFalse:[
cl > lowValL ifTrue:[
lowL := aColor.
lowValL := cl
]
]
]
]
]
]
].
(lowL notNil and:[hiL notNil]) ifTrue:[
^ self monoDitherFor:1.0 / (hiValL - lowValL) * (rl - lowValL)
between:lowL
and:hiL
on:aDevice
into:aBlock
].
"cannot happen, should always find at least black and white"
self error:'cannot happen'.
^ aBlock value:nil value:nil
].
"chromatic case"
aDevice hasColors ifFalse:[
"no chance, return nil values"
^ aBlock value:nil value:nil
].
(Red isNil or:[Green isNil or:[Blue isNil]]) ifTrue:[
"if we where not able to get primary colors: no chance"
^ aBlock value:nil value:nil
].
"try to find two bounding colors with same hue and saturation;
dither on light between those"
lowL := nil.
hiL := nil.
lowS := nil.
hiS := nil.
lowH := nil.
hiH := nil.
Lobby do:[:aColor |
aColor colorId notNil ifTrue:[
Color withHLSFromRed:aColor red green:aColor green blue:aColor blue do:[:h :l :s |
| cl ch cs|
h notNil ifTrue:[
ch := (h * 3.0) rounded / 3.0.
] ifFalse:[
ch := nil
].
cl := (l * 3.0) rounded / 3.0.
cs := (s * 3.0) rounded / 3.0.
((ch = rh) and:[cs = rs]) ifTrue:[
"found a color with same saturation and same hue, keep for light"
cl > rl ifTrue:[
hiL isNil ifTrue:[
hiL := aColor.
hiValL := cl
] ifFalse:[
cl < hiValL ifTrue:[
hiL := aColor.
hiValL := cl
]
].
] ifFalse:[
lowL isNil ifTrue:[
lowL := aColor.
lowValL := cl
] ifFalse:[
cl > lowValL ifTrue:[
lowL := aColor.
lowValL := cl
]
]
]
].
(((ch = rh) or:[ch == nil]) and:[cl = rl]) ifTrue:[
"found a color with same light and same hue, keep for saturation"
cs > rs ifTrue:[
hiS isNil ifTrue:[
hiS := aColor.
hiValS := cs
] ifFalse:[
cs < hiValS ifTrue:[
hiS := aColor.
hiValS := cs
]
].
] ifFalse:[
lowS isNil ifTrue:[
lowS := aColor.
lowValS := cs
] ifFalse:[
cs > lowValS ifTrue:[
lowS := aColor.
lowValS := cs
]
]
]
].
rh notNil ifTrue:[
cl = rl ifTrue:[
cs = rs ifTrue:[
ch notNil ifTrue:[
d := (ch - rh) abs.
d > 300 ifTrue:[
rh > 180 ifTrue:[
ch := ch + 360
] ifFalse:[
ch := ch - 360
].
].
ch > rh ifTrue:[
hiH isNil ifTrue:[
hiH := aColor.
hiValH := ch
] ifFalse:[
ch < hiValH ifTrue:[
hiH := aColor.
hiValH := ch
]
]
] ifFalse:[
lowH isNil ifTrue:[
lowH := aColor.
lowValH := ch
] ifFalse:[
ch > lowValH ifTrue:[
lowH := aColor.
lowValH := ch
]
]
]
]
]
]
]
]
]
].
"found bounds for light ?"
lowL notNil ifTrue:[
rl = lowValL ifTrue:[
^ aBlock value:lowL value:nil
].
hiL notNil ifTrue:[
^ self monoDitherFor:1.0 / (hiValL - lowValL) / (rl - lowValL)
between:lowL
and:hiL
on:aDevice
into:aBlock
].
"found bound for light - dither with white"
^ self monoDitherFor:1.0 / (100 - lowValL) / (rl - lowValL)
between:lowL
and:White
on:aDevice
into:aBlock
].
"found bound for light - dither with black"
hiL notNil ifTrue:[
^ self monoDitherFor:1.0 / (hiValL) / (rl)
between:Black
and:hiL
on:aDevice
into:aBlock
].
"found bounds for saturation?"
(lowS notNil and:[hiS notNil]) ifTrue:[
"
'saturation dither' printNewline.
"
^ self monoDitherFor:1.0 / (hiValS - lowValS) / (rs - lowValS)
between:lowS
and:hiS
on:aDevice
into:aBlock
].
"found bounds for hue ?"
(lowH notNil and:[hiH notNil]) ifTrue:[
"
'hue dither' printNewline.
"
hiValH < lowValH ifTrue:[
hiValH := hiValH + 360
].
d := hiValH - lowValH.
^ self monoDitherFor:1.0 / (d / (rh - lowValH))
between:lowH
and:hiH
on:aDevice
into:aBlock
].
^ aBlock value:nil value:nil
"Modified: 11.6.1996 / 17:26:57 / cg"
!
fixDitherRed:redVal green:greenVal blue:blueVal on:aDevice into:aBlock
"get a dither form for an rgb value.
Returns 2 values (either color or ditherForm) through aBlock.
This code uses the table of preallocated fix-colors to find
dither colors."
|
nR "{ Class: SmallInteger }"
nG "{ Class: SmallInteger }"
nB "{ Class: SmallInteger }"
hR "{ Class: SmallInteger }"
hG "{ Class: SmallInteger }"
hB "{ Class: SmallInteger }"
eR eG eB
rI "{ Class: SmallInteger }"
gI "{ Class: SmallInteger }"
bI "{ Class: SmallInteger }"
idx "{ Class: SmallInteger }"
f clr
r "{ Class: SmallInteger }"
g "{ Class: SmallInteger }"
b "{ Class: SmallInteger }"
x1 "{ Class: SmallInteger }"
x2 "{ Class: SmallInteger }"
step "{ Class: SmallInteger }"
lastIdx mx
dS "{ Class: SmallInteger }"
cube|
(cube := aDevice fixColors) notNil ifTrue:[
dS := 4.
f := Form width:dS height:dS depth:(aDevice depth) on:aDevice.
f initGC.
mx := MaxValue asFloat.
nR := aDevice numFixRed.
nG := aDevice numFixGreen.
nB := aDevice numFixBlue.
hR := nR // 2.
hG := nG // 2.
hB := nB // 2.
eR := eG := eB := 0.
r := redVal.
g := greenVal.
b := blueVal.
step := -1.
0 to:dS-1 do:[:y |
step == -1 ifTrue:[
x1 := 0. x2 := dS-1. step := 1.
] ifFalse:[
x1 := dS-1. x2 := 0. step := -1.
].
x1 to:x2 by:step do:[:x |
"/ the nearest along the grid
r := redVal + eR.
r > MaxValue ifTrue:[r := MaxValue]
ifFalse:[r < 0 ifTrue:[r := 0]].
g := greenVal + eG.
g > MaxValue ifTrue:[g := MaxValue]
ifFalse:[g < 0 ifTrue:[g := 0]].
b := blueVal + eB.
b > MaxValue ifTrue:[b := MaxValue]
ifFalse:[b < 0 ifTrue:[b := 0]].
rI := (r * (nR-1) + hR / mx) rounded.
gI := (g * (nG-1) + hG / mx) rounded .
bI := (b * (nB-1) + hB / mx) rounded .
idx := (((rI * nG) + gI) * nB + bI) + 1.
clr := (cube at:idx) exactOn:aDevice.
lastIdx isNil ifTrue:[lastIdx := idx]
ifFalse:[lastIdx ~~ idx ifTrue:[lastIdx := -1]].
f foreground:clr.
f displayPointX:x y:y.
eR := r - clr scaledRed.
eG := g - clr scaledGreen.
eB := b - clr scaledBlue.
].
].
f releaseGC.
lastIdx ~~ -1 ifTrue:[
^ aBlock value:clr value:nil
].
^ aBlock value:nil value:f
].
^ aBlock value:nil value:nil
"Modified: 11.7.1996 / 18:30:28 / cg"
!
monoDitherFor:fraction between:color1 and:color2 on:aDevice into:aBlock
"get a dither form or colorId for dithering between 2 colors.
Returns 2 values (either color or ditherForm) through aBlock."
|form c1 c2
index "{ Class:SmallInteger }"|
"/
"/ having forms with: [1 .. 63] of 64 pixels (see Form),
"/ we get dithers for: 1/64, 2/64, ... 63/64
"/
index := (fraction * 64) rounded.
c1 := color1 exactOn:aDevice.
index < 1 ifTrue:[
^ aBlock value:c1 value:nil
].
c2 := color2 exactOn:aDevice.
index >= 64 ifTrue:[
^ aBlock value:c2 value:nil
].
form := Form width:8 height:8 fromArray:(DitherBits at:index) on:aDevice.
form colorMap:(Array with:c1 with:c2).
^ aBlock value:nil value:form
"
Color basicNew
monoDitherFor:(MaxValue // 2)
between:Color black
and:Color white
on:Display
into:[:clr :dither | clr inspect. dither inspect]
"
"Modified: 11.6.1996 / 16:55:37 / cg"
!
restored
"private: color has been restored (either from snapin or binary store);
flush device stuff or reallocate a cell."
ditherForm := replacementColor := nil.
red notNil ifTrue:[
device := nil.
colorId := nil
] ifFalse:[
"a variable color has been restored"
(colorId notNil and:[writable == true and:[device notNil]]) ifTrue:[
colorId := device colorCell.
device setColor:colorId scaledRed:red scaledGreen:green scaledBlue:blue
]
]
"Modified: 17.1.1997 / 00:04:14 / cg"
!
setColorId:anId
"private: set the deviceId"
colorId := anId
"Created: 17.1.1997 / 00:05:41 / cg"
!
setDevice:aDevice colorId:aNumber
"private:set device and colorId"
device := aDevice.
colorId := aNumber
!
setDitherForm:aForm
"private: set the ditherForm"
ditherForm := aForm
"Created: 17.1.1997 / 00:04:57 / cg"
!
setScaledRed:r scaledGreen:g scaledBlue:b device:aDevice
"private: set the components"
red notNil ifTrue:[
"oops cannot change (you want to make red be green - or what)"
self error:'Colors cannot change their components'.
^ self
].
red := r.
green := g.
blue := b.
device := aDevice
"Modified: 16.1.1997 / 22:39:26 / cg"
!
setWritable:aBoolean
"set/clear the writable attribute. Highly private"
writable := aBoolean
"Modified: 23.4.1996 / 13:40:18 / cg"
! !
!Color methodsFor:'queries'!
averageColor
"return the average color - thats myself.
This method has been added for compatibility with the image
protocol."
^ self
!
averageColorIn:aRectangle
"return the average color - thats myself.
This method has been added for compatibility with the image
protocol."
^ self
!
brightness
"ST80 compatibility: return the grey intensity in [0..1]"
^ ((3 * red) + (6 * green) + (blue)) / 10.0 / MaxValue
"Modified: 7.6.1996 / 19:42:21 / cg"
!
deltaFrom:aColor
"return the distance of the receiver from some color specified
by r/g/b values"
^ aColor deltaFromRed:self red green:self green blue:self blue
"Created: 14.6.1996 / 20:07:22 / cg"
"Modified: 14.6.1996 / 20:49:32 / cg"
!
deltaFromRed:r green:g blue:b
"return the distance of the receiver from some color specified
by r/g/b values"
"
Q: how should component errors be weighted ?
"
^ (self red - r) abs
+ (self green - g) abs
+ (self blue - b) abs.
"Created: 14.6.1996 / 20:03:58 / cg"
"Modified: 14.6.1996 / 20:20:24 / cg"
!
deltaFromScaledRed:r scaledGreen:g scaledBlue:b
"return the distance of the receiver from some color specified
by r/g/b values"
"
Q: how should component errors be weighted ?
"
^ (red - r) abs
+ (green - g) abs
+ (blue - b) abs.
"Created: 11.6.1996 / 18:01:12 / cg"
"Modified: 14.6.1996 / 20:36:14 / cg"
!
errorFrom:aColor
"return some value which can be used to compare colors.
The following simply returns the vector distance of the r/g/b vectors.
This may not be a very good idea; probably, we should honor the
fact that the hue difference should have more weight than saturation and/or light"
^ (red - aColor scaledRed) squared
+ (green - aColor scaledGreen) squared
+ (blue - aColor scaledBlue) squared.
!
grayIntensity
"return the grey intensity in percent [0..100] (US version ;-)"
^ ((3 * red) + (6 * green) + (1 * blue)) * 10.0 / MaxValue
"Created: 2.5.1996 / 11:38:21 / cg"
!
greyIntensity
"return the grey intensity in percent [0..100] (English version ;-)"
^ self grayIntensity
"Modified: 28.5.1996 / 20:45:41 / cg"
!
isColor
"return true if the receiver is a Color."
^ true
!
isDithered
"return true, if this is a dithered Color.
Only makes sense if the receiver is a device color."
^ ditherForm notNil
!
isGrayColor
"return true, if this color is a gray one -
i.e. red = green = blue"
red ~~ green ifTrue:[^ false].
^ red == blue
"
(Color grey:50) isGrayColor
(Color red) isGrayColor
"
"Created: 2.5.1996 / 11:38:48 / cg"
!
isGreyColor
"return true, if this color is a grey one (English version ;-) -
i.e. red = green = blue"
^ self isGrayColor
"(Color grey:50) isGreyColor"
"(Color red) isGreyColor"
"Modified: 28.5.1996 / 20:44:36 / cg"
! !
!Color class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libview/Color.st,v 1.84 1997-01-24 12:40:45 cg Exp $'
! !
Color initialize!