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

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

Вернуться   Форум программистов > IT форум > Помощь студентам
Регистрация

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

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

Ответ
 
Опции темы Поиск в этой теме
Старый 20.01.2015, 16:12   #1
win.owl
Новичок
Джуниор
 
Регистрация: 18.01.2015
Сообщений: 3
По умолчанию Помогите решить задачу, пожалуйста

Нужно соединить два файла в один по условию задачи. Паскаль АВС.

Составить программу, которая использует модуль. В модуле разработать подпрограммы для работы с декартовой плоскостью: принадлежность точки прямой, отрезку, многоугольнику.

Код:
Program vidpr; 
Const _Eps: Real = 1e-3;
var x1,y1,x2,y2,x,y:real;
Function RealEq(Const a, b:Real):Boolean; 
begin
  RealEq := Abs(a-b)<= _Eps
End; {RealEq}

Function RealMoreEq(Const a, b:Real):Boolean; 
begin
  RealMoreEq := a - b >= _Eps
End; {RealMoreEq}

Function EqPoint(x1,y1,x2,y2:real):Boolean;
begin
  EqPoint:=RealEq(x1,x2)and RealEq(y1,y2)
end; {EqPoint}
Function AtOtres(x1,y1,x2,y2,x,y:real):Boolean;

Begin
  If EqPoint( x1,y1,x2,y2)
    Then  AtOtres:=  EqPoint( x1,y1,x,y)
    Else
  AtOtres := RealEq((x-x1)*(y2-y1)- (y-y1)*(x2-x1),0)and (RealMoreEq(x,x1)and
    RealMoreEq( x2,x)Or RealMoreEq(x,x2)and RealMoreEq( x1,x))
end;  {AtOtres}

begin {main}
  writeln('Введите координаты точек: x1,y1,x2,y2,x,y');
  readln( x1,y1,x2,y2,x,y);
  if  AtOtres(x1,y1,x2,y2,x,y)
    then writeln('Да.')
    else writeln('Нет.' );
end.  {main}




program mnog;
Const n=9;
      _Eps: Real=1e-4;
type b=record
          x,y: real;
       end;
     myArray= array[1..n] of b;
var
    input:text;
    x,y:real;
    i: integer;
    a: myArray;
v1,v2,v3,v4: real;
procedure zapmas;
begin
  assign(input,'input.pas');
  reset(input);
  read(input, a[i].x,a[i].y);
  readln(input, x,y);
  close(input);
end;
function RealLess(Const a, b: Real): Boolean; {строго менше}
begin
  RealLess := b-a> _Eps
end; {RealLess}
function VektorMulti(ax, ay, bx, by: real): real;
{ax, ay – координаты, a  bx, by – координаты b }
begin
  vektormulti:= ax*by-bx*ay;
end;
Function LinesCross(x1,y1,x2,y2,x3,y3,x4,y4: real): boolean;
begin
  v1:=vektormulti(x4-x3,y4-y3,x1-x3,y1-y3);
  v2:=vektormulti(x4-x3,y4-y3,x2-x3,y2-y3);
  v3:=vektormulti(x2-x1,y2-y1,x3-x1,y3-y1);
  v4:=vektormulti(x2-x1,y2-y1,x4-x1,y4-y1);
  if RealLess(v1*v2,0) and RealLess(v3*v4,0)
     then LinesCross:= true
    else LinesCross:= false
end; {LinesCross}
function InsidePoint(a:myArray):Boolean;
var i, k, nom: integer;
    maxx: real;
begin
  k:=0;
  maxx:=a[1].x;
  nom:=1;
  for i:=2 to n-1 do
       if maxx < a[i].x then begin maxx:=a[i].x;nom:=i;end;
  a[n].x:=a[1].x;   a[n].y:=a[1].y;
  for i:=1 to n-1 do
    if LinesCross(a[i].x,a[i].y,a[i+1].x,a[i+1].y,x,y,a[nom].x+1,a[nom].y)
      then k:=k+1;
  if k mod 2 <> 0
    then  InsidePoint:= true
    else  InsidePoint:= false;
