--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Color.st Fri Jul 16 11:42:20 1993 +0200
@@ -0,0 +1,1403 @@
+"
+ COPYRIGHT (c) 1992-93 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'
+ classVariableNames:'lobby
+ Black White LightGrey Grey DarkGrey
+ Pseudo0 Pseudo1 PseudoAll
+ Red Green Blue DitherColors'
+ poolDictionaries:''
+ category:'Graphics-Support'
+!
+
+Color comment:'
+
+COPYRIGHT (c) 1992-93 by Claus Gittinger
+ All Rights Reserved
+
+see Color documentation for more info
+
+%W% %E%
+totally rewritten summer 92 by claus (from XColor)
+'!
+
+!Color class methodsFor:'documentation'!
+
+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 (which can have a colormap and need 2 or more plain colors).
+
+Instance variables:
+
+redVal <Number> the red component (0..100)
+greenVal <Number> the green component (0..100)
+blueVal <Number> the blue component (0..100)
+device <aDevice> the device I am on, or nil
+colorId <anObject> some device dependent identifier (or nil if dithered)
+ditherForm <aForm> the Form to dither this color (if non-nil)
+
+Class variables:
+
+lobby <Registry> keeps track of dead colors
+
+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)
+
+%W% %E%
+totally rewritten summer 92 by claus (from XColor)
+ "
+! !
+
+!Color class methodsFor:'initialization'!
+
+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.
+
+ Smalltalk at:#ColorValue put:self "for ST-80 compatibility"
+ ].
+!
+
+getPrimaryColors
+ 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.
+
+ Display ncells < 256 ifTrue:[
+ "on low-color resolution displays, allocate some colors
+ for dithering - otherwise, they may not be available when
+ we need them ..."
+
+ DitherColors := OrderedCollection new.
+ DitherColors add:((self red:100 green:100 blue:0) exactOn:Display).
+ DitherColors add:((self red:100 green:0 blue:100) exactOn:Display).
+ DitherColors add:((self red:0 green:100 blue:100) exactOn:Display).
+ ]
+ ]
+!
+
+flushDeviceColors
+ "unassign all colors from their device"
+
+ lobby contentsDo:[:aColor |
+ aColor resetDevice.
+ lobby changed:aColor
+ ]
+!
+
+update:something
+ (something == #restarted) ifTrue:[
+ self flushDeviceColors
+ ].
+ (something == #returnFromSnapshot) ifTrue:[
+ self getPrimaryColors
+ ]
+! !
+
+!Color class methodsFor:'instance creation'!
+
+white
+ "return the white-color"
+
+ White isNil ifTrue:[
+ White := (self red:100 green:100 blue:100) exactOn:Display
+ ].
+ ^ White
+!
+
+black
+ "return the black-color"
+
+ Black isNil ifTrue:[
+ Black := (self red:0 green:0 blue:0) exactOn:Display
+ ].
+ ^ Black
+!
+
+mediumGrey
+ "return medium-grey color"
+
+ ^ self grey
+!
+
+veryLightGrey
+ ^ self grey:87
+!
+
+lightGrey
+ "return light-grey color -
+ take value from resource file - 67% is very dark on some, very light
+ on other displays ... sigh"
+
+ LightGrey isNil ifTrue:[
+ LightGrey := self grey:(Resource name:'COLOR_LIGHTGREY_VALUE'
+ default:67
+ fromFile:'Smalltalk.rs')
+ ].
+ ^ LightGrey
+!
+
+darkGrey
+ "return dark-grey color -
+ take value from resource file - 33% is very dark on some, very light
+ on other displays ... sigh"
+
+ DarkGrey isNil ifTrue:[
+ DarkGrey := self grey:(Resource name:'COLOR_DARKGREY_VALUE'
+ default:33
+ fromFile:'Smalltalk.rs')
+ ].
+ ^ DarkGrey
+!
+
+veryDarkGrey
+ ^ self grey:13
+!
+
+grey
+ "return a medium grey color -
+ take value from resource file - 50% is very dark on some, very light
+ on other displays ... sigh"
+
+ Grey isNil ifTrue:[
+ Grey := self grey:(Resource name:'COLOR_GREY_VALUE'
+ default:50
+ fromFile:'Smalltalk.rs')
+ ].
+ ^ Grey
+!
+
+grey:grey
+ "return a grey color. The argument, grey is interpreted as
+ percent (0..100)."
+
+ ^ self red:grey green:grey blue:grey
+!
+
+gray
+ "return grey"
+
+ ^ self grey
+!
+
+lightGray
+ "return lightGrey"
+
+ ^ self lightGrey
+!
+
+darkGray
+ "return darkGrey"
+
+ ^ self darkGrey
+!
+
+red
+ "return red"
+
+ Red isNil ifTrue:[
+ Red := self red:100 green:0 blue:0.
+ ].
+ ^ Red
+!
+
+green
+ "return green"
+
+ Green isNil ifTrue:[
+ Green := self red:0 green:100 blue:0
+ ].
+ ^ Green
+!
+
+blue
+ "return blue"
+
+ Blue isNil ifTrue:[
+ Blue := self red:0 green:0 blue:100
+ ].
+ ^ Blue
+!
+
+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 to 1/300 i.e. to about 0.33%"
+
+ rr := (r * 3) rounded / 3.0.
+ rg := (g * 3) rounded / 3.0.
+ rb := (b * 3) rounded / 3.0.
+
+ "look if already known"
+ lobby contentsDo:[: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.
+ lobby register:newColor.
+ ^ newColor
+!
+
+name:aString
+ "return a named color - or try do do as good as possible"
+
+ ^ self nameOrDither:aString
+!
+
+nameOrDither:aString
+ "return a named color - if the exact color is not available,
+ return a dithered color"
+
+ Display getRGBFromName:aString into:[:r :g :b |
+ r notNil ifTrue:[
+ ^ self red:r green:g blue:b
+ ].
+ ].
+ self error:'no color named ' , aString.
+ ^ nil
+
+ "Color nameOrDither:'Brown'"
+!
+
+nameOrNearest:aString
+ "return a named color - or its nearest match"
+
+ |id newColor|
+
+ id := Display colorNamed:aString.
+ id isNil ifTrue:[
+ ObjectMemory scavenge.
+ 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
+!
+
+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 is not the best possible solution)."
+
+ "first try exact color"
+
+ |delta minDelta bestSoFar rr rg rb|
+
+ "round to 1/300 i.e. to about 0.3%"
+
+ rr := (r * 3) rounded / 3.0.
+ rg := (g * 3) rounded / 3.0.
+ rb := (b * 3) rounded / 3.0.
+
+ lobby contentsDo:[:aColor |
+ (aColor device == aDevice) ifTrue:[
+ (aColor colorId notNil) ifTrue:[
+ (rr = aColor red) ifTrue:[
+ (rg = aColor green) ifTrue:[
+ (rb = aColor blue) ifTrue:[
+ ^ aColor
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ "exact color was not available, search for the one with the
+ smallest delta"
+
+ minDelta := 999999.
+ lobby contentsDo:[:aColor |
+ (aColor device == aDevice) ifTrue:[
+ (aColor colorId notNil) ifTrue:[
+ delta := ((rr - aColor red) squared * 0.3)
+ + ((rg - aColor green) squared * 0.6)
+ + ((rb - aColor blue) squared * 0.1).
+
+ delta < minDelta ifTrue:[
+ bestSoFar := aColor.
+ minDelta := delta
+ ]
+ ]
+ ]
+ ].
+
+ minDelta < error squared ifTrue:[
+ ^ bestSoFar
+ ].
+
+ ^ nil
+!
+
+hue:h light:l saturation:s
+ "return a color from hue, light and saturation values"
+
+ self withRGBFromHue:h light:l saturation:s do:[:r :g :b |
+ ^ self red:r green:g blue:b
+ ]
+!
+
+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)"
+
+ ^ self basicNew colorId:0
+!
+
+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)"
+
+ ^ self basicNew colorId:-1
+!
+
+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:[
+ Pseudo0 isNil ifTrue:[
+ Pseudo0 := self basicNew colorId:0
+ ].
+ ^ Pseudo0
+ ].
+ id == 1 ifTrue:[
+ Pseudo1 isNil ifTrue:[
+ Pseudo1 := self basicNew colorId:1
+ ].
+ ^ Pseudo1
+ ].
+ id == -1 ifTrue:[
+ PseudoAll isNil ifTrue:[
+ PseudoAll := self basicNew colorId:-1
+ ].
+ ^ PseudoAll
+ ].
+ ^ self basicNew colorId:id
+! !
+
+!Color class methodsFor:'private'!
+
+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) rounded / 3.0.
+ rg := (g * 3) rounded / 3.0.
+ rb := (b * 3) rounded / 3.0.
+
+ lobby contentsDo:[:aColor |
+ (aColor device == aDevice) ifTrue:[
+ aColor colorId notNil ifTrue:[
+ (rr = aColor red) ifTrue:[
+ (rg = aColor green) ifTrue:[
+ (rb = aColor blue) ifTrue:[
+ ^ aColor
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+ ^ nil
+!
+
+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|
+
+ rr := (r * 3) rounded / 3.0.
+ rg := (g * 3) rounded / 3.0.
+ rb := (b * 3) rounded / 3.0.
+
+ minDelta := 100*100*100.
+ lobby contentsDo:[:aColor |
+ (aColor device == aDevice) ifTrue:[
+ (aColor colorId notNil) ifTrue:[
+ diff := (rr - aColor red) asInteger squared
+ + (rg - aColor green) asInteger squared
+ + (rb - aColor blue) asInteger squared.
+ diff < minDelta ifTrue:[
+ bestColor := aColor.
+ minDelta := diff
+ ]
+ ]
+ ]
+ ].
+
+ "allow an error of 10% per component"
+ minDelta < (100+100+100) ifTrue:[ ^ bestColor ].
+ ^ nil
+! !
+
+!Color class methodsFor:'color space conversions'!
+
+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
+!
+
+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
+! !
+
+!Color methodsFor:'instance release'!
+
+disposed
+ "a color died - free the device color"
+
+ colorId notNil ifTrue:[
+ device freeColor:colorId
+ ]
+! !
+
+!Color methodsFor:'private'!
+
+resetDevice
+ "private: color has been restored (either from snapin or binary store);
+ flush device stuff"
+
+ ditherForm := nil.
+ device := nil.
+ colorId := nil
+!
+
+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
+!
+
+colorId:anId
+ "private: set the deviceId"
+
+ colorId := anId
+!
+
+ditherForm:aForm
+ "private: set the ditherForm"
+
+ ditherForm := aForm
+!
+
+device:aDevice
+ "private: set the device"
+
+ device := aDevice
+!
+
+ditherRed:redVal green:greenVal blue:blueVal 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"
+
+ |full none rest primary val gr values primaries sum
+ rr rg rb rh rl rs color1 color2
+ lowL hiL lowValL hiValL lowS hiS lowValS hiValS lowH hiH lowValH hiValH d|
+
+ "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) rounded / 3.0.
+ ].
+ rl := (l * 3) rounded / 3.0.
+ rs := (s * 3) rounded / 3.0.
+ ].
+
+ rh isNil ifTrue:[
+ "achromatic, dither between achromatic colors"
+
+ lowL := nil.
+ hiL := nil.
+
+ "find the 2 bounding colors"
+ lobby contentsDo:[: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) 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 contentsDo:[: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) rounded / 3.0.
+ ] ifFalse:[
+ ch := nil
+ ].
+ cl := (l * 3) rounded / 3.0.
+ cs := (s * 3) 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 and:[hiL notNil]) ifTrue:[
+ rl = lowValL ifTrue:[
+ ^ aBlock value:lowL value:nil
+ ].
+ ^ self monoDitherFor:100 / ((hiValL - lowValL)/(rl - lowValL))
+ between:lowL
+ 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 one for light, dither with black or white"
+
+ lowL notNil ifTrue:[
+ ^ self monoDitherFor:100 / ((100 - lowValL)/(rl - lowValL))
+ between:lowL
+ and:White
+ on:aDevice
+ into:aBlock
+ ].
+
+ hiL notNil ifTrue:[
+ ^ self monoDitherFor:100 / ((hiValL - 0)/(rl - 0))
+ between:Black
+ and:hiL
+ 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
+!
+
+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."
+
+ ^ self monoDitherFor:grey
+ between:Black and:White
+ on:aDevice into:aBlock
+!
+
+monoDitherFor:grey between:color1 and:color2 on:aDevice into:aBlock
+ "get a dither form or colorId for a grey color.
+ Returns 2 values (either color or ditherForm) through
+ aBlock."
+
+ |form bits color clr1 clr2
+ gr index|
+
+ "having forms with: [1 .. 31] of 64 pixels,
+ we get dithers for: 0, 1/64, 2/64, ... 32/64"
+
+ grey <= 50 ifTrue:[
+ clr1 := color1.
+ clr2 := color2.
+ gr := grey.
+ ] ifFalse:[
+ clr1 := color2.
+ clr2 := color1.
+ gr := 100 - grey.
+ ].
+
+ gr := gr * 64.
+ index := (gr // 100) asInteger.
+ index < 1 ifTrue:[
+ color := color1 exactOn:aDevice.
+ ] ifFalse:[
+ index > 63 ifTrue:[
+ color := color2 exactOn:aDevice
+ ] ifFalse:[
+ bits := Form ditherBitsForXin64:index
+ ]
+ ].
+ bits notNil ifTrue:[
+ form := Form width:8 height:8 fromArray:bits on:aDevice.
+ form colorMap:(Array with:(clr1 exactOn:aDevice)
+ with:(clr2 exactOn:aDevice))
+ ].
+ ^ aBlock value:color value:form
+!
+
+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."
+
+ |form 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.
+! !
+
+!Color methodsFor:'getting a device color'!
+
+on:aDevice
+ "create a new Color representing the same color as
+ myself on aDevice; if one already exists, return the one"
+
+ |newColor index id grey form sav|
+
+ "if Iam already assigned to that device ..."
+ (device == aDevice) ifTrue:[^ 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:[
+ 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].
+
+ aDevice hasColors ifTrue:[
+ "ask that device for the exact 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.
+ id := aDevice colorRed:redVal green:greenVal blue:blueVal
+ ].
+ 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:redVal green:greenVal blue:blueVal 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 := (0.3 * redVal) + (0.6 * greenVal) + (0.1 * blueVal).
+ "avoid things like 100.00000001"
+ grey := ((grey * 100) rounded) / 100.0.
+
+ ((grey = 0) or:[(grey = 100) or:[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.
+ id := aDevice colorRed:redVal green:greenVal blue:blueVal
+ ].
+ ]
+ ].
+
+ "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.
+ ^ 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.
+ ^ newColor
+!
+
+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 index 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.
+ 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.
+
+ "have to tell lobby - otherwise it keeps old info around"
+ lobby changed: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 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 index id|
+
+ "if Iam 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 free unused colors
+ and try again ..."
+ ObjectMemory scavenge.
+ 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.
+
+ "have to tell lobby - otherwise it keeps old info around"
+ lobby changed: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
+! !
+
+!Color methodsFor:'comparing'!
+
+= aColor
+ "two colors are considered equal, if the color components are;
+ independent of the device, the color is on"
+
+ (aColor isKindOf:Color) ifTrue:[
+ (redVal = aColor red) ifTrue:[
+ (greenVal = aColor green) ifTrue:[
+ (blueVal = aColor blue) ifTrue:[
+ ^ true
+ ]
+ ]
+ ]
+ ].
+ ^ false
+! !
+
+!Color methodsFor:'instance creation'!
+
+darkened
+ "return a new color, which is slightly darker than the receiver"
+
+ ^ 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"
+
+ ^ Color red:((100 - redVal) / 2 + redVal)
+ green:((100 - greenVal) / 2 + greenVal)
+ blue:((100 - blueVal) / 2 + blueVal)
+
+ "(Color red) lightened"
+! !
+
+!Color methodsFor:'queries'!
+
+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 methodsFor:'accessing'!
+
+red
+ "return the red component in percent"
+
+ ^ redVal
+!
+
+green
+ "return the green component in percent"
+
+ ^ greenVal
+!
+
+blue
+ "return the blue component in percent"
+
+ ^ blueVal
+!
+
+greyIntensity
+ "return the grey intensity in percent"
+
+ ^ (0.3 * redVal) + (0.6 * greenVal) + (0.1 * blueVal)
+!
+
+hue
+ "return the hue"
+
+ self class withHLSFromRed:redVal green:greenVal blue:blueVal do:[:h :l :s |
+ ^ h
+ ]
+!
+
+light
+ "return the hue"
+
+ self class withHLSFromRed:redVal green:greenVal blue:blueVal do:[:h :l :s |
+ ^ l
+ ]
+!
+
+saturation
+ "return the hue"
+
+ self class withHLSFromRed:redVal green:greenVal blue:blueVal do:[:h :l :s |
+ ^ s
+ ]
+!
+
+colorId
+ "return the device-dependent color-id"
+
+ ^ colorId
+!
+
+ditherForm
+ "return the form to dither the color"
+
+ ^ ditherForm
+!
+
+device
+ "return the device I am on"
+
+ ^ device
+!
+
+deviceRedValue
+ "return the value of the red component in device metrics"
+
+ ^ device redComponentOfColor:colorId
+!
+
+deviceGreenValue
+ "return the value of the green component in device metrics"
+
+ ^ device greenComponentOfColor:colorId
+!
+
+deviceBlueValue
+ "return the value of the blue component in device metrics"
+
+ ^ device blueComponentOfColor:colorId
+!
+
+deviceRedValue:r deviceGreenValue:g deviceBlueValue:b
+ "set r/g/b components in device metrics"
+
+ device setColor:colorId red:r green:g blue:b
+! !
+
+!Color methodsFor:'printing & storing'!
+
+printString
+ "return a string representing the receiver"
+
+ ^ self storeString
+!
+
+storeString
+ "return a string representing an expression to reconstruct the receiver"
+
+ redVal isNil ifTrue:[
+ colorId notNil ifTrue:[
+ ^ 'Color colorId:' , colorId storeString
+ ]
+ ].
+ (redVal = greenVal and:[redVal = blueVal]) ifTrue:[
+ ^ 'Color grey:' , redVal storeString
+ ].
+ ^ 'Color red:' , redVal storeString ,
+ ' green:' , greenVal storeString ,
+ ' blue:' , blueVal storeString
+! !