PureBasic

Code : Tout sélectionner

;- Structures

Structure GIFHEADER ;Header
  ghSig.b[6] ;Signature & Version
  ghWidth.w ;Logical Screen Width
  ghHeight.w ;Logical Screen Height
  ghPkFields.b ;Global Color Table Flag
  ghBkColIndex.b ;Background Color Index
  ghAspRatio.b ;Pixel Aspect Ratio
EndStructure

Structure GIFIMAGE ;Image Descriptor
  imSep.b ;Image Separator
  imLeft.w ;Image Left Position
  imTop.w ;Image Top Position
  imWidth.w ;Image Width
  imHeight.w ;Image Height
  imPkFields.b ;Local Color Table Flag
EndStructure

Structure GIFCLASS ;This is instead of using globals
  *lpBytes.BYTE ;Pointer to next byte in block
  Pass.l ;First pass for interlaced images in OutLineGIF()
  Line.l ;Offset for addressing the bits in OutLineGIF()
  lpBits.l ;Scanline for bits
  Pitch.l ;Bytes are rounded up for image lines
  CurrCodeSize.l ;The current code size
  BitsLeft.l ;Used in NextCodeGIF()
  BytesLeft.l ;Used in NextCodeGIF()
  CurrByte.l ;Current byte
  bUseGlobalColMap.b ;Is the color table global
  GlobColRes.l ;Color Resolution, bits '6' '5' '4'
  bImInterLace.b ;Is the image interlaced
  ImgColRes.l ;Color Resolution
EndStructure

Procedure OutLineGIF(lpPixels.l,LineLen.l,Height.l,*cl.GIFCLASS)
  ;Outputs the pixel color index data to the DIB
  ;lpPixels -> Memory block that holds the color index value
  ;LineLen -> Length of the line of pixels
  ;Height -> im\imHeight
  ;Gif images are 2, 16 or 256 colors, poking the values into memory
  ;requires a different method for each case. If gif is interlaced,
  ;that is dealt with here.
  
  Protected iB.l,Pixel.l,Byte.l,BitCnt.l,CntBk.l,ColRes.l,Bits.l
  
  Bits=*cl\lpBits-(*cl\Line * *cl\Pitch) ;Pointer to bits
  
  If *cl\bUseGlobalColMap
    ColRes=*cl\GlobColRes
  Else
    ColRes=*cl\ImgColRes
  EndIf
  
  Select ColRes
      
    Case 1
      Byte=0
      For Pixel=0 To LineLen-1 Step 8
        iB=0
        CntBk=7
        For BitCnt=0 To 8-1
          If PeekB(lpPixels+BitCnt+Pixel)
            iB=iB | (1 << CntBk)
          EndIf
          CntBk-1
        Next
        PokeB(Bits+Byte,iB)
        Byte+1
      Next
      
    Case 4
      Byte=0
      For Pixel=0 To LineLen-1 Step 2
        iB=((PeekB(lpPixels+Pixel) & 255) << 4)
        iB | (PeekB(lpPixels+Pixel+1) & 255)
        PokeB(Bits+Byte,iB)
        Byte+1
      Next
      
    Case 8
      For Pixel=0 To LineLen-1
        iB=PeekB(lpPixels+Pixel) & 255
        PokeB(Bits+Pixel,iB)
      Next
      
  EndSelect
  
  If *cl\bImInterLace ;Set Line for different passes when Interlaced
    
    Select *cl\Pass
        
      Case 0 ;Pass 1
        If *cl\Line<Height-8
          *cl\Line+8
        Else
          *cl\Line=4 : *cl\Pass+1 ;Set Line for second pass
        EndIf
        
      Case 1 ;Pass 2
        If *cl\Line<Height-8
          *cl\Line+8
        Else
          *cl\Line=2 : *cl\Pass+1 ;Set Line for third pass
        EndIf
        
      Case 2 ;Pass 3
        If *cl\Line<Height-4
          *cl\Line+4
        Else
          *cl\Line=1 : *cl\Pass+1 ;Set Line for fourth pass
        EndIf
        
      Case 3 ;Pass 4
        If *cl\Line<Height-2
          *cl\Line+2
        EndIf
        
    EndSelect
    
  Else ;When not Interlaced increment Line
    
    *cl\Line+1
    
  EndIf
  
