String compressor/decompressor

[Timm Motl]

I had to write a simple string compressor/decompressor for a database project that allows variable length records.
This is for user-input TEXT strings only, as the ASCII code 0 is being used arbitrarily as a "marker" for blocks
of duplicate characters that are compressed. Can anyone see where it could be made faster? (Please respond in the
Programming forum) Thanks.

#COMPILE EXE
#REGISTER NONE
#INCLUDE "Win32Api.Inc"


GLOBAL BlockChar AS STRING


FUNCTION Compress(Source AS STRING) AS STRING
   LOCAL LoopVar    AS LONG
   LOCAL Compressed AS STRING
   LOCAL CurrChar   AS STRING
   LOCAL CharCount  AS LONG
   IF INSTR(Source, BlockChar) THEN
      EXIT FUNCTION
   ELSE
      CurrChar = MID$(Source, 1, 1)
      CharCount = 1
      FOR LoopVar = 2 TO LEN(Source) + 1
         IF MID$(Source, LoopVar, 1) <> CurrChar OR CharCount = 255 OR LoopVar = LEN(Source) + 1 THEN
            IF CharCount > 1 THEN
               IF CharCount > 3 THEN
                  Compressed = Compressed + BlockChar + CHR$(CharCount) + CurrChar
               ELSE
                  Compressed = Compressed + STRING$(CharCount, CurrChar)
               END IF
               CharCount = 1
            ELSE
               Compressed = Compressed + CurrChar
            END IF
            CurrChar = MID$(Source, LoopVar, 1)
         ELSE
            INCR CharCount
         END IF
      NEXT
   END IF
   FUNCTION = Compressed
END FUNCTION


FUNCTION Decompress(Source AS STRING) AS STRING
   LOCAL Decompressed AS STRING
   LOCAL PrevSeekPos  AS LONG
   LOCAL SeekPos      AS LONG
   PrevSeekPos = 1
   DO
      SeekPos = INSTR(SeekPos + 1, Source, BlockChar)
      IF SeekPos THEN
         Decompressed = Decompressed + MID$(Source, PrevSeekPos, SeekPos - PrevSeekPos)
         Decompressed = Decompressed + STRING$(ASC(MID$(Source, SeekPos + 1)), MID$(Source, SeekPos + 2))
         PrevSeekPos = SeekPos + 3
      ELSE
         Decompressed = Decompressed + MID$(Source, PrevSeekPos, LEN(Source) - (PrevSeekPos - 1))
         EXIT DO
      END IF
   LOOP
   FUNCTION = Decompressed
END FUNCTION


FUNCTION PBMAIN
   LOCAL A AS STRING
   LOCAL B AS STRING
   LOCAL C AS STRING
   LOCAL Start   AS DWORD
   LOCAL Finish  AS DWORD


   BlockChar = CHR$(0) ' <--- Can be any ASCII code not likely to be in a text string (eg: 255)


   ' 64K test string
   A = "Sample " + STRING$(21835, "X") + " Text " + STRING$(21835, "Z") + " Compressor " + SPACE$(21835) + " ABCDE"


   Start = GetTickCount
   B = Compress(A)
   IF LEN(B) THEN
      C = Decompress(B)
      Finish = GetTickCount
      IF C = A THEN
         MSGBOX "Return string  (" + TRIM$(STR$(LEN(C))) + " bytes)  matches the source string!" + $CRLF + $CRLF +_
                "Compressed  AND  Decompressed  in  " + FORMAT$((Finish - Start) / 1000, "#.###") + "  seconds."
      ELSE
         MSGBOX "Oops!  Return string did NOT match source string!"
      END IF
   ELSE
      MSGBOX "Source string was binary (contained a NULL ASCII character)" + $CRLF + $CRLF +_
             "This routine is for text strings!"
   END IF
END FUNCTION

[This message has been edited by Timm Motl (edited March 01, 2001).]

[Timm Motl]

Previously posted example worked well on strings that contain long runs of duplicate characters to
compress, but ran terribly slow on strings that have few or no runs of duplicate characters (like
the test string used below). Decompression was fine, but had to revise the compression code to
run just as fast (even a little faster) when the string has nothing in it to compress.

#COMPILE EXE
#REGISTER NONE
#INCLUDE "Win32Api.Inc"


GLOBAL BlockChar AS STRING


FUNCTION Compress(Source AS STRING) AS STRING
   LOCAL CharCount  AS LONG
   LOCAL Compressed AS STRING
   LOCAL CurrChar   AS STRING
   LOCAL Loop1      AS LONG
   LOCAL Loop2      AS LONG
   LOCAL Mark1      AS LONG
   LOCAL Mark2      AS LONG
   IF INSTR(Source, BlockChar) THEN
      EXIT FUNCTION
   ELSE
      CurrChar = MID$(Source, 1, 1)
      CharCount = 1
      Mark1 = 1      
      FOR Loop1 = 2 TO LEN(Source) + 1
         IF MID$(Source, Loop1, 1) <> CurrChar OR CharCount = 255 OR Loop1 = LEN(Source) + 1 THEN
            IF CharCount > 1 THEN
               IF CharCount > 3 THEN
                  IF Mark2 THEN            
                     Compressed = Compressed + MID$(Source, Mark1, Mark2)
                     Mark2 = 0
                  END IF                 
                  Compressed = Compressed + BlockChar + CHR$(CharCount) + CurrChar
                  Mark1 = Loop1 
                  CharCount = 1
               ELSE      
                  FOR Loop2 = 1 TO CharCount
                     INCR Mark2
                  NEXT
               END IF          
               CharCount = 1
            ELSE
               INCR Mark2
            END IF
            CurrChar = MID$(Source, Loop1, 1)
         ELSE     
            INCR CharCount
         END IF
      NEXT
      IF Mark2 THEN            
         Compressed = Compressed + MID$(Source, Mark1, Mark2)
      END IF                 
   END IF
   FUNCTION = Compressed
END FUNCTION


FUNCTION Decompress(Source AS STRING) AS STRING
   LOCAL Decompressed AS STRING
   LOCAL PrevSeekPos  AS LONG
   LOCAL SeekPos      AS LONG
   PrevSeekPos = 1
   DO
      SeekPos = INSTR(SeekPos + 1, Source, BlockChar)
      IF SeekPos THEN
         Decompressed = Decompressed + MID$(Source, PrevSeekPos, SeekPos - PrevSeekPos)
         Decompressed = Decompressed + STRING$(ASC(MID$(Source, SeekPos + 1)), MID$(Source, SeekPos + 2))
         PrevSeekPos = SeekPos + 3
      ELSE
         Decompressed = Decompressed + MID$(Source, PrevSeekPos, LEN(Source) - (PrevSeekPos - 1))
         EXIT DO
      END IF
   LOOP
   FUNCTION = Decompressed
END FUNCTION


FUNCTION PBMAIN
   LOCAL A AS STRING
   LOCAL B AS STRING
   LOCAL C AS STRING
   LOCAL Start   AS DWORD
   LOCAL Finish  AS DWORD


   BlockChar = CHR$(0) ' <--- Can be any ASCII code not likely to be in a text string (eg: 255)


   ' 64K test string
   ' A = "Sample " + STRING$(21835, "X") + " Text " + STRING$(21835, "Z") + " Compressor " + SPACE$(21835) + " ABCDE"
   A = REPEAT$(2520, "ABCDEFGHIJKLMNOPQRSTUVWXYZ") + "ABCDEFGHIJKLMNOP"


   Start = GetTickCount
   B = Compress(A)
   IF LEN(B) THEN
      C = Decompress(B)
      Finish = GetTickCount
      IF C = A THEN
         MSGBOX "Return string  (" + TRIM$(STR$(LEN(C))) + " bytes)  matches the source string!" + $CRLF + $CRLF +_
                "Compressed  AND  Decompressed  in  " + FORMAT$((Finish - Start) / 1000, "#.###") + "  seconds."
      ELSE
         MSGBOX "Oops!  Return string did NOT match source string!"
      END IF
   ELSE
      MSGBOX "Source string was binary (contained a NULL ASCII character)" + $CRLF + $CRLF +_
             "This routine is for text strings!"
   END IF
END FUNCTION

Timm

[Calvin Chipman]

This would be much faster if you used byte pointers.


------------------
Calvin Chipman
PowerBASIC Staff

[Timm Motl]

Calvin:

I tried pointers too... didn't notice any speed difference. Can you try revising the above code to
gain some speed improvement and post it? Maybe I'm just missing something.

Timm

[Calvin Chipman]

No, I don't have time to rewrite your code, but I can show you
some code to point you in the right direction. What you want to
do is use pointers to step through the entire string one and only
once. By using InStr you are stepping through the string each
time you use it. Also when you concatenate strings, using pointers
is much faster because you are adding to the string directly,
rather than having other code doing the stepping for you.

The following code shows how to use pointers to step through
one string and copy all but white space characters to another
string:

'------------------------------------------------------------------------------
Function GetAllExceptWhiteSpace(sSource As String) As String

