Difference between revisions of "GIF Creation"

From QB64 Wiki
Jump to navigation Jump to search
imported>Clippy
(Created page with '<center>'''GIF File Creator'''</center> {{CodeStart}} ' **************** DEMO CODE ******************** '{{Cl|$INCLUDE}} 'MakeGIF.bi' '-------------- Only for testing purposes: …')
 
m (Text replacement - "Qbasic" to "QBasic")
 
(18 intermediate revisions by one other user not shown)
Line 1: Line 1:
<center>'''GIF File Creator'''</center>
<center>'''GIF File Creator'''</center>
The following routine can be used with QBasic or QB64 to create a Graphic Information File image of a program screen. 


{{CodeStart}} ' **************** DEMO CODE ********************
* Accommodates [[_NEWIMAGE]] screen pages with up to 256 colors and image files loaded with [[_LOADIMAGE]].
'{{Cl|$INCLUDE}} 'MakeGIF.bi'
* The maximum screen coordinates are always one pixel LESS than the screen mode's resolution! (SCREEN 13's are 319 and 199)
'-------------- Only for testing purposes:
* The [[$INCLUDE]] text file can be created using Notepad and is REQUIRED when the program is compiled with QB64 ONLY!
 
 
{{CodeStart}} '*********************************** DEMO CODE **********************************
'Save code as a BAS file! Includes the GIFcreate.BI and BM text files. Demo by CodeGuy
{{Cl|DEFINT}} A-Z
{{Cl|SCREEN (statement)|SCREEN}} 13
{{Cl|SCREEN (statement)|SCREEN}} 13
{{Cl|RANDOMIZE}} {{Cl|TIMER}}


{{Cl|FOR...NEXT|FOR}} A = 1 {{Cl|TO}} 40
{{Cl|FOR...NEXT|FOR}} A = 1 {{Cl|TO}} 40
Line 12: Line 19:
     {{Cl|CIRCLE}} (x, y), {{Cl|RND}} * 80, c
     {{Cl|CIRCLE}} (x, y), {{Cl|RND}} * 80, c
     {{Cl|PAINT}} (x, y), {{Cl|RND}} * 256, c
     {{Cl|PAINT}} (x, y), {{Cl|RND}} * 256, c
{{Cl|NEXT}}
{{Cl|NEXT}}
{{Cl|FOR...NEXT|FOR}} A = 1 {{Cl|TO}} 1000: {{Cl|LINE}} -({{Cl|RND}} * 320, {{Cl|RND}} * 200), {{Cl|RND}} * 256: {{Cl|NEXT}}
{{Cl|LINE}} (0, 0)-(0, 199), 14
MakeGIF "temp.gif", 320, 200, 0, 0, 319, 199, 256, 2
gif& = {{Cl|_LOADIMAGE}}("temp.gif")


'{{Cl|$INCLUDE}}: 'MakeGIF.bm'
MakeGIF "GIFtemp.gif", 0, 0, {{Cl|_WIDTH (function)|_WIDTH}} - 1, {{Cl|_HEIGHT}} - 1, 256  'use 319 and 199 in QBasic
'Use the include file in QB64 only! Hard code the SUB in QBasic.
'{{Cl|$INCLUDE}}: 'GIFcreate.BM'  


'-------------- end of DEMO code
'************************************ END DEMO *********************************
{{CodeEnd}}
{{CodeEnd}}
<center>''MakeGIF.BI text [[$INCLUDE]] file:''</center>
{{TextStart}}
' *************************** MakeGif.bi ********************
'* original code by Rich Geldreich
'* creates a GIF87a-compliant GIF from the screen and has potential as a key-activated screen capture utility.
'* will create GIF only for up to 256 color (8-bit) graphics
{{Cb|DEFINT}} A-Z
{{Cb|CONST}} True = -1, False = 0
{{Cb|DIM}} {{Cb|SHARED}} OutBuffer$, OStartAddress, OAddress, OEndAddress, Oseg
{{Cb|DIM}} {{Cb|SHARED}} CodeSize, CurrentBit, Char&, BlockLength
{{Cb|DIM}} {{Cb|SHARED}} Shift(7) {{Cb|AS}} {{Cb|LONG}}
{{Cb|DIM}} {{Cb|SHARED}} x, y, Minx, MinY, MaxX, MaxY, Done, GIFFile, LastLoc&
ShiftTable:
{{Cb|DATA}} 1,2,4,8,16,32,64,128 '' ''
{{TextEnd}}
<center>''MakeGIF.BM text [[$INCLUDE]] file:''</center>
{{TextStart}} ' ********************* MakeGIF.BM *********************
'Puts a byte into the disk buffer... when the disk buffer is full it is
'dumped to disk.
{{Cb|SUB}} BufferWrite (A) {{Cb|STATIC}}
{{Cb|IF...THEN|IF}} OAddress = OEndAddress {{Cb|THEN}} 'are we at the end of the buffer?
    PUT GIFFile, , OutBuffer$ ' yup, write it out and
    OAddress = OStartAddress '  start all over
{{Cb|END IF}}
{{Cb|POKE}} OAddress, A 'put byte in buffer
OAddress = OAddress + 1 'increment position
{{Cb|END SUB}}
'This routine gets one pixel from the display.
{{Cb|FUNCTION}} GetByte {{Cb|STATIC}}
GetByte = {{Cb|POINT}}(x, y) 'get the "byte"
x = x + 1 'increment X coordinate
{{Cb|IF...THEN|IF}} x > MaxX {{Cb|THEN}} 'are we too far?
    '* not really necessary
    '* {{Cb|LINE}} (Minx, y)-(MaxX, y), 0 'a pacifier for impatient users
    x = Minx 'go back to start
    y = y + 1 'increment Y coordinate
    {{Cb|IF...THEN|IF}} y > MaxY {{Cb|THEN}} 'are we too far down?
        Done = True ' yup, flag it then
    {{Cb|END IF}}
{{Cb|END IF}}
{{Cb|END FUNCTION}}


'
<center>''GIFcreate.BM text [[$INCLUDE]] file:''</center>
'-----------------------------------------------------------------------------
{{TextStart}} '-----------------------------------------------------------------------------
'   PDS 7.1 & QB4.5 GIF Compression Routine v1.00 By Rich Geldreich 1992
'             GIFcreate.BM Compression Routine v1.00 By Rich Geldreich 1992
'            Converted into one SUB Library routine by Ted Weissgerber 2011 
'-----------------------------------------------------------------------------
'-----------------------------------------------------------------------------
'                  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)
'
'
'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
'{{Cb|NOT}}E: EGA palettes are not supported in this version of MakeGIF.
'
'-----------------------------------------------------------------------


{{Cb|SUB}} MakeGIF (A$, ScreenX, ScreenY, Xstart, YStart, Xend, Yend, NumColors, AdaptorType)
{{Cb|SUB}} MakeGIF (file$, Xstart, YStart, Xend, Yend, NumColors)
{{Cb|CONST}} True = -1, False = 0
{{Cb|CONST}} Table.size = 7177  'hash table's size - must be a prime number!


{{Cb|CONST}} Table.Size = 7177  'hash table's size - must be a prime number!
{{Cb|DIM}} Prefix(Table.size - 1), Suffix(Table.size - 1), Code(Table.size - 1)
{{Cb|DIM}} Shift(7) {{Cb|AS}} {{Cb|LONG}}
{{Cb|FOR...NEXT|FOR}} i = 0 {{Cb|TO}} 7: Shift(i) = 2 ^ i: {{Cb|NEXT}} 'create exponent array for speed.


{{Cb|DIM}} Prefix(Table__ascii_chr_046__size - 1), Suffix(Table__ascii_chr_046__size - 1), Code(Table__ascii_chr_046__size - 1)
PWidth% = {{Cb|ABS}}(Xend - Xstart) + 1
PDepth% = {{Cb|ABS}}(Yend - Ystart) + 1
'MinX, MinY, MaxX, MaxY are maximum and minimum image coordinates
{{Cb|IF...THEN|IF}} Xstart > Xend {{Cb|THEN}} MaxX = Xstart: MinX = Xend {{Cb|ELSE}} MaxX = Xend: MinX = Xstart
{{Cb|IF...THEN|IF}} Ystart > Xend {{Cb|THEN}} MaxY = Ystart: MinY = Yend {{Cb|ELSE}} MaxY = Yend: MinY = Ystart


'The shift table contains the powers of 2 needed by the
'Open GIF output file
'PutCode routine. This is done for speed. (much faster to
GIF = {{Cb|FREEFILE}} 'use next free file
'look up an integer than to perform calculations...)
{{Cb|OPEN}} file$ {{Cb|FOR...NEXT|FOR}} {{Cb|BINARY}} {{Cb|AS}} #GIF
{{Cb|RESTORE}} ShiftTable
{{Cb|FOR...NEXT|FOR}} A = 0 {{Cb|TO}} 7: {{Cb|READ}} Shift(A): {{Cb|NEXT}}


'MinX, MinY, MaxX, MaxY have the encoding window
B$ = "GIF87a": {{Cb|PUT}} #GIF, , B$  'Put GIF87a header at beginning of file
Minx = Xstart: MinY = YStart
MaxX = Xend: MaxY = Yend


'Open GIF output file
{{Cb|SELECT CASE}} NumColors      'get color settings
GIFFile = {{Cb|FREEFILE}} 'use next free file
  {{Cb|CASE}} 2            'monochrome (B&W) image
{{Cb|OPEN}} A$ {{Cb|FOR...NEXT|FOR}} {{Cb|BINARY}} {{Cb|AS}} GIFFile
    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
  {{Cb|CASE}} 16          '16 colors images {{Cb|SCREEN (statement)|SCREEN}}S 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
  {{Cb|CASE}} 256  '256 color images {{Cb|SCREEN (statement)|SCREEN}} 13 or {{Cb|_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
{{Cb|END SELECT}}


'Put GIF87a header at beginning of file
'ColorBits = 2      'for EGA
B$ = "GIF87a"
ColorBits = 6      'VGA monitors ONLY
PUT GIFFile, , B$


'See how many colors are in this image...
{{Cb|PUT}} #GIF, , PWidth% 'put screen's dimensions
{{Cb|SELECT CASE}} NumColors
{{Cb|PUT}} #GIF, , PDepth%
    {{Cb|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


    {{Cb|CASE}} 16 '16 colors images
CP = 128 + (ColorBits - 1) * 16 + (BitsPixel - 1) 'pack colorbits and bits per pixel
        BitsPixel = 4 '4 bits per pixel
{{Cb|PUT}} #GIF, , CP
        StartSize = 5 'first LZW code is 5 bits
        StartCode = 16 'first free code
        StartMax = 32 'maximum code in 5 bits


    {{Cb|CASE}} 256 '256 color images
Zero$ = {{Cb|CHR$}}(0)    'PUT a zero into the GIF file
        BitsPixel = 8 '8 bits per pixel
{{Cb|PUT}} #GIF, , Zero$
        StartSize = 9 'first LZW code is 9 bits
        StartCode = 256 'first free code
        StartMax = 512 'maximum code in 9 bits
{{Cb|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.
{{Cb|SELECT CASE}} AdaptorType
    {{Cb|CASE}} 1
        ColorBits = 2 'EGA
    {{Cb|CASE}} 2
        ColorBits = 6 'VGA
{{Cb|END SELECT}}


PUT GIFFile, , ScreenX 'put screen's dimensions
{{Cb|OUT}} {{Cb|&H}}3C7, 0                'start read at color 0
PUT GIFFile, , ScreenY
{{Cb|FOR...NEXT|FOR}} c = 0 {{Cb|TO}} NumColors - 1 'Get the RGB palette from the screen and put into file
'pack colorbits and bits per pixel
  R = ({{Cb|INP}}({{Cb|&H}}3C9) * 65280) \ 16128 'C = R * 4.0476190(for 0-255)
A = 128 + (ColorBits - 1) * 16 + (BitsPixel - 1)
  G = ({{Cb|INP}}({{Cb|&H}}3C9) * 65280) \ 16128
PUT GIFFile, , A
  B = ({{Cb|INP}}({{Cb|&H}}3C9) * 65280) \ 16128
'throw a zero into the GIF file
  red$ = {{Cb|CHR$}}(R): {{Cb|PUT}} #GIF, , red$
A$ = {{Cb|CHR$}}(0)
  grn$ = {{Cb|CHR$}}(G): {{Cb|PUT}} #GIF, , grn$
PUT GIFFile, , A$
  blu$ = {{Cb|CHR$}}(B): {{Cb|PUT}} #GIF, , blu$
'Get the RGB palette from the screen and put it into the file...
{{Cb|NEXT}}
{{Cb|SELECT CASE}} AdaptorType
        'write out an image descriptor
    {{Cb|CASE}} 1
sep$ = ","               'image separator
        {{Cb|STOP}}
{{Cb|PUT}} #GIF, , sep$         'write it
        'EGA palette routine not implemented yet
{{Cb|PUT}} #GIF, , Minx         'image start locations
    {{Cb|CASE}} 2
{{Cb|PUT}} #GIF, , MinY
        {{Cb|OUT}} {{Cb|&H}}3C7, 0
{{Cb|PUT}} #GIF, , PWidth%      'store them into the file
        {{Cb|FOR...NEXT|FOR}} A = 0 {{Cb|TO}} NumColors - 1
{{Cb|PUT}} #GIF, , PDepth%
            'Note: a BIOS call could be used here, but then we have to use
            'the messy {{Cb|CALL INTERRUPT}} subs...
            R = ({{Cb|INP}}({{Cb|&H}}3C9) * 65280) \ 16128 'C=R * 4.0476190(for 0-255)
            G = ({{Cb|INP}}({{Cb|&H}}3C9) * 65280) \ 16128
            B = ({{Cb|INP}}({{Cb|&H}}3C9) * 65280) \ 16128
            A$ = {{Cb|CHR$}}(R): PUT GIFFile, , A$
            A$ = {{Cb|CHR$}}(G): PUT GIFFile, , A$
            A$ = {{Cb|CHR$}}(B): PUT GIFFile, , A$
        {{Cb|NEXT}}
{{Cb|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$ = {{Cb|CHR$}}(BitsPixel - 1) '# bits per pixel in the image
A$ = {{Cb|CHR$}}(BitsPixel - 1) '# bits per pixel in the image
PUT GIFFile, , A$
{{Cb|PUT}} #GIF, , A$
 
A$ = {{Cb|CHR$}}(StartSize - 1) 'store the LZW minimum code size
A$ = {{Cb|CHR$}}(StartSize - 1) 'store the LZW minimum code size
PUT GIFFile, , A$
{{Cb|PUT}} #GIF, , A$


'Initialize the vars needed by PutCode
CurrentBit = 0: Char& = 0   'Initialize the vars needed by PutCode
CurrentBit = 0: Char& = 0


MaxCode = StartMax 'the current maximum code size
MaxCode = StartMax         'the current maximum code size
CodeSize = StartSize 'the current code size
CodeSize = StartSize       'the current code size
ClearCode = StartCode 'ClearCode & {{Cb|EOF}} code are the
ClearCode = StartCode       'ClearCode & {{Cb|EOF}} code are the
{{Cb|EOF}}Code = StartCode + 1 ' first two entries
{{Cb|EOF}}Code = StartCode + 1     'first two entries
StartCode = StartCode + 2 'first free code that can be used
StartCode = StartCode + 2   'first free code that can be used
NextCode = StartCode 'the current code
NextCode = StartCode       'the current code


OutBuffer$ = {{Cb|STRING$}}(5000, 32) 'output buffer; for speedy disk writes
OutBuffer$ = {{Cb|STRING$}}(5000, 32)   'output buffer; for speedy disk writes
A& = {{Cb|SADD}}(OutBuffer$) 'find address of buffer
Buff& = {{Cb|SADD}}(OutBuffer$)                 'find address of buffer
A& = A& - 65536 * (A& < 0)
Buff& = Buff& - 65536 * (Buff& < 0)
Oseg = {{Cb|VARSEG}}(OutBuffer$) + (A& \ 16) 'get segment + offset >> 4
Oseg = {{Cb|VARSEG}}(OutBuffer$) + (Buff& \ 16) 'get segment + offset >> 4
OAddress = A& {{Cb|AND (boolean)|AND}} 15 'get address into segment
OAddress = Buff& {{Cb|AND (boolean)|AND}} 15                   'get address into segment
OEndAddress = OAddress + 5000 'end of disk buffer
OEndAddress = OAddress + 5000             'end of disk buffer
OStartAddress = OAddress 'current location in disk buffer
OStartAddress = OAddress                 'current location in disk buffer
{{Cb|DEF SEG}} = Oseg
{{Cb|DEF SEG}} = Oseg


{{Cb|GOSUB}} ClearTree 'clear the tree & output a
{{Cb|GOSUB}} ClearTree           'clear the tree & output a
PutCode ClearCode ' clear code
PC = ClearCode: {{Cb|GOSUB}} PutCode         'clear code


x = Xstart: y = YStart 'X & Y have the current pixel
x = Xstart: y = YStart     'X & Y have the current pixel
Prefix = GetByte 'the first pixel is a special case
{{Cb|GOSUB}} GetByte: Prefix = GB          'the first pixel is a special case
Done = False 'True when image is complete
Done = False               'True when image is complete


{{Cb|DO...LOOP|DO}} 'while there are more pixels to encode
{{Cb|DO...LOOP|DO}} 'while there are more pixels to encode
  {{Cb|DO...LOOP|DO}} 'until we have a new string to put into the table
    {{Cb|IF...THEN|IF}} Done {{Cb|THEN}} 'write out the last pixel, clear the disk buffer
'          'and fix up the last block so its count is correct


    {{Cb|DO...LOOP|DO}} 'until we have a new string to put into the table
      PC = Prefix: {{Cb|GOSUB}} PutCode      'write last pixel
      PC = {{Cb|EOF}}Code: {{Cb|GOSUB}} PutCode    'send {{Cb|EOF}} code


        {{Cb|IF...THEN|IF}} Done {{Cb|THEN}} 'write out the last pixel, clear the disk buffer
      {{Cb|IF...THEN|IF}} CurrentBit <> 0 {{Cb|THEN}} PC = 0: {{Cb|GOSUB}} PutCode   'flush out the last code...
            'and fix up the last block so its count is correct
      PB = 0: {{Cb|GOSUB}} PutByte
 
      OutBuffer$ = {{Cb|LEFT$}}(OutBuffer$, OAddress - OStartAddress)
            PutCode Prefix 'write last pixel
      {{Cb|PUT}} #GIF, , OutBuffer$
            PutCode {{Cb|EOF}}Code 'send {{Cb|EOF}} code
      A$ = ";" + {{Cb|STRING$}}(8, {{Cb|&H}}1A)         'the 8 {{Cb|EOF}} chars is not standard,
 
      {{Cb|PUT}} #GIF, , A$
            {{Cb|IF...THEN|IF}} CurrentBit <> 0 {{Cb|THEN}}
      A$ = {{Cb|CHR$}}(255 - BlockLength)         'correct the last block's count
                PutCode 0 'flush out the last code...
      {{Cb|PUT}} #GIF, LastLoc&, A$
            {{Cb|END IF}}
      {{Cb|CLOSE}} #GIF: {{Cb|EXIT SUB}}         '<<<<<<<<<<< End of procedure   
            PutByte 0
    {{Cb|ELSE}}     'get a pixel from the screen and find the new string in table
 
      {{Cb|GOSUB}} GetByte: Suffix = GB
            OutBuffer$ = {{Cb|LEFT$}}(OutBuffer$, OAddress - OStartAddress)
      {{Cb|GOSUB}} Hash                               'is it in hash table?
            PUT GIFFile, , OutBuffer$
      {{Cb|IF...THEN|IF}} Found = True {{Cb|THEN}} Prefix = Code(Index) 'replace prefix:suffix string with code in table
            A$ = ";" + {{Cb|STRING$}}(8, {{Cb|&H}}1A) 'the 8 {{Cb|EOF}} chars is not standard,
    {{Cb|END IF}}
            'but many GIF's have them, so how
  {{Cb|LOOP}} {{Cb|WHILE}} Found             'don't stop unless we find a new string
            'much could it hurt?
            PUT GIFFile, , A$
 
            A$ = {{Cb|CHR$}}(255 - BlockLength) 'correct the last block's count
            PUT GIFFile, LastLoc&, A$
 
            {{Cb|CLOSE}} GIFFile
            {{Cb|EXIT SUB}}
        {{Cb|ELSE}} 'get a pixel from the screen and see if we can find
            'the new string in the table
            Suffix = GetByte
            {{Cb|GOSUB}} Hash 'is it there?
            {{Cb|IF...THEN|IF}} Found = True {{Cb|THEN}} Prefix = Code(Index) 'yup, replace the
            'prefix:suffix string with whatever
            'code represents it in the table
        {{Cb|END IF}}
    {{Cb|LOOP}} {{Cb|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
  PC = Prefix: {{Cb|GOSUB}} PutCode              'output the prefix to the file
    {{Cb|IF...THEN|IF}} NextCode = MaxCode + 1 {{Cb|THEN}} 'can an output code ever exceed
  Prefix(Index) = Prefix      'put the new string in the table
        'the current code size?
  Suffix(Index) = Suffix
        'yup, increase the code size
  Code(Index) = NextCode      'we've got to keep track of code!


        MaxCode = MaxCode * 2
  Prefix = Suffix 'Prefix = the last pixel pulled from the screen


        'Note: The GIF89a spec mentions something about a deferred clear
  NextCode = NextCode + 1          'get ready for the next code
        'code. When the clear code is deferred, codes are not entered
  {{Cb|IF...THEN|IF}} NextCode = MaxCode + 1 {{Cb|THEN}}  'increase the code size
        'into the hash table anymore. When the compression of the image
    MaxCode = MaxCode * 2
         'starts to fall below a certain threshold, the clear code is
    'Note: The GIF89a spec mentions something about a deferred clear code
        'sent and the hash table is cleared. The overall result is
    {{Cb|IF...THEN|IF}} CodeSize = 12 {{Cb|THEN}}    'is the code size too big?
        'greater compression, because the table is cleared less often.
      PC = ClearCode: {{Cb|GOSUB}} PutCode      'yup; clear the table and
        'This version of MakeGIF doesn't support this, because some GIF
      {{Cb|GOSUB}} ClearTree         'start over
        'decoders crash when they attempt to enter too many codes
      NextCode = StartCode
         'into the string table.
      CodeSize = StartSize
      MaxCode = StartMax
    {{Cb|ELSE}} CodeSize = CodeSize + 1 'increase code size if not too high (not > 12)
    {{Cb|END IF}}
  {{Cb|END IF}}
{{Cb|LOOP}}         'while we have more pixels


        {{Cb|IF...THEN|IF}} CodeSize = 12 {{Cb|THEN}} 'is the code size too big?
'                             '{{Cb|GOSUB}} ROUTINES
            PutCode ClearCode 'yup; clear the table and
            {{Cb|GOSUB}} ClearTree 'start over
            NextCode = StartCode
            CodeSize = StartSize
            MaxCode = StartMax
 
 
        {{Cb|ELSE}}
            CodeSize = CodeSize + 1 'just increase the code size if
        {{Cb|END IF}} 'it's not too high( not > 12)
    {{Cb|END IF}}
 
{{Cb|LOOP}} 'while we have more pixels
ClearTree:
ClearTree:
{{Cb|FOR...NEXT|FOR}} A = 0 {{Cb|TO}} Table__ascii_chr_046__size - 1 'clears the hashing table
{{Cb|FOR...NEXT|FOR}} A = 0 {{Cb|TO}} Table.size - 1 'clears the hashing table
     Prefix(A) = -1 '-1 = invalid entry
     Prefix(A) = -1 '-1 = invalid entry
     Suffix(A) = -1
     Suffix(A) = -1
Line 294: Line 192:
{{Cb|NEXT}}
{{Cb|NEXT}}
{{Cb|RETURN}}
{{Cb|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
Hash:   'hash the prefix & suffix(there are also many ways to do this...)
'cause it's quicker(perhaps the way I implemented the tree wasn't
Index = ((Prefix * 256&) {{Cb|XOR (boolean)|XOR}} Suffix) {{Cb|MOD}} Table.size
'optimal... who knows!)
 
Hash:
'       Note: the table size(7177 in this case) must be a prime number
'hash the prefix & suffix(there are also many ways to do this...)
'   Calculate an offset just in case we don't find what we want first try...
'?? is there a better formula?
{{Cb|IF...THEN|IF}} Index = 0 {{Cb|THEN}}         'cannot have Table.Size 0!
Index = ((Prefix * 256&) {{Cb|XOR (boolean)|XOR}} Suffix) {{Cb|MOD}} Table__ascii_chr_046__size
  Offset = 1
'
'(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...
{{Cb|IF...THEN|IF}} Index = 0 {{Cb|THEN}} 'can't have Table.Size-0 !
    Offset = 1
{{Cb|ELSE}}
{{Cb|ELSE}}
    Offset = Table__ascii_chr_046__size - Index
  Offset = Table.size - Index
{{Cb|END IF}}
{{Cb|END IF}}


{{Cb|DO...LOOP|DO}} 'until we (1) find an empty entry or (2) find what we're lookin for
{{Cb|DO...LOOP|DO}}     'loop until we find an empty entry or find what we're lookin for
  {{Cb|IF...THEN|IF}} Code(Index) = -1 {{Cb|THEN}} 'is this entry blank?
    Found = False ' didn't find the string
    {{Cb|RETURN}}
  {{Cb|ELSEIF}} Prefix(Index) = Prefix {{Cb|AND (boolean)|AND}} Suffix(Index) = Suffix {{Cb|THEN}}       
    Found = True  'found the string
    {{Cb|RETURN}}
  {{Cb|ELSE}} 'didn't find anything, must retry - this slows hashing down.
    Index = Index - Offset
    {{Cb|IF...THEN|IF}} Index < 0 {{Cb|THEN}} 'too far down the table? wrap back the index to end of table
      Index = Index + Table.size
    {{Cb|END IF}}
  {{Cb|END IF}}
{{Cb|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?
{{Cb|IF...THEN|IF}} BlockLength <= 0 {{Cb|THEN}}                  'end of block
  BlockLength = 255                      'block length is now 255
  LastLoc& = {{Cb|LOC}}(GIF) + 1 + (OAddress - OStartAddress)  'remember the position
  BW = 255: {{Cb|GOSUB}} BufferWrite            'for later fixing
{{Cb|END IF}}
BW = PB: {{Cb|GOSUB}} BufferWrite
{{Cb|RETURN}}


    {{Cb|IF...THEN|IF}} Code(Index) = -1 {{Cb|THEN}} 'is this entry blank?
BufferWrite:                            'Puts a byte into the buffer
        Found = False 'yup- we didn't find the string
{{Cb|IF...THEN|IF}} OAddress = OEndAddress {{Cb|THEN}}           'are we at the end of the buffer?
        {{Cb|RETURN}}
    {{Cb|PUT}} #GIF, , OutBuffer$              'write it out and
        'is this entry the one we're looking for?
    OAddress = OStartAddress            'start all over
    {{Cb|ELSEIF}} Prefix(Index) = Prefix {{Cb|AND (boolean)|AND}} Suffix(Index) = Suffix {{Cb|THEN}}
{{Cb|END IF}}
        'yup, congrats you now understand hashing!!!
{{Cb|POKE}} OAddress, BW                        'put byte in buffer
OAddress = OAddress + 1                  'increment position
{{Cb|RETURN}}  


        Found = True
GetByte:                'This routine gets one pixel from the display
        {{Cb|RETURN}}
GB = {{Cb|POINT}}(x, y)                        'get the "byte"
    {{Cb|ELSE}}
x = x + 1 'increment X coordinate
        'shoot! we didn't find anything interesting, so we must
{{Cb|IF...THEN|IF}} x > MaxX {{Cb|THEN}}                         'are we too far?
        'retry- this is what slows hashing down. I could of used
    x = Minx                            'go back to start
        'a bigger table, that would of speeded things up a little
    y = y + 1                           'increment Y coordinate
        'because this retrying would not happen as often...
    {{Cb|IF...THEN|IF}} y > MaxY {{Cb|THEN}} Done = True        'flag if too far down
        Index = Index - Offset
        {{Cb|IF...THEN|IF}} Index < 0 {{Cb|THEN}} 'too far down the table?
            'wrap back the index to the end of the table
            Index = Index + Table__ascii_chr_046__size
        {{Cb|END IF}}
    {{Cb|END IF}}
{{Cb|LOOP}}
{{Cb|END SUB}}
 
'Puts a byte into the GIF file & also takes care of each block.
{{Cb|SUB}} PutByte (A) {{Cb|STATIC}}
BlockLength = BlockLength - 1 'are we at the end of a block?
{{Cb|IF...THEN|IF}} BlockLength <= 0 {{Cb|THEN}} ' yup,
    BlockLength = 255 'block length is now 255
    LastLoc& = {{Cb|LOC}}(1) + 1 + (OAddress - OStartAddress) 'remember the pos.
    BufferWrite 255 'for later fixing
{{Cb|END IF}}
{{Cb|END IF}}
BufferWrite A 'put a byte into the buffer
{{Cb|RETURN}}
{{Cb|END SUB}}


'Puts an LZW variable-bit code into the output file...
PutCode:                'Puts an LZW variable-bit code into the output file...
{{Cb|SUB}} PutCode (A) {{Cb|STATIC}}
Char& = Char& + PC * Shift(CurrentBit)   'put the char were it belongs;
Char& = Char& + A * Shift(CurrentBit) 'put the char were it belongs;
CurrentBit = CurrentBit + CodeSize       'shifting it to its proper place
CurrentBit = CurrentBit + CodeSize ' shifting it to its proper place
{{Cb|DO...LOOP|DO}} {{Cb|WHILE}} CurrentBit > 7                 'do we have a least one full byte?
{{Cb|DO...LOOP|DO}} {{Cb|WHILE}} CurrentBit > 7 'do we have a least one full byte?
  PB = Char& {{Cb|AND}} 255: {{Cb|GOSUB}} PutByte      'mask it off and write it out
    PutByte Char& {{Cb|AND (boolean)|AND}} 255 ' yup! mask it off and write it out
  Char& = Char& \ 256                   'shift the bit buffer right 8 bits
    Char& = Char& \ 256 'shift the bit buffer right 8 bits
  CurrentBit = CurrentBit - 8           'now we have 8 less bits
    CurrentBit = CurrentBit - 8 'now we have 8 less bits
{{Cb|LOOP}}                                     'loop until we don't have a full byte
{{Cb|LOOP}} 'until we don't have a full byte
{{Cb|RETURN}}
{{Cb|END SUB}} '' ''
{{Cb|END SUB}}'' ''
{{TextEnd}}
{{TextEnd}}
''See also:''
* [[_LOADIMAGE]]
* [[Bitmaps]], [[Icons and Cursors]]
{{PageNavigation}}

Latest revision as of 13:10, 10 February 2021

GIF File Creator

The following routine can be used with QBasic or QB64 to create a Graphic Information File image of a program screen.

  • Accommodates _NEWIMAGE screen pages with up to 256 colors and image files loaded with _LOADIMAGE.
  • The maximum screen coordinates are always one pixel LESS than the screen mode's resolution! (SCREEN 13's are 319 and 199)
  • The $INCLUDE text file can be created using Notepad and is REQUIRED when the program is compiled with QB64 ONLY!


'*********************************** DEMO CODE ********************************** 'Save code as a BAS file! Includes the GIFcreate.BI and BM text files. Demo by CodeGuy DEFINT A-Z SCREEN 13 RANDOMIZE TIMER FOR A = 1 TO 40 x = RND * 320 y = RND * 200 c = RND * 256 CIRCLE (x, y), RND * 80, c PAINT (x, y), RND * 256, c NEXT MakeGIF "GIFtemp.gif", 0, 0, _WIDTH - 1, _HEIGHT - 1, 256 'use 319 and 199 in QBasic 'Use the include file in QB64 only! Hard code the SUB in QBasic. '$INCLUDE: 'GIFcreate.BM' '************************************ END DEMO *********************************

GIFcreate.BM text $INCLUDE file:

'----------------------------------------------------------------------------- ' GIFcreate.BM Compression Routine v1.00 By Rich Geldreich 1992 ' Converted into one SUB Library routine by Ted Weissgerber 2011 '----------------------------------------------------------------------------- ' 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) 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 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 B$ = "GIF87a": PUT #GIF, , B$ '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 red$ = CHR$(R): PUT #GIF, , red$ grn$ = CHR$(G): PUT #GIF, , grn$ blu$ = CHR$(B): PUT #GIF, , blu$ NEXT 'write out an image descriptor sep$ = "," 'image separator PUT #GIF, , sep$ 'write it PUT #GIF, , Minx 'image start locations PUT #GIF, , MinY PUT #GIF, , PWidth% 'store them into the file PUT #GIF, , PDepth% A$ = CHR$(BitsPixel - 1) '# bits per pixel in the image PUT #GIF, , A$ A$ = CHR$(StartSize - 1) 'store the LZW minimum code size PUT #GIF, , A$ 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$ A$ = ";" + STRING$(8, &H1A) 'the 8 EOF chars is not standard, PUT #GIF, , A$ A$ = CHR$(255 - BlockLength) 'correct the last block's count PUT #GIF, LastLoc&, A$ 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


See also:



Navigation:
Keyword Reference - Alphabetical
Keyword Reference - By Usage
Main Wiki Page