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



    
This message has been edited by MCalkins on Oct 26, 2011 12:28 PM

Posted on Oct 26, 2011, 8:17 AM

Respond to this message   

Return to Index


Response TitleAuthor and Date
nbsp isClippy 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