Category : BASIC Source Code
Archive   : DECGIF3.ZIP
Filename : DECGIF3.BAS

'*****************************************************************************
'* DECGIF.BAS- A PDS 7.1 & QB4.5 GIF Decompressor With Some Assembly
'* By Rich Geldreich 1992
'* You may use this program for anything you wish, as long as credit
'* is given where credit is due! Thanks.
'* 06-27-92, X Y Rescaler added 07-17-92
'*
'* To make this program compatible with QB4.5, use search and replace
'* to change all of the "SSEG" strings to "VARSEG" strings in this module.
'*
'*
'* The module USEDGIF.BAS demonstrates this program.
'*
'* Any bugs/problems, write or call:
'*
'* Rich Geldreich
'* 410 Market St.
'* Gloucester City, NJ 08030
'* (609)-742-8752

DEFINT A-Z

'Procedures in this module:
DECLARE FUNCTION LoadGIF (F$, Vm, ShowType, Xorigin, Yorigin, XScale, YScale)
DECLARE SUB WriteLine ()

'Procedures in SHOWRGB.ASM:
DECLARE SUB ShowRGB (BYVAL PalOffset, BYVAL PalSegment, BYVAL NumColors, BYVAL VGA)

'Procedures in WPIX2.ASM:
DECLARE SUB SetPixels (BYVAL XSkip, A(), BYVAL X, BYVAL Y, BYVAL NumPixels)
DECLARE SUB SetMode (BYVAL Mode)
DECLARE SUB SetWidth (BYVAL ScreenWidth)

'Procedure in RESCALE.ASM:
DECLARE SUB Rescale (A(), B(), BYVAL NumPoints, BYVAL NewScale)

'Procedure in X360x480.ASM:
DECLARE SUB X360x480 ()

CONST True = -1, False = 0

CONST BufferLength = 10000 'change this if desired- but don't
'make it too low or floppy-based systems
'will suffer(A LOT)
DIM SHARED Pixels(1024)
DIM SHARED PassStep(4), PassStart(4) AS LONG
DIM SHARED ErrorStatus

END
DriveError:
ErrorStatus = True
RESUME NEXT

'Decompression tables
GIFData:
'MaxCodes(0 to 11)
DATA 4,8,16,&h20,&h40,&h80,&h100,&h200,&h400,&h800,&h1000,8192
'CodeMask(1 to 8)
DATA 1,3,7,15,31,63,127,255
'Powers2(0 to 14)
DATA 1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384

'PassStep(0 to 3), PassStart(0 to 3)
DATA 8,8,4,2,0,4,2,1

'******************************************************************************
'* Displays A GIF file.
'*
'* F$ is the filename of the GIF image.
'*
'* Vm is the video mode:
'* mode 0=320x200x256 vga QB mode 13
'* mode 1=360x480x256 vga -non QB-
'* mode 2=640x480x16 vga QB mode 12
'* mode 3=320x200x16 ega QB mode 7
'* mode 4=640x350x16 ega QB mode 9
'* (To use the 360x480x256 mode on a VGA, call the assembly procedure
'* named "X360x480". Don't forget QB doesn't have support for this graphics
'* mode.)
'*
'* ShowType:
'* 0 = Set the palette before the image is decompressed.
'* 1 = Set the palette after the image is decompressed. The entire palette
'* used by the GIF file will be set to black so the user doesn't see the
'* image while it is being decompressed.
'*
'* Xorigin, Yorigin:
'* The origin of the image. If Xorigin=50, and Yorigin=-50, then the
'* image's upper left corner will be at (50,-50). If the image cannot
'* be seen then LoadGIF will return with an error.
'*
'* Xscale, Yscale:
'* Resize parameters. Each parameter is actually divided by 256.
'* If Xscale=128, and Yscale=512, for example, then the image will
'* be 1/2 as big horizontally and twice as big vertically. If you want
'* the image to be normal size, then use 256 for both axis. If a parameter
'* is -1 then that axis will be shrunk or expanded to fit the screen's size.
'*
'* Let's say Xscale=-1, and Yscale=300. In this particular case, the image
'* will fit the screen's horizontal size and will be 300/256 as big
'* vertically. If the resized image is too small or big then LoadGIF will
'* return an error.
'*
'* If LoadGIF returns...
'* 0 = The image was decompressed successfully
'* 1 = The specified file could not be found
'* 2 = The specified file is not a GIF file, the GIF file had
'* had a local colormap, or it had an unrecognized format(maby GIF89a)
'* 3 = The GIF file had too many colors for the specified screen
'* 4 = origin or scale error(if the image was totally out of view,
'* or it was scaled too small or big, for instance)
'* 5 = An error occured while decompressing the image. The image may
'* be partly visible, however.
'*
FUNCTION LoadGIF (F$, Vm, ShowType, Xorigin, Yorigin, XScale, YScale)
DIM Prefix(4096), Suffix(4096), OutCode(1024)
DIM MaxCodes(12), Powers2(16), CodeMask(8)
DIM Masks(12)

