I searched high and low -- tested in qb64 (works correctly)
#1
Photo 
I literally searched everything until finding the code both to save and decode gif (LZW comp/dcomp algorithm patent is EXPIRED -- use FREELY). I expect no thanks. I saved some time. QB64(.net) proves a bit undependable as of late. It is not a safe code repository, so I have left this here for ALL.

Code:
DEFINT A-Z

DECLARE FUNCTION GetByte% ()

DECLARE SUB BufferWrite (a%)

DECLARE SUB MakeGif (a$, ScreenX%, ScreenY%, Xstart%, YStart%, Xend%,Yend%, NumColors%, AdaptorType%)

DECLARE SUB PutByte (a%)

DECLARE SUB PutCode (a%)

DECLARE SUB pal (c%, R%, G%, B%)

CONST TRUE = -1, FALSE = NOT TRUE



'GS3DO.BAS by Matt Bross, 1997

'The sorting algorithm was originally written by Ryan Wellman, which I

'modified for my own purposes. I made the 3D program with help from
'3D tutorials by Lithium /VLA, Shade3D.BAS by Rich Geldreich; and
'Gouraud fill with Luke Molnar's (of M/K Productions) gorau.bas. The GIF
'support is from Rich Geldreich's MakeGif.BAS.

'

'completely RANDOMIZE

RANDOMIZE TIMER: DO: RANDOMIZE TIMER: LOOP UNTIL RND > .5

'ON ERROR GOTO ErrorHandler

TYPE PointType

    x AS SINGLE 'X coordinate

    y AS SINGLE 'Y coordinate

    z AS SINGLE 'Z coordinate

    shade AS INTEGER 'shade of points

    dis AS SINGLE 'distance from the origin (0, 0, 0)

END TYPE

TYPE PolyType

    C1 AS INTEGER 'number of the first point of a polygon

    C2 AS INTEGER 'number of the second point of a polygon

    C3 AS INTEGER 'number of the third point of a polygon

    culled AS INTEGER 'TRUE if the polygon isn't visible

    AvgZ AS INTEGER 'used to sort Z coordinates of polygons

END TYPE

TYPE FillType

    Y1 AS INTEGER 'starting Y coordinate

    Y2 AS INTEGER 'ending Y coordinate

    clr1 AS INTEGER 'starting color

    clr2 AS INTEGER 'ending color

END TYPE

'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%INFO%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

SCREEN 0, 0, 0, 0: WIDTH 80, 25: CLS

PRINT "GS3DO.BAS by Matt Bross, 1997"

PRINT

PRINT "3D ANIMATION FOR THE QBASIC LANGUAGE"

PRINT "COPYRIGHT MATT BROSS. USE FREELY AS"

PRINT "LONG AS CREDIT IS GIVEN."

PRINT

PRINT "--------CONTROLS--------"

PRINT " 0 - reset rotation"

PRINT " 5 - stop rotation"

PRINT " S - reset location"

PRINT " A - stop translation"

PRINT "2, 8 - rotate around x axis"

PRINT "4, 6 - rotate around y axis"

PRINT "-, + - rotate around z axis"

PRINT CHR$(24); ", "; CHR$(25); " - translate vertically"

PRINT CHR$(27); ", "; CHR$(26); " - translate horizontally"

PRINT "Z, X - translate depthwise"

PRINT " Esc - exit"

PRINT "----CASE INSENSITIVE----"

PRINT

INPUT "OBJECT TO LOAD", file$

IF file$ = "" THEN file$ = "pyramid.txt"

'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%VARIABLES%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

'SRX = the screen's x resolution

'SRY = the screen's y resolution

SRX = 320: SRY = 200

'DX = the X coordinate of the center of the screen

'DY = the Y coordinate of the center of the screen

DX = SRX \ 2: DY = SRY \ 2

'D = the viewer's distance then object: SD = controls perspective

D = 350: SD = 140

'MaxSpin = controls the maximum rotation speed

'MaxSpeed = controls the maximum translation speed

MaxSpin = 20: MaxSpeed = 10

'NumClr = the number of palette values to assign to shading each color

NumClr = 63

'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%GIF STUFF%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

DIM SHARED OutBuffer$, OStartAddress, OAddress, OEndAddress, Oseg

DIM SHARED CodeSize, CurrentBit, Char&, BlockLength

DIM SHARED Shift(7) AS LONG

DIM SHARED x, y, Minx, MinY, MaxX, MaxY, Done, GIFFile, LastLoc&

ShiftTable:

DATA 1,2,4,8,16,32,64,128

'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%SIN TABLES%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

'create SINe and COSine tables for 360 degrees in radians, and then

'scale 1024 times for faster math.

'$STATIC

DIM SINx(360) AS LONG, COSx(360) AS LONG

