Сортировка последовательности целых чисел методом прямого слияния и методом цифровой сортировки - Turbo Pascal - Ответ 1328066

program Slip;
uses
  crt;
type
ptr=^tptr;
Tptr=record
  name:integer;
  next:ptr;
end;
var
N:integer;
procedure PrintMas(pos:ptr);           {вывод на экран}
begin
while pos<>nil do
begin
  write(pos^.naME:8);
  pos:=pos^.next;
end;
end;
 
function CreateMas(N:integer):ptr;      {создание массива}
var
  p:ptr;
  i:integer;
begin
randomize;
new(p);
CreateMas:=p;
p^.name:=random(90)+10;
for i:=2 to N do
  begin
    new(p^.next);
    p:=p^.next;
    p^.name:=random(90)+10;
  end;
  p^.next:=nil;
end;
{деление массива на две части с чередованием по N элементов}
procedure DelMasAsN(S:ptr;var a,b:ptr;N:integer);
var
  I:integer;
  f:boolean;
  a1,b1,a2,b2,s1:ptr;
begin
new(a);
new(b);
a1:=a;
b1:=b;
s1:=s;
f:=false;
i:=-1;
while s<>nil do
  begin
  inc(i);
  if (i mod N)=0 then
    if f then f:=false
    else f:=true;
 
  if f then
    begin
    {a массив}
      a1^.name:=s^.name;
      new(a1^.next);
      a2:=a1;
      a1:=a1^.next;
    end
  else
    begin
    {b массив}
      b1^.name:=s^.name;
      new(b1^.next);
      b2:=b1;
      b1:=b1^.next;
    end;
    s:=s^.next;
  end;
Dispose(a1);
Dispose(b1);
a1:=a2;
b1:=b2;
a1^.next:=nil;
b1^.next:=nil;
s:=s1;
while s1<>nil do
  begin
    s:=s1^.next;
    Dispose(s1);
    s1:=s;
  end;
end;
 
function LenMas(s:ptr):integer; {длина массива}
var
  I:integer;
begin
i:=0;
  while (s<>nil) do
  begin
    inc(i);
    s:=s^.next;
  end;
LenMas:=i;
end;
 
procedure SlipMas(a,b:ptr;var C:ptr);   {слияние массива}
var
  q,r:integer;
  c1,c2:ptr;
begin
  c:=nil;
  if (a=nil) and (b=nil) then exit;
  q:=LenMas(a);
  r:=LenMas(b);
  new(c);
  c1:=c;
  while ((q<>0) and (r<>0)) do
    begin
      if (a^.name<=b^.name) then
        begin
          c1^.name:=a^.name;
          a:=a^.next;
          q:=q-1;
        end
      else
        begin
          c1^.name:=b^.name;
          b:=b^.next;
          r:=r-1;
        end;
      new(c1^.next);
      c2:=c1;
      c1:=c1^.next;
    end;
  while q>0 do
    begin
      c1^.name:=a^.name;
      a:=a^.next;
      q:=q-1;
      new(c1^.next);
      c2:=c1;
      c1:=c1^.next;
    end;
  while r>0 do
    begin
      c1^.name:=b^.name;
      b:=b^.next;
      r:=r-1;
      new(c1^.next);
      c2:=c1;
      c1:=c1^.next;
    end;
  Dispose(c1);
  c1:=c2;
  c1^.next:=nil;
end;
{копирование части массива из S массива с i-го символа длинной count}
function CopyMas(S:ptr;i,count:integer):ptr;
var
  p,p1:ptr;
  l,j,k:integer;
begin
CopyMas:=nil;
if LenMas(S)<i then exit;
new(p);
Copymas:=p;
j:=0;
k:=0;
while s<>nil do
  begin
    inc(j);
    if j>=i then
      begin
        inc(k);
        if (k<=count) then
          begin
            p^.name:=s^.name;
            new(p^.next);
            p1:=p;
            p:=p^.next;
          end;
      end;
    s:=s^.next;
  end;
  Dispose(p);
  p:=p1;
  p^.next:=nil;
