Compressor, Improved...

Area:    Quik_Bas
  Msg:    #760
 Date:    06-18-92 16:46 (Public) 
 From:    Steve Gartrell           
 To:      All                      
 Subject: Compressor, Improved...  

'Here I go again...This is a faster version of my compression
'routine I posted yesterday.  This one will handle worst-case
'screen 13 pictures, although the compression will turn into
'expansion.  But fast.  Likewise, the 16 color sub now uses
'BSAVE/BLOAD, so is faster.  Both subs now use LINE in place
'of PSET/PRESET; definitely faster.  This is probably all for
'this week (or two); I'm hard up against the part of my work
'schedule that demands my allocating "family time".  One more
'note:  The 16 color sub "FourBit" makes a call to a graphics
'routine I posted in assembly with the object listing last
'month.  If you don't have it, gee...You're screwed.  Well,
'not exactly.  Just change the call to ReadPix and so on back
'to the way the first posting had it.  (You really are screwed,
'however...POINT is damned slow.)  If demand exists, I suppose
'I could repost READPIX.ASM/OBJ....|-}

DEFINT A-Z
DECLARE SUB ReadPix (SEG ColorBytes AS INTEGER, SEG StartX%,_
                     SEG StartY%, SEG EndX%, SEG EndY%)
DECLARE SUB FourBits ()
DECLARE SUB EightBits ()
CONST BufSize% = 32000
CONST MaxedOut% = 32001
CONST C$ = "Created 06/17/92 by Steve Gartrell.  No rights reserved."
SCREEN 13, , 0, 0
REDIM SHARED FileBuffer%(1 TO 32000), ColorBytes(0 TO 639)

DO
   FourBits
   DO: t$ = UCASE$(INKEY$): LOOP UNTIL LEN(t$)
   IF t$ = "Q" THEN EXIT DO
   EightBits
   DO: t$ = UCASE$(INKEY$): LOOP UNTIL LEN(t$)
   IF t$ = "Q" THEN EXIT DO
LOOP

SCREEN 0
WIDTH 80
COLOR 7, 0
END

SUB EightBits

REDIM FileBuffer%(1 TO BufSize%)
REDIM FileNameArray(0 TO 4) AS STRING * 12
FOR cnt% = 0 TO 4
   FileNameArray(cnt%) = "256PRES" + LTRIM$(STR$(cnt%)) + ".GRF"
NEXT cnt%


SCREEN 13
'make some graphics-borrowed from Rich Geldreich!!!
FOR A = 1 TO 400
   RANDOMIZE TIMER
   IF RND > .05 THEN
       LINE -(RND * 320, RND * 200), RND * 255
   ELSE
       LINE -(RND * 320, RND * 200), RND * 255, BF
   END IF
NEXT

COLOR 15
LOCATE 25, 1: PRINT "320 x 200";

FileNum% = FREEFILE
OPEN "256PRESS.GRF" FOR BINARY AS FileNum%
IF LOF(FileNum%) <> 0 THEN
   CLOSE FileNum%
   KILL "256PRESS.GRF"
ELSE
   CLOSE FileNum%
END IF

cell% = 1
ByteCnt& = 1
FilePtr% = 0

