;Huffman-Kompression
; von Christoph Mach ("Eingeproggt"), Jun 2008


;Funktionen ------------------

;Huffman(in$,out$)
; in$: Nachricht oder Dateipfad zu einer auszulesenden Datei
; out$: Pfad zur zu schreibenden Datei

;DecompressFile(in$,out$)
; in$: Datei, die decodiert werden soll
; out$: Datei, in die das Ergebnis geschrieben werden soll

;------------------

;Bekannte Bugs:
; Daten, die nur aus einem Zeichen bestehen, werden nicht richtig dekodiert (Programmabsturz)

;Dieses Programm ist idR nur für etwas größere Dateien geeignet (>2kb)
;Außerdem ist die Anwendung bei bereits komprimierten Daten (png, zib,...) meist nicht ratsam.


;Benötigte Variablen/Types/Arrays
Type knoten
	Field char$ ;Zeichen
	Field child1.knoten ;Erster Knoten (nur, wenn kein Zeichen definiert ist)
	Field child2.knoten ;Zweiter Knoten (nur, wenn kein Zeichen definiert ist)
	Field entropie ;Absolute Wahrscheinlichkeit
	Field code$ ;Bitcode als String aus "0" und "1"
	Field aktiv ;Gibt an, ob bei Knotenauswahl berücksichtigt werden soll
	Field id ;Handle() funktioniert hier ausdrücklich NICHT!
End Type
Global knoten.knoten
Global knotencount

Dim huffcode$(255)
Dim zweierpotenz(7)
For i=0 To 7
	zweierpotenz(i)=2^i
Next

Const ID_NOCHAR=256
Const ID_ENDOFTREE=257


Function Huffman(in$,out$)
	knotencount=1
	Local reader=ReadFile(in$)
	If reader<>0 Then
		in$=""
		While Not Eof(reader)
			in$=in$+Chr(ReadByte(reader))
		Wend
		CloseFile reader
	EndIf
	
	zeichen_erkennen(in$)
	
	huffman_main()
	
	CreateCode(Last knoten)
	
	WriteCodeFile(in$,out$)
End Function

Function zeichen_erkennen(msg$)
	Local akt_zeichen$ ;Aktuell bearbeitetes Zeichen
	Local ok,i
	
	For i=1 To Len(msg$)
		akt_zeichen=Mid(msg$,i,1)
		
		;Kontrollieren, ob Zeichen bereits erschien oder nicht
		ok=True
		For knoten=Each knoten
			If knoten\char$=akt_zeichen Then
				;Zeichen wurde bereits erkannt
				knoten\entropie=knoten\entropie+1
				ok=False
				Exit
			End If
		Next
		
		If ok=True Then
			;Ein neues Zeichen gefunden
			knoten=New knoten
			knoten\id=knotencount
			knotencount=knotencount+1
			knoten\char$=akt_zeichen$
			knoten\entropie=1
			knoten\aktiv=True
		End If
	Next
End Function

Function huffman_main()
	Local tmp.knoten
	;Knoten mit den niedrigsten Entropien -> Zusammenfassen
	Local min1.knoten=First knoten
	While Not min1\aktiv
		min1=After min1
		If min1=Null Then Return
	Wend
	
	Local min2.knoten=min1
	Repeat
		min2=After min2
		If min2=Null Then Return
	Until min2\aktiv
	
	If min2\entropie<min1\entropie Then
		tmp=min1
		min1=min2
		min2=tmp
	EndIf
	
	For knoten=Each knoten
		If knoten\aktiv Then
			;Die 2 Knoten mit den kleinsten Entropien finden
			If knoten\entropie<min1\entropie And knoten\entropie<min2\entropie Then
				If min1\entropie<min2\entropie Then
					tmp=min1
					min1=min2
					min2=tmp
				EndIf
				min1=knoten
			EndIf
			If knoten\entropie>=min1\entropie And knoten\entropie<min2\entropie Then
				If knoten<>min1 Then
					min2=knoten
					If min2\entropie<min1\entropie Then
						tmp=min1
						min1=min2
						min2=tmp
					EndIf
				EndIf
			EndIf
		EndIf
	Next
	
	;Diese 2 Knoten zusammen fassen
	knoten=New knoten
	knoten\id=knotencount
	knotencount=knotencount+1
	knoten\aktiv=True
	knoten\child1=min1
	knoten\child2=min2
	knoten\entropie=min1\entropie+min2\entropie
	min1\aktiv=False
	min2\aktiv=False
	
	huffman_main()