EndProcedure

Procedure.l NextCodeGIF(file.l, Array CharBuff.b(1), Array CodeMask.l(1),*cl.GIFCLASS)
  ;Reads the next code from the data stream
  ;Returns the LZW CODE or ERROR
  
  Protected count.l,char.l,ret.l
  
  If *cl\BitsLeft=0 ;Any bits left in byte?
    
    If *cl\BytesLeft<=0 ;If not get another block
      
      *cl\lpBytes=@CharBuff(0) ;Set byte pointer
      *cl\BytesLeft=ReadByte(file) & 255
      
      If *cl\BytesLeft<0
        ProcedureReturn *cl\BytesLeft ;Return if error
      ElseIf *cl\BytesLeft
        For count=0 To *cl\BytesLeft-1
          char=ReadByte(file) & 255
          If char<0 : ProcedureReturn char : EndIf
          CharBuff(count)=char ;Fill the char buffer with the new block
        Next
      EndIf
      
    EndIf
    
    *cl\CurrByte=*cl\lpBytes\b & 255 ;Get a byte
    *cl\lpBytes+1 ;Increment index pointer
    *cl\BitsLeft=8 ;Set bits left in the byte
    *cl\BytesLeft-1 ;Decrement the bytes left counter
    
  EndIf
  
  ;Shift off any previously used bits
  ret=*cl\CurrByte >> (8-*cl\BitsLeft)
  
  While *cl\CurrCodeSize>*cl\BitsLeft
    
    If *cl\BytesLeft<=0
      
      ;Out of bytes in current block
      *cl\lpBytes=@CharBuff(0) ;Set byte pointer
      *cl\BytesLeft=ReadByte(file) & 255
      
      If *cl\BytesLeft<0
        ProcedureReturn *cl\BytesLeft ;Return if error
      ElseIf *cl\BytesLeft
        For count=0 To *cl\BytesLeft-1
          char=ReadByte(file) & 255
          If char<0 : ProcedureReturn char : EndIf
          CharBuff(count)=char ;Fill the char buffer with the current block
        Next
      EndIf
      
    EndIf
    
    *cl\CurrByte=*cl\lpBytes\b & 255 ;Get a byte
    *cl\lpBytes+1 ;Increment index pointer
    ret | (*cl\CurrByte << *cl\BitsLeft) ;Add remaining bits to return
    *cl\BitsLeft+8 ;Set bit counter
    *cl\BytesLeft-1 ;Decrement bytesleft counter
    
  Wend
  
  *cl\BitsLeft-*cl\CurrCodeSize ;Subtract the code size from bitsleft
  ret & CodeMask(*cl\CurrCodeSize) ;Mask off the right number of bits
  ProcedureReturn ret
  
EndProcedure

