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: …')
 
imported>Clippy
m
Line 1: Line 1:
<center>'''GIF File Creator'''</center>
<center>'''GIF File Creator'''</center>


{{CodeStart}} ' **************** DEMO CODE ********************
{{CodeStart}} '*********************************** DEMO CODE **********************************
'{{Cl|$INCLUDE}} 'MakeGIF.bi'
'Save as a BAS file! Includes the MakeGIF.BI and BM files. Demo by CodeGuy
'-------------- Only for testing purposes:
 
'{{Cl|$INCLUDE}}: 'GIFcreate.BI'
 
{{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 15:
     {{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
MakeGIF "GIFtemp.gif", 0, 0, 319, 199, 256
gif& = {{Cl|_LOADIMAGE}}("temp.gif")


'{{Cl|$INCLUDE}}: 'MakeGIF.bm'
'{{Cl|$INCLUDE}}: 'GIFcreate.BM'


'-------------- end of DEMO code
'************************************ END DEMO *********************************
{{CodeEnd}}
{{CodeEnd}}
<center>''MakeGIF.BI text [[$INCLUDE]] file:''</center>
<center>''GIFcreate.BI text [[$INCLUDE]] file:''</center>
{{TextStart}}
{{TextStart}}
' *************************** MakeGif.bi ********************
' *************************** GIFcreate.bi ********************
'* original code by Rich Geldreich
'* original code by Rich Geldreich creates a GIF87a-compliant GIF from a screen image
'* 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
'* will create GIF only for up to 256 color (8-bit) graphics
{{Cb|DEFINT}} A-Z
{{Cb|DEFINT}} A-Z
{{Cb|CONST}} True = -1, False = 0
{{Cb|CONST}} True = -1, False = 0
Line 35: Line 34:
{{Cb|DIM}} {{Cb|SHARED}} CodeSize, CurrentBit, Char&, BlockLength
{{Cb|DIM}} {{Cb|SHARED}} CodeSize, CurrentBit, Char&, BlockLength
{{Cb|DIM}} {{Cb|SHARED}} Shift(7) {{Cb|AS}} {{Cb|LONG}}
{{Cb|DIM}} {{Cb|SHARED}} Shift(7) {{Cb|AS}} {{Cb|LONG}}
{{Cb|DIM}} {{Cb|SHARED}} x, y, Minx, MinY, MaxX, MaxY, Done, GIFFile, LastLoc&
{{Cb|DIM}} {{Cb|SHARED}} x, y, Minx, MinY, MaxX, MaxY, Done, GIF, LastLoc& '' ''
 
ShiftTable:
{{Cb|DATA}} 1,2,4,8,16,32,64,128 '' ''
{{TextEnd}}
{{TextEnd}}


<center>''MakeGIF.BM text [[$INCLUDE]] file:''</center>
<center>''GIFcreate.BM text [[$INCLUDE]] file:''</center>
{{TextStart}} ' ********************* MakeGIF.BM *********************
{{TextStart}} '-----------------------------------------------------------------------------
'Puts a byte into the disk buffer... when the disk buffer is full it is
'       GIFcreate.BM Compression Routine v1.00 By Rich Geldreich 1992
'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}}
 
'
'-----------------------------------------------------------------------------
'   PDS 7.1 & QB4.5 GIF Compression Routine v1.00 By Rich Geldreich 1992
'-----------------------------------------------------------------------------
'-----------------------------------------------------------------------------
'
'             for 1 BPP, 4 BPP or 8 BPP images only
'A$         = output filename
'file$       = save image output filename
'ScreenX    = X resolution of screen(320, 640, etc.)
'XStart      = <-upper left hand corner area to encode
'ScreenY    = Y resolution of screen(200, 350, 480, etc.)
'YStart      = <-"
'XStart      = <-upper left hand corner of area to encode
'YStart      = < "                                      "
'Xend        = <-lower right hand corner of area to encode
'Xend        = <-lower right hand corner of area to encode
'Yend        = < "                                      "
'Yend        = <-"                                      "
'NumColors  = # of colors on screen(2, 16, 256)
'NumColors  = # of colors on screen(2(B&W), 16({{Cb|SCREEN (statement)|SCREEN}} 12), 256({{Cb|SCREEN (statement)|SCREEN}}13)
'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}} 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__ascii_chr_046__size - 1), Suffix(Table__ascii_chr_046__size - 1), Code(Table__ascii_chr_046__size - 1)
{{Cb|DIM}} Prefix(Table__ascii_chr_046__size - 1), Suffix(Table__ascii_chr_046__size - 1), Code(Table__ascii_chr_046__size - 1)


'The shift table contains the powers of 2 needed by the
{{Cb|FOR...NEXT|FOR}} i = 0 {{Cb|TO}} 7: Shift(i) = 2 ^ i: {{Cb|NEXT}} 'create exponent array for speed.
'PutCode routine. This is done for speed. (much faster to
'look up an integer than to perform calculations...)
{{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
PWidth% = {{Cb|ABS}}(Xend - Xstart) + 1
Minx = Xstart: MinY = YStart
PDepth% = {{Cb|ABS}}(Yend - Ystart) + 1
MaxX = Xend: MaxY = Yend
'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


'Open GIF output file
'Open GIF output file
GIFFile = {{Cb|FREEFILE}} 'use next free file
GIF = {{Cb|FREEFILE}} 'use next free file
{{Cb|OPEN}} A$ {{Cb|FOR...NEXT|FOR}} {{Cb|BINARY}} {{Cb|AS}} GIFFile
{{Cb|OPEN}} file$ {{Cb|FOR...NEXT|FOR}} {{Cb|BINARY}} {{Cb|AS}} #GIF
 
B$ = "GIF87a": {{Cb|PUT}} #GIF, , B$  'Put GIF87a header at beginning of file


'Put GIF87a header at beginning of file
{{Cb|SELECT CASE}} NumColors      'get color settings
B$ = "GIF87a"
  {{Cb|CASE}} 2            'monochrome (B&W) image
PUT GIFFile, , B$
    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}}


'See how many colors are in this image...
ColorBits = 6      'VGA monitors ONLY
{{Cb|SELECT CASE}} NumColors
    {{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
{{Cb|PUT}} #GIF, , PWidth% 'put screen's dimensions
        BitsPixel = 4 '4 bits per pixel
{{Cb|PUT}} #GIF, , PDepth%
        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
CP = 128 + (ColorBits - 1) * 16 + (BitsPixel - 1) 'pack colorbits and bits per pixel
        BitsPixel = 8 '8 bits per pixel
{{Cb|PUT}} #GIF, , CP
        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
Zero$ = {{Cb|CHR$}}(0)     'PUT a zero into the GIF file
PUT GIFFile, , ScreenY
{{Cb|PUT}} #GIF, , Zero$
'pack colorbits and bits per pixel
A = 128 + (ColorBits - 1) * 16 + (BitsPixel - 1)
PUT GIFFile, , A
'throw a zero into the GIF file
A$ = {{Cb|CHR$}}(0)
PUT GIFFile, , A$
'Get the RGB palette from the screen and put it into the file...
{{Cb|SELECT CASE}} AdaptorType
    {{Cb|CASE}} 1
        {{Cb|STOP}}
        'EGA palette routine not implemented yet
    {{Cb|CASE}} 2
        {{Cb|OUT}} {{Cb|&H}}3C7, 0
        {{Cb|FOR...NEXT|FOR}} A = 0 {{Cb|TO}} NumColors - 1
            '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...
{{Cb|OUT}} {{Cb|&H}}3C7, 0                'start read at color 0
A$ = "," '"," is image seperator
{{Cb|FOR...NEXT|FOR}} c = 0 {{Cb|TO}} NumColors - 1  'Get the RGB palette from the screen and put into file
PUT GIFFile, , A$ 'write it
  R = ({{Cb|INP}}({{Cb|&H}}3C9) * 65280) \ 16128 'C = R * 4.0476190(for 0-255)
PUT GIFFile, , Minx 'write out the image's location
  G = ({{Cb|INP}}({{Cb|&H}}3C9) * 65280) \ 16128
PUT GIFFile, , MinY
  B = ({{Cb|INP}}({{Cb|&H}}3C9) * 65280) \ 16128
ImageWidth = (MaxX - Minx + 1) 'find length & width of image
  red$ = {{Cb|CHR$}}(R): {{Cb|PUT}} #GIF, , red$
ImageHeight = (MaxY - MinY + 1)
  grn$ = {{Cb|CHR$}}(G): {{Cb|PUT}} #GIF, , grn$
PUT GIFFile, , ImageWidth 'store them into the file
  blu$ = {{Cb|CHR$}}(B): {{Cb|PUT}} #GIF, , blu$
PUT GIFFile, , ImageHeight
{{Cb|NEXT}}
        'write out an image descriptor
sep$ = ","               'image separator
{{Cb|PUT}} #GIF, , sep$         'write it
{{Cb|PUT}} #GIF, , Minx         'image start locations
{{Cb|PUT}} #GIF, , MinY
{{Cb|PUT}} #GIF, , PWidth%      'store them into the file
{{Cb|PUT}} #GIF, , PDepth%
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
PutCode ClearCode         '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
Prefix = GetByte           '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
      PutCode Prefix      'write last pixel
      PutCode {{Cb|EOF}}Code     '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}} PutCode 0    'flush out the last code...
            'and fix up the last block so its count is correct
      PutByte 0
 
      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$
      A$ = {{Cb|CHR$}}(255 - BlockLength)        'correct the last block's count
      {{Cb|PUT}} #GIF, LastLoc&, A$
      {{Cb|CLOSE}} #GIF: {{Cb|EXIT SUB}}
    {{Cb|ELSE}}    'get a pixel from the screen and find the new string in table
      Suffix = GetByte
      {{Cb|GOSUB}} Hash                                'is it in hash table?
      {{Cb|IF...THEN|IF}} Found = True {{Cb|THEN}} Prefix = Code(Index) 'replace prefix:suffix string with code in table
    {{Cb|END IF}}
  {{Cb|LOOP}} {{Cb|WHILE}} Found            'don't stop unless we find a new string


            {{Cb|IF...THEN|IF}} CurrentBit <> 0 {{Cb|THEN}}
  PutCode Prefix              'output the prefix to the file
                PutCode 0 'flush out the last code...
  Prefix(Index) = Prefix      'put the new string in the table
            {{Cb|END IF}}
  Suffix(Index) = Suffix
            PutByte 0
  Code(Index) = NextCode      'we've got to keep track of code!


            OutBuffer$ = {{Cb|LEFT$}}(OutBuffer$, OAddress - OStartAddress)
  Prefix = Suffix 'Prefix = the last pixel pulled from the screen
            PUT GIFFile, , OutBuffer$
            A$ = ";" + {{Cb|STRING$}}(8, {{Cb|&H}}1A) 'the 8 {{Cb|EOF}} chars is not standard,
            'but many GIF's have them, so how
            'much could it hurt?
            PUT GIFFile, , A$


            A$ = {{Cb|CHR$}}(255 - BlockLength) 'correct the last block's count
  NextCode = NextCode + 1         'get ready for the next code
            PUT GIFFile, LastLoc&, A$
  {{Cb|IF...THEN|IF}} NextCode = MaxCode + 1 {{Cb|THEN}}   'increase the code size
 
    MaxCode = MaxCode * 2
            {{Cb|CLOSE}} GIFFile
    'Note: The GIF89a spec mentions something about a deferred clear code
            {{Cb|EXIT SUB}}
    {{Cb|IF...THEN|IF}} CodeSize = 12 {{Cb|THEN}}     'is the code size too big?
        {{Cb|ELSE}} 'get a pixel from the screen and see if we can find
      PutCode ClearCode       'yup; clear the table and
            'the new string in the table
      {{Cb|GOSUB}} ClearTree         'start over
            Suffix = GetByte
      NextCode = StartCode
            {{Cb|GOSUB}} Hash 'is it there?
      CodeSize = StartSize
            {{Cb|IF...THEN|IF}} Found = True {{Cb|THEN}} Prefix = Code(Index) 'yup, replace the
      MaxCode = StartMax
            'prefix:suffix string with whatever
    {{Cb|ELSE}} CodeSize = CodeSize + 1 'increase code size if not too high (not > 12)
            'code represents it in the table
     {{Cb|END IF}}  
        {{Cb|END IF}}
  {{Cb|END IF}}
    {{Cb|LOOP}} {{Cb|WHILE}} Found 'don't stop unless we find a new string
{{Cb|LOOP}}         'while we have more pixels
 
'                                  '{{Cb|GOSUB}} ROUTINES
    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
    {{Cb|IF...THEN|IF}} NextCode = MaxCode + 1 {{Cb|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.
 
        {{Cb|IF...THEN|IF}} CodeSize = 12 {{Cb|THEN}} 'is the code size too big?
            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__ascii_chr_046__size - 1 'clears the hashing table
Line 294: Line 198:
{{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
'optimal... who knows!)
Hash:
'hash the prefix & suffix(there are also many ways to do this...)
'?? is there a better formula?
Index = ((Prefix * 256&) {{Cb|XOR (boolean)|XOR}} Suffix) {{Cb|MOD}} Table__ascii_chr_046__size
Index = ((Prefix * 256&) {{Cb|XOR (boolean)|XOR}} Suffix) {{Cb|MOD}} Table__ascii_chr_046__size
'
'
'(Note: the table size(7177 in this case) must be a prime number, or
'(Note: the table size(7177 in this case) must be a prime number
'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
'Calculate an offset just in case we don't find what we want first try...
'first try...
{{Cb|IF...THEN|IF}} Index = 0 {{Cb|THEN}}         'cannot have Table.Size 0!
{{Cb|IF...THEN|IF}} Index = 0 {{Cb|THEN}} 'can't have Table.Size-0 !
  Offset = 1
    Offset = 1
{{Cb|ELSE}}
{{Cb|ELSE}}
    Offset = Table__ascii_chr_046__size - Index
  Offset = Table__ascii_chr_046__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|IF...THEN|IF}} Code(Index) = -1 {{Cb|THEN}} 'is this entry blank?
    {{Cb|RETURN}}
        Found = False 'yup- we didn't find the string
  {{Cb|ELSEIF}} Prefix(Index) = Prefix {{Cb|AND (boolean)|AND}} Suffix(Index) = Suffix {{Cb|THEN}}      
        {{Cb|RETURN}}
    Found = True 'found the string
        'is this entry the one we're looking for?
    {{Cb|RETURN}}
    {{Cb|ELSEIF}} Prefix(Index) = Prefix {{Cb|AND (boolean)|AND}} Suffix(Index) = Suffix {{Cb|THEN}}
  {{Cb|ELSE}} 'didn't find anything, must retry - this slows hashing down.
        'yup, congrats you now understand hashing!!!
    Index = Index - Offset
 
    {{Cb|IF...THEN|IF}} Index < 0 {{Cb|THEN}} 'too far down the table? wrap back the index to end of table
        Found = True
      Index = Index + Table__ascii_chr_046__size
        {{Cb|RETURN}}
    {{Cb|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
        {{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|END IF}}
  {{Cb|END IF}}
{{Cb|LOOP}}
{{Cb|LOOP}}
{{Cb|END SUB}}
{{Cb|END SUB}}


'Puts a byte into the GIF file & also takes care of each block.
{{Cb|SUB}} PutByte (A) {{Cb|STATIC}} '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?
BlockLength = BlockLength - 1 'are we at the end of a block?
{{Cb|IF...THEN|IF}} BlockLength <= 0 {{Cb|THEN}} ' yup,
{{Cb|IF...THEN|IF}} BlockLength <= 0 {{Cb|THEN}}     'end of block
    BlockLength = 255 'block length is now 255
  BlockLength = 255         'block length is now 255
    LastLoc& = {{Cb|LOC}}(1) + 1 + (OAddress - OStartAddress) 'remember the pos.
  LastLoc& = {{Cb|LOC}}(1) + 1 + (OAddress - OStartAddress) 'remember the position
    BufferWrite 255 'for later fixing
  BufferWrite 255           'for later fixing
{{Cb|END IF}}
{{Cb|END IF}}
BufferWrite A 'put a byte into the buffer
BufferWrite A               'put a byte into the buffer
{{Cb|END SUB}}
{{Cb|END SUB}}


'Puts an LZW variable-bit code into the output file...
{{Cb|SUB}} PutCode (A) {{Cb|STATIC}} 'Puts an LZW variable-bit code into the output file...
{{Cb|SUB}} PutCode (A) {{Cb|STATIC}}
Char& = Char& + A * 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?
    PutByte Char& {{Cb|AND (boolean)|AND}} 255 ' yup! 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}} 'until we don't have a full byte
{{Cb|LOOP}}                         'loop until we don't have a full byte
{{Cb|END SUB}} '' ''
{{Cb|END SUB}}
 
'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?
    {{Cb|PUT}} #GIF, , 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}}
 
 
{{Cb|FUNCTION}} GetByte {{Cb|STATIC}}      'This routine gets one pixel from the display
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?
    x = Minx  'go back to start
    y = y + 1 'increment Y coordinate
    {{Cb|IF...THEN|IF}} y > MaxY {{Cb|THEN}} Done = True        ' flag if too far down
{{Cb|END IF}}
{{Cb|END FUNCTION}}'' ''
{{TextEnd}}
{{TextEnd}}

Revision as of 17:49, 20 February 2011

GIF File Creator

'*********************************** DEMO CODE ********************************** 'Save as a BAS file! Includes the MakeGIF.BI and BM files. Demo by CodeGuy '$INCLUDE: 'GIFcreate.BI' 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, 319, 199, 256 '$INCLUDE: 'GIFcreate.BM' '************************************ END DEMO *********************************

GIFcreate.BI text $INCLUDE file:

' *************************** GIFcreate.bi ******************** '* original code by Rich Geldreich creates a GIF87a-compliant GIF from a screen image '* will create GIF only for up to 256 color (8-bit) graphics DEFINT A-Z CONST True = -1, False = 0 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, GIF, LastLoc&

GIFcreate.BM text $INCLUDE file:

'----------------------------------------------------------------------------- ' GIFcreate.BM Compression Routine v1.00 By Rich Geldreich 1992 '----------------------------------------------------------------------------- ' for 1 BPP, 4 BPP or 8 BPP images only 'file$ = save image output filename 'XStart = <-upper left hand corner area to encode 'YStart = <-" 'Xend = <-lower right hand corner of area to encode 'Yend = <-" " 'NumColors = # of colors on screen(2(B&W), 16(SCREEN 12), 256(SCREEN13) ' SUB MakeGIF (file$, Xstart, YStart, Xend, Yend, NumColors) CONST Table.Size = 7177 'hash table's size - must be a prime number! DIM Prefix(Table__ascii_chr_046__size - 1), Suffix(Table__ascii_chr_046__size - 1), Code(Table__ascii_chr_046__size - 1) 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 = 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 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... PutByte 0 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 ELSE 'get a pixel from the screen and find the new string in table Suffix = GetByte 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 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 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? PutCode ClearCode '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__ascii_chr_046__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__ascii_chr_046__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__ascii_chr_046__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__ascii_chr_046__size END IF END IF LOOP END SUB SUB PutByte (A) STATIC '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(1) + 1 + (OAddress - OStartAddress) 'remember the position BufferWrite 255 'for later fixing END IF BufferWrite A 'put a byte into the buffer END SUB SUB PutCode (A) STATIC 'Puts an LZW variable-bit code into the output file... 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 'loop until we don't have a full byte END SUB '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 #GIF, , 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 FUNCTION GetByte STATIC 'This routine gets one pixel from the display GetByte = 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 END FUNCTION