FOR i = 0 TO 360

    SINx(i) = SIN(i * (22 / 7) / 180) * 1024 'use 1024 to shift binary digits

    COSx(i) = COS(i * (22 / 7) / 180) * 1024 'over 6 bits.

NEXT i

'%%%%%%%%%%%%%%%%%%%%%%%%%%GOURAUD SHADE ARRAYS%%%%%%%%%%%%%%%%%%%%%%%%%

DIM scan(320) AS FillType 'DIM gouraud shading array

DIM coord(1 TO 3)

'%%%%%%%%%%%%%%%%%%%%%%%%DOUBLE BUFFERING ARRAYS%%%%%%%%%%%%%%%%%%%%%%%%

DIM SHARED aofs&

DIM SHARED ScnBuf(32001) 'DIM array to serve as page in SCREEN 13

ScnBuf(0) = 320 * 8 'set length (x)

ScnBuf(1) = 200 'set height (y)

DEF SEG = VARSEG(ScnBuf(2)) 'get segment of beginning of array data

aofs& = VARPTR(ScnBuf(2)) 'get offset of beginning of array data

'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%LIGHT TABLES%%%%%%%%%%%%%%%%%%%%%%%%%%%%

DIM LX(256), LY(256), LZ(256)

'Location of light source in spherical coordinates

l1 = 70: l2 = 40: a1! = l1 / 57.29: a2! = l2 / 57.29

s1! = SIN(a1!): C1! = COS(a1!): s2! = SIN(a2!): C2! = COS(a2!)

LX = 128 * s1! * C2!: LY = 128 * s1! * s2!: LZ = 128 * C1!

'find length of segment from light source to origin (0, 0, 0)

ldis! = SQR(LX * LX + LY * LY + LZ * LZ) / 128

FOR a = -128 TO 128

    LX(a + 128) = LX * a 'make light source lookup tables for shading

    LY(a + 128) = LY * a

    LZ(a + 128) = LZ * a

NEXT a

'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%LOAD OBJECT%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

OPEN file$ FOR INPUT AS #1

'Load Points Data

INPUT #1, MaxPoints, MaxPolys

DIM POINTS(MaxPoints) AS PointType 'at start

DIM ScnPnts(MaxPoints) AS PointType 'after rotation

DIM SX(MaxPoints), SY(MaxPoints) 'points drawn to screen

FOR i = 1 TO MaxPoints

    INPUT #1, x!, y!, z!: POINTS(i).x = x!: POINTS(i).y = y!: POINTS(i).z = z!

    'find distance from point to the origin (0, 0, 0)

    dis! = SQR(x! * x! + y! * y! + z! * z!)

    POINTS(i).dis = dis! * ldis!: ScnPnts(i).dis = dis! * ldis!

NEXT i

'Load Polygon Data

DIM SHARED P(MaxPolys) AS PolyType 'stores all polygon data

FOR i = 1 TO MaxPolys

    INPUT #1, P(i).C1, P(i).C2, P(i).C3

NEXT i: CLOSE

PRINT "Press a Key"

DO: LOOP UNTIL INKEY$ <> ""

'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%SET PALETTE%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

SCREEN 13: CLS

s! = 0: ClrStep! = 63 / NumClr

FOR a = 0 TO NumClr

    pal a, c, c, c

    s! = s! + ClrStep!: c = INT(s!)

NEXT a

'%%%%%%%%%%%%%%%%%%%%%%%%%%%LOOK UP VARIABLES%%%%%%%%%%%%%%%%%%%%%%%%%%%

ZERO = 0: ONE = 1: THREE6D = 360

'------------------------------>BEGIN MAIN LOOP<------------------------

