Урок 16. Задача 4.

Primary tabs

Submitted by Dennis80 on Fri, 09/02/2022 - 09:44

Forums:

Урок 16. Задача 4.

Пользователь вводит N (N Напишите подпрограмму, которая определит - есть ли у них общее пересечение, и если есть - вычислит координаты отрезка-пересечения. 

type ar = array[1..5, 1..2] of integer;
     br = array[1..2] of integer;

var a :ar;
    b :br;
    fl :boolean;

procedure fillArr(var a1 :ar);//наполняем массив А
  var i :integer;

begin
  writeln();
  for i := 1 to high(a1) do
  begin
    writeln('Введите начало отрезка');
    readln(a1[i, 1]);
    writeln('Введите конец отрезка');
    readln(a1[i, 2]);
  end;
  writeln();
  writeln('Ваши отрезки: ');
  for i := 1 to high(a1) do
  begin
    writeln(a1[i, 1], ' ', a1[i, 2]);
  end;
end;


procedure searchSeg(a1 :ar; var b1 :br; var fl1 :boolean);//поиск отрезка пересечения
  var i :integer;

begin
  b1[1] := a1[1, 1];
  b1[2] := a1[1, 2];
  for i := 2 to high(a1) do
  begin
    if (a1[1, 1] <= a1[i, 2]) and (a1[1, 2] >= a1[i, 1]) then
    begin
     if a1[i, 1] > b1[1] then
       b1[1] := a1[i, 1];
     if a1[i, 2] < b1[2] then
       b1[2] := a1[i, 2];
    end
    else
    begin
      fl1 := false;
      writeln('Пересечения нет');
      break;
    end;
  end;
end;

begin
  b[1] := 0;
  b[2] := 0;
  fl := true;
  fillArr(a);
  searchSeg(a, b, fl);
  if fl then
  begin
    writeln('Пересечением является отрезок с координатами: ');
    write(b[1], ' ', b[2]);
  end;
  readln();
end.
  • Log in to post comments
  • 4290 reads
vedro-compota's picture

vedro-compota

Thu, 09/08/2022 - 19:24

использовать в решении базовую подпрограмму http://fkn.ktu10.com/?q=node/15791
(потренируемся в декомпозиции)

_____________
матфак вгу и остальная классика =)

Dennis80

Sat, 09/10/2022 - 20:21 

type ar = array[1..5, 1..2] of integer;
     br = array[1..2] of integer;
 
var arA :ar;
    arB :br;
    fl :boolean;  
    
procedure create_an_array(var arA :ar);
var i :integer;
 
begin
  writeln();
  for i := 1 to high(arA) do
  begin
    writeln('Введите начало отрезка');
    readln(arA[i, 1]);
    writeln('Введите конец отрезка');
    readln(arA[i, 2]);
  end;
  writeln();
  writeln('Ваши отрезки: ');
  for i := 1 to high(arA) do
  begin
    writeln(arA[i, 1], ' ', arA[i, 2]);
  end;
end;

procedure find_intersection(a_1, a_2, b_1, b_2 :integer; var arB :br; var fl :boolean); // 16.3
begin
  if (a_1 <= b_2) and (a_2 >= b_1) then
    fl := true;
    
  if fl then
  begin
    writeln(fl);
    if a_1 < b_1 then
      arB[1] := b_1;
    if a_2 < b_2 then
      arB[2] := a_2;
  end;
end;

procedure result_record(arA :ar; var arB :br; var fl :boolean);
var i, j, a_1, a_2, b_1, b_2 :integer;
begin
  j := 2;
  for i := 1 to (high(arA) - 1) do
  begin
    a_1 := arA[i, 1];
    a_2 := arA[i, 2];
    b_1 := arA[j, 1];
    b_2 := arA[j, 2];
    find_intersection(a_1, a_2, b_1, b_2, arB, fl);
    if not fl then
      break;
    j := j + 1;
  end;
end;

procedure result_output(arB :br; fl :boolean);
begin
  if not fl then
    writeln('No intersection')
  else
    writeln('Here : ', arB[1], ' ', arB[2]);
end;

begin
  fl := false;
  create_an_array(arA);
  result_record(arA, arB, fl);
  result_output(arB, fl);
end.
vedro-compota's picture

vedro-compota

Sun, 09/11/2022 - 15:02 

procedure result_record(arA :ar; var arB :br; var fl :boolean);
var i, j, a_1, a_2, b_1, b_2 :integer;
begin
  j := 2;
  for i := 1 to (high(arA) - 1) do
  begin
    a_1 := arA[i, 1];
    a_2 := arA[i, 2];
    b_1 := arA[j, 1];
    b_2 := arA[j, 2];
    find_intersection(a_1, a_2, b_1, b_2, arB, fl);
    if not fl then
      break;
    j := j + 1;
  end;
