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

Array123. Дано целое число $$K (\gt 1)$$ и целочисленный массив размера $$N$$. Поменять местами первую серию массива и его серию с номером $$K$$. Если серий в массиве меньше $$K$$, то вывести массив без изменений.

Решение:

program Array123;
var
 a,b : array [1..20] of real;
 N,K,i,i2,ki,tempi: integer;
 addSeries:boolean;


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

 Write('K: ');
 Readln(K);

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


 tempi:=0;
 ki:=1;

//в начале в массив b заносим значения из k раздела
 for i:=1 to N do
  begin
   if ki = K  then
    begin
     inc(tempi);
     b[tempi]:=a[i];
    end;
   if i<>N then
    if a[i]<>a[i+1] then inc(ki);
  end;
//дальше заполняем весь массив значениями
 addSeries:=False;
 ki:=1;
 for i:=1 to N do
  begin
 //если значение не из перой серии и не является k-ой серией перенести значение в массив b
   if (ki > 1) and (ki <> K)  then
    begin
     inc(tempi);
     b[tempi]:=a[i];
    end;

// если значение принадлежит k серии то добавляем вместо него 1 серию.
   if (ki = K) and not(addSeries) and (k <> 1) then //если задано k равной 1 ничего не делать
    begin
     i2:=0;
     addSeries:=True; // говорим что один раз уже добавили массив
     repeat
       inc(tempi);
       inc(i2);
       b[tempi]:=a[i2];
     until (a[i2]<>a[i2+1])
    end;

   //смотрим будет ли следующий элемент из другой серии, если да то увеличивем значение ki
   if i<>N then
    if a[i]<>a[i+1] then inc(ki);
  end;


 a:=b;
 for i:=1 to tempi do writeln(a[i]);
end.

program Array123;

var

a,b : array [1..20] of real;

N,K,i,i2,ki,tempi: integer;

addSeries:boolean;

begin

Write('N: ');

Readln(N);

Write('K: ');

Readln(K);

Writeln('A: ');

for i:=1 to N do

begin

write(i,' :');

readln(a[i]);

end;

tempi:=0;

ki:=1;

//в начале в массив b заносим значения из k раздела

for i:=1 to N do

begin

if ki = K then

begin

inc(tempi);

b[tempi]:=a[i];

end;

if i<>N then

if a[i]<>a[i+1] then inc(ki);

end;

//дальше заполняем весь массив значениями

addSeries:=False;

ki:=1;

for i:=1 to N do

begin

//если значение не из перой серии и не является k-ой серией перенести значение в массив b

if (ki > 1) and (ki <> K) then

begin

inc(tempi);

b[tempi]:=a[i];

end;

// если значение принадлежит k серии то добавляем вместо него 1 серию.

if (ki = K) and not(addSeries) and (k <> 1) then //если задано k равной 1 ничего не делать

begin

i2:=0;

addSeries:=True; // говорим что один раз уже добавили массив

repeat

inc(tempi);

inc(i2);

b[tempi]:=a[i2];

until (a[i2]<>a[i2+1])

end;

//смотрим будет ли следующий элемент из другой серии, если да то увеличивем значение ki

if i<>N then

if a[i]<>a[i+1] then inc(ki);

end;

a:=b;

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

end.

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

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

Program a123;

Type
 mass = array [1..20] of integer; 

Procedure Swap(n,Seria1,num1,Start1,End1,SeriaK,numK,StartK,EndK:integer; Var a:mass);
Var i,j:integer;
Begin
 If (Seria1<>SeriaK) then
 Begin
 
  If (Seria1<SeriaK) then
  Begin
   For j:=1 to (SeriaK-Seria1) do
    Begin
     Inc(n);
     For i:=n downto 2 do a[i]:=a[i-1];
    End;
   For i:=1 to SeriaK do a[i]:=numK;
   StartK:=StartK+(SeriaK-Seria1);
   EndK:=EndK-1;
   For i:=StartK to n-1 do a[i]:=a[i+1];
   N:=N-(SeriaK-Seria1);
   For i:=StartK to EndK do a[i]:=num1;
  End;
 
  If (Seria1>SeriaK) then
  Begin
   End1:=End1-(Seria1-SeriaK);
   For j:=1 to (Seria1-SeriaK) do
    For i:=End1 to n-1 do a[i]:=a[i+1];
   StartK:=StartK-(Seria1-SeriaK);
   End1:=End1-1;
   EndK:=EndK-1;
   For i:=1 to End1 do a[i]:=numK;
   For i:=StartK to EndK do a[i]:=num1;
  End;
  
 End
 
 Else
 Begin
  For i:=Start1 to (End1-1) do a[i]:=numK;
  For i:=StartK to (EndK-1) do a[i]:=num1;
 End;
 