Dim sDestination As String
Dim pSrc As Byte Ptr
Dim pDst As Byte Ptr

'Initialize the destination string to the same size as the source.
sDestination = Space$(Len(sSource))

pSrc = StrPtr(sSource)
pDst = StrPtr(sDestination)

Do While @pSrc
Select Case @pSrc
Case 9, 10, 13, 32
'Skip white space characters
'(Tab, Line Feed, Carriage Return, Space).
Case Else
@pDst = @pSrc
Incr pDst
End Select
Incr pSrc
Loop

'Return only the newly copied part.
Function = Left$(sDestination, pDst - StrPtr(sDestination))

End Function
'------------------------------------------------------------------------------




------------------
Calvin Chipman
PowerBASIC Staff

[Calvin Chipman]

Sorry, I'm new at posting stuff. Here's another try:

'------------------------------------------------------------------------------
Function GetAllExceptWhiteSpace(sSource As String) As String

    Dim sDestination As String
    Dim pSrc As Byte Ptr
    Dim pDst As Byte Ptr

    'Initialize the destination string to the same size as the source.
    sDestination = Space$(Len(sSource))

    pSrc = StrPtr(sSource)
    pDst = StrPtr(sDestination)

    Do While @pSrc
        Select Case @pSrc
            Case 9, 10, 13, 32
                'Skip white space characters
                '(Tab, Line Feed, Carriage Return, Space).
            Case Else
                @pDst = @pSrc
                Incr pDst
        End Select
        Incr pSrc
    Loop

    'Return only the newly copied part.
    Function = Left$(sDestination, pDst - StrPtr(sDestination))

End Function
'------------------------------------------------------------------------------

------------------
Calvin Chipman
PowerBASIC Staff

[Timm Motl]

Calvin:

Thanks for the code example. When I previously tried pointers, I wasn't using them nearly to the extent that I could/should
have been. Your help gave me the direction I needed to really exploit pointers in this routine... gained an average 10x speed
improvement. Who knows... maybe it can be tweaked even further. Thanks again for the response.

#COMPILE EXE
#REGISTER ALL
#INCLUDE "Win32Api.Inc"


FUNCTION Compress(Source AS STRING) AS STRING
   LOCAL CharCount   AS LONG
   LOCAL Loop1       AS LONG
   LOCAL Loop2       AS LONG
   LOCAL SourceLen   AS LONG
   LOCAL BlockChar   AS STRING
   LOCAL Compressed  AS STRING      
   LOCAL CurrChar    AS STRING
   LOCAL DupChar     AS STRING
   LOCAL pBlockChar  AS BYTE PTR
   LOCAL pCompressed AS BYTE PTR
   LOCAL pCurrChar   AS BYTE PTR
   LOCAL pDupChar    AS BYTE PTR
   LOCAL pSource     AS BYTE PTR


   BlockChar   = CHR$(0)
   Compressed  = SPACE$(LEN(Source))
   CurrChar    = " "
   DupChar     = " "
   pBlockChar  = STRPTR(BlockChar)     
   pCompressed = STRPTR(Compressed)
   pCurrChar   = STRPTR(CurrChar)
   pDupChar    = STRPTR(DupChar)
   pSource     = STRPTR(Source)

    
   IF INSTR(Source, BlockChar) THEN
      EXIT FUNCTION
   ELSE
      @pCurrChar = @pSource
      INCR pSource
      CharCount = 1
      SourceLen = LEN(Source) + 1
      FOR Loop1 = 2 TO SourceLen
         IF @pSource <> @pCurrChar OR CharCount = 255 OR Loop1 = SourceLen THEN
            IF CharCount > 1 THEN
               IF CharCount > 3 THEN
                  @pCompressed = @pBlockChar
                  INCR pCompressed
                  LSET DupChar = CHR$(CharCount)
                  @pCompressed = @pDupChar
                  INCR pCompressed
                  @pCompressed = @pCurrChar
                  INCR pCompressed
               ELSE                                                     
                  FOR Loop2 = 1 TO CharCount
                     @pCompressed = @pCurrChar
                     INCR pCompressed
                  NEXT
               END IF
               CharCount = 1
            ELSE
               @pCompressed = @pCurrChar 
               INCR pCompressed
            END IF
            @pCurrChar = @pSource 
         ELSE
            INCR CharCount
         END IF
         INCR pSource
      NEXT
   END IF
   FUNCTION = LEFT$(Compressed, pCompressed - STRPTR(Compressed))
END FUNCTION


FUNCTION Decompress(Source AS STRING) AS STRING
   LOCAL PrevSeekPos  AS LONG
   LOCAL SeekPos      AS LONG   
   LOCAL BlockChar    AS STRING
   LOCAL Decompressed AS STRING
   BlockChar = CHR$(0)                                          
   PrevSeekPos = 1
   DO
      SeekPos = INSTR(SeekPos + 1, Source, BlockChar)
      IF SeekPos THEN
         Decompressed = Decompressed + MID$(Source, PrevSeekPos, SeekPos - PrevSeekPos)
         Decompressed = Decompressed + STRING$(ASC(MID$(Source, SeekPos + 1)), MID$(Source, SeekPos + 2))
         PrevSeekPos = SeekPos + 3
      ELSE
         Decompressed = Decompressed + MID$(Source, PrevSeekPos, LEN(Source) - (PrevSeekPos - 1))
         EXIT DO
      END IF
   LOOP
   FUNCTION = Decompressed
END FUNCTION


FUNCTION PBMAIN
   LOCAL A AS STRING
   LOCAL B AS STRING
   LOCAL C AS STRING
   LOCAL Start  AS DWORD
   LOCAL Finish AS DWORD


   ' Two different 64K test strings...
   ' A = "Sample " + STRING$(21835, "X") + " Text " + STRING$(21835, "Z") + " Compressor " + SPACE$(21835) + " ABCDE"
   A = REPEAT$(2520, "ABCDEFGHIJKLMNOPQRSTUVWXYZ") + "ABCDEFGHIJKLMNOP"


   Start = GetTickCount
   B = Compress(A)
   IF LEN(B) THEN      
      C = Decompress(B)
      Finish = GetTickCount
      IF C = A THEN
         MSGBOX "Return string  (" + TRIM$(STR$(LEN(C))) + " bytes)  matches the source string!" + $CRLF + $CRLF +_
                "Compressed  AND  Decompressed  in  " + FORMAT$((Finish - Start) / 1000, "#.###") + "  seconds."
      ELSE
         MSGBOX "Oops!  Return string did NOT match source string!"
      END IF
   ELSE
      MSGBOX "Source string was binary (contained a NULL ASCII character)" + $CRLF + $CRLF +_
             "This routine is for text strings!"
   END IF
END FUNCTION

Timm



[This message has been edited by Timm Motl (edited March 10, 2001).]

[Timm Motl]

I think these routines are now about fast as I can get them. After compressing the source string,
I'm adding a four byte DWORD to the front of the compressed string to let the Decompress routine
know exactly how long the original string was so I can use byte pointers during the decompression.

On my PIII-800, this will compress and decompress a 64K string in < 5 milliseconds. I'm more than
happy with that. Thanks again to Calvin for helping me out on this.

#COMPILE EXE
#REGISTER ALL
#INCLUDE "WIN32API.INC"


FUNCTION Compress(Source AS STRING) AS STRING
   LOCAL CharCount   AS LONG
   LOCAL Loop1       AS LONG
   LOCAL Loop2       AS LONG
   LOCAL SourceLen   AS LONG
   LOCAL BlockChar   AS STRING
   LOCAL Compressed  AS STRING      
   LOCAL CurrChar    AS STRING
   LOCAL DupChar     AS STRING
   LOCAL pBlockChar  AS BYTE PTR
   LOCAL pCurrChar   AS BYTE PTR
   LOCAL pCompressed AS BYTE PTR
   LOCAL pDupChar    AS BYTE PTR
   LOCAL pSource     AS BYTE PTR

   
   BlockChar   = CHR$(0)
   Compressed  = SPACE$(LEN(Source))
   CurrChar    = " "
   DupChar     = " "
   pBlockChar  = STRPTR(BlockChar)     
   pCompressed = STRPTR(Compressed)
   pCurrChar   = STRPTR(CurrChar)
   pDupChar    = STRPTR(DupChar)
   pSource     = STRPTR(Source)

    
   IF INSTR(Source, BlockChar) THEN
      EXIT FUNCTION
   ELSE
      @pCurrChar = @pSource
      INCR pSource
      INCR CharCount
      SourceLen = LEN(Source) + 1
      FOR Loop1 = 2 TO SourceLen
         IF @pSource <> @pCurrChar OR CharCount = 255 OR Loop1 = SourceLen THEN
            IF CharCount > 1 THEN
               IF CharCount > 3 THEN
                  @pCompressed = @pBlockChar
                  INCR pCompressed
                  LSET DupChar = CHR$(CharCount)
                  @pCompressed = @pDupChar
                  INCR pCompressed
                  @pCompressed = @pCurrChar
                  INCR pCompressed
               ELSE                                                     
                  FOR Loop2 = 1 TO CharCount
                     @pCompressed = @pCurrChar
                     INCR pCompressed
                  NEXT
               END IF
               CharCount = 1
            ELSE
               @pCompressed = @pCurrChar 
               INCR pCompressed
            END IF
            @pCurrChar = @pSource 
         ELSE
            INCR CharCount
         END IF
         INCR pSource
      NEXT
   END IF
   FUNCTION = MKDWD$(LEN(Source)) + LEFT$(Compressed, pCompressed - STRPTR(Compressed))
