--- a/Color.st Thu Aug 15 18:02:56 1996 +0200
+++ b/Color.st Thu Aug 15 18:05:46 1996 +0200
@@ -1,3920 +1,3920 @@
-"
- 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 writable'
- classVariableNames:'MaxValue Lobby Cells Black White LightGrey Grey DarkGrey Pseudo0
- Pseudo1 PseudoAll Red Green Blue RetryAllocation DitherBits
- ColorAllocationFailSignal'
- 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.
- 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
-
- [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: 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: 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: 11.7.1996 / 18:46:53 / 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'.
- ].
-
- 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: 11.7.1996 / 18:31:39 / 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 colorId:-1
- ].
- ^ PseudoAll
-!
-
-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 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: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: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 screen|
-
- screen := Screen current.
-
- id := screen colorNamed:aString.
- id isNil ifTrue:[
- ObjectMemory scavenge; finalize.
- id := screen colorNamed:aString.
- id isNil ifTrue:[^ nil].
- ].
-
- newColor := self basicNew.
- screen getScaledRGBFrom:id into:[:r :g :b |
- newColor setScaledRed:r scaledGreen:g scaledBlue:b device:screen
- ].
- newColor colorId:id.
- screen visualType ~~ #TrueColor ifTrue:[
- 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
-!
-
-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)
-!
-
-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"
-! !
-
-!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:'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:'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
-!
-
-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 := 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 r g b|
-
- "if Iam already assigned to that device ..."
- (device == aDevice and:[ditherForm isNil]) ifTrue:[^ self].
-
- r := red.
- g := green.
- b := blue.
-
- r := (r bitAnd:16rFF00) bitOr:(r bitShift:-8).
- g := (g bitAnd:16rFF00) bitOr:(g bitShift:-8).
- b := (b bitAnd:16rFF00) bitOr:(b bitShift:-8).
-
- "first look if not already there"
- newColor := Color existingColorScaledRed:r scaledGreen:g scaledBlue:b on:aDevice.
- (newColor notNil and:[newColor ditherForm isNil]) ifTrue:[^ newColor].
-
- "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 colorId:id.
- aDevice visualType ~~ #TrueColor ifTrue:[
- Lobby register:newColor.
- ].
- ^ newColor
-
- "Modified: 17.6.1996 / 16:09:05 / 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 colorId:id.
- aDevice visualType ~~ #TrueColor ifTrue:[
- Lobby register:newColor.
- ].
- ^ newColor
-
- "Modified: 14.6.1996 / 20:11:22 / 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|
-
- "/ the most common case first - someone is validating me
- "/ before drawing on aDevice
-
- aDevice notNil ifTrue:[
- aDevice == device ifTrue:[
- colorId notNil ifTrue:[
- ^ self
- ]
- ]
- ].
-
- "/ a special case for pseudo-colors (0 and 1 in bitmaps)
-
- (red isNil and:[colorId notNil]) ifTrue:[^ self].
-
- "/ on high-resolution true-color systems, dont care for dithring 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
- ] ifFalse:[
- newColor := (self class basicNew)
- setScaledRed:red
- scaledGreen:green
- scaledBlue:blue
- device:aDevice.
- newColor colorId:id.
- ^ newColor
- ]
- ]
- ]
- ].
-
- "/ want to release color ?
-
- (aDevice isNil and:[device notNil and:[colorId notNil]]) ifTrue:[
- deviceVisual ~~ #TrueColor ifTrue:[
- (device notNil and:[colorId notNil]) ifTrue:[
- Lobby unregister:self.
- device freeColor:colorId
- ].
- ].
- device := nil.
- colorId := nil.
- ^ self
- ].
-
- "/ round a bit within 1% in red & green, 2% in blue
-
- rV := (red / 100.0) rounded * 100.
- gV := (green / 100.0) rounded * 100.
- bV := (blue / 50.0) rounded * 50.
-
- "/ if Iam already assigned to that device ...
-
- (device == aDevice) ifTrue:[
-
- "/ mhmh - if I was dithered the last time (not enough colors then)
- "/ try again - maybe some colors were reclaimed in the meanwhile
-
- (ditherForm notNil
- and:[aDevice fixColors isNil
- and:[RetryAllocation]]) ifTrue:[
- 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 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:[
- aDevice fixColors 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:[
- (aDevice 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 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 ditherForm:form
- ] ifFalse:[
- newColor colorId:id.
- deviceVisual ~~ #TrueColor ifTrue:[
- Lobby register:newColor.
- ]
- ].
- ^ newColor
-
- "Created: 16.11.1995 / 20:16:42 / cg"
- "Modified: 11.7.1996 / 18:31:12 / 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'!
-
-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"
-
- 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'!
-
-colorId:anId
- "private: set the deviceId"
-
- colorId := anId
-!
-
-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"
-!
-
-device:aDevice
- "private: set the device"
-
- device := aDevice
-!
-
-ditherForm:aForm
- "private: set the ditherForm"
-
- ditherForm := aForm
-!
-
-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."
-
- red 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 scaledRed:red scaledGreen:green scaledBlue:blue
- ]
- ]
-!
-
-setDevice:aDevice colorId:aNumber
- "private:set device and colorId"
-
- device := aDevice.
- colorId := aNumber
-!
-
-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
-!
-
-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.71 1996-08-15 15:48:57 cg Exp $'
-! !
-Color initialize!
+"
+ 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 writable'
+ classVariableNames:'MaxValue Lobby Cells Black White LightGrey Grey DarkGrey Pseudo0
+ Pseudo1 PseudoAll Red Green Blue RetryAllocation DitherBits
+ ColorAllocationFailSignal'
+ 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.
+ 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
+
+ [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: 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: 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: 11.7.1996 / 18:46:53 / 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'.
+ ].
+
+ 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: 11.7.1996 / 18:31:39 / 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 colorId:-1
+ ].
+ ^ PseudoAll
+!
+
+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 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: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: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 screen|
+
+ screen := Screen current.
+
+ id := screen colorNamed:aString.
+ id isNil ifTrue:[
+ ObjectMemory scavenge; finalize.
+ id := screen colorNamed:aString.
+ id isNil ifTrue:[^ nil].
+ ].
+
+ newColor := self basicNew.
+ screen getScaledRGBFrom:id into:[:r :g :b |
+ newColor setScaledRed:r scaledGreen:g scaledBlue:b device:screen
+ ].
+ newColor colorId:id.
+ screen visualType ~~ #TrueColor ifTrue:[
+ 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
+!
+
+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)
+!
+
+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"
+! !
+
+!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:'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:'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
+!
+
+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 := 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 r g b|
+
+ "if Iam already assigned to that device ..."
+ (device == aDevice and:[ditherForm isNil]) ifTrue:[^ self].
+
+ r := red.
+ g := green.
+ b := blue.
+
+ r := (r bitAnd:16rFF00) bitOr:(r bitShift:-8).
+ g := (g bitAnd:16rFF00) bitOr:(g bitShift:-8).
+ b := (b bitAnd:16rFF00) bitOr:(b bitShift:-8).
+
+ "first look if not already there"
+ newColor := Color existingColorScaledRed:r scaledGreen:g scaledBlue:b on:aDevice.
+ (newColor notNil and:[newColor ditherForm isNil]) ifTrue:[^ newColor].
+
+ "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 colorId:id.
+ aDevice visualType ~~ #TrueColor ifTrue:[
+ Lobby register:newColor.
+ ].
+ ^ newColor
+
+ "Modified: 17.6.1996 / 16:09:05 / 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 colorId:id.
+ aDevice visualType ~~ #TrueColor ifTrue:[
+ Lobby register:newColor.
+ ].
+ ^ newColor
+
+ "Modified: 14.6.1996 / 20:11:22 / 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|
+
+ "/ the most common case first - someone is validating me
+ "/ before drawing on aDevice
+
+ aDevice notNil ifTrue:[
+ aDevice == device ifTrue:[
+ colorId notNil ifTrue:[
+ ^ self
+ ]
+ ]
+ ].
+
+ "/ a special case for pseudo-colors (0 and 1 in bitmaps)
+
+ (red isNil and:[colorId notNil]) ifTrue:[^ self].
+
+ "/ on high-resolution true-color systems, dont care for dithring 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
+ ] ifFalse:[
+ newColor := (self class basicNew)
+ setScaledRed:red
+ scaledGreen:green
+ scaledBlue:blue
+ device:aDevice.
+ newColor colorId:id.
+ ^ newColor
+ ]
+ ]
+ ]
+ ].
+
+ "/ want to release color ?
+
+ (aDevice isNil and:[device notNil and:[colorId notNil]]) ifTrue:[
+ deviceVisual ~~ #TrueColor ifTrue:[
+ (device notNil and:[colorId notNil]) ifTrue:[
+ Lobby unregister:self.
+ device freeColor:colorId
+ ].
+ ].
+ device := nil.
+ colorId := nil.
+ ^ self
+ ].
+
+ "/ round a bit within 1% in red & green, 2% in blue
+
+ rV := (red / 100.0) rounded * 100.
+ gV := (green / 100.0) rounded * 100.
+ bV := (blue / 50.0) rounded * 50.
+
+ "/ if Iam already assigned to that device ...
+
+ (device == aDevice) ifTrue:[
+
+ "/ mhmh - if I was dithered the last time (not enough colors then)
+ "/ try again - maybe some colors were reclaimed in the meanwhile
+
+ (ditherForm notNil
+ and:[aDevice fixColors isNil
+ and:[RetryAllocation]]) ifTrue:[
+ 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 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:[
+ aDevice fixColors 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:[
+ (aDevice 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 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 ditherForm:form
+ ] ifFalse:[
+ newColor colorId:id.
+ deviceVisual ~~ #TrueColor ifTrue:[
+ Lobby register:newColor.
+ ]
+ ].
+ ^ newColor
+
+ "Created: 16.11.1995 / 20:16:42 / cg"
+ "Modified: 11.7.1996 / 18:31:12 / 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'!
+
+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"
+
+ 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'!
+
+colorId:anId
+ "private: set the deviceId"
+
+ colorId := anId
+!
+
+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"
+!
+
+device:aDevice
+ "private: set the device"
+
+ device := aDevice
+!
+
+ditherForm:aForm
+ "private: set the ditherForm"
+
+ ditherForm := aForm
+!
+
+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."
+
+ red 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 scaledRed:red scaledGreen:green scaledBlue:blue
+ ]
+ ]
+!
+
+setDevice:aDevice colorId:aNumber
+ "private:set device and colorId"
+
+ device := aDevice.
+ colorId := aNumber
+!
+
+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
+!
+
+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.72 1996-08-15 16:05:46 cg Exp $'
+! !
+Color initialize!