unit Huffman;
{Written by J Derrick 16/2/2000 to perform Huffman compression and decompression on a block of memory
Takes a pointer as input, and will create or resize a handle for output.
Two external routines, HuffmanEncode and HuffmanDecode.  The outputFile variable must be either nil or a valid handle

Demonstrates a number of other techniques such as (a fudged) sort of a doubly linked list and creating and traversing a binary tree}

interface
uses
	Types;

type
	CompressionErrorType	= (eInvalidCompressionError, eNoCompressionError, eInvalidEncodingError, eNotEnoughMemoryError, eGarbledMessageError);
		
function HuffmanEncode
	(
	inputFile:			Ptr;
	inputSize:			LONGINT;
	var outputFile:		Univ Handle
	):BOOLEAN;


function HuffmanDecode
	(
	inputFile:			Ptr;
	inputSize:			LONGINT;
	var outputFile:		Univ Handle
	):CompressionErrorType;


implementation
uses Quickdraw;
const
	kMinTableEntry			= 0;
	kMaxCharEntry			= 255;
	kMaxTableEntry		= (kMaxCharEntry+1) * 2 + 6; {last 2 values used as dummy nodes for the linked list}
	
	kHeadNode				= kMaxTableEntry;
	kTailNode				= kMaxTableEntry-1;
	kNoLink				= -1;
	
	kMaxBit				= 7;
	kMinBit				= 0;
	kEncodingTypeLoc		= 5;
	kNumNodesLoc			= 6;
	kNumHeaderBits		= 9;

	kNotEncoded			= 0;
	kHuffmanEncoded		= 1;
	
	kMaxHeaderOutputBytes	= Round((kMaxCharEntry+1)*2 * kNumHeaderBits / (kMaxBit+1))  + kNumNodesLoc;
	
type
	{this will end up being a binary tree, however allocate it in one block to keep things simple
	This block has the following structure
	
	the array index is equivalent to the address for the linked list
	prevNode, next node is used for the initial sort.  We could get away with a singly linked list, but the sorting is easier
	if it is doubly linked.
	parent, rightChild and child 2 are used for the binary tree
	
	whichChar is just there to make debugging simpler}
	HuffmanRec = record
		whichChar:		Char;
		frequency:		LONGINT;
		prevNode:			INTEGER;
		nextNode:			INTEGER;
		parent:			INTEGER;
		rightChild:		INTEGER;
		leftChild:			INTEGER;
		stackDepth:		INTEGER;
		encoding:			LONGINT;
	end;
	
	HuffmanArray 	= array[kMinTableEntry ..kMaxTableEntry] of HuffmanRec;
	HuffmanPtr	= ^HuffmanArray;
	
	PByteArray	= packed array[1..MAXINT * 2 + 1] of UnsignedByte;
	PBytePtr		= ^PByteArray;
	PByteHnd		= ^PBytePtr;
	
	TaskProc		= procedure
					(
					theTable:		HuffmanPtr;
					theNode:		INTEGER;
					theData:		Ptr
					);

	HeaderRec			= record
		numNodes:	INTEGER;
		entryIdx:		INTEGER;
		nodes:		array[0..kMaxTableEntry] of INTEGER;
		{first 4 bytes of output will be used for message length, next byte for type of encoding, then next byte for the bits in the header encoding and then the header
		Dont allocate this as a record, as otherwise you may get problems with alignment}
		output:		packed array [1..kMaxHeaderOutputBytes] of UnsignedByte;
	end;
	

	
function GetNthLink
	(
	theTable:		HuffmanPtr;
	n:			INTEGER
	):INTEGER;
	
var
	curValue:		INTEGER;
	arrayIdx:		INTEGER;
	
begin
	curValue := 0;
	arrayIdx := theTable^[kHeadNode].nextNode;
	while n > curValue do begin
		arrayIdx := theTable^[arrayIdx].nextNode;
		Inc(curValue)
	end;
	GetNthLink := arrayIdx;
end;


procedure GetTwoLinks
	(
	theTable:		HuffmanPtr;
	firstIdx:		INTEGER;
	secondIdx:	INTEGER;
	var firstLink:	INTEGER;
	var secondLink:	INTEGER
	);
	
var
	curValue:		INTEGER;
	arrayIdx:		INTEGER;
	
begin
	
	curValue := 0;
	arrayIdx := theTable^[kHeadNode].nextNode;
	while firstIdx > curValue do begin
		arrayIdx := theTable^[arrayIdx].nextNode;
		Inc(curValue)
	end;
	firstLink := arrayIdx;
	while secondIdx > curValue do begin
		arrayIdx := theTable^[arrayIdx].nextNode;
		Inc(curValue)
	end;
	secondLink := arrayIdx;
end;