Procedure.l LoadGIF(filename.s)
  ;From "loadgif.c" for ImageShop32 by John Findlay
  ;Loads LZW Graphics Interchange Format files
  ;Uses NextCodeGIF() and OutLineGIF()
  
  Protected Dim Stack.b(4096) ;Stack for storing pixels
  Protected Dim Suffix.b(4096) ;Suffix table, max number of LZW codes
  Protected Dim Prefix.l(4096) ;Prefix linked list (these are longs)
  Protected Dim CharBuff.b(279) ;Current block
  Protected Dim GlobalCols.l(256) ;Global colors of gif
  Protected Dim LocalCols.l(256) ;Local image colors of gif
  Protected Dim CodeMask.l(16) ;Masks for LZW compression algorithm
  Protected gh.GIFHEADER
  Protected im.GIFIMAGE
  Protected cl.GIFCLASS
  Protected bi.BITMAPINFOHEADER
  Protected *pal.RGBQUAD
  Protected *lpSP.Byte ;Pointer to stack
  Protected *lpBuffPtr.Byte ;Pointer to buffer
  Protected bGlobColsSorted.b ;Sort Flag  bit '3' (this is unused)
  Protected file.l,sig.s,PkFields.l,bGlobColTable.b,GlobColBytes.l
  Protected GlobColors.l,count.l,red.l,green.l,blue.l
  Protected width.l,Height.l,imPkFields.l,bImColsSorted.b
  Protected bImColTable.b,ImgColBytes.l,LZWCodeSize.l,TopSlot.l
  Protected ClearCode.l,ImgColors.l,EndingCode.l,NewCodes.l,Slot.l
  Protected lpBUFF.l,TempOldCode.l,OldCode.l,BufCnt.l,BitCount.l
  Protected ncolors.l,len.l,hDIB.l,cc.l,Code.l
  
  CodeMask( 0)=$0000 : CodeMask( 1)=$0001
  CodeMask( 2)=$0003 : CodeMask( 3)=$0007
  CodeMask( 4)=$000F : CodeMask( 5)=$001F
  CodeMask( 6)=$003F : CodeMask( 7)=$007F
  CodeMask( 8)=$00FF : CodeMask( 9)=$01FF
  CodeMask(10)=$03FF : CodeMask(11)=$07FF
  CodeMask(12)=$0FFF : CodeMask(13)=$1FFF
  CodeMask(14)=$3FFF : CodeMask(15)=$7FFF
  
  ;Open the file
  file=ReadFile(#PB_Any,filename)
  If file=0
    MessageRequester("LOAD ERROR","File could not be opened")
    ProcedureReturn #False
  EndIf
  
  ;Read the file header and logical screen descriptor
  ReadData(file,gh,SizeOf(gh))
  
  sig=PeekS(@gh\ghSig,6) ;Get the header version string
  If sig<>"GIF89a" And sig<>"GIF87a"
    CloseFile(file)
    MessageRequester("LOAD ERROR","Not a valid gif file")
    ProcedureReturn #False ;NOT_VALID
  EndIf
  
  ;Store gh\ghPkFields for bit manipulation
  PkFields=gh\ghPkFields & 255
  
  ;Global Color Table Flag bit '7'
  bGlobColTable=(PkFields & (1 << 7)) >> 7
  
  If bGlobColTable
    cl\bUseGlobalColMap=#True
    
    GlobColBytes=3*(1 << ((PkFields & $07)+1)) ;Table size in bytes
    GlobColors=GlobColBytes/3 ;Number of colors
    
    ;Some gif encoders do not follow the gif spec very well,
    ;so make cl\GlobColRes from GlobColors.
    ;Also gif's are used on different platforms, which do
    ;have different bits per pixel. i.e. 32 colors is 5 bits/pixel.
    If GlobColors<=2
      cl\GlobColRes=1
    ElseIf GlobColors<=16
      cl\GlobColRes=4
    Else
      cl\GlobColRes=8
    EndIf
    
    For count=0 To GlobColors-1 ;Get the global screen colors
      red=ReadByte(file) & 255
      green=ReadByte(file) & 255
      blue=ReadByte(file) & 255
      GlobalCols(count)=RGB(red,green,blue)
    Next
  EndIf
  
  count=0
  While count<>$2C ;Search for im\imSep
    count=ReadByte(file) & 255
    If count = $F9 
      ReadByte(file) 
      transparent = ReadByte(file) & 1 
      ReadWord(file) 
      transcolor = GlobalCols(ReadByte(file)) 
    EndIf
    
  Wend
  FileSeek(file,Loc(file)-1) ;Seek to im\imSep
  
  ReadData(file,im,SizeOf(im)) ;Read the image descriptor
  
  ;Store im\imPkFields for bit manipulation
  imPkFields=im\imPkFields & 255
  
  ;Is the image interlaced
  cl\bImInterLace=(imPkFields & (1 << 6)) >> 6
  
  ;Is the local color table sorted
  bImColsSorted=(imPkFields & (1 << 5)) >> 5
  
  ;Is there a local color table
  bImColTable=(imPkFields & (1 << 7)) >> 7
  
  If bImColTable
    cl\bUseGlobalColMap=#False
    
    ImgColBytes=3*(1 << ((imPkFields & $07)+1)) ;Table size in bytes
    ImgColors=ImgColBytes/3 ;Number of colors
    
    If ImgColors<=2 ;Make sure image bit depth is 1, 4 or 8
      cl\ImgColRes=1
    ElseIf ImgColors<=16
      cl\ImgColRes=4
    Else
      cl\ImgColRes=8
    EndIf
    
    For count=0 To ImgColors-1 ;Get the local image colors
      red=ReadByte(file) & 255
      green=ReadByte(file) & 255
      blue=ReadByte(file) & 255
      LocalCols(count)=RGB(red,green,blue)
    Next
  Else ;No local color table
    If cl\bUseGlobalColMap=#False ;No global color table
      CloseFile(file)
      MessageRequester("LOAD ERROR","No color table")
      ProcedureReturn #False ;NO_COLORTABLE
    EndIf
  EndIf
  
  width=im\imWidth & $FFFF ;Image width
  Height=im\imHeight & $FFFF ;Image height
  
  ;Get the first byte of the new block of image data.
  ;Should be the bit size
  LZWCodeSize=ReadByte(file) & 255
  
  ;Bit size is normally the same as the color resolution.
  ;i.e. 8 for 256 colors
  If LZWCodeSize<2 Or LZWCodeSize>8
    CloseFile(file)
    MessageRequester("LOAD ERROR","LZW code size is not valid")
    ProcedureReturn #False ;BAD_CODE_SIZE
  EndIf
  
  ;Initialise the variables for the decoder for reading a new image.
  cl\CurrCodeSize=LZWCodeSize+1
  TopSlot=1 << cl\CurrCodeSize ;Highest code for current size
  ClearCode=1 << LZWCodeSize ;Value for a clear code
  EndingCode=ClearCode+1 ;Value for an ending code
  NewCodes=ClearCode+2 ;First available code
  Slot=NewCodes ;Last read code
  cl\BitsLeft=0
  cl\BytesLeft=0
  
  ;Just in case...
  TempOldCode=0 : OldCode=0
  
  ;Allocate space for the decode buffer
  lpBUFF=AllocateMemory(width+8) ;+8 just in case
  
  ;Set up the stack pointer, decode buffer pointer and line counter
  *lpSP=@Stack(0)
  *lpBuffPtr=lpBUFF
  BufCnt=width ;Count for pixel line length
  
  ;Start creating the DIB
  If cl\bUseGlobalColMap ;Global color table
    BitCount=cl\GlobColRes
  Else ;Local color table
    BitCount=cl\ImgColRes
  EndIf
  
  bi\biSize=SizeOf(bi)
  bi\biWidth=width
  bi\biHeight=Height
  bi\biPlanes=1
  bi\biBitCount=BitCount ;BitCount will be 1, 4 or 8
  bi\biCompression=#BI_RGB
  bi\biSizeImage=0
  bi\biXPelsPerMeter=0
  bi\biYPelsPerMeter=0
  If cl\bUseGlobalColMap ;Global color table
    bi\biClrUsed=GlobColors
  Else ;Local color table
    bi\biClrUsed=ImgColors
  EndIf
  bi\biClrImportant=0
  
  ;With the BITMAPINFO format headers, the size of the palette is
  ;in biClrUsed, whereas in the BITMAPCORE - style headers, it is
  ;dependent on the Bits per pixel (2 to the power of bitsperpixel).
  If bi\biClrUsed<>0
    ncolors=bi\biClrUsed
  Else ;We don't have an optimal palette
    ncolors=1 << bi\biBitCount
  EndIf
  
  cl\Pitch=(((BitCount*width)+31) >> 5) << 2 ;Bytes per line
  len=bi\biSize+(ncolors*4)+(cl\Pitch*Height) ;Size of DIB
  
  bi\biSizeImage=cl\Pitch*Height ;Fill in biSizeImage
  
  ;Allocate memory block to store our DIB
  hDIB=AllocateMemory(len)
  If hDIB=0
    FreeMemory(lpBUFF)
    CloseFile(file)
    MessageRequester("LOAD ERROR","Memory allocation failed")
    ProcedureReturn #False ;NO_DIB
  EndIf
  
  ;Fill first part of DIB with the BITMAPINFOHEADER
  CopyMemory(bi,hDIB,SizeOf(bi))
  
  ;Set the colors in the DIB (or masks for the new DIB formats)
  *pal=hDIB+SizeOf(bi)
  If cl\bUseGlobalColMap
    For count=0 To bi\biClrUsed-1
      *pal\rgbBlue=Blue(GlobalCols(count))
      *pal\rgbGreen=Green(GlobalCols(count))
      *pal\rgbRed=Red(GlobalCols(count))
      *pal+4
    Next
  Else
    For count=0 To bi\biClrUsed-1
      *pal\rgbBlue=Blue(LocalCols(count))
      *pal\rgbGreen=Green(LocalCols(count))
      *pal\rgbRed=Red(LocalCols(count))
      *pal+4
    Next
  EndIf
  
  cl\Line=0 ;Set address offset for OutLineGIF()
  cl\Pass=0 ;For interlaced images in OutLineGIF()
  
  ;Image data bits of DIB
  cl\lpBits=hDIB+bi\biSize+(ncolors*4)+(cl\Pitch*(Height-1))
  
  ;This is the main loop. For each code we get we pass through the
  ;linked list of prefix codes, pushing the corresponding "character"
  ;for each code onto the stack. When the list reaches a single
  ;"character" we push that on the stack too, and then start
  ;unstacking each character for output in the correct order.
  ;Special handling is included for the clear code, and the whole
  ;thing ends when we get an ending code.
  While cc<>EndingCode
    
    cc=NextCodeGIF(file,CharBuff(),CodeMask(),cl)
    
    If cc<0 ;If a file error, return without completing the decode
      FreeMemory(lpBUFF)
      CloseFile(file)
      MessageRequester("LOAD ERROR","Not a valid LZW code")
      ProcedureReturn #False ;FILE_ERROR
    EndIf
    
    ;If the code is a clear code, re-initialise all necessary items.
    If cc=ClearCode
      
      cl\CurrCodeSize=LZWCodeSize+1
      Slot=NewCodes
      TopSlot=1 << cl\CurrCodeSize
      
      ;Continue reading codes until we get a non-clear code
      ;(another unlikely, but possible case...)
      While cc=ClearCode
        cc=NextCodeGIF(file,CharBuff(),CodeMask(),cl)
      Wend
      
      ;If we get an ending code immediately after a clear code
      ;(yet another unlikely case), then break out of the loop.
      If cc=EndingCode
        Break ;end loop
      EndIf
      
      ;Finally, if the code is beyond the range of already set codes,
      ;(This one had better not happen, I have no idea what will
      ;result from this, but I doubt it will look good)
      ;then set it to color zero.
      If cc>=Slot
        cc=0
      EndIf
      
      OldCode=cc
      TempOldCode=OldCode
      
      ;And let us not forget to put the char into the buffer, and if,
      ;on the off chance, we were exactly one pixel from the end of
      ;the line, we have to send the buffer to the OutLineGIF() routine
      *lpBuffPtr\b=cc
      *lpBuffPtr+1
      BufCnt-1
      
      If BufCnt=0
        OutLineGIF(lpBUFF,width,Height,cl)
        *lpBuffPtr=lpBUFF
        BufCnt=width
      EndIf
      
    Else
      
      ;In this case, it's not a clear code or an ending code, so it
      ;must be a code code. So we can now decode the code into a
      ;stack of character codes (Clear as mud, right?).
      Code=cc
      
      If Code=Slot
        Code=TempOldCode
        *lpSP\b=OldCode
        *lpSP+1
      EndIf
      
      ;Here we scan back along the linked list of prefixes, pushing
      ;helpless characters (i.e. suffixes) onto the stack as we do so.
      While Code>=NewCodes
        *lpSP\b=Suffix(Code)
        *lpSP+1
        Code=Prefix(Code)
      Wend
      
      ;Push the last character on the stack, and set up the new
      ;prefix and suffix, and if the required slot number is greater
      ;than that allowed by the current bit size, increase the bit
      ;size. (Note - if we are all full, we *don't* save the new
      ;suffix and prefix. I'm not certain if this is correct,
      ;it might be more proper to overwrite the last code.
      *lpSP\b=Code
      *lpSP+1
      
      If Slot<TopSlot
        OldCode=Code
        Suffix(Slot)=OldCode
        Prefix(Slot)=TempOldCode
        Slot+1
        TempOldCode=cc
      EndIf
      
      If Slot>=TopSlot
        If cl\CurrCodeSize<12
          TopSlot=TopSlot << 1
          cl\CurrCodeSize+1
        EndIf
      EndIf
      
      ;Now that we've pushed the decoded string (in reverse order)
      ;onto the stack, lets pop it off and put it into our decode
      ;buffer, and when the decode buffer is full, write another line.
      While *lpSP>@Stack(0)
        *lpSP-1
        *lpBuffPtr\b=*lpSP\b
        *lpBuffPtr+1
        BufCnt-1
        
        If BufCnt=0
          OutLineGIF(lpBUFF,width,Height,cl)
          *lpBuffPtr=lpBUFF
          BufCnt=width
        EndIf
      Wend
      
    EndIf
    
  Wend
  
  If BufCnt<>width ;If there are any left, output the bytes
    OutLineGIF(lpBUFF,width-BufCnt-1,Height,cl)
  EndIf
  
  CloseFile(file) ;Close the file
  FreeMemory(lpBUFF)
  ProcedureReturn hDIB
  
EndProcedure

Procedure.l LoadGIF_(filename.s)
  
  Protected *dib.BITMAPINFOHEADER
  Protected Bits.l,hDC.l,hBitmap.l
  
  *dib=LoadGIF(filename)
  If *dib=0 ;Avoid errors
    ProcedureReturn #False
  EndIf
  
  Bits=*dib+*dib\biSize+(*dib\biClrUsed*4) ;Pointer to bits
  
  ;Create the DDB bitmap
  hDC=GetDC_(#Null)
  hBitmap=CreateDIBitmap_(hDC,*dib,#CBM_INIT,Bits,*dib,#DIB_RGB_COLORS)
  
  FreeMemory(*dib) ;Free the DIB
  ProcedureReturn hBitmap
  
EndProcedure

If OpenWindow(0,0,0,640,480,"Load GIF",#PB_Window_SystemMenu | #PB_Window_ScreenCentered) And CreateGadgetList(WindowID(0))
  ButtonGadget(0,10,10,80,20,"Open File")
  ImageGadget(1,10,50,300,300,0,#PB_Image_Border)
EndIf

Repeat
  Select WaitWindowEvent()
    Case #PB_Event_Gadget
      Select EventGadget()
        Case 0
          Pattern.s="All Supported Formats|*.gif"
          filename.s=OpenFileRequester("Choose An Image File To Open","",Pattern,0)
          If filename
            hBitmap.l=LoadGIF_(filename)
            SendMessage_(GadgetID(1),#STM_SETIMAGE,#IMAGE_BITMAP,hBitmap)
          EndIf
      EndSelect
    Case #PB_Event_CloseWindow
      End
  EndSelect
ForEver