Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Arithmetic Compression Example

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Arithmetic Compression Example

    The code below is a port from C++ code from http://www.bodden.de/ac/ .
    The code was modified to to support memory buffers instead of file streams.
    The port seems to be faster than the original code.
    BTW, the compression rate is far away from ZIP or RAR, but it is not
    all day evening yet.


    Code:
    #Compile Exe
    
    Macro Function SHL1(V, S)
        MacroTemp V1
        Dim V1 As Byte
        V1 = V
        Shift Left V1, S
    End Macro = V1
    
    Macro Function SHR1(V, S)
        MacroTemp V1
        Dim V1 As Byte
        V1 = V
        Shift Right V1, S
    End Macro = V1
    
    Macro Function SHL4(V, S)
        MacroTemp V1
        Dim V1 As Dword
        V1 = V
        Shift Left V1, S
    End Macro = V1
    
    Macro Function SHR4(V, S)
        MacroTemp V1
        Dim V1 As Dword
        V1 = V
        Shift Right V1, S
    End Macro = V1
    
    Macro SetBit(bit_)
        mBitBuffer = SHL1(mBitBuffer, 1) Or bit_
        Incr mBitCount
        If mBitCount = 8 Then
            @mWriteBuf = mBitBuffer
            mBitCount = 0
            Incr mWriteBuf
            Incr mWritten
        End If
    End Macro
    
    Macro SetBitFlush
        While mBitCount <> 0
            SetBit(0)
        Wend
    End Macro
    
    Macro Function GetBit()
        MacroTemp Bit_
        Dim Bit_ As Byte
        If mBitCount = 0 Then
            If mReadBuf < mReadBufEnd Then
                mBitBuffer = @mReadBuf
                Incr mReadBuf
            Else
                mBitBuffer = 0
            End If
            mBitCount = 8
        End If
        bit_ = SHR1(mBitBuffer, 7)
        mBitBuffer = SHL1(mBitBuffer, 1)
        Decr mBitCount
    End Macro = Bit_
    
    Macro Encode(low_count, high_count, total )
        mStep = ( mHigh - mLow + 1 ) \ total
        mHigh = mLow + mStep * high_count - 1
        mLow = mLow + mStep * low_count
        While ( mHigh < g_Half ) Or ( mLow >= g_Half )
            If( mHigh < g_Half ) Then
                SetBit( 0 )
                mLow = mLow * 2
                mHigh = mHigh * 2 + 1
                While mScale > 0
                    SetBit( 1 )
                    Decr mScale
                Wend
            Else
                If( mLow >= g_Half ) Then
                    SetBit( 1 )
                    mLow = 2 * ( mLow - g_Half )
                    mHigh = 2 * ( mHigh - g_Half ) + 1
                    While mScale > 0
                        SetBit( 0 )
                        Decr mScale
                    Wend
                End If
            End If
        Wend
        While ( ( g_FirstQuarter <= mLow ) And ( mHigh < g_ThirdQuarter ) )
            Incr mScale
            mLow = 2 * ( mLow - g_FirstQuarter )
            mHigh = 2 * ( mHigh - g_FirstQuarter ) + 1
        Wend
    End Macro
    
    Macro EncodeFinish()
        MacroTemp i
        Dim i As Dword
        If mLow < g_FirstQuarter Then
            SetBit( 0 )
            For i = 0 To mScale
                SetBit(1)
            Next
        Else
            SetBit(1)
        End If
        SetBitFlush
    End Macro
    
    Macro DecodeStart()
        MacroTemp i
        Dim i As Dword
        For i = 0 To 30
            mBuffer = SHL4(mBuffer, 1) Or GetBit
        Next
    End Macro
    
    Macro Function DecodeTarget(total)
        MacroTemp R
        Dim R As Dword
        mStep = (mHigh - mLow + 1) \ total
        R = (mBuffer - mLow) \ mStep
    End Macro = R
    
    Macro Decode(low_count, high_count)
        mHigh = mLow + mStep * high_count - 1
        mLow = mLow + mStep * low_count
        While (mHigh < g_Half) Or (mLow >= g_Half)
            If mHigh < g_Half Then
                mLow = mLow * 2
                mHigh = mHigh * 2 + 1
                mBuffer = 2 * mBuffer + GetBit
            Else
                If (mLow >= g_Half) Then
                    mLow = 2 * ( mLow - g_Half )
                    mHigh = 2 * ( mHigh - g_Half ) + 1
                    mBuffer = 2 * ( mBuffer - g_Half ) + GetBit
                End If
            End If
            mScale = 0
        Wend
        While (g_FirstQuarter <= mLow) And (mHigh < g_ThirdQuarter)
            Incr mScale
            mLow = 2 * (mLow - g_FirstQuarter)
            mHigh = 2 * (mHigh - g_FirstQuarter ) + 1
            mBuffer = 2 * (mBuffer - g_FirstQuarter ) + GetBit
        Wend
    End Macro
    
    Function CD_ompress(ByVal pInBuffer As Byte Ptr, ByVal cbInBuffer As Dword, ByVal pOutBuffer As Byte Ptr, ByVal cbOutBuffer As Dword, ByVal Mode As Dword) As Dword
        Dim mBitBuffer      As Byte
        Dim mBitCount       As Byte
        Dim mLow            As Dword
        Dim mHigh           As Dword
        Dim mStep           As Dword
        Dim mScale          As Dword
        Dim mBuffer         As Dword
        Dim mReadBuf        As Byte Ptr
        Dim mReadBufEnd     As Dword
        Dim mWriteBuf       As Byte Ptr
        Dim mWritten        As Dword
        Dim symbol          As Word
        Dim low_count       As Dword
        Dim j               As Byte
        Dim mTotal          As Dword
        Dim mCumCount(257)  As Dword
        Dim mValue          As Dword
        Dim g_FirstQuarter  As Dword
        Dim g_ThirdQuarter  As Dword
        Dim g_Half          As Dword
        Dim g_Signature     As Dword  Ptr
    
        g_FirstQuarter = &H20000000
        g_ThirdQuarter = &H60000000
        g_Half         = &H40000000
    
        For mTotal = 0 To 256
            mCumCount(mTotal) = 1
        Next
    
        mTotal = 257
        mBitCount = 0
        mBitBuffer = 0
    
        mLow = 0
        mHigh = &H7FFFFFFF
        mScale = 0
    
        mBuffer = 0
        mStep = 0
    
        mWriteBuf   = pOutBuffer
    
        If Mode = 0 Then
            mReadBuf    = pInBuffer
            mReadBufEnd = mReadBuf + cbInBuffer
            g_Signature = mWriteBuf
            @g_Signature = &H434D4341
            mWriteBuf = mWriteBuf + 4
            mWritten = mWritten + 4
            While mReadBuf < mReadBufEnd
                symbol = @mReadBuf
                low_count = 0
                For j=0 To symbol - 1
                    low_count = low_count + mCumCount(j)
                Next
                Encode (low_count, (low_count + mCumCount(j)), mTotal)
                Incr mCumCount(symbol)
                Incr mTotal
                Incr mReadBuf
            Wend
            Encode ((mTotal-1), mTotal, mTotal)
            EncodeFinish
        Else
            mReadBuf    = pInBuffer + 4
            mReadBufEnd = mReadBuf + cbInBuffer
            DecodeStart
            Do
                mValue = DecodeTarget(mTotal)
                low_count = 0
                symbol = 0
                While low_count + mCumCount(symbol) <= mValue
                    low_count = low_count + mCumCount(symbol)
                    Incr symbol
                Wend
                If symbol < 256 Then
                    @mWriteBuf = symbol
                    Incr mWriteBuf
                    Incr mWritten
                End If
                Decode (low_count, (low_count + mCumCount(symbol)) )
                Incr mCumCount(symbol)
                Incr mTotal
            Loop Until symbol = 256
        End If
        Function = mWritten
    End Function
    
    Function PbMain
    
        Dim s1 As String
        Dim s2 As String
        Dim l As Dword
        Dim w As Dword
        Dim i As Dword
        Dim b As Byte Ptr
        s1 = Repeat$(30000, "aes")
        l = Len(s1)
        s2 = String$(Len(s1) + 5, Chr$(0))
        w = CD_ompress(StrPtr(s1), Len(s1), StrPtr(s2), Len(s2), 0)
        MsgBox "compressed to" + Str$(w) + " chars"
        s1 = s2
        s2 = String$(l, Chr$(0))
        w = CD_ompress(StrPtr(s1), Len(s1), StrPtr(s2), Len(s2), 1)
        MsgBox "decompressed to" + Str$(w) + " chars"
    
    End Function
    ------------------

  • #2
    Torsten Rienow:

    I have tried your arithmeticcoding.bas code, but unfortunately, have not got it to work.
    I am using PB for Windows 7. Could you email me at drjb@uniserve.com? I would like to get this code up and running.

    Thanks,

    Joe Butler

    Comment

    Working...
    X