function CompareFrequencies
	(
	theTable:			HuffmanPtr;
	rec1:			LONGINT;
	rec2:			LONGINT
	):BOOLEAN;
	
var
	temp1:			HuffmanRec;
	temp2:			HuffmanRec;

begin
	temp1 := theTable^[rec1];
	temp2 := theTable^[rec2];
	CompareFrequencies := temp1.frequency > temp2.frequency;
end;




procedure DeleteFromList
	(
	theTable:			HuffmanPtr;
	theNode:			INTEGER
	);
var
	tempNode:			INTEGER;
	
begin
	{don't delete our dummy nodes!}
	if not (theNode in [kHeadNode, kTailNode]) then begin
		tempNode := theTable^[theNode].prevNode;
		theTable^[tempNode].nextNode := theTable^[theNode].nextNode;
		tempNode := theTable^[theNode].nextNode;
		theTable^[tempNode].prevNode := theTable^[theNode].prevNode;
	end;
end;


procedure InsertAfter
	(
	theTable:			HuffmanPtr;
	afterWhich:		INTEGER;
	theNode:			INTEGER
	);
	
var
	tempNode:			INTEGER;
	
begin
	theTable^[theNode].prevNode := afterWhich;
	theTable^[theNode].nextNode := theTable^[afterWhich].nextNode;
	tempNode := theTable^[theNode].nextNode;
	theTable^[tempNode].prevNode := theNode;
	theTable^[afterWhich].nextNode := theNode;
end;


procedure SwapHuffmanRecs 
	(
	theTable:			HuffmanPtr;
	rec1:			LONGINT;
	rec2:			LONGINT
	);

var
	earlierNode1:	INTEGER;
	earlierNode2:	INTEGER;
	
begin
	if rec1 <> rec2 then begin

		earlierNode1 := rec1;
		repeat
			earlierNode1 := theTable^[earlierNode1].prevNode;
		until earlierNode1 <> rec2;
		
		earlierNode2 := rec2;
		repeat
			earlierNode2 := theTable^[earlierNode2].prevNode;
		until earlierNode2 <> rec1;
		
		DeleteFromList(theTable, rec1);
		DeleteFromList(theTable, rec2);
		InsertAfter(theTable, earlierNode1, rec2);
		
		if earlierNode1 <> earlierNode2 then
			InsertAfter(theTable, earlierNode2, rec1)
		else begin
			if theTable^[rec1].frequency < theTable^[rec2].frequency then
				InsertAfter(theTable, rec2, rec1)
			else
				InsertAfter(theTable, earlierNode2, rec1);
		end;
	end;
end;


procedure InsertionSort
	(
	theTable:		HuffmanPtr;
	left:			LONGINT;
	right:		LONGINT
	);

{Insertion sort.  Note that we stop our backwards scanning when we find an equal record.  This makes the sort lose
its stability, but on the other hand, as we are calling it from Quicksort with a random pivot, we have already lost this
property anyway.  Doing this makes the sort twice as fast}	
var
	
	head:		INTEGER;
	tail:			INTEGER;
	curNode:		INTEGER;
	nextNode:		INTEGER;
	prevNode:		INTEGER;
	
begin
	GetTwoLinks(theTable, left, right, head, tail);
	curNode := head;
	head := theTable^[head].prevNode;
	tail := theTable^[tail].nextNode;
	
	while curNode <> tail do begin
		
		{If we are on the first record then don't bother going through the loop}
		prevNode := theTable^[curNode].prevNode;
		if prevNode = head then begin
			curNode := theTable^[curNode].nextNode;
			Cycle;
		end;
			
		{cut out record from list}
		nextNode := theTable^[curNode].nextNode;
		DeleteFromList(theTable, curNode);
		
		repeat
			{compare it with all previous records, if we find a record that is greater or equal to us, stop}
			if CompareFrequencies(theTable, curNode, prevNode) then
				prevNode := theTable^[prevNode].prevNode
			else
				Leave;
			{until we get to the end of the list}
		until prevNode = head;
		
		{paste the record back in}
		InsertAfter(theTable, prevNode, curNode);
		curNode := nextNode;
	end;
end;


procedure SortByFrequency
	(
	theTable:			HuffmanPtr;
	left:				LONGINT;
	right:			LONGINT
	);
   
{Turns the table into a linked list in descending order of frequency.
Random pivot, tail recursion removed, insertion sort of small groups of records}
const
	kMinPivotLength	= 2;
	
var
	lIndex: 			LONGINT;
	rIndex: 			LONGINT;
	pivotIdx:			LONGINT;
	
	lLink:			INTEGER;
	rLink:			INTEGER;
	pivotLink:			INTEGER;
		
begin
		
	while left < right do begin
	
		{Insertion sort if we have only a few records left}
		if right - left < 25 then begin
			InsertionSort(theTable, left, right);
			Leave;
		end;
		
		lIndex := left;
		rIndex := right;
		
		{pick a random pivot, which is not too close to either end.  As we are doing an insertion sort on smaller groups of records
		we know that there will be a gap of at least 4 between both ends}
		pivotIdx := Abs(Random) mod (rIndex - lIndex) + lIndex;
		if (pivotIdx- lIndex <  kMinPivotLength) | (rIndex - pivotIdx < kMinPivotLength) then
			pivotIdx := lIndex + kMinPivotLength;

		pivotLink	:= GetNthLink(theTable, pivotIdx);

		repeat                
			GetTwoLinks(theTable, lIndex, rIndex, lLink, rLink);
			
			{scan left side}
			while CompareFrequencies(theTable, lLink, pivotLink) do begin
				Inc(lIndex);	
				lLink := theTable^[lLink].nextNode;
			end;
			
			{scan right side}
			while CompareFrequencies(theTable, pivotLink, rLink) do begin
				Dec(rIndex);						
				rLink := theTable^[rLink].prevNode;
			end;
			
			{exchange records}
			if lIndex <= rIndex then begin       
				SwapHuffmanRecs(theTable, lLink, rLink);
				if lIndex = pivotIdx then begin
					pivotIdx := rIndex;
					pivotLink	:= GetNthLink(theTable, pivotIdx);
				end
				else if rIndex = pivotIdx then begin
					pivotIdx := lIndex;
					pivotLink	:= GetNthLink(theTable, pivotIdx);
				end;
					
				Inc(lIndex);
				Dec(rIndex);
			end;
			
		{until the partition is finished}	
		until lIndex > rIndex;						
		
		{recursively sort the smaller partition, and loop through the larger one}
		if (rIndex - left) < (right - lIndex) then begin
			SortByFrequency(theTable, left, rIndex);
			left := lIndex;
		end
		else begin
			SortByFrequency(theTable, lIndex, right);
			right := rIndex;
		end;
	end;
	 
end;



procedure InitialiseTable
	(
	theTable:		HuffmanPtr
	);
	
var
	tableIdx:		INTEGER;
	
begin
	{these are the leaves}
	for tableIdx := kMinTableEntry to  kMaxCharEntry do begin
		theTable^[tableIdx].whichChar := Chr(tableIdx);
		theTable^[tableIdx].frequency := 0;
		
		{set up the linked list}
		if tableIdx > kMinTableEntry then
			theTable^[tableIdx].prevNode := tableIdx-1
		else
			theTable^[tableIdx].prevNode := kHeadNode;
		if tableIdx < kMaxCharEntry then
			theTable^[tableIdx].nextNode := tableIdx + 1
		else
			theTable^[tableIdx].nextNode := kTailNode;
			
		theTable^[tableIdx].parent := kNoLink;
		theTable^[tableIdx].rightChild := kNoLink;
		theTable^[tableIdx].leftChild := kNoLink;
	end;
	
	{these are the nodes}
	for tableIdx := kMaxCharEntry + 1 to  kMaxTableEntry do begin
		theTable^[tableIdx].whichChar := Chr(tableIdx);
		theTable^[tableIdx].frequency := 0;
		theTable^[tableIdx].prevNode := kNoLink;
		theTable^[tableIdx].nextNode := kNoLink;
		theTable^[tableIdx].parent := kNoLink;
		theTable^[tableIdx].rightChild := kNoLink;
		theTable^[tableIdx].leftChild := kNoLink;
	end;
	
	{and these are the head and tail nodes for the linked list}
	theTable^[kHeadNode].prevNode := kHeadNode;
	theTable^[kHeadNode].nextNode := kMinTableEntry;
	theTable^[kHeadNode].frequency := MAXLONGINT;

	theTable^[kTailNode].nextNode := kTailNode;
	theTable^[kTailNode].prevNode := kMaxCharEntry;
	theTable^[kTailNode].frequency := -1;
end;


procedure AttachLeavesToParent
	(
	theTable:		HuffmanPtr;
	parentNode:	INTEGER;
	firstChild:		INTEGER;
	secondChild:	INTEGER
	);

begin
	{OK, this is pretty dopey, however CW 3 crashes if the LONGINT value overflows.  This may occur if all characters are the same, so the second child is the 
	head node, which is initialised to a frequency of MAXLONGINT}
	if firstChild <> kHeadNode then begin
		theTable^[parentNode].rightChild := firstChild;
		theTable^[parentNode].frequency := theTable^[firstChild].frequency;
		theTable^[firstChild].parent := parentNode;
	end;
	
	if secondChild <> kHeadNode then begin
		theTable^[parentNode].leftChild := secondChild;
		theTable^[parentNode].frequency := theTable^[parentNode].frequency + theTable^[secondChild].frequency;
		theTable^[secondChild].parent := parentNode;
	end;
end;


procedure InsertNodeIntoList
	(
	theTable:		HuffmanPtr;
	theNode:		INTEGER
	);

var
	curNode:		INTEGER;
	
begin
	curNode := theTable^[kTailNode].prevNode;
	while theTable^[theNode].frequency >= theTable^[curNode].frequency do
		curNode := theTable^[curNode].prevNode;
	 	
	InsertAfter(theTable, curNode, theNode);
end;


procedure SetBitEncoding
	(
	theTable:		HuffmanPtr;
	theNode:		INTEGER
	);
	
var
	theParent:		INTEGER;
	
begin
	theParent := theTable^[theNode].parent;
	
	if theTable^[theNode].parent <> kNoLink then begin
		theTable^[theNode].stackDepth := 1 + theTable^[theParent].stackDepth;
		
		{we have assigned 32 bits for the encoding, although the worst case seems to be about 11}
		theTable^[theNode].encoding :=  theTable^[theParent].encoding shl 1;
		if theNode = theTable^[theParent].rightChild then
			BSet(theTable^[theNode].encoding, 0);
	end
	else begin
		theTable^[theNode].stackDepth := 0;
		theTable^[theNode].encoding := 0;
	end;
end;


procedure TraverseAndAssignBitValues
	(
	theTable:		HuffmanPtr;
	theNode:		INTEGER
	);

{recursively traverses the tree}
	
begin

	if theNode <> kNoLink then begin
		SetBitEncoding(theTable, theNode);
		
		if (theTable^[theNode].leftChild <> kNoLink) then begin
			
			{a node}
			{if there is only one record then there may be no right child, however in this case the parent node should
			be no link}
			TraverseAndAssignBitValues(theTable, theTable^[theNode].leftChild);
			TraverseAndAssignBitValues(theTable, theTable^[theNode].rightChild);
		end
		else begin
			
			{a leaf}
		end;
	end;
end;


function AssignEncodings
	(
	theTable:			HuffmanPtr;
	var parentNode:	INTEGER
	):BOOLEAN;

var
	lastLeaf:			INTEGER;
	firstParent:		INTEGER;
	secondLastNode:	INTEGER;
	success:			BOOLEAN;
	
begin
	{first sort the table in descending order of frequency}
	SortByFrequency(theTable, kMinTableEntry, kMaxCharEntry);
	
	{delete the zero values from the list, and find the last non zero value}
	lastLeaf := theTable^[kTailNode].prevNode;
	while theTable^[lastLeaf].frequency <= 0 do begin
		DeleteFromList(theTable, lastLeaf);
		lastLeaf := theTable^[kTailNode].prevNode;
	end;
	
	
	{now turn the list into a binary tree}	success := lastLeaf <> kHeadNode;
	firstParent := kMaxCharEntry;
	 
	 if success then begin
	 	repeat
		 	{find the two lowest nodes}
		 	lastLeaf := theTable^[kTailNode].prevNode;
		 	secondLastNode := theTable^[lastLeaf].prevNode;
		 			 	
		 	{assign them a new parent node}
		 	Inc(firstParent);
		 	AttachLeavesToParent(theTable, firstParent, secondLastNode, lastLeaf);
		 	
		 	{delete the two lowest nodes from linked list}
		 	DeleteFromList(theTable, lastLeaf);
		 	DeleteFromList(theTable, secondLastNode);

		 	{insert new parent into linked list}
		 	InsertNodeIntoList (theTable, firstParent);
		 			 	
	 	until (theTable^[firstParent].prevNode = kHeadNode) &  (theTable^[firstParent].nextNode = kTailNode);
	 end;
	 
	 {now traverse the tree, and assign the bit values}
	 TraverseAndAssignBitValues(theTable, firstParent);
	 parentNode := firstParent;
	AssignEncodings := success;
end;


procedure TranslateEncodingsToOutput
	(
	huffTable:			HuffmanPtr;
	inputFile:			PBytePtr;
	outputFile:		PBytePtr;
	inputSize:			LONGINT;
	var outputSize:		LONGINT
	);
	
var
	charIdx:			LONGINT;
	curChar:			UnsignedByte;
	numBits:			INTEGER;
	bitCode:			LONGINT;
	curOutput:		UnsignedByte;
	curBit:			INTEGER;
	bitIdx:			INTEGER;
	curPos:			LONGINT;
	
begin
	curOutput := 0;
	curBit := kMaxBit;
	curPos := 0;
	
	for charIdx := 1 to inputSize do begin
		curChar := inputFile^[charIdx];
		bitCode := huffTable^[curChar].encoding;
		numBits := huffTable^[curChar].stackDepth;
				
		{translate the character into bit codes}
		for bitIdx := numBits downto 1 do begin
			if BTst(bitCode, bitIdx - 1) then
				BSet(curOutput, curBit);
			Dec(curBit);
			
			{if our output byte is full then put it into the outputFile and start again}
			if curBit < kMinBit then begin
				curBit := kMaxBit;
				Inc(curPos);
				{note we have assumed the output file won't be bigger than the input file if we ignore the header}
				outputFile^[curPos] := curOutput;
				curOutput := 0;
			end;
		end;
	end;
	
	{do the last byte if necessary}
	if curBit < kMaxBit then begin
		Inc(curPos);
		{note we have assumed the output file won't be bigger than the input file if we ignore the header}
		outputFile^[curPos] := curOutput;
	end;
	
	outputSize := curPos;
end;


function FindCharInTree
	(
	huffTable:			HuffmanPtr;
	turnRight:			BOOLEAN;
	var curNode:		INTEGER;
	var theChar:		UnsignedByte
	):BOOLEAN;
	
var
	found:			BOOLEAN;
	
begin
	if turnRight then
		curNode := huffTable^[curNode].rightChild
	else
		curNode := huffTable^[curNode].leftChild;
	
	{if we have found a leaf, then we have arrived}
	found := huffTable^[curNode].leftChild = kNoLink;
	if found then begin
		theChar := curNode;
	end;
	
	FindCharInTree := found;
end;


function DecodeEncodingsToInput
	(
	huffTable:			HuffmanPtr;
	parentNode:		INTEGER;
	inputSize:			LONGINT;
	origSize:			LONGINT;
	inputFile:			PBytePtr;
	outputFile:		PByteHnd
	):BOOLEAN;

{decodes the input file.  If it finds it can't decode a character it will return false, meaning the data is probably corrupt}	
var
	byteIdx:			LONGINT;
	curByte:			UnsignedByte;
	bitIdx:			INTEGER;
	curNode:			INTEGER;
	inputIdx:			LONGINT;
	success:			BOOLEAN;
	
begin
	curNode := parentNode;
	inputIdx := 0;
	success := TRUE;
	
	for byteIdx := 1 to inputSize do begin
		if not success then
			Leave;
		curByte := inputFile^[byteIdx];
		
		for bitIdx := kMaxBit downto kMinBit do begin
		
			{find character in tree}
			if BTst(curByte, bitIdx) then
				curNode := huffTable^[curNode].rightChild
			else
				curNode := huffTable^[curNode].leftChild;
			
			{if we have found a leaf, then we have arrived.  We know we are at a leaf because there will be no children}
			if huffTable^[curNode].leftChild = kNoLink then begin

				Inc(inputIdx);
				outputFile^^[inputIdx] := curNode;
				curNode := parentNode;
				if inputIdx >= origSize then
					Leave;
			end;
			
			if curNode <= kMaxCharEntry then begin
				{we are in trouble, our data has become corrupted}
				success := FALSE;
				Leave;
			end;
			
		end;
		
		if inputIdx >= origSize then begin
			if success then begin
				success := byteIdx = inputSize;
				{Assert(success);}
			end;
			Leave;
		end;
		
	end;
	DecodeEncodingsToInput := success;
end;


procedure MakeTable
	(
	theTable:		HuffmanPtr;
	theNode:		INTEGER;
	theData:		Ptr
	);

{we are assuming here that we have been passed a pointer to a buffer which is long enough to store all of our data}
type
	HeaderPtr			= ^HeaderRec;
	
var
	localData:			HeaderPtr;	
			
begin
	localData := HeaderPtr(theData);
	localData^.nodes[(localData^.numNodes)*2] := theTable^[theNode].leftChild;
	localData^.nodes[(localData^.numNodes)*2+1] := theTable^[theNode].rightChild;
	Inc(localData^.numNodes);
end;


procedure RecreateTree
	(
	theTable:		HuffmanPtr;
	theNode:		INTEGER;
	theData:		Ptr
	);

{we are assuming here that we have been passed a pointer to a buffer which is long enough to store all of our data}
type
	HeaderPtr			= ^HeaderRec;
	
var
	localData:			HeaderPtr;	
			
begin
	localData := HeaderPtr(theData);
	theTable^[theNode].leftChild := localData^.nodes[localData^.entryIdx];
	theTable^[theNode].rightChild := localData^.nodes[localData^.entryIdx+1];
	localData^.entryIdx := localData^.entryIdx + 2;
end;


procedure TraverseInternalNodes
	(
	theTable:			HuffmanPtr;
	theNode:			INTEGER;
	task:				TaskProc;
	theData:			Ptr
	);

{recursively traverses the internal nodes.  Note internal nodes are all above kMaxChar}
	
begin

	if theNode > kMaxCharEntry then begin
			
		{a node}
		task(theTable, theNode, theData);
		TraverseInternalNodes(theTable, theTable^[theNode].leftChild, task, theData);
		TraverseInternalNodes(theTable, theTable^[theNode].rightChild, task, theData);
	end;
end;


function CheckTreeIsValid
	(
	theTable:			HuffmanPtr;
	theNode:			INTEGER
	):BOOLEAN;

{recursively traverses the internal nodes.  Note internal nodes are all above kMaxChar}
var
	valid:		BOOLEAN;	
	
begin
	valid := TRUE;
	
	if theNode > kMaxCharEntry then begin
			
		{a node}
		valid := (theTable^[theNode].leftChild < kMaxTableEntry) & (theTable^[theNode].leftChild >= kMinTableEntry);
		if valid then
			valid := (theTable^[theNode].rightChild < kMaxTableEntry) & (theTable^[theNode].rightChild >= kMinTableEntry);
		if valid then
			valid := CheckTreeIsValid(theTable, theTable^[theNode].leftChild);
		if valid then
			valid := CheckTreeIsValid(theTable, theTable^[theNode].rightChild);
	end
	else begin
		
		{a leaf}
		valid := (theTable^[theNode].rightChild = kNoLink) & (theTable^[theNode].leftChild = kNoLink);
	end;
	CheckTreeIsValid := valid;
end;

procedure CompressHeader
	(
	var header:		HeaderRec;
	var outputSize:		INTEGER
	);
	
{compresses the header and puts the output into output.  We could use the original location and store the output in nodes, 
however then we would have to be careful that we didn't write over the data before we had read it, and it would be less
clear what was going on.  The extra memory required is trivial anyway...}
	
var
	headerIdx:		INTEGER;
	numEntries:		INTEGER;
	curEntry:			INTEGER;
	curOutput:		UnsignedByte;
	curBit:			INTEGER;
	bitIdx:			INTEGER;
	
begin
	numEntries := header.numNodes * 2;
	curOutput := 0;
	
	{only use the minimum number of bits necessary to store each node number, which should be 9}
	curBit := kMaxBit;
	outputSize := kNumNodesLoc;
	
	for headerIdx := 0 to numEntries - 1 do begin
		{all node numbers will be greater than 255, so we it is tempting to subtract 256 to compress them further.
		Unfortunately this would mean that we can't represent the leaves}
		curEntry := header.nodes[headerIdx];
		
		for bitIdx := kNumHeaderBits-1 downTo kMinBit do begin
			if BTst(curEntry, bitIdx) then
				BSet(curOutput, curBit);
			Dec(curBit);
			
			{if our output byte is full then put it into the outputFile and start again}
			if curBit < kMinBit then begin
				curBit := kMaxBit;
				Inc(outputSize);
				header.output[outputSize] := curOutput;
				curOutput := 0;
			end;
		end;
	end;
	
	{do the last byte if necessary}
	if curBit < kMaxBit then begin
		Inc(outputSize);
		header.output[outputSize] := curOutput;
	end;
	
end;


function DecompressHeader
	(
	theData:			PBytePtr;
	var header:		HeaderRec
	):BOOLEAN;
	
var
	headerIdx:		INTEGER;
	numEntries:		INTEGER;
	curEntry:			INTEGER;
	curOutput:		INTEGER;
	curBit:			INTEGER;
	bitIdx:			INTEGER;
	entryIdx:			INTEGER;
	validHeader:		BOOLEAN;
	
begin
	numEntries := header.numNodes * 2;
	validHeader := numEntries < kMaxTableEntry;
	if validHeader then
		validHeader := numEntries >0;
	
	if validHeader then begin
		curOutput := 0;
		entryIdx := -1;
		headerIdx := 1;
		
		curBit := kNumHeaderBits-1;
		
		while entryIdx < numEntries-1 do begin
			curEntry := theData^[headerIdx];
			
			for bitIdx := kMaxBit downTo kMinBit do begin
				if BTst(curEntry, bitIdx) then
					BSet(curOutput, curBit);
				Dec(curBit);
				
				{if our output byte is full then put it into the outputFile and start again}
				if curBit < kMinBit then begin
					curBit := kNumHeaderBits-1;
					Inc(entryIdx);
					header.nodes[entryIdx] := curOutput;
					curOutput := 0;
					if entryIdx >= numEntries-1 then
						Leave;
				end;
			end;
			Inc(headerIdx);
			if headerIdx > kMaxHeaderOutputBytes then begin
				validHeader := FALSE;
				Leave;
			end;
		end;
	end;
	
	if validHeader then begin
		for entryIdx := 0 to numEntries-1 do begin
			if (header.nodes[entryIdx] < kMinTableEntry) | (header.nodes[entryIdx] > kMaxTableEntry) then begin
				validHeader := FALSE;
				Leave;
			end;
		end;
	end;
	DecompressHeader := validHeader;
end;



function SafePtrAndHand
	(
	sourcePtr:			Ptr;
	var destHnd:		univ Handle;
	theSize:			LONGINT
	):BOOLEAN;
	
var
	success:	BOOLEAN;
	theErr:		OSErr;
	
begin
	success:=FALSE;
	if sourcePtr <> nil then begin
		theErr:=PtrAndHand(sourcePtr,destHnd,theSize);
		if theErr = noErr then begin
			success:=(destHnd <> nil);
		end
		else;
	end;
	SafePtrAndHand:=success;
end;



function SafeSetHandleSize(theHandle:univ Handle;theSize:LONGINT):BOOLEAN;
{ Sets size of handle, filling empty space with zeroes on increasing size, or invalid space with $FDs on decreasing size.
Setting size to zero gives valid zero size handle.  Returns TRUE if setting handle size successful.  Assert if unsuccessful.
Checks to ensure that valid handle has been passed}
const
	kFailed = FALSE;
	kSucceeded = TRUE;

var
	theErr:OSErr;
	success:BOOLEAN;
begin
	SafeSetHandleSize:=FALSE;
	success:=kFailed;
	if (theHandle <> nil) then
	begin
		SetHandleSize(theHandle,theSize);
		theErr:=MemError;
		if theErr = noErr then
		begin
			success:=kSucceeded;
		end;
	end;
	SafeSetHandleSize:=success;
end;


function HuffmanEncode
	(
	inputFile:			Ptr;
	inputSize:			LONGINT;
	var outputFile:		Univ Handle
	):BOOLEAN;

type
	LPtr				= ^LONGINT;
	
var
	huffTable:			HuffmanPtr;
	theErr:			OSErr;
	success:			BOOLEAN;
	byteIdx:			LONGINT;
	theByte:			UnsignedByte;
	parentNode:		INTEGER;
	header:			HeaderRec;
	headerSize:		INTEGER;
	outputSize:		LONGINT;
	worthEncoding:		BOOLEAN;
	
begin
	{create the output handle first}
	if (outputFile <> nil) then begin
		SetHandleSize(outputFile,0);
		success:=MemError = noErr;
	end
	else begin
		outputFile:=NewHandle(0);
		success := (outputFile <> nil) & (MemError = noErr);
	end;
	
	if success then begin	
		{create the table structure}
		huffTable := nil;
		huffTable := HuffmanPtr(NewPtrClear(SizeOf(HuffmanArray)));
		theErr := MemError;
		success := (theErr = noErr) & (huffTable<> nil);
		
		if success then begin
			InitialiseTable(huffTable);
			
			{count the frequencies first}
			for byteIdx := 1 to inputSize do begin
				theByte := PBytePtr(inputFile)^[byteIdx];
				Inc(huffTable^[theByte].frequency);
			end;
						
			{now assign the encodings to the characters according to frequency}
			success := AssignEncodings(huffTable, parentNode);
			
			{create the header}
			for byteIdx := 0 to kMaxCharEntry do
				header.nodes[byteIdx] := 0;
			header.numNodes := 0;
			TraverseInternalNodes(huffTable, parentNode, MakeTable, @header);
			LPtr(@header.output)^ := inputSize;
			header.output[kEncodingTypeLoc] := kHuffmanEncoded;
			header.output[kNumNodesLoc] := header.numNodes;
			CompressHeader(header, headerSize);
			
			{insert the header into the beginning of the file.}
			success := SafePtrAndHand(@header.output, outputFile, headerSize);
			
			{resize the output so that it will take the encoding.  Use a worst case assumption about the size to start with,
			we will resize the handle later}
			if success then
				success := SafeSetHandleSize(outputFile, inputSize + headerSize);
			
			{now create the outputFile.  The routine shouldn't move memory, but why take a chance}
			if success then begin
				HLockHi(outputFile);
				TranslateEncodingsToOutput(huffTable, PBytePtr(inputFile), PBytePtr(Ord(outputFile^)+headerSize), inputSize, outputSize);
				HUnlock(outputFile);
				worthEncoding := outputSize+headerSize < inputSize;
				if worthEncoding then
					success := SafeSetHandleSize(outputFile, outputSize + headerSize);
			end;
			
			{it is possible that we have been wasting our time, if so don't waste space as well, just put a short header in and return the uncompressed text}
			if not worthEncoding then begin
				success := SafeSetHandleSize(outputFile, kEncodingTypeLoc);
				if success then begin
					PByteHnd(outputFile)^^[kEncodingTypeLoc] := kNotEncoded;
					success := SafePtrAndHand(inputFile, outputFile, inputSize);
				end;
			end;		
			InitialiseTable(huffTable);
			DisposePtr(Ptr(huffTable));
		end;
	end;
	
	HuffmanEncode := success;
end;



function HuffmanDecode
	(
	inputFile:			Ptr;
	inputSize:			LONGINT;
	var outputFile:		Univ Handle
	):CompressionErrorType;

const
	kBitsInByte		= 8;
		
type
	LPtr				= ^LONGINT;
	
var
	huffTable:			HuffmanPtr;
	theErr:			OSErr;
	outcome:			CompressionErrorType;
	enoughMemory:		BOOLEAN;
	outputSize:		LONGINT;
	header:			HeaderRec;
	headerSize:		LONGINT;
	encodingType:		UnsignedByte;
	
begin
	encodingType := PBytePtr(inputFile)^[kEncodingTypeLoc];
	if (encodingType in [kNotEncoded,  kHuffmanEncoded]) then
		outcome := eNoCompressionError
	else
		outcome := eInvalidEncodingError;
	
	{Assert(outcome = eNoCompressionError);}
	
	if outcome = eNoCompressionError then begin
		
		{create the output handle first}
		if (outputFile <> nil) then
			enoughMemory := SafeSetHandleSize(outputFile, 0)
		else begin
			outputFile:=NewHandle(0);
			enoughMemory := (outputFile <> nil) & (MemError = noErr);
		end;
		
		if enoughMemory then begin	
		
			{it is possible that we decided not to encode the data, as there was no saving obtained by doing so.  Check for this here}
			if encodingType = kHuffmanEncoded then begin
			
				{create the table structure}
				huffTable := nil;
				huffTable := HuffmanPtr(NewPtrClear(SizeOf(HuffmanArray)));
				theErr := MemError;
				enoughMemory := (theErr = noErr) & (huffTable <> nil);
				
				if enoughMemory then begin

					{recreate the binary tree}
					InitialiseTable(huffTable);
					header.numNodes := PBytePtr(inputFile)^[kNumNodesLoc];
					header.entryIdx := 0;
					outputSize := LPtr(inputFile)^;
					
					{now the output size must be between 8x the input size, ie best possible compression, and the input size
					as we would not have bothered to compress it otherwise.  If it is not, then our data is irretrievable corrupted}
					if not ((outputSize > inputSize )&(outputSize <= (inputSize-kEncodingTypeLoc) * 8)) then
						outcome := eGarbledMessageError;
					
					if outcome = eNoCompressionError then
						if not  DecompressHeader(PBytePtr(Ord(inputFile) + (kNumNodesLoc) * SizeOf(UnsignedByte)), header) then
							outcome := eGarbledMessageError;
					
					if outcome = eNoCompressionError then begin
						{we will declare kHeadNode as the parentNode as it hasn't been used in the binary tree}
						TraverseInternalNodes(huffTable, kHeadNode, RecreateTree, @header);
						if not  CheckTreeIsValid(huffTable, kHeadNode) then
							outcome := eGarbledMessageError;
					end;
									
					{resize the output so that it will take the decoded text}
					if outcome = eNoCompressionError then
						enoughMemory := SafeSetHandleSize(outputFile, outputSize);
					
					{now create the outputFile.}
					if enoughMemory  & (outcome = eNoCompressionError) then begin
						headerSize := header.numNodes * kNumHeaderBits * 2;
						if headerSize mod kBitsInByte = 0 then
							headerSize := headerSize div kBitsInByte
						else
							headerSize := headerSize div kBitsInByte + 1;
						headerSize := headerSize + kEncodingTypeLoc +1;
						
						if not DecodeEncodingsToInput(huffTable, kHeadNode, inputSize - headerSize, outputSize, PBytePtr(Ord(inputFile)+ headerSize), PByteHnd(outputFile)) then
							outcome := eGarbledMessageError;
					end;
					
					InitialiseTable(huffTable);
					DisposePtr(Ptr(huffTable));
				end;
			end
			else begin
				
				{the file is not encoded, just copy it to the output file.  Make a quick check to see that we haven't been passed some garbage
				data with a 0 at the encoding type location}
				outputSize := LPtr(inputFile)^;
				if outputSize = inputSize - kEncodingTypeLoc then
					enoughMemory := SafePtrAndHand(Ptr(Ord(inputFile)+kEncodingTypeLoc ), outputFile, inputSize - kEncodingTypeLoc )
				else
					outcome := eGarbledMessageError;
			end;
		end;
		
		if not enoughMemory then
			outcome := eNotEnoughMemoryError;
	end;
	
	HuffmanDecode := outcome;
end;

end.