END FUNCTION


FUNCTION Decompress(Source AS STRING) AS STRING
   LOCAL Loop1         AS LONG
   LOCAL Loop2         AS LONG
   LOCAL SourceLen     AS LONG
   LOCAL BlockChar     AS STRING
   LOCAL DupChar       AS STRING
   LOCAL Decompressed  AS STRING
   LOCAL pBlockChar    AS BYTE PTR
   LOCAL pDecompressed AS BYTE PTR
   LOCAL pDupChar      AS BYTE PTR
   LOCAL pSource       AS BYTE PTR


   SourceLen     = LEN(Source)
   BlockChar     = CHR$(0)
   Decompressed  = SPACE$(CVDWD(Source))
   pBlockChar    = STRPTR(BlockChar)     
   pDecompressed = STRPTR(Decompressed)
   pDupChar      = STRPTR(DupChar)
   pSource       = STRPTR(Source) + 4


   DO
      IF @pSource = @pBlockChar THEN
         INCR pSource
         @pDupChar = @pSource
         INCR pSource
         FOR Loop2 = 1 TO @pDupChar
            @pDecompressed = @pSource
            INCR pDecompressed
         NEXT
      ELSE
         @pDecompressed = @pSource
         INCR pDecompressed
      END IF
      INCR pSource
   LOOP WHILE pSource - STRPTR(Source) < SourceLen
   FUNCTION = Decompressed
END FUNCTION


FUNCTION PBMAIN
   LOCAL A AS STRING
   LOCAL B AS STRING
   LOCAL C AS STRING
   LOCAL Start  AS DWORD
   LOCAL Finish AS DWORD


   ' 64K test string... highly compressible
   A = "Sample " + STRING$(21835, "X") + " Text " + STRING$(21835, "Z") + " Compressor " + SPACE$(21835) + " ABCDE"

   
   ' 64K test string... not compressible
   'A = REPEAT$(2520, "ABCDEFGHIJKLMNOPQRSTUVWXYZ") + "ABCDEFGHIJKLMNOP"


   Start = GetTickCount
   B = Compress(A)
   IF LEN(B) THEN
      C = Decompress(B)
      Finish = GetTickCount     
      IF A = C THEN
         MSGBOX "Compressed and decompressed in  " + _
                FORMAT$((Finish - Start) / 1000, "#.###") + "  seconds"
      ELSE
         MSGBOX "Oops!  Return string did NOT match source string!"
      END IF
   ELSE
      MSGBOX "Source string was binary (contained a NULL ASCII character)" + $CRLF + $CRLF + _
             "This routine is for text strings only!"
   END IF
END FUNCTION

Timm

[Mike Doty]

The string will compress to 211 bytes with zlib.
Reference https://forum.powerbasic.com/forum/u...rapper?t=23037

FUNCTION PBMAIN () AS LONG
  LOCAL a,b,c,sErrorCode AS STRING

  ' 64K test string... not compressible  (using
  A = REPEAT$(2520, "ABCDEFGHIJKLMNOPQRSTUVWXYZ") + "ABCDEFGHIJKLMNOP"

  gzCompressString(a, b)
  gzDeCompressString(b,c)
  IF a = c THEN sErrorCode = "Success" ELSE sErrorCode = "Failed"
  ? USING$("Original=#, Compressed=#, Decompressed=#,",LEN(a),LEN(b),LEN(c)),,sErrorCode
END FUNCTION
'
'  pb_zlib.inc
'
'  Declares and Wrappers for PB-DLL and PB-CC 32-bit
'  using zlib32.dll compression library. This is not a
'  full translation of the zlib api, but it is enough
'  to perform some basic compression/decompression of
'  strings and files.
'
'  By Don Dickinson
'  [email protected]
'  dickinson.basicguru.com
'
'  Hereby Public Domain. Provided in good faith by the auther
'  Don Dickinson. Your use or mis-use of this code impies that
'  you hold the author harmless of all effects and side-effects
'  of its use.
'
'
'- These might be defined already, but if not,
'  I do it here.
'
#IF NOT %DEF(%True)
%True = -1
%False = 0
#ENDIF

GLOBAL g_gzLastError AS STRING
%DECOMPRESS_BLOCK_SIZE     = 100000

$Z_OPEN_READ               = "rb"
$Z_OPEN_WRITE              = "wb"

%Z_NO_FLUSH                = 0
%Z_PARTIAL_FLUSH           = 1
%Z_SYNC_FLUSH              = 2
%Z_FULL_FLUSH              = 3
%Z_FINISH                  = 4

%Z_OK                      = 0
%Z_STREAM_END              = 1
%Z_NEED_DICT               = 2
%Z_ERRNO                   = -1
%Z_STREAM_ERROR            = -2
%Z_DATA_ERROR              = -3
%Z_MEM_ERROR               = -4
%Z_BUF_ERROR               = -5
%Z_VERSION_ERROR           = -6

%Z_NO_COMPRESSION          = 0
%Z_BEST_SPEED              = 1
%Z_BEST_COMPRESSION        = 9
%Z_DEFAULT_COMPRESSION     = -1

%Z_FILTERED                = 1
%Z_HUFFMAN_ONLY            = 2
%Z_DEFAULT_STRATEGY        = 0

%Z_BINARY                  = 0
%Z_ASCII                   = 1
%Z_UNKNOWN                 = 2

%Z_DEFLATED                = 8

DECLARE FUNCTION compress LIB "zlib.dll" ALIAS "compress" _
        (   compr AS ANY, comprLen AS LONG, buf AS ANY, _
            BYVAL buflen AS LONG ) AS LONG

DECLARE FUNCTION uncompress LIB "zlib.dll" ALIAS "uncompress" _
        (   uncompr AS ANY, uncomprLen AS LONG, compr AS ANY, _
            BYVAL lcompr AS LONG ) AS LONG

DECLARE FUNCTION gzopen LIB "zlib.dll" ALIAS "gzopen" _
        (   zFile AS ASCIIZ, zMode AS ASCIIZ ) AS LONG

DECLARE FUNCTION gzread LIB "zlib.dll" ALIAS "gzread" _
        (   BYVAL file AS LONG, uncompr AS ANY, _
            BYVAL uncomprLen AS LONG ) AS LONG

DECLARE FUNCTION gzwrite LIB "zlib.dll" ALIAS "gzwrite" _
        (   BYVAL file AS LONG, uncompr AS ANY, _
            BYVAL uncomprLen AS LONG) AS LONG

DECLARE FUNCTION gzclose LIB "zlib.dll" ALIAS "gzclose" _
        (   BYVAL file AS LONG ) AS LONG

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  gzGetLastError
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FUNCTION gzGetLastError() AS STRING
   FUNCTION = g_gzLastError