End;

Var
 a: mass;
 n,i,k: integer;
 Seria1,num1,Start1,End1,SeriaK,numK,StartK,EndK: integer;
 
Begin
Randomize;
 n:=random(6)+4;
 Writeln('N=',n);
 Write('K=');
 Readln(k);
 Massiv(n,a);
 Start1:=1;
 End1:=1;
 Num1:=a[Start1];
 StartK:=1;
 EndK:=1;
 For i:=2 to n do
  Begin
   If (a[i]<>a[i-1]) then
    Begin
     Inc(StartK);
     If (End1=1) then End1:=i;
    End;
   If (StartK=k) then Break;
  End;
 If (StartK=k) then
  Begin
   StartK:=i;
   NumK:=a[StartK];
   EndK:=i;
   Repeat Inc(EndK);
   Until (a[EndK]<>a[StartK]);
   Seria1:=End1-Start1;
   SeriaK:=EndK-StartK;
   Swap(n,Seria1,num1,Start1,End1,SeriaK,numK,StartK,EndK,a);
  End;
 Write('A: ');
 For i:=1 to n do Write(a[i]:4);
End.

Program a123;

Type

mass = array [1..20] of integer;

Procedure Swap(n,Seria1,num1,Start1,End1,SeriaK,numK,StartK,EndK:integer; Var a:mass);

Var i,j:integer;

Begin

If (Seria1<>SeriaK) then

Begin

If (Seria1<SeriaK) then

Begin

For j:=1 to (SeriaK-Seria1) do

Begin

Inc(n);

For i:=n downto 2 do a[i]:=a[i-1];

End;

For i:=1 to SeriaK do a[i]:=numK;

StartK:=StartK+(SeriaK-Seria1);

EndK:=EndK-1;

For i:=StartK to n-1 do a[i]:=a[i+1];

N:=N-(SeriaK-Seria1);

For i:=StartK to EndK do a[i]:=num1;

End;

If (Seria1>SeriaK) then

Begin

End1:=End1-(Seria1-SeriaK);

For j:=1 to (Seria1-SeriaK) do

For i:=End1 to n-1 do a[i]:=a[i+1];

StartK:=StartK-(Seria1-SeriaK);

End1:=End1-1;

EndK:=EndK-1;

For i:=1 to End1 do a[i]:=numK;

For i:=StartK to EndK do a[i]:=num1;

End;

End

Else

Begin

For i:=Start1 to (End1-1) do a[i]:=numK;

For i:=StartK to (EndK-1) do a[i]:=num1;

End;

Var

a: mass;

n,i,k: integer;

Seria1,num1,Start1,End1,SeriaK,numK,StartK,EndK: integer;

Begin

Randomize;

n:=random(6)+4;

Writeln('N=',n);

Write('K=');

Readln(k);

Massiv(n,a);

Start1:=1;

End1:=1;

Num1:=a[Start1];

StartK:=1;

EndK:=1;

For i:=2 to n do

Begin

If (a[i]<>a[i-1]) then

Begin

Inc(StartK);

If (End1=1) then End1:=i;

End;

If (StartK=k) then Break;

End;

If (StartK=k) then

Begin

StartK:=i;

NumK:=a[StartK];

EndK:=i;

Repeat Inc(EndK);

Until (a[EndK]<>a[StartK]);

Seria1:=End1-Start1;

SeriaK:=EndK-StartK;

Swap(n,Seria1,num1,Start1,End1,SeriaK,numK,StartK,EndK,a);

End;

Write('A: ');

For i:=1 to n do Write(a[i]:4);

End.

Ответить

Anton

04.05.2017 в 11:12

Много букв не осилил 🙂
только в 60 строчке какая то странная функция Massiv. А что она должна делать?
Потому как в коде объяснения этому нет 🙂

Ответить
- Kirk
  
  05.05.2017 в 19:13
  
  Куда то пропала процедура построения массива ^^»
  
  Ответить

Решение двумя реверсами. Позже попробую еще вставкой плюс циклический сдвиг.

program Array123;//fp

var
  a: array[1..10] of integer = (1, 2, 2, 3, 3, 4, 5, 5, 6, 7);
  i, j, n, k, m, Len1, LenK, tmp, p: integer;

