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

Array64. Даны три целочисленных массива $$A$$, $$B$$ и $$C$$ размера $$N_A$$, $$N_B$$, $$N_C$$ соответственно, элементы которых упорядочены по убыванию. Объединить эти массивы так, чтобы результирующий целочисленный массив $$D$$ (размера $$N_A + N_B + N_C$$) остался упорядоченным по убыванию.

Решение:

program Array64;

type
 MyArray = array[1..30] of integer;

var
  a,b,c,d,ab: MyArray;
  NA,NB,NC,k:Integer;

Function ConnectionArray(a,b:MyArray;NA,NB:Integer):MyArray;
  var
   tempArray: MyArray;
   i,ia,ib:integer;
  begin
   ia:=1;
   ib:=1;
   for i:=1 to NA+NB do
    begin
     if ia>NA then
      begin
       tempArray[i]:=b[ib];
       inc(ib);
      end
     else
     if ib>NB then
      begin
       tempArray[i]:=a[ia];
       inc(ia);
      end
     else
     if a[ia]>b[ib] then
      begin
       tempArray[i]:=a[ia];
       inc(ia);
      end
     else
      begin
       tempArray[i]:=b[ib];
       inc(ib);
      end;

    end;
    ConnectionArray:=tempArray;
  end;

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

  Writeln('A: ');
  for k:=1 to NA do
   begin
    write(k,' :');
    readln(a[k]);
   end;
  Write('NB: ');
  Readln(NB);

  Writeln('B: ');
  for k:=1 to NB do
   begin
    write(k,' :');
    readln(b[k]);
   end;

  Write('NC: ');
  Readln(NC);

  Writeln('C: ');
  for k:=1 to NC do
   begin
    write(k,' :');
    readln(c[k]);
   end;
//------------------------------
  ab:=ConnectionArray(a,b,NA,NB);
  d:=ConnectionArray(ab,c,NA+NB,NC);

  Writeln('D(',NA+NB+NC,'):');
  for k:=1 to NA+NB+NC do writeln(k,' :',d[k]);
end.

program Array64;

type

MyArray = array[1..30] of integer;

var

a,b,c,d,ab: MyArray;

NA,NB,NC,k:Integer;

Function ConnectionArray(a,b:MyArray;NA,NB:Integer):MyArray;

var

tempArray: MyArray;

i,ia,ib:integer;

begin

ia:=1;

ib:=1;

for i:=1 to NA+NB do

begin

if ia>NA then

begin

tempArray[i]:=b[ib];

inc(ib);

end

else

if ib>NB then

begin

tempArray[i]:=a[ia];

inc(ia);

end

else

if a[ia]>b[ib] then

begin

tempArray[i]:=a[ia];

inc(ia);

end

else

begin

tempArray[i]:=b[ib];

inc(ib);

end;

ConnectionArray:=tempArray;

end;

begin

Write('NA: ');

Readln(NA);

Writeln('A: ');

for k:=1 to NA do

begin

write(k,' :');

readln(a[k]);

end;

Write('NB: ');

Readln(NB);

Writeln('B: ');

for k:=1 to NB do

begin

write(k,' :');

readln(b[k]);

end;

Write('NC: ');

Readln(NC);

Writeln('C: ');

for k:=1 to NC do

begin

write(k,' :');

readln(c[k]);

end;

//------------------------------

ab:=ConnectionArray(a,b,NA,NB);

d:=ConnectionArray(ab,c,NA+NB,NC);

Writeln('D(',NA+NB+NC,'):');

for k:=1 to NA+NB+NC do writeln(k,' :',d[k]);

end.

Решение olegst1975 рекурсия:

type
  mas=array [1..30]of integer;
var
  i,ia,ib,ic,id,na,nb,nc,nd:integer;
  a,b,c,d:mas;

