Program Huffman;

Const
  n = 255;
  textIn = 'Huffman1.txt'; //Ввод текста
  textOut = 'Huffman2.txt'; //Вывод текста

Type
  symbolsArray = array[1..20000] of string;
  numbersArray = array[1..n] of integer;

Procedure sorting(var tempSymbols: symbolsArray; var numbers: numbersArray; var k: integer);
  Var
    i, j: integer; //Счетчики
    temp1: string; //Переменная для обмена значений
    temp2: integer; //Переменная для обмена значений
  Begin
    for i := 1 to k do
      for j := 1 to (k - 1) do
        if (numbers[j] > numbers[j + 1]) then begin
          temp1 := tempSymbols[j]; tempSymbols[j] := tempSymbols[j + 1]; tempSymbols[j + 1] := temp1;
          temp2 := numbers[j]; numbers[j] := numbers[j + 1]; numbers[j + 1] := temp2;
          end;
  End;

Procedure code(m, k: integer; symbols, tempSymbols: symbolsArray; var codes: symbolsArray);
Var
  i, j: integer; //Счетчики
  flag: boolean; //Флаг
  a, b: byte; //Коды
  line: string;
  Begin
    a := 0; b := 1;
    line := tempSymbols[m + 1];
    for i := 1 to length(line) do begin
      flag := false; j := 1; //Сбрасывание флага и счетчика
      while (flag = false) and (j <= k) do begin
        if (line[i] = symbols[j]) then begin
          if (m = 0) then codes[j] := a + codes[j] else codes[j] := b + codes[j];
          flag := true;
          end;
        j := j + 1;
        end;
      end;
  End;

Var
  tfIn, tfOut: textfile; //Файлы
  text1, text2: symbolsArray; //Текст из файла и текст в файл
  text: string; //Строка текста
  symbols, tempSymbols: symbolsArray; //Символы
  codes: symbolsArray; //Коды символов
  numbers: numbersArray; //Кол-во повторений
  i, j, l, m: integer; //Счетчики
  k, tempK: integer; //Длины массивов
  flag: boolean; //Флаг для прерывание цикла

Begin
  assignfile(tfIn, textIn);
  reset(tfIn);
  m := 0; //Кол-во строк
  //Ввод текста до последней строки
  while not eof(tfIn) do begin
    m := m + 1; //Кол-во строк
    readln(tfIn, text1[m]);
    end;
  closefile(tfIn);
  //Ввод символов
  k := 0; //Кол-во символов
  for l := 1 to m do begin
    text := text1[l];
    for i := 1 to length(text) do begin
      flag := false; j := 1; //Сбрасывание флага и счетчика
      while (flag = false) and (j <= n) do begin  //Нет совпадений - flag = false
        if (text[i] = symbols[j]) then begin
          flag := true;
          numbers[j] := numbers[j] + 1; //+1 к кол-ву повторений
          end;
        j := j + 1;
        end;
      if (flag = false) then begin
        k := k + 1;
        symbols[k] := text[i];
        tempSymbols[k] := text[i];
        numbers[k] := 1;
        end;
      end;
    end;
  tempK := k;
  if (tempK = 1) then codes[1] := '0';
  while (tempK > 1) do begin
    //Сортировка по возрастанию кол-ва повторений
    sorting(tempSymbols, numbers, tempK);
    //Добавление 0 к самому редкому символу
    code(0, k, symbols, tempSymbols, codes);
    //Добавление 1 ко 2-ому самому редкому символу
    code(1, k, symbols, tempSymbols, codes);
    //Соединение двух самых редких строк
    numbers[1] := numbers[1] + numbers[2];
    tempSymbols[1] := tempSymbols[1] + tempSymbols[2];
    if (tempK > 2) then
      for i := 2 to (tempK - 1) do begin
        numbers[i] := numbers[i + 1];
        tempSymbols[i] := tempSymbols[i + 1];
        end;
    tempK := tempK - 1;
    end;
  //Создание нового текста
  for l := 1 to m do begin
    text := text1[l];
    for i := 1 to length(text) do begin
      flag := false; j := 1;
      while (flag = false) and (j <= k) do begin
        if (text[i] = symbols[j]) then text2[l] := text2[l] + codes[j];
        j := j + 1;
        end;
      end;
    end;
  //Вывод архивированного текста
  if (k > 0) then begin
    assignfile(tfOut, textOut);
    rewrite(tfOut);
    for i := 1 to k do writeln(tfOut, symbols[i],' - ', codes[i]);
    writeln(tfOut);
    for i := 1 to m do writeln(tfOut, text2[i]);
    closefile(tfOut);
    end;
end.