hg/stx-libview: comparison Depth8Image.st

equal deleted inserted replaced

-:8f9c629a4245
+:ea2bf46eb669
 Depth8Image comment:'
 COPYRIGHT (c) 1993 by Claus Gittinger
 	      All Rights Reserved
-$Header: /cvs/stx/stx/libview/Depth8Image.st,v 1.15 1994-11-28 21:00:47 claus Exp $
+$Header: /cvs/stx/stx/libview/Depth8Image.st,v 1.16 1995-02-06 00:35:59 claus Exp $
 '!
 !Depth8Image class methodsFor:'documentation'!
 copyright
 "
 !
 version
 "
-$Header: /cvs/stx/stx/libview/Depth8Image.st,v 1.15 1994-11-28 21:00:47 claus Exp $
+$Header: /cvs/stx/stx/libview/Depth8Image.st,v 1.16 1995-02-06 00:35:59 claus Exp $
 "
 !
 documentation
 "
 It mainly consists of methods already implemented in Image,
 reimplemented here for more performance.
 "
 ! !
-!Depth8Image methodsFor:'accessing'!
+!Depth8Image class methodsFor:'queries'!
+imageDepth
+^ 8
+! !
+!Depth8Image methodsFor:'queries'!
 bitsPerPixel
 "return the number of bits per pixel"
 ^ 8
 samplesPerPixel
 "return the number of samples per pixel in the image."
 ^ 1
+!
+usedValues
+"return a collection of color values used in the receiver."
+^ bytes usedValues
 ! !
 !Depth8Image methodsFor:'accessing'!
 atX:x y:y
 photometric ~~ #palette ifTrue:[
 	self error:'format not supported'.
 	^ nil
 ].
 index := value + 1.
-^ Color red:(((colorMap at:1) at:index) * 100 / 255)
+^ colorMap at:index
-	  green:(((colorMap at:2) at:index) * 100 / 255)
-	   blue:(((colorMap at:3) at:index) * 100 / 255)
 !
 valueAtX:x y:y
 "retrieve a pixel at x/y; return a pixelValue.
 Pixels start at x=0 , y=0 for upper left pixel, end at
 index := (width * y) + 1 + x.
 bytes at:index put:aPixelValue.
 ! !
-!Depth8Image methodsFor:'enumeration'!
+!Depth8Image methodsFor:'enumerating'!
 valueAtY:y from:xLow to:xHigh do:aBlock
 "perform aBlock for each pixelValue from x1 to x2 in row y.
 The block is passed the pixelValue at each pixel.
 This method allows slighly faster processing of an
 image than using valueAtX:y:, since some processing can be
 avoided when going from pixel to pixel. However, for
 real image processing, specialized methods should be written."
 |srcIndex   "{ Class: SmallInteger }"
-index      "{ Class: SmallInteger }"
 pixelValue "{ Class: SmallInteger }"
 x1         "{ Class: SmallInteger }"
 x2         "{ Class: SmallInteger }"|
 x1 := xLow.
 value    "{ Class: SmallInteger }"
 x1       "{ Class: SmallInteger }"
 x2       "{ Class: SmallInteger }"
 color colors last|
