'Header include below is just here for ease of quick formatting and error checking of SUBS/FUNCTIONS when writing/editing the library. ''$INCLUDE:'SaveImage.BI' '************************************************ ' Beginning of SaveImage Library Subs/Functions by SMcNeill '************************************************ FUNCTION SaveImage (file$, image&, x1%, y1%, x2%, y2%) '-1 All is good. We think we exported a proper PNG file. ' 0 Compression failed. File is probably corrupt. ' 1 File Already Exists. As these are Binary files, we probably don't want to just overwrite the same file. ' 2 Incorrect Alpha settings. Check for Alpha mode, and Color mode, and look for conflicts. ' 3 Bad GrabMode ' 4 Bad x1 coordinate ' 5 Bad y1 coordinate ' 6 Bad x2 coordinate ' 7 Bad y2 coordinate ' 8 x2 < x1 -- correct this to proceed ' 9 y2 < y1 -- correct this to proceed '10 Bad color mode. Either use 256 or 32 color mode. '11 Attempted to export a text screen which will not work. '12 PNG save is impossible on non-Windows systems. Can only use BMP '13 Invalid extension, or lack of extension IF x1% < 0 THEN SaveImage = 4: EXIT FUNCTION IF y1% < 0 THEN SaveImage = 5: EXIT FUNCTION IF x2% > _WIDTH(image&) THEN SaveImage = 6: EXIT FUNCTION IF y2% > _HEIGHT(image&) THEN SaveImage = 7: EXIT FUNCTION IF x1% > x2% THEN SaveImage = 8: EXIT FUNCTION IF y1% > y2% THEN SaveImage = 9: EXIT FUNCTION IF _PIXELSIZE(image&) = 0 THEN IF x1% < 1 THEN x1% = 1 'Text Coordinates start at 1 to _WIDTH IF y1% < 1 THEN y1% = 1 IF SaveTextAs256Color 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& EXIT FUNCTION END IF ext$ = UCASE$(RIGHT$(file$, 4)) IF ext$ = ".BMP" THEN SaveBMP file$, image&, x1%, y1%, x2%, y2% SaveImage = -1 ELSEIF ext$ = ".PNG" THEN $IF WIN THEN SaveImage = PNGExport(file$, image&, x1%, y1%, x2%, y2%) $ELSE SaveImage = 12 'Error message informing that PNG saving is impossible on Linux $END IF ELSEIF ext$ = ".JPG" THEN SaveJPG file$, image&, x1%, y1%, x2%, y2% SaveImage = -1 ELSEIF ext$ = ".GIF" THEN S = _SOURCE: D = _DEST IF _PIXELSIZE(image&) = 4 THEN 'It's a 32-bit image screen. It has to be converted down to 256 colors before making 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 ELSE _SOURCE image&: MakeGIF file$, x1%, y1%, x2%, y2%, 256 _SOURCE S END IF SaveImage = -1 ELSE SaveImage = 13 END IF END SUB SUB SaveFullImage (filename$) S = _SOURCE result = SaveImage(filename$, S, 0, 0, _WIDTH(S) - 1, _HEIGHT(S) - 1) END SUB SUB SaveFullBMP (filename$) S = _SOURCE SaveBMP filename$, S, 0, 0, _WIDTH(S) - 1, _HEIGHT(S) - 1 END SUB FUNCTION SaveFullPNG (filename$) S = _SOURCE SaveFullPNG = PNGExport(filename$, S, 0, 0, _WIDTH(S) - 1, _HEIGHT(S) - 1) END SUB SUB SaveFullJPG (filename$) S = _SOURCE SaveJPG filename$, S, 0, 0, _WIDTH(S) - 1, _HEIGHT(S) - 1 END SUB SUB SaveBMP (filename$, image&, x1%, y1%, x2%, y2%) 'Super special STEVE-Approved BMP Export routine for use with any QB64 graphic mode. IF x2% = _WIDTH(image&) THEN x2% = x2% - 1 IF y2% = _HEIGHT(image&) THEN y2% = y2% - 1 IF _PIXELSIZE(image&) = 0 THEN IF SaveTextAs256Color THEN tempimage& = TextScreenToImage256&(image&) ELSE tempimage& = TextScreenToImage32&(image&) END IF F = _FONT(image&) FW = _FONTWIDTH(F): FH = _FONTHEIGHT(F) SaveBMP filename$, tempimage&, x1% * FW, y1% * FH, x2% * FW, y2% * FH _FREEIMAGE tempimage& EXIT FUNCTION END IF TYPE BMPFormat ID AS STRING * 2 Size AS LONG Blank AS LONG Offset AS LONG Hsize AS LONG PWidth AS LONG PDepth AS LONG Planes AS INTEGER BPP AS INTEGER Compression AS LONG ImageBytes AS LONG Xres AS LONG Yres AS LONG NumColors AS LONG SigColors AS LONG END TYPE DIM BMP AS BMPFormat DIM x AS LONG, y AS LONG DIM temp AS STRING, t AS STRING * 1 DIM n AS _MEM, o AS _OFFSET, m AS _MEM m = _MEMIMAGE(image&) IF x1% > x2% THEN SWAP x1%, x2% IF y1% > y2% THEN SWAP y1%, y2% IF x2% = _WIDTH(imagehandle%) THEN x2% = _WIDTH(imagehandle%) - 1 'troubleshoot in case user does a common mistake for 0-width instead of 0 - (width-1) for fullscreen IF y2% = _HEIGHT(imagehandle%) THEN y2% = _HEIGHT(imagehandle%) - 1 'troubleshoot in case user does a common mistake for 0-width instead of 0 - (width-1) for fullscreen s& = _SOURCE _SOURCE image& BMP.PWidth = (x2% - x1%) + 1 BMP.PDepth = (y2% - y1%) + 1 BMP.ID = "BM" BMP.Blank = 0 BMP.Hsize = 40 BMP.Planes = 1 BMP.Compression = 0 BMP.Xres = 0 BMP.Yres = 0 BMP.SigColors = 0 SELECT CASE _PIXELSIZE(image&) CASE 1 temp = SPACE$(x2% - x1% + 1) OffsetBITS& = 54 + 1024 'add palette in 256 color modes BMP.BPP = 8 IF BMP.PWidth MOD 4 THEN ZeroPAD$ = SPACE$(4 - (BMP.PWidth MOD 4)) ImageSize& = (BMP.PWidth + LEN(ZeroPAD$)) * BMP.PDepth BMP.ImageBytes = ImageSize& BMP.NumColors = 256 BMP.Size = ImageSize& + OffsetBITS& BMP.Offset = OffsetBITS& CASE 4 temp = SPACE$(3) OffsetBITS& = 54 'no palette in 24/32 bit BMP.BPP = 24 IF ((BMP.PWidth * 3) MOD 4) THEN ZeroPAD$ = SPACE$(4 - ((BMP.PWidth * 3) MOD 4)) ImageSize& = (BMP.PWidth + LEN(ZeroPAD$)) * BMP.PDepth BMP.ImageBytes = ImageSize& BMP.NumColors = 0 BMP.Size = ImageSize& * 3 + OffsetBITS& BMP.Offset = OffsetBITS& END SELECT F = FREEFILE n = _MEMNEW(BMP.Size) _MEMPUT n, n.OFFSET, BMP o = n.OFFSET + 54 zp& = LEN(ZeroPAD$) $CHECKING:OFF IF BMP.BPP = 8 THEN 'Store the Palette for 256 color mode FOR c& = 0 TO 255 ' read BGR color settings from JPG image + 1 byte spacer(CHR$(0)) cv& = _PALETTECOLOR(c&, image) ' color attribute to read. b$ = CHR$(_BLUE32(cv&)) + CHR$(_GREEN32(cv&)) + CHR$(_RED32(cv&)) + CHR$(0) 'spacer byte _MEMPUT n, o, b$ o = o + 4 NEXT y = y2% + 1 w& = _WIDTH(image&) x = x2% - x1% + 1 DO y = y - 1 _MEMGET m, m.OFFSET + (w& * y + x1%), temp _MEMPUT n, o, temp o = o + x _MEMPUT n, o, ZeroPAD$ o = o + zp& LOOP UNTIL y = y1% ELSE y = y2% + 1 w& = _WIDTH(image&) DO y = y - 1: x = x1% - 1 DO x = x + 1 _MEMGET m, m.OFFSET + (w& * y + x) * 4, temp _MEMPUT n, o, temp o = o + 3 LOOP UNTIL x = x2% _MEMPUT n, o, ZeroPAD$ o = o + zp& LOOP UNTIL y = y1% END IF $CHECKING:ON _MEMFREE m OPEN filename$ FOR BINARY AS #F t1$ = SPACE$(BMP.Size) _MEMGET n, n.OFFSET, t1$ PUT #F, , t1$ _MEMFREE n CLOSE #F _SOURCE s& END SUB 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 SUB Update_PNGCRC (PNGCRC AS _UNSIGNED LONG, buf AS _MEM) 'PNGCRC is updated by reference DIM n AS _UNSIGNED _OFFSET IF 0 = PNGCRC_table_computed THEN Make_PNGCRC_Table n = 0 WHILE n < buf.SIZE PNGCRC = PNGCRC_table((PNGCRC XOR _MEMGET(buf, buf.OFFSET + n, _UNSIGNED _BYTE)) AND &HFF) XOR PNGCRC \ 2 ^ 8 n = n + 1 WEND END FUNCTION FUNCTION ConvertUL~& (x AS _UNSIGNED LONG) ConvertUL = x \ 2 ^ 24 OR x * 2 ^ 24 OR (x AND &HFF0000) \ 2 ^ 8 OR (x AND &HFF00~&) * 2 ^ 8 END FUNCTION SUB Make_PNGCRC_Table DIM c AS _UNSIGNED LONG DIM n AS LONG, k AS LONG FOR n = 0 TO 255 c = n FOR k = 0 TO 7 IF c AND 1 THEN c = &HEDB88320 XOR c \ 2 ELSE c = c \ 2 END IF NEXT PNGCRC_table(n) = c NEXT PNGCRC_table_computed = 1 END SUB SUB PNGAutoReset PNGOptions.Alpha = 0 PNGOptions.Screen = 0 PNGOptions.GrabMode = 0 PNGOptions.x1 = 0 PNGOptions.y1 = 0 PNGOptions.x2 = 0 PNGOptions.y2 = 0 END SUB FUNCTION PNGExport (file$, imagehandle%, x1%, y1%, x2%, y2%) 'file$ is the name of the file we want to save to 'imagehandle% is the handle of the image to save 'x1,y1,x2,y2 define the screen portion that we want to save to 'Alpha is a True/False toggle for 32-bit color modes in case we want to save the screen alpha channels DIM PNGImageHeader AS PNGImageHeaderType DIM PNGFileSignature AS _UNSIGNED _INTEGER64 ' 727905341920923785 DIM PNGChunk AS PNGChunkLayout DIM x AS _UNSIGNED _INTEGER64 DIM l AS _UNSIGNED LONG DIM b AS _UNSIGNED _BYTE DIM m AS _MEM DIM FileSize AS _UNSIGNED LONG DIM CompSize AS _UNSIGNED LONG DIM Result AS LONG DIM z AS _UNSIGNED LONG PNGOptions.Screen = imagehandle% WorkScreen& = _SOURCE _SOURCE PNGOptions.Screen SELECT CASE _PIXELSIZE(imagehandle%) CASE 0: PNGExport = 11 'Can't export text screen image CASE 1: PNGOptions.Color = 256 CASE 4: PNGOptions.Color = 32 END SELECT PNGExport = 0 IF x2% = _WIDTH(imagehandle%) THEN x2% = _WIDTH(imagehandle%) - 1 'troubleshoot in case user does a common mistake for 0-width instead of 0 - (width-1) for fullscreen IF y2% = _HEIGHT(imagehandle%) THEN y2% = _HEIGHT(imagehandle%) - 1 'troubleshoot in case user does a common mistake for 0-width instead of 0 - (width-1) for fullscreen PNGOptions.x1 = x1% PNGOptions.y1 = y1% PNGOptions.x2 = x2% PNGOptions.y2 = y2% PNGOptions.Alpha = 0 IF PNGOptions.Color = 32 THEN '32 bit color mode m = _MEMIMAGE(imagehandle%) i = 0 DO check = _MEMGET(m, m.OFFSET + i + 3, _UNSIGNED _BYTE) IF check <> 255 THEN PNGOptions.Alpha = 1: EXIT DO i = i + 4 LOOP UNTIL i >= m.SIZE _MEMFREE m END IF IF PNGOptions.x1 < 0 OR PNGOptions.x1 >= _WIDTH(imagehandle%) THEN PNGExport = 4 IF PNGOptions.y1 < 0 OR PNGOptions.y1 >= _HEIGHT(imagehandle%) THEN PNGExport = 5 IF PNGOptions.x2 < 0 OR PNGOptions.x2 >= _WIDTH(imagehandle%) THEN PNGExport = 6 IF PNGOptions.y2 < 0 OR PNGOptions.y2 >= _HEIGHT(imagehandle%) THEN PNGExport = 7 IF PNGOptions.x2 < PNGOptions.x1 THEN PNGExport = 8 IF PNGOptions.y2 < PNGOptions.y1 THEN PNGExport = 9 IF PNGOptions.Color <> 256 AND PNGOptions.Color <> 32 THEN PNGExport = 10 IF PNGExport <> 0 THEN _SOURCE WorkScreen& EXIT FUNCTION END IF 'PNGExport results: '-1 All is good. We think we exported a proper PNG file. ' 0 Compression failed. File is probably corrupt. ' 1 File Already Exists. As these are Binary files, we probably don't want to just overwrite the same file. ' 2 Incorrect Alpha settings. Check for Alpha mode, and Color mode, and look for conflicts. ' 3 Bad GrabMode ' 4 Bad x1 coordinate ' 5 Bad y1 coordinate ' 6 Bad x2 coordinate ' 7 Bad y2 coordinate ' 8 x2 < x1 -- correct this to proceed ' 9 y2 < y1 -- correct this to proceed '10 Bad color mode. Either use 256 or 32 color mode. '11 Attempted to export a text screen which will not work. '12 PNG save is impossible on non-Windows systems. Can only use BMP 'Check to see if we already have a file with the name we want to save as. 'If so, return error code #1 -- File Exists IF _FILEEXISTS(file$) THEN PNGExport = 1: EXIT FUNCTION f = FREEFILE OPEN file$ FOR BINARY AS #f 'This will be our save file, if all works as it should PNGFileSignature = 727905341920923785 '1st 8 bytes are 137 80 78 71 13 10 26 10, this is a PNG file signature. Without these, it's not a PNG file PUT #f, , PNGFileSignature 'The first 8 bytes of any PNG file. This identifies it as PNG format. l = ConvertUL~&(13) '13 bytes in the header PUT #f, , l 'Store the length of the header temp$ = "IHDR" 'The name of the header PUT #f, , temp$ ' the next info is the image header which holds the data specifications of our image height = PNGOptions.y2 - PNGOptions.y1 + 1 width = PNGOptions.x2 - PNGOptions.x1 + 1 PNGImageHeader.Width = ConvertUL~&(width) PNGImageHeader.Height = ConvertUL~&(height) PNGImageHeader.Depth = 8 PNGImageHeader.ColorType = 2 IF PNGOptions.Color = 32 THEN m = _MEMIMAGE(imagehandle%) DIM o AS _OFFSET DO UNTIL 0 >= m.SIZE alpha% = _MEMGET(m, m.OFFSET + o, _UNSIGNED _BYTE) IF alpha% <> 255 THEN PNGImageHeader.ColorType = 6: mode = 32: EXIT DO o = o + 4 LOOP _MEMFREE m END IF IF PNGOptions.Color = 256 THEN PNGImageHeader.ColorType = 3 PNGImageHeader.Compression = 0 PNGImageHeader.Filter = 0 PNGImageHeader.Interlace = 0 PUT #f, , PNGImageHeader m = _MEM(PNGImageHeader) REDIM temparray(0 TO LEN(PNGImageHeader) - 1) AS _UNSIGNED _BYTE FOR mcheck = 0 TO LEN(PNGImageHeader) - 1 temparray(mcheck) = _MEMGET(m, m.OFFSET + mcheck, _UNSIGNED _BYTE) NEXT _MEMFREE m l = ConvertUL(PNGCRCDataCheck("IHDR", temparray())) PUT #f, , l ' Our PNGCRC check for IHDR 'IF we're in 256 color mode in QB64, then we need to get our color palette IF PNGOptions.Color = 256 THEN temp$ = "PLTE" DIM pal(255 * 3 + 2) AS _UNSIGNED _BYTE FOR i = 0 TO 255 pal(i * 3) = _RED(i) pal(i * 3 + 1) = _GREEN(i) pal(i * 3 + 2) = _BLUE(i) NEXT l = ConvertUL(255 * 3 + 3) 'length of our data array to hold all 256 colors in our palette PUT #f, , l PUT #f, , temp$ PUT #f, , pal() l = ConvertUL(PNGCRCDataCheck("PLTE", pal())) PUT #f, , l END IF temp$ = "IDAT" IF mode = 0 THEN FileSize = height * (3 * width + 1) ELSE FileSize = height * (4 * width + 1) END IF IF PNGOptions.Color = 256 THEN FileSize = height * (width + 1) DIM FileBuff(0 TO FileSize) AS _UNSIGNED _BYTE z = 0 FOR y = PNGOptions.y1 TO PNGOptions.y2 z = z + 1 FileBuff(z) = 0 FOR x = PNGOptions.x1 TO PNGOptions.x2 IF PNGOptions.Color = 256 THEN z = z + 1 FileBuff(z) = POINT(x, y) ELSE t~& = POINT(x, y) FileBuff(z + 1) = _RED32(t~&) FileBuff(z + 2) = _GREEN32(t~&) FileBuff(z + 3) = _BLUE32(t~&) IF mode = 0 THEN z = z + 3 'We don't want to gather any alpha ELSE FileBuff(z + 4) = _ALPHA32(t~&) z = z + 4 'We need the alpha channel END IF END IF NEXT NEXT temp$ = space$(FileSize) m = _mem(FileBuff()) _memget m, m.offset+1, temp$ compresseddata$ = _deflate$(temp$) l = ConvertUL~&(len(compresseddata$)) PUT #f, , l temp$ = "IDAT" PUT #f, , temp$ put #f, ,compresseddata$ l = ConvertUL(PNGCRCStringCheck("IDAT", compresseddata$)) PUT #f, , l l = 0 ' a zero length data field goes with IEND. It's the END of our PNG indicator/ PUT #f, , l temp$ = "IEND" PUT #f, , temp$ l = ConvertUL(PNGCRCStringCheck("IEND", "")) PUT #f, , l CLOSE 'And we should have now exported a PNG file. IF PNGOptions.Color = 32 THEN temphandle& = _LOADIMAGE(file$, 32) IF temphandle& = -1 THEN PNGExport = 666 'EVIL code. We exported something, but we can't load it! ELSE PNGExport = -1 'We have good export, but QB64 _LOADIMAGE won't import it. _FREEIMAGE temphandle& END IF ELSE PNGExport = -1 'We can't currently load 256 color images in QB64, so we have to assume that it worked at this point END IF _SOURCE WorkScreen& IF PNGOptions.AutoReset = 1 THEN PNGAutoReset END FUNCTION FUNCTION PNGCRCStringCheck~& (id AS STRING * 4, dta$) DIM m AS _MEM DIM text(0 TO LEN(dta$) - 1) AS _UNSIGNED _BYTE PNGCRC = -1 FOR z = 0 TO LEN(dta$)-1: text(z ) = ASC(dta$, z+1): NEXT m = _MEM(id): Update_PNGCRC PNGCRC, m: _MEMFREE m m = _MEM(text()): Update_PNGCRC PNGCRC, m: _MEMFREE m PNGCRCStringcheck~& = NOT PNGCRC END FUNCTION FUNCTION PNGCRCDataCheck~& (id AS STRING * 4, dta() AS _UNSIGNED _BYTE) DIM m AS _MEM DIM temp(0 TO 3) AS _UNSIGNED _BYTE PNGCRC = -1 FOR z = 1 TO 4: temp(z - 1) = ASC(id, z): NEXT m = _MEM(temp()): Update_PNGCRC PNGCRC, m: _MEMFREE m m = _MEM(dta()): Update_PNGCRC PNGCRC, m: _MEMFREE m PNGCRCDataCheck~& = NOT PNGCRC END FUNCTION 'SaveJPG functions from here on down SUB SaveJPG (file$, image&, startx, starty, finishx, finishy) DIM D AS LONG, S AS LONG DIM tempimage AS LONG, genx AS INTEGER, geny AS INTEGER DIM outfilename AS STRING D = _DEST: S = _SOURCE tempimage = _NEWIMAGE(finishx - startx + 1, finishy - starty + 1, 32) genx = _WIDTH(tempimage): geny = _HEIGHT(tempimage) _PUTIMAGE (0, 0)-(genx, geny), image&, tempimage&, (startx, starty)-(finishx, finishy) _SOURCE tempimage&: _DEST tempimage& outfilename = file$ OPEN outfilename FOR BINARY AS #1 'Set quality tables 'The smaller the paramter, the higher the quality '0.01 is 100% quality JPEG.StandardQT 0.05, JPG_Library_QT() 'Start image JPEG.Begin 1, genx, geny, JPG_Library_Sampling(), JPG_Library_State, JPG_Library_QT(), JPG_Library_Huff() DIM B(0 TO 7, 0 TO 7) AS INTEGER DIM SuperY AS INTEGER, SuperX AS INTEGER DIM BlockY AS INTEGER, BlockX AS INTEGER DIM OffY AS INTEGER, OffX AS INTEGER DIM JPG_Library_X AS SINGLE, JPG_Library_Y AS SINGLE DIM R AS INTEGER, G AS INTEGER, B AS INTEGER FOR SuperY = 0 TO geny - 1 STEP 16 FOR SuperX = 0 TO genx - 1 STEP 16: REM vstupni velikost obrazku 'Output the luminance blocks FOR BlockY = 0 TO 15 STEP 8 FOR BlockX = 0 TO 15 STEP 8 FOR OffY = 0 TO 7: FOR OffX = 0 TO 7 JPG_Library_X! = OffX + BlockX + SuperX: REM- 63.5 JPG_Library_Y! = OffY + BlockY + SuperY: REM - 63.5 R = _RED32(POINT(JPG_Library_X!, JPG_Library_Y!)) G = _GREEN32(POINT(JPG_Library_X!, JPG_Library_Y!)) B = _BLUE32(POINT(JPG_Library_X!, JPG_Library_Y!)) B(OffX, OffY) = JPEG.JPG_Library_Y(R, G, B) NEXT OffX, OffY JPEG.Block.Output B(), JPG_Library_State, JPG_Library_QT(), JPG_Library_Huff() NEXT BlockX, BlockY 'Output the blue chrominance block FOR OffY = 0 TO 7: FOR OffX = 0 TO 7 JPG_Library_X! = OffX * 2 + SuperX JPG_Library_Y! = OffY * 2 + SuperY R = _RED32(POINT(JPG_Library_X!, JPG_Library_Y!)) G = _GREEN32(POINT(JPG_Library_X!, JPG_Library_Y!)) B = _BLUE32(POINT(JPG_Library_X!, JPG_Library_Y!)) B(OffX, OffY) = JPEG.Cb(R, G, B) NEXT OffX, OffY JPEG.Block.Output B(), JPG_Library_State, JPG_Library_QT(), JPG_Library_Huff() 'Output the red chrominance block FOR OffY = 0 TO 7: FOR OffX = 0 TO 7 JPG_Library_X! = OffX * 2 + SuperX JPG_Library_Y! = OffY * 2 + SuperY R = _RED32(POINT(JPG_Library_X!, JPG_Library_Y!)) G = _GREEN32(POINT(JPG_Library_X!, JPG_Library_Y!)) B = _BLUE32(POINT(JPG_Library_X!, JPG_Library_Y!)) B(OffX, OffY) = JPEG.Cr(R, G, B) NEXT OffX, OffY JPEG.Block.Output B(), JPG_Library_State, JPG_Library_QT(), JPG_Library_Huff() NEXT SuperX, SuperY JPEG.Finish JPG_Library_State CLOSE _DEST D: _SOURCE S END SUB SUB JPEG.ACHuff (RLE AS INTEGER, AC AS INTEGER, JPG_Library_Huff() AS INTEGER, A AS INTEGER, JPG_Library_State AS JPEGState) DIM C AS INTEGER, JPG_Library_X AS INTEGER C = JPEG.Category(AC) JPG_Library_X = RLE * 16 + C JPEG.PutBinString JPG_Library_Huff(JPG_Library_X, 1, A, 0), JPG_Library_Huff(JPG_Library_X, 1, A, 1), JPG_Library_State JPEG.PutRightBinString AC + (AC < 0), C, JPG_Library_State END SUB SUB JPEG.Begin (FileNo AS INTEGER, W AS INTEGER, H AS INTEGER, JPG_Library_Sampling() AS INTEGER, JPG_Library_State AS JPEGState, JPG_Library_QT() AS INTEGER, JPG_Library_Huff() AS INTEGER) DIM I AS INTEGER, J AS INTEGER, JPG_Library_X AS INTEGER, JPG_Library_Y AS INTEGER, JPG_Library_T AS INTEGER DIM S AS STRING JPG_Library_State.FileNo = FileNo RESTORE Huff0 JPEG.GenerateHuffmanTable JPG_Library_Huff(), 0, 0 JPEG.GenerateHuffmanTable JPG_Library_Huff(), 0, 1 JPEG.GenerateHuffmanTable JPG_Library_Huff(), 1, 0 JPEG.GenerateHuffmanTable JPG_Library_Huff(), 1, 1 JPG_Library_State.YCount = JPG_Library_Sampling(0, 0) * JPG_Library_Sampling(0, 1) JPG_Library_State.CbCount = JPG_Library_Sampling(1, 0) * JPG_Library_Sampling(1, 1) JPG_Library_State.CrCount = JPG_Library_Sampling(2, 0) * JPG_Library_Sampling(2, 1) JPG_Library_State.YDC = 0 JPG_Library_State.CbDC = 0 JPG_Library_State.CrDC = 0 JPG_Library_State.Position = 0 JPG_Library_State.Leftover = 0 JPG_Library_State.LeftoverBits = 0 'SOI PutChar FileNo, 255 PutChar FileNo, 216 'APP0 PutChar FileNo, 255 PutChar FileNo, 224 JPEG.PutWord FileNo, 16 S$ = "JFIF" + CHR$(0): PUT FileNo, , S$ PutChar FileNo, 1 PutChar FileNo, 2 PutChar FileNo, 0 PutChar FileNo, 0 PutChar FileNo, 1 PutChar FileNo, 0 PutChar FileNo, 1 PutChar FileNo, 0 PutChar FileNo, 0 'DQT PutChar FileNo, 255 PutChar FileNo, 219 JPEG.PutWord FileNo, 132 PutChar FileNo, 0 FOR I = 0 TO 63 PutChar FileNo, JPG_Library_QT(JPG_Library_ZigZagX(I), JPG_Library_ZigZagY(I), 0) NEXT PutChar FileNo, 1 FOR I = 0 TO 63 PutChar FileNo, JPG_Library_QT(JPG_Library_ZigZagX(I), JPG_Library_ZigZagY(I), 1) NEXT 'DHT PutChar FileNo, 255 PutChar FileNo, 196 JPG_Library_T = 2 + 4 * (16 + 1) RESTORE Huff0 FOR I = 1 TO 16 * 4 READ JPG_Library_X FOR J = 1 TO JPG_Library_X READ JPG_Library_Y JPG_Library_T = JPG_Library_T + 1 NEXT NEXT JPEG.PutWord FileNo, JPG_Library_T PutChar FileNo, 0 RESTORE Huff0 FOR I = 1 TO 16 READ JPG_Library_X PutChar FileNo, JPG_Library_X FOR J = 1 TO JPG_Library_X READ JPG_Library_Y NEXT NEXT RESTORE Huff0 FOR I = 1 TO 16 READ JPG_Library_X FOR J = 1 TO JPG_Library_X READ JPG_Library_Y PutChar FileNo, JPG_Library_Y NEXT NEXT PutChar FileNo, 1 RESTORE Huff1 FOR I = 1 TO 16 READ JPG_Library_X PutChar FileNo, JPG_Library_X FOR J = 1 TO JPG_Library_X READ JPG_Library_Y NEXT NEXT RESTORE Huff1 FOR I = 1 TO 16 READ JPG_Library_X FOR J = 1 TO JPG_Library_X READ JPG_Library_Y PutChar FileNo, JPG_Library_Y NEXT NEXT PutChar FileNo, 16 RESTORE Huff2 FOR I = 1 TO 16 READ JPG_Library_X PutChar FileNo, JPG_Library_X FOR J = 1 TO JPG_Library_X READ JPG_Library_Y NEXT NEXT RESTORE Huff2 FOR I = 1 TO 16 READ JPG_Library_X FOR J = 1 TO JPG_Library_X READ JPG_Library_Y PutChar FileNo, JPG_Library_Y NEXT NEXT PutChar FileNo, 17 RESTORE Huff3 FOR I = 1 TO 16 READ JPG_Library_X PutChar FileNo, JPG_Library_X FOR J = 1 TO JPG_Library_X READ JPG_Library_Y NEXT NEXT RESTORE Huff3 FOR I = 1 TO 16 READ JPG_Library_X FOR J = 1 TO JPG_Library_X READ JPG_Library_Y PutChar FileNo, JPG_Library_Y NEXT NEXT 'SOF0 PutChar FileNo, 255 PutChar FileNo, 192 JPEG.PutWord FileNo, 8 + 9 PutChar FileNo, 8 JPEG.PutWord FileNo, H JPEG.PutWord FileNo, W PutChar FileNo, 3 PutChar FileNo, 1 PutChar FileNo, JPG_Library_Sampling(0, 0) * 16 + JPG_Library_Sampling(0, 1) PutChar FileNo, 0 PutChar FileNo, 2 PutChar FileNo, JPG_Library_Sampling(1, 0) * 16 + JPG_Library_Sampling(1, 1) PutChar FileNo, 1 PutChar FileNo, 3 PutChar FileNo, JPG_Library_Sampling(2, 0) * 16 + JPG_Library_Sampling(2, 1) PutChar FileNo, 1 'SOS PutChar FileNo, 255 PutChar FileNo, 218 JPEG.PutWord FileNo, 12 PutChar FileNo, 3 PutChar FileNo, 1 PutChar FileNo, &H0 PutChar FileNo, 2 PutChar FileNo, &H11 PutChar FileNo, 3 PutChar FileNo, &H11 PutChar FileNo, 0 PutChar FileNo, 63 PutChar FileNo, 0 END SUB SUB JPEG.Block.Huffman (B() AS INTEGER, LastDC AS INTEGER, JPG_Library_Huff() AS INTEGER, A AS INTEGER, JPG_Library_State AS JPEGState) DIM DC AS INTEGER, I AS INTEGER DIM C AS INTEGER DC = B(0) - LastDC JPEG.DCHuff DC, JPG_Library_Huff(), A, JPG_Library_State B(64) = -1 I = 1 DO C = 0 IF B(I) = 0 THEN DO I = I + 1 C = C + 1 LOOP WHILE B(I) = 0 IF I = 64 THEN JPEG.PutBinString JPG_Library_Huff(0, 1, A, 0), JPG_Library_Huff(0, 1, A, 1), JPG_Library_State EXIT DO END IF WHILE C >= 16 JPEG.PutBinString JPG_Library_Huff(&HF0, 1, A, 0), JPG_Library_Huff(&HF0, 1, A, 1), JPG_Library_State C = C - 16 WEND END IF JPEG.ACHuff C, B(I), JPG_Library_Huff(), A, JPG_Library_State I = I + 1 LOOP WHILE I < 64 END SUB SUB JPEG.Block.Output (B() AS INTEGER, JPG_Library_State AS JPEGState, JPG_Library_QT() AS INTEGER, JPG_Library_Huff() AS INTEGER) DIM O(0 TO 64) AS INTEGER JPG_Library_State.Position = JPG_Library_State.Position + 1 IF JPG_Library_State.Position > JPG_Library_State.YCount + JPG_Library_State.CbCount + JPG_Library_State.CrCount THEN JPG_Library_State.Position = 1 IF JPG_Library_State.Position <= JPG_Library_State.YCount THEN JPEG.Block.Transform B(), O(), JPG_Library_QT(), 0 JPEG.Block.Huffman O(), JPG_Library_State.YDC, JPG_Library_Huff(), 0, JPG_Library_State JPG_Library_State.YDC = O(0) ELSE JPEG.Block.Transform B(), O(), JPG_Library_QT(), 1 IF JPG_Library_State.Position <= JPG_Library_State.YCount + JPG_Library_State.CbCount THEN JPEG.Block.Huffman O(), JPG_Library_State.CbDC, JPG_Library_Huff(), 1, JPG_Library_State JPG_Library_State.CbDC = O(0) ELSE JPEG.Block.Huffman O(), JPG_Library_State.CrDC, JPG_Library_Huff(), 1, JPG_Library_State JPG_Library_State.CrDC = O(0) END IF END IF END SUB SUB JPEG.Block.Transform (B() AS INTEGER, O() AS INTEGER, JPG_Library_QT() AS INTEGER, A AS INTEGER) DIM U AS INTEGER, V AS INTEGER, JPG_Library_X AS INTEGER, JPG_Library_Y AS INTEGER DIM B2(0 TO 7, 0 TO 7) AS SINGLE DIM JPG_Library_T AS SINGLE FOR V = 0 TO 7: FOR U = 0 TO 7 JPG_Library_T = 0 FOR JPG_Library_X = 0 TO 7 JPG_Library_T = JPG_Library_T + B(JPG_Library_X, V) * JPG_Library_Cosine(JPG_Library_X, U) NEXT JPG_Library_X B2(U, V) = JPG_Library_T NEXT U, V FOR U = 0 TO 7: FOR V = 0 TO 7 JPG_Library_T = 0 FOR JPG_Library_Y = 0 TO 7 JPG_Library_T = JPG_Library_T + B2(U, JPG_Library_Y) * JPG_Library_Cosine(JPG_Library_Y, V) NEXT JPG_Library_Y JPG_Library_T = JPG_Library_T / 4 IF U = 0 THEN JPG_Library_T = JPG_Library_T / SQR(2) IF V = 0 THEN JPG_Library_T = JPG_Library_T / SQR(2) B(U, V) = CINT(JPG_Library_T / JPG_Library_QT(U, V, A)) NEXT V, U FOR U = 0 TO 63 O(U) = B(JPG_Library_ZigZagX(U), JPG_Library_ZigZagY(U)) NEXT END SUB FUNCTION JPEG.Category% (JPG_Library_X AS INTEGER) DIM JPG_Library_T AS INTEGER, I AS INTEGER JPG_Library_T = ABS(JPG_Library_X) WHILE JPG_Library_T JPG_Library_T = JPG_Library_T \ 2 I = I + 1 WEND JPEG.Category = I END FUNCTION FUNCTION JPEG.Cb% (R AS INTEGER, G AS INTEGER, B AS INTEGER) JPEG.Cb = -.1687 * R - .3313 * G + .5 * B END FUNCTION FUNCTION JPEG.Cr% (R AS INTEGER, G AS INTEGER, B AS INTEGER) JPEG.Cr = .5 * R - .4187 * G - .0813 * B END FUNCTION SUB JPEG.DCHuff (DC AS INTEGER, JPG_Library_Huff() AS INTEGER, A AS INTEGER, JPG_Library_State AS JPEGState) DIM C AS INTEGER C = JPEG.Category(DC) JPEG.PutBinString JPG_Library_Huff(C, 0, A, 0), JPG_Library_Huff(C, 0, A, 1), JPG_Library_State JPEG.PutRightBinString DC + (DC < 0), C, JPG_Library_State END SUB SUB JPEG.Finish (JPG_Library_State AS JPEGState) DEF SEG = VARSEG(JPG_Library_State.Leftover) IF JPG_Library_State.LeftoverBits > 8 THEN JPEG.PutByte JPG_Library_State.FileNo, PEEK(VARPTR(JPG_Library_State.Leftover) + 1) POKE VARPTR(JPG_Library_State.Leftover) + 1, JPG_Library_State.Leftover AND 255 JPG_Library_State.LeftoverBits = JPG_Library_State.LeftoverBits - 8 END IF IF JPG_Library_State.LeftoverBits THEN JPEG.PutByte JPG_Library_State.FileNo, PEEK(VARPTR(JPG_Library_State.Leftover) + 1) OR (JPG_Library_Pow2(8 - JPG_Library_State.LeftoverBits) - 1) END IF DEF SEG 'EOF marker PutChar JPG_Library_State.FileNo, 255 PutChar JPG_Library_State.FileNo, 217 END SUB SUB JPEG.GenerateHuffmanTable (JPG_Library_Huff() AS INTEGER, A AS INTEGER, B AS INTEGER) DIM S AS LONG, I AS INTEGER, J AS INTEGER, JPG_Library_T AS INTEGER DIM JPG_Library_X AS INTEGER, JPG_Library_Y AS INTEGER S = -1 FOR I = 1 TO 16 READ JPG_Library_X FOR J = 1 TO JPG_Library_X IF S = -1 THEN S = 0 ELSE S = S + JPG_Library_Pow2(JPG_Library_T) END IF READ JPG_Library_Y IF S AND 32768 THEN JPG_Library_Huff(JPG_Library_Y, A, B, 0) = CINT(S AND 32767&) OR -32768 ELSE JPG_Library_Huff(JPG_Library_Y, A, B, 0) = S JPG_Library_Huff(JPG_Library_Y, A, B, 1) = I JPG_Library_T = 16 - I NEXT NEXT END SUB SUB JPEG.PutBinString (BS AS INTEGER, Length AS INTEGER, JPG_Library_State AS JPEGState) DIM Temp AS INTEGER Temp = BS JPG_Library_State.Leftover = JPG_Library_State.Leftover OR JPEG.Shift(Temp, JPG_Library_State.LeftoverBits) JPG_Library_State.LeftoverBits = JPG_Library_State.LeftoverBits + Length IF JPG_Library_State.LeftoverBits >= 16 THEN DEF SEG = VARSEG(JPG_Library_State.Leftover) JPEG.PutByte JPG_Library_State.FileNo, PEEK(VARPTR(JPG_Library_State.Leftover) + 1) DEF SEG JPEG.PutByte JPG_Library_State.FileNo, JPG_Library_State.Leftover AND 255 JPG_Library_State.LeftoverBits = JPG_Library_State.LeftoverBits - 16 JPG_Library_State.Leftover = Temp END IF END SUB SUB JPEG.PutByte (FileNo AS INTEGER, Byte AS INTEGER) DIM C AS STRING * 1 C = CHR$(Byte) PUT FileNo, , C IF Byte = 255 THEN C = CHR$(0): PUT FileNo, , C END SUB SUB JPEG.PutRightBinString (BS AS INTEGER, Length AS INTEGER, JPG_Library_State AS JPEGState) DIM Temp AS LONG IF Length THEN Temp = (CLNG(BS) AND JPG_Library_Pow2(Length) - 1) * JPG_Library_Pow2(16 - Length) IF Temp AND 32768 THEN Temp = Temp OR -65536 JPEG.PutBinString CINT(Temp), Length, JPG_Library_State END IF END SUB SUB JPEG.PutWord (FileNo AS INTEGER, Word AS INTEGER) DIM C AS STRING * 1 C = CHR$(Word \ 256) PUT FileNo, , C C = CHR$(Word AND 255) PUT FileNo, , C END SUB FUNCTION JPEG.Shift% (I AS INTEGER, N AS INTEGER) DIM JPG_Library_T AS LONG IF N = 0 THEN JPEG.Shift = I I = 0 EXIT FUNCTION END IF JPG_Library_T = CLNG(I) AND 65535 JPEG.Shift = JPG_Library_T \ JPG_Library_Pow2(N) JPG_Library_T = (JPG_Library_T AND (JPG_Library_Pow2(N) - 1)) * JPG_Library_Pow2((16 - N) AND 15) IF JPG_Library_T AND 32768 THEN I = CINT(JPG_Library_T AND 32767&) OR -32768 ELSE I = CINT(JPG_Library_T) END FUNCTION SUB JPEG.StandardQT (quality AS SINGLE, JPG_Library_QT() AS INTEGER) DIM I AS INTEGER, JPG_Library_X AS INTEGER, JPG_Library_Y AS INTEGER, JPG_Library_T AS INTEGER RESTORE StandardQT FOR I = 0 TO 1: FOR JPG_Library_Y = 0 TO 7: FOR JPG_Library_X = 0 TO 7 READ JPG_Library_T JPG_Library_QT(JPG_Library_X, JPG_Library_Y, I) = JPG_Library_T * quality IF JPG_Library_QT(JPG_Library_X, JPG_Library_Y, I) = 0 THEN JPG_Library_QT(JPG_Library_X, JPG_Library_Y, I) = 1 NEXT JPG_Library_X, JPG_Library_Y, I END SUB FUNCTION JPEG.JPG_Library_Y% (R AS INTEGER, G AS INTEGER, B AS INTEGER) JPEG.JPG_Library_Y = .299 * R + .587 * G + .114 * B - 128 END FUNCTION SUB PutChar (FileNo AS INTEGER, Char AS INTEGER) DIM C AS STRING * 1 C = CHR$(Char) PUT FileNo, , C END SUB 'END OF JPEG Stuff 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(_RED(t), _GREEN(t), _BLUE(t), _ALPHA(t), I256) color256 = _RGBA32(_RED(index256, I256), _GREEN(index256, I256), _BLUE(index256, I256), _ALPHA(index256, I256)) IF t <> color256 THEN NSCU = -1: EXIT FOR NEXT IF NSCU THEN 'it's not a standard QB64 256 color palette, but it's still less than 256 total colors. IF ConvertToStandard256Palette THEN TI256 = RemapImageFS(image&, I256) _MEMFREE m(1) 'free the old memory _FREEIMAGE I256 'and the old image I256 = TI256 'replace with the new image m(1) = _MEMIMAGE(I256) 'and point the mem block to the new image ELSE FOR i = 0 TO colors: _PALETTECOLOR i, Pal(i), I256: NEXT 'set the palette END IF END IF 'If we didn't change the palette above, we should work 100% with qb64's internal 256 color palette o = 0 DO 'Get the colors, put them to a 256 color screen, as is _MEMGET m(0), m(0).OFFSET + o + 3, a _MEMGET m(0), m(0).OFFSET + o + 2, r _MEMGET m(0), m(0).OFFSET + o + 1, g _MEMGET m(0), m(0).OFFSET + o + 0, b _MEMPUT m(1), m(1).OFFSET + o \ 4, _RGBA(r, g, b, a, I256) AS _UNSIGNED _BYTE o = o + 4 LOOP UNTIL o >= m(0).SIZE _MEMFREE m() Image32To256 = I256 END FUNCTION FUNCTION RemapImageFS& (ohan&, dhan&) 'Routine written by RhoSigma and used (with permission) for SaveImage 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:suffix 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