'Note that there are two SHARED variables which we can make use of with this set of code:

'ConvertToStandard256Palette and SaveTextAs256Color

'(Long arse names, I know, but they shouldn't have any name collisions with other's code like so.)



'SaveTextAs256Color is a flag we can set to save Screen 0 screens in 256 color mode.

'If it's not TRUE (has a value of 0), then we save Screen 0 screens in 32-bit color mode.

'Dim a LONG varialbe with this name, and set it to non-zero, if you want to save in 256 colors,

'which have smaller file sizes usually.



'ConvertToStandard256Palette is a flag we set to decide if we want to reduce 32-bit color screens

'down to the standard 256-color QB64PE palette, or if we want to use whatever colors best suit

'the image.

'Set the value to 0 (FALSE) to preseve the color information perfectly, using its default palette.

'If the value is set (TRUE), then we convert our colors to as close of a match as possible, while

'preserving the standard QB64 256-color palette.



'For this brief demo here, neither are in effect, as they're completely optional flags.





testing$ = "temp.gif"



PRINT "Testing test test"



IF _FILEEXISTS(testing$) THEN KILL testing$

x = SaveImage(testing$, 0, 1, 1, 10, 10)



FUNCTION SaveImage (file$, image&, tx1%, ty1%, tx2%, ty2%)

    'This routine can benefit/be altered if the user sets a couple of CONST or DIM SHARED variables

    'to alter the behavior of things a little, as so:



    'SaveTextAs256Color is a flag we can set to save Screen 0 screens in 256 color mode.

    'If it's not TRUE (has a value of 0), then we save Screen 0 screens in 32-bit color mode.

    'Dim a LONG varialbe with this name, and set it to non-zero, if you want to save in 256 colors,

    'which have smaller file sizes usually.



    'ConvertToStandard256Palette is a flag we set to decide if we want to reduce 32-bit color screens

    'down to the standard 256-color QB64PE palette, or if we want to use whatever colors best suit

    'the image.

    'Set the value to 0 (FALSE) to preseve the color information perfectly, using its default palette.

    'If the value is set (TRUE), then we convert our colors to as close of a match as possible, while

    'preserving the standard QB64 256-color palette.







    'ERROR CODES WHICE WE CAN GENERATE:

    '1 File Already Exists. As these are Binary files, we probably don't want to just overwrite the same file.

    '2 WINDOW coordinates not supported.  Convert to standard coordinates before using SaveImage.

    '3 Bad x/y coordinates which are beyond the bounds of the screen.

    '4 Bad file format passed to be saved.

    '5 Image Failed to save for some unknown reason.  Sorry.





    D = _DEST: S = _SOURCE

    _DEST image&: _SOURCE image&

    IF _FILEEXISTS(file$) THEN glitch = 1



    x1% = tx1%: y1% = ty1% 'preserve our old coordiantes without changing them

    x2% = tx2%: y2% = ty2% 'ditto





    bpp = _PIXELSIZE

    SELECT CASE bpp 'any glitch here is from sending an x/y coordinate off the screen

        CASE 0 'text image

            IF x1% < 1 OR x1% > _WIDTH(image&) THEN glitch = 3

            IF x2% < 1 OR x2% > _WIDTH(image&) THEN glitch = 3

            IF y1% < 1 OR y1% > _HEIGHT(image&) THEN glitch = 3

            IF y2% < 1 OR y2% > _HEIGHT(image&) THEN glitch = 3

        CASE 1, 4 ' 256 color image// 32-bit color image

            IF PMAP(0, 2) <> 0 OR PMAP(0, 3) <> 0 THEN glitch = 2

            IF PMAP(_WIDTH - 1, 2) <> _WIDTH - 1 OR PMAP(_HEIGHT - 1, 3) <> _HEIGHT - 1 THEN glitch = 2

            IF x1% < 0 OR x1% >= _WIDTH(image&) THEN glitch = 3

            IF x2% < 0 OR x2% >= _WIDTH(image&) THEN glitch = 3

            IF y1% < 0 OR y1% >= _HEIGHT(image&) THEN glitch = 3

            IF y2% < 0 OR y2% >= _HEIGHT(image&) THEN glitch = 3

    END SELECT



    ext$ = RIGHT$(file$, 3) 'get the extension

    SELECT CASE UCASE$(ext$)

        CASE "JPG", "PNG", "TGA", "BMP", "PSD", "GIF", "HDR", "PIC", "PNM", "PCX", "SVG", "QOI"

            'built in _SaveImage formats.  All these are good.

        CASE "GIF"

            'this is good, as this is included in the SaveImage Library here.

        CASE ELSE

            glitch = 4 'any glitch here is from an invalid extension on the file$

    END SELECT



    IF glitch THEN

        _DEST D: _SOURCE S

        SaveImage = glitch

        EXIT FUNCTION

    END IF



    'If we've made it to here, then everything should pass muster and be good for saving.

    'No other file exists that we'd try to overwrite.  (Error 1)  -- check!

    'Window coordinates are not in play to screw up anything.  (Error 2) -- check!

    'Our x/y coorinates are actually on the screen.  (Error 3) -- check!

    'And we're in a valid and recognized format.  (Error 4) -- check!



    'All checks passed -- let's do this!!



    IF x2% < x1% THEN SWAP x2%, x1%

    IF y2% < y1% THEN SWAP y2%, y1%



    SELECT CASE bpp

        CASE 0 'we have to convert our screen 0 image to a graphic image

            IF SaveTextAs256Color <> 0 OR UCASE$(ext$) = "GIF" THEN

                tempimage& = TextScreenToImage256&(image&)

            ELSE

                tempimage& = TextScreenToImage32&(image&)

            END IF

            F = _FONT(image&)

            FW = _FONTWIDTH(F): FH = _FONTHEIGHT(F)

            SaveImage = SaveImage(file$, tempimage&, (x1% - 1) * FW, (y1% - 1) * FH, x2% * FW - 1, y2% * FH - 1)

            _FREEIMAGE tempimage&

            _DEST D: _SOURCE S

            EXIT FUNCTION

        CASE 1

            mode = 256

            IF UCASE$(ext$) = "GIF" THEN

                MakeGIF file$, x1%, y1%, x2%, y2%, 256

                SkipCreation = -1

            END IF

        CASE 4

            IF UCASE$(ext$) = "GIF" THEN 'we have to convert 32-bit images down to 256 colors for a GIF

                t = Image32To256(image&) 'View comments in FUNCTION Image32To256 for CONST settings to toggle behavior

                _DEST t: _SOURCE t 'make the converted image our source

                MakeGIF file$, x1%, y1%, x2%, y2%, 256

                _DEST D: _SOURCE S 'restore our source

                _FREEIMAGE t 'free the converted image

                SkipCreation = -1

            END IF

            mode = 32

    END SELECT



    IF SkipCreation = 0 THEN 'we didn't already make the file in GIF format.

        'We still need to create it here, in whatever valid format we specified.

        Xsize = x2% - x1% + 1: Ysize = y2% - y1% + 1

        tempimage& = _NEWIMAGE(Xsize, Ysize, mode)

        _PUTIMAGE (0, 0)-(Xsize - 1, Ysize - 1), image&, tempimage&, (x1%, y1%)-(x2%, y2%)

        _SAVEIMAGE file$, tempimage&

        _FREEIMAGE tempimage&

    END IF



    'We should have now saved our image in whatever format we chose.

    'Let's test to make certain that we can load it validly.

    tempimage& = _LOADIMAGE(file$)

    IF tempimage& = -1 THEN 'we didn't load the image!  Something went wrong.

        SaveImage = 5 'Error 5 here is from failure to reload the saved image, for who knows what reason.

        'Disk full?  Tried to save on a locked drive?  USB stick got ejected?  I dunno!

        'I just know we passed all the tests, *should've* made a file, but when we went to load it

        'back, it simply didn't load.

        'Honestly, the file may have been written properly and _LOADIMAGE might be glitched, or some such.

        'All we know for certain is we tried to save and load the results and something failed.

        'Report it with 5, and let the end user sort it out.

    ELSE

        SaveImage = 0

        _FREEIMAGE tempimage&

    END IF

    _DEST D: _SOURCE S