end;
begin {main}
  zapMas;
  if InsidePoint(a)
    then  writeln('Точка всредине многоугольника.')
    else  writeln('Точка вне многоугольника.')
end.

Последний раз редактировалось win.owl; 20.01.2015 в 16:22.
win.owl вне форума Ответить с цитированием
Старый 20.01.2015, 16:22   #2
Stilet
Белик Виталий :)
Старожил
 
Аватар для Stilet
 
Регистрация: 23.07.2007
Сообщений: 57,097
По умолчанию

Странная задача, ну да ладно.
Вот так будет выглядеть модуль:
Код:
unit u;

interface
Const _Eps: Real = 1e-3;
       n=9;
      _Eps: Real=1e-4;
type b=record
          x,y: real;
       end;
     myArray= array[1..n] of b;


Function RealEq(Const a, b:Real):Boolean; 
Function RealMoreEq(Const a, b:Real):Boolean;
Function EqPoint(x1,y1,x2,y2:real):Boolean;
Function AtOtres(x1,y1,x2,y2,x,y:real):Boolean;
function RealLess(Const a, b: Real): Boolean; {строго менше}
Function LinesCross(x1,y1,x2,y2,x3,y3,x4,y4: real): boolean;
function VektorMulti(ax, ay, bx, by: real): real;
Function LinesCross(x1,y1,x2,y2,x3,y3,x4,y4: real): boolean;
function InsidePoint(a:myArray):Boolean;

implementation
Function RealEq(Const a, b:Real):Boolean; 
begin
  RealEq := Abs(a-b)<= _Eps
End; {RealEq}

Function RealMoreEq(Const a, b:Real):Boolean; 
begin
  RealMoreEq := a - b >= _Eps
End; {RealMoreEq}

Function EqPoint(x1,y1,x2,y2:real):Boolean;
begin
  EqPoint:=RealEq(x1,x2)and RealEq(y1,y2)
end; {EqPoint}

Function AtOtres(x1,y1,x2,y2,x,y:real):Boolean;
Begin
  If EqPoint( x1,y1,x2,y2)
    Then  AtOtres:=  EqPoint( x1,y1,x,y)
    Else
  AtOtres := RealEq((x-x1)*(y2-y1)- (y-y1)*(x2-x1),0)and (RealMoreEq(x,x1)and
    RealMoreEq( x2,x)Or RealMoreEq(x,x2)and RealMoreEq( x1,x))
end;  {AtOtres}


function RealLess(Const a, b: Real): Boolean; {строго менше}
begin
  RealLess := b-a> _Eps
end; {RealLess}

function VektorMulti(ax, ay, bx, by: real): real;
{ax, ay – координаты, a  bx, by – координаты b }
begin
  vektormulti:= ax*by-bx*ay;
end;

Function LinesCross(x1,y1,x2,y2,x3,y3,x4,y4: real): boolean;
begin
  v1:=vektormulti(x4-x3,y4-y3,x1-x3,y1-y3);
  v2:=vektormulti(x4-x3,y4-y3,x2-x3,y2-y3);
  v3:=vektormulti(x2-x1,y2-y1,x3-x1,y3-y1);
  v4:=vektormulti(x2-x1,y2-y1,x4-x1,y4-y1);
  if RealLess(v1*v2,0) and RealLess(v3*v4,0)
     then LinesCross:= true
    else LinesCross:= false
end; {LinesCross}

function InsidePoint(a:myArray):Boolean;
var i, k, nom: integer;
    maxx: real;
begin
  k:=0;
  maxx:=a[1].x;
  nom:=1;
  for i:=2 to n-1 do
       if maxx < a[i].x then begin maxx:=a[i].x;nom:=i;end;
  a[n].x:=a[1].x;   a[n].y:=a[1].y;
  for i:=1 to n-1 do
    if LinesCross(a[i].x,a[i].y,a[i+1].x,a[i+1].y,x,y,a[nom].x+1,a[nom].y)
      then k:=k+1;
  if k mod 2 <> 0
    then  InsidePoint:= true
    else  InsidePoint:= false;
