Can somebody fix that?by Pharoah (no login)The "preview" function lied to me! Here's the code: DEFINT A-Z TYPE bmpFileHeader magic AS STRING * 2 size AS LONG zeros AS LONG offset AS LONG END TYPE TYPE bmpInfoHeader headerSize AS LONG w AS LONG h AS LONG planes AS INTEGER bpp AS INTEGER '1, 4, 8, or 24 compression AS LONG imageSize AS LONG ppmx AS LONG ppmy AS LONG colors AS LONG importantColors AS LONG END TYPE TYPE rgbColor b AS STRING * 1 g AS STRING * 1 r AS STRING * 1 END TYPE TYPE intColor r AS INTEGER g AS INTEGER b AS INTEGER END TYPE '=== CONSTANTS file$ = "test2.bmp" '=== MAIN SCREEN 12 DIM fileHeader AS bmpFileHeader DIM infoHeader AS bmpInfoHeader DIM rawPixel AS rgbColor DIM intPixel AS intColor DIM errors AS intColor DIM blank AS intColor DIM bestErrors AS intColor blank.r = 0 blank.g = 0 blank.b = 0 'Build lookup table DIM lookup(0 TO 15) AS intColor FOR i = 0 TO 15 READ lookup(i).r, lookup(i).g, lookup(i).b NEXT i 'Read the image data and display it OPEN file$ FOR BINARY AS #1 GET #1, , fileHeader GET #1, , infoHeader IF infoHeader.bpp <> 24 THEN PRINT "Can only read true color bitmaps." PRINT "BPP = " + STR$(infoHeader.bpp) END ELSEIF infoHeader.compression <> 0 THEN PRINT "Can't read compressed bitmaps." END IF DIM quantErrors(-1 TO 0, 0 TO infoHeader.w - 1) AS intColor qeLine = 0 ' Move to the actual image data SEEK #1, fileHeader.offset + 1 endSkip = (infoHeader.w * 3) MOD 4 ' This meets an alignment requirement DIM dummy AS STRING * 1 FOR y = infoHeader.h - 1 TO 0 STEP -1 FOR x = 0 TO infoHeader.w - 1 GET #1, , rawPixel ' Add the pixel value to the diffused error intPixel.r = ASC(rawPixel.r) + quantErrors(qeLine, x).r IF intPixel.r < 0 THEN intPixel.r = 0 ELSE IF intPixel.r > 255 THEN intPixel.r = 255 intPixel.g = ASC(rawPixel.g) + quantErrors(qeLine, x).g IF intPixel.g < 0 THEN intPixel.g = 0 ELSE IF intPixel.g > 255 THEN intPixel.g = 255 intPixel.b = ASC(rawPixel.b) + quantErrors(qeLine, x).b IF intPixel.b < 0 THEN intPixel.b = 0 ELSE IF intPixel.b > 255 THEN intPixel.b = 255 quantErrors(qeLine, x) = blank ' Find the best match best = 0 DIM e AS LONG e = 100000000 FOR i = 0 TO 15 errors.r = intPixel.r - lookup(i).r errors.g = intPixel.g - lookup(i).g errors.b = intPixel.b - lookup(i).b ee = ABS(errors.r) + ABS(errors.g) + ABS(errors.b) IF ee < e THEN e = ee best = i bestErrors = errors END IF NEXT i ' Diffuse the error to neighboring pixels in this pattern: ' X .5 '.25 .25 bestErrors.r = bestErrors.r \ 4 bestErrors.g = bestErrors.g \ 4 bestErrors.b = bestErrors.b \ 4 quantErrors(NOT qeLine, x).r = quantErrors(NOT qeLine, x).r + bestErrors.r quantErrors(NOT qeLine, x).g = quantErrors(NOT qeLine, x).g + bestErrors.g quantErrors(NOT qeLine, x).b = quantErrors(NOT qeLine, x).b + bestErrors.b IF x > 0 THEN quantErrors(NOT qeLine, x - 1).r = quantErrors(NOT qeLine, x - 1).r + bestErrors.r quantErrors(NOT qeLine, x - 1).g = quantErrors(NOT qeLine, x - 1).g + bestErrors.g quantErrors(NOT qeLine, x - 1).b = quantErrors(NOT qeLine, x - 1).b + bestErrors.b END IF IF x < infoHeader.w - 1 THEN quantErrors(qeLine, x + 1).r = quantErrors(qeLine, x + 1).r + bestErrors.r + bestErrors.r quantErrors(qeLine, x + 1).g = quantErrors(qeLine, x + 1).g + bestErrors.g + bestErrors.g quantErrors(qeLine, x + 1).b = quantErrors(qeLine, x + 1).b + bestErrors.b + bestErrors.b END IF PSET (x, y), best NEXT x qeLine = NOT qeLine FOR i = 1 TO endSkip GET #1, , dummy NEXT i NEXT y DATA 0, 0, 0 DATA 0, 0, 170 DATA 0, 170, 0 DATA 0, 170, 170 DATA 170, 0, 0 DATA 170, 0, 170 DATA 170, 85, 0 DATA 170, 170, 170 DATA 85, 85, 85 DATA 85, 85, 255 DATA 85, 255, 85 DATA 85, 255, 255 DATA 255, 85, 85 DATA 255, 85, 255 DATA 255, 255, 85 DATA 255, 255, 255
|
| Response Title | Author and Date |
| nbsp is | Clippy on Oct 26 |
| Re: Can somebody fix that? | on Oct 26 |
| * CHR$(255) works too... | on Oct 26 |
| It depends on code page translation. | on Oct 26 |
| That's better than... | on Oct 26 |
| I'd originally done a similar thing... | Pharoah on Oct 26 |