const
  L2 = 8;
type
  Mas12 = array [1..L2] of string;
  STR = ^STRElement;
  STRElement = record
    data: string;//Значение элемента
    raz: string; //Номер разряда
    right, down: STR;
  end;
procedure RadixSortString(var Mas: Mas12);//Поразрядная сортировка строк
  procedure Obhod1(var Mas: Mas12; a, b, s, e, k: integer);
  //Проход по разряду №b с a наборов значений, от s до e в массиве с макс. разрядом = k
  begin
    //Фаза 1: создание списка разрядов
    var Head, Act, Prev: STR;
    
    for var r := 'а' to 'я' do //Задать список из разрядов
    begin
      new(Act); //Новый элемент списка
      if r = 'а' then //Если разряд первый
      begin
        Head := Act; //Начало списка - актуал
        Prev := Head; //Предыдущий элемент - голова
      end
      else
      begin
        Prev^.right := Act; //Предыдущий для следующего - актуал
        Prev := Prev^.right; //Сдвиг предыдущего на актуал
      end;
      Act^.raz := r; //Разряд актуала - актуальный разряд
      Act := Act^.right; //Сдвиг актуала вправо
    end;
    
    //Фаза 2: заполнение списка разрядов
    for var j := s to e do //Обход каждого элемента
    begin
      var ZnachRaz := Mas[j]; //Запомнить актуальный элемент
      //Отсеивание лишних разрядов с правой части числа
      ZnachRaz := copy(ZnachRaz, b, 1);
      Act := Head; //Вернуть актуал в начало списка
      var temp := Head;
      for var r := 'а' to 'я' do //Занесение элемента в один из разрядов
      begin
        if r = ZnachRaz.ToLower then //Если разряд совпадает со значением разряда элемента
        begin
          while Act <> nil do //Добавить его в нижнюю часть списка
          begin
            Prev := Act; //Предыдущий просмотренный - текущий актуал
            Act := Act^.down; //Сдвиг актуала вниз
          end; //Когда найден конец списка
          new(Act); //Новый элемент
          Prev^.down := Act; //Для предыдущего следующий - актуал
          Act^.data := Mas[j]; //Его значение - значение элемента
          break; //Прервать поиск разрядов для элемента
        end
        else Act := Act^.right; //Разряд не тот? Проверять дальше
        Temp := Temp^.right;
        Act := Temp;
      end;
    end;
    Act := Head;
    
    //Фаза 3: перенос списка разрядов в массив
    var j := s; //Счётчик элементов
    Act := Head; //Переместить актуал в начало
    for var z := 'а' to 'я' do //Пройти по всем подспискам
    begin
      Prev := Act; //Запомнить начало столбца разрядов
      if Act^.down <> nil then println(Act^.raz, '--------------------------------------------------------');
      Act := Act^.down;
      if Act <> nil then while Act <> nil do //Пройти столбец целиком
        begin
          println('Элемент №', j, Act^.data); //Тестовый вывод
          Mas[j] := Act^.data; //Значение массива - значение из столбца
          inc(j); //Увеличить индексный счётчик массива
          Act := Act^.down;
        end;
      Act := Prev^.right; //Перейти на правый разряд 
    end;
    
    //Фаза 4: рекурсия
    e := s; inc(b);
    while e <> L2 do //Пока не будет пройдено всё количество реальных значений разряда
    begin
      //Шаг 1) Выделить подмассив из одинаковых значений разряда
      while (s < L2) and (Mas[s][b] = ' ') do inc(s);
      var TMP := Mas[s][b];
      e := s; //Конец подмассива нужно найти, то есть это поиск с начала массива
      while (e < L2) and (Mas[e + 1][b] = TMP) do inc(e);
      //Шаг 2) Использовать подмассив как массив и обойти его (если b<=k)
      if (b < k) and (s < e) then Obhod1(Mas, 33, b, s, e, k);
      s := e + 1; //Если подмассив пройден, то началом будет конец
    end;
  end;{Конец процедуры обхода}

begin
  var k := 0; //Счётчик разрядов
  for var i := 1 to L2 do //Поиск максимального разряда в массиве
  begin
    var temp1 := Mas[i];
    var temp2 := 0;
    while temp1.Length <> 0 do
    begin
      temp1 := copy(temp1, 1, temp1.Length - 1);
      inc(temp2);
    end;
    if temp2 > k then k := temp2;
  end;
  for var i := 1 to L2 do
    while Mas[i].Length < k do Mas[i] += ' ';
  {Начало сортировки}
  Obhod1(Mas, 33, 1, 1, L2, k);
  for var i := 1 to L2 do
    for var j := Mas[i].Length downto 1 do
      if Mas[i][j] = ' ' then delete(Mas[i], j, 1)
      else break;
end;

        begin
          writeln('Сортировка строк распределением');
          write('Изначальный массив: ');
          var Massiv: Mas12 := ('неделя','око','илья','окно','невод','ил','игла','вилы');
          writeln(Massiv);
          RadixSortString(Massiv);

          writeln(chr(13), 'Сортировка завершена!');
          write('Отсортированный массив: ');
          writeln(Massiv);          
        
end.