DO

    '*********************************GET KEY*******************************

    k$ = UCASE$(INKEY$)

    SELECT CASE k$

        CASE "0"

            R1 = ZERO: R2 = ZERO: R3 = ZERO

            D1 = ZERO: D2 = ZERO: D3 = ZERO

        CASE "5"

            D1 = ZERO: D2 = ZERO: D3 = ZERO

        CASE "A"

            MX = ZERO: MY = ZERO: MZ = ZERO

        CASE "S"

            MX = ZERO: MY = ZERO: MZ = ZERO

            MMX = ZERO: MMY = ZERO: MMZ = ZERO

        CASE "2"

            D1 = D1 - ONE

        CASE "8"

            D1 = D1 + ONE

        CASE "4"

            D2 = D2 - ONE

        CASE "6"

            D2 = D2 + ONE

        CASE "+", "="

            D3 = D3 - ONE

        CASE "-"

            D3 = D3 + ONE

        CASE CHR$(0) + "H"

            MY = MY + ONE

        CASE CHR$(0) + "P"

            MY = MY - ONE

        CASE CHR$(0) + "K"

            MX = MX + ONE

        CASE CHR$(0) + "M"

            MX = MX - ONE

        CASE "Z"

            MZ = MZ + ONE

        CASE "X"

            MZ = MZ - ONE

        CASE CHR$(27)

            GOTO ShutDown

        CASE "G"

            file$ = "pyramid.gif"


            IF RIGHT$(UCASE$(file$), 4) <> ".GIF" THEN file$ = file$ + ".GIF"

            PUT (0, 0), ScnBuf(), PSET

            MakeGif file$, 320, 200, 0, 0, 319, 199, 256, 2

    END SELECT

    '*********************************ROTATION******************************

    'keep rotation speed under control

    IF D1 > MaxSpin THEN D1 = MaxSpin

    IF D2 > MaxSpin THEN D2 = MaxSpin

    IF D2 > MaxSpin THEN D2 = MaxSpin

    IF D1 < -MaxSpin THEN D1 = -MaxSpin

    IF D2 < -MaxSpin THEN D2 = -MaxSpin

    IF D2 < -MaxSpin THEN D2 = -MaxSpin

    'keep SINes and COSines in array limits

    R1 = (R1 + D1) MOD THREE6D: IF R1 < ZERO THEN R1 = THREE6D + R1

    R2 = (R2 + D2) MOD THREE6D: IF R2 < ZERO THEN R2 = THREE6D + R2

    R3 = (R3 + D3) MOD THREE6D: IF R3 < ZERO THEN R3 = THREE6D + R3

    '********************************TRANSLATION****************************

    'Keep translation speed from becoming uncontrollable

    IF MX > MaxSpeed THEN MX = MaxSpeed

    IF MY > MaxSpeed THEN MY = MaxSpeed

    IF MZ > MaxSpeed THEN MZ = MaxSpeed

    IF MX < -MaxSpeed THEN MX = -MaxSpeed

    IF MY < -MaxSpeed THEN MY = -MaxSpeed

    IF MZ < -MaxSpeed THEN MZ = -MaxSpeed

    MMX = MMX + MX: MMY = MMY + MY: MMZ = MMZ + MZ

    'Keeps variables within limits of integers

    IF MMX > 32767 THEN MMX = 32767

    IF MMY > 250 THEN MMY = 250

    IF MMZ > 120 THEN MMZ = 120

    IF MMX < -32767 THEN MMX = -32767

    IF MMY < -120 THEN MMY = -120

    IF MMZ < -327 THEN MMZ = -327

    '*******************************MOVE OBJECT*****************************

    FOR i = 1 TO MaxPoints

        'rotate points around the Y axis

        TEMPX = (POINTS(i).x * COSx(R2) - POINTS(i).z * SINx(R2)) \ 1024

        TEMPZ = (POINTS(i).x * SINx(R2) + POINTS(i).z * COSx(R2)) \ 1024

        'rotate points around the X axis

        ScnPnts(i).z = (TEMPZ * COSx(R1) - POINTS(i).y * SINx(R1)) \ 1024

        TEMPY = (TEMPZ * SINx(R1) + POINTS(i).y * COSx(R1)) \ 1024

        'rotate points around the Z axis

        ScnPnts(i).x = (TEMPX * COSx(R3) + TEMPY * SINx(R3)) \ 1024

        ScnPnts(i).y = (TEMPY * COSx(R3) - TEMPX * SINx(R3)) \ 1024

        '******************************CONVERT 3D TO 2D*************************

        TEMPZ = ScnPnts(i).z + MMZ - SD

        IF TEMPZ < ZERO THEN 'only calculate points visible by viewer

            SX(i) = (D * ((ScnPnts(i).x + MMX) / TEMPZ)) + DX

            SY(i) = (D * ((ScnPnts(i).y + MMY) / TEMPZ)) + DY

        END IF

        '*******************************SHADE POINTS****************************

        X1 = ScnPnts(i).x: Y1 = ScnPnts(i).y: Z1 = ScnPnts(i).z

        s = CINT((X1 * LX + Y1 * LY + Z1 * LZ) \ ScnPnts(i).dis) + 128

        IF s < ZERO THEN s = ZERO

        IF s > 256 THEN s = 256

        shade = (LX(s) + LY(s) + LZ(s)) \ 3

        IF shade < ZERO THEN shade = ZERO

        IF shade > NumClr THEN shade = NumClr

        ScnPnts(i).shade = shade

    NEXT

    FOR i = 1 TO MaxPolys

        '*************************CULL NON-VISIABLE POLYGONS********************

        'this isn't perfect yet so I REMmed it, so for more speed unrem the following

        coord(1) = P(i).C1: coord(2) = P(i).C2: coord(3) = P(i).C3

        X1 = ScnPnts(coord(1)).x: X2 = ScnPnts(coord(2)).x: X3 = ScnPnts(coord(3)).x

        Y1 = ScnPnts(coord(1)).y: Y2 = ScnPnts(coord(2)).y: Y3 = ScnPnts(coord(3)).y

        Z1 = ScnPnts(coord(1)).z: Z2 = ScnPnts(coord(2)).z: Z3 = ScnPnts(coord(3)).z

        cull1 = X3 * ((Y1 * Z2) - (Z1 * Y2)): cull2 = Y3 * ((X1 * Z2) - (Z1 * X2))

        cull3 = Z3 * ((X1 * Y2) - (Y1 * X2))

        IF cull1 + cull2 + cull3 = ZERO THEN P(i).culled = TRUE ELSE P(i).culled = FALSE

        '******************FIND AVERAGE Z COORDINATE OF EACH POLYGON************

        P(i).AvgZ = (Z1 + Z2 + Z3) \ 3

    NEXT i

    '******************SORT POLGONS BY THEIR AVERAGE Z COORDINATE***********

    increment = MaxPolys + 1

    DO

        increment = increment \ 2

        FOR index = 1 TO MaxPolys - increment

            IF P(index).AvgZ > P(index + increment).AvgZ THEN

                SWAP P(index), P(index + increment)

                IF index > increment THEN

                    cutpoint = index

                    DO

                        index = (index - increment): IF index < 1 THEN index = 1

                        IF P(index).AvgZ > P(index + increment).AvgZ THEN

                            SWAP P(index), P(index + increment)

                        ELSE

                            index = cutpoint: EXIT DO

                        END IF

                    LOOP

                END IF

            END IF

        NEXT index

    LOOP UNTIL increment <= 1

    '******************************DRAW POLYGONS****************************

    'clear screen buffer. Use a 320 by 200 BLOADable graphic for a background.

    ERASE ScnBuf: ScnBuf(0) = 2560: ScnBuf(1) = SRY



    FOR i = 1 TO MaxPolys

        IF P(i).culled = FALSE THEN

            'load points

            coord(1) = P(i).C1: coord(2) = P(i).C2: coord(3) = P(i).C3

            'find highest and lowest Y coordinates

            xmin = SRX: xmax = ZERO

            IF SX(coord(1)) > xmax THEN xmax = SX(coord(1))

            IF SX(coord(2)) > xmax THEN xmax = SX(coord(2))

            IF SX(coord(3)) > xmax THEN xmax = SX(coord(3))

            IF SX(coord(1)) < xmin THEN xmin = SX(coord(1))

            IF SX(coord(2)) < xmin THEN xmin = SX(coord(2))

            IF SX(coord(3)) < xmin THEN xmin = SX(coord(3))

            'keep min's and max's in the limits of the screen

            IF xmin < ZERO THEN xmin = ZERO

            IF xmax > SRX THEN xmax = SRX

            IF xmin > SRX THEN EXIT FOR

            IF xmax < ZERO THEN EXIT FOR

            IF SY(coord(1)) AND SY(coord(2)) AND SY(coord(3)) < ZERO THEN EXIT FOR

            IF SY(coord(1)) AND SY(coord(2)) AND SY(coord(3)) > SRY THEN EXIT FOR



            ERASE scan



            FOR j = 1 TO 3

                k = j + 1: IF k > 3 THEN k = 1

                VAL1 = coord(j): VAL2 = coord(k)

                IF SX(VAL1) > SX(VAL2) THEN SWAP VAL1, VAL2

                Y1 = SY(VAL1): X1 = SX(VAL1): Y2 = SY(VAL2): X2 = SX(VAL2)

                col1 = ScnPnts(VAL1).shade: Col2 = ScnPnts(VAL2).shade

                XDelta = X2 - X1: YDelta = Y2 - Y1: CDelta = Col2 - col1

                IF XDelta <> ZERO THEN

                    YSlope = (YDelta / XDelta) * 128

                    CSlope = (CDelta / XDelta) * 128

                ELSE

                    YSlope = ZERO

                    CSlope = ZERO

                END IF



                YVal& = Y1 * 128: CVal& = col1 * 128

                IF X1 < ZERO THEN X1 = ZERO

                IF X2 > SRX THEN X2 = SRX



                FOR f = X1 TO X2

                    IF scan(f).Y1 = ZERO THEN

                        scan(f).Y1 = YVal& \ 128

                        scan(f).clr1 = CVal& \ 128

                    ELSE

                        scan(f).Y2 = YVal& \ 128

                        scan(f).clr2 = CVal& \ 128

                    END IF

                    YVal& = YVal& + YSlope

                    CVal& = CVal& + CSlope

                NEXT f

            NEXT j



            FOR f = xmin TO xmax



                IF scan(f).Y1 > scan(f).Y2 THEN

                    Y1 = scan(f).Y2: Y2 = scan(f).Y1

                    col1 = scan(f).clr2: Col2 = scan(f).clr1

                ELSE

                    Y1 = scan(f).Y1: Y2 = scan(f).Y2

                    col1 = scan(f).clr1: Col2 = scan(f).clr2

                END IF



                YDelta = Y2 - Y1: CDelta = Col2 - col1

                IF YDelta = ZERO THEN YDelta = 1

                CSlope = (CDelta / YDelta) * 128: CVal& = col1 * 128



                FOR j = scan(f).Y1 TO scan(f).Y2

                    'clip polygon to screen (set boundaries)

                    IF f < SRX AND f > ZERO AND j > ZERO AND j < SRY THEN

                        pixel = CVal& \ 128: IF pixel > NumClr THEN pixel = NumClr

                        'write pixel to screen buffer

                        POKE aofs& + f + j * 320&, pixel

                    END IF

                    CVal& = CVal& + CSlope

                NEXT j

            NEXT f

        END IF

    NEXT i



    PUT (ZERO, ZERO), ScnBuf(), PSET 'dump array to screen, like PCOPY

    '******************************FRAME COUNTER****************************

    'LOCATE 1, 1: PRINT fps: frame = frame + 1

    'LOCATE 2, 1: PRINT TIMER - D#: D# = TIMER

    'IF TIMER > t# THEN t# = TIMER + 1: fps = frame: frame = zero

