Haffmun

program HuffmanCode;
uses
    System.SysUtils;

type
  PNode = ^TNode;
  TNode = record
    ch: Char;
    freq: Integer;
    left, right: PNode;
  end;

  TPriorityQueue = record
    nodes: array of PNode;
    count: Integer;
  end;

  TCharFrequency = record
    ch: Char;
    freq: Integer;
  end;

  THuffmanCode = record
    codeMap: array [Char] of string;
  end;

procedure InitializePriorityQueue(var pq: TPriorityQueue);
begin
  SetLength(pq.nodes, 256);
  pq.count := 0;
end;

procedure Enqueue(var pq: TPriorityQueue; node: PNode);
var
  i: Integer;
begin
  i := pq.count;
  while (i > 0) and (node.freq < pq.nodes[i - 1].freq) do
  begin
    pq.nodes[i] := pq.nodes[i - 1];
    Dec(i);
  end;
  pq.nodes[i] := node;
  Inc(pq.count);
end;

function Dequeue(var pq: TPriorityQueue): PNode;
begin
  if pq.count > 0 then
  begin
    Result := pq.nodes[0];
    Dec(pq.count);
    Move(pq.nodes[1], pq.nodes[0], pq.count * SizeOf(PNode));
  end
  else
    Result := nil;
end;

procedure BuildHuffmanTree(const text: string; var root: PNode);
var
  freq: array [Char] of Integer;
  ch: Char;
  i: Integer;
  node: PNode;
  pq: TPriorityQueue;
begin
  for ch := Low(Char) to High(Char) do
    freq[ch] := 0;

  for i := 1 to Length(text) do
    Inc(freq[text[i]]);

  InitializePriorityQueue(pq);

  for ch := Low(Char) to High(Char) do
  begin
    if freq[ch] > 0 then
    begin
      New(node);
      node.ch := ch;
      node.freq := freq[ch];
      node.left := nil;
      node.right := nil;
      Enqueue(pq, node);
    end;
  end;

  while pq.count > 1 do
  begin
    New(node);
    node.left := Dequeue(pq);
    node.right := Dequeue(pq);
    node.freq := node.left.freq + node.right.freq;
    Enqueue(pq, node);
  end;

  root := Dequeue(pq);
end;

procedure EncodeData(node: PNode; const str: string; var huffmanCode: THuffmanCode);
begin
  if node = nil then
    Exit;

  if (node^.left = nil) and (node^.right = nil) then
    huffmanCode.codeMap[node^.ch] := str
  else
  begin
    EncodeData(node^.left, str + '0', huffmanCode);
    EncodeData(node^.right, str + '1', huffmanCode);
  end;
end;

procedure DecodeData(node: PNode; var index: Integer; const sb: string);
begin
  if node = nil then
    Exit;

  if (node^.left = nil) and (node^.right = nil) then
  begin
    Write(node^.ch);
    Exit;
  end;

  Inc(index);
  if sb[index] = '0' then
    DecodeData(node^.left, index, sb)
  else
    DecodeData(node^.right, index, sb);
end;

procedure FreeTree(node: PNode);
begin
  if node = nil then
    Exit;

  FreeTree(node^.left);
  FreeTree(node^.right);
  Dispose(node);
end;

procedure CreateHuffmanTree(const text: string);
var
  root: PNode;
  huffmanCode: THuffmanCode;
  sb: TStringBuilder;
  i, index: Integer;
  ch: Char;
begin
  if text = '' then
    Exit;

  BuildHuffmanTree(text, root);

  FillChar(huffmanCode, SizeOf(huffmanCode), 0);
  EncodeData(root, '', huffmanCode);

  WriteLn('Huffman Codes of the characters are:');
  for ch := Low(Char) to High(Char) do
  begin
    if huffmanCode.codeMap[ch] <> '' then
      WriteLn(ch, ': ', huffmanCode.codeMap[ch]);
  end;

  WriteLn('The initial string is: ', text);

  sb := TStringBuilder.Create;
  for i := 1 to Length(text) do
    sb.Append(huffmanCode.codeMap[text[i]]);

  WriteLn('The encoded string is: ', sb.ToString);

  Write('The decoded string is: ');
  if (root^.left = nil) and (root^.right = nil) then
  begin
    while root^.freq > 0 do
    begin
      Write(root^.ch);
      Dec(root^.freq);
    end;
  end
  else
  begin
    index := 0;
    while index < sb.Length do
      DecodeData(root, index, sb.ToString);
  end;

  FreeTree(root);
  sb.Free;
end;

var
  text: string;
begin
  text := 'абабвгвгдеде';
  CreateHuffmanTree(text);
  readln;
end.