home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / basic / library / qb_pds / qbfaqr01 / graphic / decgif.bas < prev    next >
Encoding:
BASIC Source File  |  1992-08-09  |  5.6 KB  |  192 lines
  1. 'Date: 06-01-92 (22:49)
  2. 'From: MIKE SCHUTZ
  3. 'Subj: decgif.bas : Display Gifs
  4.  
  5. 'Many thanks to Ken Goosens, Jr. for his help with this!
  6.  
  7. '$DYNAMIC
  8. DEFINT A-Z
  9. DECLARE FUNCTION Getbit ()
  10. DECLARE FUNCTION ReadCode (CodeSize)
  11. CONST True = -1, False = 0, redc = 0, greenc = 1, bluec = 2
  12. DIM ByteBuffer AS STRING * 1
  13. DIM Powers(8), Prefix(4096), Suffix(4096), Outcode(1024)
  14. DIM MaxCodes(12), Powers2(16), pal(255) AS LONG
  15. DIM SHARED Xstart, Xend
  16. DIM endcounter AS LONG
  17. DIM image%(1 TO 32200)
  18. DIM colours(256 * 3) AS STRING * 1
  19. counter = 0
  20. xofs% = 0
  21. yofs% = 0
  22. xlen% = 320
  23. ylen% = 200
  24. FOR a = 1 TO 8: Powers(a) = 2 ^ (a - 1): NEXT
  25. DATA 4,8,16,&h20,&h40,&h80,&h100,&h200,&h400,&h800,&h1000,8192
  26. FOR a = 0 TO 11: READ MaxCodes(a): NEXT
  27. DATA 1,3,7,15,31,63,127,255
  28. FOR a = 1 TO 8: READ CodeMask(a): NEXT
  29. DATA 1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192,16384
  30. FOR a = 0 TO 14: READ Powers2(a): NEXT
  31. CLS
  32. d$ = COMMAND$
  33. INPUT "Enter path"; f$
  34. INPUT "Enter destination"; e$
  35. OPEN f$ FOR BINARY AS #1 LEN = 1
  36. OPEN (e$ + ".DAT") FOR BINARY AS #3 LEN = 1
  37. IF LOF(1) = 0 THEN PRINT "File not found!": CLOSE : KILL f$: END
  38. FOR a = 1 TO 6
  39.     GET #1, , ByteBuffer: a$ = a$ + ByteBuffer
  40. NEXT
  41. IF a$ <> "GIF87a" THEN
  42.     PRINT "Warning, the "; a$; " protocol is being used in this file."
  43.     LINE INPUT "Proceed anyway(Y/N)?"; a$
  44.     IF UCASE$(a$) <> "Y" THEN END
  45. END IF
  46. GET #1, , TotalX
  47. GET #1, , TotalY
  48. GET #1, , ByteBuffer: a = ASC(ByteBuffer)
  49. bitspixel = (a AND 7) + 1
  50. GET #1, , ByteBuffer: Background = ASC(ByteBuffer)
  51. GET #1, , ByteBuffer
  52. IF ASC(ByteBuffer) <> 0 THEN
  53.     PRINT "Bad file."
  54.     END
  55. END IF
  56. ' Retrieves and saves color palette.
  57. FOR a = 0 TO 2 ^ bitspixel - 1
  58.     GET #1, , ByteBuffer: red = ASC(ByteBuffer)
  59.     GET #1, , ByteBuffer: green = ASC(ByteBuffer)
  60.     GET #1, , ByteBuffer: blue = ASC(ByteBuffer)
  61.     ' Here's the main change... had to save the palette to a file so that
  62.     ' I could fix the color problem.
  63.     colours((a * 3) + redc) = CHR$(red)
  64.     colours((a * 3) + greenc) = CHR$(green)
  65.     colours((a * 3) + bluec) = CHR$(blue)
  66.     PUT #3, , colours((a * 3) + redc)
  67.     PUT #3, , colours((a * 3) + greenc)
  68.     PUT #3, , colours((a * 3) + bluec)
  69. NEXT
  70. CLOSE #3
  71. GET #1, , ByteBuffer
  72. IF ByteBuffer <> "," THEN
  73.     PRINT "Bad file."
  74.     END
  75. END IF
  76. GET #1, , Xstart
  77. GET #1, , Ystart
  78. GET #1, , Xlength
  79. GET #1, , Ylength
  80. Xend = Xlength + Xstart - 1: Yend = Ylength + Ystart - 1
  81. GET #1, , ByteBuffer
  82. a = ASC(ByteBuffer)
  83. IF (a AND 128) = 128 THEN
  84.     PRINT "Local colormap encountered."
  85.     END
  86. ELSEIF (a AND 64) = 64 THEN
  87.     PRINT "Image is interlaced!"
  88.     END
  89. END IF
  90. GET #1, , ByteBuffer
  91. CodeSize = ASC(ByteBuffer): ClearCode = Powers2(CodeSize)
  92. EOFCode = ClearCode + 1: FirstFree = ClearCode + 2
  93. FreeCode = FirstFree: CodeSize = CodeSize + 1
  94. InitCodeSize = CodeSize: Maxcode = MaxCodes(CodeSize - 2)
  95. Bitmask = CodeMask(bitspixel)
  96. GET #1, , ByteBuffer
  97. BlockLength = ASC(ByteBuffer) + 1: Bitsin = 8
  98. OutCount = 0
  99. x = Xstart: y = Ystart
  100. ON ERROR GOTO 0
  101. PRINT "Translating file now.";
  102. SCREEN 13
  103. DO
  104.     Code = ReadCode(CodeSize)
  105.     IF Code <> EOFCode THEN
  106.         IF Code = ClearCode THEN
  107.             CodeSize = InitCodeSize
  108.             Maxcode = MaxCodes(CodeSize - 2): FreeCode = FirstFree
  109.             Code = ReadCode(CodeSize): CurCode = Code
  110.             OldCode = Code: Finchar = Code AND Bitmask
  111.             a = Finchar
  112.             GOSUB Plot
  113.         ELSE
  114.             CurCode = Code: InCode = Code
  115.             IF Code >= FreeCode THEN
  116.                 CurCode = OldCode
  117.                 Outcode(OutCount) = Finchar
  118.                 OutCount = OutCount + 1
  119.             END IF
  120.             IF CurCode > Bitmask THEN
  121.                 DO
  122.                     Outcode(OutCount) = Suffix(CurCode)
  123.                     OutCount = OutCount + 1
  124.                     CurCode = Prefix(CurCode)
  125.                 LOOP UNTIL CurCode <= Bitmask
  126.             END IF
  127.             Finchar = CurCode AND Bitmask
  128.             Outcode(OutCount) = Finchar
  129.             OutCount = OutCount + 1
  130.             FOR i = OutCount - 1 TO 0 STEP -1
  131.                 a = Outcode(i)
  132.                 GOSUB Plot
  133.             NEXT
  134.             OutCount = 0
  135.             Prefix(FreeCode) = OldCode: Suffix(FreeCode) = Finchar
  136.             OldCode = InCode: FreeCode = FreeCode + 1
  137.             IF FreeCode >= Maxcode THEN
  138.                 IF CodeSize < 12 THEN
  139.                     CodeSize = CodeSize + 1: Maxcode = Maxcode * 2
  140.                 END IF
  141.             END IF
  142.         END IF
  143.     END IF
  144.     a$ = INKEY$
  145. LOOP UNTIL Code = EOFCode OR a$ <> ""
  146. CLOSE #1
  147. GET (0, 0)-(319, 199), image%(1)
  148. DEF SEG = VARSEG(image%(1))
  149. BSAVE e$ + ".SAV", VARPTR(image%(1)), 64200
  150. DEF SEG
  151. SCREEN 0
  152. WIDTH 80, 25
  153. PRINT "Translation complete."
  154. END
  155. Plot:
  156.   PSET (x - xofs%, y - yofs%), a
  157.   x = x + 1
  158.   IF x > Xend THEN
  159.     x = Xstart
  160.     y = y + 1
  161.   END IF
  162.   RETURN
  163. REM $STATIC
  164. 'This subprogram gets one bit from the data stream.
  165. FUNCTION Getbit STATIC
  166.     SHARED ByteBuffer AS STRING * 1, Powers(), Bitsin, BlockLength, Num
  167.     Bitsin = Bitsin + 1
  168.     IF Bitsin = 9 THEN
  169.         GET #1, , ByteBuffer
  170.         TempChar = ASC(ByteBuffer)
  171.         Bitsin = 1
  172.         Num = Num + 1
  173.         IF Num = BlockLength THEN
  174.             BlockLength = TempChar + 1
  175.             GET #1, , ByteBuffer
  176.             TempChar = ASC(ByteBuffer)
  177.             Num = 1
  178.         END IF
  179.     END IF
  180.     IF (TempChar AND Powers(Bitsin)) = 0 THEN Getbit = 0 ELSE Getbit = 1
  181. END FUNCTION
  182. FUNCTION ReadCode (CodeSize)
  183.     SHARED Powers2()
  184.     Code = 0
  185.     FOR Aa = 0 TO CodeSize - 1
  186.         Code = Code + Getbit * Powers2(Aa)
  187.     NEXT
  188.     ReadCode = Code
  189. END FUNCTION
  190.  
  191.  
  192.