End Function

Function CreateCode(knoten.knoten)
	If knoten\child1<>Null Then
		knoten\child1\code$=knoten\code$+"0"
		CreateCode(knoten\child1)
	EndIf
	If knoten\child2<>Null Then
		knoten\child2\code$=knoten\code$+"1"
		CreateCode(knoten\child2)
	EndIf
End Function

Function WriteCodeFile(msg$,name$)
	Local file=WriteFile(name$)
	If file=0 Then Return
	Local i,txt$
	
	;Original-Dateigröße zur Kontrolle
	WriteInt(file,Len(msg$))
	;Code in Array bzw Datei schreiben, da in Types unpraktisch aufgehoben
	For knoten=Each knoten
		If knoten\char$<>"" Then
			;DebugLog knoten\char$+": "+knoten\code$+" ("+knoten\entropie+")"
			WriteShort(file,Asc(knoten\char$)) ;Zeichen
			huffcode$(Asc(knoten\char$))=knoten\code$
		Else
			WriteShort(file,ID_NOCHAR) ;Kein Zeichen sondern Knoten
			WriteShort(file,knoten\child1\id)
			WriteShort(file,knoten\child2\id)
		EndIf
	Next
	Delete Each knoten
	WriteShort(file,ID_ENDOFTREE) ;Baum abgeschlossen
	
	;Eigentliche Codierung
	For i=1 To Len(msg$)
		txt$=txt$+huffcode$(Asc(Mid(msg$,i,1)))
		If Len(txt$)>=8 Then
			WriteByte(file,BitsToByte(Left(txt$,8)))
			txt$=Right(txt$,Len(txt$)-8)
		EndIf
	Next
	WriteByte(file,BitsToByte(txt$))
	
	CloseFile file
End Function

Function BitsToByte(bits$)
	Local i,byte
	For i=1 To Len(bits$)
		byte=byte+Int(Mid(bits$,i,1))*zweierpotenz(8-i)
	Next
	Return byte
End Function

Function DecompressFile(in$,out$)
	Local file=ReadFile(in$)
	If file=0 Then Return
	
	Local tmp.knoten,id,num1,num2
	Local txt$,size,newsize,temp$
	knotencount=1
	
	;Dateigröße zur Fehlererkennung
	size=ReadInt(file)
	If size=0 Then
		RuntimeError("Originaldateigröße von 0byte wird nicht unterstützt")
	EndIf
	;Baumstruktur einlesen und daraus Binärbaum erstellen
	Repeat
		id=ReadShort(file)
		If id=ID_ENDOFTREE Then Exit
		knoten=New knoten
		knoten\id=knotencount
		knotencount=knotencount+1
		If id<ID_NOCHAR Then
			knoten\char$=Chr(id)
		ElseIf id=ID_NOCHAR Then
			num1=ReadShort(file)
			num2=ReadShort(file)
			For tmp=Each knoten
				If tmp\id=num1 Then
					knoten\child1=tmp
				EndIf
				If tmp\id=num2 Then
					knoten\child2=tmp
				EndIf
			Next
		Else
			RuntimeError("Datei ist beschädigt, ungültig, unvollständig, was-weiß-ich...")
		EndIf
	Forever
	
	Local writer=WriteFile(out$)
	If writer=0 Then
		CloseFile file
		Return
	EndIf
	;Dateiinhalt dekodieren
	While Not Eof(file)
		txt$=txt$+Right(Bin$(ReadByte(file)),8)
		Repeat
			temp$=Decode(txt$,writer)
			If temp$=txt$ Then Exit
			newsize=newsize+1
			If newsize=size Then Exit
			txt$=temp$
		Forever
	Wend
	
	CloseFile file
	CloseFile writer
	Delete Each knoten
End Function

Function Decode$(txt$,file)
	Local i
	knoten=Last knoten
	For i=1 To Len(txt$)
		If Mid(txt$,i,1)="0" Then
			knoten=knoten\child1
		Else
			knoten=knoten\child2
		EndIf
		
		If knoten\char$<>"" Then
			WriteByte(file,Asc(knoten\char$))
			txt$=Right(txt$,Len(txt$)-i)
			Exit
		EndIf
	Next
	Return txt$
End Function