Task: LZW compression








VB: Option Explicit
Const numchars=127  

Function LZWCompress(si)
  Dim oDict,  intMaxCode, i,z,ii,ss,strCurrent,strNext,j
  Set oDict = CreateObject("Scripting.Dictionary")
  ReDim a(Len(si))
  
  intMaxCode = numchars
  For i = 0 To numchars
    oDict.Add Chr(i), i
  Next
  
  strCurrent = Left(si,1)
  j=0
  For ii=2 To Len(si)
    strNext = Mid(si,ii,1)
    ss=strCurrent & strNext
    If oDict.Exists(ss) Then
      strCurrent = ss
    Else
      a(j)=oDict.Item(strCurrent) :j=j+1
      intMaxCode = intMaxCode + 1
      oDict.Add ss, intMaxCode
      strCurrent = strNext
    End If
  Next
  a(j)=oDict.Item(strCurrent) 
  ReDim preserve a(j)
  LZWCompress=a
  Set oDict = Nothing
End Function

Function lzwUncompress(sc)
  Dim intNext, intCurrent, intMaxCode, i,ss,istr,s,j
  s=""     
  reDim dict(1000)
  intMaxCode = numchars
  For i = 0 To numchars : dict(i)= Chr(i) :  Next
    intCurrent=sc(0)
    
    For j=1 To UBound(sc)
      ss=dict(intCurrent)
      s= s & ss
      intMaxCode = intMaxCode + 1
      intnext=sc(j)
      If intNext<intMaxCode Then
        dict(intMaxCode)=ss & Left(dict(intNext), 1)
      Else
        dict(intMaxCode)=ss & Left(ss, 1) 
      End If
      intCurrent = intNext
    Next
    s= s & dict(intCurrent)
    lzwUncompress=s
End function

Sub printvec(a)
  Dim s,i,x
  s="("
  For i=0 To UBound (a)
   s=s & x & a(i)
   x=", "
  Next 
  WScript.echo s &")"
End sub

Dim a,b
b="TOBEORNOTTOBEORTOBEORNOT"
WScript.Echo b
a=LZWCompress (b)
printvec(a)
WScript.echo lzwUncompress (a )
wscript.quit 1



Fortran: 









      MODULE LZW_SHARED_PARAMETERS
      IMPLICIT NONE



      INTEGER , PARAMETER  ::  COMPILER_INTEGER_SIZE = 32 , BITS = 12 , FILEIN = 66 ,     &
                             & FILEOUT = 99 , MAX_VALUE = (2**BITS) - 1 ,                 &
                             & MAX_CODE = MAX_VALUE - 1 , MAX_DICTIONARY_SIZE = 5021 ,    &
                             & SYMBOL_SIZE = 8 , MISSING_BITS = COMPILER_INTEGER_SIZE -   &
                             & SYMBOL_SIZE



      INTEGER , DIMENSION(0:MAX_DICTIONARY_SIZE)  ::  concatenatedsymbols
      INTEGER , DIMENSION(0:MAX_DICTIONARY_SIZE)  ::  prefixcodes
      INTEGER  ::  the_status = 0


 
      END MODULE LZW_SHARED_PARAMETERS










      MODULE CODECIO
      USE LZW_SHARED_PARAMETERS
      IMPLICIT NONE

      CONTAINS
      SUBROUTINE SETOUTPUTCODE(Code)
      IMPLICIT NONE



      INTEGER  ::  Code
      INTENT (IN) Code



      INTEGER  ::  buffer
      INTEGER  ::  outputbitbuffer = 0
      INTEGER  ::  outputbitcount = 0
      INTEGER  ::  shift
      INTEGER  ::  shiftedsymbol

      shift = COMPILER_INTEGER_SIZE - BITS - outputbitcount
      shiftedsymbol = ISHFT(Code , shift)
      outputbitbuffer = IOR(outputbitbuffer , shiftedsymbol)
      outputbitcount = outputbitcount + BITS
 
      DO WHILE(outputbitcount >= SYMBOL_SIZE)

         buffer = ISHFT(outputbitbuffer , -MISSING_BITS)
         CALL SETRAWBYTE(buffer)
         outputbitbuffer = ISHFT(outputbitbuffer , SYMBOL_SIZE)
         outputbitcount = outputbitcount - SYMBOL_SIZE
      END DO
      RETURN
      END SUBROUTINE SETOUTPUTCODE
 
 
      SUBROUTINE SETRAWBYTE(Symbol)
      IMPLICIT NONE



      INTEGER  ::  Symbol
      INTENT (IN) Symbol

 
      CALL FPUTC(FILEOUT , ACHAR(Symbol))
      END SUBROUTINE SETRAWBYTE
 
 
      FUNCTION GETRAWBYTE()
      IMPLICIT NONE



      INTEGER  ::  GETRAWBYTE



      CHARACTER  ::  bufferedbyte

      CALL FGETC(FILEIN , bufferedbyte , THE_status)
      GETRAWBYTE = IACHAR(bufferedbyte)
      END FUNCTION GETRAWBYTE
 
      FUNCTION GETINPUTCODE()
      IMPLICIT NONE



      INTEGER  ::  GETINPUTCODE



      INTEGER  ::  inputbitbuffer = 0
      INTEGER  ::  inputbitcounter = 0
      INTEGER  ::  integerinputbuff
      INTEGER  ::  returnn
      INTEGER  ::  shiftedbit

      DO WHILE( inputbitcounter <= MISSING_BITS )

         integerinputbuff = GETRAWBYTE()
         shiftedbit = ISHFT(integerinputbuff , MISSING_BITS - inputbitcounter)
         inputbitbuffer = IOR(inputbitbuffer , shiftedbit)
         inputbitcounter = inputbitcounter + SYMBOL_SIZE
      END DO
 
      returnn = ISHFT(inputbitbuffer , BITS - COMPILER_INTEGER_SIZE)
      inputbitbuffer = ISHFT(inputbitbuffer , BITS)
      inputbitcounter = inputbitcounter - BITS
      GETINPUTCODE = returnn
      RETURN
      END FUNCTION GETINPUTCODE
