Решаем задачи Абрамян на Паскале. Array89

Array89. Дан массив размера $$N$$, все элементы которого, кроме одного, упорядочены по убыванию. Сделать массив упорядоченным, переместив элемент, нарушающий упорядоченность, на новую позицию.

Решение:

program Array89;
var
  a : array[1..10] of Integer;
  N,i:Integer;

begin
  Write('N: ');
  Readln(N);

  Writeln('A: ');
  for i:=1 to N do
   begin
    write(i,' :');
    readln(a[i]);
   end;

  for i:=N-1 downto 1 do
   if a[i]<a[i+1] then
    begin
     a[i+1]:=a[i]+a[i+1];
     a[i]:=a[i+1]-a[i];
     a[i+1]:=a[i+1]-a[i];
    end;

   for i:=2 to N do
   if a[i-1]<a[i] then
    begin
     a[i-1]:=a[i]+a[i-1];
     a[i]:=a[i-1]-a[i];
     a[i-1]:=a[i-1]-a[i];
    end;

  for i:=1 to N do writeln(i,' :',a[i]);
end.

program Array89;

var

a : array[1..10] of Integer;

N,i:Integer;

begin

Write('N: ');

Readln(N);

Writeln('A: ');

for i:=1 to N do

begin

write(i,' :');

readln(a[i]);

end;

for i:=N-1 downto 1 do

if a[i]<a[i+1] then

begin

a[i+1]:=a[i]+a[i+1];

a[i]:=a[i+1]-a[i];

a[i+1]:=a[i+1]-a[i];

end;

for i:=2 to N do

if a[i-1]<a[i] then

begin

a[i-1]:=a[i]+a[i-1];

a[i]:=a[i-1]-a[i];

a[i-1]:=a[i-1]-a[i];

end;

for i:=1 to N do writeln(i,' :',a[i]);

end.

Решение от olegst1975:

type
  mas=array [1..10]of real;
var
  n,i:integer;      
  a:mas;
procedure sink(var a:mas;i:integer);
  begin
    if (i=1)or(a[i]<a[i-1]) then exit;
    a[i]:=a[i]+a[i-1];
    a[i-1]:=a[i]-a[i-1];
    a[i]:=a[i]-a[i-1];
    sink(a,i-1);
  end;
begin   
  readln(n);        
  for i:=1 to n do readln(a[i]);   
  for i:=2 to n do sink(a,i);  
  for i:=1 to n do writeln(a[i]);
end.

type

mas=array [1..10]of real;

var

n,i:integer;

a:mas;

procedure sink(var a:mas;i:integer);

begin

if (i=1)or(a[i]<a[i-1]) then exit;

a[i]:=a[i]+a[i-1];

a[i-1]:=a[i]-a[i-1];

a[i]:=a[i]-a[i-1];

sink(a,i-1);

end;

begin

readln(n);

for i:=1 to n do readln(a[i]);

for i:=2 to n do sink(a,i);

for i:=1 to n do writeln(a[i]);

end.

Решение рекурсивное:

type
  mas=array [1..10]of real;
var
  n,i:integer;      
  a:mas;

procedure swap(var i1,i2:real);
begin
  i1:=i1+i2;
  i2:=i1-i2;
  i1:=i1-i2;
end;

procedure sink(var a:mas;n,i:integer);
  begin
    if i>1 then
     if i<=n then
      if (a[i-1]>a[i]) then sink(a,n,i-1)
       else
        begin
         swap(a[i],a[i-1]);
         sink(a,n,i+1);
        end
     else
      sink(a,n,n);
  end;


begin
  readln(n);
  for i:=1 to n do readln(a[i]);
  sink(a,n,n);
  for i:=1 to n do writeln(a[i]);
end.

type

mas=array [1..10]of real;

var

n,i:integer;

a:mas;

procedure swap(var i1,i2:real);

begin

i1:=i1+i2;

i2:=i1-i2;

i1:=i1-i2;

end;

procedure sink(var a:mas;n,i:integer);

begin

if i>1 then

if i<=n then

if (a[i-1]>a[i]) then sink(a,n,i-1)

else

begin

swap(a[i],a[i-1]);

sink(a,n,i+1);

end

else

sink(a,n,n);

end;

begin

readln(n);

for i:=1 to n do readln(a[i]);

sink(a,n,n);

for i:=1 to n do writeln(a[i]);

end.

Решение без использования циклов:

type
  mas=array [1..10]of real;
var
  n,i:integer;      
  a:mas;

procedure swap(var i1,i2:real);
begin
  i1:=i1+i2;
  i2:=i1-i2;
  i1:=i1-i2;
end;

procedure sink(var a:mas;n,i,status:integer);
  begin
   case status of
   1: begin
    if i<=n then
     begin
      Write(i,' : ');
      Readln(a[i]);
      sink(a,n,i+1,1);
     end
    else sink(a,n,n,2);
   end;
   2: begin
    if i>1 then
     if i<=n then
      if (a[i-1]>a[i]) then sink(a,n,i-1,2)
       else
        begin
         swap(a[i],a[i-1]);
         sink(a,n,i+1,2);
        end
     else
      sink(a,n,n,2)
    else
      sink(a,n,1,3);
   end;
   3:begin
      if i<=n then
       begin
        Writeln(i,' : ',a[i]);
        sink(a,n,i+1,3);
       end;
   end;
  end;
end;

begin
  readln(n);
  sink(a,n,1,1);
end.

type

mas=array [1..10]of real;

var