END FUNCTION





FUNCTION TextScreenToImage256& (image&)

    d& = _DEST: s& = _SOURCE

    DIM Plt(15) AS LONG

    _SOURCE image&: _DEST image&

    FOR i = 0 TO 15: Plt(i) = _PALETTECOLOR(i, image&): NEXT

    f& = _FONT(image&)

    _FONT f&

    fw& = _FONTWIDTH

    fh& = _FONTHEIGHT

    w& = _WIDTH * _FONTWIDTH

    h& = _HEIGHT * _FONTHEIGHT '+ _HEIGHT

    l& = (_WIDTH * _HEIGHT) * 2 'The screen is width * height in pixels.  (80X25) = 2000 X 2 bytes each = 4000 total bytes to hold a page of screen 0 text and color

    tempscreen& = _NEWIMAGE(w&, h& + _HEIGHT, 256)

    Screen0to256& = _NEWIMAGE(w&, h&, 256)



    DIM m AS _MEM, b AS _UNSIGNED _BYTE, t AS STRING * 1

    DIM o AS _OFFSET

    m = _MEMIMAGE(image&)

    o = m.OFFSET



    _DEST (tempscreen&)

    FOR i = 0 TO 15: _PALETTECOLOR i, Plt(i): NEXT

    _FONT f&



    FOR i = 0 TO l& - 2 STEP 2

        _MEMGET m, m.OFFSET + i, t

        _MEMGET m, m.OFFSET + i + 1, b

        IF b > 127 THEN b = b - 128

        COLOR b MOD 16, b \ 16

        PRINT t;

    NEXT

    _PUTIMAGE , tempscreen&, Screen0to256&, (0, 0)-(w&, h&)

    _FREEIMAGE tempscreen&

    _DEST d&: _SOURCE s&

    _MEMFREE m

    TextScreenToImage256 = Screen0to256&