end;
 
procedure DestroyMas(S:ptr);  {разрушение массива}
var
 S1:ptr;
begin
s1:=s;
while s1<>nil do
  begin
    s:=s1^.next;
    Dispose(s1);
    s1:=s;
  end;
end;
  {яЁюуЁрььр ёыш*эш}
 
procedure Exempel(S:ptr; var C:ptr);
var
  L,n,i,x:integer;
  a,b,a0,b0,a1,b1,c0,c1,ax,bx,ahead,bhead:ptr;
begin
  L:=LenMas(S);           {определяю длинну}
  DelMasAsN(S,a,b,1);     {делю пополам с чередованием 1}
  printMas(a);
  writeln;
  printMas(b);
  writeln;
  writeln;
  n:=1;
while (L>=2*n) do        {цикл определяет число итераций}
begin
  i:=1;
  while (L div 2)>=i do   {цикл формирования массивов с0 и с1  }
  begin
    a0:=CopyMas(a,i,n);   {копирую из массива элементы с очередностью n в a0}
    b0:=CopyMas(b,i,n);
    SlipMas(a0,b0,c0);    {сливаю эти элементы}
    DestroyMas(a0);       {роазрушаю ненужные массивы}
    DestroyMas(b0);
    i:=i+n;               {закончено формирование части элементов массива с0}
    a1:=CopyMas(a,i,n);
    b1:=CopyMas(b,i,n);
    SlipMas(a1,b1,c1);
    DestroyMas(a1);
    DestroyMas(b1);       {закончено формирование части элементов массива с1 }
    if i=(1+n) then       {слияние всех кусочков массива с1 и с0 }
      begin
        ahead:=c0;
        bhead:=c1;
        while c0^.next<>nil do c0:=c0^.next;
        while c1^.next<>nil do c1:=c1^.next;
        ax:=c0;
        bx:=c1;
        ax^.next:=nil;
        bx^.next:=nil;
      end
    else
      begin
        ax^.next:=c0;
        bx^.next:=c1;
        while ax^.next<>nil do ax:=ax^.next;
        while bx^.next<>nil do bx:=bx^.next;
        ax^.next:=nil;
        bx^.next:=nil;
      end;
    i:=i+n;
  end;
  DestroyMas(a);
  DestroyMas(b);
  a:=ahead;
  b:=bhead;
  printMas(a);    {вывод результата итерации}
  writeln;
  printMas(b);
  writeln;
  writeln;
  n:=2*n;
end;
  SlipMas(a,b,c);  {слияние оконечного результата}
end;
 
var
  head,mas:ptr;
begin
clrscr;
write('                    Введите количество элементов в массиве= ');
readln(N);
head:=CreateMas(N); {создаю массив элементов}
printmas(head);      {выважу на экран}
writeln;
Exempel(head,mas);   {сортирую}
printmas(mas);       {вывод конечного результата}
readln;
end.

program Digital;
 
uses
 crt,dos;
type
ptr=^tptr;
tptr=record
  Name:integer;
  next:ptr;
end;
var
NN:integer;
 
procedure PrintMas(pos:ptr);       {вывод элементов}
begin
while pos<>nil do
begin
  write(pos^.name:8);
  pos:=pos^.next;
end;
end;
 
function CreateMas(N:integer):ptr;      {создаю массив элементов}
var
  p:ptr;
  i:integer;
begin
randomize;
new(p);
CreateMas:=p;
p^.name:=random(90)+10;
for i:=2 to N do
  begin
    new(p^.next);
    p:=p^.next;
    p^.name:=random(90)+10;
  end;
  p^.next:=nil;
end;
 
Function IntToStr(I:integer):String;
{ Преобразовывает значение типа Integer в String }
Var S:String[10];
Begin
 Str(I,S);
 IntToStr:=S;
End;
 