end module codecIO









      MODULE LZW_ENCODER
      USE LZW_SHARED_PARAMETERS
      USE CODECIO
      IMPLICIT NONE



      INTEGER , PARAMETER  ::  HASH_SHIFT = BITS - SYMBOL_SIZE



      INTEGER , DIMENSION(0:MAX_DICTIONARY_SIZE)  ::  symbolvalues
      CONTAINS
      SUBROUTINE COMPRESS()
      IMPLICIT NONE



      INTEGER  ::  codedsymbol
      INTEGER  ::  my_index
      INTEGER  ::  nextsymbol
      INTEGER  ::  symbol
      CHARACTER  ::  bufferedbyte

      nextsymbol = COMPILER_INTEGER_SIZE*SYMBOL_SIZE
      SYMbolvalues(:) = -1
 

      CALL FGETC(FILEIN , bufferedbyte , THE_status)
      codedsymbol = IACHAR(bufferedbyte)

      DO WHILE(THE_status == 0)

          CALL FGETC(FILEIN , bufferedbyte , THE_status)
          symbol = IACHAR(bufferedbyte)
         IF( THE_status/=0 )CYCLE
 
         my_index = GETPOSITIONONDICTIONARY(codedsymbol , symbol)
         IF( SYMbolvalues(my_index)/= - 1 )THEN
            codedsymbol = SYMbolvalues(my_index)
         ELSE
            IF( nextsymbol<=MAX_CODE )THEN
               SYMbolvalues(my_index) = nextsymbol
               nextsymbol = nextsymbol + 1
               PREfixcodes(my_index) = codedsymbol
               CONcatenatedsymbols(my_index) = symbol
            END IF
            CALL SETOUTPUTCODE(codedsymbol)
            codedsymbol = symbol
         END IF
      END DO
      CALL SETOUTPUTCODE(codedsymbol)
      CALL SETOUTPUTCODE(MAX_VALUE)
      CALL SETOUTPUTCODE(0)
      END SUBROUTINE COMPRESS
 
function getPositionOnDictionary(hashPrefix, hashSymbol)
      integer, intent(in) :: hashPrefix
      integer, intent(in) :: hashSymbol
      integer             :: getPositionOnDictionary
      integer             :: index
      integer             :: offset

      index = ishft(hashSymbol, HASH_SHIFT)
      index = ieor(index, hashPrefix)
      if (index == 0) then
        offset = 1
      else
        offset = MAX_DICTIONARY_SIZE - index
      endif

      do
        if (symbolValues(index) == -1) then
          getPositionOnDictionary = index
          exit
        endif

        if (prefixCodes(index) == hashPrefix .and. &
            & concatenatedSymbols(index) == hashSymbol) then
          getPositionOnDictionary = index
          exit
        endif

        index = index - offset
        if (index < 0) then
          index = index + MAX_DICTIONARY_SIZE
        endif
      end do
      return
    end function