procedure add_mass(var a,b,c,d:mas;ia,ib,ic,id:integer);
  begin    
    if (ib=(nb+1))or((a[ia]>b[ib])and(ia<(na+1))) then
     begin
      if (ic=(nc+1))or((a[ia]>c[ic])and(ia<(na+1))) then
        begin
         if ia=(na+1) then exit;
         d[id]:=a[ia];
         add_mass(a,b,c,d,ia+1,ib,ic,id+1);
        end
      else
        begin         
         d[id]:=c[ic];
         add_mass(a,b,c,d,ia,ib,ic+1,id+1);
        end         
     end
    else
     begin
      if (ic=(nc+1))or((b[ib]>c[ic])and(ib<nb+1)) then
        begin         
         d[id]:=b[ib];
         add_mass(a,b,c,d,ia,ib+1,ic,id+1);
        end
      else
        begin         
         d[id]:=c[ic];
         add_mass(a,b,c,d,ia,ib,ic+1,id+1);
        end         
     end; 
  end;
      
begin
 writeln('a:');
 read(na);
 for i:=1 to na do read(a[i]);
 writeln('b:');
 read(nb);
 for i:=1 to nb do read(b[i]);
 writeln('c:');
 read(nc);
 for i:=1 to nc do read(c[i]);

 nd:=na+nb+nc;
  ia:=1;
  ib:=1;
  ic:=1;
  id:=1;
  add_mass(a,b,c,d,ia,ib,ic,id);
  for i:=1 to nd do write(d[i]);
end.

type

mas=array [1..30]of integer;

var

i,ia,ib,ic,id,na,nb,nc,nd:integer;

a,b,c,d:mas;

procedure add_mass(var a,b,c,d:mas;ia,ib,ic,id:integer);

begin

if (ib=(nb+1))or((a[ia]>b[ib])and(ia<(na+1))) then

begin

if (ic=(nc+1))or((a[ia]>c[ic])and(ia<(na+1))) then

begin

if ia=(na+1) then exit;

d[id]:=a[ia];

add_mass(a,b,c,d,ia+1,ib,ic,id+1);

end

else

begin

d[id]:=c[ic];

add_mass(a,b,c,d,ia,ib,ic+1,id+1);

end

else

begin

if (ic=(nc+1))or((b[ib]>c[ic])and(ib<nb+1)) then

begin

d[id]:=b[ib];

add_mass(a,b,c,d,ia,ib+1,ic,id+1);

end

else

begin

d[id]:=c[ic];

add_mass(a,b,c,d,ia,ib,ic+1,id+1);

end

end;

begin

writeln('a:');

read(na);

for i:=1 to na do read(a[i]);

writeln('b:');

read(nb);

for i:=1 to nb do read(b[i]);

writeln('c:');

read(nc);

for i:=1 to nc do read(c[i]);

nd:=na+nb+nc;

ia:=1;

ib:=1;

ic:=1;

id:=1;

add_mass(a,b,c,d,ia,ib,ic,id);

for i:=1 to nd do write(d[i]);

end.

Решение olegst1975 указатели:

type
  mas=array [1..30]of integer;
  type_pointer=^integer;
var
  i,na,nb,nc,nd,ia,ib,ic:integer;     
  a,b,c,d:mas;
  p,np:type_pointer;

procedure init(var np,p:type_pointer; var nx,x:integer);
  begin
    p:=@x;
    np:=@nx;
  end;
   
begin
 ia:=1;
 ib:=1;
 ic:=1;   
 read(na);        
 for i:=1 to na do read(a[i]);
 read(nb);        
 for i:=1 to nb do read(b[i]); 
 read(nc);        
 for i:=1 to nc do read(c[i]); 
 nd:=na+nb+nc; 
 for i:=1 to nd do
   begin
     if (ib=(nb+1))or((ia<(na+1))and(a[ia]>b[ib])) then init(np,p,ia,a[ia]) else init(np,p,ib,b[ib]);
     if ((ib=(nb+1))and(ia=(na+1)))or((p^<c[ic])and(ic<(nc+1))) then init(np,p,ic,c[ic]);
     d[i]:=p^;
     inc(np^);     
   end;
 for i:=1 to nd do write(d[i]);
end.

type

mas=array [1..30]of integer;

type_pointer=^integer;

var

i,na,nb,nc,nd,ia,ib,ic:integer;

a,b,c,d:mas;

p,np:type_pointer;

procedure init(var np,p:type_pointer; var nx,x:integer);

begin

p:=@x;

np:=@nx;

end;

begin

ia:=1;

ib:=1;

ic:=1;

