QB64 Phoenix Edition
Convert 32-bit image to 256 color - Printable Version

+- QB64 Phoenix Edition (https://staging.qb64phoenix.com)
+-- Forum: QB64 Rising (https://staging.qb64phoenix.com/forumdisplay.php?fid=1)
+--- Forum: Prolific Programmers (https://staging.qb64phoenix.com/forumdisplay.php?fid=26)
+---- Forum: SMcNeill (https://staging.qb64phoenix.com/forumdisplay.php?fid=29)
+---- Thread: Convert 32-bit image to 256 color (/showthread.php?tid=288)

Convert 32-bit image to 256 color - SMcNeill - 05-01-2022

And, after much brain melting, I think I've finally pieced together a suitable method to convert 32-bit images down to 256 colors for use with QB64.  Needless to say, you'll need the attached files to run this demo:

Code: (Select All)
_Define A-Z As _UNSIGNED LONG

ws = _NewImage(640, 480, 32) 'A 32 bit screen
ts = _NewImage(640, 480, 256) 'A 256 color screen, which is only used so I can get the standard 256 color paletter from it.
Screen ws
Randomize Timer
Dim color256 As _Unsigned Long

Const ConvertToStandard256Palette = -1 'Change to 0 and you can see that we preseve the second pass's
'                                       color information perfectly.
'                                       If the CONST is set, then we convert our colors on the screen
'                                       to as close of a match as possible, while preserving the standard
'                                       QB64 256-color palette.

Cls , _RGB32(0, 0, 0)

For j = 1 To 2
    If j = 1 Then
        For i = 1 To 100 '100 random colors
            'if we want to use the standard 256 color screen palette, we can do so as below
            color256 = _RGB32(_Red(i, ts), _Green(i, ts), _Blue(i, ts))
            Line (Rnd * 640, Rnd * 480)-(Rnd * 640, Rnd * 480), color256, BF
        Next
    Else 'we can go with completely random colors with the following instead:
        For i = 1 To 100 '100 random colors
            Line (Rnd * 640, Rnd * 480)-(Rnd * 640, Rnd * 480), &HF0000000 + Rnd * &HFFFFFFF, BF
        Next
    End If
    Print "This is the original screen, pass"; j
    Sleep 'show the original screen

    t = Image32To256(ws)
    Screen t 'show the standard 256 image screen with the image converted over
    '         this keeps us from having to learn or use any new/unique palettes the image may have
    '         but, it does cause us to lose details and hues.
    Print "This is the 256-color screen, pass"; j
    Sleep
    Screen ws
    _FreeImage t
    Cls
Next


l = _LoadImage("Beautiful_colorful_bird_wallpaper01.jpg", 32)
Screen l
_ScreenMove 0, 0 'move the screen to use as much of the screen as possible, since it's so damn huge!
Print "This is the original 32-bit screen."
Sleep 'to show the 32-bit image of the colorful bird I found

t = Image32To256(l)
Screen t 'show the 256 image screen with the image converted over
_ScreenMove 0, 0 'move this one too!
Print "This is the converted 256 color screen."
'And we're done.  You should now be seeing a pretty little 256 color version of the bird


Function Image32To256 (image&)
    Dim o As _Offset
    Dim a As _Unsigned _Byte, r As _Unsigned _Byte
    Dim g As _Unsigned _Byte, b As _Unsigned _Byte
    Dim t As _Unsigned Long, color256 As _Unsigned Long
    Dim index256 As _Unsigned Long
    Type Pal_type
        c As _Unsigned Long 'color index
        n As Long 'number of times it appears
    End Type
    Dim Pal(255) As _Unsigned Long
    I256 = _NewImage(_Width(image&), _Height(image&), 256)
    Dim m(1) As _MEM: m(0) = _MemImage(image&): m(1) = _MemImage(I256)
    Do 'get the palette and number of colors used
        _MemGet m(0), m(0).OFFSET + o, t 'Get the colors from the original screen
        For i = 0 To colors 'check to see if they're in the existing palette we're making
            If Pal(i) = t Then Exit For
        Next
        If i > colors Then
            Pal(colors) = t
            colors = colors + 1 'increment the index for the new color found
            If colors > 255 Then 'no need to check any further; it's not a normal QB64 256 color image
                Image32To256 = RemapImageFS(image&, I256)
                _FreeImage I256
                _MemFree m()
                Exit Function 'and we're done, with 100% image compatability saved
            End If
        End If
        o = o + 4
    Loop Until o >= m(0).SIZE

    '  we might be working with a standard qb64 256 color screen
    '  check for that first
    colors = colors - 1 'back up one, as we found our limit and aren't needing to set another
    For i = 0 To colors 'comparing palette against QB64 256 color palette
        t = Pal(i)
        index256 = _RGBA(_Red(t), _Green(t), _Blue(t), _Alpha(t), I256)
        color256 = _RGBA32(_Red(index256, I256), _Green(index256, I256), _Blue(index256, I256), _Alpha(index256, I256))
        If t <> color256 Then NSCU = -1: Exit For
    Next
    If NSCU Then 'it's not a standard QB64 256 color palette, but it's still less than 256 total colors.
        If ConvertToStandard256Palette Then
            TI256 = RemapImageFS(image&, I256)
            _MemFree m(1) 'free the old memory
            _FreeImage I256 'and the old image
            I256 = TI256 'replace with the new image
            m(1) = _MemImage(I256) 'and point the mem block to the new image
        Else
            For i = 0 To colors: _PaletteColor i, Pal(i), I256: Next 'set the palette
        End If
    End If
    'If we didn't change the palette above, we should work 100% with qb64's internal 256 color palette
    o = 0
    Do 'Get the colors, put them to a 256 color screen, as is
        _MemGet m(0), m(0).OFFSET + o + 3, a
        _MemGet m(0), m(0).OFFSET + o + 2, r
        _MemGet m(0), m(0).OFFSET + o + 1, g
        _MemGet m(0), m(0).OFFSET + o + 0, b
        _MemPut m(1), m(1).OFFSET + o \ 4, _RGBA(r, g, b, a, I256) As _UNSIGNED _BYTE
        o = o + 4
    Loop Until o >= m(0).SIZE
    _MemFree m()
    Image32To256 = I256
End Function

Function RemapImageFS& (ohan&, dhan&)
    RemapImageFS& = -1 'so far return invalid handle
    shan& = ohan& 'avoid side effect on given argument
    If shan& < -1 Then
        '--- check/adjust source image & get new 8-bit image ---
        swid% = _Width(shan&): shei% = _Height(shan&)
        If _PixelSize(shan&) <> 4 Then
            than& = _NewImage(swid%, shei%, 32)
            If than& >= -1 Then Exit Function
            _PutImage , shan&, than&
            shan& = than&
        Else
            than& = -1 'avoid freeing below
        End If
        nhan& = _NewImage(swid%, shei%, 256)
        '--- Floyd-Steinberg error distribution arrays ---
        rhan& = _NewImage(swid%, 2, 32) 'these are missused as LONG arrays,
        ghan& = _NewImage(swid%, 2, 32) 'with CHECKING:OFF this is much faster
        bhan& = _NewImage(swid%, 2, 32) 'than real QB64 arrays
        '--- curr/next row offsets (for distribution array access) ---
        cro% = 0: nro% = swid% * 4 'will be swapped after each pixel row
        '--- the matrix values are extended by 16384 to avoid slow floating ---
        '--- point ops and to allow for integer storage in the above arrays ---
        '--- also it's a power of 2, which may be optimized into a bitshift ---
        seven% = (7 / 16) * 16384 'X+1,Y+0 error fraction
        three% = (3 / 16) * 16384 'X-1,Y+1 error fraction
        five% = (5 / 16) * 16384 'X+0,Y+1 error fraction
        one% = (1 / 16) * 16384 'X+1,Y+1 error fraction
        '--- if all is good, then start remapping ---
        $Checking:Off
        If nhan& < -1 And rhan& < -1 And ghan& < -1 And bhan& < -1 Then
            _CopyPalette dhan&, nhan& 'dest palette to new image
            '--- for speed we do direct memory access ---
            Dim sbuf As _MEM: sbuf = _MemImage(shan&): soff%& = sbuf.OFFSET
            Dim nbuf As _MEM: nbuf = _MemImage(nhan&): noff%& = nbuf.OFFSET
            Dim rbuf As _MEM: rbuf = _MemImage(rhan&): roff%& = rbuf.OFFSET
            Dim gbuf As _MEM: gbuf = _MemImage(ghan&): goff%& = gbuf.OFFSET
            Dim bbuf As _MEM: bbuf = _MemImage(bhan&): boff%& = bbuf.OFFSET
            '--- iterate through pixels ---
            For y% = 0 To shei% - 1
                For x% = 0 To swid% - 1
                    '--- curr/prev/next pixel offsets ---
                    cpo% = x% * 4: ppo% = cpo% - 4: npo% = cpo% + 4
                    '--- get pixel ARGB value from source ---
                    srgb~& = _MemGet(sbuf, soff%&, _Unsigned Long)
                    '--- add distributed error, shrink by 16384, clear error ---
                    '--- current pixel X+0, Y+0 (= cro% (current row offset)) ---
                    poff% = cro% + cpo% 'pre-calc full pixel offset
                    sr% = ((srgb~& And &HFF0000~&) \ 65536) + (_MemGet(rbuf, roff%& + poff%, Long) \ 16384) 'red
                    sg% = ((srgb~& And &HFF00~&) \ 256) + (_MemGet(gbuf, goff%& + poff%, Long) \ 16384) 'green
                    sb% = (srgb~& And &HFF~&) + (_MemGet(bbuf, boff%& + poff%, Long) \ 16384) 'blue
                    _MemPut rbuf, roff%& + poff%, 0 As LONG 'clearing each single pixel error using _MEMPUT
                    _MemPut gbuf, goff%& + poff%, 0 As LONG 'turns out even faster than clearing the entire
                    _MemPut bbuf, boff%& + poff%, 0 As LONG 'pixel row using _MEMFILL at the end of the loop
                    '--- find nearest color ---
                    crgb~& = _RGBA32(sr%, sg%, sb%, 0) 'used for fast value clipping + channel merge
                    npen% = _RGB(sr%, sg%, sb%, nhan&)
                    '--- put colormapped pixel to dest ---
                    _MemPut nbuf, noff%&, npen% As _UNSIGNED _BYTE
                    '------------------------------------------
                    '--- Floyd-Steinberg error distribution ---
                    '------------------------------------------
                    '--- You may comment this block out, to see the
                    '--- result without applied FS matrix.
                    '-----
                    '--- get dest palette RGB value, calc error to clipped source ---
                    nrgb~& = _PaletteColor(npen%, nhan&)
                    er% = ((crgb~& And &HFF0000~&) - (nrgb~& And &HFF0000~&)) \ 65536
                    eg% = ((crgb~& And &HFF00~&) - (nrgb~& And &HFF00~&)) \ 256
                    eb% = (crgb~& And &HFF~&) - (nrgb~& And &HFF~&)
                    '--- distribute error according to FS matrix ---
                    If x% > 0 Then
                        '--- X-1, Y+1 (= nro% (next row offset)) ---
                        poff% = nro% + ppo% 'pre-calc full pixel offset
                        _MemPut rbuf, roff%& + poff%, _MemGet(rbuf, roff%& + poff%, Long) + (er% * three%) As LONG 'red
                        _MemPut gbuf, goff%& + poff%, _MemGet(gbuf, goff%& + poff%, Long) + (eg% * three%) As LONG 'green
                        _MemPut bbuf, boff%& + poff%, _MemGet(bbuf, boff%& + poff%, Long) + (eb% * three%) As LONG 'blue
                    End If
                    '--- X+0, Y+1 (= nro% (next row offset)) ---
                    poff% = nro% + cpo% 'pre-calc full pixel offset
                    _MemPut rbuf, roff%& + poff%, _MemGet(rbuf, roff%& + poff%, Long) + (er% * five%) As LONG 'red
                    _MemPut gbuf, goff%& + poff%, _MemGet(gbuf, goff%& + poff%, Long) + (eg% * five%) As LONG 'green
                    _MemPut bbuf, boff%& + poff%, _MemGet(bbuf, boff%& + poff%, Long) + (eb% * five%) As LONG 'blue
                    If x% < (swid% - 1) Then
                        '--- X+1, Y+0 (= cro% (current row offset)) ---
                        poff% = cro% + npo% 'pre-calc full pixel offset
                        _MemPut rbuf, roff%& + poff%, _MemGet(rbuf, roff%& + poff%, Long) + (er% * seven%) As LONG 'red
                        _MemPut gbuf, goff%& + poff%, _MemGet(gbuf, goff%& + poff%, Long) + (eg% * seven%) As LONG 'green
                        _MemPut bbuf, boff%& + poff%, _MemGet(bbuf, boff%& + poff%, Long) + (eb% * seven%) As LONG 'blue
                        '--- X+1, Y+1 (= nro% (next row offset)) ---
                        poff% = nro% + npo% 'pre-calc full pixel offset
                        _MemPut rbuf, roff%& + poff%, _MemGet(rbuf, roff%& + poff%, Long) + (er% * one%) As LONG 'red
                        _MemPut gbuf, goff%& + poff%, _MemGet(gbuf, goff%& + poff%, Long) + (eg% * one%) As LONG 'green
                        _MemPut bbuf, boff%& + poff%, _MemGet(bbuf, boff%& + poff%, Long) + (eb% * one%) As LONG 'blue
                    End If
                    '------------------------------------------
                    '--- End of FS ----------------------------
                    '------------------------------------------
                    noff%& = noff%& + 1 'next dest pixel
                    soff%& = soff%& + 4 'next source pixel
                Next x%
                tmp% = cro%: cro% = nro%: nro% = tmp% 'exchange distribution array row offsets
            Next y%
            '--- memory cleanup ---
            _MemFree bbuf
            _MemFree gbuf
            _MemFree rbuf
            _MemFree nbuf
            _MemFree sbuf
            '--- set result ---
            RemapImageFS& = nhan&
            nhan& = -1 'avoid freeing below
        End If
        $Checking:On
        '--- remapping done or error, cleanup remains ---
        If bhan& < -1 Then _FreeImage bhan&
        If ghan& < -1 Then _FreeImage ghan&
        If rhan& < -1 Then _FreeImage rhan&
        If nhan& < -1 Then _FreeImage nhan&
        If than& < -1 Then _FreeImage than&
    End If
End Function

As this works, it does 3 things for us:
First, it checks to see if the image has 256 colors or less in it.

If it does, then it checks to see if those 256 colors match the original QB64 256 color palette.  If they do, we convert the image to a standard QB64 256-color image, and at this point you can work with it with the normal color values you know and love.

If there's colors which aren't in the QB64 standard palette, then it alters the palette to match the image and then converts it to work with that palette.  (How you'd know what colors are what, I dunno, but I'll leave that up to the end user to sort out.  I suppose if you have a palette which you normally use, you could scan the colors in this one and swap them back and forth with the ones which you normally use, until the values match as originally intended.)

The results seem more than reasonable to me, and this will be a tool which I'll probably make use of quite a bit in the future.  With it, loading and using 256 color images are now available once again with QB64!


[i][b]NOTE: Don't forget the attached files![/b][/i]



In the demo, the first pass uses the standard QB64 256 color palette.  As you notice, the white text which we print to the screen with, continues to remain white, with no issues.

The second pass uses a random set of colors, which certainly won't match the standard 256 color palette, forcing us to save the palette in use, which (more than likely) is going to change the default value of white.  The text which pops up in the top left of the converted screen is going to whatever the NEW palette tells us white is, for that image.

The third pass takes a large numbers of colors, dithers them down to 256 colors, and then saves the palette for them as closely as possible to the original.  Since we attempted to save the image, converted down using the QB64 standard palette, the colors should be the ones that you're used to seeing normally.  The white text should still look white, just as normal for us.

Play around with it.  Kick it about a bit.  See how it performs for you, and if there's any issues or problems. 

And don't forget to thank RhoSigma, whose graphic library I borrowed (stole really  Big Grin ) heavily from to get this working the way it is now.