'   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