DeflatePro

[a740g]

This is a QB64 _INFLATE$ compatible compression library. Internally it uses Google's Zopfli. Zopfli is a highly optimized C-based compression library designed to produce efficient (though slow) Deflate or zlib-compressed data. The advantage is that the compressed data is fully compatible with QB64’s _INFLATE$ function, allowing seamless decompression.

The library contains a single function:

Code: (Select All)

' @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)

The attached file has a test program in the zip root and the library inside the "include" directory. Use it however you see fit.




FAQ:
Q: Why did you do this?
A: Why not? Ok, just for fun.

[Petr]

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.

[a740g]

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.

You are welcome.  

The library does not use any v4-specific features. So you should be able to use that with previous versions of QB64-PE.

[Sanmayce]

Thanks, such add-ons are essential for quickening (keeping the spirit of quickness alive) the "Quick" in QB64, hee-hee.

Eric Biggers's libdeflate is the best ZIP implementation known to me, he constantly makes it better each year.
Zopfli is Jyrki's implementation, he is an algorithmicwhiz, among the best programmers, his contributions in graphics, compression, hashing are industry-standard.

To me, QB64 has to be enriched with similar libraries (under one hood, e.g. QB64_Cgems).
For example, QB64 lacks FuzzyMemMem&(Haystack$, Needle$, EditDistance%) function.
Huh, even GLIBC is lacking in that department...

Keep up the good work, man, salute you!

[aadityap0901]

Check this out:
1B - A pre-compression algorithm to increase the compression-ratio of deflate:
Basic Usage: 1b -c [FILENAME]

Code: (Select All)

$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

I made a lot of other versions too, but this turned out to be the best of 4

[a740g]

@aadityap0901 I tried it. 1b is very picky and only shows goodness in very few cases. It generally does poorly when the data already has gone through some type of compression. But that is expected. Deflate does marginally better in these cases though.





The ".deflate" files are just raw dumps from _DEFLATE$.

[aadityap0901]

Yes, 1b is picky about that, but it just takes out the byte having the highest frequency, and then encodes it as a zero bit
I haven't said all in the usage section, even if 1b isn't that powerful, I have other alternatives for many things,
Introducing BlockSize - The length of data it encodes at a time.
Example Usage: 1b -c a.txt 23
Here 23 means 1b will allocate 2 ^ 23 bytes (8 MiB) and then input data from the file.
Default is 20 (1 MiB)
For Images:
img_c -c [FILENAME] [BLOCKSIZE]
It compresses the above temp.bmp to just 0.11%

Code: (Select All)

