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