end module LZW_Encoder









      MODULE LZW_DECODER
      USE LZW_SHARED_PARAMETERS
      USE CODECIO
      IMPLICIT NONE



      TYPE :: DECODE_BUFFER_STACK
         INTEGER , DIMENSION(0:MAX_DICTIONARY_SIZE)  ::  DECODERSTACK
         INTEGER  ::  TOP
      END TYPE DECODE_BUFFER_STACK



      TYPE(DECODE_BUFFER_STACK)  ::  stack
      CONTAINS


      SUBROUTINE DECOMPRESS()
      IMPLICIT NONE



      INTEGER  ::  newsymbol
      INTEGER  ::  nextsymbol
      INTEGER  ::  oldsymbol
      INTEGER  ::  popedsymbol
      INTEGER  ::  symbol

      nextsymbol = COMPILER_INTEGER_SIZE*SYMBOL_SIZE
      oldsymbol = GETINPUTCODE()
      symbol = oldsymbol
 
      CALL SETRAWBYTE(oldsymbol)
 
      DO
         newsymbol = GETINPUTCODE()
 
         IF( newsymbol==MAX_VALUE )RETURN
 
         IF( newsymbol>=nextsymbol )THEN
            STAck%DECODERSTACK(0) = symbol
            CALL DECODESYMBOL(STAck%DECODERSTACK(1:) , oldsymbol)
         ELSE
            CALL DECODESYMBOL(STAck%DECODERSTACK(:) , newsymbol)
         END IF
 
         symbol = STAck%DECODERSTACK(STAck%TOP)
 
         DO WHILE ( STAck%TOP>=0 )
            popedsymbol = STAck%DECODERSTACK(STAck%TOP)
            CALL SETRAWBYTE(popedsymbol)
            STAck%TOP = STAck%TOP - 1
         END DO
 
         IF( nextsymbol<=MAX_CODE )THEN
            PREfixcodes(nextsymbol) = oldsymbol
            CONcatenatedsymbols(nextsymbol) = symbol
            nextsymbol = nextsymbol + 1
         END IF
         oldsymbol = newsymbol
      END DO
      RETURN
      END SUBROUTINE DECOMPRESS
  
      SUBROUTINE DECODESYMBOL(Buffer , Code)
      IMPLICIT NONE



      INTEGER  ::  Code
      INTEGER , DIMENSION(:)  ::  Buffer
      INTENT (IN) Code
      INTENT (INOUT) Buffer



      INTEGER  ::  i
      INTEGER  ::  j
      INTEGER  ::  symbol

      j = 0
      symbol = Code
      STAck%TOP = 0
      DO WHILE ( symbol>=COMPILER_INTEGER_SIZE*SYMBOL_SIZE )
 
 
         IF( j>=MAX_CODE )THEN
            PRINT * , "Decoding error"
            STOP
         END IF
 
         i = STAck%TOP + 1
         Buffer(i) = CONcatenatedsymbols(symbol)
         symbol = PREfixcodes(symbol)
         STAck%TOP = STAck%TOP + 1
         j = j + 1
      END DO
      i = j + 1
      Buffer(i) = symbol
      END SUBROUTINE DECODESYMBOL
end module LZW_Decoder









 
      MODULE LZW
      USE LZW_SHARED_PARAMETERS
      USE LZW_ENCODER
      USE LZW_DECODER
      IMPLICIT NONE
      CONTAINS
      SUBROUTINE INIT(Input , Output , Operation , Filename)
      IMPLICIT NONE



      CHARACTER(100)  ::  Filename
      CHARACTER(100)  ::  Input
      CHARACTER(1)  ::  Operation
      CHARACTER(100)  ::  Output
      INTENT (IN) Filename , Input , Operation , Output

      IF( Operation/='d' .AND. Operation/='e' )THEN
         PRINT * , "Usage: " // TRIM(Filename) // " <operation> input output"
         PRINT * , "Possible operations: "
         PRINT * , "    e -> encode (compress)"
         PRINT * , "    d -> decode (inflate)"
         STOP
      END IF
 
      OPEN(UNIT = FILEIN , FILE = Input , ACTION = "read" , STATUS = "old" ,              &
          &ACCESS = 'stream' , FORM = "formatted")
      OPEN(UNIT = FILEOUT , FILE = Output , ACTION = "write" , STATUS = "replace" ,       &
         & ACCESS = 'stream' , FORM = "formatted")
 
      IF( Operation=='d' )THEN
         PRINT * , "Decoding..."
         CALL DECOMPRESS()
      ELSE
         PRINT * , "Encoding..."
         CALL COMPRESS()
      END IF
 
      CLOSE(UNIT = FILEIN)
      CLOSE(UNIT = FILEOUT)
      END SUBROUTINE INIT
end module LZW

      PROGRAM MAIN
      USE LZW
      IMPLICIT NONE



      CHARACTER(100)  ::  filename
      REAL  ::  finish
      CHARACTER(100)  ::  input
      CHARACTER(1)  ::  operation
      CHARACTER(100)  ::  output
      REAL  ::  start

      CALL GETARG(0 , filename)
      CALL GETARG(1 , operation)
      CALL GETARG(2 , input)
      CALL GETARG(3 , output)
      CALL CPU_TIME(start)
      CALL INIT(input , output , operation , filename)
      CALL CPU_TIME(finish)
      PRINT '("Time = ",f6.3," seconds.")' , finish - start
      END PROGRAM MAIN