FOR x% = 0 TO 319
   CurColorPix% = POINT(x%, 0)
   ColorWord& = CurColorPix% * &H100&
   FOR y% = 0 TO 199
      ThisPixColor% = POINT(x%, y%)
      IF ThisPixColor% = CurColorPix% THEN
         ColorWord& = ColorWord& + 1
      ELSE
         IF ColorWord& > 32767 THEN
             ColorWord& = ((-ColorWord& - 1) XOR &HFFFFFFFF) - 65536
         END IF
         FileBuffer%(cell%) = CINT(ColorWord&)
         cell% = cell% + 1
         IF cell% = MaxedOut% THEN
            DEF SEG = VARSEG(FileBuffer%(1))
            BSAVE FileNameArray(FilePtr%), VARPTR(FileBuffer%(1)), 64000
            DEF SEG
            FilePtr% = FilePtr% + 1
            cell% = 1
         END IF
         CurColorPix% = ThisPixColor%
         ColorWord& = CurColorPix% * &H100& + 1&
      END IF
   NEXT
   LINE (x%, 0)-(x%, 199), 0
   IF ColorWord& > 32767 THEN
       ColorWord& = ((-ColorWord& - 1) XOR &HFFFFFFFF) - 65536
   END IF
   FileBuffer%(cell%) = CINT(ColorWord&)
   cell% = cell% + 1
   IF cell% = MaxedOut% THEN
      DEF SEG = VARSEG(FileBuffer%(1))
      BSAVE FileNameArray(FilePtr%), VARPTR(FileBuffer%(1)), 64000
      DEF SEG
      FilePtr% = FilePtr% + 1
      cell% = 1
   END IF
NEXT

LOCATE 9, 1
Total& = cell% * 2& + (FilePtr% * 64000) + (7 * (FilePtr% + 1))
PRINT "Screen reduced to "; LTRIM$(STR$(Total&)); " bytes.";

IF cell% > 1 THEN
   LOCATE 10, 1: PRINT "Saving to file.";
   cell& = cell% * 2&
   DEF SEG = VARSEG(FileBuffer%(1))
   BSAVE FileNameArray(FilePtr%), VARPTR(FileBuffer%(1)), cell&
   DEF SEG
END IF

BEEP: BEEP: BEEP
LOCATE 10, 1: PRINT "Press any key to decompress.";
DO: LOOP UNTIL INKEY$ <> ""

CLS

FilePtr% = 0

FileNum% = FREEFILE
OPEN FileNameArray(FilePtr%) FOR BINARY AS FileNum%
cell% = (LOF(FileNum%) - 7) \ 2
CLOSE FileNum%

REDIM FileBuffer%(1 TO cell%)

DEF SEG = VARSEG(FileBuffer%(1))
BLOAD FileNameArray(0), VARPTR(FileBuffer%(1))
DEF SEG

BitCnt% = 0
x% = 0
cell% = 1

DO
   ColorWord% = FileBuffer%(cell%)
   cell% = cell% + 1
   IF cell% = MaxedOut% THEN
      FilePtr% = FilePtr% + 1
      FileNum% = FREEFILE
      OPEN FileNameArray(FilePtr%) FOR BINARY AS FileNum%
      cell% = (LOF(FileNum%) - 7) \ 2
      CLOSE FileNum%
      REDIM FileBuffer%(1 TO cell%)
      DEF SEG = VARSEG(FileBuffer%(1))
      BLOAD FileNameArray(FilePtr%), VARPTR(FileBuffer%(1))
      DEF SEG
      cell% = 1
   END IF
   IF ColorWord% < 0 THEN
       ColorWord& = ABS(((CLNG(ColorWord%) + 65536) XOR &HFFFF) + 1)
   ELSE
       ColorWord& = CLNG(ColorWord%)
   END IF
   PixCnt% = ColorWord& MOD &H100
   PixColor% = ColorWord& \ &H100
   EndPix% = (BitCnt% + PixCnt%) - 1
   LINE (x%, BitCnt%)-(x%, EndPix%), PixColor%
   BitCnt% = BitCnt% + PixCnt%
   IF BitCnt% = 200 THEN
      BitCnt% = 0
      x% = x% + 1
      IF x% = 320 THEN
         EXIT DO
      END IF
   END IF
LOOP

BEEP: BEEP: BEEP


END SUB

SUB FourBits

REDIM FileBuffer%(1 TO BufSize%)
REDIM FileNameArray(0 TO 4) AS STRING * 12
FOR cnt% = 0 TO 4
   FileNameArray(cnt%) = "16PRESS" + LTRIM$(STR$(cnt%)) + ".GRF"
NEXT cnt%

SCREEN 12
-end-
~~