Поразрядная сортировка целых положительных чисел
{$R-}
Program xa;
uses
crt;
type
itype=longint; {Тип сортируемых данных}
TTImas=array [1..1] of itype;
TImas=^TTImas;
ltype=byte; {Тип для массива "карманов"}
TTBmas=array [1..1] of ltype;
TBmas=^TTBmas;
{процедура вывода массива}
procedure printmas(mas:TImas; n:longint);
var
i:longint;
begin
for i:=1 to n do
Write(mas^[i], ' ');
end;
{Процедура определения длинны числа}
function lengthi(ch:longint):integer;
var
s:string;
begin
str(ch,s);
lengthi:=length(s);
end;
{Процедура определяющая в какой "карман" пойдёт число}
function numberpos(ch,posi:longint):integer;
var
s:string;
code,tmpi:integer;
begin
str(ch,s);
if length(s)<posi then
numberpos:=0
else
begin
delete(s,1,length(s)-posi);
if length(s)>1 then
delete(s,2,length(s)-1);
val(s,tmpi,code);
numberpos:=tmpi
end;
end;
{Процедура сортировки}
procedure sortmas(var mas:TImas; n:longint);
var
i,k,koliter,posf,l,posi,tmp:longint;
mastmp:TImas;
pos:TBmas;
begin
koliter:=0;
GetMem(MasTmp,sizeof(itype)*n);
GetMem(pos,sizeof(ltype)*n);
for i:=1 to n do
begin
if lengthi(mas^[i])>koliter then
koliter:=lengthi(mas^[i]);
pos^[i]:=0;
end;
for i:=1 to koliter do
begin
for k:=1 to n do
begin
pos^[k]:=numberpos(mas^[k],i);
mastmp^[k]:=mas^[k];
end;
posi:=1;
for posf:=0 to 9 do
for k:=1 to n do
if (pos^[k]=posf) then
begin
mas^[posi]:=mastmp^[k];
inc (posi);
end;
end;
end;
{Процедура проверки правильности сортировки}
function yes(mas:TImas; n:longint):boolean;
var
flag:boolean;
i:longint;
begin
flag:=true;
i:=n;
while (i>1) and flag do
begin
if mas^[i]<mas^[i-1] then
flag:=False;
dec(i);
end;
yes:=flag;
end;
var
massiv:TImas;
i,n:longint;
begin
repeat
clrscr;
Write('Vvedute pa3mepHoCt'' massiva, n= ');
readln(n);
until (n>0);
clrscr;
Writeln('VVedute elemenTbl massiva');
GetMem(massiv,sizeof(itype)*n);
for i:=1 to n do
begin
Write('Massiv[',i,']= ');
readln(massiv^[i]);
end;
clrscr;
writeln('massiv do coptupovki:');
printmas(massiv,n);
sortmas(massiv,n);
writeln;
writeln;
writeln('massiv posle sortupovku');
printmas(massiv,n);
writeln;
Write('Macciv otcoptipovan ');
if yes(massiv,n) then
writeln('pravul''no')
else
writeln('nepravil''no');
readln;
FreeMem(massiv,sizeof(itype)*n);
end.
{$R+}
Комментарии:
Нету комментариев для вывода...