LZSS
Algorithm creator(s)
Abraham Lempel, Jakob Ziv
PB author(s)
Semen Matusovski, Don Dickinson
Description
Slow compression but decompression is fast.
Note
n/a
Source
https://forum.powerbasic.com/forum/user-to-user-discussions/source-code/25004-lzss?t=24355
See also
Source Code
Download source code file lzss.bas (Right-click -> "Save as ...")
'Somehow Don already posted similar code - see http://www.powerbasic.com/support/forums/Forum7/HTML/000379.html
'I decided to increase a little compression speed.
'I have no idea, why Don named this algo "LZ77".
'If somebody interesting,
'you can find brief description at http://www.rasip.fer.hr/research/compress/algorithms/index.html
'Unf. LZSS compression is not fast by definition (and this fact not directly
'depends of implementation) and commercial archivators use this algo in
'combination with arithmetic coding only.
' 6.11
#Compile Exe
#Dim All
#Register None
#Include "Win32Api.Inc"
$SourceFile = "C:\System.1St" ' <--- Change
$TargetFile = "C:\System.Lz
'=============================================================================
%LZSS_WINDOW_SIZE = 4096
%LZSS_MATCH_LENGTH_MAXIMUM = 18
%LZSS_MATCH_LENGTH_MINIMUM = 3
Function Compress_LZSS (InBuf As String, OutBuf As String) As Long
Dim InBufSize As Local Dword
Dim InBufCurAddr As Local Byte Ptr
Dim InBufEndAddr As Local Dword
Dim OutBufSize As Local Dword
Dim OutBufCurAddr As Local Byte Ptr
Dim OutBufEndAddr As Local Dword
Dim OutBufNewAddr As Local Byte Ptr
Dim WndBuf As Local String
Dim WndBufBaseAddr As Local Byte Ptr
Dim WndBufPos As Local Word
Dim WndEnt(&HFFFF??) As Local Word
Dim WndRef(%LZSS_WINDOW_SIZE) As Local Word
Dim WndSch As Word
Dim WndBufPosT As Local Word
Dim WndBufPosL As Local Word
Dim WndBufPosM As Local Word
Dim WndBufPosC As Local Word
Dim WndBufPosA As Local Dword
Dim WndSubLen As Local Word
Dim WndSubOff As Local Word
Dim WndSubBestLen As Local Word
Dim WndSubBestOff As Local Word
Dim MaxSearchChars As Local Dword
Dim LenAndOffSet As Local Word
Dim BitMask As Local Byte
Dim BitMaskAdd As Local Byte
InBufSize = Len(InBuf): If InBufSize < %LZSS_MATCH_LENGTH_MINIMUM Then _
OutBuf = "": Function = -1: Exit Function ' Nothing to compress
InBufCurAddr = StrPtr(InBuf)
InBufEndAddr = InBufCurAddr + InBufSize
OutBufSize = InBufSize ' maximum
OutBuf = Space$(OutBufSize)
OutBufCurAddr = StrPtr(OutBuf)
OutBufEndAddr = InBufCurAddr + OutBufSize
WndBuf = Space$(%LZSS_WINDOW_SIZE + %LZSS_MATCH_LENGTH_MAXIMUM - 1)
WndBufBaseAddr = StrPtr(WndBuf) - 1
WndBufPos = 1
Do
If InBufCurAddr >= InBufEndAddr Then Exit Do
OutBufNewAddr = OutBufCurAddr + 1: If CDwd(OutBufEndAddr - OutBufCurAddr) < 17 Then _
OutBuf = "": Function = -1: Exit Function ' 17 = 2 * 8 + 1
BitMask = 0: BitMaskAdd = 1
Do
WndSubBestLen = 2
MaxSearchChars = InBufEndAddr - InBufCurAddr
If MaxSearchChars > %LZSS_MATCH_LENGTH_MAXIMUM Then MaxSearchChars = %LZSS_MATCH_LENGTH_MAXIMUM
WndSch = @InBufCurAddr + @InBufCurAddr[1] * 256
WndBufPosT = WndEnt(WndSch)
While WndBufPosT
If @InBufCurAddr[WndSubBestLen] = @WndBufBaseAddr[WndBufPosT + WndSubBestLen] Then
WndSubLen = 2
For WndBufPosA = 2 To MaxSearchChars - 1
If @InBufCurAddr[WndBufPosA] <> @WndBufBaseAddr[WndBufPosT + WndBufPosA] Then Exit For
Incr WndSubLen
Next
If WndSubLen > WndSubBestLen Then
If (WndBufPosT + WndSubLen) <= (%LZSS_WINDOW_SIZE + 1) Then _
WndSubBestLen = WndSubLen: WndSubBestOff = WndBufPosT
End If
End If
WndBufPosT = WndRef(WndBufPosT)
Wend
If WndSubBestLen < %LZSS_MATCH_LENGTH_MINIMUM Then
BitMask = BitMask + BitMaskAdd
@OutBufNewAddr = @InBufCurAddr: Incr OutBufNewAddr
WndSubBestLen = 1
Else
LenAndOffSet = (WndSubBestLen - %LZSS_MATCH_LENGTH_MINIMUM) * &H1000 + (WndSubBestOff - 1)
@OutBufNewAddr = LoByt(LenAndOffset): Incr OutBufNewAddr
@OutBufNewAddr = HiByt(LenAndOffset): Incr OutBufNewAddr
End If
For WndBufPosA = 1 To WndSubBestLen
If WndBufPos > %LZSS_WINDOW_SIZE Then WndBufPos = 1
For WndBufPosC = 0 To 1
WndBufPosM = WndBufPos - WndBufPosC
If WndBufPosM Then
WndSch = @WndBufBaseAddr[WndBufPosM] + @WndBufBaseAddr[WndBufPosM + 1] * 256
WndBufPosT = WndEnt(WndSch)
WndBufPosL = 0
While WndBufPosT
If WndBufPosT = WndBufPosM Then
If WndBufPosL = 0 Then WndEnt(WndSch) = WndRef(WndBufPosM) Else _
WndRef(WndBufPosL) = WndRef(WndBufPosM)
WndRef(WndBufPosM) = 0: Exit Do
End If
WndBufPosL = WndBufPosT
WndBufPosT = WndRef(WndBufPosT)
Wend
End If
Next
@WndBufBaseAddr[WndBufPos] = @InBufCurAddr
For WndBufPosC = 0 To 1
WndBufPosM = WndBufPos - WndBufPosC
If WndBufPosM Then
WndSch = @WndBufBaseAddr[WndBufPosM] + @WndBufBaseAddr[WndBufPosM + 1] * 256
WndRef(WndBufPosM) = WndEnt(WndSch)
WndEnt(WndSch) = WndBufPosM
End If
Next
Incr WndBufPos
Incr InBufCurAddr
Next
If InBufCurAddr = InBufEndAddr Then Exit Loop
If BitMaskAdd = 128 Then Exit Do
BitMaskAdd = BitMaskAdd + BitMaskAdd
Loop
@OutBufCurAddr = BitMask
OutBufCurAddr = OutBufNewAddr
Loop
OutBuf = MkDwd$(InBufSize) + Left$(outBuf, OutBufCurAddr - StrPtr(OutBuf))
End Function
'=================================================================
Function DeCompress_LZSS (InBuf As String, OutBuf As String) As Long
Dim InBufSize As Local Dword
Dim InBufCurAddr As Local Byte Ptr
Dim InBufEndAddr As Local Dword
Dim OutBufSize As Local Dword
Dim OutBufCurAddr As Local Byte Ptr
Dim OutBufEndAddr As Local Dword
Dim WndBuf As Local String
Dim WndBufStartAddr As Local Byte Ptr
Dim WndBufCurAddr As Local Byte Ptr
Dim WndBufEndAddr As Local Dword
Dim WndBufSubstrAddr As Local Byte Ptr
Dim WndSubOff As Local Word
Dim WndSubLen As Local Word
Dim WndBufPosA As Local Word
Dim LenAndOffSet As Local Word
Dim BitMask As Local Byte
Dim BitMaskAdd As Local Byte
InBufSize = Len(InBuf)
If InBufSize < 4 Then Function = -1: Exit Function
InBufCurAddr = StrPtr(InBuf)
InBufEndAddr = InBufCurAddr + InBufSize
OutBufSize = CvDwd(InBuf, 1): InBufCurAddr = InBufCurAddr + 4
OutBuf = Space$(OutBufSize)
OutBufCurAddr = StrPtr(outBuf)
WndBuf = Space$(%LZSS_WINDOW_SIZE + %LZSS_MATCH_LENGTH_MAXIMUM - 1)
WndBufStartAddr = StrPtr(WndBuf)
WndBufEndAddr = WndBufStartAddr + %LZSS_WINDOW_SIZE
WndBufCurAddr = WndBufStartAddr
Do
If InBufCurAddr >= InBufEndAddr Then Exit Do
BitMask = @InBufCurAddr: Incr InBufCurAddr
BitMaskAdd = 1
Do
If InBufCurAddr >= InBufEndAddr Then Exit Do
If (BitMask And BitMaskAdd) Then
If WndBufCurAddr >= WndBufEndAddr Then WndBufCurAddr = WndBufStartAddr
@OutBufCurAddr = @InBufCurAddr
@WndBufCurAddr = @InBufCurAddr
Incr WndBufCurAddr: Incr InBufCurAddr: Incr OutBufCurAddr
Else
LenAndOffset = @InBufCurAddr + 256 * @InBufCurAddr[1]
InBufCurAddr = InBufCurAddr + 2
WndSubOff = LenAndOffset And &HFFF
Shift Right LenAndOffset, 12
WndSubLen = LenAndOffset + %LZSS_MATCH_LENGTH_MINIMUM
WndBufSubstrAddr = WndBufStartAddr + WndSubOff
For WndBufPosA = 1 To WndSubLen
@OutBufCurAddr = @WndBufSubstrAddr
Incr WndBufSubstrAddr: Incr OutBufCurAddr
Next
WndBufSubstrAddr = OutBufCurAddr - WndSubLen
For WndBufPosA = 1 To WndSubLen
If WndBufCurAddr >= WndBufEndAddr Then WndBufCurAddr = WndBufStartAddr
@WndBufCurAddr = @WndBufSubstrAddr
Incr WndBufCurAddr
Incr WndBufSubstrAddr
Next
End If
If BitMaskAdd = 128 Then Exit Do Else BitMaskAdd = BitMaskAdd + BitMaskAdd
Loop
Loop
End Function
Function PbMain
Local InBuf As String, InBuf2 As String, OutBuf As String
Local f As Long, t1 As Single, t2 As Single, t3 As Single
f = FreeFile: ErrClear: Open $SourceFile For Binary As #f
If Err = 0 Then Get$ #f, Lof(f), InBuf
Close #f
If Err Then MsgBox "Can't read the source file": Exit Function
t1 = Timer
If Compress_LZSS (InBuf, OutBuf) < 0 Then MsgBox "Can't compress": Exit Function
t2 = Timer
If Decompress_LZSS (OutBuf, inBuf2) Then MsgBox "Can't decompress": Exit Function
t3 = Timer
f = FreeFile: ErrClear: Open $TargetFile For Output As #f
If Err = 0 Then Print #f, OutBuf;
Close #f
If Err Then MsgBox "Can't write the target file": Exit Function
MsgBox "Compress: " + Format$(1000# * (t2 - t1), "#") + " ms" + $CrLf + _
"Decompress: " + Format$(1000# * (t3 - t2), "#") + " ms" + $CrLf + _
"Ratio: " + Format$(Len(InBuf)) + " -> " + Format$(Len(OutBuf))
If InBuf <> InBuf2 Then MsgBox "Problems"
End Function
------------------
E-MAIL: matus@perevozki.ru