2017-12-15

Navigation

Skip Navigation Links

Hash algorithms

Asymmetric Algorithms

Symmetric Cipher Algorithms

Encoding Algorithms

Compression Algorithms

Pseudo Random Number Algorithms

Steganography

Library Wrappers

String Comparison

Others

Syntax highlighting by Prism
PBCrypto.com Mirror

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

Mirror provided by Knuth Konrad