end;

-- по-идее после того как нашли пересение 1-ого со 2ым надо искать пересечение результат с третьим отрезком и т.д.

1 3
2 4
3 5
4 6

Ищем именно общее пересечение, а не попарно проверяем пересекаются ли.

_____________
матфак вгу и остальная классика =)

Dennis80

Wed, 09/14/2022 - 18:25 

type ar = array[1..5, 1..2] of integer;
     br = array[1..2] of integer;

var arA :ar;
    arB :br;
    fl :boolean;

procedure create_an_array(var arA :ar);
var i :integer;

begin
  writeln();
  for i := 1 to high(arA) do
  begin
    writeln('Введите начало отрезка');
    readln(arA[i, 1]);
    writeln('Введите конец отрезка');
    readln(arA[i, 2]);
  end;
  writeln();
  writeln('Ваши отрезки: ');
  for i := 1 to high(arA) do
  begin
    writeln(arA[i, 1], ' ', arA[i, 2]);
  end;
end;

procedure find_intersection(a_1, a_2 :integer; var arB :br; var fl :boolean);
begin
  if (a_1 <= arB[2]) and (a_2 >= arB[1]) then
    fl := true
  else
    fl := false;

  if fl then
  begin
    if a_1 > arB[1] then
      arB[1] := a_1;
    if a_2 < arB[2] then
      arB[2] := a_2;
  end;
end;

procedure result_record(arA :ar; var arB :br; var fl :boolean);
var i, a_1, a_2 :integer;
begin
  arB[1] := arA[1, 1];
  arB[2] := arA[1, 2];
  for i := 2 to high(arA) do
  begin
    a_1 := arA[i, 1];
    a_2 := arA[i, 2];
    find_intersection(a_1, a_2, arB, fl);
    if not fl then
      break;
  end;
end;

procedure result_output(arB :br; fl :boolean);
begin
  if not fl then
    writeln('No intersection')
  else
    writeln('Here : ', arB[1], ' ', arB[2]);
end;

begin
  fl := false;
  create_an_array(arA);
  result_record(arA, arB, fl);
  result_output(arB, fl);
end.
vedro-compota's picture

vedro-compota

Wed, 09/14/2022 - 19:35 

  if (a_1 <= arB[2]) and (a_2 >= arB[1]) then

Проверить условие для такого расположения элементов:

 a_1  arB[1]   arB[2]  a_2

_____________
матфак вгу и остальная классика =)

Dennis80

Wed, 09/21/2022 - 15:16 

type ar = array[1..5, 1..2] of integer;
     br = array[1..2] of integer;

var arA :ar;
    arB :br;
    fl :boolean;

procedure create_an_array(var arA :ar);
var i :integer;

begin
  writeln();
  for i := 1 to high(arA) do
  begin
    writeln('Введите начало отрезка');
    readln(arA[i, 1]);
    writeln('Введите конец отрезка');
    readln(arA[i, 2]);
  end;
  writeln();
  writeln('Ваши отрезки: ');
  for i := 1 to high(arA) do
  begin
    writeln(arA[i, 1], ' ', arA[i, 2]);
  end;
end;

procedure find_intersection(a_1, a_2 :integer; var arB :br; var fl :boolean);
begin
  if (a_1 <= arB[1]) and (a_2 <= arB[2]) or (a_1 <= arB[2]) and (a_2 >= arB[1]) then
    fl := true
  else
    fl := false;

  if fl then
  begin
    if a_1 > arB[1] then
      arB[1] := a_1;
    if a_2 < arB[2] then
      arB[2] := a_2;
  end;
end;

procedure result_record(arA :ar; var arB :br; var fl :boolean);
var i, a_1, a_2 :integer;
begin
  arB[1] := arA[1, 1];
  arB[2] := arA[1, 2];
  for i := 2 to high(arA) do
  begin
    a_1 := arA[i, 1];
    a_2 := arA[i, 2];
    find_intersection(a_1, a_2, arB, fl);
    if not fl then
      break;
  end;
end;

procedure result_output(arB :br; fl :boolean);
begin
  if not fl then
    writeln('No intersection')
  else
    writeln('Here : ', arB[1], ' ', arB[2]);
end;

begin
  fl := false;
  create_an_array(arA);
  result_record(arA, arB, fl);
  result_output(arB, fl);
  readln();
end.
vedro-compota's picture

vedro-compota

Wed, 09/21/2022 - 19:29

засчитано

_____________
матфак вгу и остальная классика =)