$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": IMG& = _LoadImage(INFILE$, 32)

        Open INFILE$ For Binary As #1

        OUTFILE$ = INFILE$ + ".img_c"

        Open OUTFILE$ For Output As #2

        Close #2

        Open OUTFILE$ For Binary As #2

        ST! = Timer(0.001)

        O$ = Compress$(IMG&)

        Put #2, , O$

        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$

            If Command$(4) = "n" Then O$ = DeCompress$(I$) Else O$ = DeCompress$(_Inflate$(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 Compress$ (__I&)

    Dim As _Unsigned _Byte __BYTE

    Dim As _Unsigned Integer __W, __H

    Dim As _Unsigned Long __I, __J, __K, __Source, __Colours, __P, __L

    Dim As _Unsigned Long __Pallete(1 To 16777216)

    __Source = _Source: _Source __I&

    __W = _Width(__I&)

    __H = _Height(__I&)

    Print "Preprocessing"

    For __I = 0 To __W - 1

        For __J = 0 To __H - 1

            __P = Point(__I, __J)

            For __K = 1 To __Colours

                If __P = __Pallete(__K) Then

                    Exit For

                End If

            Next __K

            If __Colours = 0 Or __P <> __Pallete(__K) Then

                __Colours = __Colours + 1

                If __Colours > 16777216 Then Print "Error": System

                __Pallete(__Colours) = __P

            End If

    Next __J, __I

    __MBU = min_bits_used~%%(__Colours - 1)

    __B$ = String$(__W * __H * __MBU, 48)

    Print "Encoding"

    For __I = 0 To __W - 1: For __J = 0 To __H - 1

            __P = Point(__I, __J)

            For __K = 1 To __Colours

                If __P = __Pallete(__K) Then

                    Mid$(__B$, (__I * __W + __J) * __MBU + 1, __MBU) = LongToBits$(__K - 1, __MBU)

                End If

            Next __K

    Next __J, __I

    __L = __W * __H * __MBU

    __L = _SHR(__L, 3) + Sgn(__L Mod 8)

    __O$ = String$(__L, 0)

    For __I = 1 To __L

        Asc(__O$, __I) = Val("&B" + Mid$(__B$, __I * 8 - 7, 8))

    Next __I

    __Pallete$ = String$(__Colours * 4, 0)

    MemCopy _Offset(__Pallete()), _Offset(__Pallete$), __Colours * 4

    __O$ = _Deflate$(__O$)

    Compress$ = MKI$(__W) + MKI$(__H) + MKL$(__Colours) + __Pallete$ + MKL$(Len(__O$)) + __O$

    _Source __Source

End Function

Function DeCompress$ (__I$)

End Function

Sub MemCopy (__S As _Offset, __D As _Offset, __SIZE As _Unsigned Long)

    Dim As _MEM __M1, __M2

    __M1 = _Mem(__S, __SIZE): __M2 = _Mem(__D, __SIZE)

    _MemCopy __M1, __M1.OFFSET, __M1.SIZE To __M2, __M2.OFFSET

    _MemFree __M1: _MemFree __M2

End Sub

Sub MemCopyFromImage (__S As Long, __D As _Offset, __SIZE As _Unsigned Long)

    Dim As _MEM __M1, __M2

    __M1 = _MemImage(__S): __M2 = _Mem(__D, __SIZE)

    _MemCopy __M1, __M1.OFFSET, __M1.SIZE To __M2, __M2.OFFSET

    _MemFree __M1: _MemFree __M2

End Sub

Function ByteToBits$ (__BYTE As _Unsigned _Byte, __MAX_LEN As _Unsigned _Byte)

    Dim __I As _Unsigned _Byte

    Dim __O$8

    __O$8 = String$(8, 48)

    For __I = 1 To __MAX_LEN

        Asc(__O$8, 9 - __I) = 48 - _ReadBit(__BYTE, __I - 1)

    Next __I

    ByteToBits$ = Right$(__O$8, __MAX_LEN)

End Function

Function LongToBits$ (__LONG As _Unsigned Long, __MAX_LEN As _Unsigned _Byte)

    Dim __I As _Unsigned _Byte

    Dim __O$32

    __O$32 = String$(32, 48)

    For __I = 1 To __MAX_LEN

        Asc(__O$32, 33 - __I) = 48 - _ReadBit(__LONG, __I - 1)

    Next __I

    LongToBits$ = Right$(__O$32, __MAX_LEN)

End Function

Function min_bits_used~%% (A As _Unsigned Long)

    Dim __I As _Unsigned _Byte

    For __I = 31 To 0 Step -1

        If A And 2 ^ __I Then min_bits_used = __I + 1: Exit Function

    Next __I

    min_bits_used = 1

End Function

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

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

End Function

Function Round (__N As Double)

    Round = Int(100 * __N) / 100

End Function

Function PNG32 (__FILENAME As String, __IMAGE As Long, __PNGDATA As String)

    Dim As String __PNGHEADER, __IHDR, __IDAT, __IMAGDATA, __IEND

    Dim As String __EXT

    Dim As Long __WIDTH, __HEIGHT, __F, __SOURCE, __OFFSET, __X, __Y, __P

    Dim As _Byte __SAVEMODE

    If Len(__FILENAME) Then __SAVEMODE = -1 Else __SAVEMODE = 0

    __PNGHEADER$ = Chr$(&H89) + Chr$(&H50) + Chr$(&H4E) + Chr$(&H47) + Chr$(&H0D) + Chr$(&H0A) + Chr$(&H1A) + Chr$(&H0A)

    __WIDTH = _Width(__IMAGE): __HEIGHT = _Height(__IMAGE)

    __F = FreeFile

    If LCase$(Right$(__FILENAME, 4)) <> ".png" Then __EXT = ".png" Else __EXT = ""

    If __SAVEMODE Then Open __FILENAME + __EXT For Output As #__F: Close #__F

    If __SAVEMODE Then Open __FILENAME + __EXT For Binary As #__F

    If __SAVEMODE Then Put #__F, , __PNGHEADER$

    __IHDR = "IHDR" + Reverse$(MKL$(__WIDTH)) + Reverse$(MKL$(__HEIGHT)) + Chr$(&H08) + Chr$(&H06) + String$(3, 0)

    __IHDR = Reverse$(MKL$(&H0D)) + __IHDR + Reverse$(MKL$(crc32(__IHDR)))

    If __SAVEMODE Then Put #__F, , __IHDR

    __SOURCE = _Source

    _Source __IMAGE

    __IMAGDATA = String$(__HEIGHT * __WIDTH * 4 + __HEIGHT, 0)

    __OFFSET = 1

    For __Y = 1 To __HEIGHT Step 1

        __OFFSET = __OFFSET + 1

        For __X = 1 To __WIDTH Step 1

            __P = Point(__X - 1, __Y - 1)

            Asc(__IMAGDATA, __OFFSET) = _Red32(__P)

            Asc(__IMAGDATA, __OFFSET + 1) = _Green32(__P)

            Asc(__IMAGDATA, __OFFSET + 2) = _Blue32(__P)

            Asc(__IMAGDATA, __OFFSET + 3) = _Alpha32(__P)

            __OFFSET = __OFFSET + 4

        Next __X

    Next __Y

    _Source __SOURCE

    __IDAT = _Deflate$(__IMAGDATA)

    __IDAT = Reverse$(MKL$(Len(__IDAT))) + "IDAT" + __IDAT + Reverse$(MKL$(crc32("IDAT" + __IDAT)))

    If __SAVEMODE Then Put #__F, , __IDAT

    __IEND = Reverse$(MKL$(&H00)) + "IEND" + Reverse$(MKL$(&HAE426082))

    If __SAVEMODE Then Put #__F, , __IEND

    If __SAVEMODE Then Close #__F

    __PNGDATA = __PNGHEADER$ + __IHDR + __IDAT + __IEND

    If _FileExists(__FILENAME) Then PNG32 = -1 Else PNG32 = 0

End Function

Function Reverse$ (__IN$)

    IN$ = __IN$

    L~& = Len(IN$)

    For I~& = 1 To _SHR(L~&, 1)

        TMP~%% = Asc(IN$, I~&)

        Asc(IN$, I~&) = Asc(IN$, L~& - I~& + 1)

        Asc(IN$, L~& - I~& + 1) = TMP~%%

    Next I~&

    Reverse$ = IN$

End Function

Function crc32~& (__IN$)

    Dim As _Unsigned Long __CRC32_POLY, __CRC, __I

    Dim As _Unsigned _Byte __J

    __CRC32_POLY = &HEDB88320

    __CRC = &HFFFFFFFF

    For __I = 1 To Len(__IN$)

        __CRC = __CRC Xor Asc(__IN$, __I)

        For __J = 1 To 8

            If __CRC And 1 Then __CRC = (__CRC \ 2) Xor __CRC32_POLY Else __CRC = __CRC \ 2

        Next __J

    Next __I

    crc32~& = Not __CRC

End Function

Function adler32~& (__IN$)

    Dim As _Unsigned Long __A, __B

    __A = 1: __B = 0

    For __I = 1 To Len(__IN$)

        __A = (__A + Asc(Mid$(__IN$, __I, 1))) Mod 65521

        __B = (__B + __A) Mod 65521

    Next __I

    adler32~& = __B * 65536 + __A

End Function

Even check this, it builds a frequency table and then substitutes bytes with a byte having less bits:
Try this with that same file temp.bmp
f -c [FILENAME] [BLOCKSIZE]

Code: (Select All)

$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$ + ".f"

        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$

            If Command$(4) = "n" Then O$ = Compress$(I$) Else O$ = _Deflate$(Compress$(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$

            If Command$(4) = "n" Then O$ = DeCompress$(I$) Else O$ = DeCompress$(_Inflate$(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 Compress$ (__I$)

    Dim As _Unsigned _Byte __Code_Table(0 To 255), __Inverse_Code_Table(0 To 255)

    Dim As _Unsigned Long __Frequency_Table(0 To 255)

    Dim As _Unsigned Long __I, __LENA

    __LENA = Len(__I$)

    For __I = 1 To __LENA

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

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

    Next __I

    For __BJ~%% = 0 To 255

        For __BI~%% = 0 To 255

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

        Next __BI~%%

        __Code_Table(__MAXBYTE~%%) = __BJ~%%

        __Inverse_Code_Table(__BJ~%%) = __MAXBYTE~%%

        __Frequency_Table(__MAXBYTE~%%) = 0

        __MAXBYTE~%% = __MAXBYTE~%% + 1

    Next __BJ~%%

    __B$ = String$(256 + __LENA, 0)

    For __I = 0 To 255

        Asc(__B$, __I + 1) = __Inverse_Code_Table(__I)

    Next __I

    For __I = 1 To __LENA

        Asc(__B$, 256 + __I) = __Code_Table(Asc(__I$, __I))

    Next __I

    __B$ = ZeroByteEncode$(__B$)

    Compress$ = __B$

    __B$ = ""

End Function

Function DeCompress$ (__I$)

    Dim __Inverse_Code_Table(0 To 255) As _Unsigned _Byte

    Dim As _Unsigned Long __I, __LENA

    __B$ = ZeroByteDecode$(__I$)

    __LENA = Len(__B$) - 256

    For __I = 0 To 255

        __Inverse_Code_Table(__I) = Asc(__B$, __I + 1)

    Next __I

    __O$ = String$(__LENA, 0)

    For __I = 1 To __LENA

        Asc(__O$, __I) = __Inverse_Code_Table(Asc(__B$, __I + 256))

    Next __I

    DeCompress$ = __O$

    __O$ = ""

End Function

Function ZeroByteEncode$ (__I$)

    Dim As _Unsigned _Byte __C

    Dim As _Unsigned Long __BYTE_BUFFER_OFFSET, __POSITION_BUFFER_OFFSET, __I

    Dim __J As _Unsigned _Bit * 3

    Dim As String __BYTE_BUFFER, __POSITION_BUFFER

    __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 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))

    ZeroByteEncode$ = MKL$(Len(__I$)) + MKL$(__POSITION_BUFFER_OFFSET) + MKL$(__BYTE_BUFFER_OFFSET) + MKL$(Len(__POSITION_BUFFER)) + MKL$(Len(__BYTE_BUFFER)) + __POSITION_BUFFER + __BYTE_BUFFER

    __POSITION_BUFFER = ""

    __BYTE_BUFFER = ""

    Exit Function

End Function

Function ZeroByteDecode$ (__I$)

    Dim As _Unsigned Long __I, __BYTE_BUFFER_OFFSET, __POSITION_BUFFER_OFFSET

    Dim As _Unsigned _Byte __C

    Dim As _Unsigned _Bit * 3 __J

    Dim As String __BYTE_BUFFER, __POSITION_BUFFER, __OUT_BUFFER

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

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

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

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

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

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

    __BYTE_BUFFER = _Inflate$(Mid$(__I$, 21 + __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)

        End If

        __J = __J + 1

    Next __I

    ZeroByteDecode = __OUT_BUFFER

End Function

Function ByteToBits$ (__BYTE As _Unsigned _Byte, __MAX_LEN As _Unsigned _Byte)

    Dim __I As _Unsigned _Byte

    Dim __O$

    __O$ = String$(__MAX_LEN, 48)

    For __I = 0 To __MAX_LEN - 1

        If __BYTE And 2 ^ __I Then Asc(__O$, __MAX_LEN - __I) = 49

    Next __I

    ByteToBits$ = __O$

End Function

Function min_bits_used~%% (A As _Unsigned _Byte)

    Dim __I As _Unsigned _Byte

    For __I = 7 To 0 Step -1

        If A And 2 ^ __I Then min_bits_used~%% = __I + 1: Exit Function

    Next __I

    min_bits_used~%% = 1

End Function

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

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

End Function

Function Round (__N As Double)

    Round = Int(100 * __N) / 100

End Function

I have 1 more, but it is not the best.