END FUNCTION

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  gzCompressFile
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FUNCTION gzCompressFile(inFile AS STRING, outFile AS STRING) AS LONG

   DIM hInput AS LONG
   DIM hOutput AS LONG
   DIM iReturn AS LONG
   DIM i AS LONG
   DIM iBlocks AS LONG
   DIM iLeft AS LONG
   DIM sInput AS STRING

   '- Initialize the error message
   g_gzLastError = "Success"

   '- The input must exist
   IF DIR$(inFile) = "" THEN
      g_gzLastError = "Input file " + inFile + " not found"
      GOTO gzCompresssFile_Error
   END IF

   '- The output cannot exist
   IF DIR$(outFile) <> "" THEN
      g_gzLastError = "Output file: " + outFile + " already exists"
      GOTO gzCompresssFile_Error
   END IF

   '- Tell zLib to open the output file
   hOutput = gzopen(BYCOPY outFile, $Z_OPEN_WRITE)
   IF hOutput = 0 THEN
      g_gzLastError = "zLib is unable to open output file: " + outFile
      GOTO gzCompresssFile_Error
   END IF

   '- Use PB to open the input file
   ON ERROR RESUME NEXT
   hInput = FREEFILE
   OPEN inFile FOR BINARY SHARED AS #hInput
   IF ERR THEN
      hInput = 0
      g_gzLastError = "Unable to open input file: " + inFile + " Error =" + STR$(ERR)
      GOTO gzCompresssFile_Error
   ELSEIF LOF(hInput) < 1 THEN
      g_gzLastError = "Input file: " + inFile + " is zero-length"
      GOTO gzCompresssFile_Error
   END IF

   #IF 0
   '- Get memory for the input buffer
   ON ERROR RESUME NEXT
   sInput = STRING$(LOF(hInput), 0)
   IF ERR THEN
      g_gzLastError = "Error allocating " + FORMAT$(LOF(hInput)) + " bytes of memory"
      GOTO gzCompresssFile_Error
   END IF

   '- Fill the decompression (input) buffer with the contents
   '  of the input file.
   '
   GET #hInput,, sInput
   IF ERR THEN
      g_gzLastError = "Error reading from: " + inFile + " Error =" + STR$(ERR)
      GOTO gzCompresssFile_Error
   END IF

   '- Compress the data to the output file
   iReturn = gzwrite(hOutput, BYVAL STRPTR(sInput), LEN(sInput))
   IF iReturn <> LEN(sInput) THEN
      g_gzLastError= "Error compressing data buffer: " + FORMAT$(iReturn)
      GOTO gzCompresssFile_Error
   END IF
   #ENDIF

   iLeft =  LOF(hInput) MOD %DECOMPRESS_BLOCK_SIZE
   iBlocks = (LOF(hInput) - iLeft) / %DECOMPRESS_BLOCK_SIZE
   sInput = SPACE$(%DECOMPRESS_BLOCK_SIZE)
   IF ERR THEN
      g_gzLastError = "Error allocating " + FORMAT$(%DECOMPRESS_BLOCK_SIZE) + " bytes of memory"
      GOTO gzCompresssFile_Error
   END IF

   FOR i = 1 TO iBlocks
      GET #hInput,, sInput
      IF ERR THEN
         g_gzLastError = "Error reading from: " + inFile + " Error =" + STR$(ERR)
         GOTO gzCompresssFile_Error
      END IF

      iReturn = gzwrite(hOutput, BYVAL STRPTR(sInput), LEN(sInput))
      IF iReturn <> LEN(sInput) THEN
         g_gzLastError= "Error compressing data buffer: " + FORMAT$(iReturn)
         GOTO gzCompresssFile_Error
      END IF
   NEXT i

   IF iLeft > 0 THEN
      sInput = SPACE$(iLeft)
      IF ERR THEN
         g_gzLastError = "Error allocating " + FORMAT$(iLeft) + " bytes of memory"
         GOTO gzCompresssFile_Error
      END IF

      GET #hInput,, sInput
      IF ERR THEN
         g_gzLastError = "Error reading from: " + inFile + " Error =" + STR$(ERR)
         GOTO gzCompresssFile_Error
      END IF

      iReturn = gzwrite(hOutput, BYVAL STRPTR(sInput), LEN(sInput))
      IF iReturn <> LEN(sInput) THEN
         g_gzLastError= "Error compressing data buffer: " + FORMAT$(iReturn)
         GOTO gzCompresssFile_Error
      END IF
   END IF

   '- Clean up and return OK
   '  If we make it this far, then the
   '  compression worked!
   '
   CLOSE #hInput
   gzclose hOutput
   FUNCTION = %True
   '============
   EXIT FUNCTION
   '============

gzCompresssFile_Error:
   IF hInput THEN CLOSE hInput
   IF hOutput THEN gzclose hOutput
   FUNCTION = %False

END FUNCTION

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  gzUncompressFile
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FUNCTION gzUncompressFile(compFile AS STRING, outFile AS STRING) AS LONG

   DIM hInput AS LONG
   DIM hOutput AS LONG
   DIM iReturn AS LONG
   DIM iCount AS LONG
   DIM sOutput AS STRING

   '- Initialize the error message
   g_gzLastError = "Success"

   '- The input must exist
   IF DIR$(compFile) = "" THEN
      g_gzLastError = "Compressed file " + compFile + " not found"
      GOTO gzDecompresssFile_Error
   END IF

   '- The output cannot exist
   IF DIR$(outFile) <> "" THEN
      g_gzLastError = "Output file: " + outFile + " already exists"
      GOTO gzDecompresssFile_Error
   END IF

   '- Tell zLib to open the output file
   hInput = gzopen(BYCOPY compFile, $Z_OPEN_READ)
   IF hInput = 0 THEN
      g_gzLastError = "zLib is unable to open compressed file: " + compFile
      GOTO gzDecompresssFile_Error
   END IF

   '- Use PB to open the output file
   ON ERROR RESUME NEXT
   hOutput = FREEFILE
   OPEN outFile FOR BINARY AS #hOutput
   IF ERR THEN
      hOutput = 0
      g_gzLastError = "Unable to open output file: " + compFile + " Error =" + STR$(ERR)
      GOTO gzDecompresssFile_Error
   END IF

   sOutput = STRING$(%DECOMPRESS_BLOCK_SIZE, 0)
   DO
      iCount = iCount + 1

      iReturn = gzread(hInput, BYVAL STRPTR(sOutput), %DECOMPRESS_BLOCK_SIZE)
      IF iReturn < 1 THEN
         EXIT DO
      ELSEIF iReturn < %DECOMPRESS_BLOCK_SIZE THEN
         sOutput = LEFT$(sOutput, iReturn)
         PUT #hOutput,, sOutput
         EXIT DO
      ELSE
         PUT #hOutput,, sOutput
      END IF
      IF ERR THEN
         g_gzLastError = "Error writing output file: " + outFile + " Error =" + STR$(ERR)
         GOTO gzDecompresssFile_Error
      END IF

   LOOP

   '- Clean up and return OK
   '  If we make it this far, then the
   '  compression worked!
   '
   CLOSE #hOutput
   gzclose hInput
   FUNCTION = %True
   '============
   EXIT FUNCTION
   '============

gzDecompresssFile_Error:
   IF hOutput THEN CLOSE hOutput
   IF hInput THEN gzclose hInput
   FUNCTION = %False

END FUNCTION

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'  gzCompressString
'  Compresses the string
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FUNCTION gzCompressString(BYVAL deString AS STRING, compString AS STRING) AS LONG

   DIM iReturn AS LONG
   DIM iComp AS LONG
   DIM iDeComp AS LONG

   IF LEN(deString) < 1  THEN
      FUNCTION = %False
   ELSE

      '- Calculate and allocate the compression buffer.
      compString = STRING$(LEN(deString) * 1.2 + 12, 0)
      iComp = LEN(compString)
      iDeComp = LEN(deString)

      '- Compress it
      iReturn = compress(BYVAL STRPTR(compString), iComp, BYVAL STRPTR(deString), iDeComp)
      IF iReturn = %Z_OK THEN

         '- compString will contain the length of the decompressed buffer
         '  in the first 4 bytes.
         '
         compString = MKL$(iDecomp) + LEFT$(compString, iComp)
         FUNCTION = %True
      ELSE
         compString = ""
         g_gzLastError = "Error compressing buffer. zLib err =" + STR$(iReturn)
         FUNCTION = %False
      END IF
   END IF

END FUNCTION

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
FUNCTION gzDecompressString(BYVAL compString AS STRING, deString AS STRING) AS LONG

   DIM iReturn AS LONG
   DIM iComp AS LONG
   DIM iDeComp AS LONG

   iComp = LEN(compString)
   IF iComp < 5 THEN
      FUNCTION = %False
   ELSE

      '- The first 4 bytes contain the length of the decompressee string
      iDeComp = CVL(LEFT$(compString, 4))
      iComp = iComp - 4
      compString = MID$(compString, 5)

      '- Create the decompression buffer
      deString = SPACE$(iDeComp)
      iReturn = uncompress(BYVAL STRPTR(deString), iDeComp, BYVAL STRPTR(compString), iComp)
      IF iReturn = %Z_OK THEN
         FUNCTION = %True
      ELSE
         FUNCTION = %False
      END IF
   END IF

END FUNCTION

[Anne Wilson]

Hi Mike

Where can we download zlib.dll ?
I went to the following website - but the downloads are in source code and needs to be compiled in C

http://www.winimage.com/zLibDll/

[Pierre Bellisle]

Anne,

Try the "Binaries" @ http://gnuwin32.sourceforge.net/packages/zlib.htm

Pierre

[Mike Doty]

I use version 1.2.3.0 which was renamed to SQLiteningZLib.dll in SQLitening (74,240 bytes.)
I sent you a private message with a link to what I use.

