# HG changeset patch # User Claus Gittinger # Date 1504029640 -7200 # Node ID 099bb6b947982992d4179e942d15880a62be1b3a # Parent 24692d82a3d5db5f399365ce00b765340950a3f3 #FEATURE by cg class: Color class added: #best:ditherColorsForImage: #browserColors comment/format in: #colorCubeWithRed:green:blue: #getColors6x6x4 #getColors6x6x5 #getColors6x6x6 #getColors6x7x4 #getColors7x8x4 #getColorsRed:green:blue: #getColorsRed:green:blue:on: #getGrayColors:on: #getPrimaryColorsOn: changed: #standardDitherColorsForDepth8 category of:16 methods diff -r 24692d82a3d5 -r 099bb6b94798 Color.st --- a/Color.st Tue Aug 29 18:11:04 2017 +0200 +++ b/Color.st Tue Aug 29 20:00:40 2017 +0200 @@ -16,10 +16,10 @@ Object subclass:#Color instanceVariableNames:'red green blue device colorId ditherForm replacementColor writable' - classVariableNames:'MaxValue Cells Black White LightGrey Grey DarkGrey Pseudo0 - Pseudo1 PseudoAll Red Green Blue Yellow Orange RetryAllocation - DitherBits ColorErrorSignal ColorAllocationFailSignal - InvalidColorNameSignal StandardColorValues Transparent' + classVariableNames:'Black Blue Cells ColorAllocationFailSignal ColorErrorSignal + DarkGrey DitherBits Green Grey InvalidColorNameSignal LightGrey + MaxValue Orange Pseudo0 Pseudo1 PseudoAll Red RetryAllocation + StandardColorValues Transparent White Yellow' poolDictionaries:'' category:'Graphics-Support' ! @@ -164,404 +164,6 @@ !Color class methodsFor:'initialization'! -allocateColorsIn:aColorVector on:aDevice - "{ Pragma: +optSpace }" - - "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." - - |clr round devClr| - - round := 0. - 1 to:aColorVector size do:[:dstIndex | - clr := aColorVector at:dstIndex. - devClr := clr exactOn:aDevice. - devClr isNil ifTrue:[ - round == 0 ifTrue:[ - Logger info:'scavenge to reclaim colors'. - ObjectMemory scavenge. - round := 1. - devClr := clr exactOn:aDevice. - ]. - devClr isNil ifTrue:[ - round == 1 ifTrue:[ - Logger info:'collect garbage to reclaim colors'. - ObjectMemory - garbageCollect; finalize. - round := 2. - devClr := clr exactOn:aDevice. - ]. - devClr isNil ifTrue:[ - round == 2 ifTrue:[ - Logger info:'lowSpaceCleanup and collect garbage to reclaim colors'. - ObjectMemory - performLowSpaceCleanup; - garbageCollect; finalize. - round := 3. - devClr := clr exactOn:aDevice. - ]. - devClr isNil ifTrue:[ - ColorAllocationFailSignal raiseErrorString:'failed to allocate fix color'. - ^ self - ]. - ]. - ]. - ]. - aColorVector at:dstIndex put:devClr. - ]. - - "Modified: / 02-03-2017 / 17:43:36 / stefan" -! - -colorCubeWithRed:nRed green:nGreen blue:nBlue - "{ Pragma: +optSpace }" - - |nR "{Class: SmallInteger }" - nG "{Class: SmallInteger }" - nB "{Class: SmallInteger }" - dR dG dB red green blue dstIndex clr round - colorCube| - - nR := nRed. - nG := nGreen. - nB := nBlue. - - dR := 100.0 / (nR - 1). - dG := 100.0 / (nG - 1). - dB := 100.0 / (nB - 1). - - colorCube := 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. - colorCube at:dstIndex put:clr. - dstIndex := dstIndex + 1 - ] - ] - ]. - ^ colorCube - - "Created: 11.7.1996 / 17:55:32 / cg" - "Modified: 10.1.1997 / 15:37:13 / cg" -! - -flushDeviceColors - "unassign all colors from their device" - - self allInstances do:[:aColor | - aColor restored - ]. - - "Modified: 24.2.1997 / 18:27:06 / cg" -! - -flushDeviceColorsFor:aDevice - self allInstancesDo:[:aColor | - aColor device == aDevice ifTrue:[ - aColor restored - ] - ] -! - -getColors6x6x4 - "{ Pragma: +optSpace }" - - "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 - "{ Pragma: +optSpace }" - - "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 - "{ Pragma: +optSpace }" - - "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 - "{ Pragma: +optSpace }" - - "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 - "{ Pragma: +optSpace }" - - "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 - "{ Pragma: +optSpace }" - - "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:Screen current - - " - Color getColorsRed:2 green:2 blue:2 - " - - "Modified: 11.7.1996 / 17:58:09 / cg" -! - -getColorsRed:nRed green:nGreen blue:nBlue on:aDevice - "{ Pragma: +optSpace }" - - "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 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 := self colorCubeWithRed:nRed green:nGreen blue:nBlue. - self allocateColorsIn:fixColors on:aDevice. - - aDevice setFixColors:fixColors numRed:nR numGreen:nG numBlue:nB - - " - Color getColorsRed:2 green:2 blue:2 on:Display - " - - "Created: 11.7.1996 / 17:55:32 / cg" - "Modified: 10.1.1997 / 15:37:13 / cg" -! - -getGrayColors:nGray on:aDevice - "{ Pragma: +optSpace }" - - "preallocates nGray gray colors 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." - - |nG "{Class: SmallInteger }" - d fixGrayColors| - - aDevice visualType == #TrueColor ifTrue:[^ self]. - - nG := nGray. - d := 100.0 / (nG - 1). - - fixGrayColors := self grayColorVector:nGray. - self allocateColorsIn:fixGrayColors on:aDevice. - - aDevice setFixGrayColors:fixGrayColors - - " - Color getGrayColors:16 on:Display - " - - "Created: 23.6.1997 / 15:29:50 / cg" -! - -getPrimaryColorsOn:aDevice - "{ Pragma: +optSpace }" - - "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 clr dDepth - lastPix "{ Class: SmallInteger }" | - - (aDevice notNil and:[aDevice ditherColors isNil]) ifTrue:[ - white := (self red:100 green:100 blue:100) exactOn:aDevice. - white colorId isNil ifTrue:[ - 'Color [warning]: cannot allocate white color' errorPrintCR. - ]. - black := (self red:0 green:0 blue:0) exactOn:aDevice. - black colorId isNil ifTrue:[ - 'Color [warning]: cannot allocate black color' errorPrintCR. - ]. - - 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. - (red isNil - or:[green isNil - or:[blue isNil - or:[red colorId isNil - or:[green colorId isNil - or:[blue colorId isNil]]]]]) ifTrue:[ - 'Color [warning]: cannot allocate primary color(s)' errorPrintCR. - dDepth := aDevice depth. - ((dDepth >= 4) and:[dDepth <= 8]) ifTrue:[ - "/ - "/ see what we have ... - "/ - lastPix := (1 bitShift:dDepth) - 1. - 0 to:lastPix do:[:pixel | - colors := OrderedCollection new. - aDevice getRGBFrom:pixel into:[:r :g :b | - colors add:((Color red:r green:g blue:b) exactOn:aDevice). - ] - ]. - red := (self red:100 green:0 blue:0) nearestOn:aDevice. - green := (self red:0 green:100 blue:0) nearestOn:aDevice. - blue := (self red:0 green:0 blue:100) nearestOn:aDevice. - ] ifFalse:[ - aDevice hasColors:false. - aDevice hasGrayscales:false. - red := green := blue := nil. - ] - ] - ]. - - 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. - clr := (self gray:50) exactOn:aDevice. - (clr notNil and:[clr colorId notNil]) ifTrue:[ - colors add:clr - ]. - - 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). - ]. - - aDevice hasGrayscales 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 notNil ifTrue:[ - colors := colors select:[:clr | clr notNil and:[clr colorId notNil]]. - aDevice setDitherColors:(colors asArray). - ] - ] - ] - - "Created: 11.7.1996 / 18:09:28 / cg" - "Modified: 21.10.1997 / 02:42:28 / cg" -! - -grayColorVector:nGray - |nG "{Class: SmallInteger }" - d gray dstIndex clr round - grayColors| - - nG := nGray. - d := 100.0 / (nG - 1). - - grayColors := Array new:nG. - - round := 0. - - dstIndex := 1. - 1 to:nG do:[:sG | - gray := d * (sG - 1). - clr := self red:gray green:gray blue:gray. - grayColors at:dstIndex put:clr. - dstIndex := dstIndex + 1 - ]. - ^ grayColors - - " - Color getGrayColors:16 on:Display - " - - "Created: 23.6.1997 / 15:29:50 / cg" -! - initialize "setup tracker of known colors and initialize classvars with heavily used colors" @@ -629,30 +231,6 @@ "Modified: 6.3.1997 / 02:28:58 / cg" ! -standardDitherColorsForDepth8 - "return a set of colors useful for dithering (roughly 200 colors); - This includes a color cube and the main grayScale colors." - - |ditherColors| - - ditherColors := self colorCubeWithRed:6 green:8 blue:4. - ditherColors := ditherColors , - (Array - with:(Color gray:20) - with:(Color gray:25) - with:(Color gray:40) - with:(Color gray:50) - with:(Color gray:60) - with:(Color gray:75) - with:(Color gray:80) - with:(Color rgbValue:16rBFBFBF)). - ^ ditherColors - - " - self standardDitherColorsForDepth8 - " -! - update:something with:aParameter from:changedObject "handle image restarts and flush any device resource handles" @@ -683,33 +261,6 @@ "Created: 15.6.1996 / 15:14:03 / cg" "Modified: 24.2.1997 / 22:08:05 / cg" -! - -vgaColors - "{ Pragma: +optSpace }" - - |colors| - - colors := Array new:16. - colors at:1 put:(Color rgbValue:16rFFFFFF). - colors at:2 put:(Color rgbValue:16rC0C0C0). - colors at:3 put:(Color rgbValue:16r808080). - colors at:4 put:(Color rgbValue:16r000000). - colors at:5 put:(Color rgbValue:16rFF0000). - colors at:6 put:(Color rgbValue:16r800000). - colors at:7 put:(Color rgbValue:16r008000). - colors at:8 put:(Color rgbValue:16r00FF00). - colors at:9 put:(Color rgbValue:16r0000FF). - colors at:10 put:(Color rgbValue:16r000080). - colors at:11 put:(Color rgbValue:16rFF00FF). - colors at:12 put:(Color rgbValue:16r800080). - colors at:13 put:(Color rgbValue:16rFFFF00). - colors at:14 put:(Color rgbValue:16r808000). - colors at:15 put:(Color rgbValue:16r00FFFF). - colors at:16 put:(Color rgbValue:16r008080). - ^ colors - - "Created: / 07-07-2006 / 13:36:15 / cg" ! ! !Color class methodsFor:'instance creation'! @@ -3944,6 +3495,787 @@ "Modified: 11.7.1996 / 18:20:14 / cg" ! ! +!Color class methodsFor:'utilities'! + +allocateColorsIn:aColorVector on:aDevice + "{ Pragma: +optSpace }" + + "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." + + |clr round devClr| + + round := 0. + 1 to:aColorVector size do:[:dstIndex | + clr := aColorVector at:dstIndex. + devClr := clr exactOn:aDevice. + devClr isNil ifTrue:[ + round == 0 ifTrue:[ + Logger info:'scavenge to reclaim colors'. + ObjectMemory scavenge. + round := 1. + devClr := clr exactOn:aDevice. + ]. + devClr isNil ifTrue:[ + round == 1 ifTrue:[ + Logger info:'collect garbage to reclaim colors'. + ObjectMemory + garbageCollect; finalize. + round := 2. + devClr := clr exactOn:aDevice. + ]. + devClr isNil ifTrue:[ + round == 2 ifTrue:[ + Logger info:'lowSpaceCleanup and collect garbage to reclaim colors'. + ObjectMemory + performLowSpaceCleanup; + garbageCollect; finalize. + round := 3. + devClr := clr exactOn:aDevice. + ]. + devClr isNil ifTrue:[ + ColorAllocationFailSignal raiseErrorString:'failed to allocate fix color'. + ^ self + ]. + ]. + ]. + ]. + aColorVector at:dstIndex put:devClr. + ]. + + "Modified: / 02-03-2017 / 17:43:36 / stefan" +! + +best:numColors ditherColorsForImage:anImage + "work in progress" + + |bigCube boxMax numBits numGray usedColors + minRed maxRed minGreen maxGreen minBlue maxBlue + boundaryColors boxesSegmented segments boxesToDo enumerateNeighbors + firstTry segmentColors| + + ((anImage photometric == #blackIs0) or:[anImage photometric == #whiteIs0]) ifTrue:[ + numGray := (1 bitShift:anImage depth) min:numColors. + ^ self grayColorVector:numGray + ]. + (anImage photometric == #palette) ifTrue:[ + "/ all gray? + (anImage colorMap conform:[:clr | clr isGrayColor]) ifTrue:[ + numGray := ((1 bitShift:anImage depth) min:anImage colorMap size) min:numColors. + ^ self grayColorVector:numGray + ]. + ]. + + boxMax := 63. + numBits := 6. + firstTry := true. + + [ + "/ first, a rough cube with less precision... + bigCube := IntegerArray new:(boxMax+1)*(boxMax+1)*(boxMax+1). + + firstTry ifTrue:[ + usedColors := Set new. + minRed := minGreen := minBlue := 255. + maxRed := maxGreen := maxBlue := 0. + ]. + + anImage + rgbValuesFromX:0 y:0 + toX:(anImage width-1) y:(anImage height-1) + do:[:x :y :rgb | + |redByte greenByte blueByte r g b idx oldCount| + + redByte := (rgb rightShift:16) bitAnd:16rFF. + greenByte := (rgb rightShift:8) bitAnd:16rFF. + blueByte := (rgb) bitAnd:16rFF. + + r := redByte rightShift:(8-numBits). + g := greenByte rightShift:(8-numBits). + b := blueByte rightShift:(8-numBits). + idx := (((r * (boxMax+1))+g)*(boxMax+1))+b+1. + oldCount := bigCube at:idx. + + firstTry ifTrue:[ + redByte < minRed ifTrue:[minRed := redByte] ifFalse:[redByte > maxRed ifTrue:[maxRed := redByte]]. + greenByte < minGreen ifTrue:[minGreen := greenByte] ifFalse:[greenByte > maxGreen ifTrue:[maxGreen := greenByte]]. + blueByte < minBlue ifTrue:[minBlue := blueByte] ifFalse:[blueByte > maxBlue ifTrue:[maxBlue := blueByte]]. + + oldCount == 0 ifTrue:[ + usedColors add:rgb. + ]. + ]. + bigCube at:idx put:oldCount+1. + ]. + + firstTry ifTrue:[ + usedColors size <= numColors ifTrue:[ + "/ huh - that will be easy!! + ^ usedColors asArray. + ]. + + "/ if not even the basic colors fit, dither to b&w + numColors == 2 ifTrue:[ + ^ { Color black . Color white } + ]. + "/ if not even the basic colors fit, dither to b&w + numColors == 4 ifTrue:[ + ^ { Color black . Color red . Color green . Color blue. } + ]. + + "/ we need the at least the 8 corners for dithering, at least... + boundaryColors := OrderedCollection new. + { minRed . maxRed } do:[:r | + { minGreen . maxGreen } do:[:g | + { minBlue . maxBlue } do:[:b | + boundaryColors add:(Color redByte:r greenByte:g blueByte:b) + ]. + ]. + ]. + numColors == 8 ifTrue:[ + ^ boundaryColors + ]. + ]. + firstTry := false. + + "/ + "/ find and generate connected subarea box sets + "/ + boxesSegmented := Set new. + segments := OrderedCollection new. + + boxesToDo := OrderedCollection new. + + "/ each box has 9+9+3+3+1+1 neighbors + "/ + enumerateNeighbors := + [:rgb :aBlock| + |r g b| + + r := (rgb rightShift:(numBits+numBits)) bitAnd:boxMax. + g := (rgb rightShift:numBits) bitAnd:boxMax. + b := (rgb) bitAnd:boxMax. + r-1 to:r+1 do:[:n_r | + (n_r between:0 and:boxMax) ifTrue:[ + g-1 to:g+1 do:[:n_g | + (n_g between:0 and:boxMax) ifTrue:[ + b-1 to:b+1 do:[:n_b | + (n_b between:0 and:boxMax) ifTrue:[ + ((n_r == r) and:[n_g == g and:[n_b == b]]) ifFalse:[ + aBlock value:((((n_r * (boxMax+1))+n_g)*(boxMax+1))+n_b). + ] + ] + ] + ] + ] + ] + ]. + ]. + + 0 to:boxMax do:[:r | + 0 to:boxMax do:[:g | + 0 to:boxMax do:[:b | + |rgb| + + rgb := (((r * (boxMax+1))+g)*(boxMax+1))+b. + (bigCube at:rgb+1) ~~ 0 ifTrue:[ + (boxesSegmented includes:rgb) ifFalse:[ + |currentSegment| + + "/ start a segment + currentSegment := OrderedCollection new. + segments add:currentSegment. + + boxesToDo add:rgb. + boxesSegmented add:rgb. + + [boxesToDo notEmpty] whileTrue:[ + |rgb| + + rgb := boxesToDo removeLast. + currentSegment add:rgb. + + enumerateNeighbors value:rgb value:[:n_rgb | + (bigCube at:n_rgb+1) ~~ 0 ifTrue:[ + "/ neighbor has used pixels as well... + (boxesSegmented includes:n_rgb) ifFalse:[ + "/ neighbor was not processed... + boxesSegmented add:rgb. + boxesToDo add:n_rgb. + ]. + ]. + ]. + ]. + ]. + ]. + ] + ] + ]. + + (segments size < numColors) ifTrue:[ + segmentColors := segments + collect:[:eachSegment | + |n sumRed sumGreen sumBlue centerRed centerGreen centerBlue| + + "/ compute central point + "/ as center of mass (taking count per box as weight) + "/ this central point will be placed into the colormap. + sumRed := sumGreen := sumBlue := 0. + n := eachSegment size. + + eachSegment do:[:rgbOfBoxInSegment | + |r g b| + + r := (rgbOfBoxInSegment rightShift:(numBits+numBits)) bitAnd:boxMax. + g := (rgbOfBoxInSegment rightShift:numBits) bitAnd:boxMax. + b := (rgbOfBoxInSegment) bitAnd:boxMax. + sumRed :=sumRed + r. + sumGreen := sumGreen + g. + sumBlue := sumBlue + b. + ]. + centerRed := (sumRed / n) rounded. + centerGreen := (sumGreen / n) rounded. + centerBlue := (sumBlue / n) rounded. + + centerRed := (centerRed bitShift:(8-numBits)) + bitOr:(centerRed bitShift:(8-numBits-numBits)). + centerGreen := (centerGreen bitShift:(8-numBits)) + bitOr:(centerGreen bitShift:(8-numBits-numBits)). + centerBlue := (centerBlue bitShift:(8-numBits)) + bitOr:(centerBlue bitShift:(8-numBits-numBits)). + + Color redByte:centerRed greenByte:centerGreen blueByte:centerBlue. + ] + as:OrderedCollection. + "/ can we add black & white? + (segmentColors includes:Color white) ifFalse:[ + segmentColors add:Color white. + ]. + (segmentColors includes:Color black) ifFalse:[ + segmentColors add:Color black. + ]. + "/ can we add the boundary colors? + boundaryColors do:[:each | + (segmentColors size < numColors) ifTrue:[ + (segmentColors includes:each) ifFalse:[ + segmentColors add:each. + ]. + ]. + ]. + ^ segmentColors. + ]. + + numBits := numBits - 1. + boxMax := ((boxMax+1) // 2) - 1. + + numBits == 0 ifTrue:[ + self error. + ]. + ] loop. + + " + Color + best:16 + ditherColorsForImage:(Image fromFile:'../../goodies/bitmaps/pcxImages/lena_depth8_palette.pcx') + + Color + best:16 + ditherColorsForImage:(Image fromFile:'../../goodies/bitmaps/pcxImages/lena_depth24_rgb.pcx') + + Color + best:16 + ditherColorsForImage:((Image fromFile:'../../goodies/bitmaps/pcxImages/lena_depth8_palette.pcx') asGrayImageDepth:8) + + " + + "Created: / 29-08-2017 / 14:31:19 / cg" + "Modified (comment): / 29-08-2017 / 20:00:32 / cg" +! + +browserColors + "return the palette, known as 'the color cube', 'the Netscape palette', + or 'the Browser-Safe palette'. + This is familiar to all seasoned Web designers and graphics production specialists; + Use this map for low-color-res depth 8 (gif-) images, if old pseudo displays are to be + supported." + + ^ self colorCubeWithRed:6 green:6 blue:6. + + " + |img| + + img := Image width:(8*6*6)+1 height:(8*6)+1 depth:8. + img colorMap:(Color browserColors). + img pixelFunction: + [:x :y | + |r g b| + + (y \\ 8 == 0 ) ifTrue:[ + 86 + ] ifFalse:[ + x \\ 8 == 0 ifTrue:[ + 86 + ] ifFalse:[ + r := g := b := 0. + 'y is green component'. + g := 5-(y // 8). + 'x inside subsquare is blue component'. + b := (x \\ (8*6)) // 8. + 'subsquare is red component'. + r := (x // (8*6)). + ((r*6)+g)*6+b + ] + ]. + ]. + img inspect. + " + + "Created: / 29-08-2017 / 17:01:23 / cg" +! + +colorCubeWithRed:nRed green:nGreen blue:nBlue + "given a number of red, green and blue shades, + return a color cube (map) containing those colors. + Eg, return a map containing any combination of the + nRed, nGreen and nBlue shades. + This is used for dithering of deep images onto limited-depth canvases + for example: with nRed,nGreen,nBlue == 2,3,2 + you will get a cube of 2*3*2 = 12 colors, with two shades of red (0 and 255), + threed shades of green (0, 127 and 255) and two shades of blue (0 and 255)." + + "{ Pragma: +optSpace }" + + |nR "{Class: SmallInteger }" + nG "{Class: SmallInteger }" + nB "{Class: SmallInteger }" + dR dG dB red green blue dstIndex clr round + colorCube| + + nR := nRed. + nG := nGreen. + nB := nBlue. + + dR := 100.0 / (nR - 1). + dG := 100.0 / (nG - 1). + dB := 100.0 / (nB - 1). + + colorCube := 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. + colorCube at:dstIndex put:clr. + dstIndex := dstIndex + 1 + ] + ] + ]. + ^ colorCube + + " + Color colorCubeWithRed:2 green:2 blue:2 + Color colorCubeWithRed:2 green:3 blue:2 + Color colorCubeWithRed:3 green:4 blue:3 + " + + "Created: / 11-07-1996 / 17:55:32 / cg" + "Modified: / 10-01-1997 / 15:37:13 / cg" + "Modified (comment): / 29-08-2017 / 14:27:58 / cg" +! + +flushDeviceColors + "unassign all colors from their device" + + self allInstances do:[:aColor | + aColor restored + ]. + + "Modified: 24.2.1997 / 18:27:06 / cg" +! + +flushDeviceColorsFor:aDevice + self allInstancesDo:[:aColor | + aColor device == aDevice ifTrue:[ + aColor restored + ] + ] +! + +getColors6x6x4 + "{ Pragma: +optSpace }" + + "preallocates a 6x6x4 (144) colorMap and later uses those colors only + on a palette display (pseudoColor visual). + + 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 + " + + "Modified (comment): / 29-08-2017 / 17:22:22 / cg" +! + +getColors6x6x5 + "{ Pragma: +optSpace }" + + "preallocates a 6x6x5 (180) colorMap and later uses those colors only + on a palette display (pseudoColor visual). + + 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 + " + + "Modified (comment): / 29-08-2017 / 17:22:17 / cg" +! + +getColors6x6x6 + "{ Pragma: +optSpace }" + + "preallocates a 6x6x6 (196) colorMap and later uses those colors only + on a palette display (pseudoColor visual). + + 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 + " + + "Modified (comment): / 29-08-2017 / 17:22:10 / cg" +! + +getColors6x7x4 + "{ Pragma: +optSpace }" + + "preallocates a 6x7x4 (168) colorMap and later uses those colors only + on a palette display (pseudoColor visual). + + 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-06-1996 / 17:41:57 / cg" + "Modified (comment): / 29-08-2017 / 17:22:04 / cg" +! + +getColors7x8x4 + "{ Pragma: +optSpace }" + + "preallocates a 7x8x4 (224) colorMap and later uses those colors only + on a palette display (pseudoColor visual). + + 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 + " + + "Modified (comment): / 29-08-2017 / 17:21:56 / cg" +! + +getColorsRed:nRed green:nGreen blue:nBlue + "{ Pragma: +optSpace }" + + "preallocates a nR x nG x nB colorMap for later use in dithering + on a palette display (pseudoColor visual). + + 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:Screen current + + " + Color getColorsRed:2 green:2 blue:2 + " + + "Modified: / 11-07-1996 / 17:58:09 / cg" + "Modified (comment): / 29-08-2017 / 16:47:34 / cg" +! + +getColorsRed:nRed green:nGreen blue:nBlue on:aDevice + "{ Pragma: +optSpace }" + + "preallocates a nR x nG x nB colorMap for later use in dithering + on a palette display (pseudoColor visual). + + 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 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 := self colorCubeWithRed:nRed green:nGreen blue:nBlue. + self allocateColorsIn:fixColors on:aDevice. + + aDevice setFixColors:fixColors numRed:nR numGreen:nG numBlue:nB + + " + Color getColorsRed:2 green:2 blue:2 on:Display + " + + "Created: / 11-07-1996 / 17:55:32 / cg" + "Modified: / 10-01-1997 / 15:37:13 / cg" + "Modified (comment): / 29-08-2017 / 16:47:38 / cg" +! + +getGrayColors:nGray on:aDevice + "{ Pragma: +optSpace }" + + "preallocates nGray gray colors for later use in dithering + on a palette display (pseudoColor visual). + + Doing so has the advantage that the system will never run out of colors, + however, colors may be either inexact or dithered." + + |nG "{Class: SmallInteger }" + d fixGrayColors| + + aDevice visualType == #TrueColor ifTrue:[^ self]. + + nG := nGray. + d := 100.0 / (nG - 1). + + fixGrayColors := self grayColorVector:nGray. + self allocateColorsIn:fixGrayColors on:aDevice. + + aDevice setFixGrayColors:fixGrayColors + + " + Color getGrayColors:16 on:Display + " + + "Created: / 23-06-1997 / 15:29:50 / cg" + "Modified (comment): / 29-08-2017 / 17:23:18 / cg" +! + +getPrimaryColorsOn:aDevice + "{ Pragma: +optSpace }" + + "preallocate the primary colors on a palette display (pseudoColor visual). + + 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 clr dDepth + lastPix "{ Class: SmallInteger }" | + + (aDevice notNil and:[aDevice ditherColors isNil]) ifTrue:[ + white := (self red:100 green:100 blue:100) exactOn:aDevice. + white colorId isNil ifTrue:[ + 'Color [warning]: cannot allocate white color' errorPrintCR. + ]. + black := (self red:0 green:0 blue:0) exactOn:aDevice. + black colorId isNil ifTrue:[ + 'Color [warning]: cannot allocate black color' errorPrintCR. + ]. + + 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. + (red isNil + or:[green isNil + or:[blue isNil + or:[red colorId isNil + or:[green colorId isNil + or:[blue colorId isNil]]]]]) ifTrue:[ + 'Color [warning]: cannot allocate primary color(s)' errorPrintCR. + dDepth := aDevice depth. + ((dDepth >= 4) and:[dDepth <= 8]) ifTrue:[ + "/ + "/ see what we have ... + "/ + lastPix := (1 bitShift:dDepth) - 1. + 0 to:lastPix do:[:pixel | + colors := OrderedCollection new. + aDevice getRGBFrom:pixel into:[:r :g :b | + colors add:((Color red:r green:g blue:b) exactOn:aDevice). + ] + ]. + red := (self red:100 green:0 blue:0) nearestOn:aDevice. + green := (self red:0 green:100 blue:0) nearestOn:aDevice. + blue := (self red:0 green:0 blue:100) nearestOn:aDevice. + ] ifFalse:[ + aDevice hasColors:false. + aDevice hasGrayscales:false. + red := green := blue := nil. + ] + ] + ]. + + 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. + clr := (self gray:50) exactOn:aDevice. + (clr notNil and:[clr colorId notNil]) ifTrue:[ + colors add:clr + ]. + + 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). + ]. + + aDevice hasGrayscales 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 notNil ifTrue:[ + colors := colors select:[:clr | clr notNil and:[clr colorId notNil]]. + aDevice setDitherColors:(colors asArray). + ] + ] + ] + + "Created: / 11-07-1996 / 18:09:28 / cg" + "Modified: / 21-10-1997 / 02:42:28 / cg" + "Modified (comment): / 29-08-2017 / 17:23:36 / cg" +! + +grayColorVector:nGray + |nG "{Class: SmallInteger }" + d gray dstIndex clr round + grayColors| + + nG := nGray. + d := 100.0 / (nG - 1). + + grayColors := Array new:nG. + + round := 0. + + dstIndex := 1. + 1 to:nG do:[:sG | + gray := d * (sG - 1). + clr := self red:gray green:gray blue:gray. + grayColors at:dstIndex put:clr. + dstIndex := dstIndex + 1 + ]. + ^ grayColors + + " + Color getGrayColors:16 on:Display + " + + "Created: 23.6.1997 / 15:29:50 / cg" +! + +standardDitherColorsForDepth8 + "return a set of colors useful for dithering (roughly 200 colors); + This includes a color cube and the main grayScale colors." + + |ditherColors| + + ditherColors := self colorCubeWithRed:6 green:8 blue:4. + ditherColors := ditherColors , + ( #(10 20 25 30 40 50 60 70 75 80 90) + collect:[:grayPercent | Color gray:grayPercent] + thenSelect:[:grey | (ditherColors includes:grey) not] ) + asArray. + ^ ditherColors + + " + self standardDitherColorsForDepth8 + " + + "Modified: / 29-08-2017 / 17:29:58 / cg" +! + +vgaColors + "{ Pragma: +optSpace }" + + |colors| + + colors := Array new:16. + colors at:1 put:(Color rgbValue:16rFFFFFF). + colors at:2 put:(Color rgbValue:16rC0C0C0). + colors at:3 put:(Color rgbValue:16r808080). + colors at:4 put:(Color rgbValue:16r000000). + colors at:5 put:(Color rgbValue:16rFF0000). + colors at:6 put:(Color rgbValue:16r800000). + colors at:7 put:(Color rgbValue:16r008000). + colors at:8 put:(Color rgbValue:16r00FF00). + colors at:9 put:(Color rgbValue:16r0000FF). + colors at:10 put:(Color rgbValue:16r000080). + colors at:11 put:(Color rgbValue:16rFF00FF). + colors at:12 put:(Color rgbValue:16r800080). + colors at:13 put:(Color rgbValue:16rFFFF00). + colors at:14 put:(Color rgbValue:16r808000). + colors at:15 put:(Color rgbValue:16r00FFFF). + colors at:16 put:(Color rgbValue:16r008080). + ^ colors + + "Created: / 07-07-2006 / 13:36:15 / cg" +! ! + !Color methodsFor:'Compatibility-ST80'! asDevicePaintOn:aDevice