"
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:'redVal greenVal blueVal device colorId ditherForm writable'
classVariableNames:'Lobby Cells Black White LightGrey Grey DarkGrey Pseudo0 Pseudo1
PseudoAll Red Green Blue DitherColors RetryAllocation FixColors
NumFixRed NumFixGreen NumFixBlue'
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 in percent (0 .. 100).
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:]
redVal <Number> the red component (0..100)
greenVal <Number> the green component (0..100)
blueVal <Number> the blue component (0..100)
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:]
Lobby <Registry> all colors in use - keeps track of already allocated
colors for reuse and finalization.
Cells <Registry> keeps track of allocated writable color cells
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
"
! !
!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
]
!
getColors5x5x5
"preallocates a 5x5x5 (125) 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:5 green:5 blue:5
"
Color getColors5x5x5
"
!
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
"
!
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."
|nR "{Class: SmallInteger }"
nG "{Class: SmallInteger }"
nB "{Class: SmallInteger }"
dR dG dB red green blue dstIndex clr round|
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:Display.
clr isNil ifTrue:[
round == 0 ifTrue:[
'COLOR: collect garbage to reclaim colors' infoPrintNL.
ObjectMemory garbageCollect.
round := 1.
].
clr := (self red:red green:green blue:blue) exactOn:Display.
].
clr isNil ifTrue:[
FixColors := nil.
NumFixRed := NumFixGreen := NumFixBlue := 0.
self error:'failed to allocate color'.
^ self
].
FixColors at:dstIndex put:clr.
dstIndex := dstIndex + 1
]
]
].
NumFixRed := nR.
NumFixGreen := nG.
NumFixBlue := nB.
!
getPrimaryColors
"preallocate the primary colors.
Doing so during early startup prevents us from running out
of (at least those required) colors later"
|colors|
Display notNil ifTrue:[
White := (self red:100 green:100 blue:100) exactOn:Display.
Black := (self red:0 green:0 blue:0) exactOn:Display.
Display hasColors ifTrue:[
Red := (self red:100 green:0 blue:0) exactOn:Display.
Green := (self red:0 green:100 blue:0) exactOn:Display.
Blue := (self red:0 green:0 blue:100) exactOn:Display.
"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 red:50 green:50 blue:50) exactOn:Display).
colors add:White.
colors add:Black.
colors add:Red.
colors add:Green.
colors add:Blue.
colors add:((self red:100 green:100 blue:0) exactOn:Display).
colors add:((self red:100 green:0 blue:100) exactOn:Display).
colors add:((self red:0 green:100 blue:100) exactOn:Display).
colors := colors select:[:clr | clr notNil].
DitherColors := colors asArray.
]
]
"Modified: 23.4.1996 / 13:35:01 / cg"
!
initialize
"setup tracker of known colors and initialize classvars with
heavily used colors"
Lobby isNil ifTrue:[
Lobby := Registry new.
self getPrimaryColors.
"want to be informed when returning from snapshot"
ObjectMemory addDependent:self.
RetryAllocation := true.
NumFixRed := NumFixGreen := NumFixBlue := 0.
].
!
releaseDitherColors
"release dither colors"
FixColors := nil.
NumFixRed := NumFixGreen := NumFixBlue := 0.
!
update:something
"handle image restarts and flush any device resource handles"
(something == #restarted) ifTrue:[
self flushDeviceColors
].
(something == #returnFromSnapshot) ifTrue:[
self getPrimaryColors.
FixColors notNil ifTrue:[
self getColorsRed:NumFixRed
green:NumFixGreen
blue:NumFixBlue
]
]
"Modified: 23.4.1996 / 13:35:20 / 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 colorId:-1
].
^ PseudoAll
!
black
"return the black color"
Black isNil ifTrue:[
Black := (self red:0 green:0 blue:0) exactOn:Display
].
^ Black
"
Color black inspect
"
"Modified: 23.4.1996 / 13:15:43 / 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"
!
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 colorId:1
].
^ Pseudo1
].
id == -1 ifTrue:[
^ self allColor
].
"look if already known"
Lobby do:[:aColor |
(aColor colorId == id) ifTrue:[
^ aColor
]
].
^ self basicNew colorId:id
!
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 darkGrey color (English version ;-)"
^ self darkGrey
"
Color darkGray inspect
"
"Modified: 23.4.1996 / 13:17:49 / cg"
!
darkGrey
"return the dark grey color (US version ;-)"
DarkGrey isNil ifTrue:[
DarkGrey := self grey:33
].
^ DarkGrey
"
Color darkGrey inspect
"
"Modified: 23.4.1996 / 13:17:52 / 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"
!
gray
"return the grey color (English version ;-)"
^ self grey
"
Color gray inspect
"
"Modified: 23.4.1996 / 13:18:22 / cg"
!
gray:grey
"return a gray color (English version).
The argument, grey is interpreted as percent (0..100)."
^ self grey:grey
"
Color gray:25
Color gray:12.5
"
"Modified: 23.4.1996 / 13:19:24 / 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 a medium grey color (US version ;-)"
Grey isNil ifTrue:[
Grey := self grey:50
].
^ Grey
"
Color grey inspect
"
"Modified: 23.4.1996 / 13:18:03 / cg"
!
grey:grey
"return a grey color (US version).
The argument, grey is interpreted as percent (0..100)."
^ self red:grey green:grey blue:grey
"
Color grey:25
"
"Modified: 23.4.1996 / 13:18:54 / cg"
!
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"
!
lightGray
"return the lightGrey color (English version ;-)"
^ self lightGrey
"
Color lightGray inspect
"
"Modified: 23.4.1996 / 13:23:24 / cg"
!
lightGrey
"return the lightGrey color (US version ;-)"
LightGrey isNil ifTrue:[
LightGrey := self grey:67
].
^ LightGrey
"
Color lightGrey inspect
"
"Modified: 23.4.1996 / 13:23:32 / 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 (English version ;-)"
^ self grey
"
Color mediumGray inspect
"
"Created: 23.4.1996 / 13:24:17 / cg"
!
mediumGrey
"return medium-grey color (US version ;-)"
^ self grey
"
Color mediumGrey inspect
"
"Modified: 23.4.1996 / 13:24:00 / cg"
!
name:aString
"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 nameOrDither:aString
"
Color name:'brown'
Color name:'foo'
Color name:'snow'
"
"Modified: 23.4.1996 / 13:28:27 / cg"
!
name:aString ifIllegal:aBlock
"Return a named color (either exact or dithered).
Return the result from evaluating aBlock, if aString is not a
valid color name."
^ self nameOrDither:aString ifIllegal:aBlock
"
Color name:'brown' ifIllegal:[Color black]
Color name:'foo' ifIllegal:[Color black]
"
"Modified: 23.4.1996 / 13:28:52 / cg"
!
nameOrDither:aString
"return a named color - if the exact color is not available,
return a dithered color. Report an error, if the colorname is
illegal."
^ self nameOrDither:aString
ifIllegal:[self error:'no color named ' , aString. nil]
"
Color nameOrDither:'Brown'
Color nameOrDither:'foo'
"
"Modified: 23.4.1996 / 13:29:04 / cg"
!
nameOrDither:aString 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."
Display getRGBFromName:aString into:[:r :g :b |
r notNil ifTrue:[
^ self red:r green:g blue:b
].
].
^ errorBlock value
"
Color nameOrDither:'Brown' ifIllegal:[nil]
Color nameOrDither:'foo ' ifIllegal:[nil]
"
"Modified: 23.4.1996 / 13:29:14 / cg"
!
nameOrNearest:aString
"return a named color - or its nearest match"
|id newColor|
id := Display colorNamed:aString.
id isNil ifTrue:[
ObjectMemory scavenge; finalize.
id := Display colorNamed:aString.
id isNil ifTrue:[^ nil].
].
newColor := self basicNew.
Display getRGBFrom:id into:[:r :g :b |
newColor setRed:r green:g blue:b device:Display
].
newColor colorId:id.
Lobby register:newColor.
^ newColor
!
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 colorId:0
].
^ Pseudo0
!
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"
!
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)"
|newColor rr rg rb|
"
round color component values to 1/300 i.e. to about 0.33%
Q: since the eye can only distinguish about 100 different grey values,
could (should) we round to about 1% ?.
or even less for blue ?
"
"/ 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%"
"look if already known"
Lobby do:[:aColor |
(rr = aColor red) ifTrue:[
(rg = aColor green) ifTrue:[
(rb = aColor blue) ifTrue:[
^ aColor
]
]
]
].
newColor := self basicNew setRed:rr green:rg blue:rb 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"
!
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'.
cell := Color variableColorOn:(Screen current).
l foreground:cell.
[
1 to:100 do:[:i|
i odd ifTrue:[
cell red:100 green:0 blue:0
] ifFalse:[
cell red:0 green:0 blue:0
].
(Delay forSeconds:0.3) wait
]
] fork.
l open
"
!
veryDarkGray
"return a very dark-grey color (English version ;-)"
^ self veryDarkGrey
"Created: 23.4.1996 / 13:33:14 / cg"
!
veryDarkGrey
"return a very dark-grey color (US version ;-)"
^ self grey:13
"Modified: 23.4.1996 / 13:33:23 / cg"
!
veryLightGray
"return a very light-grey color (English version ;-)"
^ self veryLightGrey
"Created: 23.4.1996 / 13:33:46 / cg"
!
veryLightGrey
"return a very light-grey color (US version ;-)"
^ self grey:87
"Modified: 23.4.1996 / 13:33:33 / 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:'accessing'!
fixColors
"return the table of preallocated fix colors (a colorCube)"
^ FixColors
"Modified: 23.4.1996 / 13:35:44 / cg"
!
numFixBlue
"return the number of blue shades in the
preallocated fix color cube (or 0 if there is none)"
^ NumFixBlue
"Modified: 23.4.1996 / 13:36:16 / cg"
!
numFixGreen
"return the number of green shades in the
preallocated fix color cube (or 0 if there is none)"
^ NumFixGreen
"Modified: 23.4.1996 / 13:36:23 / cg"
!
numFixRed
"return the number of red shades in the
preallocated fix color cube (or 0 if there is none)"
^ NumFixRed
"Modified: 23.4.1996 / 13:36:29 / 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)
!
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:'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 device == 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
!
existingColorRed:r green:g blue:b on:aDevice
"return a device color on aDevice with rgb values
if there is one, nil otherwise."
|rr rg rb|
"/ 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%"
Lobby do:[:aColor |
"/ aColor colorId notNil ifTrue:[
(rr = aColor red) ifTrue:[
(rg = aColor green) ifTrue:[
(rb = aColor blue) ifTrue:[
(aColor device == aDevice) ifTrue:[
^ aColor
]
]
]
"/ ]
]
].
^ nil
! !
!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)
! !
!Color class methodsFor:'special instance creation'!
nearestColorRed:r green:g blue:b error:error 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)."
"
if there are preallocated colors, things are much easier ...
"
(FixColors notNil and:[aDevice == Display]) ifTrue:[
^ self nearestPreallocatedColorRed:r green:g blue:b on:aDevice
].
"
search in existing colors ...
"
^ self nearestColorRed:r
green:g
blue:b
error:error
on:aDevice
in:Lobby
!
nearestColorRed:r green:g blue:b error:error 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)."
|delta minDelta bestSoFar rr rg rb|
"
round values somewhat - the human eye cannot distinguish
more than about 100 grades anyway ...
"
"/ rr := (r * 3.0) rounded / 3.0. "round to about 0.3%"
"/ rg := (g * 3.0) rounded / 3.0. "round to about 0.3%"
"/ rb := (b * 3.0) rounded / 3.0. "round to about 0.3%"
rr := r rounded. "round to 1%"
rg := (g * 2.0) rounded / 2.0. "round to 0.5%"
rb := ((b / 2) rounded * 2) asInteger. "round to 2%"
minDelta := 999999.
colors do:[:aColor |
|cr cg cb|
(aColor device == aDevice) ifTrue:[
aColor colorId notNil ifTrue:[
"/ cr := (aColor red * 3.0) rounded / 3.0.
"/ cg := (aColor green * 3.0) rounded / 3.0.
"/ cb := (aColor blue * 3.0) rounded / 3.0.
cr := aColor red rounded.
cg := (aColor green * 2.0) rounded / 2.0.
cb := ((aColor blue / 2) rounded * 2) asInteger.
"
an exact fit - no need to continue search
"
(rr == cr) ifTrue:[
(rb == cb) ifTrue:[
(rg = cg) ifTrue:[
^ aColor
]
]
].
"
Q: how should component errors be weighted ?
"
delta := ((rr - cr) squared * 3)
+ ((rg - cg) squared * 4)
+ ((rb - cb) squared * 2).
delta < minDelta ifTrue:[
bestSoFar := aColor.
minDelta := delta
]
]
]
].
minDelta < error squared ifTrue:[
^ bestSoFar
].
^ nil
!
nearestPreallocatedColorRed:r green:g blue:b on:aDevice
"return a device color on aDevice with rgb values same or near r/g/b.
This looks for preallocated colors only 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 }"|
"
if there are preallocated colors, thungs are much easier ...
"
(FixColors notNil and:[aDevice == Display]) ifTrue:[
"
round to the step given by FixColors
"
nR := NumFixRed.
nG := NumFixGreen.
nB := NumFixBlue.
sR := 100 // (nR - 1).
sG := 100 // (nG - 1).
sB := 100 // (nB - 1).
rI := (r + (sR // 2)) // sR.
gI := (g + (sG // 2)) // sG.
bI := (b + (sB // 2)) // sB.
idx := (((rI * nG) + gI) * nB + bI) + 1.
^ FixColors at:idx
].
^ nil
!
quickNearestColorRed:r green:g blue:b error:error 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)."
|colors|
"
if there are preallocated colors, thungs are much easier ...
"
(FixColors notNil and:[aDevice == Display]) ifTrue:[
^ self nearestPreallocatedColorRed:r green:g blue:b on:aDevice
].
aDevice == Display ifTrue:[
colors := DitherColors
] ifFalse:[
colors := DitherColors collect:[:aColor | aColor on:aDevice]
].
"
search in existing colors ...
"
^ self nearestColorRed:r
green:g
blue:b
error:error
on:aDevice
in:colors
! !
!Color methodsFor:'accessing'!
blue
"return the blue component in percent [0..100]"
(blueVal isNil and:[colorId notNil]) ifTrue:[
device getRGBFrom:colorId into:[:r :g :b | ^ b].
].
^ blueVal
!
colorId
"return the device-dependent color-id"
^ colorId
!
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
!
green
"return the green component in percent [0..100]"
(greenVal isNil and:[colorId notNil]) ifTrue:[
device getRGBFrom:colorId into:[:r :g :b | ^ g].
].
^ greenVal
!
hue
"return the hue (in hue/light/saturation model) in degrees [0..360]"
(redVal isNil and:[colorId notNil]) ifTrue:[
device getRGBFrom:colorId into:[:r :g :b |
self class withHLSFromRed:r green:g blue:b do:[:h :l :s |
^ h
].
]
].
self class withHLSFromRed:redVal green:greenVal blue:blueVal do:[:h :l :s |
^ h
]
"
Color yellow hue
"
"Modified: 23.4.1996 / 13:37:11 / 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)"
(redVal isNil and:[colorId notNil]) ifTrue:[
device getRGBFrom:colorId into:[:r :g :b |
self class withHLSFromRed:r green:g blue:b do:[:h :l :s |
^ l
].
]
].
self class withHLSFromRed:redVal green:greenVal blue:blueVal do:[:h :l :s |
^ l
]
"
Color yellow light
Color yellow darkened light
"
"Modified: 23.4.1996 / 13:38:01 / cg"
!
red
"return the red component in percent [0..100]"
(redVal isNil and:[colorId notNil]) ifTrue:[
device getRGBFrom:colorId into:[:r :g :b | ^ r].
].
^ redVal
!
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)."
(colorId isNil or:[redVal notNil]) ifTrue:[
self error:'not allowed for shared colors'
].
device setColor:colorId red:r green:g blue:b
"
|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.
"
!
saturation
"return the saturation (in hue/light/saturation model) in percent [0..100].
This corresponds to the saturation setting of a color TV"
(redVal isNil and:[colorId notNil]) ifTrue:[
device getRGBFrom:colorId into:[:r :g :b |
self class withHLSFromRed:r green:g blue:b do:[:h :l :s |
^ s
].
]
].
self class withHLSFromRed:redVal green:greenVal blue:blueVal do:[:h :l :s |
^ s
]
"Modified: 23.4.1996 / 13:38:39 / cg"
!
writable
"return true, if this is a writable colorcell"
^ writable == true
! !
!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:[
(redVal = aColor red) ifTrue:[
(greenVal = aColor green) ifTrue:[
(blueVal = aColor blue) ifTrue:[
^ true
]
]
]
].
^ false
!
hash
"return an integer useful as hash key for the receiver.
Redefined since = is redefined"
^ redVal hash + greenVal hash + redVal hash
! !
!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."
redVal := encoding at:2.
greenVal := encoding at:3.
blueVal := encoding at:4.
"
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:redVal
with:greenVal
with:blueVal
"
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 := nil
"Modified: 23.4.1996 / 13:39:20 / 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|
"if Iam already assigned to that device ..."
(device == aDevice) ifTrue:[^ self].
"first look if not already there"
newColor := Color existingColorRed:redVal green:greenVal blue:blueVal on:aDevice.
newColor notNil ifTrue:[^ newColor].
"ask that device for the color"
id := aDevice colorRed:redVal green:greenVal blue:blueVal.
id isNil ifTrue:[
"this is a kludge: scavenge to free unused colors
and try again ..."
ObjectMemory scavenge; finalize.
id := aDevice colorRed:redVal green:greenVal blue:blueVal
].
id isNil ifTrue:[
"no such color - fail"
^ nil
].
"receiver was not associated - do it now"
device isNil ifTrue:[
device := aDevice.
colorId := id.
"
Lobby changed:self.
"
Lobby register:self.
^ self
].
"receiver was already associated to another device - need a new color"
newColor := (self class basicNew) setRed:redVal green:greenVal blue:blueVal device:aDevice.
newColor colorId:id.
Lobby register:newColor.
^ newColor
!
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 one nearby."
^ self nearestOn:aDevice error:100
!
nearestOn:aDevice error:error
"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 one with an error less than the argument error (in percent)."
|newColor id|
"if I'am already assigned to that device ..."
(device == aDevice) ifTrue:[^ self].
"first look if not already there"
newColor := Color nearestColorRed:redVal green:greenVal blue:blueVal
error:error on:aDevice.
newColor notNil ifTrue:[^ newColor].
"ask that device for the color"
id := aDevice colorRed:redVal green:greenVal blue:blueVal.
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 colorRed:redVal green:greenVal blue:blueVal
" "
].
id isNil ifTrue:[
"no color - fail"
^ nil
].
"receiver was not associated - do it now"
device isNil ifTrue:[
device := aDevice.
colorId := id.
"
Lobby changed:self.
"
Lobby register:self.
^ self
].
"receiver was already associated to another device - need a new color"
newColor := (self class basicNew) setRed:redVal green:greenVal blue:blueVal device:aDevice.
newColor colorId:id.
Lobby register:newColor.
^ newColor
!
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 rV gV bV|
"if Iam already assigned to that device ..."
(device == aDevice) ifTrue:[
(ditherForm notNil
and:[RetryAllocation]) ifTrue:[
"
mhmh - I was dithered the last time (not enough colors then)
try again ?
"
aDevice depth > 2 ifTrue:[
"
if I was dithered, try again
(but there is no chance on b&w displays - so don't try)
"
id := aDevice colorRed:redVal green:greenVal blue:blueVal.
id notNil ifTrue:[
colorId := id.
ditherForm := nil.
Lobby register:self
]
]
].
^ self
].
"the is a special case for pseudo-colors (0 and 1 in bitmaps)"
(redVal isNil and:[colorId notNil]) ifTrue:[^ self].
"want to release color ?"
(aDevice isNil and:[device notNil and:[colorId notNil]]) ifTrue:[
(device notNil and:[colorId notNil]) ifTrue:[
Lobby unregister:self.
device freeColor:colorId
].
device := nil.
colorId := nil.
"have to tell Lobby - otherwise it keeps old info around"
"
Lobby changed:self.
"
^ self
].
newColor := Color existingColorRed:redVal green:greenVal blue:blueVal 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
"/
grey := (3 * redVal) + (6 * greenVal) + (1 * blueVal).
"avoid things like 100.00000001"
grey := ((grey * 10) rounded) // 100.0.
((redVal - grey) abs <= 1
and:[(greenVal - grey) abs <= 2
and:[(greenVal - grey) abs <= 2]]) ifTrue:[
rV := gV := bV := grey rounded.
] ifFalse:[
rV := redVal. gV := greenVal. bV := blueVal.
].
aDevice hasColors ifTrue:[
"ask that device for the exact color"
id := aDevice colorRed:rV green:gV blue:bV.
id isNil ifTrue:[
"this is a kludge: scavenge to free unused colors
and try again ..."
ObjectMemory scavenge; finalize.
id := aDevice colorRed:rV green:gV blue:bV
].
id isNil ifTrue:[
"no such color, look for a near-by one"
"
newColor := Color colorNearRed:redVal green:greenVal blue:blueVal on:aDevice.
newColor notNil ifTrue:[^ newColor].
"
"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].
].
"still none found, do a hard dither"
(id isNil and:[form isNil]) ifTrue:[
(FixColors 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 hard dither"
(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"
"/ grey := (3 * redVal) + (6 * greenVal) + (1 * blueVal).
"/ "avoid things like 100.00000001"
"/ grey := ((grey * 10) rounded) / 100.0.
grey = 0 ifTrue:[
id := aDevice blackpixel
] ifFalse:[
grey = 100 ifTrue:[
id := aDevice whitepixel
] ifFalse:[
aDevice hasGreyscales ifTrue:[
"kludge for 2-plane display - dither using 4 grey levels"
(aDevice depth == 2) ifTrue:[
grey := grey rounded.
self dither2PlaneFor:grey on:aDevice
into:[:c :f | newColor := c. form := f].
newColor notNil ifTrue:[^ newColor].
] ifFalse:[
id := aDevice colorRed:grey green:grey blue:grey.
id isNil ifTrue:[
ObjectMemory scavenge; finalize.
id := aDevice colorRed:grey green:grey blue:grey.
].
].
].
]
].
"now we have either a form (2-plane dithering)
or an id (a real color).
if both are nil, fall back to very simple dithering
"
(form isNil and:[id isNil]) ifTrue:[
self monoDitherFor:grey
on:aDevice
into:[:c :f | newColor := c. form := f].
newColor notNil ifTrue:[^ newColor].
].
].
device isNil ifTrue:[
"receiver was not associated - do it now"
device := aDevice.
id isNil ifTrue:[
ditherForm := form
].
colorId := id.
"have to tell Lobby - otherwise it keeps old info around"
"
Lobby changed:self.
"
id notNil ifTrue:[
Lobby register:self
].
^ self
].
"receiver was already associated to another device - need a new color"
newColor := (self class basicNew) setRed:redVal green:greenVal blue:blueVal device:aDevice.
id isNil ifTrue:[
newColor ditherForm:form
] ifFalse:[
newColor colorId:id.
Lobby register:newColor.
].
"
Lobby register:newColor.
"
^ newColor
"Created: 16.11.1995 / 20:16:42 / 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'!
darkened
"return a new color, which is slightly darker than the receiver"
redVal isNil ifTrue:[^ Black].
^ Color red:(redVal / 2) green:(greenVal / 2) blue:(blueVal / 2)
"(Color red) darkened"
!
lightened
"return a new color, which is slightly lighter than the receiver"
redVal isNil ifTrue:[^ White].
^ Color red:((100 - redVal) / 2 + redVal)
green:((100 - greenVal) / 2 + greenVal)
blue:((100 - blueVal) / 2 + blueVal)
"(Color red) lightened"
! !
!Color methodsFor:'instance release'!
disposed
"a color died - free the device color"
colorId notNil ifTrue:[
device freeColor:colorId.
colorId := nil.
]
!
shallowCopyForFinalization
"redefined, since for finalization only device and colorIndex
are needed - thus a faster copy is possible here"
|aCopy|
aCopy := self class 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"
redVal isNil ifTrue:[
colorId notNil ifTrue:[
aStream nextPutAll:'(Color colorId:'.
colorId storeOn:aStream.
aStream nextPut:$).
^ self
]
].
(redVal = greenVal and:[redVal = blueVal]) ifTrue:[
redVal = 0 ifTrue:[
aStream nextPutAll:'(Color black)'.
] ifFalse:[
redVal = 100 ifTrue:[
aStream nextPutAll:'(Color white)'.
] ifFalse:[
aStream nextPutAll:'(Color grey:'.
redVal storeOn:aStream.
aStream nextPut:$).
]
].
^ self
].
aStream nextPutAll:'(Color red:'.
redVal storeOn:aStream.
aStream nextPutAll:' green:'.
greenVal storeOn:aStream.
aStream nextPutAll:' blue:'.
blueVal storeOn:aStream.
aStream nextPut:$).
! !
!Color methodsFor:'private'!
colorId:anId
"private: set the deviceId"
colorId := anId
!
complexDitherRed:redVal green:greenVal blue:blueVal 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 := redVal + errR.
wantG := greenVal + errG.
wantB := blueVal + errB.
"find the nearest color"
" "
clr := Color quickNearestColorRed:wantR green:wantG blue:wantB
error:100 on:aDevice.
" "
"
clr := Color nearestColorRed:wantR green:wantG blue:wantB
error:100 on:aDevice.
"
clr isNil ifTrue:[
clr := Color red:wantR green:wantG blue:wantB.
clr greyIntensity > 50.0 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 red.
errG := wantG - clr green.
errB := wantB - clr blue.
].
].
f colorMap:map.
"
'hard dither' printNewline.
"
^ aBlock value:nil value:f
!
device:aDevice
"private: set the device"
device := aDevice
!
dither2PlaneFor:grey on:aDevice into:aBlock
"get a dither form or colorId for a grey color.
Returns 2 values (either color or ditherForm) through
aBlock.
This code optimized for 2-plane displays (NeXT),
- must be generalized for any number of planes."
|color
gr "{ Class:SmallInteger }"
color1 color2 low high scaled|
gr := grey asInteger.
gr <= 1 ifTrue:[
color := Black exactOn:aDevice
] ifFalse:[
(gr between:32 and:34) ifTrue:[
color := (Color grey:33) exactOn:aDevice
] ifFalse:[
(gr between:66 and:68) ifTrue:[
color := (Color grey:67) exactOn:aDevice
] ifFalse:[
gr >= 99 ifTrue:[
color := White exactOn:aDevice
]
]
]
].
color notNil ifTrue:[
^ aBlock value:color value:nil
].
(gr between:0 and:33) ifTrue:[
color1 := Black on:aDevice.
color2 := (Color grey:33) on:aDevice.
] ifFalse:[
(gr between:34 and:66) ifTrue:[
color1 := (Color grey:33) on:aDevice.
color2 := (Color grey:67) on:aDevice.
] ifFalse:[
color1 := (Color grey:67) on:aDevice.
color2 := White on:aDevice.
]
].
low := color1 red.
high := color2 red.
"scale gr in between low..high"
scaled := ((gr - low) * 100 / (high - low)) rounded.
^ self monoDitherFor:scaled
between:color1
and:color2
on:aDevice
into:aBlock.
!
ditherForm:aForm
"private: set the ditherForm"
ditherForm := aForm
!
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 redVal greenVal blueVal grey greyVal
lowL hiL lowValL hiValL lowS hiS lowValS hiValS lowH hiH lowValH hiValH d|
"/
"/ if its 'almost' grey, make it grey
"/
redVal := rV.
blueVal := bV.
greenVal := gV.
grey := (3 * redVal) + (6 * greenVal) + (1 * blueVal).
greyVal := grey // 10.
((redVal - greyVal) abs <= 1
and:[(greenVal - greyVal) abs <= 2
and:[(greenVal - greyVal) abs <= 2]]) ifTrue:[
redVal := greenVal := blueVal := greyVal.
].
"get hls (since we dither anyway, round them a bit"
Color withHLSFromRed:redVal green:greenVal blue:blueVal 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:100 / ((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:100 / ((hiValL - lowValL)/(rl - lowValL))
between:lowL
and:hiL
on:aDevice
into:aBlock
].
"found bound for light - dither with white"
^ self monoDitherFor:100 / ((100 - lowValL)/(rl - lowValL))
between:lowL
and:White
on:aDevice
into:aBlock
].
"found bound for light - dither with black"
hiL notNil ifTrue:[
^ self monoDitherFor:100 / ((hiValL - 0)/(rl - 0))
between:Black
and:hiL
on:aDevice
into:aBlock
].
"found bounds for saturation?"
(lowS notNil and:[hiS notNil]) ifTrue:[
"
'saturation dither' printNewline.
"
^ self monoDitherFor:100 / ((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:100 / (d / (rh - lowValH))
between:lowH
and:hiH
on:aDevice
into:aBlock
].
^ aBlock value:nil value:nil
!
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 }"
sR sG sB eR eG eB
rI "{ Class: SmallInteger }"
gI "{ Class: SmallInteger }"
bI "{ Class: SmallInteger }"
r1 g1 b1 r2 g2 b2 clr1 clr2
rI2 "{ Class: SmallInteger }"
gI2 "{ Class: SmallInteger }"
bI2 "{ Class: SmallInteger }"
idx "{ Class: SmallInteger }"
where reverse dWhat t|
(FixColors notNil and:[aDevice == Display]) ifTrue:[
nR := NumFixRed.
nG := NumFixGreen.
nB := NumFixBlue.
sR := 100 // (nR - 1).
sG := 100 // (nG - 1).
sB := 100 // (nB - 1).
rI := (redVal + (sR / 2)) // sR.
gI := (greenVal + (sG // 2)) // sG.
bI := (blueVal + (sB // 2)) // sB.
r1 := rI * sR.
g1 := gI * sG.
b1 := bI * sB.
"/ 'got: ' print. r1 print. ' ' print. g1 print.
"/ ' ' print. b1 printNL.
"/ 'at: ' print. rI print. ' ' print. gI print.
"/ ' ' print. bI printNL.
"
color r1/g1/b1 (at rI/gI/bI) is the nearest from the table
compute the error ...
"
eR := (r1 - redVal) abs.
eG := (g1 - greenVal) abs.
eB := (b1 - blueVal) abs.
"/ 'err: ' print. eR print. ' ' print. eG print.
"/ ' ' print. eB printNL.
((eR = 0)
and:[(eG = 0)
and:[eB = 0]]) ifTrue:[
"
this cannot happen - we where not in this method
if there was an exact match
"
idx := (((rI * nR) + gI) * nG + bI) + 1.
^ FixColors at:idx
].
"
find r2/g2/b2 (at rI2/gI2/bI2) to be used for dithering
"
r1 < (redVal - (sR / 4)) ifTrue:[
r2 := r1 + sR.
rI2 := rI + 1
] ifFalse:[
r1 > (redVal + (sR / 4)) ifTrue:[
r2 := r1 - sR.
rI2 := rI - 1
] ifFalse:[
r2 := r1.
rI2 := rI
]
].
g1 < (greenVal - (sG / 4)) ifTrue:[
g2 := g1 + sG.
gI2 := gI + 1
] ifFalse:[
g1 > (greenVal + (sG / 4)) ifTrue:[
g2 := g1 - sG.
gI2 := gI - 1
] ifFalse:[
g2 := g1.
gI2 := gI
]
].
b1 < (blueVal - (sB / 4)) ifTrue:[
b2 := b1 + sB.
bI2 := bI + 1
] ifFalse:[
b1 > (blueVal + (sB / 4)) ifTrue:[
b2 := b1 - sB.
bI2 := bI - 1
] ifFalse:[
b2 := b1.
bI2 := bI
]
].
"/ 'other: ' print. r2 print. ' ' print. g2 print.
"/ ' ' print. b2 printNL.
"/ 'at: ' print. rI2 print. ' ' print. gI2 print.
"/ ' ' print. bI2 printNL.
"
have two colors, and the errors eR, eG and eB
scale the error acc. the colors weight, and dither on the
component with the biggest error
"
eR := eR * 6.
eG := eG * 3.
eR > eG ifTrue:[
eR > eB ifTrue:[
"dither on red"
dWhat := #red.
reverse := r2 < r1.
where := (eR / 6) / sR * 100.
] ifFalse:[
"dither on blue"
dWhat := #blue.
reverse := b2 < b1.
where := eB / sB * 100
]
] ifFalse:[
eG > eB ifTrue:[
"dither on green"
dWhat := #green.
reverse := g2 < g1.
where := (eG / 3) / sG * 100
] ifFalse:[
"dither on blue"
dWhat := #blue.
reverse := b2 < b1.
where := eB / sB * 100
]
].
"/ 'dither ' print. dWhat print.
"/ ' step=' print. where printNL.
reverse ifTrue:[
dWhat == #red ifTrue:[
t := gI. gI := gI2. gI2 := t.
t := bI. bI := bI2. bI2 := t.
].
dWhat == #green ifTrue:[
t := rI. rI := rI2. rI2 := t.
t := bI. bI := bI2. bI2 := t.
].
dWhat == #blue ifTrue:[
t := gI. gI := gI2. gI2 := t.
t := rI. rI := rI2. rI2 := t.
].
].
"
get the two colors
"
idx := (((rI * nG) + gI) * nB + bI) + 1.
clr1 := FixColors at:idx.
"/ 'idx1=' print. idx printNL.
"/ 'clr1=' print. clr1 printNL.
idx := (((rI2 * nG) + gI2) * nB + bI2) + 1.
clr2 := FixColors at:idx.
"/ 'idx2=' print. idx printNL.
"/ 'clr2=' print. clr2 printNL.
"
now, use those for dithering
"
^ self monoDitherFor:where between:clr1 and:clr2 on:aDevice into:aBlock
].
^ aBlock value:nil value:nil
!
monoDitherFor:grey 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 bits
index "{ Class:SmallInteger }"|
"
having forms with: [1 .. 63] of 64 pixels (see Form),
we get dithers for: 1/64, 2/64, ... 63/64
"
index := (grey * 64 // 100) .
index <= 1 ifTrue:[
^ aBlock value:(color1 exactOn:aDevice) value:nil
].
index >= 64 ifTrue:[
^ aBlock value:(color2 exactOn:aDevice) value:nil
].
bits := Form ditherBitsForXin64:index.
form := Form width:8 height:8 fromArray:bits on:aDevice.
form colorMap:(Array with:(color1 exactOn:aDevice)
with:(color2 exactOn:aDevice)).
^ aBlock value:nil value:form
!
monoDitherFor:grey on:aDevice into:aBlock
"get a dither form or colorId for a grey color.
Returns 2 values (either color or ditherForm) through
aBlock."
"
this avoids later work, when the color is used
as a viewBackground
"
aDevice blackpixel == 0 ifTrue:[
^ self monoDitherFor:grey
between:Black and:White
on:aDevice into:aBlock
].
^ self monoDitherFor:100-grey
between:White and:Black
on:aDevice into:aBlock
!
restored
"private: color has been restored (either from snapin or binary store);
flush device stuff or reallocate a cell."
redVal notNil ifTrue:[
ditherForm := nil.
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 red:redVal green:greenVal blue:blueVal
]
]
!
setDevice:aDevice colorId:aNumber
"private:set device and colorId"
device := aDevice.
colorId := aNumber
!
setRed:r green:g blue:b device:aDevice
"private: set the components"
redVal notNil ifTrue:[
"oops cannot change (you want to make red be green - or what)"
self error:'Colors cannot change their components'.
^ self
].
redVal := r.
greenVal := g.
blueVal := b.
device := aDevice
!
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]"
^ ((0.3 * redVal) + (0.6 * greenVal) + (0.1 * blueVal)) / 100
!
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"
^ (redVal - aColor red) asInteger squared
+ (greenVal - aColor green) asInteger squared
+ (blueVal - aColor blue) asInteger squared.
!
greyIntensity
"return the grey intensity in percent [0..100]"
^ (0.3 * redVal) + (0.6 * greenVal) + (0.1 * blueVal)
!
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
!
isGreyColor
"return true, if this color is a grey one -
i.e. red = green = blue"
^ (redVal = greenVal) and:[redVal = blueVal]
"(Color grey:50) isGreyColor"
"(Color red) isGreyColor"
! !
!Color class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libview/Color.st,v 1.40 1996-04-23 20:12:21 cg Exp $'
! !
Color initialize!