-colors := Array new:256.
+photometric == #palette ifTrue:[
+	colors := colorMap.
+] ifFalse:[
+	colors := Array new:256.
+].
 x1 := xLow.
 x2 := xHigh.
 srcIndex := (width * y) + 1 + x1.
 	    last := value.
 	    index := value + 1.
 	    color := colors at:index.
 	    color isNil ifTrue:[
 		photometric == #whiteIs0 ifTrue:[
-		    color := (Color grey:100 - (100 / 255 * value))
+		    color := (Color grey:100 - (100 * value / 255))
 		] ifFalse:[
 		    photometric == #blackIs0 ifTrue:[
-			color := (Color grey:(100 / 255 * value))
+			color := (Color grey:(100 * value / 255))
 		    ] ifFalse:[
-			photometric == #palette ifTrue:[
+			photometric ~~ #palette ifTrue:[
-			    color := (Color red:(((colorMap at:1) at:index) * 100 / 255)
-					  green:(((colorMap at:2) at:index) * 100 / 255)
-					   blue:(((colorMap at:3) at:index) * 100 / 255))
-			] ifFalse:[
 			    self error:'format not supported'.
 			    ^ nil
 			]
 		    ]
 		].
 formBytes := ByteArray uninitializedNew:(w * 2 + 7 // 8) * h.
 patterns := Array new:nColors.
 pixel0bytes := ByteArray uninitializedNew:nColors.
 pixel1bytes := ByteArray uninitializedNew:nColors.
-"extract dither patterns and values to use for 1/o bits
+"extract dither patterns and values to use for 1/0 bits
 in those from the dithercolors"
 1 to:nColors do:[:i |
 	clr := (map at:i) on:aDevice.
 	ditherPattern := clr ditherForm.
 the result is a thresholded form, with white for
 brightness values above 50%, black below"
 |monoBits f
 map rMap gMap bMap
-fast
+failed
 r g b
 v        "{ Class: SmallInteger }"
 bitCount "{ Class: SmallInteger }"
 bits     "{ Class: SmallInteger }"
 w        "{ Class: SmallInteger }"
 h        "{ Class: SmallInteger }"
 mapSize  "{ Class: SmallInteger }"
 srcIndex "{ Class: SmallInteger }"
-dstIndex "{ Class: SmallInteger }" |
+dstIndex "{ Class: SmallInteger }"|
 w := width.
 h := height.
 monoBits := ByteArray uninitializedNew:(((w + 7) // 8) * h).
-rMap := colorMap at:1.
-gMap := colorMap at:2.
-bMap := colorMap at:3.
 map := ByteArray uninitializedNew:256.
+mapSize := colorMap size.
-mapSize := rMap size.
+"
+map entries: 0 for dark entries, 1 for bright entries
+"
 1 to:mapSize do:[:i |
-	r := rMap at:i.
+	map at:i put:(colorMap at:i) brightness rounded
-	r notNil ifTrue:[
+].
-	    g := gMap at:i.
-	    b := bMap at:i.
+failed := true.
-	    v := ((3 * r) + (6 * g) + (1 * b)) // 10.
-	    v := v bitShift:-7. "only keep hi-bit"
-	    (v == 1) ifTrue:[
-		map at:i put:0   "was: 1"
-	    ] ifFalse:[
-		map at:i put:1   "was: 0"
-	    ]
-	]
-].
-fast := false.
 %{
 register unsigned char *srcPtr, *dstPtr, *mapPtr;
 register __v, __bits, __bitCount;
 register j;
 register i;
 extern OBJ ByteArray;
-if (__isByteArray(_INST(bytes)) && __isByteArray(map) && __isByteArray(monoBits)) {
+if (__isByteArray(_INST(bytes))
-	fast = true;
+&& __isByteArray(map)
+&& __isByteArray(monoBits)) {
+	failed = false;
 	srcPtr = _ByteArrayInstPtr(_INST(bytes))->ba_element;
 	dstPtr = _ByteArrayInstPtr(monoBits)->ba_element;
 	mapPtr = _ByteArrayInstPtr(map)->ba_element;
 	for (i=_intVal(h); i>0; i--) {
 	    __bitCount = 0;
 	    }
 	}
 }
 %}
 .
-fast ifFalse:[
+failed ifTrue:[
-	srcIndex := 1.
+"/
-	dstIndex := 1.
+"/ the above code is equivalent to:
-	1 to:h do:[:row |
+"/
+"/        srcIndex := 1.
-	    bitCount := 0.
+"/        dstIndex := 1.
-	    bits := 0.
+"/        1 to:h do:[:row |
-	    1 to:w do:[:col |
+"/
-		v := bytes at:srcIndex.
+"/            bitCount := 0.
-		srcIndex := srcIndex + 1.
+"/            bits := 0.
-		v := map at:(v + 1).
+"/            1 to:w do:[:col |
-		bits := (bits bitShift:1) bitOr:v.
+"/                v := bytes at:srcIndex.
-		bitCount := bitCount + 1.
+"/                srcIndex := srcIndex + 1.
-		(bitCount == 8) ifTrue:[
+"/                v := map at:(v + 1).
-		    monoBits at:dstIndex put:bits.
+"/                bits := (bits bitShift:1) bitOr:v.
-		    dstIndex := dstIndex + 1.
+"/                bitCount := bitCount + 1.
-		    bits := 0.
+"/                (bitCount == 8) ifTrue:[
-		    bitCount := 0
+"/                    monoBits at:dstIndex put:bits.
-		]
+"/                    dstIndex := dstIndex + 1.
-	    ].
+"/                    bits := 0.
-	    (bitCount ~~ 0) ifTrue:[
+"/                    bitCount := 0
-		monoBits at:dstIndex put:bits.
+"/                ]
-		dstIndex := dstIndex + 1
+"/            ].
-	    ]
+"/            (bitCount ~~ 0) ifTrue:[
-	]
+"/                monoBits at:dstIndex put:bits.
+"/                dstIndex := dstIndex + 1
+"/            ]
+"/        ]
+"/
+"/ we dont need the fall-back code; so trigger an error
+	self primitiveFailed.
+	^ nil
 ].
 f := Form width:w height:h depth:1 on:aDevice.
 f isNil ifTrue:[^ nil].
 f initGC.
 "return a 2-bit greyForm from the palette picture -
 the result is a thresholded form, with white/lightGrey/darkGrey
 and black for brightness values 100..75, 75..50, 50..25 and 25..0 %"
 |twoPlaneBits f
-map rMap gMap bMap fast
+map rMap gMap bMap failed
 v        "{ Class: SmallInteger }"
 bitCount "{ Class: SmallInteger }"
 bits     "{ Class: SmallInteger }"
 w        "{ Class: SmallInteger }"
 h        "{ Class: SmallInteger }"
 w := width.
 h := height.
 twoPlaneBits := ByteArray uninitializedNew:(((w * 2 + 7) // 8) * h).
-rMap := colorMap at:1.
-gMap := colorMap at:2.
-bMap := colorMap at:3.
 map := ByteArray uninitializedNew:256.
-1 to:(rMap size) do:[:i |
+mapSize := colorMap size.
-	|r g b v|
+"
-	r := rMap at:i.
+map entries: 0 .. 3 give brightness in 4 thresholded steps
-	r notNil ifTrue:[
+"
-	    g := gMap at:i.
+1 to:mapSize do:[:i |
-	    b := bMap at:i.
+	map at:i put:(colorMap at:i) brightness * 3 rounded
-	    v := ((3 * r) + (6 * g) + (1 * b)) // 10.
+].
-	    v := v bitShift:-6. "only keep hi-2-bits"
-	    map at:i put:v
+failed := true.
-	]
-].
-fast := false.
 %{
 register unsigned char *srcPtr, *dstPtr, *mapPtr;
 register __v, __bits, __bitCount;
 register j;
 register i;
 extern OBJ ByteArray;
-if ((__isByteArray(_INST(bytes))) && (__isByteArray(map)) && (__isByteArray(twoPlaneBits))) {
+if ((__isByteArray(_INST(bytes)))
-	fast = true;
+&& (__isByteArray(map))
+&& (__isByteArray(twoPlaneBits))) {
+	failed = false;
 	srcPtr = _ByteArrayInstPtr(_INST(bytes))->ba_element;
 	dstPtr = _ByteArrayInstPtr(twoPlaneBits)->ba_element;
 	mapPtr = _ByteArrayInstPtr(map)->ba_element;
 	for (i=_intVal(h); i>0; i--) {
 	    __bitCount = 0;
 	    if (__bitCount != 0) {
 		*dstPtr++ = __bits;
 	    }
 	}
 }
-%}
+%}.
-.
+failed ifTrue:[
-fast ifFalse:[
+"/
-	srcIndex := 1.
+"/ the above code is equivalent to:
-	dstIndex := 1.
+"/
-	1 to:h do:[:row |
+"/        srcIndex := 1.
-	    bitCount := 0.
+"/        dstIndex := 1.
-	    bits := 0.
+"/        1 to:h do:[:row |
-	    1 to:w do:[:col |
+"/            bitCount := 0.
-		v := bytes at:srcIndex.
+"/            bits := 0.
-		srcIndex := srcIndex + 1.
+"/            1 to:w do:[:col |
-		v := map at:(v + 1).
+"/                v := bytes at:srcIndex.
-		bits := (bits bitShift:2) bitOr:v.
+"/                srcIndex := srcIndex + 1.
-		bitCount := bitCount + 1.
+"/                v := map at:(v + 1).
-		(bitCount == 4) ifTrue:[
+"/                bits := (bits bitShift:2) bitOr:v.
-		    twoPlaneBits at:dstIndex put:bits.
+"/                bitCount := bitCount + 1.
-		    dstIndex := dstIndex + 1.
+"/                (bitCount == 4) ifTrue:[
-		    bits := 0.
+"/                    twoPlaneBits at:dstIndex put:bits.
-		    bitCount := 0
+"/                    dstIndex := dstIndex + 1.
-		]
+"/                    bits := 0.
-	    ].
+"/                    bitCount := 0
-	    (bitCount ~~ 0) ifTrue:[
+"/                ]
-		twoPlaneBits at:dstIndex put:bits.
+"/            ].
-		dstIndex := dstIndex + 1
+"/            (bitCount ~~ 0) ifTrue:[
-	    ]
+"/                twoPlaneBits at:dstIndex put:bits.
-	]
+"/                dstIndex := dstIndex + 1
+"/            ]
+"/        ]
+"/
+	self primitiveFailed.
+	^ nil
 ].
 f := Form width:w height:h depth:2 on:aDevice.
 f isNil ifTrue:[^ nil].
 f initGC.
 		   x:0 y:0
 		into:(f id) x:0 y:0 width:w height:h with:(f gcId).
 ^ f
 !
-paletteImageAsPseudoFormOn:aDevice
+paletteImageAsDitheredPseudoFormOn:aDevice
-"return a pseudoForm from the palette picture. The main work is
+"return a dithered pseudoForm from the palette picture. Depend
-in color reduction, when not all colors can be aquired."
+on dither colors being preallocated (see Color>>getColors*)"
-|pseudoBits f gcRound has8BitImage deviceDepth
+^ self paletteImageAsDitheredPseudoFormOn:aDevice
-imgMap newImage pxl
+	   colors:Color fixColors
-usedColors usageCounts nUsed map mapIndex rMap gMap bMap
+	   nRed:Color numFixRed
-fit scale lastOK error
+	   nGreen:Color numFixGreen
-div
+	   nBlue:Color numFixBlue
-shift "{Class: SmallInteger }"
+!
-m     "{Class: SmallInteger }" |
+paletteImageAsDitheredPseudoFormOn:aDevice colors:fixColors nRed:nRed nGreen:nGreen nBlue:nBlue
-'D8Image: allocating colors ...' errorPrintNewline.
+"return a dithered pseudoForm from the palette picture.
+Use the colors in the fixColors array, which must be fixR x fixG x fixB
-"find used colors"
+colors assigned to aDevice, such as the preallocated colors of the
+Color class.
-usedColors := bytes usedValues.         "gets us an array filled with used values"
+By passing the ditherColors as extra array, this method can
-					   "(could use bytes asBag)"
+also be used to dither an 8bit image into a smaller number of colors,
-nUsed := usedColors max + 1.
+for example to create Depth4Images."
-"sort by usage"
+"the code below is a q&d hack - it needs a rewrite to use a
-usageCounts := bytes usageCounts.
+floyd-steinberg dither (currently, the error is only forwarded
-usageCounts := usedColors asArray collect:[:clr | usageCounts at:(clr + 1)].
+to the next pixel on the right, which seems ok for photograph-like
-usageCounts sort:[:a :b | a > b] with:usedColors.
+images, but leads to more artifacts with equal colored areas).
+"
-"allocate the colors (in order of usage count)"
+|pseudoBits f has8BitImage deviceDepth
-rMap := colorMap at:1.
+redBytes greenBytes blueBytes
-gMap := colorMap at:2.
+"/     eR    "{Class: SmallInteger }"
-bMap := colorMap at:3.
+"/     eG    "{Class: SmallInteger }"
+"/     eB    "{Class: SmallInteger }"
-imgMap := Array new:nUsed.
+"/     wantR "{Class: SmallInteger }"
+"/     wantG "{Class: SmallInteger }"
-"first,  we try to get the exact colors"
+"/     wantB "{Class: SmallInteger }"
+w     "{Class: SmallInteger }"
-shift := (8 - aDevice bitsPerRGB) negated.
+h     "{Class: SmallInteger }"
-m := (1 bitShift:(aDevice bitsPerRGB)) - 1.
+index "{Class: SmallInteger }"
-div := m asFloat.
+fixR  "{Class: SmallInteger }"
+fixG  "{Class: SmallInteger }"
-fit := true.
+fixB  "{Class: SmallInteger }"
-scale := 100.0 / div.       "to scale 0..255 into 0.0 .. 100.0"
+fixIds failed|
-lastOK := 0.
-usedColors do:[:aColorIndex |
+aDevice ~~ Display ifTrue:[^ nil].
-	|devColor color
-	 r     "{Class: SmallInteger }"
+fixR := nRed.
-	 g     "{Class: SmallInteger }"
+fixR == 0 ifTrue:[ ^ nil].
-	 b     "{Class: SmallInteger }"
+fixG := nGreen.
-	 rMask "{Class: SmallInteger }"
+fixG == 0 ifTrue:[ ^ nil].
-	 gMask "{Class: SmallInteger }"
+fixB := nBlue.
-	 bMask "{Class: SmallInteger }"|
+fixB == 0 ifTrue:[ ^ nil].
+"/ simple check
-	fit ifTrue:[
+(fixR * fixG * fixB) ~~ fixColors size ifTrue:[
-	    gMask := bMask := rMask := m.
+	self error:'invalid color array passed'.
+	^ nil
-	    mapIndex := aColorIndex + 1.
+].
-	    r := rMap at:mapIndex.
+fixIds := (fixColors asArray collect:[:clr | clr colorId]) asByteArray.
-	    g := gMap at:mapIndex.
-	    b := bMap at:mapIndex.
-	    color := Color red:((r bitShift:shift) bitAnd:rMask) * scale
-			 green:((g bitShift:shift) bitAnd:gMask) * scale
-			  blue:((b bitShift:shift) bitAnd:bMask) * scale.
-	    devColor := color exactOn:aDevice.
-	    devColor isNil ifTrue:[
-		"no such color - on the first round, do a GC to flush unused
-		 colors - this may help"
-		gcRound == 0 ifTrue:[
-		    ObjectMemory scavenge.
-		    devColor := color exactOn:aDevice.
-		    gcRound := 1
-		].
-		devColor isNil ifTrue:[
-		    gcRound == 1 ifTrue:[
-			'D8Image: force GC for possible color reclamation.' errorPrintNL.
-			ObjectMemory markAndSweep.
-			devColor := color exactOn:aDevice.
-			gcRound := 2
-		    ]
-		]
-	    ].
-	    (devColor notNil and:[devColor colorId notNil]) ifTrue:[
-		imgMap at:mapIndex put:devColor.
-		lastOK := lastOK + 1.
-	    ] ifFalse:[
-		fit := false
-	    ]
-	]
-].
-"again, this time allow wrong colors (loop while increasing allowed error)"
-fit ifFalse:[
-	gcRound := 0.
-	error := 10.
-	[fit] whileFalse:[
-	    fit := true.
-	    usedColors from:(lastOK+1) to:(usedColors size) do:[:aColorIndex |
-		|devColor color
-		 r     "{Class: SmallInteger }"
-		 g     "{Class: SmallInteger }"
-		 b     "{Class: SmallInteger }"
-		 rMask "{Class: SmallInteger }"
-		 gMask "{Class: SmallInteger }"
-		 bMask "{Class: SmallInteger }"|
-		fit ifTrue:[
-		    gMask := bMask := rMask := m.
-		    mapIndex := aColorIndex + 1.
-		    r := rMap at:mapIndex.
-		    g := gMap at:mapIndex.
-		    b := bMap at:mapIndex.
-		    color := Color red:((r bitShift:shift) bitAnd:rMask) * scale
-				 green:((g bitShift:shift) bitAnd:gMask) * scale
-				  blue:((b bitShift:shift) bitAnd:bMask) * scale.
-		    devColor := color nearestOn:aDevice error:error.
-		    devColor isNil ifTrue:[
-			"no such color - on the first round, do a GC to flush unused
-			 colors - this may help"
-			gcRound == 0 ifTrue:[
-			    ObjectMemory scavenge.
-			    devColor := color nearestOn:aDevice error:error.
-			    gcRound := 1
-			].
-			devColor isNil ifTrue:[
-			    gcRound == 1 ifTrue:[
-				'D8Image: force GC for possible color reclamation.' errorPrintNL.
-				ObjectMemory markAndSweep.
-				devColor := color nearestOn:aDevice error:error.
-				gcRound := 2
-			    ]
-			]
-		    ].
-		    (devColor notNil and:[devColor colorId notNil]) ifTrue:[
-			imgMap at:mapIndex put:devColor.
-			lastOK := lastOK + 1.
-		    ] ifFalse:[
-			fit := false
-		    ]
-		].
-	    ].
-	    error := error * 2
-	].
-	error > 100 ifTrue:[
-	    'D8Image: not enough colors for a reasonable image' errorPrintNewline
-	] ifFalse:[
-	    'D8Image: not enough colors for exact picture' errorPrintNewline.
-	]
-].
-"create translation map"
-map := ByteArray new:256.
-1 to:imgMap size do:[:i |
-	(imgMap at:i) notNil ifTrue:[
-	    map at:i put:(imgMap at:i) colorId
-	]
-].
 deviceDepth := aDevice depth.
 deviceDepth == 8 ifTrue:[
 	has8BitImage := true.
 ] ifFalse:[
 	    (fmt at:2) == 8 ifTrue:[
 		has8BitImage := true.
 	    ]
 	]
 ].
+has8BitImage ifFalse:[^ nil].
+'D8IMAGE: dithering ...' errorPrintNL.
+"
+collect color components as integer values
+(code below uses components percent * 2.55 asInteger everywhere, to avoid
+float arithmetic, rounding etc. Thus, the range is 0..255 here)
+"
+redBytes := ByteArray uninitializedNew:(colorMap size).
+greenBytes := ByteArray uninitializedNew:(colorMap size).
+blueBytes := ByteArray uninitializedNew:(colorMap size).
+1 to:(colorMap size) do:[:i |
+	|clr|
+	clr := colorMap at:i.
+	redBytes at:i put:(clr red * 2.55) asInteger.
+	greenBytes at:i put:(clr green * 2.55) asInteger.
+	blueBytes at:i put:(clr blue * 2.55) asInteger.
+].
+pseudoBits := ByteArray uninitializedNew:(width * height).
+w := width.
+h := height.
+failed := true.
+%{
+int __x, __y;
+int __eR, __eG, __eB;
+int __wantR, __wantG, __wantB;
+unsigned char *srcP, *dstP;
+unsigned char *redP, *greenP, *blueP;
+int pix;
+unsigned char *idP;
+int __fR, __fG, __fB;
+int iR, iG, iB;
+int idx;
+if (__isByteArray(_INST(bytes))
+&& __isByteArray(pseudoBits)
+&& __isByteArray(redBytes)
+&& __isByteArray(greenBytes)
+&& __isByteArray(blueBytes)
+&& __isByteArray(fixIds)
+&& _isSmallInteger(fixR)
+&& _isSmallInteger(fixG)
+&& _isSmallInteger(fixB)) {
+	failed = false;
+	srcP = _ByteArrayInstPtr(_INST(bytes))->ba_element;
+	dstP = _ByteArrayInstPtr(pseudoBits)->ba_element;
+	redP = _ByteArrayInstPtr(redBytes)->ba_element;
+	greenP = _ByteArrayInstPtr(greenBytes)->ba_element;
+	blueP = _ByteArrayInstPtr(blueBytes)->ba_element;
+	idP = _ByteArrayInstPtr(fixIds)->ba_element;
+	__fR = _intVal(fixR)-1;
+	__fG = _intVal(fixG)-1;
+	__fB = _intVal(fixB)-1;
+	for (__y=_intVal(h); __y>0; __y--) {
+	    __eR = __eG = __eB = 0;
+	    for (__x=_intVal(w); __x>0; __x--) {
+		int t;
+		int __want;
+		pix = *srcP++;
+		/*
+		 * wR, wG and wB is the wanted r/g/b value;
+		 * compute the index into the dId table ..
+		 * values: 0..255; scale to 0..fR-1, 0..fG-1, 0..fB-1
+		 *
+		 * bad kludge: knows how to index into FixColor table
+		 */
+		__wantR = redP[pix] + __eR;
+		__wantG = greenP[pix] + __eG;
+		__wantB = blueP[pix] + __eB;
+		if (__wantR > 255) __want = 255;
+		else if (__wantR < 0) __want = 0;
+		else __want = __wantR;
+		iR = __want * __fR / 128;
+		iR = (iR / 2) + (iR & 1);
+		idx = iR * (__fG+1);
+		if (__wantG > 255) __want = 255;
+		else if (__wantG < 0) __want = 0;
+		else __want = __wantG;
+		iG = __want * __fG / 128;
+		iG = (iG / 2) + (iG & 1);
+		idx = (idx + iG) * (__fB+1);
+		if (__wantB > 255) __want = 255;
+		else if (__wantB < 0) __want = 0;
+		else __want = __wantB;
+		iB = __want * __fB / 128;
+		iB = (iB / 2) + (iB & 1);
+		idx = idx + iB;
+		/*
+		 * store the corresponding dither colorId
+		 */
+		*dstP++ = idP[idx];
+		/*
+		 * the new error:
+		 */
+		__eR = __wantR - (iR * 256 / __fR);
+		__eG = __wantG - (iG * 256 / __fG);
+		__eB = __wantB - (iB * 256 / __fB);
+	    }
+	}
+}
+%}.
+failed ifTrue:[
+	self primitiveFailed.
+	^ nil
+"/ for non-C programmers:
+"/   the above code is (roughly) equivalent to:
+"/
+"/    index := 1.
+"/    1 to:h do:[:y |
+"/        eR := eG := eB := 0.
+"/        1 to:w do:[:x |
+"/            |pixel "{ Class: SmallInteger }"
+"/             clr
+"/             wR    "{ Class: SmallInteger }"
+"/             wG    "{ Class: SmallInteger }"
+"/             wB    "{ Class: SmallInteger }" |
+"/
+"/            pixel := (bytes at:index) + 1.
+"/
+"/            wantR := ((redBytes at:pixel) + eR).
+"/            wantG := ((greenBytes at:pixel) + eG).
+"/            wantB := ((blueBytes at:pixel) + eB).
+"/            wR := wantR.
+"/            wR > 200 ifTrue:[wR := 200] ifFalse:[wR < 0 ifTrue:[wR := 0]].
+"/            wG := wantG.
+"/            wG > 200 ifTrue:[wG := 200] ifFalse:[wG < 0 ifTrue:[wG := 0]].
+"/            wB := wantB.
+"/            wB > 200 ifTrue:[wB := 200] ifFalse:[wB < 0 ifTrue:[wB := 0]].
+"/
+"/            iR := wR * (fixR-1) / 128.
+"/            iR := (iR / 2) + (iR bitAnd:1).
+"/            iG := wG * (fixG-1) / 128.
+"/            iG := (iG / 2) + (iG bitAnd:1).
+"/            iB := wB * (fixB-1) / 128.
+"/            iB := (iB / 2) + (iB bitAnd:1).
+"/            idx := (iR * fixR + iG) * fixB + iB.
+"/            clr := fixColors at:idx.
+"/
+"/            eR := wantR - (clr red * 2) asInteger.
+"/            eG := wantG - (clr green * 2) asInteger.
+"/            eB := wantB - (clr blue * 2) asInteger.
+"/
+"/            pixel := clr colorId.
+"/            pseudoBits at:index put:pixel.
+"/
+"/            index := index + 1
+"/        ].
+"/    ].
+].
+f := Form width:width height:height depth:deviceDepth on:aDevice.
+f isNil ifTrue:[^ nil].
+f colorMap:fixColors.
+f initGC.
+aDevice drawBits:pseudoBits bitsPerPixel:8 depth:deviceDepth
+	       width:width height:height
+		   x:0 y:0
+		into:(f id) x:0 y:0
+	       width:width height:height with:(f gcId).
+^ f
+"
+example: color reduction from Depth8 to Depth4 can be done by:
+|img8 reducedImg8 img4 map|
+map := #(
+		  (0     0   0)
+		  (0     0 100)
+		  (0    50   0)
+		  (0    50 100)
+		  (0   100   0)
+		  (0   100 100)
+		  (100   0   0)
+		  (100   0 100)
+		  (100  50   0)
+		  (100  50 100)
+		  (100 100   0)
+		  (100 100 100)) collect:[:rgb | (Color red:(rgb at:1)
+						      green:(rgb at:2)
+						       blue:(rgb at:3)) on:Display].
+img8 := Image fromFile:'bitmaps/bf.im8'.
+form := img8 paletteImageAsDitheredPseudoFormOn:Display
+		      colors:map
+			nRed:2
+		      nGreen:3
+		       nBlue:2.
+img8 := Depth8Image fromForm:form.
+img4 := Depth4Image fromImage:img8.
+"
+!
+paletteImageAsPseudoFormOn:aDevice
+"return a pseudoForm from the palette picture. The main work is
+in color reduction, when not all colors can be aquired."
+|pseudoBits f gcRound has8BitImage deviceDepth
+imgMap newImage pxl
+usedColors usageCounts nUsed map
+fit scale lastOK error
+div
+shift "{Class: SmallInteger }"
+m     "{Class: SmallInteger }" |
+Color fixColors notNil ifTrue:[
+	f := self paletteImageAsDitheredPseudoFormOn:aDevice.
+	f notNil ifTrue:[^ f].
+].
+'D8IMAGE: allocating colors ...' errorPrintNL.
+"find used colors"
+usedColors := bytes usedValues.         "gets us an array filled with used values"
+					   "(could use bytes asBag)"
+nUsed := usedColors max + 1.
+"sort by usage"
+usageCounts := bytes usageCounts.
+usageCounts := usedColors asArray collect:[:clr | usageCounts at:(clr + 1)].
+usageCounts sort:[:a :b | a > b] with:usedColors.
+"allocate the colors (in order of usage count)"
+imgMap := Array new:nUsed.
+"
+first, try to get the exact colors ...
+"
+shift := (8 - aDevice bitsPerRGB) negated.
+m := (1 bitShift:(aDevice bitsPerRGB)) - 1.
+div := m asFloat.
+fit := true.
+scale := 100.0 / div.       "to scale 0..255 into 0.0 .. 100.0"
+lastOK := 0.
+gcRound := 0.
+usedColors do:[:aColorIndex |
+	|devColor color
+	 r        "{Class: SmallInteger }"
+	 g        "{Class: SmallInteger }"
+	 b        "{Class: SmallInteger }"
+	 mapIndex "{Class: SmallInteger }"
+	 rMask    "{Class: SmallInteger }"
+	 gMask    "{Class: SmallInteger }"
+	 bMask    "{Class: SmallInteger }"|
+	fit ifTrue:[
+	    gMask := bMask := rMask := m.
+	    mapIndex := aColorIndex + 1.
+	    color := colorMap at:mapIndex.
+	    color colorId notNil ifTrue:[
+		"wow - an immediate hit"
+		devColor := color
+	    ] ifFalse:[
+		devColor := color exactOn:aDevice.
+		devColor isNil ifTrue:[
+		    "
+		     could not allocate color - on the first round, do a GC to flush
+		     unused colors - this may help if some colors where locked by
+		     already free images.
+		    "
+		    gcRound == 0 ifTrue:[
+			ObjectMemory scavenge.
+			devColor := color exactOn:aDevice.
+			gcRound := 1
+		    ].
+		    devColor isNil ifTrue:[
+			gcRound == 1 ifTrue:[
+			    'D8IMAGE: force GC for possible color reclamation.' errorPrintNL.
+			    ObjectMemory markAndSweep.
+			    devColor := color exactOn:aDevice.
+			    gcRound := 2
+			]
+		    ]
+		].
+	    ].
+	    (devColor notNil and:[devColor colorId notNil]) ifTrue:[
+		imgMap at:mapIndex put:devColor.
+		lastOK := lastOK + 1.
+	    ] ifFalse:[
+		fit := false
+	    ]
+	]
+].
+fit ifFalse:[
+	"
+	 again, this time allow wrong colors (loop while increasing allowed error)
+	"
+	error := 10.
+	[fit] whileFalse:[
+	    fit := true.
+	    usedColors from:(lastOK+1) to:(usedColors size) do:[:aColorIndex |
+		|devColor color
+		 r        "{Class: SmallInteger }"
+		 g        "{Class: SmallInteger }"
+		 b        "{Class: SmallInteger }"
+		 mapIndex "{Class: SmallInteger }"
+		 rMask    "{Class: SmallInteger }"
+		 gMask    "{Class: SmallInteger }"
+		 bMask    "{Class: SmallInteger }"|
+		fit ifTrue:[
+		    gMask := bMask := rMask := m.
+		    mapIndex := aColorIndex + 1.
+		    color := colorMap at:mapIndex.
+		    r := (color red * 255 / 100) rounded.
+		    g := (color green * 255 / 100) rounded.
+		    b := (color blue * 255 / 100) rounded.
+		    color := Color red:((r bitShift:shift) bitAnd:rMask) * scale
+				 green:((g bitShift:shift) bitAnd:gMask) * scale
+				  blue:((b bitShift:shift) bitAnd:bMask) * scale.
+		    color colorId notNil ifTrue:[
+			"wow - an immediate hit"
+			devColor := color
+		    ] ifFalse:[
+			devColor := color nearestOn:aDevice error:error.
+			devColor isNil ifTrue:[
+			    "
+			     no free color - on the first round, do a GC to flush unused
+			     colors - this may help if some colors where locked by already
+			     free images.
+			    "
+			    gcRound == 0 ifTrue:[
+				ObjectMemory scavenge.
+				devColor := color nearestOn:aDevice error:error.
+				gcRound := 1
+			    ].
+			    devColor isNil ifTrue:[
+				gcRound == 1 ifTrue:[
+				    'D8IMAGE: force GC for possible color reclamation.' errorPrintNL.
+				    ObjectMemory markAndSweep.
+				    devColor := color nearestOn:aDevice error:error.
+				    gcRound := 2
+				]
+			    ]
+			].
+		    ].
+		    (devColor notNil and:[devColor colorId notNil]) ifTrue:[
+			imgMap at:mapIndex put:devColor.
+			lastOK := lastOK + 1.
+		    ] ifFalse:[
+			fit := false
+		    ]
+		].
+	    ].
+	    error := error * 2.
+	    error > 1000 ifTrue:[
+		"
+		 break out, if the error becomes too big.
+		"
+		'D8IMAGE: hard color allocation problem - revert to b&w' errorPrintNL.
+		"
+		 map to b&w as a last fallback.
+		 (should really do a dither here)
+		"
+		usedColors from:(lastOK+1) to:(usedColors size) do:[:aColorIndex |
+		    |color
+		     mapIndex "{ Class: SmallInteger }"|
+		    mapIndex := aColorIndex + 1.
+		    color := colorMap at:mapIndex.
+		    color brightness > 0.5 ifTrue:[
+			imgMap at:mapIndex put:(Color white on:aDevice).
+		    ] ifFalse:[
+			imgMap at:mapIndex put:(Color black on:aDevice).
+		    ]
+		].
+		fit := true.
+	    ]
+	].
+	error > 100 ifTrue:[
+	    'D8IMAGE: not enough colors for a reasonable image' errorPrintNL
+	] ifFalse:[
+	    'D8IMAGE: not enough colors for exact picture' errorPrintNL.
+	]
+].
+"
+create translation map (from image colors to allocated colorIds)
+"
+map := ByteArray new:256.
+1 to:imgMap size do:[:i |
+	(imgMap at:i) notNil ifTrue:[
+	    map at:i put:(imgMap at:i) colorId
+	]
+].
+deviceDepth := aDevice depth.
+deviceDepth == 8 ifTrue:[
+	has8BitImage := true.
+] ifFalse:[
+	has8BitImage := false.
+	aDevice supportedImageFormats do:[:fmt |
+	    (fmt at:2) == 8 ifTrue:[
+		has8BitImage := true.
+	    ]
+	]
+].
+"
+finally, create a form on the device and copy (& translate)
+the pixel values
+"
 has8BitImage ifTrue:[
 	pseudoBits := ByteArray uninitializedNew:(width * height).
 	bytes expandPixels:8         "xlate only"
 		    width:width
 paletteImageAsGreyFormOn:aDevice
 "return an 8-bit greyForm from the 8-bit palette picture;
 only a translation has to be done"
-|greyBits f v
+|greyBits f map
-nColors "{ Class: SmallInteger }"
+mapSize "{ Class: SmallInteger }"|
-r       "{ Class: SmallInteger }"
-g       "{ Class: SmallInteger }"
-b       "{ Class: SmallInteger }"
-map rMap gMap bMap|
 greyBits := ByteArray uninitializedNew:(width * height).
-rMap := colorMap at:1.
-gMap := colorMap at:2.
-bMap := colorMap at:3.
-nColors := rMap size.
 map := ByteArray uninitializedNew:256.
+mapSize := colorMap size.
-1 to:nColors do:[:i |
-	r := rMap at:i.
+1 to:mapSize do:[:i |
-	r notNil ifTrue:[
+	map at:i put:((colorMap at:i) brightness * 255) rounded
-	    g := gMap at:i.
+].
-	    b := bMap at:i.
-	    v := ((3 * r) + (6 * g) + (1 * b)) // 10.
-	    map at:i put:v
-	]
-].
 bytes expandPixels:8         "xlate only"
 		width:width
 	       height:height
 		 into:greyBits
 	      mapping:map.
 paletteImageAsPatternDitheredGreyFormOn:aDevice
 "return a dithered greyForm from the 8-bit palette picture.
 works for any destination depth - but is very slow for some."
 |f
-r g b
+map run last ditherColors first delta
-map rMap gMap bMap
+clr depth grey
-run last ditherColors first delta
-clr depth
 nDither       "{Class: SmallInteger }"
 nColors       "{Class: SmallInteger }"
 w             "{Class: SmallInteger }"
 h             "{Class: SmallInteger }"
 v             "{Class: SmallInteger }"
 delta := 100 / nDither.
 0 to:nDither-1 do:[:i |
 	ditherColors at:i+1 put:(Color grey:(i * delta + first)).
 ].
-rMap := colorMap at:1.
+nColors := colorMap size.
-gMap := colorMap at:2.
-bMap := colorMap at:3.
-nColors := rMap size.
 map := Array new:nColors.
 1 to:nColors do:[:i |
-	r := rMap at:i.
+	clr := colorMap at:i.
-	r notNil ifTrue:[
+	grey := clr brightness.
-	    g := gMap at:i.
+	map at:i put:(ditherColors at:(v * (nDither - 1)) rounded)
-	    b := bMap at:i.
-	    v := ((3 * r) + (6 * g) + (1 * b)) asInteger.
-	    " v is now in the range 0 .. 2550 "
-	    v := (v * (nDither - 1) // 2550) rounded.
-	    " v is now 0 .. nDither-1 "
-	    map at:i put:(ditherColors at:(v + 1))
-	]
 ].
 "tuning - code below is so slooow"
 "get the patterns, fill form bytes here"
 magnifyRowFrom:srcBytes offset:srcStart
 	  into:dstBytes offset:dstStart factor:mX
 "magnify a single pixel row - can only magnify by integer factors.
-Especially tuned for factors 2,3 and 4."
+Specially tuned for factors 2,3 and 4."
 %{
 REGISTER unsigned char *srcP, *dstP;
 REGISTER unsigned char _byte;
 int _mag;
 This is the general magnification method, handling non-integral values"
 |mX mY
 newWidth  "{ Class: SmallInteger }"
 newHeight "{ Class: SmallInteger }"
-w          "{ Class: SmallInteger }"
+w         "{ Class: SmallInteger }"
 h         "{ Class: SmallInteger }"
 newImage newBytes
 value     "{ Class: SmallInteger }"
 srcRowIdx "{ Class: SmallInteger }"
 srcIndex  "{ Class: SmallInteger }"
 	    *_dstP++ = _srcRowP[(int)((double)_col / _mX)];
 	}
 }
 %}
 .
-"   the above C-code is equivalent to:
+"/   the above C-code is equivalent to:
+"/
-dstIndex := 1.
+"/    dstIndex := 1.
-w := newWidth - 1.
+"/    w := newWidth - 1.
-h := newHeight - 1.
+"/    h := newHeight - 1.
-0 to:h do:[:row |
+"/    0 to:h do:[:row |
-	srcRowIdx := (width * (row // mY)) + 1.
+"/        srcRowIdx := (width * (row // mY)) + 1.
-	0 to:w do:[:col |
+"/        0 to:w do:[:col |
-	    srcIndex := srcRowIdx + (col // mX).
+"/            srcIndex := srcRowIdx + (col // mX).
-	    value := bytes at:srcIndex.
+"/            value := bytes at:srcIndex.
-	    newBytes at:dstIndex put:value.
+"/            newBytes at:dstIndex put:value.
-	    dstIndex := dstIndex + 1
+"/            dstIndex := dstIndex + 1
-	]
+"/        ]
-].
+"/    ].
-"
+"/
 ^ newImage
 ! !

changeset 89	ea2bf46eb669
parent 86	032006651226
child 97	dd6116883ac0