begin
  n := 10;
  for i := 1 to n do begin{a[i] := Random(2) + 1;}Write(a[i], ' '); end;
  Writeln;
  k := 5;
  
  i := 1;
  m := 1;//счетчик серий
  Len1 := 0;//длина 1-й серии
  LenK := 0;//длина k-й серии
  
  while i <= n do
  begin
    if m = 1 then Len1 += 1;
    if (i = n) or (a[i] <> a[i + 1]) then m += 1;//если конец массива (i=n) или переход к след серии
    if m = k then LenK += 1;
    if m = k + 1 then //как только заканчивается серия k
    begin
      for j := 1 to i div 2 do//первый реверс от 1-й до k-й серии (включительно)
      begin
        tmp := a[j];
        a[j] := a[i - j + 1];
        a[i - j + 1] := tmp
      end;
      
      if k <= 3 then break;//если k<=3 то достаточно первого реверса
      
      j := LenK + 1;
      for p := 1 to (i - (Len1 + LenK)) div 2 do//второй реверс между k-й и 1-й сериями
      begin
        tmp := a[j];
        a[j] := a[i - Len1 + 1 - p];
        a[i - Len1 + 1 - p] := tmp;
        j += 1;
      end;
      break
    end;
    i += 1
  end;
  
  for i := 1 to n do Write(a[i], ' ');//5 5 2 2 3 3 4 1 6 7
  Readln;
end.

program Array123;//fp

var

a: array[1..10] of integer = (1, 2, 2, 3, 3, 4, 5, 5, 6, 7);

i, j, n, k, m, Len1, LenK, tmp, p: integer;

begin

n := 10;

for i := 1 to n do begin{a[i] := Random(2) + 1;}Write(a[i], ' '); end;

Writeln;

k := 5;

i := 1;

m := 1;//счетчик серий

Len1 := 0;//длина 1-й серии

LenK := 0;//длина k-й серии

while i <= n do

begin

if m = 1 then Len1 += 1;

if (i = n) or (a[i] <> a[i + 1]) then m += 1;//если конец массива (i=n) или переход к след серии

if m = k then LenK += 1;

if m = k + 1 then //как только заканчивается серия k

begin

for j := 1 to i div 2 do//первый реверс от 1-й до k-й серии (включительно)

begin

tmp := a[j];

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

a[i - j + 1] := tmp

end;

if k <= 3 then break;//если k<=3 то достаточно первого реверса

j := LenK + 1;

for p := 1 to (i - (Len1 + LenK)) div 2 do//второй реверс между k-й и 1-й сериями

begin

tmp := a[j];

a[j] := a[i - Len1 + 1 - p];

a[i - Len1 + 1 - p] := tmp;

j += 1;

end;

break

end;

i += 1

end;

for i := 1 to n do Write(a[i], ' ');//5 5 2 2 3 3 4 1 6 7

Readln;

end.

Ответить

program Array123;//pabc.net

begin
  var n := 10;
  var a := Lst(1, 2, 2, 3, 3, 4, 5, 5, 6, 7); a.Println;
  var k := 5;
  
  var i := 1;
  var m := 1;//счетчик серий
  var Len1 := 0;//длина первой серии
  var LenK := 0;//длина K-ой серии
  
  while i <= n do
  begin
    if m = 1 then Len1 += 1;
    if (i = n) or (a[i] <> a[i - 1]) then m += 1;// (i=n) если k-серия в конце массива
    if m = k then LenK += 1;
    if m = k + 1 then
    begin
      a := a[i - LenK:i] + a[Len1:i - LenK] + a[:Len1] + a?[i:];
      break;
    end;
    i += 1;
  end;
  
  a.Println;//5 5 2 2 3 3 4 1 6 7
end.

program Array123;//pabc.net

begin

var n := 10;

var a := Lst(1, 2, 2, 3, 3, 4, 5, 5, 6, 7); a.Println;

var k := 5;

var i := 1;

var m := 1;//счетчик серий

var Len1 := 0;//длина первой серии

var LenK := 0;//длина K-ой серии

while i <= n do

begin

if m = 1 then Len1 += 1;

if (i = n) or (a[i] <> a[i - 1]) then m += 1;// (i=n) если k-серия в конце массива

if m = k then LenK += 1;

if m = k + 1 then

begin

a := a[i - LenK:i] + a[Len1:i - LenK] + a[:Len1] + a?[i:];

break;

end;

i += 1;

end;

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

end.

Ответить

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

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

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

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