LOOP

'------------------------------>END MAIN LOOP<--------------------------

ShutDown:

DEF SEG

SCREEN 0, 0, 0, 0: WIDTH 80, 25: CLS

PRINT "GS3DO.BAS by Matt Bross, 1997"

PRINT: PRINT "THERE WERE"; MaxPoints; "POINTS AND"; MaxPolys; "POLYGONS"

PRINT: PRINT "Free space"

PRINT " String Array Stack"

PRINT STRING$(21, "-")

'PRINT FRE(""); FRE(-1); FRE(-2): END

END
RETURN
ErrorHandler:

RESUME NEXT



'Puts a byte into the disk buffer... when the disk buffer is full it is

'dumped to disk.

SUB BufferWrite (a) STATIC



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

    PUT GIFFile, , OutBuffer$ ' yup, write it out and

    OAddress = OStartAddress ' start all over

END IF

POKE OAddress, a 'put byte in buffer

OAddress = OAddress + 1 'increment position

END SUB



'This routine gets one pixel from the display.

FUNCTION GetByte STATIC



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

x = x + 1 'increment X coordinate

IF x > MaxX THEN 'are we too far?

    LINE (Minx, y)-(MaxX, y), 0 'a pacifier for impatient users

    x = Minx 'go back to start

    y = y + 1 'increment Y coordinate

    IF y > MaxY THEN 'are we too far down?

        Done = TRUE ' yup, flag it then

    END IF