read(na);

for i:=1 to na do read(a[i]);

read(nb);

for i:=1 to nb do read(b[i]);

read(nc);

for i:=1 to nc do read(c[i]);

nd:=na+nb+nc;

for i:=1 to nd do

begin

if (ib=(nb+1))or((ia<(na+1))and(a[ia]>b[ib])) then init(np,p,ia,a[ia]) else init(np,p,ib,b[ib]);

if ((ib=(nb+1))and(ia=(na+1)))or((p^<c[ic])and(ic<(nc+1))) then init(np,p,ic,c[ic]);

d[i]:=p^;

inc(np^);

end;

for i:=1 to nd do write(d[i]);

end.

Ещё одно Решение в один проход :

program Array64;
type
 MyArray = array[1..30] of integer;

var
  a,b,c,d: MyArray;
  NA,NB,NC,k:Integer;

Function CompInt1(a,b,c:integer):byte;
begin
 if (a>b) and (a>c) then CompInt1:=1
 else if (b>c) then CompInt1:=2
      else CompInt1:=3;
end;

Function CompInt(a,b,c,d:integer):byte;
begin
 if (a<=d) and ((b>d) or (a>b))  and ((c>d) or (a>c)) then CompInt:=1
 else if (b<=d) and ((c>d) or (b>c)) then CompInt:=2
      else if (c<=d) then CompInt:=3
           else CompInt:=4;
end;


Procedure ConnectionArray (a,b,c:MyArray; NA,NB,NC:Integer; var d:MyArray);
var
 ai,bi,ci,di,Comp:integer;
begin
 ai:=1;
 bi:=1;
 ci:=1;
 di:=1;
 Comp:=1;
 While (Comp<>4) do
  begin
   if (di-1)>=1 then Comp:=CompInt(a[ai],b[bi],c[ci],d[di-1])
   else Comp:=CompInt1(a[1],b[1],c[1]);

   case Comp of
    1: begin
        d[di]:=a[ai];
        if ai<NA then inc(ai)
        else a[ai]:=d[1]+1;
       end;
    2: begin
        d[di]:=b[bi];
        if bi<NB then inc(bi)
        else b[bi]:=d[1]+1;
       end;
    3: begin
        d[di]:=c[ci];
        if ci<NC then inc(ci)
        else c[ci]:=d[1]+1;
       end;
   end;
   inc(di);
 end;
end;

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

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

  Write('NB: ');
  Readln(NB);

  Writeln('B: ');
  for k:=1 to NB do
   begin
    write(k,' :');
    readln(b[k]);
   end;

  Write('NC: ');
  Readln(NC);

  Writeln('C: ');
  for k:=1 to NC do
   begin
    write(k,' :');
    readln(c[k]);
   end;

 ConnectionArray(a,b,c,NA,NB,NC,d);

 for k:=1 to NA+NB+NC do  writeln(k,' : ',d[k]);
 readln;
end.

program Array64;

type

MyArray = array[1..30] of integer;

var

a,b,c,d: MyArray;

NA,NB,NC,k:Integer;

Function CompInt1(a,b,c:integer):byte;

begin

if (a>b) and (a>c) then CompInt1:=1

else if (b>c) then CompInt1:=2

else CompInt1:=3;

end;

Function CompInt(a,b,c,d:integer):byte;

begin

if (a<=d) and ((b>d) or (a>b)) and ((c>d) or (a>c)) then CompInt:=1

else if (b<=d) and ((c>d) or (b>c)) then CompInt:=2

else if (c<=d) then CompInt:=3

else CompInt:=4;

end;

Procedure ConnectionArray (a,b,c:MyArray; NA,NB,NC:Integer; var d:MyArray);

var

ai,bi,ci,di,Comp:integer;

begin

ai:=1;

bi:=1;

ci:=1;

di:=1;

Comp:=1;

While (Comp<>4) do

begin

if (di-1)>=1 then Comp:=CompInt(a[ai],b[bi],c[ci],d[di-1])

else Comp:=CompInt1(a[1],b[1],c[1]);

case Comp of

1: begin

d[di]:=a[ai];

if ai<NA then inc(ai)

else a[ai]:=d[1]+1;

end;

2: begin

