' @brief Compresses a STRING buffer using the Deflate algorithm with Zopfli. The output can be decompressed using QB64's _INFLATE$ function.

' @param inputBuffer The STRING buffer to compress.

' @param compressionLevel The compression level to use (0 - 65535). 65535 provides the highest compression, while 0 uses the library’s default. Levels above 255 may yield diminishing returns and are extremely slow.

' @return The compressed string.

FUNCTION DeflatePro$ (inputBuffer AS STRING, compressionLevel AS _UNSIGNED INTEGER)

(12-20-2024, 07:54 PM)Petr Wrote: Thanks for posting. I use _Deflate$ to compress image masks. I appreciate you posting it here. I tested it in version 4.0 (older versions see an unknown command there). I can use it for short strings, so the program stays snappy.

$Console:Only

If _CommandCount = 0 Then System

Dim As _Unsigned Long BS

Dim ST!, LT!, I$, O$, Y%, INFILE$, OUTFILE$, PATHPREFIX$, MODE%%, L&

If Command$(1) = "-c" Or Command$(1) = "--compress" Then MODE%% = 1

If Command$(1) = "-d" Or Command$(1) = "--decompress" Then MODE%% = 2

INFILE$ = Command$(2)

If _FileExists(INFILE$) = 0 Then PATHPREFIX$ = _StartDir$ + "\"

INFILE$ = PATHPREFIX$ + INFILE$

If _FileExists(INFILE$) = 0 Then Print "File "; Command$(2); " does not exists!": System

Y% = CsrLin + 1

Select Case MODE%%

    Case 1: Print "Compressing": Open INFILE$ For Binary As #1

        OUTFILE$ = INFILE$ + ".1b"

        Open OUTFILE$ For Output As #2

        Close #2

        Open OUTFILE$ For Binary As #2

        ST! = Timer(0.001)

        BS = 2 ^ Val(Command$(3))

        If BS = 1 Then BS = 2 ^ 20

        Do

            LT! = Timer(0.001)

            If LOF(1) - Seek(1) + 1 >= BS Then I$ = Space$(BS) Else I$ = Space$(LOF(1) - Seek(1) + 1)

            Get #1, , I$

            O$ = OneByteEncode$(I$)

            I$ = MKL$(Len(O$)) + O$

            Put #2, , I$

            If LOF(1) <= Seek(1) - 1 Then Exit Do

            Locate Y%, 1: Print Round(100 * (Seek(1) - 1) / LOF(1)); "%", Round(100 * LOF(2) / (Seek(1) - 1)); "%", Round(Timer(0.001) - LT!); "s", Round((Timer(0.001) - LT!) / BS * (LOF(1) - Seek(1) + 1)); "s", Round(Timer(0.001) - ST!); "s"

        Loop

        Print "Ratio:"; Round(100 * LOF(2) / LOF(1)); "%"

        Print "Time: "; Timer(0.001) - ST!; "s"

        Close

    Case 2: Print "Decompressing": Open INFILE$ For Binary As #1

        OUTFILE$ = INFILE$ + ".out"

        Open OUTFILE$ For Output As #2

        Close #2

        Open OUTFILE$ For Binary As #2

        ST! = Timer(0.001)

        Do

            LT! = Timer(0.001)

            Get #1, , L&

            If EOF(1) = -1 Then Exit Do

            I$ = Space$(L&)

            Get #1, , I$

            O$ = OneByteDecode$(I$)

            Put #2, , O$

            Locate Y%, 1: Print Round(100 * (Seek(1) - 1) / LOF(1)); "%", Round(Timer(0.001) - LT!); "s", Round(Timer(0.001) - ST!); "s"

        Loop

        Print "Time: "; Timer(0.001) - ST!; "s"

        Close

End Select

System

Function Round (__N As Double)

    Round = Int(100 * __N) / 100

End Function

Function Remain~& (A~&, B~&)

    Remain~& = A~& \ B~& + Sgn(A~& Mod B~&)

End Function

Function OneByteEncode$ (__I$)

    Dim As _Unsigned _Byte __ONEBYTE, __C

    Dim As _Unsigned Long __BYTE_BUFFER_OFFSET, __POSITION_BUFFER_OFFSET, __I, __LENA, __Frequency_Table(0 To 255)

    Dim __J As _Unsigned _Bit * 3

    Dim As String __BYTE_BUFFER, __POSITION_BUFFER

    __LENA = Len(__I$)

    For __I = 1 To __LENA

        __BYTE~%% = Asc(__I$, __I)

        __Frequency_Table(__BYTE~%%) = __Frequency_Table(__BYTE~%%) + 1

    Next __I

    For __BI~%% = 0 To 255

        If __Frequency_Table(__BI~%%) > __Frequency_Table(__ONEBYTE) Then __ONEBYTE = __BI~%%

    Next __BI~%%

    __BYTE_BUFFER = String$(Len(__I$), 0): __POSITION_BUFFER = String$(Remain(Len(__I$), 8) + 1, 0)

    For __I = 1 To Len(__I$)

        __C = Asc(__I$, __I): If __J = 0 Then __POSITION_BUFFER_OFFSET = __POSITION_BUFFER_OFFSET + 1

        If __C <> __ONEBYTE Then

            Asc(__POSITION_BUFFER, __POSITION_BUFFER_OFFSET) = _SetBit(Asc(__POSITION_BUFFER, __POSITION_BUFFER_OFFSET), __J)

            __BYTE_BUFFER_OFFSET = __BYTE_BUFFER_OFFSET + 1: Asc(__BYTE_BUFFER, __BYTE_BUFFER_OFFSET) = __C

        End If

        __J = __J + 1

    Next __I

    __POSITION_BUFFER = _Deflate$(Left$(__POSITION_BUFFER, __POSITION_BUFFER_OFFSET))

    __BYTE_BUFFER = _Deflate$(Left$(__BYTE_BUFFER, __BYTE_BUFFER_OFFSET))

    OneByteEncode$ = MKL$(Len(__I$)) + MKL$(Len(__POSITION_BUFFER)) + MKL$(Len(__BYTE_BUFFER)) + Chr$(__ONEBYTE) + __POSITION_BUFFER + __BYTE_BUFFER

    __POSITION_BUFFER = ""

    __BYTE_BUFFER = ""

    Exit Function