END IF

END FUNCTION



'

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

' PDS 7.1 & QB4.5 GIF Compression Routine v1.00 By Rich Geldreich 1992

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

'

'A$ = output filename

'ScreenX = X resolution of screen(320, 640, etc.)

'ScreenY = Y resolution of screen(200, 350, 480, etc.)

'XStart = <-upper left hand corner of area to encode

'YStart = < " "

'Xend = <-lower right hand corner of area to encode

'Yend = < " "

'NumColors = # of colors on screen(2, 16, 256)

'AdaptorType = 1 for EGA 2 for VGA

'NOTE: EGA palettes are not supported in this version of MakeGIF.

'

SUB MakeGif (a$, ScreenX, ScreenY, Xstart, YStart, Xend, Yend, NumColors, AdaptorType)
_TITLE "makegif"
'hash table's size - must be a prime number!

CONST Table.Size = 7177



DIM Prefix(Table.Size - 1), Suffix(Table.Size - 1), code(Table.Size - 1)



'The shift table contains the powers of 2 needed by the

'PutCode routine. This is done for speed. (much faster to

'look up an integer than to perform calculations...)

RESTORE ShiftTable

FOR a = 0 TO 7: READ Shift(a): NEXT



'MinX, MinY, MaxX, MaxY have the encoding window

Minx = Xstart: MinY = YStart

MaxX = Xend: MaxY = Yend



'Open GIF output file

GIFFile = FREEFILE 'use next free file

OPEN a$ FOR BINARY AS GIFFile



'Put GIF87a header at beginning of file

B$ = "GIF87a"

PUT GIFFile, , B$



'See how many colors are in this image...

SELECT CASE NumColors

    CASE 2 'monochrome 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

        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

        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

'This following routine probably isn't needed- I've never

'had to use the "ColorBits" variable... With the EGA, you

'have 2 bits for Red, Green, & Blue. With VGA, you have 6 bits.

SELECT CASE AdaptorType

    CASE 1

        ColorBits = 2 'EGA

    CASE 2

        ColorBits = 6 'VGA

END SELECT



PUT GIFFile, , ScreenX 'put screen's dimensions

PUT GIFFile, , ScreenY