d[di]:=b[bi];

if bi<NB then inc(bi)

else b[bi]:=d[1]+1;

end;

3: begin

d[di]:=c[ci];

if ci<NC then inc(ci)

else c[ci]:=d[1]+1;

end;

inc(di);

end;

begin

Write('NA: ');

Readln(NA);

Writeln('A: ');

for k:=1 to NA do

begin

write(k,' :');

readln(a[k]);

end;

Write('NB: ');

Readln(NB);

Writeln('B: ');

for k:=1 to NB do

begin

write(k,' :');

readln(b[k]);

end;

Write('NC: ');

Readln(NC);

Writeln('C: ');

for k:=1 to NC do

begin

write(k,' :');

readln(c[k]);

end;

ConnectionArray(a,b,c,NA,NB,NC,d);

for k:=1 to NA+NB+NC do writeln(k,' : ',d[k]);

readln;

end.

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

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

С рекурсией без допмассива

[crayon-673e3ae484e5e499328361 inline="true" ]
type
  mas=array [1..30]of integer;
var
  i,ia,ib,ic,id,na,nb,nc,nd,ia,ib,ic,id:integer;     
  a,b,c,d:mas;

procedure add_mass(var a,b,c,d:mas;ia,ib,ic,id:integer);
  begin    
    if (ib=(nb+1))or((a[ia]>b[ib])and(ia<(na+1))) then
     begin
      if (ic=(nc+1))or((a[ia]>c[ic])and(ia<(na+1))) then
        begin
         if ia=(na+1) then exit;
         d[id]:=a[ia];
         add_mass(a,b,c,d,ia+1,ib,ic,id+1);
        end
      else
        begin         
         d[id]:=c[ic];
         add_mass(a,b,c,d,ia,ib,ic+1,id+1);
        end         
     end
    else
     begin
      if (ic=(nc+1))or((b[ib]>c[ic])and(ib<nb+1)) then
        begin         
         d[id]:=b[ib];
         add_mass(a,b,c,d,ia,ib+1,ic,id+1);
        end
      else
        begin         
         d[id]:=c[ic];
         add_mass(a,b,c,d,ia,ib,ic+1,id+1);
        end         
     end; 
  end;
      
begin 
 read(na);        
 for i:=1 to na do read(a[i]);
 read(nb);        
 for i:=1 to nb do read(b[i]); 
 read(nc);        
 for i:=1 to nc do read(c[i]);
 nd:=na+nb+nc; 
  ia:=1;
  ib:=1;
  ic:=1;
  id:=1;
  add_mass(a,b,c,d,ia,ib,ic,id);
  for i:=1 to nd do write(d[i]);
end.

[crayon-673e3ae484e5e499328361 inline="true" ]

type

mas=array [1..30]of integer;

var

i,ia,ib,ic,id,na,nb,nc,nd,ia,ib,ic,id:integer;

a,b,c,d:mas;

procedure add_mass(var a,b,c,d:mas;ia,ib,ic,id:integer);

begin

if (ib=(nb+1))or((a[ia]>b[ib])and(ia<(na+1))) then

begin

if (ic=(nc+1))or((a[ia]>c[ic])and(ia<(na+1))) then

begin

if ia=(na+1) then exit;

d[id]:=a[ia];

add_mass(a,b,c,d,ia+1,ib,ic,id+1);

end

else

begin

d[id]:=c[ic];

add_mass(a,b,c,d,ia,ib,ic+1,id+1);

end

else

begin

if (ic=(nc+1))or((b[ib]>c[ic])and(ib<nb+1)) then

begin

d[id]:=b[ib];

add_mass(a,b,c,d,ia,ib+1,ic,id+1);

end

else

begin

d[id]:=c[ic];

add_mass(a,b,c,d,ia,ib,ic+1,id+1);

end

end;

begin

read(na);

for i:=1 to na do read(a[i]);

read(nb);

for i:=1 to nb do read(b[i]);

read(nc);

for i:=1 to nc do read(c[i]);

nd:=na+nb+nc;

ia:=1;

ib:=1;

ic:=1;

id:=1;

add_mass(a,b,c,d,ia,ib,ic,id);

for i:=1 to nd do write(d[i]);