Function Strtoint(S:string):integer ;
 {Преобразовывает значение типа String в integer }
Var E,L:integer;
Begin
E:=0;
 val(s,L,E);
{  if E<>0 then  }
 strtoint:=L;
End;
 
function infoMas(pos:ptr;var Count:integer;const index:integer):integer;
{определяет порядок элементов в массиве и их систему счисления}
var
  S:ptr;
x, L,L1:integer;
 name:string;
begin
{index:=1;}
  S:=pos;
  Count:=0;
  while S<>nil do
  begin
    name:=inttostr(S^.Name);
    L:=length(Name);
    if L>Count then Count:=L;
    S:=S^.next;
  end;
  S:=pos;
  L1:=0;
  while S<>nil do
  begin
    name:=inttostr(S^.Name);
    L:=length(Name);
    if count>=index then
      if L>=index then
        begin
         L:=strtoint(name[L+1-index]); 
          if L>=L1 then
        L1:=L;
        end;
    S:=S^.next;
  end;
  infomas:=L1;
end;
 
procedure DestroyMas(S:ptr);  {уничтожение всех элементов массива}
var
 S1:ptr;
begin
s1:=s;
while s1<>nil do
  begin
    s:=s1^.next;
    Dispose(s1);
    s1:=s;
  end;
end;
 
function digitMas(pos:ptr; index,digit:integer):ptr;
{процедура формирования массива по двум параметрам: }
{ dijit -системы счисленияш* index - параметр элемента}
var
  p,a,a1,heada:ptr;
  name:string;
  L:integer;
begin
  a1:=nil;
  p:=pos;
  new(heada);
  a:=heada;
  while p<>nil do
  begin
    Name:=inttostr(p^.name);
    L:=length(Name);
    if L>=index then
      begin
        if {strtoint}(name[l+1-index])=inttostr(digit) then
          begin
            a^.Name:=p^.Name;
            new(a^.next);
            a1:=a;
            a:=a^.next;
          end;
      end
    else
      if digit=0 then
      begin
        a^.Name:=p^.Name;
        new(a^.next);
        a1:=a;
        a:=a^.next;
      end;
    p:=p^.next;
  end;
  Dispose(A);
  a:=a1;
  DigitMas:=heada;
  if a<>nil then a^.next:=nil
  else DigitMas:=nil;
end;
 
var
  Head,p:ptr;
  a:string;
 b, L,k,i,j,n:integer;
  HeadMas:array[0..256] of ptr;
  begin
  clrscr;
   writeln;
   write('                 Введите количество элементов в массиве= ' );
  readln(NN);
  clrscr;
    head:=CreateMas(NN); {создаю массив}
      PrintMas(head);      {отображаю его}
      InfoMas(head,L,i);     {определяю число символов в элементе массива }
  for i:=1 to L do         {цикл прогонки по порядку цифр}
  begin
    k:=InfoMas(head,L,i);  {определяю систему счисления у i-ых символов}
    for j:=0 to k do       {цикл прогонки по системе счисления}
    begin
      HeadMas[j]:=digitMas(head,i,j); {создает массив из i-го порядка и
                                         j-ой системы счисления *}
      write('Q',j,':');
      PrintMas(HeadMas[j]);
      writeln;
    end;
    DestroyMas(head);        {разрушаю массив}
      for n:=0 to (k) do  {проверяю на наличие массива в массиве заголовк в Headmas}
    begin
      if HeadMas[n]<>nil then break;
    end;
    head:=HeadMas[n];     {устанавливаю n-й заголовок}
    p:=HeadMas[n];
    if p<>nil then                         {прогоняюмассив вконец}
    while p^.next<>nil do p:=p^.next;
    for j:=n to k do                    {формирую массив}
    begin
      p^.next:=headMas[j+1];
      if p<>nil then
      while p^.next<>nil do p:=p^.next;
    end;
    printmas(head); {вывод массива}
  end;
  readln;
end.