Форум программистов, компьютерный форум, киберфорум
Turbo Pascal
Форум программистов и сисадминов Киберфорум > Форум программистов > Pascal (Паскаль) > Turbo Pascal
Войти
Регистрация
Восстановить пароль
Правила Карта форума Темы раздела Блоги Социальные группы Поиск Сообщения за день  
 
0 / 0 / 0
Регистрация: 28.04.2016
Сообщений: 14
1

Определить число точек, попадающих в произвольно задаваемый круг

28.04.2016, 17:22. Показов 478. Ответов 17
Метки нет (Все метки)
Здравствуйте,помогите пожалуйста чуть-чуть переделать программу .
задание: матрица(N,3),где n количество проб, представляет собой данные площадного опробования,(N,1) элемент является координатой Х точки, (N,2) элемент координата Y,(N,3) элемент содержания признака в точке опробования.Определить число точек, попадающих в произвольно задаваемый круг и среднее значение этих точек.нужна еще подпрограмма для вывода результатов на экран или на принтер, и еще подпрограмма для наглядного участка опробования с точками и произвольно заданной в пределах участка окружности.
нужно из программы убрать список пород и при сохранении чтобы не выдавало введите название пород,у меня не получается(((вот текст программы:
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181

uses crt,graph;
const m=3;
      nmax=100;
 
type mtr=array[1..nmax,1..m] of longint;
 
var b,c,d:boolean;{глобальные переменные для фиксации создания матрицы, круга и файла}
 
procedure matrix(var a:mtr;var n:integer);
var i:integer;
begin
clrscr;
randomize;
repeat
write('Количество проб до ',nmax,' n=');
readln(n);
until n in [1..nmax];
for i:=1 to n do
 begin
  a[i,1]:=1+random(640);
  a[i,2]:=1+random(480);
  a[i,3]:=random(50);
 end;
b:=true;
end;
 
procedure krug(a:mtr;n:integer;var ox,oy,r:longint;var k:integer);
var i:integer;
begin
clrscr;
if not b then
 begin
  writeln('Матрица точек не создана, вернитесь к пункту 1');
  readln;
  exit
 end;
repeat
write('Радиус круга от 10 до 200 r=');
readln(r);
until r in [10..200];
repeat
write('Координата Х центра круга от ',r,' до ',640-r,' x=');
readln(ox);
until(ox>=r)and(ox<=640-r);
repeat
write('Координата Y центра круга от ',r,' до ',480-r,' y=');
readln(oy);
until(oy>=r)and(ox<=480-r);
c:=true;
k:=0;
for i:=1 to n do
if sqr(ox-a[i,1])+sqr(oy-a[i,2])<r*r then k:=k+1;
writeln('В выделенный круг попало точек=',k);
readln
end;
 
procedure fail(a:mtr;n:integer;var f:text);
var nz:string;
    i:integer;
begin
clrscr;
if not b then
 begin
  writeln('Матрица точек не создана, вернитесь к пункту 1');
  readln;
  exit
 end;
assign(f,'data.txt');
rewrite(f);
for i:=1 to n do
 begin
  write(f,a[i,1]:4,a[i,2]:4,a[i,3]:3);
  write('Введите название породы: ');
  readln(nz);
  writeln(f,' ',nz);
 end;
close(f);
writeln('Данные записаны в файл data.txt');
d:=true;
readln
end;
 
procedure spisok(var f:text);
var a:array[1..nmax] of string[30];
    m,i,k:integer;
    s:string;
begin
clrscr;
if not d then
 begin
  writeln('Файл данных не создан, вернитесь к пункту 3');
  readln;
  exit
 end;
reset(f);
readln(f,s);
while pos(' ',s)>0 do
delete(s,1,1);
m:=1;
a[m]:=s;
while not eof(f) do
 begin
  readln(f,s);
  while pos(' ',s)>0 do
  delete(s,1,1);
  k:=0;
  for i:=1 to m do
  if a[i]=s then k:=1;
  if k=0 then
   begin
    m:=m+1;
    a[m]:=s;
   end;
 end;
close(f);
writeln('Список пород участка опробования');
for i:=1 to m do
writeln(a[i]);
readln
end;
 
procedure plan(a:mtr;n:integer;ox,oy,r:longint);
var g,d,i:integer;
begin
clrscr;
if not b then
 begin
  writeln('Матрица точек не создана, вернитесь к пункту 1');
  readln;
  exit
 end;
if not c then
 begin
  writeln('Круг еще не задан, вернитесь к пункту 2');
  readln;
  exit
 end;
g:=detect;
d:=vgahi;
initgraph(g,d,'');
setcolor(14);
circle(ox,oy,r);
for i:=1 to n do
 begin
  if sqr(ox-a[i,1])+sqr(oy-a[i,2])<r*r then setcolor(12)
  else setcolor(9);
  circle(a[i,1],a[i,2],2);
 end;
readln;
restorecrtmode
end;
var a:mtr;
    n,k:integer;
    ox,oy,r:longint;
    f:text;
    w:char;
begin
b:=false;
c:=false;
d:=false;
clrscr;
repeat
clrscr;
writeln('Выберите действие');
writeln('1-создание матрицы');
writeln('2-задать круг и определить число точек в нем');
writeln('3-создать файл');
writeln('4-показать список пород');
writeln('5-Показать план опробования');
writeln('другое выход');
readln(w);
case w of
'1':matrix(a,n);
'2':krug(a,n,ox,oy,r,k);
'3':fail(a,n,f);
'4':spisok(f);
'5': plan(a,n,ox,oy,r);
else exit
end;
until not(w in ['1'..'6']);
end.
0
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
 28.04.2016, 17:22
Ответы с готовыми решениями:

Определить число точек, попадающих в произвольно задаваемый круг и среднее значение содержания этих точек
Задание: а) Матрица из (N,3) чисел, где N - количество проб, предс*тавляет собой данные площадного...

Подсчитать число точек, попадающих в круг
Основы алгоритмизации Задание. Подсчитать число точек с координатами x0+(i-1)*hx, y0+(i-1)*hy, где...

Определить число точек, попадающих в произвольно задаваемый круг
задание: матрица(N,3),где n количество проб, представляет собой данные площадного...

Определить количество точек с целочисленными координатами, попадающих в круг
Очень нужна помощь в решении задания!!!! Вопрос жизни и смерти!!! Задание1 Вычислить k -...

17
2 / 2 / 2
Регистрация: 28.04.2016
Сообщений: 19
28.04.2016, 17:28 2
Не совсем понимаю что не получается.

Круг рисуется, точки попадают. Осталось удалить лишнее и всё.
0
0 / 0 / 0
Регистрация: 28.04.2016
Сообщений: 14
28.04.2016, 17:31  [ТС] 3
при сохранении файла выдает введите название пород,а я ведь все лишнее убрала и процедуру список убрала она лишняя((
0
2 / 2 / 2
Регистрация: 28.04.2016
Сообщений: 19
28.04.2016, 17:35 4
В процедуре fail же :

Pascal
1
2
3

write('Введите название породы: ');
readln(nz);
writeln(f,' ',nz);
0
0 / 0 / 0
Регистрация: 28.04.2016
Сообщений: 14
28.04.2016, 17:49  [ТС] 5
я оттуда убрала ,но все равно выдает(

Добавлено через 1 минуту
и в последнем кстати где участок опробования,когда нажимаю программа выдает ошибку

Добавлено через 11 минут
помогите пожалуйста)))
0
2 / 2 / 2
Регистрация: 28.04.2016
Сообщений: 19
28.04.2016, 19:05 6
У меня дома win 7, паскаль нормально не ставится, завтра с работы посмотрю.

Но программа запустилась =)
0
0 / 0 / 0
Регистрация: 28.04.2016
Сообщений: 14
28.04.2016, 22:07  [ТС] 7
Спаааааааасибо Вам большущеее
0
2 / 2 / 2
Регистрация: 28.04.2016
Сообщений: 19
29.04.2016, 09:59 8
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191

uses crt,graph;
const m=3;
      nmax=100;
 
type mtr=array[1..nmax,1..m] of longint;
 
var b,c,d:boolean;{глобальные переменные для фиксации создания матрицы, круга и файла}
 
procedure matrix(var a:mtr;var n:integer);
var i:integer;
begin
clrscr;
randomize;
repeat
write('Количество проб до ',nmax,' n=');
readln(n);
until n in [1..nmax];
for i:=1 to n do
 begin
  a[i,1]:=1+random(640);
  a[i,2]:=1+random(480);
  a[i,3]:=random(50);
 end;
b:=true;
end;
 
procedure krug(a:mtr;n:integer;var ox,oy,r:longint;var k:integer);
var i:integer;
begin
clrscr;
if not b then
 begin
  writeln('Матрица точек не создана, вернитесь к пункту 1');
  readln;
  exit
 end;
repeat
write('Радиус круга от 10 до 200 r=');
readln(r);
until r in [10..200];
repeat
write('Координата Х центра круга от ',r,' до ', 640-r,' x=');
readln(ox);
until(ox>=r)and(ox<=640-r);
repeat
write('Координата Y центра круга от',r,' до ',480-r,' y=');
readln(oy);
until(oy>=r)and(ox<=480-r);
c:=true;
k:=0;
for i:=1 to n do
if sqr(ox-a[i,1])+sqr(oy-a[i,2])<r*r then k:=k+1;
writeln('В выделенный круг попало точек=',k);
readln
end;
 
procedure fail(a:mtr;n:integer;var f:text);
var nz:string;
    i:integer;
begin
clrscr;
if not b then
 begin
  writeln('Матрица точек не создана, вернитесь к пункту 1');
  readln;
  exit
 end;
assign(f,'data.txt');
rewrite(f);
for i:=1 to n do
 begin
  write(f,a[i,1]:4,a[i,2]:4,a[i,3]:3);
{  write('Введите название породы: ');}
{  readln(nz);}
{  writeln(f,' ',nz);}
  writeln(f,'  проба: ', i);
 end;
close(f);
writeln('Данные записаны в файл data.txt');
d:=true;
readln
end;
 
procedure spisok(var f:text);
var a:array[1..nmax] of string[30];
    m,i,k:integer;
    s:string;
begin
clrscr;
if not d then
 begin
  writeln('Файл данных не создан, вернитесь к пункту 3');
  readln;
  exit
 end;
reset(f);
readln(f,s);
while pos(' ',s)>0 do
delete(s,1,1);
m:=1;
a[m]:=s;
while not eof(f) do
 begin
  readln(f,s);
  while pos(' ',s)>0 do
  delete(s,1,1);
  k:=0;
  for i:=1 to m do
  if a[i]=s then k:=1;
  if k=0 then
   begin
    m:=m+1;
    a[m]:=s;
   end;
 end;
close(f);
writeln('Список пород участка опробования');
for i:=1 to m do
writeln(a[i]);
readln
end;
 
procedure plan(a:mtr;n:integer;ox,oy,r:longint);
var g,d,i:integer;
begin
clrscr;
if not b then
 begin
  writeln('Матрица точек не создана, вернитесь к пункту 1');
  readln;
  exit
 end;
if not c then
 begin
  writeln('Круг ещё не создан, вернитесь к пункту 2');
  readln;
  exit
 end;
g:=detect;
d:=vgahi;
initgraph(g,d,'../bgi');
setcolor(14);
circle(ox,oy,r);
for i:=1 to n do
 begin
  if sqr(ox-a[i,1])+sqr(oy-a[i,2])<r*r then setcolor(12)
  else setcolor(9);
  circle(a[i,1],a[i,2],2);
 end;
readln;
restorecrtmode
end;
var a:mtr;
    n,k:integer;
    ox,oy,r:longint;
    f:text;
    w:char;
begin
b:=false;
c:=false;
d:=false;
clrscr;
repeat
clrscr;
{writeln('Выберите действие');
writeln('1-создание матрицы');
writeln('2-задать круг и определить число точек в нем');
writeln('3-создать файл');
writeln('4-показать список пород');
writeln('5-показать план опробования');
writeln('другое выход');}
 
writeln('Выберите действие');
writeln('1-создание матрицы');
writeln('2-задать круг и определить число точек в нем');
writeln('3-создать файл');
writeln('4-показать план опробования');
writeln('другое выход');
 
readln(w);
case w of
'1':matrix(a,n);
'2':krug(a,n,ox,oy,r,k);
'3':fail(a,n,f);
{'4':spisok(f);
'5': plan(a,n,ox,oy,r);}
'4': plan(a,n,ox,oy,r);
else exit
end;
until not(w in ['1'..'6']);
end.
{} - это закоментировал то что было и добавил своё.
Сделал только то что ты просила.
0
0 / 0 / 0
Регистрация: 28.04.2016
Сообщений: 14
29.04.2016, 14:01  [ТС] 9
спасибо большое,а еще у меня на 4м пункте вылетает программа не подскажите почему? появляется окно this system does not support fullscreen mode.Close 'close' to terminate the application
0
2 / 2 / 2
Регистрация: 28.04.2016
Сообщений: 19
29.04.2016, 14:05 10
Может
initgraph(g,d,'../bgi'); заменить на initgraph(g,d,' ');


Я честно недавно стал вспоминать Паскаль,
0
0 / 0 / 0
Регистрация: 28.04.2016
Сообщений: 14
29.04.2016, 14:18  [ТС] 11
все равно вылетает(
0
318 / 208 / 162
Регистрация: 08.12.2015
Сообщений: 863
29.04.2016, 14:28 12
ИРИШКА161, в чем запускаете? В Турбо Паскаль school pak работает нормально.
0
0 / 0 / 0
Регистрация: 28.04.2016
Сообщений: 14
29.04.2016, 14:32  [ТС] 13
вы не могли бы скинуть установочник программы?)пожалуйста))
0
2 / 2 / 2
Регистрация: 28.04.2016
Сообщений: 19
29.04.2016, 14:32 14
У меня так работает.
А раньше работала?