end.

[/crayon]
Ну и последний вариант(как по мне наиболее перспективный, может можно сделать лучше) — с указателями. Правда, чет не везде работало

[crayon-673e3ae484e62798566889 inline="true" ]
type
  mas=array [1..30]of integer;
  type_pointer=^integer;
var
  i,na,nb,nc,nd,ia,ib,ic:integer;     
  a,b,c,d:mas;
  p,np:type_pointer;

procedure init(var np,p:type_pointer; var nx,x:integer);
  begin
    p:=@x;
    np:=@nx;
  end;
   
begin
 ia:=1;
 ib:=1;
 ic:=1;   
 read(na);        
 for i:=1 to na do read(a[i]);
 read(nb);        
 for i:=1 to nb do read(b[i]); 
 read(nc);        
 for i:=1 to nc do read(c[i]); 
 nd:=na+nb+nc; 
 for i:=1 to nd do
   begin
     if (ib=(nb+1))or((ia<(na+1))and(a[ia]>b[ib])) then init(np,p,ia,a[ia]) else init(np,p,ib,b[ib]);
     if ((ib=(nb+1))and(ia=(na+1)))or((p^<c[ic])and(ic<(nc+1))) then init(np,p,ic,c[ic]);
     d[i]:=p^;
     inc(np^);     
   end;
 for i:=1 to nd do write(d[i]);
end.

[crayon-673e3ae484e62798566889 inline="true" ]

type

mas=array [1..30]of integer;

type_pointer=^integer;

var

i,na,nb,nc,nd,ia,ib,ic:integer;

a,b,c,d:mas;

p,np:type_pointer;

procedure init(var np,p:type_pointer; var nx,x:integer);

begin

p:=@x;

np:=@nx;

end;

begin

ia:=1;

ib:=1;

ic:=1;

read(na);

for i:=1 to na do read(a[i]);

read(nb);

for i:=1 to nb do read(b[i]);

read(nc);

for i:=1 to nc do read(c[i]);

nd:=na+nb+nc;

for i:=1 to nd do

begin

if (ib=(nb+1))or((ia<(na+1))and(a[ia]>b[ib])) then init(np,p,ia,a[ia]) else init(np,p,ib,b[ib]);

if ((ib=(nb+1))and(ia=(na+1)))or((p^<c[ic])and(ic<(nc+1))) then init(np,p,ic,c[ic]);

d[i]:=p^;

inc(np^);

end;

for i:=1 to nd do write(d[i]);

end.

[/crayon]

Ответить

Anton

24.03.2016 в 08:52

В рекурсии:
ia,ib,ic,id объявляется два раза исправил.
И ещё добавил writeln, а то совсем уж не понятно, что вводишь.
Про указатели, я думаю это нормально, что не везде рабоатет 🙂

Ответить
- Anton
  
  24.03.2016 в 11:06
  
  Не удержался, написал ещё одно решение выполняющее слияние за один проход, но строчек больше получилось…
  
  Ответить
  - olegst1975
    
    24.03.2016 в 15:31
    
    Спасибо за правки. Очень оперативное новое решение!
    
    Ответить
    - olegst1975
      
      24.03.2016 в 15:41
      
      Нужно проверить, может и косяки компилятора(или что-то с повторами чисел??)
      Исходные данные
      NA = 6 A: 97 94 57 -10 -67 -69
      NB = 6 B: 73 58 18 10 6 -45
      NC = 5 C: 73 37 5 -31 -99
      Полученные результаты
      D: 97 94 73 57 37 5 -10 -31 -67 -69 -99 0 0 0 0 0 0
      Пример верного решения
      D: 97 94 73 73 58 57 37 18 10 6 5 -10 -31 -45 -67 -69 -99
      
      Исходные данные
      NA = 4 A: 43 32 14 -56
      NB = 3 B: 67 44 -24
      NC = 7 C: 98 61 61 46 28 24 -24
      Полученные результаты
      D: 98 67 61 44 43 32 14 -24 -56 0 0 0 0 0
      Пример верного решения
      D: 98 67 61 61 46 44 43 32 28 24 14 -24 -24 -56
      
      Ответить
      - Anton
        
        24.03.2016 в 17:13
        
        free pascal — всё ок
        delphi 7 — всё ок
        pascalabc.net — всё плохо… (но я бы удивился если бы всё было хорошо, там даже вот это не работает)
        
        Ответить