'pack colorbits and bits per pixel

a = 128 + (ColorBits - 1) * 16 + (BitsPixel - 1)

PUT GIFFile, , a

'throw a zero into the GIF file

a$ = CHR$(0)

PUT GIFFile, , a$

'Get the RGB palette from the screen and put it into the file...

SELECT CASE AdaptorType

    CASE 1

        STOP

        'EGA palette routine not implemented yet

    CASE 2

        OUT &H3C7, 0

        FOR a = 0 TO NumColors - 1

            'Note: a BIOS call could be used here, but then we have to use

            'the messy CALL INTERRUPT subs...

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

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

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

            a$ = CHR$(R): PUT GIFFile, , a$

            a$ = CHR$(G): PUT GIFFile, , a$

            a$ = CHR$(B): PUT GIFFile, , a$

        NEXT

END SELECT



'write out an image descriptor...

a$ = "," '"," is image seperator

PUT GIFFile, , a$ 'write it

PUT GIFFile, , Minx 'write out the image's location

PUT GIFFile, , MinY

ImageWidth = (MaxX - Minx + 1) 'find length & width of image

ImageHeight = (MaxY - MinY + 1)

PUT GIFFile, , ImageWidth 'store them into the file

PUT GIFFile, , ImageHeight

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

PUT GIFFile, , a$



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

PUT GIFFile, , a$



'Initialize the vars needed by PutCode

CurrentBit = 0: Char& = 0



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

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

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

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

OAddress = a& 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

PutCode ClearCode ' clear code



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

Prefix = GetByte '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



            PutCode Prefix 'write last pixel

            PutCode EOFCode 'send EOF code



            IF CurrentBit <> 0 THEN

                PutCode 0 'flush out the last code...

            END IF

            PutByte 0



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

            PUT GIFFile, , OutBuffer$

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

            'but many GIF's have them, so how

            'much could it hurt?

            PUT GIFFile, , a$



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

            PUT GIFFile, LastLoc&, a$



            CLOSE GIFFile

            EXIT SUB

        ELSE 'get a pixel from the screen and see if we can find

            'the new string in the table

            Suffix = GetByte

            GOSUB Hash 'is it there?

            IF Found = TRUE THEN Prefix = code(index) 'yup, replace the

            'prefix:suffix string with whatever

            'code represents it in the table

        END IF

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



    PutCode Prefix '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 if what code this is!



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



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

    IF NextCode = MaxCode + 1 THEN 'can an output code ever exceed

        'the current code size?

        'yup, increase the code size



        MaxCode = MaxCode * 2



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

        'code. When the clear code is deferred, codes are not entered

        'into the hash table anymore. When the compression of the image

        'starts to fall below a certain threshold, the clear code is

        'sent and the hash table is cleared. The overall result is

        'greater compression, because the table is cleared less often.

        'This version of MakeGIF doesn't support this, because some GIF

        'decoders crash when they attempt to enter too many codes

        'into the string table.



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

            PutCode ClearCode 'yup; clear the table and

            GOSUB ClearTree 'start over

            NextCode = StartCode

            CodeSize = StartSize

            MaxCode = StartMax





        ELSE

            CodeSize = CodeSize + 1 'just increase the code size if

        END IF 'it's not too high( not > 12)

    END IF



LOOP 'while we have more pixels

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

'this is only one of a plethora of ways to search the table for

'a match! I used a binary tree first, but I switched to hashing