n,i:integer;

a:mas;

procedure swap(var i1,i2:real);

begin

i1:=i1+i2;

i2:=i1-i2;

i1:=i1-i2;

end;

procedure sink(var a:mas;n,i,status:integer);

begin

case status of

1: begin

if i<=n then

begin

Write(i,' : ');

Readln(a[i]);

sink(a,n,i+1,1);

end

else sink(a,n,n,2);

end;

2: begin

if i>1 then

if i<=n then

if (a[i-1]>a[i]) then sink(a,n,i-1,2)

else

begin

swap(a[i],a[i-1]);

sink(a,n,i+1,2);

end

else

sink(a,n,n,2)

else

sink(a,n,1,3);

end;

3:begin

if i<=n then

begin

Writeln(i,' : ',a[i]);

sink(a,n,i+1,3);

end;

begin

readln(n);

sink(a,n,1,1);

end.

Задачи из раздела Array можно посмотреть здесь.

Комментарии 4

[crayon-6743b2106d05f429678127 inline="true" ]
type
  mas=array [1..10]of real;
var
  n,i:integer;      
  a:mas;
procedure sink(var a:mas;i:integer);
  begin
    if (i=1)or(a[i]<a[i-1]) then exit;
    a[i]:=a[i]+a[i-1];
    a[i-1]:=a[i]-a[i-1];
    a[i]:=a[i]-a[i-1];
    sink(a,i-1);
  end;
begin   
  readln(n);        
  for i:=1 to n do readln(a[i]);   
  for i:=2 to n do sink(a,i);  
  for i:=1 to n do writeln(a[i]);
end.

[crayon-6743b2106d05f429678127 inline="true" ]

type

mas=array [1..10]of real;

var

n,i:integer;

a:mas;

procedure sink(var a:mas;i:integer);

begin

if (i=1)or(a[i]<a[i-1]) then exit;

a[i]:=a[i]+a[i-1];

a[i-1]:=a[i]-a[i-1];

a[i]:=a[i]-a[i-1];

sink(a,i-1);

end;

begin

readln(n);

for i:=1 to n do readln(a[i]);

for i:=2 to n do sink(a,i);

for i:=1 to n do writeln(a[i]);

end.

[/crayon]

Ответить

Anton

11.04.2016 в 10:18

мне не нравиться запупск рекурсивной функции в цикле… как то это ресурсозатратно звучит 🙂
в шапку добавил решение где я избавляюсь, от запуска рекурсии в цикле, а потом я изабвился и от всех циклов… 🙂

Ответить
olegst1975

11.04.2016 в 11:35

ОГО! Ну не столько же за одно утро!.. «как то это ресурсозатратно звучит» — да, скорее применимо для сортировки всего массива, а не одно число поставить на место(решение с большииим запасом))

Ответить

Хорошая задача, надо будет по-разбираться в вашем коде. Мое решение — сортировка вставками.

program array_89;//pascalABC.net

procedure InsertShiftRight(a: array of integer; i: integer);
begin
  var j := 0;
  while a[i] < a[j] do inc(j);
  var temp := a[i];
  for var k := i downto j + 1 do
    a[k] := a[k - 1];
  a[j] := temp
end;

procedure InsertShiftLeft(a: array of integer; i: integer);
begin
  var j := a.Length - 1;
  while a[i] > a[j] do dec(j);
  var temp := a[i];
  for var k := i to j - 1 do
    a[k] := a[k + 1];
  a[j] := temp
end;

//главная программа
begin
  var n := 10;
  var a := Arr(9, 8, 7, 0, 6, 5, 4, 3, 2, 1);
  var i, j: integer;
  
  //ищем индекс "неупорядоченного" элемента
  for j := 1 to n - 2 do
    if a[j] > a[j - 1] then
      if a[j - 1] < a[j + 1] then
        begin i := j - 1; break end
      else begin i := j; break end
    else i := n - 1;
  
  //сортировка вставкой со сдвигом элементов вправо, или влево
  if (i = j) or (i = n - 1) then InsertShiftRight(a, i)
  else InsertShiftLeft(a, i);
  
  a.Println;//9 8 7 6 5 4 3 2 1 0
end.

program array_89;//pascalABC.net

procedure InsertShiftRight(a: array of integer; i: integer);

begin

var j := 0;

while a[i] < a[j] do inc(j);

var temp := a[i];

for var k := i downto j + 1 do

a[k] := a[k - 1];

a[j] := temp

end;

procedure InsertShiftLeft(a: array of integer; i: integer);

begin

var j := a.Length - 1;

while a[i] > a[j] do dec(j);

var temp := a[i];

for var k := i to j - 1 do

a[k] := a[k + 1];

a[j] := temp

end;

//главная программа

begin

var n := 10;

var a := Arr(9, 8, 7, 0, 6, 5, 4, 3, 2, 1);

var i, j: integer;

//ищем индекс "неупорядоченного" элемента

for j := 1 to n - 2 do

if a[j] > a[j - 1] then

if a[j - 1] < a[j + 1] then

begin i := j - 1; break end

else begin i := j; break end

else i := n - 1;

//сортировка вставкой со сдвигом элементов вправо, или влево

if (i = j) or (i = n - 1) then InsertShiftRight(a, i)

else InsertShiftLeft(a, i);

a.Println;//9 8 7 6 5 4 3 2 1 0

end.

Ответить

Решаем задачи Абрамян на Паскале. Array89

Комментарии:

Комментарии 4

Добавить комментарий Отменить ответ