SHARED CurrentPixel, CurrentLine&
SHARED XStart&, YStart&, YEnd&, ScreenY&
SHARED MaxLength, XStart, ScreenY, StoredXLength
SHARED PassNumber, Interlaced, Done
SHARED SkipX, SkipY
SHARED ArrayOffset

'used for reading single bytes from GIF file
DIM ByteBuffer AS STRING * 1

RESTORE GIFData

B = 2: FOR A = 1 TO 12: Masks(A) = B - 1: B = B * 2: NEXT
FOR A = 0 TO 11: READ MaxCodes(A): NEXT
FOR A = 1 TO 8: READ CodeMask(A): NEXT
FOR A = 0 TO 14: READ Powers2(A): NEXT

'get unused file handle
Handle = FREEFILE

'add GIF extension of needed
IF INSTR(F$, ".") = 0 THEN F$ = F$ + ".GIF"

'see if file is present
ErrorStatus = False
ON ERROR GOTO DriveError
OPEN F$ FOR INPUT AS Handle

'if not then return with error
IF ErrorStatus THEN
ON ERROR GOTO 0
ErrorStatus = False
LoadGIF = 1
CLOSE Handle
EXIT FUNCTION
ELSE
CLOSE Handle
END IF
're-open file in binary mode
OPEN F$ FOR BINARY AS Handle
ON ERROR GOTO 0
'just in case it didn't work
IF ErrorStatus THEN
ErrorStatus = False
LoadGIF = 1
CLOSE Handle
EXIT FUNCTION
END IF

'check to see if it's a GIF87a file
'one of these days I'll implement the GIF89a stuff...
A$ = SPACE$(6)
GET Handle, , A$
IF A$ <> "GIF87a" THEN
LoadGIF = 2
CLOSE Handle
EXIT FUNCTION
END IF

'get total screen length and width
GET Handle, , TotalX
GET Handle, , TotalY

'get number of bits required to represent each pixel
GET Handle, , ByteBuffer
A = ASC(ByteBuffer)
BitsPixel = (A AND 7) + 1
'check for global color map (if none is present then
'the default palette, whatever that may be, will be used)

IF (A AND 128) = 0 THEN
NoPalette = True
ELSE
NoPalette = False
END IF

'get background color
'(the background color is ignored in this version, it's seldom
'important so no big loss)
GET Handle, , ByteBuffer
BackGround = ASC(ByteBuffer)
GET Handle, , ByteBuffer

'check to make sure byte 7 of the screen descriptor is 0
IF ASC(ByteBuffer) <> 0 THEN
LoadGIF = 2
CLOSE Handle
EXIT FUNCTION
END IF

'calculate the number of colors in image
NumColors = Powers2(BitsPixel)
'check out which video mode the caller wants
SELECT CASE Vm
CASE 0
SetMode 0
ScreenX& = 320 * 256&
ScreenY& = 200 * 256&
VGA = True: MaxColors = 256
CASE 1
SetMode 1
SetWidth 90
ScreenX& = 360 * 256&
ScreenY& = 480 * 256&
VGA = True: MaxColors = 256
CASE 2
SetMode 2
SetWidth 80
ScreenX& = 640 * 256&
ScreenY& = 480 * 256&
VGA = True: MaxColors = 16
CASE 3
SetMode 2
SetWidth 40
ScreenX& = 320 * 256&
ScreenY& = 200 * 256&
VGA = False: MaxColors = 16
CASE 4
SetMode 2
SetWidth 80
ScreenX& = 640 * 256&
ScreenY& = 350 * 256&
VGA = False: MaxColors = 16
END SELECT

'if the video mode selected doesn't have enough colors for the
'image then return with error
IF NumColors > MaxColors THEN
LoadGIF = 3
CLOSE Handle
EXIT FUNCTION
END IF