Не согласен. У меня не получается). На работе лазарус — мимо, дома делфи7 тот же результат. Хорошая идея с заменой последнего числа в сливаемых массивах. Но при одинаковых числах, встречающихся в них, итоговый размер массива D получается меньше чем NA+NB+NC и дальше заполняется нулями(вернее он уже заполнен).
A: 4
B: 7, 1
C: 3, 3, 1
При «ловле» второй тройки срабатывает условие в строке 19, хотя должны были добраться до 20… Так, много текста, вот предложение

[crayon-673e3ae484d93062057388 inline="true" ]
if (a<=d) and ((b>d) or (a>b))  and ((c>d) or (a>c)) then CompInt:=1
 else if (b<=d) and ((c>d) or (b>c)) then CompInt:=2

[crayon-673e3ae484d93062057388 inline="true" ]

if (a<=d) and ((b>d) or (a>b)) and ((c>d) or (a>c)) then CompInt:=1

else if (b<=d) and ((c>d) or (b>c)) then CompInt:=2

[/crayon]

Ответить

Anton

25.03.2016 в 07:22

Я понял о каком решении говориться, только сейчас… я думал мы говорим про поинты…
Действительно, всё так как вы говорите, поправил.
Спасибо за настойчивость 🙂

Ответить

program Array64;//fpc

type
  Arr = array[1..30] of integer;

procedure JoinSort(const a, b: Arr; var c: Arr; na, nb: integer);
var
  i1, i2, i: integer;
begin
  i1 := 1;
  i2 := 1;
  for i := 1 to na + nb do
    if (i2 > nb) or ((i1 <= na) and (a[i1] > b[i2])) then
    begin
      c[i] := a[i1];
      i1 += 1
    end else
    begin
      c[i] := b[i2];
      i2 += 1
    end;
end;

var
  a, b, c, d, tmp: Arr;
  na, nb, nc, i: integer;

begin
  na := 3;
  nb := 4;
  nc := 5;
  
  for i := 1 to na do begin a[i] := 8 - i * 2; Write(a[i], ' '); end;
  Writeln;//6 4 2
  
  for i := 1 to nb do begin b[i] := 8 - (i * 2 - 1); Write(b[i], ' '); end;
  Writeln;//7 5 3 1
  
  for i := 1 to nc do begin c[i] := 13 - i; Write(c[i], ' '); end;
  Writeln;//12 11 10 9 8
  
  JoinSort(a, b, tmp, na, nb);
  JoinSort(c, tmp, d, nc, na + nb);
  
  for i := 1 to na + nb + nc do Write(d[i], ' ');//12 11 10 9 8 7 6 5 4 3 2 1
  Readln;
end.

program Array64;//fpc

type

Arr = array[1..30] of integer;

procedure JoinSort(const a, b: Arr; var c: Arr; na, nb: integer);

var

i1, i2, i: integer;

begin

i1 := 1;

i2 := 1;

for i := 1 to na + nb do

if (i2 > nb) or ((i1 <= na) and (a[i1] > b[i2])) then

begin

c[i] := a[i1];

i1 += 1

end else

begin

c[i] := b[i2];

i2 += 1

end;

var

a, b, c, d, tmp: Arr;

na, nb, nc, i: integer;

begin

na := 3;

nb := 4;

nc := 5;

for i := 1 to na do begin a[i] := 8 - i * 2; Write(a[i], ' '); end;

Writeln;//6 4 2

for i := 1 to nb do begin b[i] := 8 - (i * 2 - 1); Write(b[i], ' '); end;

Writeln;//7 5 3 1

for i := 1 to nc do begin c[i] := 13 - i; Write(c[i], ' '); end;

Writeln;//12 11 10 9 8

JoinSort(a, b, tmp, na, nb);

JoinSort(c, tmp, d, nc, na + nb);

for i := 1 to na + nb + nc do Write(d[i], ' ');//12 11 10 9 8 7 6 5 4 3 2 1

Readln;

end.

Ответить

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

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

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

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