Я запускаю в обычном Tp 7.1

В общем незнаю в чём у вас может быть проблема
0
0 / 0 / 0
Регистрация: 28.04.2016
Сообщений: 14
29.04.2016, 14:33  [ТС] 15
у меня просто 7
0
318 / 208 / 162
Регистрация: 08.12.2015
Сообщений: 863
29.04.2016, 14:35 16
вы в полноэкранном режиме запускаете:?
0
0 / 0 / 0
Регистрация: 28.04.2016
Сообщений: 14
30.04.2016, 08:20  [ТС] 17
в обоих пробовала

Добавлено через 17 часов 18 минут
Спасибо всем кто откликнулся
0
Почетный модератор
64276 / 47575 / 32739
Регистрация: 18.05.2008
Сообщений: 115,182
30.04.2016, 08:53 18
Цитата Сообщение от ИРИШКА161 Посмотреть сообщение
у меня просто 7
Такого нет. Есть 7.0 и 7.1
0
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
 30.04.2016, 08:53
Помогаю со студенческими работами здесь

Вычислить число точек с целочисленными координатами, попадающих в круг радиуса R с центром в начале координат
Задача1. Вычислить число точек с целочисленными координатами, попадающих в круг радиуса R с...

Определить количество и номера точек последовательности, попадающих в круг радиуса R с центром в точке Q
Помогите пожалуйста написать программу! Задана последовательность точек плоскости P1(x, y);...

Определить число точек с (x;y) попадающих
Определить число точек C (x;y) попадающих: Внутрь заштрихованной области На границу Вне заданной...

Подсчитать количество точек, попадающих в круг
Приняв, что координаты точек на плоскости задаются двумя числами x и y, составить программу,...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
18
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Поддержать - Реклама - Обратная связь
Powered by vBulletin
Copyright ©2000 - 2023, CyberForum.ru