End Function

Function OneByteDecode$ (__I$)

    Dim As _Unsigned Long __I, __BYTE_BUFFER_OFFSET, __POSITION_BUFFER_OFFSET

    Dim As _Unsigned _Bit * 3 __J

    Dim As String __BYTE_BUFFER, __POSITION_BUFFER, __OUT_BUFFER

    __OUT_LENGTH~& = CVL(Left$(__I$, 4))

    __POSITION_BUFFER_DEFLATE_LENGTH~& = CVL(Mid$(__I$, 5, 4))

    __BYTE_BUFFER_DEFLATE_LENGTH~& = CVL(Mid$(__I$, 9, 4))

    __ONEBYTE~%% = Asc(__I$, 13)

    __POSITION_BUFFER = _Inflate$(Mid$(__I$, 14, __POSITION_BUFFER_DEFLATE_LENGTH~&))

    __BYTE_BUFFER = _Inflate$(Mid$(__I$, 14 + __POSITION_BUFFER_DEFLATE_LENGTH~&, __BYTE_BUFFER_DEFLATE_LENGTH~&))

    __OUT_BUFFER = String$(__OUT_LENGTH~&, 0)

    __POSITION_BUFFER_OFFSET = 0

    __BYTE_BUFFER_OFFSET = 0

    For __I = 1 To __OUT_LENGTH~&

        If __J = 0 Then __POSITION_BUFFER_OFFSET = __POSITION_BUFFER_OFFSET + 1

        If _ReadBit(Asc(__POSITION_BUFFER, __POSITION_BUFFER_OFFSET), __J) Then

            __BYTE_BUFFER_OFFSET = __BYTE_BUFFER_OFFSET + 1

            Asc(__OUT_BUFFER, __I) = Asc(__BYTE_BUFFER, __BYTE_BUFFER_OFFSET)

        Else

            Asc(__OUT_BUFFER, __I) = __ONEBYTE~%%

        End If

        __J = __J + 1

    Next __I

    __POSITION_BUFFER = ""

    __BYTE_BUFFER = ""

    OneByteDecode = __OUT_BUFFER

End Function

Function RLEEncode$ (__I$)

    Dim As _Unsigned _Byte __CB, __LB, __C

    Dim As Long __I

    Dim As String __OUT_BUFFER

    __OUT_BUFFER = String$(Len(__I$) * 2, 0)

    __LB = Asc(__I$, 1)

    __C = 1

    For __I = 2 To Len(__I$)

        __CB = Asc(__I$, __I)

        If __CB = __LB And __C < 255 Then

            __C = __C + 1

        Else

            __OUT_BUFFER_OFFSET = __OUT_BUFFER_OFFSET + 1

            Asc(__OUT_BUFFER, __OUT_BUFFER_OFFSET) = __LB

            __OUT_BUFFER_OFFSET = __OUT_BUFFER_OFFSET + 1

            Asc(__OUT_BUFFER, __OUT_BUFFER_OFFSET) = __C

            __C = 1

            __LB = __CB

        End If

    Next __I

    __OUT_BUFFER_OFFSET = __OUT_BUFFER_OFFSET + 1

    Asc(__OUT_BUFFER, __OUT_BUFFER_OFFSET) = __LB

    __OUT_BUFFER_OFFSET = __OUT_BUFFER_OFFSET + 1

    Asc(__OUT_BUFFER, __OUT_BUFFER_OFFSET) = __C

    If 5 + __OUT_BUFFER_OFFSET > Len(__I$) Then

        RLEEncode$ = Chr$(0) + __I$

    Else

        RLEEncode$ = Chr$(1) + MKL$(Len(__I$)) + Left$(__OUT_BUFFER, __OUT_BUFFER_OFFSET + 1)

    End If

    __OUT_BUFFER = ""

End Function

Function RLEDecode$ (__I$)

    Dim As _Unsigned _Byte __B, __C

    Dim As Long __I, __OUT_BUFFER_OFFSET

    Dim As String __OUT_BUFFER

    If Asc(__I$, 1) = 0 Then

        RLEDecode$ = Mid$(__I$, 2)

        Exit Function

    End If

    __OUT_LENGTH~& = CVL(Mid$(__I$, 2, 4))

    __OUT_BUFFER = String$(__OUT_LENGTH~&, 0)

    __OUT_BUFFER_OFFSET = 1

    For __I = 6 To Len(__I$) - 1

        __B = Asc(__I$, __I): __I = __I + 1: __C = Asc(__I$, __I)

        Mid$(__OUT_BUFFER, __OUT_BUFFER_OFFSET, __C) = String$(__C, __B)

        __OUT_BUFFER_OFFSET = __OUT_BUFFER_OFFSET + __C

    Next __I

    RLEDecode$ = __OUT_BUFFER

    __OUT_BUFFER = ""

End Function