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

Arithmetic Coding

Algorithm creator(s)

Eric Bodden, Malte Clasen, Joachim Kneis


PB author(s)

Torsten Rienow


Description

Arithmetic Coding Data Compression


Note

The PB code is a port from C++ code from http://www.bodden.de/ac/ and modified to support memory buffers instead of file streams.


Source

https://forum.powerbasic.com/forum/user-to-user-discussions/source-code/24444-arithmetic-compression-example?t=23808


See also


Source Code

Download source code file arithmeticcoding.bas (Right-click -> "Save as ...")

#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

Mirror provided by Knuth Konrad