IF NOT NoPalette THEN 'set the palette if it exists
PalString$ = STRING$(NumColors * 2 + NumColors, 0)

IF ShowType <> 0 THEN
ShowRGB SADD(PalString$), SSEG(PalString$), NumColors, VGA
END IF

GET Handle, , PalString$

IF ShowType = 0 THEN
ShowRGB SADD(PalString$), SSEG(PalString$), NumColors, VGA
END IF
END IF

'skip by any GIF extension blocks(some GIF's have them, some don't)
GET Handle, , ByteBuffer
DO WHILE ByteBuffer <> ","
'if not an extension block then return with error
IF ByteBuffer <> "!" THEN
LoadGIF = 2
CLOSE Handle
EXIT FUNCTION
ELSE
'skip the function code
GET Handle, , ByteBuffer
'skip by function data bytes
DO
GET Handle, , ByteBuffer
BlockLength = ASC(ByteBuffer)
A$ = SPACE$(BlockLength)
GET Handle, , A$
LOOP UNTIL BlockLength = 0
END IF
GET Handle, , ByteBuffer
LOOP

'*************************************************************************
'* X/Y Rescaling Setup Routines Start Here
'* 7-17-92

'get image start coordinates
GET Handle, , A: XStart& = A * 256&
GET Handle, , A: YStart& = A * 256&
GET Handle, , StoredXLength
GET Handle, , A

IF XScale = -1 THEN XScale = ScreenX& \ StoredXLength
IF YScale = -1 THEN YScale = ScreenY& \ A

XLength& = StoredXLength * CLNG(XScale)
YLength& = A * CLNG(YScale)
IF XScale <= 1 OR YScale <= 0 OR XLength& > 524288 OR YScale > 4095 THEN
LoadGIF = 4
CLOSE Handle
EXIT FUNCTION
END IF

XStart& = XStart& + Xorigin * 256&
YStart& = YStart& + Yorigin * 256&

IF XStart& < 0 THEN
ArrayOffset = (-XStart&) \ 256
XLength& = XLength& + XStart&
XStart& = 0
ELSE
ArrayOffset = 0
END IF

XEnd& = XLength& + XStart& - 256
YEnd& = YLength& + YStart& - 256

MaxLength = XLength& \ 256
IF (MaxLength * 256& + XStart& - 256) > ScreenX& THEN
MaxLength = (ScreenX& - XStart&) \ 256
END IF

IF XStart& >= ScreenX& OR YStart& >= ScreenY& OR XEnd& < 0 OR YEnd& < 0 OR MaxLength = 0 THEN
LoadGIF = 4
CLOSE Handle
EXIT FUNCTION
END IF

SkipX = 65536 \ XScale
SkipY = YScale
XStart = XStart& \ 256
ScreenY = ScreenY& \ 256

FOR I = 0 TO 3: READ A: PassStep(I) = A * YScale: NEXT
FOR I = 0 TO 3: READ A: PassStart(I) = A * YScale + YStart&: NEXT
'*************************************************************************
'* X/Y Rescaling Setup Routines End Here
'*


'check for local colormap(I'll handle this as soon as I find
'a GIF that has one!)
GET Handle, , ByteBuffer: A = ASC(ByteBuffer)
IF (A AND 128) THEN
LoadGIF = 2
CLOSE Handle
EXIT FUNCTION
END IF

'check if interlaced
IF (A AND 64) THEN
Interlaced = True
PassNumber = 0
ELSE
Interlaced = False

END IF

'get LZW minimum code size
GET Handle, , ByteBuffer
CodeSize = ASC(ByteBuffer)

'when the clear code is received the LZW vars are reset
ClearCode = Powers2(CodeSize)
'when EofCode is received the decompressor stops
EofCode = ClearCode + 1
'first free code in table
FirstFree = ClearCode + 2
FreeCode = FirstFree
'# bits in code
CodeSize = CodeSize + 1
InitCodeSize = CodeSize
'maximum # of codes for the current codesize
MaxCode = MaxCodes(CodeSize - 2)
BitMask = CodeMask(BitsPixel)
ReadMask = Masks(CodeSize)

'set up the disk buffer vars
BitsLeft = 0 'number of bits left(ReadCode)
BlockLength = 1 'current GIF block length
Address = 0 'current address in disk buffer
EndAddress = 1 'address of end of disk buffer

