| Im Folgenden werde ich keine vollständigen Quelltexte abbilden, sondern jeweils nur die interessanten Teile. Um die vollständigen Quelltexte einzusehen, kann man sich das Beispielprojekt herunterladen. Die Liste Public Sub Push(Node As Pointer, Frequency As Long)
Dim pItem As Pointer
pItem = Alloc()
Heap(pItem).Seg.Data = Node
Heap(pItem).Seg.Freq = Frequency
Heap(pItem).Seg.Next = m_First
m_First = pItem
m_Size = m_Size + 1
End Sub Listing 6 Hierbei geschieht nichts besonderes. Es wird lediglich ein neues Element erzeugt und in die Kette eingehängt. Public Function PopLowest() As Pointer
Dim pIter As Pointer, _
pLast As Pointer
Dim Min As Long
Dim pMin As Pointer, _
pTmp As Pointer
pIter = m_First
Min = &HFFFFFFF
Do While pIter
If Heap(pIter).Seg.Freq < Min Then
Min = Heap(pIter).Seg.Freq
pMin = pLast
End If
pLast = pIter
pIter = Heap(pIter).Seg.Next
Loop
If pMin = 0 Then
PopLowest = Heap(m_First).Seg.Data
pTmp = m_First
m_First = Heap(m_First).Seg.Next
Else
pTmp = Heap(pMin).Seg.Next
PopLowest = Heap(pTmp).Seg.Data
Heap(pMin).Seg.Next = Heap(pTmp).Seg.Next
End If
Call Free(pTmp)
m_Size = m_Size - 1
End Function Listing 7 Hier wird etwas mehr Aufwand getrieben, da zuerst das kleinste Element bestimmt werden muss. Hierzu setzen wir am Anfang die Variable Min auf einen sehr großen Wert. Dies kann problematisch werden, wenn wir mit größeren Dateien arbeiten: falls die Datei mehr als 255 MB haben sollte, kann es vorkommen, dass ein Zeichen häufiger auftaucht und die Prozedur somit falsche Resultate liefert. Ich nehme aber einmal an, dass niemand versuchen wird, eine derart große Datei in VB zu komprimieren. In der Schleife merken wir uns nun immer das Element unmittelbar vor dem kleinsten. Dies müssen wir tun, da wir das vorhergehende Element brauchen, um das kleinste Element aus der Kette zu eliminieren und die Kette trotzdem intakt zu lassen. Nach Durchlaufen der Schleife müssen wir prüfen, ob es sich bei dem kleinsten Element um das erste Element der Kette handelt, in diesem Fall müssen wir die Variable m_First nämlich neu zuweisen. Nachdem wir das Element aus der Kette ausgegliedert und den Wert ausgelesen haben, wird der Zeiger per Free() freigegeben. Das Lexikon Die Implementierung des Lexikons ist um einiges umfangreicher. Ich werde zunächst die Funktionen zum Erstellen desselben erklären, da diese den Huffman-Algorithmus implementieren. Public Sub Create(Text() As Byte)
Dim Idx As Long
Call SetHeapSize(200)
Call SetDynamic(True, 50)
For Idx = 0 To UBound(Text)
m_Freqs(Text(Idx)) = m_Freqs(Text(Idx)) + 1
Next Idx
m_Root = CreateHuffmanTree()
If m_Root = 0 Then _
Exit Sub
Dim NewCode As ByteCode
Call CreateTable(m_Root, NewCode)
End Sub Listing 8 Zuerst wird der Heap dimensioniert. Die Start- und Vergrößerungswerte für den Heap sind hierbei mehr oder weniger willkürlich; sie sollten aber in etwa im oben gewählten Bereich liegen. Nun werden in einer einfachen Schleife die Häufigkeiten der einzelnen Zeichen ausgezählt. Danach wird der Huffmanbaum mit der Wurzel Root erstellt. Zuletzt erzeugen wir aus dem Baum eine Übersetzungstabelle. Es folgen nunmehr die Prozeduren CreateHuffmanTree() und CreateTable(): Private Function CreateHuffmanTree() As Pointer
Dim Idx As Long
Dim List As List
Dim Node As Pointer
Set List = New List
For Idx = 0 To 255
If m_Freqs(Idx) > 0 Then
Node = Alloc()
Heap(Node).Seg.Data.Char = CByte(Idx)
Heap(Node).Seg.Data.Freq = m_Freqs(Idx)
Call List.Push(Node, m_Freqs(Idx))
End If
Next Idx
Dim Left As Pointer, _
Righ As Pointer
Dim Freq As Long
Do While List.Size > 0
Left = List.PopLowest()
Righ = List.PopLowest()
Node = Alloc()
Freq = Heap(Left).Seg.Data.Freq + Heap(Righ).Seg.Data.Freq
Heap(Node).Seg.Data.Freq = Freq
Heap(Node).Seg.Left = Left
Heap(Node).Seg.Righ = Righ
If List.Size = 0 Then
CreateHuffmanTree = Node
Exit Do
End If
Call List.Push(Node, Freq)
Loop
End Function Listing 9 Sieht eigentlich ganz einfach aus - ist es auch. Huffman entzaubert. In einem ersten Schritt wird für jedes Zeichen, das im Text vorkommt, ein Listeneintrag erzeugt. Dann geht es richtig los: in der Schleife werden zuerst die beiden Knoten mit dem niedrigsten Gewicht entfernt. Dann wird ein neuer Knoten erstellt, als Kinder werden ihm die beiden Knoten zugewiesen und seine Gewichtung entspricht der Summe der Gewichtungen der beiden Kindesknoten. Dieser neue Knoten wird in die Liste eingefügt, es sei denn, die Liste ist leer. In diesem Fall wird die Prozedur verlassen und der neu erstellte Knoten als Wurzel des Huffmanbaumes zurückgegeben. Private Sub CreateTable(Node As Pointer, Code As ByteCode)
If Heap(Node).Seg.Left = 0 Then
m_Table(Heap(Node).Seg.Data.Char) = Code
Else
Dim LeftCode As ByteCode
Dim RighCode As ByteCode
LeftCode.Len = Code.Len + 1
LeftCode.Bits = Code.Bits * 2&
Call CreateTable(Heap(Node).Seg.Left, LeftCode)
RighCode.Len = Code.Len + 1
RighCode.Bits = (Code.Bits * 2&) Or 1&
Call CreateTable(Heap(Node).Seg.Righ, RighCode)
End If
End Sub Listing 10 Diese Prozedur ist sogar noch einfacher. Zuerst wird geprüft, ob das aktuelle Kind des aktuellen Knotens definiert ist. Wenn nicht, so handelt es sich um ein Blatt, also einen Knoten, der ein Zeichen enthält. Wir notieren uns daher den aktuellen Code in der Übersetzungstabelle. Ansonsten rufen wir die Prozedur nacheinander erneut mit den beiden Kindern des aktuellen Knotens auf. Beim Aufruf verändern wir den aktuellen Code: die Länge des Codes wird um eins erhöht (denn wir befinden uns einen Ast tiefer), außerdem fügen wir für den linken Ast eine Null an den Code, für den rechten eine Eins. Das geht ganz einfach, indem wir den Code mit zwei multiplizieren (was einem Verschieben der Bits um eine Stelle nach links entspricht) und eins addieren. Statt der Addition nehmen wir hier den bitweise-Or-Operator, der dasselbe macht aber schneller ist. Nun stehen noch die Funktionen aus, die die Daten des Lexikons in einem Datenblock ablegen und wieder auslesen. Als einzige Information zum Erstellen des Huffmanbaumes brauchen wir die Häufigkeit der einzelnen Zeichen. Daher speichern wir einfach für jedes Byte-Zeichen einen Long-Wert ab. Dies nimmt allerdings einiges an Speicherplatz weg, nämlich 256 * 4 Bytes = 1 KB. Dadurch lohnt sich eine Kompression von vornherein nur für Dateien, die größer als 1 KB sind. Um die Long-Werte in ein Bytefeld zu bekommen, verwenden wir folgende Prozedur: Public Function Serialize() As Byte()
Dim Buff() As Byte
Dim Idx As Long
Dim BufIdx As Long
ReDim Buff(256 * 4 - 1)
For Idx = 0 To 255
BufIdx = Idx * 4
Buff(BufIdx) = m_Freqs(Idx) \ &H1000000
Buff(BufIdx + 1) = m_Freqs(Idx) \ &H10000 And &HFF&
Buff(BufIdx + 2) = m_Freqs(Idx) \ &H100& And &HFF&
Buff(BufIdx + 3) = m_Freqs(Idx) And &HFF&
Next Idx
Serialize = Buff
End Function Listing 11 Um an die einzelnen Bytes des vier-Byte-Long heranzukommen, verwenden wir die Ganzzahldivision, um die Bytes nach rechts zu verschieben. Die anschließende And-Operation sorgt dafür, dass wirklich nur das nun unterste Byte ausgelesen wird und die oberen Bytes wegfallen. Public Function Read(Code() As Byte, StartCell As Long) As Long
Dim Idx As Long
Call SetHeapSize(200)
Call SetDynamic(True, 50)
Read = StartCell
For Idx = 0 To 255
m_Freqs(Idx) = CLng(Code(Read)) * &H1000000 Or _
CLng(Code(Read + 1)) * &H10000 Or _
CLng(Code(Read + 2)) * &H100& Or _
CLng(Code(Read + 3))
Read = Read + 4
Next Idx
m_Root = CreateHuffmanTree()
End Function Listing 12 Hier geschieht nun genau das Gegenteil: wir übergeben ein Bytefeld und eine Startzelle (da die relevanten Daten sich nicht ganz zu Anfang des Feldes befinden). Zuerst wird, wie in Create(), der Heap initialisiert. Dann werden die Häufigkeiten ausgelesen und der Huffmanbaum erstellt. Da wir für das Decodieren keine Übersetzungstabelle brauchen, wird auch keine erstellt. Zum Codieren brauchen wir die Übersetzungstabelle, daher wird sie von außen für Lesezugriffe zugänglich gemacht: Friend Property Get Char() As ByteCode()
Char = m_Table
End Property Listing 13 Um den Baum für die Decodierung nutzbar zu machen, verwenden wir die folgende Funktion, die jeweils immer das nächste Zeichen in einer Huffmandatei ausliest: Public Function GetLetter( _
Text() As Byte, _
ByRef Cell As Long, _
ByRef Offset As Long _
) As Byte
Dim Node As Pointer
Node = m_Root
Do
If Heap(Node).Seg.Left = 0 Then
GetLetter = Heap(Node).Seg.Data.Char
Exit Function
End If
If IsBitSet(Text(Cell), Offset) Then _
Node = Heap(Node).Seg.Righ _
Else _
Node = Heap(Node).Seg.Left
Offset = Offset + 1
If Offset = 8 Then
Offset = 0
Cell = Cell + 1
End If
Loop
End Function Listing 14 Dieser Funktion werden sowohl die aktuelle Zelle als auch das aktuelle Bit in der Zelle des Feldes übergeben. Dies ist nötig, da wir ja auf Bitebene statt auf Byteebene manipulieren. Zuerst weisen wir einem Knoten die Wurzel als Start zu. Dann führen wir eine Schleife aus, in der geprüft wird, ob der Knoten Kinder besitzt. Falls nicht, haben wir das Zeichen fertig ausgelesen und können es zurückgeben. Ansonsten testen wir anhand der Funktion IsBitSet(), ob das aktuelle Bit gesetzt ist oder nicht und setzen in Abhängigkeit den Knoten auf sein rechtes oder linkes Kind. Dann erhöhen wir die aktuelle Bitposition. Sollte sie größer als acht sein, haben wir das Byte fertig abgearbeitet und erhöhen die Zellenposition um eins. Auf diese Weise tasten wir uns, ähnlich wie bei den Telefonnummern, immer näher an unser Ziel heran. Huffman Bei den Funktionen EncodeString() und DecodeString() handelt es sich lediglich um eine "Verpackung" für die Bytependants der Funktionen: Public Function EncodeString(Text As String) As String
EncodeString = _
StrConv( _
EncodeBytes(StrConv(Text, vbFromUnicode)), _
vbUnicode _
)
End Function
Public Function DecodeString(Text As String) As String
DecodeString = _
StrConv( _
DecodeBytes(StrConv(Text, vbFromUnicode)), _
vbUnicode _
)
End Function Listing 15 Die Funktion EncodeBytes() muss die meiste Arbeit verrichten: sie codiert die Daten und setzt die Ausgabedaten aus Kennung, Kopf und Daten zusammen. Bei der Kennung handelt es sich um die ersten vier Bytes der Huffmandatei: nur wenn diese Kennung vorhanden ist, erkennt die Klasse eine Datei als Huffmandatei an und decodiert sie. Dies unterbindet Fehleingaben und stellt gleichzeitig eine Versionskontrolle zur Verfügung. Public Function EncodeBytes(Text() As Byte) As Byte()
Dim Dict As Dictionary
Dim Head() As Byte, _
Data() As Byte
Dim DatLen As Long
Dim TextLen As Long
Dim Pos As Long, _
Bit As Long
Dim Offset As Long
Dim Cell As Long
Dim Bits() As ByteCode
Set Dict = New Dictionary
Call Dict.Create(Text)
TextLen = UBound(Text)
Bits = Dict.Char
For Pos = 0 To TextLen
DatLen = DatLen + Bits(Text(Pos)).Len
Next Pos
ReDim Data((DatLen - 1) \ 8)
For Pos = 0 To TextLen
For Bit = Bits(Text(Pos)).Len - 1 To 0 Step -1
Call SetBit( _
Data(Cell), _
Offset, _
DWIsBitSet(Bits(Text(Pos)).Bits, Bit) _
)
Offset = Offset + 1
If Offset = 8 Then
Offset = 0
Cell = Cell + 1
End If
Next Bit
Next Pos
Head = Dict.Serialize()
If UBound(Head) + UBound(Data) + 8 < UBound(Text) Then
Dim StrID As String, _
StrHead As String, _
StrLen As String, _
StrData As String
TextLen = TextLen + 1
StrID = HeaderID
StrHead = Head
StrLen = _
StrConv( _
Chr$(TextLen \ &H1000000) & _
Chr$(TextLen \ &H10000 And &HFF&) & _
Chr$(TextLen \ &H100& And &HFF&) & _
Chr$(TextLen And &HFF&), _
vbFromUnicode _
)
StrData = Data
EncodeBytes = StrID & StrHead & StrLen & StrData
Else
EncodeBytes = Text
End If
End Function Listing 16 Zuerst wird das Lexikon erstellt. Dann wird die Länge der Ausgabedaten errechnet und das Feld neu dimensioniert. Da die Länge in Bits ist, müssen wir den Wert durch acht teilen, um auf Bytes zu kommen. Nun gehen wir der Reihe nach alle Zeichen der Eingabedatei durch. In einer weiteren Schleife gehen wir die Bits des Bitcodes des aktuellen Zeichens durch, testen, ob sie gesetzt sind und setzen in diesem Falle das aktuelle Zeichen im Ausgabefeld. Hier arbeiten wir wieder mit zwei Indizes: einem für die aktuelle Zelle des Ausgabefeldes und einem für das aktuelle Bit des Ausgabefeldes. Wenn das Bit den Wert acht hat, wird die Zelle erhöht und die Bitposition zurück auf null gesetzt. Nachdem wir auf diese Weise den Text codiert haben, speichern wir im Feld Head die Häufigkeiten der Zeichen. Nun testen wir, ob die Ausgabedatei kleiner wäre als die Eingabe. Nur wenn dies der Fall ist, geben wir die codierten Daten zurück, ansonsten belassen wir die Eingabedatei unverändert: unser Algorithmus kann sie nicht verkleinern. Nun müssen wir noch die einzelnen Felder (die Identifikation, den Kopf, die Daten sowie die Datenlänge) zusammenführen. Dies geht in VB am einfachsten, indem man die Bytefelder in temporäre Strings speichert und diese dann verkettet. Die Länge des Texts wird hierbei wieder in vier Bytes abgelegt, wie das auch mit den Häufigkeitswerten passiert. Bei diesem doch recht großen Aufwand ist es verwunderlich, dass das Decodieren - dank unserer Vorarbeit im Lexikon - viel einfacher geht: Public Function DecodeBytes(Text() As Byte) As Byte()
Dim Dict As Dictionary
Dim Offset As Long
Dim CharPos As Long
Dim Cell As Long
Dim TextLen As Long
Dim Res() As Byte
If Not ByteCompare(Text, HeaderID, 4) Then
DecodeBytes = Text
Exit Function
End If
Set Dict = New Dictionary
Cell = Dict.Read(Text, UBound(HeaderID) + 1)
If Cell = 0 Then _
Exit Function
TextLen = CLng(Text(Cell)) * &H1000000 Or _
CLng(Text(Cell + 1)) * &H10000 Or _
CLng(Text(Cell + 2)) * &H100& Or _
CLng(Text(Cell + 3))
Cell = Cell + 4
ReDim Res(TextLen)
For CharPos = 0 To TextLen - 1
Res(CharPos) = Dict.GetLetter(Text, Cell, Offset)
Next
DecodeBytes = Res
End Function Listing 17 Zuerst wird mit der Prozedur ByteCompare() getestet, ob die ersten vier Bytes unserer Kennung entsprechen. Dann lesen wir die Häufigkeiten der Zeichen aus und erstellen mit diesen Informationen das Lexikon. Nun wird die Textlänge ausgelesen und unser Ergebnisfeld entsprechend dimensioniert. In der anschließenden Schleife ermitteln wir nacheinander alle Ausgabezeichen dank der Prozedur GetLetter() im Lexikon. Hilfsfunktionen Wir haben einige Hilfsfunktionen zur Bit- und Bytemanipulation verwendet. Diese Funktionen habe ich in ein Modul ausgegliedert: Option Explicit
Private m_Init As Boolean
Private m_BitTable(31) As Long
Public Sub InitBits()
Dim I As Long
If Not m_Init Then
m_BitTable(0) = 1
m_BitTable(31) = -2147483648#
For I = 1 To 30
m_BitTable(I) = m_BitTable(I - 1) * 2
Next I
End If
End Sub
Public Sub SetBit( _
ByRef Char As Byte, _
Offset As Long, _
Condition As Boolean _
)
If Condition Then _
Char = Char Or m_BitTable(Offset)
End Sub
Public Function DWIsBitSet(DWord As Long, Offset As Long) As Boolean
DWIsBitSet = DWord And m_BitTable(Offset)
End Function
Public Function IsBitSet(Char As Byte, Offset As Long) As Boolean
IsBitSet = Char And m_BitTable(Offset)
End Function
Public Function ByteCompare( _
Haystack() As Byte, _
Compare() As Byte, _
Number As Long, _
Optional Start As Long = 0 _
) As Boolean
Dim I As Long
On Error Goto ERR_ByteCompare
For I = Start To Start + Number - 1
If Haystack(I) <> Compare(I) Then _
Exit Function
Next I
ByteCompare = True
ERR_ByteCompare:
End Function Listing 18 In der Prozedur InitBits() wird eine Tabelle mit Bitwerten initialisiert. Dies erspart uns später die Zweiterpotenzierung, die recht zeitaufwändig ist. SetBit() setzt ein angegebenes Bit in einem Byte. IsBitSet() liest aus, ob ein angegebenes Bit in einem Byte gesetzt ist. DWIsBitSet() tut das selbe in einem Longwert. ByteCompare() geht eine gegebene Anzahl von Bytes in zwei Feldern durch und vergleicht, ob diese gleich sind. Bei der ersten Abweichung wird False zurückgeliefert. | 
Code-Implementierung aus dem Tutorial
