First the code, and then the discussion about it. 
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. )
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.
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 prefix
uffix 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.
)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.