OutCount = 0 '# of pixels in the psuedo-stack

CurrentPixel = 0
CurrentLine& = YStart&

Done = False

Buffer$ = SPACE$(BufferLength) 'disk buffer
CodeErrors = 0: ErrorThreshold = 0 'if CodeErrors>ErrorThreshold then
'the image is assumed to be corrupted
ERASE Pixels

DO 'until an error or EOFCode is detected

'get a code from the data stream- inserted directly into
'the code to aviod a GOSUB command for each code
'*************************************************************************

'GOSUB ReadCode

'do we have any bits left?
IF BitsLeft = 0 THEN
Address = Address + 1
IF Address = EndAddress THEN GOSUB FillBuffer
TempChar = PEEK(Address)
BlockLength = BlockLength - 1
IF BlockLength = 0 THEN
BlockLength = TempChar
Address = Address + 1
IF Address = EndAddress THEN GOSUB FillBuffer
TempChar = PEEK(Address)
END IF
'8 bits left now
BitsLeft = 8
END IF
'attach bits to workcode&
WorkCode& = TempChar \ Powers2(8 - BitsLeft)
'loop while more bits are needed...
DO WHILE CodeSize > BitsLeft
'get another byte from buffer
Address = Address + 1
'fill up buffer if it's empty
IF Address = EndAddress THEN GOSUB FillBuffer
TempChar = PEEK(Address)
'see if at end of current block
BlockLength = BlockLength - 1
IF BlockLength = 0 THEN
'get another block
BlockLength = TempChar
Address = Address + 1
IF Address = EndAddress THEN GOSUB FillBuffer
TempChar = PEEK(Address)
END IF
'add bits to workcode&
WorkCode& = WorkCode& OR TempChar * CLNG(Powers2(BitsLeft))
BitsLeft = BitsLeft + 8
LOOP
'update the BitsLeft variable
BitsLeft = BitsLeft - CodeSize
'mask off WorkCode&
Code = WorkCode& AND ReadMask


'*************************************************************************


'is it an EofCode?
IF Code <> EofCode THEN
'check if it's a Clear Code
IF Code = ClearCode THEN
'process a clear code; reset LZW vars
CodeSize = InitCodeSize
ReadMask = Masks(CodeSize)
MaxCode = MaxCodes(CodeSize - 2)
FreeCode = FirstFree
'first code must be a character
GOSUB ReadCode
CurCode = Code
OldCode = Code
FinChar = Code AND BitMask
Pixels(CurrentPixel) = FinChar
CurrentPixel = CurrentPixel + 1
IF CurrentPixel = StoredXLength THEN WriteLine
ELSE
'process a code
CurCode = Code
InCode = Code
'do we have this string yet?
IF Code >= FreeCode THEN
'Code > FreeCode is invalid: increment CodeErrors and
'stop decompression if too many errors(for bum GIF
'files)
IF Code > FreeCode THEN
CodeErrors = CodeErrors + 1
IF CodeErrors > ErrorThreshold THEN
'trick decompressor into ending early
Code = EofCode
END IF
END IF
'trick decompressor into thinking it has just
'received the last code
CurCode = OldCode
OutCode(OutCount) = FinChar
OutCount = OutCount + 1
END IF

'does this code represent a string?
IF CurCode > BitMask THEN
DO 'until we get the last character in this string
OutCode(OutCount) = Suffix(CurCode)
CurCode = Prefix(CurCode)
OutCount = OutCount + 1
LOOP UNTIL CurCode <= BitMask 'LOOP until we have one
END IF 'character left

FinChar = CurCode AND BitMask
OutCode(OutCount) = FinChar
'plot the pixels; "pop" each one off the stack
'when the line buffer is full it will be dumped onto
'the screen
FOR I = OutCount TO 0 STEP -1
Pixels(CurrentPixel) = OutCode(I)
CurrentPixel = CurrentPixel + 1
IF CurrentPixel = StoredXLength THEN WriteLine
NEXT
'reset the stack
OutCount = 0

'enter new string into table
Prefix(FreeCode) = OldCode
Suffix(FreeCode) = FinChar
'remember code for later
OldCode = InCode
FreeCode = FreeCode + 1
'increment code size if needed
IF FreeCode >= MaxCode AND CodeSize < 12 THEN
CodeSize = CodeSize + 1
MaxCode = MaxCode * 2
ReadMask = ReadMask * 2 OR 1
END IF
END IF
END IF
'loop until error or done
LOOP UNTIL Code = EofCode OR ErrorStatus OR Done
'close file
CLOSE Handle