'cause it's quicker(perhaps the way I implemented the tree wasn't

'optimal... who knows!)

Hash:

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

'?? is there a better formula?

index = ((Prefix * 256&) XOR Suffix) MOD Table.Size

'

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

'else there's a chance that the routine will hang up... hate when

'that happens!)

'

'Calculate an offset just in case we don't find what we want on the

'first try...

IF index = 0 THEN 'can't have Table.Size-0 !

    Offset = 1

ELSE

    Offset = Table.Size - index

END IF



DO 'until we (1) find an empty entry or (2) find what we're lookin for





    IF code(index) = -1 THEN 'is this entry blank?

        Found = FALSE 'yup- we didn't find the string

        RETURN

        'is this entry the one we're looking for?

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

        'yup, congrats you now understand hashing!!!



        Found = TRUE

        RETURN

    ELSE

        'shoot! we didn't find anything interesting, so we must

        'retry- this is what slows hashing down. I could of used

        'a bigger table, that would of speeded things up a little

        'because this retrying would not happen as often...

        index = index - Offset

        IF index < 0 THEN 'too far down the table?

            'wrap back the index to the end of the table

            index = index + Table.Size

        END IF

    END IF

LOOP

END SUB



SUB pal (c, R, G, B)

OUT &H3C8, c

OUT &H3C9, R

OUT &H3C9, G

OUT &H3C9, B

END SUB



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

SUB PutByte (a) STATIC

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

IF BlockLength <= 0 THEN ' yup,

    BlockLength = 255 'block length is now 255

    LastLoc& = LOC(1) + 1 + (OAddress - OStartAddress) 'remember the pos.

    BufferWrite 255 'for later fixing

END IF

BufferWrite a 'put a byte into the buffer

END SUB



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

SUB PutCode (a) STATIC

Char& = Char& + a * 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?

    PutByte Char& AND 255 ' yup! 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 'until we don't have a full byte

END SUB
This code is VALUABLE. It took me a while to find decoder. The encoder was a breeze. D@mn that A, Richie G. I'll refactor these, but for now, this is GOLD for GIF. I thought my ascents up Pike's Peak were difficult. In another way, this was too. Displays gif upon loading.
Code:
gifload "pyramid.gif", 320, 200

DECLARE SUB gifload (A$)

SUB gifload (filein$, wide%, high%)
DEFINT A-Z
CONST GifIdStr$ = "GIF87a"
CONST BitsInByte% = 8
CONST GifMaxEncodeBits% = 12
CONST GifBitsMag% = 4095 '* 2^GifMaxEncodeBits%-1 (aka 12 bits) CONST does not handle operations by another prior defined CONST :(
GifInChannel% = FREEFILE
IF GifInChannel% > 0 THEN
    DIM Prefix(0 TO GifBitsMag%)
    DIM Suffix(0 TO GifBitsMag%)
    DIM OutStack(0 TO GifBitsMag%)
    DIM shiftout%(8)
    DIM Ybase AS LONG, powersof2(0 TO GifMaxEncodeBits% - 1) AS LONG, WorkCode AS LONG

    FOR A% = 0 TO BitsInByte% - 1
        shiftout%(BitsInByte% - A%) = 2 ^ A%
    NEXT A%
    FOR A% = 0 TO GifMaxEncodeBits% - 1
        powersof2(A%) = 2 ^ A%
    NEXT A%
    IF filein$ = "" THEN
        INPUT "GIF file"; filein$
        IF filein$ = "" THEN END
    END IF
    IF INSTR(filein$, ".") = 0 THEN filein$ = filein$ + ".gif"
    OPEN filein$ FOR BINARY AS #GifInChannel%
    A$ = SPACE$(LEN(GifIdStr$))
    GET #GifInChannel%, , A$
    IF A$ <> GifIdStr$ THEN
        PRINT "Not a "; GifIdStr$; " file."
        EXIT SUB
    END IF
    GET #GifInChannel%, , TotalX: GET #GifInChannel%, , TotalY
    GOSUB GetByte
    NumColors = 2 ^ ((A% AND 7) + 1)
    NoPalette = (A% AND 128) = 0
    GOSUB GetByte
    Background = A%
    GOSUB GetByte
    IF A% <> 0 THEN
        PRINT "Bad screen descriptor."
        EXIT SUB
    END IF
    IF NoPalette = 0 THEN
        P$ = SPACE$(NumColors * 3)
        GET #GifInChannel%, , P$
    END IF
    DO
        GOSUB GetByte
        IF A% = 44 THEN
            EXIT DO
        ELSEIF A% <> 33 THEN
            PRINT "Unknown extension type.": END
        END IF
        GOSUB GetByte
        DO
            GOSUB GetByte
            A$ = SPACE$(A%)
            GET #GifInChannel%, , A$
        LOOP UNTIL A% = 0
    LOOP
    GET #GifInChannel%, , XStart
    GET #GifInChannel%, , YStart
    GET #GifInChannel%, , XLength
    GET #GifInChannel%, , YLength
    XEnd = XStart + XLength
    YEnd = YStart + YLength
    GOSUB GetByte
    IF A% AND 128 THEN PRINT "Can't handle local colormaps.": END
    Interlaced = A% AND 64
    PassNumber = 0
    PassStep = 8
    GOSUB GetByte
    ClearCode = 2 ^ A%
    EOSCode = ClearCode + 1
    FirstCode = ClearCode + 2
    NextCode = FirstCode
    StartCodeSize = A% + 1
    CodeSize = StartCodeSize
    StartMaxCode = 2 ^ (A% + 1) - 1
    MaxCode = StartMaxCode

    BitsIn = 0
    BlockSize = 0
    BlockPointer = 1
    x% = XStart
    y% = YStart
    Ybase = y% * wide%

    SCREEN 13: DEF SEG = &HA000
    IF NoPalette = 0 THEN
        OUT &H3C7, 0
        OUT &H3C8, 0
        FOR A% = 1 TO NumColors * 3
            OUT &H3C9, ASC(MID$(P$, A%, 1)) \ 4
        NEXT A%
    END IF
    LINE (0, 0)-(wide% - 1, high% - 1), Background, BF
    DO
        GOSUB GetCode
        IF Code <> EOSCode THEN
            IF Code = ClearCode THEN
                NextCode = FirstCode
                CodeSize = StartCodeSize
                MaxCode = StartMaxCode
                GOSUB GetCode
                CurCode = Code
                LastCode = Code
                LastPixel = Code
                IF x% < wide% THEN POKE x% + Ybase, LastPixel
                x% = x% + 1
                IF x% = XEnd THEN GOSUB NextScanLine
            ELSE
                CurCode = Code
                StackPointer = 0
                IF Code > NextCode THEN EXIT DO
                IF Code = NextCode THEN
                    CurCode = LastCode
                    OutStack(StackPointer) = LastPixel
                    StackPointer = StackPointer + 1
                END IF

                DO WHILE CurCode >= FirstCode
                    OutStack(StackPointer) = Suffix(CurCode)
                    StackPointer = StackPointer + 1
                    CurCode = Prefix(CurCode)
                LOOP

                LastPixel = CurCode
                IF x% < wide% THEN POKE x% + Ybase, LastPixel
                x% = x% + 1
                IF x% = XEnd THEN GOSUB NextScanLine

                FOR A% = StackPointer - 1 TO 0 STEP -1
                    IF x% < wide% THEN POKE x% + Ybase, OutStack(A%)
                    x% = x% + 1
                    IF x% = XEnd THEN GOSUB NextScanLine
                NEXT A%

                IF NextCode <= GifBitsMag% THEN
                    Prefix(NextCode) = LastCode
                    Suffix(NextCode) = LastPixel
                    NextCode = NextCode + 1
                    IF NextCode > MaxCode AND CodeSize < GifMaxEncodeBits% THEN
                        CodeSize = CodeSize + 1
                        MaxCode = MaxCode * 2 + 1
                    END IF
                END IF
                LastCode = Code
            END IF
        END IF
    LOOP UNTIL DoneFlag OR Code = EOSCode
    CLOSE #GifInChannel%
    ERASE Prefix
    ERASE Suffix
    ERASE OutStack
    ERASE shiftout%
    ERASE powersof2
END IF
EXIT SUB

GetByte:
A$ = " "
GET #GifInChannel%, , A$
A% = ASC(A$)
RETURN

NextScanLine:
IF Interlaced THEN
    y% = y% + PassStep
    IF y% >= YEnd THEN
        PassNumber = PassNumber + 1
        SELECT CASE PassNumber
            CASE 1
                y% = 4
                PassStep = 8
            CASE 2
                y% = 2
                PassStep = 4
            CASE 3
                y% = 1
                PassStep = 2
        END SELECT
    END IF
ELSE
    y% = y% + 1
END IF
x% = XStart
Ybase = y% * wide%
DoneFlag = y% > high%
RETURN

GetCode:
IF BitsIn = 0 THEN
    GOSUB ReadBufferedByte
    LastChar = A%
    BitsIn = 8
END IF
WorkCode = LastChar \ shiftout%(BitsIn)
DO WHILE CodeSize > BitsIn
    GOSUB ReadBufferedByte
    LastChar = A%
    WorkCode = WorkCode OR LastChar * powersof2(BitsIn)
    BitsIn = BitsIn + 8
LOOP
BitsIn = BitsIn - CodeSize
Code = WorkCode AND MaxCode
RETURN

ReadBufferedByte:
IF BlockPointer > BlockSize THEN
    GOSUB GetByte: BlockSize = A%
    A$ = SPACE$(BlockSize)
    GET #GifInChannel%, , A$
    BlockPointer = 1
END IF
A% = ASC(MID$(A$, BlockPointer, 1))
BlockPointer = BlockPointer + 1
RETURN
END SUB
Reply
#2
$pyramid.txt
<from JUST after here>
5 36
10 0 0
0 0 10
0 0 -10
-10 0 0
0 10 0
5 1 3
5 3 1
3 1 5
3 5 1
1 3 5
1 5 3
5 1 2
5 2 1
2 1 5
2 5 1
1 2 5
1 5 2
5 2 4
5 4 2
2 4 5
2 5 4
4 5 2
4 2 5
5 3 4
5 4 3
3 4 5
3 5 4
4 5 3
4 3 5
4 3 1
4 1 3
3 1 4
3 4 1
1 3 4
1 4 3
4 1 2
4 2 1
2 1 4
2 4 1
1 2 4
1 4 2
<to JUST before here>


Attached Files Thumbnail(s)

Reply
#3
Certain 256-color images have been subject to problems under the latest iterations of qb64. I am simply providing examples under ZERO copyright limitations involving zero extra libraries that can be REASONABLY inlined to existing code, including qb64 source itself. The MakeGiF() and LoadGIF() SUBs are IMPORTANT. I will refactor so it can be included in QB64 primary source, preferably as a self-contained encode/decode SUB.
Reply