END FUNCTION



FUNCTION TextScreenToImage32& (image&)

    d& = _DEST: s& = _SOURCE

    DIM Plt(15) AS LONG

    _SOURCE image&

    FOR i = 0 TO 15: Plt(i) = _PALETTECOLOR(i, image&): NEXT

    f& = _FONT(image&)

    _FONT f&

    fw& = _FONTWIDTH

    fh& = _FONTHEIGHT

    w& = _WIDTH * _FONTWIDTH

    h& = _HEIGHT * _FONTHEIGHT '+ _HEIGHT

    l& = (_WIDTH * _HEIGHT) * 2 'The screen is width * height in pixels.  (80X25) = 2000 X 2 bytes each = 4000 total bytes to hold a page of screen 0 text and color

    tempscreen& = _NEWIMAGE(w&, h& + _HEIGHT, 32)

    Screen0to32& = _NEWIMAGE(w&, h&, 32)

    _DEST tempscreen&



    DIM m AS _MEM, b AS _UNSIGNED _BYTE, t AS STRING * 1

    DIM o AS _OFFSET

    m = _MEMIMAGE(image&)

    o = m.OFFSET



    _FONT f&



    FOR i = 0 TO l& - 2 STEP 2

        _MEMGET m, m.OFFSET + i, t

        _MEMGET m, m.OFFSET + i + 1, b

        IF b > 127 THEN b = b - 128

        fgc = b MOD 16: bgc = b \ 16

        COLOR _RGB32(_RED(fgc, image&), _GREEN(fgc, image&), _BLUE(fgc, image&)), _RGB32(_RED(bgc, image&), _GREEN(bgc, image&), _BLUE(bgc, image&))

        PRINT t;

    NEXT

    _PUTIMAGE , tempscreen&, Screen0to32&, (0, 0)-(w&, h&)

    _FREEIMAGE tempscreen&

    _DEST d&: _SOURCE s&

    _MEMFREE m

    TextScreenToImage32 = Screen0to32&

END FUNCTION









