LZW
Algorithm creator(s)
Abraham Lempel, Jakob Ziv, Terry Welch, Unisys
PB author(s)
Patrice Terrier
Description
LZW (like) compressor/decompressor
Note
n/a
Source
n/a
See also
n/a
Source Code
Download source code file lzw.bas (Right-click -> "Save as ...")
' LZW (like) code converted to 32-bit by Patrice Terrier
' http://www.zapsolution.com
' e-mail: pterrier@zapsolution.com
' These functions use only 32-bit API file I/O
'
DIM zTmp AS ASCIIZ * 128
'
TYPE HashRecCompType
First AS INTEGER
Nxt AS INTEGER
Char AS BYTE
Filler AS STRING * 3
END TYPE
'
TYPE HashRecDeCompType
Prev AS INTEGER
Char AS BYTE
Filler AS BYTE
END TYPE
'
FUNCTION Exist& (BYVAL FileSpec$) EXPORT
LOCAL fd AS WIN32_FIND_DATA
IF LEN(FileSpec$) THEN
hFind& = FindFirstFile(BYVAL STRPTR(FileSpec$), fd)
IF hFind& <> %INVALID_HANDLE_VALUE THEN
CALL FindClose(hFind&)
FUNCTION = -1
END IF
END IF
END FUNCTION
'
FUNCTION FOpen& (FileName$, BYVAL AccessMode%, BYVAL ShareMode%, hFile&) EXPORT
' This one is a generic binary file I/O using Win32 API calls.
'DIM lpSecurityAttributes AS SECURITY_ATTRIBUTES
'DIM lpOverlapped AS OVERLAPPED
'lpSecurityAttributes.nLength = SIZEOF(lpSecurityAttributes)
zTmp = FileName$
AccessMode% = MIN%(MAX%(AccessMode%, 0), 2) ' Coherce between 0-2
IF AccessMode% = 0 THEN ' 0 = Open file for reading only.
AccessIs& = %GENERIC_READ
ELSEIF AccessMode% = 1 THEN ' 1 = Open file for writing only.
AccessIs& = %GENERIC_WRITE
ELSE ' 2 = Open file for reading and writing.
AccessIs& = %GENERIC_READ OR %GENERIC_WRITE
END IF
ShareMode% = MIN%(MAX%(ShareMode%, 1), 4) ' Coherce between 1-4
IF ShareMode% = 1 THEN ' 1 = Deny read/write access.
ShareIs& = 0
ELSEIF ShareMode% = 2 THEN ' 2 = Deny write access.
ShareIs& = %FILE_SHARE_READ
ELSEIF ShareMode% = 3 THEN ' 3 = Deny read access.
ShareIs& = %FILE_SHARE_WRITE
ELSE ' 4 = Deny none (full share mode).
ShareIs& = %FILE_SHARE_READ OR %FILE_SHARE_WRITE
END IF
IF hFile& = -1 THEN
FlagAndAttribute& = %FILE_ATTRIBUTE_NORMAL OR %FILE_FLAG_WRITE_THROUGH
ELSE
FlagAndAttribute& = %FILE_ATTRIBUTE_NORMAL
END IF
hFile& = CreateFile(zTmp, AccessIs&, ShareIs&, BYVAL %NULL, %OPEN_ALWAYS, FlagAndAttribute&,
BYVAL %NULL)
IF hFile& = %INVALID_HANDLE_VALUE THEN ' -1 Fail to create the file
FUNCTION = GetLastError ' Set the error code
hFile& = 0 ' Reset handle number
END IF
END FUNCTION
'
FUNCTION FSeek& (hFile&, BYVAL PosByte& EXPORT
IF SetFilePointer(hFile&, PosByte&, BYVAL %NULL, %FILE_BEGIN) = &HFFFFFFFF THEN
FUNCTION = GetLastError
END IF
END FUNCTION
'
FUNCTION FPut& (BYVAL hFile&, Buf$) EXPORT
IF hFile& THEN
LenBuf& = LEN(Buf$)
IF LenBuf& THEN
IF WriteFile&(hFile&, BYVAL STRPTR(Buf$), LenBuf&, ByttesWritten&, BYVAL %NULL) = 0 THEN
FUNCTION = GetLastError
END IF
END IF
END IF
END FUNCTION
'
FUNCTION Flof& (BYVAL hFile&) EXPORT
IF GetFileType(hFile&) = %FILE_TYPE_DISK THEN
fSize& = GetFileSize(hFile&, BYVAL %NULL)
IF fSize& <> &HFFFFFFFF THEN FUNCTION = fSize&
END IF
END FUNCTION
'
FUNCTION FGet& (BYVAL hFile&, Buf$) EXPORT
IF hFile& THEN
LenBuf& = LEN(Buf$)
IF LenBuf& THEN
IF ReadFile&(hFile&, BYVAL STRPTR(Buf$), LenBuf&, ByttesReaded&, BYVAL %NULL) = 0 THEN
FUNCTION = GetLastError
END IF
END IF
END IF
END FUNCTION
'
FUNCTION FGetAt& (BYVAL hFile&, BYVAL PosByte&, Buf$) EXPORT
ErrCode& = FSeek&(hFile&, PosByte&)
IF ErrCode& = 0 THEN ErrCode& = FGet&(hFile&, Buf$)
FUNCTION = ErrCode&
END FUNCTION
'
FUNCTION LZW! (BYVAL FileIn$, BYVAL FileOut$, ErrCode&) EXPORT
ErrCode& = 0
IF Exist(FileIn$) THEN ' Open source file
ErrCode& = FOpen& (FileIn$, 0, 2, InHandle&)
ELSE
ErrCode& = 2& ' File not found alias error 53 for DOS
END IF
IF ErrCode& = 0 THEN ' Create target file
CALL dvKillFile(FileOut$)
ErrCode& = FOpen& (FileOut$, 1, 1, OutHandle&)
END IF
IF ErrCode& THEN
CALL CloseHandle(InHandle&)
CALL CloseHandle(OutHandle&)
EXIT FUNCTION
END IF
MaxDim% = 16384
BytesToComp& = Flof&(InHandle&)
REDIM HashRec(0 TO MaxDim%) AS HashRecCompType
IF BytesToComp& >= MaxDim% THEN
InBufLen% = MaxDim%
ELSE
InBufLen% = BytesToComp&
END IF
Sign$ = CHR$(90,0,158,155) ' "Z"+CHR$(0)+"��"
InBuf$ = SPACE$(InBufLen%)
OutBuf$ = STRING$(MaxDim%, 0)
OutBufPos% = 1
BitPos% = 1
FOR Temp% = 0 TO 255
HashRec(Temp%).First = -1
HashRec(Temp%).Nxt = -1
NEXT
ErrCode& = FGet(InHandle&, InBuf$)
BytesRead& = InBufLen%
W% = ASC(InBuf$): InBufPos% = 2: ToP% = 257: CodeSize% = 9: NextMax% = 512
StartLoc:
IF InBufPos% > InBufLen% THEN
IF BytesRead& >= BytesToComp& THEN
GOTO EndLoc
ELSE
IF (BytesToComp& - BytesRead&) < InBufLen% THEN
InBufLen% = BytesToComp& - BytesRead&
InBuf$ = SPACE$(InBufLen%)
END IF
ErrCode& = FGet(InHandle&, InBuf$)
InBufPos% = 1
BytesRead& = BytesRead& + InBufLen%
END IF
ELSE
K% = ASC(InBuf$, InBufPos%)
IF HashRec(W%).First = -1 THEN
HashRec(W%).First = ToP%
GOSUB AddChar
ELSE
Flag = -1
ChainBufPos% = HashRec(W%).First
WHILE Flag
IF HashRec(ChainBufPos%).Char = CBYT(K%) THEN
Flag = 0
W% = ChainBufPos%
ELSE
IF HashRec(ChainBufPos%).Nxt <> -1 THEN
ChainBufPos% = HashRec(ChainBufPos%).Nxt
ELSE
Flag = 0
HashRec(ChainBufPos%).Nxt = ToP%
GOSUB AddChar
END IF
END IF
WEND
END IF
InBufPos% = InBufPos% + 1
END IF
GOTO StartLoc
EndLoc:
GOSUB AddChar
W% = K%
GOSUB AddChar
OutBufPos% = OutBufPos% - 1
IF OutBufPos% THEN
OutBuf$ = LEFT$(OutBuf$, OutBufPos%)
ErrCode& = FPut(OutHandle&, OutBuf$)
END IF
ERASE HashRec
fSize& = GetFileSize(OutHandle&, BYVAL %NULL)
IF fSize& > 0 THEN ' Add the signature
ErrCode& = FPut(OutHandle&, Sign$)
FUNCTION = fSize& * 100 / BytesToComp&
END IF
CALL CloseHandle(InHandle&)
CALL CloseHandle(OutHandle&)
InBuf$ = "": OutBuf$ = ""
EXIT FUNCTION
AddChar:
IF BitPos% > 0 AND BitPos% < 8 THEN
Mul% = ASC(CHR$(1,2,4,8,16,32,64), BitPos%)
ELSE
Mul% = 128
END IF
WorkBuf& = WorkBuf& + W% * Mul%
BitPos% = BitPos% + CodeSize%
WHILE BitPos% > 8
MiC% = CINT(WorkBuf& AND &HFF)
ASC(OutBuf$, OutBufPos%) = MiC%
WorkBuf& = WorkBuf& \ 256
BitPos% = BitPos% - 8
IF OutBufPos% = MaxDim% THEN
ErrCode& = FPut&(OutHandle&, OutBuf$)
OutBufPos% = 1
ELSE
OutBufPos% = OutBufPos% + 1
END IF
WEND
HashRec(ToP%).Char = CBYT(K%)
HashRec(ToP%).First = -1
HashRec(ToP%).Nxt = -1
ToP% = ToP% + 1
IF ToP% = NextMax% THEN
SELECT CASE ToP%
CASE MaxDim%
SELECT CASE BitPos%
CASE 1
AddValue& = 256
CASE 2
AddValue& = 512
CASE 3
AddValue& = 1024
CASE 4
AddValue& = 2048
CASE 5
AddValue& = 4096
CASE 6
AddValue& = 8192
CASE 7
AddValue& = 16384
CASE ELSE
AddValue& = 32768
END SELECT
WorkBuf& = WorkBuf& + AddValue&
BitPos% = BitPos% + CodeSize%
WHILE BitPos% > 8
MiC% = CINT(WorkBuf& AND &HFF)
ASC(OutBuf$, OutBufPos%) = MiC%
WorkBuf& = WorkBuf& \ 256
BitPos% = BitPos% - 8
IF OutBufPos% = MaxDim% THEN
ErrCode& = FPut&(OutHandle&, OutBuf$)
OutBufPos% = 1
ELSE
OutBufPos% = OutBufPos% + 1
END IF
WEND
FOR Temp% = 0 TO 255
HashRec(Temp%).First = -1
HashRec(Temp%).Nxt = -1
NEXT
Top% = 257
CodeSize% = 9
NextMax% = 512
CASE ELSE
CodeSize% = CodeSize% + 1
NextMax% = NextMax% + NextMax%
END SELECT
END IF
W% = K%
RETURN
END FUNCTION
'
FUNCTION UnLZW& (BYVAL FileIn$, BYVAL FileOut$, ErrCode&) EXPORT
FUNCTION = -1
ErrCode& = 0
IF Exist(FileIn$) THEN ' Open source file
ErrCode& = FOpen& (FileIn$, 0, 2, InHandle&)
ELSE
ErrCode& = 2& ' File not found alias error 53 for DOS
END IF
IF ErrCode& = 0 THEN ' Create target file
BytesToRead& = Flof&(InHandle&)
IF BytesToRead& > 3& THEN
Sign$ = CHR$(90,0,158,155) ' "Z"+CHR$(0)+"��"
InBuf$ = Sign$
BytesToRead& = BytesToRead& - 4&
CALL FGetAt(InHandle&, BytesToRead&, InBuf$)
IF InBuf$ <> Sign$ THEN
BadFile% = -1: FUNCTION = 0
ELSE
CALL FSeek(InHandle&, 0&)
CALL DeleteFile(BYVAL STRPTR(FileOut$))
ErrCode& = FOpen& (FileOut$, 1, 1, OutHandle&)
END IF
ELSE
BadFile% = -1: FUNCTION = 0
END IF
END IF
IF ErrCode& OR BadFile% THEN
CALL CloseHandle(InHandle&)
CALL CloseHandle(OutHandle&)
EXIT FUNCTION
END IF
MaxDim% = 16384
DIM Mask%(1 TO 6), BitPosMult%(0 TO 13)
IF BytesToRead& >= MaxDim% THEN
InBufLen% = MaxDim%
ELSE
InBufLen% = BytesToRead&
END IF
InBuf$ = SPACE$(InBufLen%)
OutBuf$ = STRING$(MaxDim%, 0)
ErrCode& = FGet(InHandle&, InBuf$)
BytesRead& = InBufLen%
OutBufPos% = 1
InPos% = 1
BitPos% = 0
Mask%(1) = 511
Mask%(2) = 1023
Mask%(3) = 2047
Mask%(4) = 4095
Mask%(5) = 8191
Mask%(6) = 16383
P2% = 1 ' Calcule puissances de 2 de 1 � 8192
FOR K% = 0 TO 13
BitPosMult(K%) = P2%: P2% = P2% * 2
NEXT
InitDeComp:
REDIM HashRec(0 TO MaxDim%) AS HashRecDeCompType
REDIM StackTemp%(0 TO 4096)
MaskNum% = 1: CodeSize% = 9: Top% = 257
WHILE BitPos% < CodeSize%
InVal% = ASC(InBuf$, InPos%)
WorkBuf& = WorkBuf& + (InVal% * BitPosMult(BitPos%))
BitPos% = BitPos% + 8
InPos% = InPos% + 1
IF InPos% > InBufLen% THEN
IF BytesRead& >= BytesToRead& THEN
OutBufPos% = OutBufPos% - 1
IF OutBufPos% THEN
OutBuf$ = LEFT$(OutBuf$, OutBufPos%)
ErrCode& = FPut(OutHandle&, OutBuf$)
END IF
CALL CloseHandle(InHandle&)
CALL CloseHandle(OutHandle&)
EXIT FUNCTION
END IF
IF (BytesToRead& - BytesRead&) < InBufLen% THEN
InBufLen% = BytesToRead& - BytesRead&
InBuf$ = SPACE$(InBufLen%)
END IF
ErrCode& = FGet(InHandle&, InBuf$)
BytesRead& = BytesRead& + InBufLen%
InPos% = 1
END IF
WEND
W% = WorkBuf& AND Mask%(MaskNum%)
WorkBuf& = WorkBuf& \ (Mask%(MaskNum%) + 1)
BitPos% = BitPos% - CodeSize%
InCode% = W%
K% = W%
OldCode% = W%
FinChar% = W%
ASC(OutBuf$, OutBufPos%) = K%
OutBufPos% = OutBufPos% + 1
StackPtr% = 0
NextMax& = 511
DeCompLoop:
WHILE BitPos% < CodeSize%
InVal% = ASC(InBuf$, InPos%)
WorkBuf& = WorkBuf& + (InVal% * BitPosMult(BitPos%))
BitPos% = BitPos% + 8
InPos% = InPos% + 1
IF InPos% > InBufLen% THEN
IF BytesRead& >= BytesToRead& THEN
OutBufPos% = OutBufPos% - 1
IF OutBufPos% THEN
OutBuf$ = LEFT$(OutBuf$, OutBufPos%)
ErrCode& = FPut(OutHandle&, OutBuf$)
END IF
InBuf$ = "": OutBuf$ = ""
ERASE HashRec, StackTemp%
CALL CloseHandle(InHandle&)
CALL CloseHandle(OutHandle&)
EXIT FUNCTION
END IF
IF (BytesToRead& - BytesRead&) < InBufLen% THEN
InBufLen% = BytesToRead& - BytesRead&
InBuf$ = SPACE$(InBufLen%)
END IF
ErrCode& = FGet(InHandle&, InBuf$)
BytesRead& = BytesRead& + InBufLen%
InPos% = 1
END IF
WEND
W% = WorkBuf& AND Mask%(MaskNum%)
WorkBuf& = WorkBuf& \ (Mask%(MaskNum%) + 1)
BitPos% = BitPos% - CodeSize%
IF W% <> 256 THEN
InCode% = W%
IF W% = Top% THEN
StackPtr% = StackPtr% + 1
StackTemp%(StackPtr%) = FinChar%
W% = OldCode%
END IF
WHILE (W% AND &HFF00)
Char% = HashRec(W%).Char
Code% = HashRec(W%).Prev
StackPtr% = StackPtr% + 1
StackTemp%(StackPtr%) = Char%
W% = Code%
WEND
K% = W%
FinChar% = W%
ASC(OutBuf$, OutBufPos%) = W%
OutBufPos% = OutBufPos% + 1
IF OutBufPos% > MaxDim% THEN
ErrCode& = FPut&(OutHandle&, OutBuf$)
OutBufPos% = 1
END IF
WHILE StackPtr% > 0
ASC(OutBuf$, OutBufPos%) = StackTemp%(StackPtr%)
OutBufPos% = OutBufPos% + 1
IF OutBufPos% > MaxDim% THEN
ErrCode& = FPut&(OutHandle&, OutBuf$)
OutBufPos% = 1
END IF
StackPtr% = StackPtr% - 1
WEND
HashRec(Top%).Char = K%
HashRec(Top%).Prev = OldCode%
OldCode% = InCode%
Top% = Top% + 1
IF Top% = NextMax& THEN
IF NextMax& <> 16383 THEN
CodeSize% = CodeSize% + 1
MaskNum% = MaskNum% + 1
NextMax& = NextMax& + NextMax& + 1
END IF
END IF
GOTO DeCompLoop
ELSE
GOTO InitDeComp
END IF
END FUNCTION