Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Delphi программирование > Паскаль, Turbo Pascal, PascalABC.NET
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 15.11.2012, 22:55   #1
Элька21
 
Регистрация: 12.12.2011
Сообщений: 3
По умолчанию Определить площадь фигуры, получающейся в результате объединения прямоугольников (Проверить код)

Задача.
На плоскости задано N (от 1 до 300) прямоугольников со сторонами, параллельными координатным осям (см. рисунок). Координаты вершин прямоугольников – вещественные числа, заданные с точностью до двух знаков после запятой. Написать программу определения площади фигуры, получающейся в результате объединения прямоугольников.
Код:
Const InputFile='Input.TxT';
OutputFile='Output.TxT';
MaxN=300;
Eps=1e-5;
Tochn=4;
Type TPoint=Record X,Y:Real;End;
MasPnt=Array[1..MaxN] Of TPoint;
BMasPnt=Array[1..MaxN*2] Of Real;
BMasSSt=Array[1..MaxN*2] Of LongInt;
Var PrM: Array[1..2] Of MasPnt;
N: LongInt;
Res: Real;
Ox, Oy: BMasPnt;
FOy: BMasSSt;
Procedure ReadPoint(Var A: TPoint);
Begin
Read(A.X, A.Y);
End;
 
Procedure More(Const a, b: Real): Boolean;
Begin
More:=a-b>Eps;
End;
 
Procedure Swap(Var a, b: Real);
Var t: Real;
Begin
  t:=a; a:=b; b:=t;
End;
 
Procedure Init;
Var i: LongInt;
Begin
  Res:=0;
  FillChar(Ox, SizeOf(Ox), 0);
  FillChar(Oy, SizeOf(Oy), 0);
  FillChar(Foy, SizeOf(FoY), 0);
  FillChar(PrM, SizeOf(PrM), 0);
  Assign(Input, InputFile);Reset(Input);
  Read(N);
  For i:=1 To N Do Begin
   ReadPoint(PrM[1,i]);ReadPoint(PrM[2,i]);
   If More(PrM[1,i].X, PrM[2,i].X)
     Then Swap(PrM[1,i].X, PrM[2,i].X);
   If More(PrM[1,i].Y, PrM[2,i].Y)
     Then Swap(PrM[1,i].Y, PrM[2,i].Y);
   Ox[i*2-1]:=PrM[1,i].X;Ox[i*2]:=PrM[2,i].X;
  End;
  Close(Input);
End;
Function Eq(Const a, b: Real): Boolean;
  Begin
    Eq:=Abs(a-b)<Eps;
  End;
 
Procedure SwapInt(Var a, b: LongInt);
  Var t: LongInt;
  Begin
   t:=a; a:=b; b:=t;
  End;
  Procedure FstSort(Var Ox: BMasPnt;
Var SOx: BMasSSt;
Const lf, rg: LongInt);
Var i, j: LongInt;
x: Real;
  Begin
   i:=lf;j:=rg;x:=Ox[(lf+rg) Div 2];
   Repeat
    While More(x, Ox[i]) Do Inc(i);
    While More(Ox[j], x) Do Dec(j);
    If i<=j Then
      Begin
       Swap(Ox[i],Ox[j]);
       SwapInt(SOx[i],SOx[j]);
       Inc(i);Dec(j);
      End;
   Until i>j;
   If lf<j Then FstSort(Ox, Sox, lf, j);
   If i<rg Then FstSort(Ox, Sox, i, rg);
End;
Procedure Solve;
Var i: LongInt; m: Real;
Begin
   Sort(Ox, 1, N*2);{сортируем по неубыванию
                    значения координаты X прямоугольников}
   m:=0;Res:=0;{m – длина сечения, Res –
                значение площади объединения прямоугольников}
   For i:=1 To N*2 Do Begin
    If i<>1 Then Res:=Res+Abs((Ox[i]-Ox[i-1])*m);
     {прибавляем площадь очередного сечения}
    If (i=1) Or Not(Eq(Ox[i], Ox[i-1]))
           Then Change(Ox[i], m);
          {определяем новое значение длины сечения}
   End;
End;
Function Peres(Const k: LongInt;
Const x: Real): Boolean;
Begin
  Peres:=Not More(PrM[1,k].X,x) And
  More(PrM[2,k].X,x);
End;
 
Procedure Change(Const x: Real; Var rs: Real);
Var i, M: LongInt;
  Begin
    M:=0;FillChar(Oy,SizeOf(Oy),0);
    FillChar(FOy,SizeOf(Foy),0);
    For i:=1 To N Do
      If Peres(i, x) Then Begin
       {если есть пересечение?}
       Oy[M+1]:=PrM[1,i].Y;Oy[M+2]:=PrM[2,i].Y;
       {формируем массив ординат для данной
        координаты X}
       FOy[M+1]:=1;FOy[M+2]:=-1;
       {признаки начала и конца отрезка}
       Inc(M, 2);
      End;
      If M=0 Then rs:=0
       Else Begin FstSort(Oy,FOy,1,M);
       rs:=Abs(Calc(Oy,FOy,M));
      End;
      {сортируем Oy, переставляя одновременно соответствующие
       элементы массива FOy; вычисляем новое значение длины
       сечения – функция Calc}
End;
Procedure Done;
Begin
  Assign(Output, OutputFile);
  Rewrite(Output);
  WriteLn(Res:0:Tochn);
  Close(Output);
End;
 
Begin
Init;
Solve;
Done;
End.
Элька21 вне форума Ответить с цитированием
Старый 15.11.2012, 23:07   #2
Poma][a
Новичок
Джуниор
 
Регистрация: 11.10.2011
Сообщений: 3,882
По умолчанию

Цитата:
параллельными координатным осям (см. рисунок)
Мой компилятор сказал Runtime error и не пустил дальше...
Poma][a вне форума Ответить с цитированием
Старый 15.11.2012, 23:46   #3
Элька21
 
Регистрация: 12.12.2011
Сообщений: 3
По умолчанию

И что сделать нужно?
Элька21 вне форума Ответить с цитированием
Старый 15.11.2012, 23:56   #4
Stilet
Белик Виталий :)
Старожил
 
Аватар для Stilet
 
Регистрация: 23.07.2007
Сообщений: 57,097
По умолчанию

Цитата:
Procedure More(Const a, b: Real): Boolean;
Это что? Что эта... подпрограмма должна делать?
Может так?:
Код:
Function More(Const a, b: Real): Boolean;
Begin
More:=(a-b)>Eps;
End;
Цитата:
Sort(Ox, 1, N*2);
А это что?
I'm learning to live...
Stilet вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц



Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Площадь фигуры Демик Помощь студентам 0 20.12.2011 01:48
Найти площадь фигуры samouelson Помощь студентам 2 17.12.2010 20:22
Площадь заштрихованной фигуры.VB! KOPC1886 Помощь студентам 0 05.12.2010 23:41
Площадь прямоугольников savraska Помощь студентам 7 04.06.2010 16:42
Площадь фигуры по координатам вершин Maksss123 Фриланс 8 09.03.2010 21:30