Another very popular version is 1.2.8 which I had some problems with SQLitening (didn't find a reason.)
I see there is a version 1.2.10 at http://zlib.net

I see Pierre posted at the same time as I did.
The link he posted has a version 1.2.3.2027 in the binaries that I have not tested.


Properties of the version 1.2.3.0

[Mike Doty]

There is also this link:
https://forum.powerbasic.com/forum/u...or-zip-program

DECLARE FUNCTION ZlibCompress LIB "zlib123.dll" ALIAS "compress" _
   (compr AS ANY, comprLen AS DWORD, buf AS ANY, BYVAL buflen AS DWORD)AS LONG

DECLARE FUNCTION ZlibUncompress LIB "zlib123.dll" ALIAS "uncompress" _
(uncompr AS ANY, uncomprLen AS DWORD, compr AS ANY, BYVAL lcompr AS DWORD)AS LONG

FUNCTION PBMAIN AS LONG 'compress.bas

  s$ = REPEAT$(40,CHR$(48 TO 58,65 TO 90,97 TO 122)+$CR)
  c$ = Compress   (s$)
  u$ = Uncompress (c$)
  ? u$,,USING$("Compressed length # bytes",LEN(c$))

END FUNCTION

FUNCTION Compress (rsTextIn AS STRING) AS STRING
   LOCAL wsTextOut AS STRING, llDo AS LONG,lspIn,lspOut AS STRING PTR
   lspIn = VARPTR(rsTextIn):lspOut = VARPTR(wsTextOut)
   @lspOut = SPACE$(LEN(@lspIn) * 1.2 + 12)
   llDo = LEN(@lspOut)
   ZlibCompress BYVAL STRPTR(@lspOut), llDo, BYVAL STRPTR(@lspIn), LEN(@lspIn)
   FUNCTION = MKDWD$(LEN(@lspIn)) & LEFT$(@lspOut, llDo)
END FUNCTION

FUNCTION UnCompress(rsTextIn AS STRING) AS STRING
   LOCAL wsTextOut AS STRING, lspIn,lspOut AS STRING PTR
   lspIn = VARPTR(rsTextIn):lspOut = VARPTR(wsTextOut)
   @lspOut = SPACE$(CVDWD(@lspIn))
   ZLibUncompress BYVAL STRPTR(@lspOut),LEN(@lspOut),BYVAL STRPTR(@lspIn)+4,LEN(@lspIn)-4
   FUNCTION [email protected]
END FUNCTION

FUNCTION CompressFile(sInputFile AS STRING, sOutputFile AS STRING) AS LONG
   LOCAL sData AS STRING, hFile, result AS LONG
   result = FileToString(sInputFile,sData)         'input file to string
  IF result THEN FUNCTION = result:EXIT FUNCTION  'if any error then exit
   IF ISFILE(sOutputFile) THEN  'need new output file
    KILL sOutputFile
    IF ERR THEN
      FUNCTION = ERR
      EXIT FUNCTION
    END IF
  END IF
  sData = Compress(sData)
  hFile = FREEFILE
  OPEN sOutputFile FOR BINARY AS #hFile
  IF ERR THEN FUNCTION = ERR:EXIT FUNCTION
  IF LEN(sData) THEN PUT$ #hFile,sData
  IF ERR THEN FUNCTION = ERR
  CLOSE #hFile
END FUNCTION

FUNCTION FileToString(sInputFile AS STRING,sData AS STRING) AS LONG
  LOCAL hFile,FileLen AS LONG 'return 0 on success
  IF ISFALSE(ISFILE(sInputFile)) THEN FUNCTION = 53:EXIT FUNCTION
  hFile = FREEFILE
  OPEN sInputFile FOR BINARY AS #hFile
  IF ERR THEN FUNCTION = ERR:EXIT FUNCTION
  FileLen = LOF(#hFile)
  IF FileLen = 0 THEN
    FUNCTION = -99
  ELSE
    GET$ #hFile,FileLen,sData
    FUNCTION = ERR
  END IF
  CLOSE #hFile
END FUNCTION

[Anne Wilson]

Thanks so much guys, downloaded Pierre's link and it works

[Jerry Wilson]

I've used zlib for quite some time but have had to be careful to test for the existence of the zlib dll file (explicit loading). The other day, I noticed that the Win32API contains some data compression functions here. The good news is that I don't need to keep up on zlib revisions and make sure that the zlib dll is available. The M$ compression functions also seem compress data just a well and as fast as the zlib functions. The bad news (for some people) is that compression only seems to be available for Windows 8 and later - which is not a problem for my work. In any case, here's some test code that I've been playing with.

#COMPILE EXE
#DIM ALL

#INCLUDE "win32api.inc" ' Need this for random data generation

DECLARE FUNCTION CreateCompressor LIB "Cabinet.dll" ALIAS "CreateCompressor" ( _
    BYVAL Algorithm           AS DWORD, _
    BYVAL AllocationRoutines  AS LONG, _
    BYREF CompressorHandle    AS LONG _
    ) AS LONG

DECLARE FUNCTION CreateDecompressor LIB "Cabinet.dll" ALIAS "CreateDecompressor" ( _
    BYVAL Algorithm           AS DWORD, _
    BYVAL AllocationRoutines  AS LONG, _
    BYREF DompressorHandle    AS LONG _
    ) AS LONG

DECLARE FUNCTION CloseCompressor LIB "Cabinet.dll" ALIAS "CloseCompressor" ( _
    BYVAL CompressorHandle AS LONG _
    ) AS LONG

DECLARE FUNCTION CloseDecompressor LIB "Cabinet.dll" ALIAS "CloseDecompressor" ( _
    BYVAL DecompressorHandle AS LONG _
    ) AS LONG

DECLARE FUNCTION Compress LIB "Cabinet.dll" ALIAS "Compress" ( _
    BYVAL CompressorHandle      AS LONG, _
    BYVAL UncompressedData      AS LONG, _  ' Pointer
    BYVAL UncompressedDataSize  AS LONG, _
    BYVAL CompressedBuffer      AS LONG, _  ' Pointer
    BYVAL CompressedBufferSize  AS LONG, _
    BYREF CompressedDataSize    AS LONG _
    ) AS LONG

DECLARE FUNCTION Decompress LIB "Cabinet.dll" ALIAS "Decompress" ( _
    BYVAL DecompressorHandle      AS LONG, _
    BYVAL CompressedData          AS LONG, _  ' Pointer
    BYVAL CompressedDataSize      AS LONG, _
    BYVAL UncompressedBuffer      AS LONG, _  ' Pointer
    BYVAL UncompressedBufferSize  AS LONG, _
    BYREF UncompressedDataSize    AS LONG _
    ) AS LONG

%COMPRESS_ALGORITHM_MSZIP       = 2
%COMPRESS_ALGORITHM_XPRESS      = 3   ' Fastest, good compression and low memory
%COMPRESS_ALGORITHM_XPRESS_HUFF = 4
%COMPRESS_ALGORITHM_LZMS        = 5

FUNCTION cngRNGBuff ( _
    BYVAL pBuff AS LONG, _              'IN: Ptr to buffer to hold random data
    BYVAL dLen  AS LONG _               'IN: Length of random data to write to buffer
    ) THREADSAFE AS LONG                'RET: Err val or zero if no errors

  STATIC hProv  AS LONG

  '-- If this is the first time that this is called then open a CNG provider (should never fail).
  IF ISFALSE(hProv) THEN
    BCryptOpenAlgorithmProvider(hProv, $$BCRYPT_RNG_ALGORITHM, $$NUL, 0)
  END IF

  '-- Any errors will be caused by a null buffer pointer or length. Bad values will prob GPF.
  IF BCryptGenRandom ( _
      hProv, _
      pBuff, _
      dLen, _
      %NULL) THEN
    FUNCTION = 1234
  END IF

END FUNCTION


FUNCTION PBMAIN () AS LONG
  LOCAL hComp, hdComp AS LONG
  LOCAL sInBuff, sOutBuff, sFinal AS STRING
  LOCAL dSize, bSize, ret, nErr AS LONG

  '-- Create the compressor and decompressor objects.
  ret = CreateCompressor ( _
      %COMPRESS_ALGORITHM_XPRESS, _   ' Choose an algorithm
      0, _                            ' No allocation routines
      hComp _                         ' Handle for object
      )                               ' Not zero = success
  nErr = GetLastError
  PRINT "CreateCompressor ret =" ret " Handle =" hComp
  IF ISFALSE ret THEN
    PRINT "  Function error =" nErr
    GOTO ExitMain
  END IF

  ret = CreateDecompressor ( _
      %COMPRESS_ALGORITHM_XPRESS, _   ' Choose an algorithm
      0, _                            ' No allocation routines
      hDComp _                        ' Handle for object
      )                               ' Not zero = success
  nErr = GetLastError
  PRINT "CreateDecompressor ret =" ret " Handle =" hDComp
  IF ISFALSE ret THEN
    PRINT "  Function error =" nErr
    GOTO ExitMain
  END IF

  '-- Create buffer with some compressible data.
  sInBuff += "Of all the fishes in the sea, the mermaid is the one for me."
  sInBuff += "The quick brown fox jumps over the lazy dogs back."
  sInBuff += "Of all the fishes in the sea, the mermaid is the one for me."
  sInBuff += "The quick brown fox jumps over the lazy dogs back."
  sInBuff += "Of all the fishes in the sea, the mermaid is the one for me."
  sInBuff += "The quick brown fox jumps over the lazy dogs back."
  sInBuff += "Of all the fishes in the sea, the mermaid is the one for me."
  sInBuff += "The quick brown fox jumps over the lazy dogs back."

  '-- Use this to create a buffer full of random data.
'  sInBuff = space$(90000)
'  cngRNGBuff(strptr(sInBuff), len(sInBuff))

  PRINT "Uncompressed data size =" LEN(sInBuff)

  '-- Get recommended compression output buffer size (bSize).
  ret = Compress(hComp, STRPTR(sInBuff), LEN(sInBuff), 0, 0, bSize)
  nErr = GetLastError
  PRINT "Compress (get buff size) ret =" ret " bSize =" bSize
  IF (ISFALSE ret) AND (nErr <> %ERROR_INSUFFICIENT_BUFFER) THEN
    PRINT " Function error =" nErr
    GOTO ExitMain
  END IF

  '-- Compress the data and get the size of the compressed data.
  sOutBuff = SPACE$(bSize)
  ret = Compress(hComp, STRPTR(sInBuff), LEN(sInBuff), STRPTR(sOutBuff), LEN(sOutBuff), dSize)
  nErr = GetLastError
  PRINT "Compress (compress data) ret =" ret " dSize =" dSize
  IF (ISFALSE ret) AND (nErr <> %ERROR_INSUFFICIENT_BUFFER) THEN
    PRINT " Function error =" nErr
    GOTO ExitMain
  END IF

  '-- Get recommended decompression output buffer size.
  ret = Decompress(hDComp, STRPTR(sOutBuff), dSize, 0, 0, bSize)
  nErr = GetLastError
  PRINT "Decompress (get buff size) ret =" ret " bSize =" bSize
  IF (ISFALSE ret) AND (nErr <> %ERROR_INSUFFICIENT_BUFFER) THEN
    PRINT " Function error =" nErr
    GOTO ExitMain
  END IF

  '-- Decompress the data and get the decompressed data size.
  sFinal = SPACE$(bSize)  ' Buffer to hold decompressed data
  ret = Decompress(hDComp, STRPTR(sOutBuff), dSize, STRPTR(sFinal), LEN(sFinal), dSize)
  nErr = GetLastError
  PRINT "Decompress (decompress data) ret =" ret " dSize =" dSize
  IF (ISFALSE ret) AND (nErr <> %ERROR_INSUFFICIENT_BUFFER) THEN
    PRINT " Function error =" nErr
    GOTO ExitMain
  END IF

  '-- Test output data.
  IF sInBuff <> sFinal THEN
    PRINT "Data does not match!"
  ELSE
    PRINT "No errors"
  END IF

Exitmain:
  '-- Clean up objects.
  IF hComp THEN CloseCompressor hComp
  IF hDComp THEN CloseDecompressor hdComp

  PRINT "Finished"
  WAITKEY$

END FUNCTION

[Stuart McLachlan]

Jerry's code is PBCC specific. Following is modified to work with both PBWIn and PBCC (just required a rewrite of the PRINT lines to use "?" and STR$() for numerics plus conditional WATITKEY$)

'

#COMPILE EXE
#DIM ALL

#INCLUDE "win32api.inc" ' Need this for random data generation

DECLARE FUNCTION CreateCompressor LIB "Cabinet.dll" ALIAS "CreateCompressor" ( _
    BYVAL Algorithm           AS DWORD, _
    BYVAL AllocationRoutines  AS LONG, _
    BYREF CompressorHandle    AS LONG _
    ) AS LONG

DECLARE FUNCTION CreateDecompressor LIB "Cabinet.dll" ALIAS "CreateDecompressor" ( _
    BYVAL Algorithm           AS DWORD, _
    BYVAL AllocationRoutines  AS LONG, _
    BYREF DompressorHandle    AS LONG _
    ) AS LONG

DECLARE FUNCTION CloseCompressor LIB "Cabinet.dll" ALIAS "CloseCompressor" ( _
    BYVAL CompressorHandle AS LONG _
    ) AS LONG

DECLARE FUNCTION CloseDecompressor LIB "Cabinet.dll" ALIAS "CloseDecompressor" ( _
    BYVAL DecompressorHandle AS LONG _
    ) AS LONG

DECLARE FUNCTION Compress LIB "Cabinet.dll" ALIAS "Compress" ( _
    BYVAL CompressorHandle      AS LONG, _
    BYVAL UncompressedData      AS LONG, _  ' Pointer
    BYVAL UncompressedDataSize  AS LONG, _
    BYVAL CompressedBuffer      AS LONG, _  ' Pointer
    BYVAL CompressedBufferSize  AS LONG, _
    BYREF CompressedDataSize    AS LONG _
    ) AS LONG

DECLARE FUNCTION Decompress LIB "Cabinet.dll" ALIAS "Decompress" ( _
    BYVAL DecompressorHandle      AS LONG, _
    BYVAL CompressedData          AS LONG, _  ' Pointer
    BYVAL CompressedDataSize      AS LONG, _
    BYVAL UncompressedBuffer      AS LONG, _  ' Pointer
    BYVAL UncompressedBufferSize  AS LONG, _
    BYREF UncompressedDataSize    AS LONG _
    ) AS LONG

%COMPRESS_ALGORITHM_MSZIP       = 2
%COMPRESS_ALGORITHM_XPRESS      = 3   ' Fastest, good compression and low memory
%COMPRESS_ALGORITHM_XPRESS_HUFF = 4
%COMPRESS_ALGORITHM_LZMS        = 5

FUNCTION cngRNGBuff ( _
    BYVAL pBuff AS LONG, _              'IN: Ptr to buffer to hold random data
    BYVAL dLen  AS LONG _               'IN: Length of random data to write to buffer
    ) THREADSAFE AS LONG                'RET: Err val or zero if no errors

  STATIC hProv  AS LONG

  '-- If this is the first time that this is called then open a CNG provider (should never fail).
  IF ISFALSE(hProv) THEN
    BCryptOpenAlgorithmProvider(hProv, $$BCRYPT_RNG_ALGORITHM, $$NUL, 0)
  END IF

  '-- Any errors will be caused by a null buffer pointer or length. Bad values will prob GPF.
  IF BCryptGenRandom ( _
      hProv, _
      pBuff, _
      dLen, _
      %NULL) THEN
    FUNCTION = 1234
  END IF

END FUNCTION


FUNCTION PBMAIN () AS LONG
  LOCAL hComp, hdComp AS LONG
  LOCAL sInBuff, sOutBuff, sFinal AS STRING
  LOCAL dSize, bSize, ret, nErr AS LONG

  '-- Create the compressor and decompressor objects.
  ret = CreateCompressor ( _
      %COMPRESS_ALGORITHM_XPRESS, _   ' Choose an algorithm
      0, _                            ' No allocation routines
      hComp _                         ' Handle for object
      )                               ' Not zero = success
  nErr = GetLastError
  ? "CreateCompressor ret =" & STR$(ret) &  " Handle =" & STR$(hComp)
  IF ISFALSE ret THEN
    ? "  Function error =" & STR$(nErr)
    GOTO ExitMain
  END IF

  ret = CreateDecompressor ( _
      %COMPRESS_ALGORITHM_XPRESS, _   ' Choose an algorithm
      0, _                            ' No allocation routines
      hDComp _                        ' Handle for object
      )                               ' Not zero = success
  nErr = GetLastError
  ? "CreateDecompressor ret =" & STR$(ret) & " Handle =" & STR$(hDComp)
  IF ISFALSE ret THEN
    ? "  Function error =" & STR$(nErr)
    GOTO ExitMain
  END IF

  '-- Create buffer with some compressible data.
  sInBuff += "Of all the fishes in the sea, the mermaid is the one for me."
  sInBuff += "The quick brown fox jumps over the lazy dogs back."
  sInBuff += "Of all the fishes in the sea, the mermaid is the one for me."
  sInBuff += "The quick brown fox jumps over the lazy dogs back."
  sInBuff += "Of all the fishes in the sea, the mermaid is the one for me."
  sInBuff += "The quick brown fox jumps over the lazy dogs back."
  sInBuff += "Of all the fishes in the sea, the mermaid is the one for me."
  sInBuff += "The quick brown fox jumps over the lazy dogs back."

  '-- Use this to create a buffer full of random data.
'  sInBuff = space$(90000)
'  cngRNGBuff(strptr(sInBuff), len(sInBuff))

  ? "Uncompressed data size =" & STR$(LEN(sInBuff))

  '-- Get recommended compression output buffer size (bSize).
  ret = Compress(hComp, STRPTR(sInBuff), LEN(sInBuff), 0, 0, bSize)
  nErr = GetLastError
  ? "Compress (get buff size) ret =" & STR$(ret) &  " bSize =" & STR$(bSize)
  IF (ISFALSE ret) AND (nErr <> %ERROR_INSUFFICIENT_BUFFER) THEN
    ? " Function error =" & STR$(nErr)
    GOTO ExitMain
  END IF

  '-- Compress the data and get the size of the compressed data.
  sOutBuff = SPACE$(bSize)
  ret = Compress(hComp, STRPTR(sInBuff), LEN(sInBuff), STRPTR(sOutBuff), LEN(sOutBuff), dSize)
  nErr = GetLastError
  ? "Compress (compress data) ret =" & STR$(ret) &  " dSize =" & STR$(dSize)
  IF (ISFALSE ret) AND (nErr <> %ERROR_INSUFFICIENT_BUFFER) THEN
    ? " Function error =" & STR$(nErr)
    GOTO ExitMain
  END IF

  '-- Get recommended decompression output buffer size.
  ret = Decompress(hDComp, STRPTR(sOutBuff), dSize, 0, 0, bSize)
  nErr = GetLastError
  ? "Decompress (get buff size) ret =" & STR$(ret) & " bSize =" & STR$(bSize)
  IF (ISFALSE ret) AND (nErr <> %ERROR_INSUFFICIENT_BUFFER) THEN
    ? " Function error =" & STR$(nErr)
    GOTO ExitMain
  END IF

  '-- Decompress the data and get the decompressed data size.
  sFinal = SPACE$(bSize)  ' Buffer to hold decompressed data
  ret = Decompress(hDComp, STRPTR(sOutBuff), dSize, STRPTR(sFinal), LEN(sFinal), dSize)
  nErr = GetLastError
  ? "Decompress (decompress data) ret =" & STR$(ret) & " dSize =" & STR$(dSize)
  IF (ISFALSE ret) AND (nErr <> %ERROR_INSUFFICIENT_BUFFER) THEN
    ? " Function error =" & STR$(nErr)
    GOTO ExitMain
  END IF

  '-- Test output data.
  IF sInBuff <> sFinal THEN
    ? "Data does not match!"
  ELSE
    ? "No errors"
  END IF

Exitmain:
  '-- Clean up objects.
  IF hComp THEN CloseCompressor hComp
  IF hDComp THEN CloseDecompressor hdComp

  ? "Finished"
  #IF %DEF(%PB_CC32)
   WAITKEY$
  #ENDIF

END FUNCTION
'

[Pierre Bellisle]

And if for any reason, you want something embedded in Windows since XP...

[noparse]
#COMPILE EXE '#Win#
#DIM ALL
#OPTION VERSION5 'XP+
#INCLUDE "Win32Api.inc"
#INCLUDE "ntStatus.inc"

$AppName = "MS Compression"

'Thank to José Roca for the declares
DECLARE FUNCTION RtlCompressBuffer LIB "NtDll.dll" ALIAS "RtlCompressBuffer" _
(BYVAL CompressionFormat       AS WORD, _
 BYVAL SourceBuffer            AS BYTE POINTER, _
 BYVAL SourceBufferLength      AS DWORD, _
 BYVAL DestinationBuffer       AS BYTE POINTER, _
 BYVAL DestinationBufferLength AS DWORD, _
 BYVAL Unknow                  AS DWORD, _
 BYREF pDestinationSize        AS DWORD, _
 BYVAL WorkspaceBuffer         AS DWORD) AS LONG

DECLARE FUNCTION RtlGetCompressionWorkSpaceSize LIB "NtDll.dll" ALIAS "RtlGetCompressionWorkSpaceSize" _
(BYVAL CompressionFormat       AS WORD,  _
 BYREF pNeededBufferSize       AS DWORD, _
 BYREF pUnknown                AS DWORD)  AS LONG

DECLARE FUNCTION RtlDecompressBuffer LIB "NtDll.dll" ALIAS "RtlDecompressBuffer" _
(BYVAL CompressionFormat       AS WORD, _
 BYVAL DestinationBuffer       AS BYTE POINTER, _
 BYVAL DestinationBufferLength AS DWORD, _
 BYVAL SourceBuffer            AS BYTE POINTER, _
 BYVAL SourceBufferLength      AS DWORD, _
 BYREF pDestinationSize        AS DWORD) AS LONG

'The RtlDecompressFragment function is used to decompress part of a compressed buffer (that is, a buffer "fragment").
DECLARE FUNCTION RtlDecompressFragment LIB "NtDll.dll" ALIAS "RtlDecompressFragment" _
(BYVAL CompressionFormat        AS WORD, _
 BYVAL UncompressedFragment     AS BYTE POINTER, _
 BYVAL UncompressedFragmentSize AS DWORD, _
 BYVAL CompressedBuffer         AS BYTE POINTER, _
 BYVAL CompressedBufferSize     AS DWORD, _
 BYVAL FragmentOffset           AS DWORD, _
 BYREF FinalUncompressedSize    AS DWORD, _
 BYVAL WorkSpace                AS DWORD) AS LONG
'______________________________________________________________________________

FUNCTION Compress(BYVAL sUncompressed AS STRING, BYREF sCompressed AS STRING) AS DWORD
 LOCAL sWorkBuffer       AS STRING
 LOCAL UnCompressedLen   AS DWORD
 LOCAL BufferLen         AS DWORD
 LOCAL CompressedLen     AS DWORD
 LOCAL FormatAndEngine   AS DWORD
 LOCAL WorkSpaceLenAsked AS DWORD
 LOCAL FragmentLenAsked  AS DWORD
 LOCAL dwRetVal          AS DWORD

 FormatAndEngine = MAK(DWORD, %COMPRESSION_FORMAT_LZNT1, %COMPRESSION_ENGINE_MAXIMUM) '%COMPRESSION_ENGINE_STANDARD
 RtlGetCompressionWorkSpaceSize(FormatAndEngine, WorkSpaceLenAsked, FragmentLenAsked)
 sWorkBuffer     = NUL$(WorkSpaceLenAsked)
 UnCompressedLen = LEN(sUncompressed)
 BufferLen       = 4 + UnCompressedLen '4 for UnCompressedLen DWORD.
 sCompressed     = NUL$(BufferLen)
 dwRetVal = RtlCompressBuffer(BYVAL FormatAndEngine, _
                              STRPTR(sUncompressed), _
                              BYVAL UnCompressedLen, _
                              BYVAL STRPTR(sCompressed) + 4, _ '4 for UnCompressedLen DWORD
                              BYVAL BufferLen - 4, _
                              4096, _ 'MSDN: 4096 is recommended.
                              CompressedLen, _
                              BYVAL STRPTR(sWorkBuffer))
 IF dwRetVal <> %STATUS_SUCCESS THEN 'Aka %STATUS_BUFFER_TOO_SMALL, if any error, return the original string
   'Compress output might be bigger than input if in is already compressed like a .png for example,
   'in this case kepp original uncompressed data.
   sCompressed = MKDWD$(UnCompressedLen) & sUncompressed 'INVALID_FILE_SIZE for unable to compress, out is bigger than in.
   FUNCTION = UnCompressedLen
   SetLastError(%STATUS_BUFFER_TOO_SMALL) 'Optionnal. %STATUS_SUCCESS %STATUS_BUFFER_ALL_ZEROS %STATUS_INVALID_PARAMETER %STATUS_UNSUPPORTED_COMPRESSION %STATUS_NOT_SUPPORTED %STATUS_BUFFER_TOO_SMALL
 ELSE
   POKE DWORD, STRPTR(sCompressed), UnCompressedLen 'UnCompressedLen DWORD
   sCompressed = LEFT$(sCompressed, CompressedLen + 4) '4 for UnCompressedLen DWORD
   FUNCTION = CompressedLen
 END IF

END FUNCTION
'______________________________________________________________________________

FUNCTION DeCompress(BYVAL sCompressed AS STRING, BYREF sDeCompressed AS STRING) AS DWORD
 LOCAL DeCompressedLenResult AS DWORD
 LOCAL DeCompressedLen       AS DWORD
 LOCAL dwRetVal              AS DWORD

 DeCompressedLen = PEEK(DWORD, STRPTR(sCompressed))
 IF DeCompressedLen = 0 THEN 'Nothing to decompress
   sDeCompressed = ""
   FUNCTION      = 0
   SetLastError(%STATUS_NO_DATA_DETECTED) 'Optionnal.
 ELSEIF DeCompressedLen = LEN(sCompressed) - 4 THEN 'Was not compressed
   sDeCompressed = MID$(sCompressed, 5) 'Remove DWORD lenght
   FUNCTION      = DeCompressedLen
 ELSE
   sDeCompressed = NUL$(DeCompressedLen)
   dwRetVal = RtlDeCompressBuffer(%COMPRESSION_FORMAT_LZNT1, _
                                BYVAL STRPTR(sDeCompressed), _
                                BYVAL DeCompressedLen, _
                                BYVAL STRPTR(sCompressed) + 4, _ 'Bypass DWORD for DeCompressedLen
                                BYVAL LEN(sCompressed) - 4, _    'Less DWORD for DeCompressedLen
                                DeCompressedLenResult)
   IF DeCompressedLen <> DeCompressedLenResult THEN 'Some error
     SetLastError(dwRetVal) 'Optionnal. %STATUS_SUCCESS %STATUS_BUFFER_ALL_ZEROS %STATUS_INVALID_PARAMETER %STATUS_UNSUPPORTED_COMPRESSION %STATUS_NOT_SUPPORTED %STATUS_BUFFER_TOO_SMALL
     sDeCompressed = ""
     FUNCTION      = 0
   ELSE
     FUNCTION = DeCompressedLenResult
   END IF
 END IF

END FUNCTION
'______________________________________________________________________________

FUNCTION GetFragment(BYVAL sCompressed AS STRING, BYREF sFragment AS STRING, _
                     BYVAL FragmentOffset AS DWORD, BYVAL FragmentLen AS DWORD) AS DWORD
 LOCAL sWorkBuffer           AS STRING
 LOCAL UncompressedLenResult AS DWORD
 LOCAL FormatAndEngine       AS DWORD
 LOCAL WorkSpaceLenAsked     AS DWORD
 LOCAL FragmentLenAsked      AS DWORD
 LOCAL dwRetVal              AS DWORD

 IF LEN(sCompressed) = 0 THEN
   sFragment = ""
   FUNCTION  = 0
   SetLastError(%STATUS_NO_DATA_DETECTED) 'Optionnal.
 ELSE
   IF PEEK(DWORD, STRPTR(sCompressed)) = LEN(sCompressed) THEN 'Was not compressed
     sFragment = MID$(sCompressed, FragmentOffset + 1 + 4, FragmentLen) '4 to bypass first DWORD lenght, 1 for zero to one based api vs ddt
     FUNCTION  = LEN(sFragment)
   ELSE
     FormatAndEngine = MAK(DWORD, %COMPRESSION_FORMAT_LZNT1, %COMPRESSION_ENGINE_MAXIMUM) '%COMPRESSION_ENGINE_STANDARD
     RtlGetCompressionWorkSpaceSize(FormatAndEngine, WorkSpaceLenAsked, FragmentLenAsked)
     sWorkBuffer = NUL$(FragmentLenAsked)
     sFragment   = NUL$(FragmentLen)

     'The RtlDecompressFragment function is used to decompress part of a compressed buffer (that is, a buffer "fragment").
     dwRetVal = RtlDecompressFragment(%COMPRESSION_FORMAT_LZNT1, _
                                    BYVAL STRPTR(sFragment), _
                                    BYVAL LEN(sFragment), _
                                    BYVAL STRPTR(sCompressed) + 4, _ 'Bypass DWORD for UnCompressedLen
                                    BYVAL LEN(sCompressed) - 4, _    'Less DWORD for UnCompressedLen
                                    BYVAL FragmentOffset, _          'Position in uncompressed buffer
                                    BYREF UncompressedLenResult, _
                                    BYVAL STRPTR(sWorkBuffer))
     IF UncompressedLenResult <> FragmentLen THEN
       SetLastError(dwRetVal) '%STATUS_SUCCESS %STATUS_INVALID_PARAMETER %STATUS_UNSUPPORTED_COMPRESSION %COMPRESSION_FORMAT_LZNT1 %COMPRESSION_FORMAT_NONE %COMPRESSION_FORMAT_DEFAULT %STATUS_BAD_COMPRESSION_BUFFER
       sFragment = ""
       FUNCTION  = 0
     ELSE
       FUNCTION = LEN(sFragment)
     END IF
   END IF
 END IF

END FUNCTION
'______________________________________________________________________________

FUNCTION PBMAIN() AS LONG
 LOCAL hFile           AS DWORD
 LOCAL UnCompressedLen AS DWORD
 LOCAL DeCompressedLen AS DWORD
 LOCAL CompressedLen   AS DWORD
 LOCAL FragmentLen     AS DWORD
 LOCAL FragmentOffset  AS DWORD
 LOCAL sUncompressed   AS STRING
 LOCAL sDecompressed   AS STRING
 LOCAL sCompressed     AS STRING
 LOCAL sFragment       AS STRING
 LOCAL zFileName       AS ASCIIZ * %MAX_PATH

 'Get sUncompressed from a file
 GetSystemDirectory(zFileName, %MAX_PATH)
 zFileName &= "\Shell32.DLL"
 'zFileName = "D:\Basic\Bas\SRC\Graf\~Img\PNG_Transparency.png" 'Try with already highly compressed .png data
 hFile = FREEFILE : OPEN zFileName FOR BINARY AS hFile : GET$ hFile, LOF(hFile), sUncompressed : CLOSE hFile

 'Get sUncompressed from code
 'sUncompressed = REPEAT$(100000, CHR$(0 TO 255)) 'Try this...

 UnCompressedLen = LEN(sUncompressed)
 CompressedLen   = Compress(sUncompressed, sCompressed)
 DeCompressedLen = DeCompress(sCompressed, sDeCompressed)

 MessageBox(%HWND_DESKTOP, _
            "UnCompressedLen " & $TAB & FORMAT$(UnCompressedLen, "000,###,###") & $CRLF & _
            "CompressedLen "   & $TAB & FORMAT$(CompressedLen,   "000,###,###") & $CRLF & _
            "DeCompressedLen"  & $TAB & FORMAT$(DeCompressedLen, "000,###,###"), _
            $AppName, %MB_OK OR %MB_TOPMOST)

 FragmentOffset = 100 'Give offset as if it was in a decompressed buffer.
 FragmentLen    = 1024
 FragmentLen    = GetFragment(sCompressed, sFragment, FragmentOffset, FragmentLen)
 MessageBox(%HWND_DESKTOP, _
            "FragmentOffset " & $TAB & FORMAT$(FragmentOffset, "000,###,###") & $CRLF & _
            "FragmentLen "    & $TAB & FORMAT$(FragmentLen, "000,###,###"), _
            $AppName & " - Fragment", %MB_OK OR %MB_TOPMOST)

 sUncompressed   = "A"
 UnCompressedLen = LEN(sUncompressed)
 CompressedLen   = Compress(sUncompressed, sCompressed)
 DeCompressedLen = DeCompress(sCompressed, sDeCompressed)

 MessageBox(%HWND_DESKTOP, _
            "UnCompressedLen " & $TAB & FORMAT$(UnCompressedLen, "000,###,###") & $CRLF & _
            "CompressedLen "   & $TAB & FORMAT$(CompressedLen,   "000,###,###") & $CRLF & _
            "DeCompressedLen"  & $TAB & FORMAT$(DeCompressedLen, "000,###,###"), _
            $AppName, %MB_OK OR %MB_TOPMOST)

 sUncompressed   = REPEAT$(100, "A") & "Tim" & REPEAT$(100, "B")
 UnCompressedLen = LEN(sUncompressed)
 CompressedLen   = Compress(sUncompressed, sCompressed)
 DeCompressedLen = DeCompress(sCompressed, sDeCompressed)

 MessageBox(%HWND_DESKTOP, _
            "UnCompressedLen " & $TAB & FORMAT$(UnCompressedLen, "000,###,###") & $CRLF & _
            "CompressedLen "   & $TAB & FORMAT$(CompressedLen,   "000,###,###") & $CRLF & _
            "DeCompressedLen"  & $TAB & FORMAT$(DeCompressedLen, "000,###,###"), _
            $AppName, %MB_OK OR %MB_TOPMOST)

 FragmentOffset = 100 'Give offset as if it was in a decompressed buffer.
 FragmentLen    = 3
 FragmentLen    = GetFragment(sCompressed, sFragment, FragmentOffset, FragmentLen)
 MessageBox(%HWND_DESKTOP, _
            "Fragment       " & $TAB & $DQ & sFragment & $DQ & $CRLF & _
            "FragmentOffset " & $TAB & FORMAT$(FragmentOffset, "000,###,###") & $CRLF & _
            "FragmentLen    " & $TAB & FORMAT$(FragmentLen,    "000,###,###")  & $CRLF & _
            "CompressedLen  " & $TAB & FORMAT$(CompressedLen,  "000,###,###"), _
            $AppName & " - Fragment", %MB_OK OR %MB_TOPMOST)

 END FUNCTION
'_____________________________________________________________________________
'
[/noparse]

[Raymond Leech]

I've switched to LZ4 for most of my string compression, and zSTD for the rest. zLib served me well for many years, but both of the new routines are significantly faster.

LZ4 is much faster, but you sacrifice compression ratio for speed.

zSTD is slower than LZ4 / much faster than zLib, but gives better compression ratio, somewhere between LZ4 and zLib.

Using production data in my testing, zlib creates the smallest (22%), zstd next (27%), lz4 largest (29%). But, in order of speed it was LZ4, ZSTD, zLib.

Both lz4 and zstd support dictionaries which are supposed to enhance compression ratio and speed, but I never finished testing those.

Check them out: LZ4 and ZSTD. There is a good benchmark table where you can compare several algos.

If anyone has any interest, I could probably dig up some of the test code I used.

[Stuart McLachlan]

I've switched to LZ4 for most of my string compression, and zSTD for the rest.

Have you compared them to aPLib (it comes with a PB .inc and sample code) ? http://ibsensoftware.com/products_aPLib.html

[Raymond Leech]

Have you compared them to aPLib

I haven't used aPLib since probably 2000. I switched to addCrypt/addZip until 2018 or so. Maybe I'll compare them in my next go-around. Thanks for reminding me they still exist Stuart!