Thread Rating:
  • 1 Vote(s) - 5 Average
  • 1
  • 2
  • 3
  • 4
  • 5
SaveImage Library 3.0 (in progress)
#1
First the code, and then the discussion about it.  Tongue

Code: (Select All)
'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 prefixConfuseduffix 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



Now, as you guys probably know, I've had a SaveImage Library for use with QB64 and QB64PE for the last dozen years or so.  The primary use of this library was to allow folks to quickly and easily capture whatever screen they wanted, and to save it to disk -- and it was LOVELY!!

... and then.... the evil, mean, nasty, brilliant _SAVEIMAGE command was added to the language and made the library more-or-less obsolete overall.  (All that hard work and all those years maintaining it, for it to die on us!  /WAAAAHHHHH!!!!)

Which leads to you guys asking, "Well then, Steve, just what the crap is this junk here??"

Well, I'm glad you asked!  (Or I imagined you asked, anyway. Tongue )

This is basically an extension of what was left from my old code, and is still relevant with today's _SAVEIMAGE command being built in.

What does this offer that _SAVEIMAGE doesn't??

1) Partial screen grabs and saves -- say you just want an image from (100,100)-(300,300), and not the whole screen.  This does that!
2) This saves GIF files for us.  The built-in _SAVEIMAGE doesn't do that!  /Nanner-nanner!
3) This has some built in image tools for us which allow us to convert text screens to graphic screens, or 32-bit screens to 256-color screens.

And what does _SAVEIMAGE do that this doesn't??

1)



And, I'll probably built in a few more useful features for this in the future, as this is just my first draft at upgrading this longstanding routine to make it relevant once again for everyone.  Smile
Reply
#2
G'donya Steve!
This sounds exciting... even *I* can think of uses for this!
Of all the places on Earth, and all the planets in the Universe, I'd rather live here (Perth, W.A.) Big Grin
Please visit my Website at: http://oldendayskids.blogspot.com/
Reply
#3
Updated with comments and fixed a few minor spots where I exited without resetting the source and dest back to what they were before the routine ran.
Reply
#4
gifs @smneill you can make mini films with this? that would be fantastic
b = b + ...
Reply
#5
(06-22-2024, 03:14 PM)bplus Wrote: gifs @smneill you can make mini films with this? that would be fantastic

Just single frame gifs, for now.  I may expand it for multi-frames later.  Smile
Reply
#6
please do mini movies if you can. that would be fabulous to show animated clips of our code master-pieces.

i was under impression that _saveimage in QB64pe was your code incorportated.

getting section is handy but as i recall _saveimage takes a handle so was't hard to do a section from a _newimage handle.
b = b + ...
Reply




Users browsing this thread: 1 Guest(s)