Code: Select all
Namespace Lzg9
Const sizeInt = SizeOf(Integer)
#Define MemCopy(adrIn,adrOut,size) fb_memcopy(*(adrOut),*(adrIn),size)
#Define WriteCaption() Poke Long,outData,&H09477A4C : WriteVarInt(inSize)
#Define OptSize(size) (size-1 And Not(sizeInt-1)) + sizeInt
#Macro WriteVarInt(value)
i = 1 : outValP = outData+indOut : inVal = value
*outValP = inVal And 127 : inVal Shr= 7
Do While inVal
outValP[i-1] Or= 128 : outValP[i] = inVal
inVal Shr= 7 : i += 1
Loop
indOut += i
#EndMacro
#Macro ReadVarInt(value)
k = 0 : inValP = inData+indIn : value = *inValP And 127
Do While inValP[k] > 127
k += 1 : value Or= Cast(Integer, inValP[k] And 127) Shl k*7
Loop
indIn += k+1
#EndMacro
#Macro AddHash4(adrIn)
h4 = Peek(ULong,adrIn)*41443 + (Peek(ULong,adrIn) Shr 16)
#EndMacro
#Macro AddHash42()
hash4(h4) = counter : counter += 1
#EndMacro
#Macro WriteFound()
If length > 4 Then
If length < 20 Then
outData[indOut] = 128 Or ((length-5) Shl 3) Or (distance And 7) : indOut += 1
Else
outData[indOut] = 248 Or (distance And 7) : indOut += 1
WriteVarInt(length-20)
EndIf
distance Shr= 3
Else
outData[indOut] = 64 Or (distance And 63)
distance Shr= 6 : indOut += 1
EndIf
#EndMacro
#Macro WriteFound2()
If length > 4 Then
If length < 20 Then
outData[indOut] = 128 Or ((length-5) Shl 3) Or (distance And 7)
indOut += 1 : sizeOldFound = 1
Else
outData[indOut] = 248 Or (distance And 7) : indOut += 1
WriteVarInt(length-20) : sizeOldFound = i+1
EndIf
distance Shr= 3
Else
outData[indOut] = 64 Or (distance And 63)
distance Shr= 6 : indOut += 1 : sizeOldFound = 1
EndIf
#EndMacro
#Macro AddFoundOfLiteral()
Do While (inData[indFound-1] = inData[indIn-1]) And (indFound > 0) And (literal > 0)
indFound -= 1 : indIn -= 1 : literal -= 1 : addLeft += 1 : length += 1
Loop
If literal Then
WriteLiteral(inData,outData,indIn,indOut,literal,adrLit)
Else
i = 1
Do While i <= dlnPred And ((inData[indFound-i] = inData[indIn-i]) And (indFound-i>0))
i += 1
Loop
If i > dlnPred Then
indIn -= dlnPred : addLeft += dlnPred
length += dlnPred : indOut -= sizeOldFound
EndIf
EndIf
#EndMacro
#Macro CompareFoundBlock(lenFound)
For i = indIn+lenFound To inLimit Step sizeInt
If Peek(Integer,inData+i) = Peek(Integer,inData+indFound+length) Then length += sizeInt Else Exit For
Next
#EndMacro
#Macro CompareFound()
For i = indIn+length To indMax
If inData[i] = inData[indFound+length] Then length += 1 Else Exit For
Next
#EndMacro
Sub WriteLiteral(ByRef inData As UByte Ptr,ByRef outData As UByte Ptr,_
ByRef indIn As Integer,ByRef indOut As Integer,_
ByRef size As Integer,ByRef adrLit As Integer)
If size < 49 Then
If size > 1 Then
outData[indOut] = size-2 : indOut += 1
Else
If adrLit Then
outData[adrLit] Or= inData[indIn-1] Shr 4
outData[indOut] = 15 And inData[indIn-1] Or 48 : adrLit = 0
Else
outData[indOut] = 48 : adrLit = indOut
indOut += 1 : outData[indOut] = inData[indIn-1]
EndIf
size = 0 : indOut += 1 : Exit Sub
EndIf
Else
Dim As UByte Ptr outValP : Dim As Integer inVal, i
outData[indOut] = 47 : indOut += 1
WriteVarInt(size-49)
EndIf
MemCopy(@inData[indIn-size],@outData[indOut],OptSize(size))
indOut += size : size = 0
End Sub
Function Compr1(inData As UByte Ptr,inSize As Integer,_
outData As UByte Ptr) As Integer
#Macro CreatingHash(adrIn)
h4 = (Peek(ULong,adrIn) Shl 4) + (Peek(ULong,adrIn) Shr 16)
#EndMacro
Dim As Integer literal,length,inLimit,i,inVal,indIn,adrLit
Dim As Integer indFound,distance,indOut=4,indMax=inSize-1
Dim As ULong counter,hash4(65535)
Dim As UShort h4
Dim As UByte Ptr outValP
WriteCaption()
If inSize > 3 Then
inLimit = inSize-8 : CreatingHash(inData) : hash4(h4) = indIn
EndIf
literal = 1 : indIn = 1
Do While indIn < inLimit
CreatingHash(inData+indIn) : indFound = hash4(h4)
If Peek(Long,inData+indFound) = Peek(Long,inData+indIn) Then
length = 4 : distance = indIn-indFound : CompareFoundBlock(4) : CompareFound()
EndIf
hash4(h4) = indIn
If length Then
Do While (inData[indFound-1] = inData[indIn-1]) And (indFound > 0) And (literal > 0)
indFound -= 1 : indIn -= 1 : literal -= 1 : length += 1
Loop
If literal Then
WriteLiteral(inData,outData,indIn,indOut,literal,adrLit)
EndIf
WriteFound() : WriteVarInt(distance) : indIn += length : length = 0
Else
literal += 1 : indIn += 1
EndIf
Loop
literal += inSize-indIn
If literal Then
WriteLiteral(inData,outData,inSize,indOut,literal,adrLit)
EndIf
Return indOut
End Function
Function Compr2(inData As UByte Ptr,inSize As Integer,_
outData As UByte Ptr) As Integer
Dim As Integer literal,length,inLimit,indIn,indMax=inSize-1
Dim As Integer i,inVal,indFound,addLeft,adrLit,distance,counter,indOut=4
Dim As UShort h4
Dim As ULong hash4(65535)
Dim As UByte Ptr outValP : WriteCaption()
If inSize > 7 Then
inLimit = inSize-8 : AddHash4(inData) : AddHash42()
EndIf
literal = 1 : indIn = 1
Do While indIn < inLimit
AddHash4(inData+indIn) : indFound = hash4(h4)
If Peek(Long,inData+indFound) = Peek(Long,inData+indIn) Then
length = 4 : distance = indIn-indFound : CompareFoundBlock(4) : CompareFound()
EndIf
AddHash42()
If length Then
Do While (inData[indFound-1] = inData[indIn-1]) And (indFound > 0) And (literal > 0)
indFound -= 1 : indIn -= 1 : literal -= 1 : addLeft += 1 : length += 1
Loop
If literal Then
WriteLiteral(inData,outData,indIn,indOut,literal,adrLit)
EndIf
WriteFound() : WriteVarInt(distance)
If indIn+length < inLimit Then
For outValP = inData+indIn+addLeft+1 To inData+indIn+length-1
AddHash4(outValP) : AddHash42()
Next
EndIf
indIn += length : length = 0 : addLeft = 0
Else
literal += 1 : indIn += 1
EndIf
Loop
literal += inSize-indIn
If literal Then
WriteLiteral(inData,outData,inSize,indOut,literal,adrLit)
EndIf
Return indOut
End Function
Function Compr3(inData As UByte Ptr,inSize As Integer,_
outData As UByte Ptr) As Integer
Dim As Integer i,indFound,literal,length,inLimit,indIn,inVal,indMax=inSize-1
Dim As Integer addLeft,adrLit,distance,counter,sizeOldFound,dlnPred,indOut=4
Dim As UShort h4 : Dim As ULong hash4(65535)
Dim As UByte Ptr outValP : WriteCaption()
If inSize > 7 Then
inLimit = inSize-8 : AddHash4(inData) : AddHash42()
EndIf
literal = 1 : indIn = 1
Do While indIn < inLimit
AddHash4(inData+indIn) : indFound = hash4(h4)
If Peek(Long,inData+indFound) = Peek(Long,inData+indIn) Then
length = 4 : distance = indIn-indFound : CompareFoundBlock(4) : CompareFound()
EndIf
AddHash42()
If length Then
AddFoundOfLiteral() : WriteFound2()
WriteVarInt(distance) : sizeOldFound += i
If indIn+length < inLimit Then
For outValP = inData+indIn+addLeft+1 To inData+indIn+length-1
AddHash4(outValP) : AddHash42()
Next
EndIf
dlnPred = length : indIn += length : length = 0 : addLeft = 0
Else
literal += 1 : indIn += 1
EndIf
Loop
literal += inSize-indIn
If literal Then
WriteLiteral(inData,outData,inSize,indOut,literal,adrLit)
EndIf
Return indOut
End Function
Function Compr4(inData As UByte Ptr,inSize As Integer,_
outData As UByte Ptr) As Integer
#Macro AddHash()
hash4(h4) = counter : hash8(h8) = counter : counter += 1
#EndMacro
#Macro CreatingHash(adrIn)
h4 = Peek(ULong,adrIn)*41443 + (Peek(ULong,adrIn) Shr 16)
h8 = Peek(ULong,adrIn+4)*67777 + (Peek(ULong,adrIn+4) Shr 16) + h4
#EndMacro
Dim As Integer i,indFound,literal,length,inLimit,indIn,inVal,indMax=inSize-1
Dim As Integer addLeft,adrLit,distance,counter,sizeOldFound,dlnPred,indOut=4
Dim As UShort h4,h8 : Dim As ULong hash4(65535),hash8(65535)
Dim As UByte Ptr outValP : WriteCaption()
If inSize > 7 Then
inLimit = inSize-8 : CreatingHash(inData) : AddHash()
EndIf
literal = 1 : indIn = 1
Do While indIn < inLimit
CreatingHash(inData+indIn) : indFound = hash8(h8)
If Peek(LongInt,inData+indFound) = Peek(LongInt,inData+indIn) Then
length = 8 : distance = indIn-indFound : CompareFoundBlock(8)
Else
indFound = hash4(h4)
If Peek(Long,inData+indFound) = Peek(Long,inData+indIn) Then
length = 4 : distance = indIn-indFound
EndIf
EndIf
AddHash()
If length Then
CompareFound() : AddFoundOfLiteral() : WriteFound2()
WriteVarInt(distance) : sizeOldFound += i
If indIn+length < inLimit Then
For outValP = inData+indIn+addLeft+1 To inData+indIn+length-1
CreatingHash(outValP) : AddHash()
Next
EndIf
dlnPred = length : indIn += length : length = 0 : addLeft = 0
Else
literal += 1 : indIn += 1
EndIf
Loop
literal += inSize-indIn
If literal Then
WriteLiteral(inData,outData,inSize,indOut,literal,adrLit)
EndIf
Return indOut
End Function
Function Compr5(inData As UByte Ptr,inSize As Integer,_
outData As UByte Ptr) As Integer
#Macro AddHash()
hash4(h4) = counter : hash8(h8) = counter : counter += 1
#EndMacro
#Macro CreatingHash(adrIn)
h4 = Peek(ULong,adrIn)*41443 + (Peek(ULong,adrIn) Shr 16)
h8 = (Peek(ULong,adrIn+4)*67777 + (Peek(ULong,adrIn+4) Shr 16) + h4) And bitMsk
#EndMacro
Dim As Integer i,indFound,literal,length,inLimit,indIn,inVal,indMax=inSize-1
Dim As Integer addLeft,adrLit,distance,counter,sizeOldFound,dlnPred,indOut=4,bitMsk=17
Do While (1 shl (bitMsk+4)) < inSize : bitMsk += 1 : Loop
bitMsk = (1 shl bitMsk) - 1
Dim As UShort h4 : Dim As ULong h8,hash4(65535)
Dim As UByte Ptr outValP : ReDim As ULong hash8(bitMsk) : WriteCaption()
If inSize > 7 Then
inLimit = inSize-8 : CreatingHash(inData) : AddHash()
EndIf
literal = 1 : indIn = 1
Do While indIn < inLimit
CreatingHash(inData+indIn) : indFound = hash8(h8)
If Peek(LongInt,inData+indFound) = Peek(LongInt,inData+indIn) Then
length = 8 : distance = indIn-indFound : CompareFoundBlock(8)
Else
indFound = hash4(h4)
If Peek(Long,inData+indFound) = Peek(Long,inData+indIn) Then
length = 4 : distance = indIn-indFound
EndIf
EndIf
AddHash()
If length Then
CompareFound() : AddFoundOfLiteral() : WriteFound2()
WriteVarInt(distance) : sizeOldFound += i
If indIn+length < inLimit Then
For outValP = inData+indIn+addLeft+1 To inData+indIn+length-1
CreatingHash(outValP) : AddHash()
Next
EndIf
dlnPred = length : indIn += length : length = 0 : addLeft = 0
Else
literal += 1 : indIn += 1
EndIf
Loop
literal += inSize-indIn
If literal Then
WriteLiteral(inData,outData,inSize,indOut,literal,adrLit)
EndIf
Return indOut
End Function
Function Compr6(inData As UByte Ptr,inSize As Integer,_
outData As UByte Ptr) As Integer
#Macro AddHash()
hash4(h4) = counter : hash6(h6) = counter : hash8(h8) = counter : counter += 1
#EndMacro
#Macro CreatingHash(adrIn)
h4 = Peek(ULong,adrIn)*41443 + (Peek(ULong,adrIn) Shr 16)
h6 = (Peek(ULong,adrIn+2)*67777 + h4) And bitMsk
h8 = (Peek(ULong,adrIn+4)*67777 + (Peek(ULong,adrIn+4) Shr 16) + h4) And bitMsk
#EndMacro
Dim As Integer i,indFound,literal,length,inLimit,indIn,inVal,indMax=inSize-1
Dim As Integer addLeft,adrLit,distance,counter,sizeOldFound,dlnPred,indOut=4,bitMsk=17
Do While (1 shl (bitMsk+4)) < inSize : bitMsk += 1 : Loop
bitMsk = (1 shl bitMsk) - 1
Dim As UByte Ptr outValP : Dim As UShort h4 : Dim As ULong h6,h8,hash4(65535)
ReDim As ULong hash6(bitMsk),hash8(bitMsk) : WriteCaption()
If inSize > 7 Then
inLimit = inSize-8 : CreatingHash(inData) : AddHash()
EndIf
literal = 1 : indIn = 1
Do While indIn < inLimit
CreatingHash(inData+indIn)
If literal < 192 Or (literal And 3) = 0 Then
indFound = hash8(h8)
If Peek(LongInt,inData+indFound) = Peek(LongInt,inData+indIn) Then
length = 8 : distance = indIn-indFound : CompareFoundBlock(8)
Else
#Define msk6B &H0000ffffffffffff
indFound = hash6(h6)
If ((Peek(LongInt,inData+indFound) Eqv Peek(LongInt,inData+indIn)) And msk6B) = msk6B Then
length = 6 : distance = indIn-indFound : CompareFoundBlock(6)
Else
indFound = hash4(h4)
If Peek(Long,inData+indFound) = Peek(Long,inData+indIn) Then
length = 4 : distance = indIn-indFound
EndIf
EndIf
EndIf
EndIf
AddHash()
If length Then
CompareFound() : AddFoundOfLiteral() : WriteFound2()
WriteVarInt(distance) : sizeOldFound += i
If indIn+length < inLimit Then
For outValP = inData+indIn+addLeft+1 To inData+indIn+length-1
CreatingHash(outValP) : AddHash()
Next
EndIf
dlnPred = length : indIn += length : length = 0 : addLeft = 0
Else
literal += 1 : indIn += 1
EndIf
Loop
literal += inSize-indIn
If literal Then
WriteLiteral(inData,outData,inSize,indOut,literal,adrLit)
EndIf
Return indOut
End Function
Function RaCompr(inData As UByte Ptr,inSize As Integer,_
outData As UByte Ptr) As Integer
Dim As Integer literal,sovpad,distance,indOut,k,indIn
Dim As UByte Ptr inValP : Dim As UByte bufProp,bufFl,komBait
Do
komBait = inData[indIn] : indIn += 1
If komBait > 63 Then
If komBait > 127 Then
sovpad = ((komBait Shr 3) And 15)
If sovpad < 15 Then
sovpad += 5
Else
ReadVarInt(sovpad) : sovpad += 20
EndIf
ReadVarInt(distance) : distance = (distance Shl 3) Or (komBait And 7)
Else
sovpad = 4 : ReadVarInt(distance)
distance = (distance Shl 6) Or (komBait And 63)
EndIf
If sovpad > distance Then
If distance >= 4 Then
For inValP = outData+indOut To outData+indOut+sovpad-1 Step 4
Poke Long, inValP, Peek(Long,inValP-distance)
Next
ElseIf distance < 3 Then
k = 4-distance
For inValP = outData+indOut To outData+indOut+k-1
*inValP = *(inValP-distance)
Next
For inValP = outData+indOut+k To outData+indOut+sovpad-1 Step 4
Poke Long, inValP, Peek(Long,inValP-4)
Next
Else
For inValP = outData+indOut To outData+indOut+sovpad-1 Step 3
Poke Long, inValP, Peek(Long,inValP-3)
Next
EndIf
Else
MemCopy(outData+indOut-distance,outData+indOut,OptSize(sovpad))
EndIf
indOut += sovpad
Else
If komBait < 48 Then
If komBait <> 47 Then
literal = komBait + 2
Else
ReadVarInt(literal) : literal += 49
EndIf
MemCopy(inData+indIn,outData+indOut,OptSize(literal))
indIn += literal : indOut += literal
Else
If bufFl Then
outData[indOut] = bufProp Or (komBait And 15) : bufFl = 0
Else
bufProp = komBait Shl 4 : bufFl = 1
outData[indOut] = inData[indIn] : indIn += 1
EndIf
indOut += 1
EndIf
EndIf
Loop While indIn < inSize
Return 1
End Function
Function ZapZglvk0(outData As UByte Ptr, inSize As Integer) As Integer
Dim As UByte Ptr outValP : Dim As Integer i,inVal,indOut=4
WriteCaption()
If inSize < 49 Then
outData[indOut] = IIf(inSize > 1,inSize-2,48)
indOut += 1
Else
outData[indOut] = 47 : indOut += 1
WriteVarInt(inSize-49)
EndIf
Return indOut
End Function
Function Compr0(zglvk As UByte Ptr,zglvkRzm As Integer,inData As UByte Ptr,_
inSize As Integer,outData As UByte Ptr) As Integer
MemCopy(zglvk,outData,zglvkRzm)
MemCopy(inData,outData+zglvkRzm,inSize)
Return inSize + zglvkRzm
End Function
#Macro Dekodmethod()
Var Compr = @Compr4
Select Case method
Case 1 : Compr = @Compr1
Case 2 : Compr = @Compr2
Case 3 : Compr = @Compr3
Case 5 : Compr = @Compr5
Case 6 : Compr = @Compr6
End Select
#EndMacro
Type TipaStr
As ZString Ptr data1
As Integer len1, size1
End Type
Function Compress OverLoad (vhSt As String, method As Integer=4) As String
If Len(vhSt) = 0 Then Return ""
If method Then
Dim As UByte Ptr outData = Allocate(Len(vhSt)*1.04+16)
If outData = 0 Then Return ""
Dekodmethod() : Var vihMasRazm = Compr(SAdd(vhSt),Len(vhSt),outData)
Dim As TipaStr sTip = Type(Cast(ZString Ptr,outData),vihMasRazm,vihMasRazm+1)
Function = *Cast(String Ptr, @sTip)
DeAllocate outData
Else
Dim As UByte zglvk(20) : Var rzZg = ZapZglvk0(@zglvk(0),Len(vhSt))
Var rz = Len(vhSt) + rzZg, vihSt = Space(rz)
If Len(vihSt) <> rz Then Return ""
Compr0(@zglvk(0),rzZg,SAdd(vhSt),Len(vhSt),SAdd(vihSt)) : Return vihSt
EndIf
End Function
Function Compress(inData As UByte Ptr,inSize As Integer,_
ByRef outData As UByte Ptr,method As Integer=4) As Integer
If inData = 0 Or inSize = 0 Then Return -1
If method Then
outData = Allocate(inSize*1.04+16)
If outData = 0 Then Return 0
Dekodmethod() : Return Compr(inData,inSize,outData)
Else
Dim As UByte zglvk(20) : Var rZg = ZapZglvk0(@zglvk(0),inSize)
outData = Allocate(inSize + rZg)
If outData = 0 Then Return 0
Return Compr0(@zglvk(0),rZg,inData,inSize,outData)
EndIf
End Function
Function HtZagolovok(inData As UByte Ptr, ByRef indIn As Integer) As Integer
If Peek(Long,inData) <> &H09477A4C Then Return 0
Dim As UByte Ptr inValP : Dim As Integer vihMasRazm, k
ReadVarInt(vihMasRazm) : Return vihMasRazm
End Function
Function Decompress OverLoad (vhSt As String) As String
If Len(vhSt) < 7 Then Return ""
Dim As UByte Ptr inData = SAdd(vhSt) : Var indIn = 4
Var vihMasRazm = HtZagolovok(inData,indIn)
If vihMasRazm = 0 Then Return ""
Dim As UByte Ptr outData = Allocate(vihMasRazm+8)
If outData = 0 Then Return ""
If RaCompr(inData+indIn,Len(vhSt)-indIn,outData) Then
Dim As TipaStr sTip = Type(Cast(ZString Ptr,outData),vihMasRazm,vihMasRazm+1)
Function = *Cast(String Ptr, @sTip)
EndIf
DeAllocate outData
End Function
Function Decompress(inData As UByte Ptr,inSize As Integer,_
ByRef outData As UByte Ptr) As Integer
If inData = 0 Or inSize < 7 Then Return -1
Var indIn = 4, vihMasRazm = HtZagolovok(inData,indIn)
If vihMasRazm = 0 Then Return 0
outData = Allocate(vihMasRazm+8)
If outData = 0 Then Return 0
If RaCompr(inData+indIn,inSize-indIn,outData) Then Return vihMasRazm
End Function
End Namespace
Code: Select all
#Include "lzg9.bas"
Using Lzg9
Dim As String s3, s2, s = "abracadabra abracadabra abracadabra abracadabra"
? : ?" Compress = ";
s2 = Compress(s) : ? "OK": ?
? " Decompress = ";
s3 = Decompress(s2) : ? "OK"
? : ? " size_in = "; Len(s)
? " size_out = "; Len(s2)
? : ? " Compare = "; IIf(s = s3, "Y", "N")
Sleep
Code: Select all
#Include "file.bi"
#Include "lzg9.bas"
Var file = ExePath & "\lzg9.bas"
Var ff = FreeFile, method = 4 ' method = 0..6(max)
Dim As ULong i, sizeIn, sizeCompr, sizeIn2
Dim As UByte Ptr p1,p2,p3
If FileExists(file) = 0 Then ? "No File for Compress!" : Sleep : End
Open file For Binary Access Read As ff
sizeIn = Lof(ff)
If sizeIn Then
p1 = Allocate(sizeIn)
Get #ff,,*p1,sizeIn
Else
? "No Data for Compress!" : Sleep : End
EndIf
Close ff
Var tm = Timer
? : ? " Compress = ";
sizeCompr = Lzg9.Compress(p1, sizeIn, p3, method)
? Using "##.### sek";(Timer-tm) : tm = Timer
? " Decompress = ";
sizeIn2 = Lzg9.Decompress(p3, sizeCompr, p2)
? Using "##.### sek"; (Timer-tm)
? : ? " sizeIn = "; sizeIn
? " sizeCompr = "; sizeCompr
? : ? " Compare = ";
If sizeIn = sizeIn2 Then
For i = 0 To sizeIn-1
If p1[i] <> p2[i] Then Exit For
Next
EndIf
If i = sizeIn Then ? "Y" Else ? "N"
ff = FreeFile
Open file & ".lzg" For Binary Access write Lock write As ff
Put #ff,,*p3,sizeCompr
Close ff
DeAllocate p1
DeAllocate p2
DeAllocate p3
Sleep