'***************************************************************
' Name        : Compression, uncompression using RLE-algorithm
' Description : Compresses strings, most effective on bitmap files
' (C) 97 Jouni Vuorio - Finnland
' adapted for pbcc 5.0 by Ralph Berger


$INCLUDE "win32api.inc"

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' rle compression
' not too fast - if you need more speed try using strptr
' in for x - loop
'
FUNCTION compress(BYVAL text1 AS STRING) AS STRING
    LOCAL x       AS INTEGER
    LOCAL fchar   AS INTEGER
    LOCAL flag    AS LONG
    LOCAL maxlen  AS INTEGER
    LOCAL test    AS INTEGER
    LOCAL START   AS LONG
    LOCAL ENDE    AS LONG
    LOCAL tt      AS LONG
    LOCAL procstr AS STRING

    ''''' count characters used
    DIM cUsed(0:255) AS LONG
    START = STRPTR(text1)
    ENDE  = START + LEN(TEXT1)
    FOR tt = START TO ENDE
        INCR cUsed(PEEK(tt))
    NEXT tt

    ''''' unused char is startmark for rle
    FOR fchar = 255 TO 0 STEP -1
       IF cUsed(fchar) = 0 THEN EXIT
    NEXT fchar

    ''''' no unused char -> no compression
    IF fchar < 0 THEN
'       PRINT "cannot compress"
       FUNCTION = text1
       EXIT FUNCTION
    END IF

    procstr = text1
    ''''' loop through all chars
    FOR x = 0 TO 255
        IF cUsed(x) < 4 THEN ITERATE   ''' not interesting, skip to next char
        maxlen = MIN(136, cUsed(x))    ''' rle stores up to 256 repeats
                     ''' Range 5 to 255    try to match with your recordlen to tune up
                     
        FOR test = maxlen TO 4 STEP -1                    ''' try to find
           flag = INSTR(procStr,REPEAT$( test , CHR$(x))) ''' drill down search lenght
           IF flag = 0 THEN ITERATE
                                                          ''' start rle compression
           REPLACE MID$(procStr,flag,test) _              ''' found char * len
           WITH CHR$(fchar,test,x) _                      ''' RLE sign,len,char
           IN procStr
        NEXT test
    NEXT x

    FUNCTION = CHR$(255,255,fchar,255) + procStr
END FUNCTION



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' decompress rle encoded strings
' this one should be fast enough
'
FUNCTION uncompress(text1 AS STRING) AS STRING

    LOCAL fchar   AS STRING, _
          procStr AS STRING, _
          flag    AS LONG

    ''' check for magic header
    IF ASC(MID$(TEXT1,1,1)) <> 255 OR _
       ASC(MID$(TEXT1,2,1)) <> 255 OR _
       ASC(MID$(TEXT1,4,1)) <> 255 THEN
'       messagebox 0,"No Magic Header ","decompress",%MB_OK
       FUNCTION = text1
       EXIT FUNCTION
    ELSE
       fChar   = MID$(TEXT1,3,1)
       procStr = MID$(TEXT1,5)
    END IF

    ''' replace rle entries with real values
    DO
       flag = INSTR(procStr,fChar)
       IF flag = 0 THEN
          EXIT LOOP
       ELSE
          REPLACE MID$(procStr,flag,3) _                                         ''' RLE sign,len,char
           WITH REPEAT$(ASC(MID$(procStr,flag+1,1)), MID$(procStr, flag+2,1)) _  ''' create char * len
           IN procStr
       END IF
    LOOP

    FUNCTION = procStr
END FUNCTION




FUNCTION pbmain()
   LOCAL ins AS STRING
   LOCAL new AS STRING
   LOCAL ff AS LONG
   LOCAL I AS LONG

   ff = FREEFILE
   OPEN "huge.dbf" FOR BINARY SHARED AS #ff '..........select a filename
   GET$ #ff, LOF(FF), ins
   CLOSE #ff

   PRINT LEN(ins)
   PRINT TIMER
   neu = compress(ins)
   PRINT TIMER
   PRINT LEN(neu)
   neu = uncompress(neu)
   PRINT TIMER
   PRINT LEN(neu)
   PRINT NEU = ins
   
   ''''' suspicious ? check all bytes
   'FOR i= 1 TO LEN(ins)
   '   IF MID$(ins,i,1) <> MID$(new,i,1) THEN
   '      PRINT i, MID$(ins,i,1) , MID$(new,i,1)
   '   END IF
   'NEXT i
   EXIT FUNCTION


END FUNCTION