'check for errors
IF ErrorStatus OR CodeErrors > 0 THEN
LoadGIF = 5
ELSE
IF ShowType = 1 THEN
ShowRGB SADD(PalString$), SSEG(PalString$), NumColors, VGA
END IF
LoadGIF = 0
END IF
'all done
EXIT FUNCTION

'*****************************************************************************
'* Reads one code from the GIF data stream
'* BitsLeft - # of bits currently left in TempChar
'* TempChar - holds the current byte from buffer
'* Address - current address in buffer
'* EndAddress - end address of buffer
'* BlockLength - number of bytes left in current block
'* WorkCode& - temporary variable;holds current code
'* If this routine was coded in assembly, the decompression speed of this
'* program would probably increase by 100% or more...
ReadCode:
'do we have any bits left?
IF BitsLeft = 0 THEN
Address = Address + 1
IF Address = EndAddress THEN GOSUB FillBuffer
TempChar = PEEK(Address)
BlockLength = BlockLength - 1
IF BlockLength = 0 THEN
BlockLength = TempChar
Address = Address + 1
IF Address = EndAddress THEN GOSUB FillBuffer
TempChar = PEEK(Address)
END IF
'8 bits left now
BitsLeft = 8
END IF
'attach bits to workcode&
WorkCode& = TempChar \ Powers2(8 - BitsLeft)
'loop while more bits are needed...
DO WHILE CodeSize > BitsLeft

Address = Address + 1 'get another byte from buffer

'fill up buffer if it's empty
IF Address = EndAddress THEN GOSUB FillBuffer
TempChar = PEEK(Address)

BlockLength = BlockLength - 1 'see if at end of current block
IF BlockLength = 0 THEN
BlockLength = TempChar 'get another block
Address = Address + 1
IF Address = EndAddress THEN GOSUB FillBuffer
TempChar = PEEK(Address)
END IF

'add bits to workcode&
WorkCode& = WorkCode& OR TempChar * CLNG(Powers2(BitsLeft))
BitsLeft = BitsLeft + 8
LOOP

BitsLeft = BitsLeft - CodeSize 'update the BitsLeft variable
Code = WorkCode& AND ReadMask 'mask off WorkCode&
RETURN
FillBuffer:
'fills up the disk buffer

'turn on error checking for this read
'if an error is detected then main loop will stop decoding the image

ON ERROR GOTO DriveError
GET Handle, , Buffer$
ON ERROR GOTO 0

A& = SADD(Buffer$)
A& = A& - 65536 * (A& < 0)
DEF SEG = SSEG(Buffer$) + (A& \ 16)
Address = A& MOD 16

EndAddress = Address + BufferLength
RETURN

END FUNCTION

SUB WriteLine
SHARED CurrentPixel, CurrentLine&
SHARED XStart&, YStart&, YEnd&, ScreenY&
SHARED MaxLength, XStart, ScreenY, StoredXLength
SHARED PassNumber, Interlaced, Done
SHARED SkipX, SkipY
SHARED ArrayOffset
DIM ScaledPixels(2047) 'enough to hold 2048 pixels

Y = CurrentLine& \ 256
Y1 = (CurrentLine& + SkipY) \ 256
IF SkipX <> 256 THEN

Rescale Pixels(), ScaledPixels(), StoredXLength, SkipX

FOR Y = Y TO Y1 - 1
IF Y > -1 AND Y < ScreenY THEN
SetPixels ArrayOffset, ScaledPixels(), XStart, Y, MaxLength
END IF
NEXT
ELSE
FOR Y = Y TO Y1 - 1
IF Y > -1 AND Y < ScreenY THEN
SetPixels ArrayOffset, Pixels(), XStart, Y, MaxLength
END IF
NEXT
END IF

CurrentPixel = 0
IF NOT Interlaced THEN
CurrentLine& = CurrentLine& + SkipY
IF CurrentLine& >= ScreenY& THEN Done = True
ELSE
CurrentLine& = CurrentLine& + PassStep(PassNumber)
IF CurrentLine& > YEnd& THEN
PassNumber = PassNumber + 1
CurrentLine& = PassStart(PassNumber)
END IF
IF PassNumber = 3 AND CurrentLine& >= ScreenY& THEN Done = True
END IF
END SUB