end;

end.
Соответственно программа:
Код:
uses u;
var x1,y1,x2,y2,x,y:real;
    input:text;
    x,y:real;
    i: integer;
    a: myArray;
v1,v2,v3,v4: real;

begin {main}
  writeln('Введите координаты точек: x1,y1,x2,y2,x,y');
  readln( x1,y1,x2,y2,x,y);
  if  AtOtres(x1,y1,x2,y2,x,y)
    then writeln('Да.')
    else writeln('Ні.' );

  zapMas;
  if InsidePoint(a)
    then  writeln('Точка всредине многоугольника.')
    else  writeln('Точка вне многоугольника.')

end.  {main}
сразу предупреждаю - не проверял.
I'm learning to live...
Stilet вне форума Ответить с цитированием
Старый 20.01.2015, 17:38   #3
win.owl
Новичок
Джуниор
 
Регистрация: 18.01.2015
Сообщений: 3
По умолчанию Спасибо огромное

Очень Вам благодарен.
win.owl вне форума Ответить с цитированием
Старый 20.01.2015, 17:43   #4
win.owl
Новичок
Джуниор
 
Регистрация: 18.01.2015
Сообщений: 3
По умолчанию

Код:
Program Lab9;
type mass=array[1..50]of integer;

Procedure sum(n,m:integer);
var
sm,sp,name,nname:string;
fi:text;
i,j,tmp,f:integer;
Mmas,MMmas:mass;
begin
repeat
write('Vvedite nazvanie fayla v kotoriy sohranit rezultat ');
readln(name);
//{$I-}
//reset(fi);   //{$I+}
nname:=name+'.txt';
if FileExists(nname)=false then
writeln('Ukazannogo fayla netu') ;
until (FileExists(nname));
assign(fi,nname);
write('Vvedite pervoe chislo ');
readln(n);
write('Vvedite vtoroe chislo ');
readln(m);
if m>n then begin
tmp:=n;
n:=m;
m:=tmp;
end;
str(m,sm);
for i:=length(sm) downto 1 do begin
Mmas[i]:=(ord(sm[i])-48);
end;
j:=1;
for i:=length(sm) downto 1 do begin
MMmas[j]:=(Mmas[i]*n);
inc(j);
end;
append(fi);
writeln(fi,n:10);writeln(fi,m:10);
writeln(n:10); writeln(m:10);
writeln('----------');
writeln(fi,'----------');
f:=0;
for j:=1 to length(sm) do
begin
writeln(MMmas[j]:(11-j));
writeln(fi,MMmas[j]:(11-j));
for i:=0 to j-1 do if i=0 then tmp:=1 else tmp:=tmp*10;
f:=f+MMmas[j]*tmp
end;
writeln('----------');
writeln(fi,'----------');
writeln(f:10);writeln(fi,f:10);
writeln(fi,' ');
close(fi);
end;

var a,b:integer;
begin
sum(a,b);

end.
В этой есть ошибка, никак не могу понять в чём дело. Компилятор Паскаль АВС
win.owl вне форума Ответить с цитированием
Старый 20.01.2015, 17:59   #5
Stilet
Белик Виталий :)
Старожил
 
Аватар для Stilet
 
Регистрация: 23.07.2007
Сообщений: 57,097
По умолчанию

Ну... Ошибки дело наживное )
Чтоб понять в чем дело ошибку нужно читать.
I'm learning to live...
Stilet вне форума Ответить с цитированием
Ответ


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



Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Помогите пожалуйста решить задачу на C# $Anya$ Помощь студентам 1 15.11.2009 16:02
Помогите решить задачу ,пожалуйста DimoniusX Паскаль, Turbo Pascal, PascalABC.NET 11 12.01.2009 19:57
Помогите решить задачу пожалуйста Никитка89 Паскаль, Turbo Pascal, PascalABC.NET 3 29.05.2008 08:35