FUNCTION Image32To256 (image&)

    'This routine can benefit/be altered if the user sets a CONST or DIM SHARED variable name ConvertToStandard256Palette, as so:

    '    CONST ConvertToStandard256Palette = -1

    '          Set the value to 0 (FALSE) to preseve the color information perfectly, using its default palette.

    '          If the CONST is set (TRUE), then we convert our colors to as close of a match as possible, while

    '          preserving the standard QB64 256-color palette.

    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(_RED32(t), _GREEN32(t), _BLUE32(t), _ALPHA32(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&) 'Routine written by RhoSigma and used (with permission) for ImageSaver Library

    '// +---------------+---------------------------------------------------+

    '// | ###### ###### |    .--. .        .-.                            |

    '// | ##  ## ##  # |    |  )|        (  ) o                        |

    '// | ##  ##  ##    |    |--' |--. .-.  `-.  .  .-...--.--. .-.        |

    '// | ######  ##  |    |  \ |  |(  )(  ) | (  ||  |  |(  )      |

    '// | ##      ##    |    '  `'  `-`-'  `-'-' `-`-`|'  '  `-`-'`-      |

    '// | ##    ##  # |                            ._.'                  |

    '// | ##    ###### | Sources & Documents placed under the MIT License. |

    '// +-------------------------------------------------------------------+

    '// | Done by RhoSigma, R.Heyder, provided AS IS, use at your own risk. |

    '// | Find me in the QB64 Forum or mail to support@rhosigma-cw.net for  |

    '// | any questions or suggestions. Thanx for your interest in my work. |

    '// +-------------------------------------------------------------------+



    RemapImageFS& = -1 'so far return invalid handle

    shan& = ohan& 'avoid side effect on given argument

    IF shan& < -1 OR shan& = 0 THEN '0 represents the visible screen

        '--- 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% = 7168 '(7 / 16) * 16384 'X+1,Y+0 error fraction

        three% = 3072 '(3 / 16) * 16384 'X-1,Y+1 error fraction

        five% = 5120 '(5 / 16) * 16384 'X+0,Y+1 error fraction

        one% = 1025 '(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









'-----------------------------------------------------------------------------

'            GIFcreate.BM Compression Routine v1.00 By Rich Geldreich 1992

'            Converted into one SUB Library routine by Ted Weissgerber 2011

'            Copied from QB64 wiki and inserted into SaveImage library 2019

'-----------------------------------------------------------------------------

'                  For 1 BPP, 4 BPP or 8 BPP images only!

'file$      = save image output filename

'XStart      = <-left hand column of area to encode

'YStart      = <-upper row of area to encode

'Xend        = <-right hand column of area to encode

'Yend        = <-lowest row of area to encode                                      "

'NumColors  = # of colors on screen: 2(Black & White), 16(SCREEN 12), 256(SCREEN13)

'



SUB MakeGIF (file$, Xstart, YStart, Xend, Yend, NumColors)

    IF Xend = _WIDTH THEN Xend = _WIDTH - 1 'Minor correct to prevent many simple user errors

    IF Yend = _WIDTH THEN Yend = _HEIGHT - 1 '



    CONST True = -1, False = 0

    CONST Table.size = 7177 'hash table's size - must be a prime number!



    DIM Prefix(Table.size - 1), Suffix(Table.size - 1), Code(Table.size - 1)

    DIM Shift(7) AS LONG

    DIM i AS INTEGER, PWidth AS INTEGER, PDepth AS INTEGER

    DIM MaxX AS INTEGER, MaxY AS INTEGER

    DIM MinX AS INTEGER, MinY AS INTEGER

    DIM GIF AS INTEGER

    DIM temp AS STRING, Zero AS STRING, OutBuffer AS STRING

    DIM BitsPixel AS INTEGER

    DIM StartSize AS INTEGER

    DIM StartCode AS INTEGER

    DIM StartMax AS INTEGER

    DIM ColorBits AS INTEGER

    DIM CP AS INTEGER, C AS INTEGER, R AS INTEGER, G AS INTEGER

    DIM B AS INTEGER, CurrentBit AS INTEGER, CHAR AS LONG

    DIM MaxCode AS INTEGER, CodeSize AS INTEGER, ClearCode AS INTEGER

    DIM EOFCode AS INTEGER, NextCode AS INTEGER

    DIM Buff AS LONG

    DIM Oseg AS INTEGER, OAddress AS INTEGER, OEndAddress AS INTEGER, OStartAddress AS INTEGER

    DIM PC AS INTEGER, x AS INTEGER, y AS INTEGER, Prefix AS INTEGER

    DIM GB AS INTEGER, Done AS INTEGER, PB AS INTEGER

    DIM BlockLength AS INTEGER, LastLoc AS LONG

    DIM Suffix AS INTEGER, Found AS INTEGER, Index AS INTEGER

    DIM A AS INTEGER, Offset AS INTEGER, BW AS INTEGER



    FOR i = 0 TO 7: Shift(i) = 2 ^ i: NEXT 'create exponent array for speed.



    PWidth% = ABS(Xend - Xstart) + 1

    PDepth% = ABS(Yend - YStart) + 1

    'MinX, MinY, MaxX, MaxY are maximum and minimum image coordinates

    IF Xstart > Xend THEN MaxX = Xstart: MinX = Xend ELSE MaxX = Xend: MinX = Xstart

    IF YStart > Xend THEN MaxY = YStart: MinY = Yend ELSE MaxY = Yend: MinY = YStart



    'Open GIF output file

    GIF = FREEFILE 'use next free file

    OPEN file$ FOR BINARY AS #GIF



    temp = "GIF87a": PUT #GIF, , temp 'Put GIF87a header at beginning of file



    SELECT CASE NumColors 'get color settings

        CASE 2 'monochrome (B&W) image

            BitsPixel = 1 '1 bit per pixel

            StartSize = 3 'first LZW code is 3 bits

            StartCode = 4 'first free code

            StartMax = 8 'maximum code in 3 bits

        CASE 16 '16 colors images SCREENS 7, 8, 9, 12, 13

            BitsPixel = 4 '4 bits per pixel

            StartSize = 5 'first LZW code is 5 bits

            StartCode = 16 'first free code

            StartMax = 32 'maximum code in 5 bits

        CASE 256 '256 color images SCREEN 13 or _NEWIMAGE 256

            BitsPixel = 8 '8 bits per pixel

            StartSize = 9 'first LZW code is 9 bits

            StartCode = 256 'first free code

            StartMax = 512 'maximum code in 9 bits

    END SELECT



    'ColorBits = 2      'for EGA

    ColorBits = 6 'VGA monitors ONLY



    PUT #GIF, , PWidth% 'put screen's dimensions

    PUT #GIF, , PDepth%



    CP = 128 + (ColorBits - 1) * 16 + (BitsPixel - 1) 'pack colorbits and bits per pixel

    PUT #GIF, , CP



    Zero$ = CHR$(0) 'PUT a zero into the GIF file

    PUT #GIF, , Zero$



    OUT &H3C7, 0 'start read at color 0

    FOR C = 0 TO NumColors - 1 'Get the RGB palette from the screen and put into file

        R = (INP(&H3C9) * 65280) \ 16128 'C = R * 4.0476190(for 0-255)

        G = (INP(&H3C9) * 65280) \ 16128

        B = (INP(&H3C9) * 65280) \ 16128

        temp = CHR$(R): PUT #GIF, , temp

        temp = CHR$(G): PUT #GIF, , temp

        temp = CHR$(B): PUT #GIF, , temp

    NEXT

    'write out an image descriptor

    temp = "," 'image separator

    PUT #GIF, , temp 'write it

    PUT #GIF, , MinX 'image start locations

    PUT #GIF, , MinY

    PUT #GIF, , PWidth% 'store them into the file

    PUT #GIF, , PDepth%

    temp = CHR$(BitsPixel - 1) '# bits per pixel in the image

    PUT #GIF, , temp

    temp = CHR$(StartSize - 1) 'store the LZW minimum code size

    PUT #GIF, , temp



    CurrentBit = 0: CHAR& = 0 'Initialize the vars needed by PutCode



    MaxCode = StartMax 'the current maximum code size

    CodeSize = StartSize 'the current code size

    ClearCode = StartCode 'ClearCode & EOF code are the

    EOFCode = StartCode + 1 'first two entries

    StartCode = StartCode + 2 'first free code that can be used

    NextCode = StartCode 'the current code



    OutBuffer$ = STRING$(5000, 32) 'output buffer; for speedy disk writes

    Buff& = SADD(OutBuffer$) 'find address of buffer

    Buff& = Buff& - 65536 * (Buff& < 0)

    Oseg = VARSEG(OutBuffer$) + (Buff& \ 16) 'get segment + offset >> 4

    OAddress = Buff& AND 15 'get address into segment

    OEndAddress = OAddress + 5000 'end of disk buffer

    OStartAddress = OAddress 'current location in disk buffer

    DEF SEG = Oseg



    GOSUB ClearTree 'clear the tree & output a

    PC = ClearCode: GOSUB PutCode 'clear code



    x = Xstart: y = YStart 'X & Y have the current pixel

    GOSUB GetByte: Prefix = GB 'the first pixel is a special case

    Done = False 'True when image is complete



    DO 'while there are more pixels to encode

        DO 'until we have a new string to put into the table

            IF Done THEN 'write out the last pixel, clear the disk buffer

                '          'and fix up the last block so its count is correct



                PC = Prefix: GOSUB PutCode 'write last pixel

                PC = EOFCode: GOSUB PutCode 'send EOF code



                IF CurrentBit <> 0 THEN PC = 0: GOSUB PutCode 'flush out the last code...

                PB = 0: GOSUB PutByte

                OutBuffer$ = LEFT$(OutBuffer$, OAddress - OStartAddress)

                PUT #GIF, , OutBuffer$

                temp = ";" + STRING$(8, &H1A) 'the 8 EOF chars is not standard,

                PUT #GIF, , temp

                temp = CHR$(255 - BlockLength) 'correct the last block's count

                PUT #GIF, LastLoc&, temp

                CLOSE #GIF: EXIT SUB '<<<<<<<<<<< End of procedure

            ELSE 'get a pixel from the screen and find the new string in table

                GOSUB GetByte: Suffix = GB

                GOSUB Hash 'is it in hash table?

                IF Found = True THEN Prefix = Code(Index) 'replace prefixuffix string with code in table

            END IF

        LOOP WHILE Found 'don't stop unless we find a new string



        PC = Prefix: GOSUB PutCode 'output the prefix to the file

        Prefix(Index) = Prefix 'put the new string in the table

        Suffix(Index) = Suffix

        Code(Index) = NextCode 'we've got to keep track of code!



        Prefix = Suffix 'Prefix = the last pixel pulled from the screen



        NextCode = NextCode + 1 'get ready for the next code

        IF NextCode = MaxCode + 1 THEN 'increase the code size

            MaxCode = MaxCode * 2

            'Note: The GIF89a spec mentions something about a deferred clear code

            IF CodeSize = 12 THEN 'is the code size too big?

                PC = ClearCode: GOSUB PutCode 'yup; clear the table and

                GOSUB ClearTree 'start over

                NextCode = StartCode

                CodeSize = StartSize

                MaxCode = StartMax

            ELSE CodeSize = CodeSize + 1 'increase code size if not too high (not > 12)

            END IF

        END IF

    LOOP 'while we have more pixels



    '                              'GOSUB ROUTINES

    ClearTree:

    FOR A = 0 TO Table.size - 1 'clears the hashing table

        Prefix(A) = -1 '-1 = invalid entry

        Suffix(A) = -1

        Code(A) = -1

    NEXT

    RETURN



    Hash: 'hash the prefix & suffix(there are also many ways to do this...)

    Index = ((Prefix * 256&) XOR Suffix) MOD Table.size



    '        Note: the table size(7177 in this case) must be a prime number

    '    Calculate an offset just in case we don't find what we want first try...

    IF Index = 0 THEN 'cannot have Table.Size 0!

        Offset = 1

    ELSE

        Offset = Table.size - Index

    END IF



    DO 'loop until we find an empty entry or find what we're lookin for

        IF Code(Index) = -1 THEN 'is this entry blank?

            Found = False ' didn't find the string

            RETURN

        ELSEIF Prefix(Index) = Prefix AND Suffix(Index) = Suffix THEN

            Found = True 'found the string

            RETURN

        ELSE 'didn't find anything, must retry - this slows hashing down.

            Index = Index - Offset

            IF Index < 0 THEN 'too far down the table? wrap back the index to end of table

                Index = Index + Table.size

            END IF

        END IF

    LOOP



    PutByte: 'Puts a byte into the GIF file & also takes care of each block.

    BlockLength = BlockLength - 1 'are we at the end of a block?

    IF BlockLength <= 0 THEN 'end of block

        BlockLength = 255 'block length is now 255

        LastLoc& = LOC(GIF) + 1 + (OAddress - OStartAddress) 'remember the position

        BW = 255: GOSUB BufferWrite 'for later fixing

    END IF

    BW = PB: GOSUB BufferWrite

    RETURN



    BufferWrite: 'Puts a byte into the buffer

    IF OAddress = OEndAddress THEN 'are we at the end of the buffer?

        PUT #GIF, , OutBuffer$ 'write it out and

        OAddress = OStartAddress 'start all over

    END IF

    POKE OAddress, BW 'put byte in buffer

    OAddress = OAddress + 1 'increment position

    RETURN



    GetByte: 'This routine gets one pixel from the display

    GB = POINT(x, y) 'get the "byte"

    x = x + 1 'increment X coordinate

    IF x > MaxX THEN 'are we too far?

        x = MinX 'go back to start

        y = y + 1 'increment Y coordinate

        IF y > MaxY THEN Done = True 'flag if too far down

    END IF

    RETURN



    PutCode: 'Puts an LZW variable-bit code into the output file...

    CHAR& = CHAR& + PC * Shift(CurrentBit) 'put the char were it belongs;

    CurrentBit = CurrentBit + CodeSize 'shifting it to its proper place

    DO WHILE CurrentBit > 7 'do we have a least one full byte?

        PB = CHAR& AND 255: GOSUB PutByte 'mask it off and write it out

        CHAR& = CHAR& \ 256 'shift the bit buffer right 8 bits

        CurrentBit = CurrentBit - 8 'now we have 8 less bits

    LOOP 'loop until we don't have a full byte

    RETURN

END SUB

(06-22-2024, 03:14 PM)bplus Wrote: gifs @smneill you can make mini films with this? that would be fantastic