Форум программистов, компьютерный форум, киберфорум
Наши страницы
Turbo Pascal
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг 4.82/1163: Рейтинг темы: голосов - 1163, средняя оценка - 4.82
Dj Programmer
13 / 13 / 14
Регистрация: 05.10.2013
Сообщений: 141
08.11.2013, 23:33 #141
Цитата Сообщение от ildwine Посмотреть сообщение
А теперь то же самое, но в циклах...
Спасибо, учту
0
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
08.11.2013, 23:33
Ответы с готовыми решениями:

Графика в Турбо Паскаль
(b+\sqrt{b-4ac}/2a)-a*a*a*c - помогите как это записать в турбо паскале...

Графика в Турбо Паскаль
ситуация следующая. написала програму в которой задаешь координаты точки и в...

Графика в Турбо Паскаль
Не могли бы вы посоветовать книгу или дать ссылку на форуме где подробно...

Графика в Турбо Паскаль не работает
Люди помогите плиз. У меня windows 7 когда я пытаюсь запустить программу с...

построение графика на Турбо Паскаль
Помогите пожалуйста Y=(x*(3-x))/(1-x)*sqr(1-x)

157
RAFISTAUR
8 / 8 / 12
Регистрация: 16.12.2013
Сообщений: 79
25.12.2013, 15:54 #142
Вот программа графического Лохотрона:
0
Вложения
Тип файла: rar LOHOTRON.rar (2.1 Кб, 48 просмотров)
Svager
394 / 374 / 405
Регистрация: 14.09.2013
Сообщений: 1,202
12.05.2014, 02:25 #143
Игра Расстановка 16 букв
собственного производства
1
Вложения
Тип файла: rar GAME16.rar (2.1 Кб, 30 просмотров)
dimabubyakin
159 / 120 / 85
Регистрация: 16.10.2013
Сообщений: 1,738
Завершенные тесты: 5
15.06.2014, 00:39 #144
Ну что-то типа рисовалки, работает мышка)
Кликните здесь для просмотра всего текста
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
192
193
194
195
196
program GRAPHEDITOR;
uses graph,crt,dos;
 
procedure InitGraphMode;
var
   g,d:integer;
begin
     g:=detect;
     initgraph(g,d,'');
end;
 
procedure DrawArea;
var
   covers:array[1..4]of PointType;
begin
 
setbkcolor(14);
 
covers[1].x:=20;   covers[1].y:=20;
covers[2].x:=20;   covers[2].y:=460;
covers[3].x:=500;  covers[3].y:=460;
covers[4].x:=500;  covers[4].y:=20;
 
setcolor(8);
setfillstyle(1,15);
fillpoly(4,covers);
 
 
 
covers[1].x:=560;   covers[1].y:=30;
covers[2].x:=580;   covers[2].y:=30;
covers[3].x:=580;   covers[3].y:=50;
covers[4].x:=560;   covers[4].y:=50;
fillpoly(4,covers);
outtextxy(590,37,'WIDTH');
 
 
covers[1].x:=560;   covers[1].y:=70;
covers[2].x:=580;   covers[2].y:=70;
covers[3].x:=580;   covers[3].y:=90;
covers[4].x:=560;   covers[4].y:=90;
setfillstyle(3,8);
fillpoly(4,covers);
outtextxy(590,77,'FILL');
 
 
outtextxy(550,410,'COLOR');
 
 
covers[1].x:=520;   covers[1].y:=430;
covers[2].x:=540;   covers[2].y:=430;
covers[3].x:=540;   covers[3].y:=450;
covers[4].x:=520;   covers[4].y:=450;
setfillstyle(1,8);
fillpoly(4,covers);
 
 
 
covers[1].x:=560;   covers[1].y:=430;
covers[2].x:=580;   covers[2].y:=430;
covers[3].x:=580;   covers[3].y:=450;
covers[4].x:=560;   covers[4].y:=450;
setfillstyle(1,4);
fillpoly(4,covers);
 
 
 
covers[1].x:=600;   covers[1].y:=430;
covers[2].x:=620;   covers[2].y:=430;
covers[3].x:=620;   covers[3].y:=450;
covers[4].x:=600;   covers[4].y:=450;
setfillstyle(1,15);
fillpoly(4,covers);
 
end;
 
procedure ClearDrawArea;
var
   covers:array[1..4]of PointType;
begin
covers[1].x:=20;   covers[1].y:=20;
covers[2].x:=20;   covers[2].y:=460;
covers[3].x:=500;  covers[3].y:=460;
covers[4].x:=500;  covers[4].y:=20;
setcolor(8);
setfillstyle(1,15);
fillpoly(4,covers);
end;
 
procedure ShowCursor;
var
     r:registers;
begin
r.ax:=1;
intr($33,r);
end;
 
procedure HideCursor;
var
     r:registers;
begin
r.ax:=2;
intr($33,r);
end;
 
procedure M_GETXY(var x,y:integer);
var
     r:registers;
begin
r.ax:=3;
intr($33,r);
x:=r.cx;
y:=r.dx;
end;
 
function GetKeyDown:integer;
var
     r:registers;
begin 
r.ax:=3;
intr($33,r);
GetKeyDown:=r.bl;
end;
 
 
var
     x,y:integer;
     key:char;
     Color,Width:word;
     s:string;
     covers:array[1..4]of PointType;
begin
InitGraphMode;
DrawArea;
setbkcolor(0);
ShowCursor;
setbkcolor(14);
MoveTo(240,220);
setcolor(8);
width:=2;
repeat
     if keypressed then 
     begin 
          key:=readkey;
          if key=#27 then break;
     end;
if width<3  then width:=3;
if width>20 then width:=20;
M_GETXY(x,y);
setcolor(color);
 
if (x-width>20) and (x+width<500) and (y-width>20) and (y+width<460) 
then if GetKeyDown=1 then 
          begin
          HideCursor;
          setcolor(color);
          setfillstyle(1,color);
          FillEllipse(x,y,width,width);
          FillEllipse(x,y,width,width);
          FillEllipse(x,y,width,width);
          FillEllipse(x,y,width,width);
          FillEllipse(x,y,width,width);
          ShowCursor;
          end;
 
 
if (x>560) and (x<580) and (y>70) and (y<90)
then if GetKeyDown=1 then 
          begin
          covers[1].x:=20;   covers[1].y:=20;
          covers[2].x:=20;   covers[2].y:=460;
          covers[3].x:=500;  covers[3].y:=460;
          covers[4].x:=500;  covers[4].y:=20;
          setcolor(8);
          setfillstyle(1,color);
          fillpoly(4,covers);
          end;
 
if (x>560) and (x<580) and (y>30) and (y<50)
then if GetKeyDown=1 then inc(width) 
else if GetKeyDown=2 then dec(width);
          
 
if (x>520) and (x<540) and (y>430) and (y<450)
then if GetKeyDown=1 then Color:=8;
 
 
if (x>560) and (x<580) and (y>430) and (y<450)
then if GetKeyDown=1 then Color:=4;
 
 
if (x>600) and (x<620) and (y>430) and (y<450)
then if GetKeyDown=1 then Color:=15;
until 1<0;
Closegraph;
end.
0
hoch
Заблокирован
28.09.2014, 11:16 #145
Нарисовано 11 квадратов. Они расположены по спирали
Архимеда (сама спираль не нарисована). Размеры квадратов
по мере удаления от центра возрастают. Использована
рекурсивная процедура
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
Uses Graph,Crt;
var
   x,y,z: integer;
   q: real;
   Driv:integer;
   Mode:integer;
   Pach:string;
 
procedure f(p:integer);
begin
   if p > 0 then
      begin
         x:= round(60*q*cos(q) + 300);
         y:= round(60*q*sin(q) + 200);
         q:= q + 0.4;
         Rectangle(x,y,x+z,y+z);
      end
   else exit;
   inc(z,4);
   dec(p);
   f(p);
end;
 
BEGIN
   Driv:=VGA;
   Mode:=VGAHi;
   Pach:='C:\tp\bgi';
   InitGraph (Driv,Mode,Pach);
   if GraphResult <> grOK then Halt (1);
   z:= 20;
   f(11);
   OutText('Press_Enter');
 
   readln;
   CloseGraph;
END.
0
hoch
Заблокирован
29.09.2014, 12:19 #146
Это анимация. В квадрат вписан треугольник.
Треугольник движется в квадрате так, что его
вершины принадлежат квадрату. Для выхода из
программы нажмите Enter.
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
uses Crt,Graph;
var
   x1,y1,x2,y2,x3,y3: integer;
 
procedure iniG;
var
   Driv,Mode:integer;
   Path:string;
begin
   Driv:= VGA;
   Mode:= VGAHi;
   Path:= 'C:\tp\bgi';
   InitGraph (Driv,Mode,Path);
   if GraphResult < 0 then Halt (1);
end;
 
procedure los(var x,y: integer);
begin
   if (y=90) and (x<470) then inc(x);
   if (y=90) and (x=470) then inc(y);
   if (y<390) and (x=470) then inc(y);
   if (y=390) and (x=470) then dec(x);
   if (y=390) and (x>170) then dec(x);
   if (y=390) and (x=170) then dec(y);
   if (y>90) and (x=170) then dec(y);
   if (y=90) and (x=170) then inc(x);
 
   SetColor(14);
   Rectangle(170,90,470,390);
   SetColor(15);
   line(x1,y1,x2,y2);
   line(x2,y2,x3,y3);
   line(x3,y3,x1,y1);
end;
 
BEGIN
   randomize;
   x1:= 320;
   y1:= 90;
   x2:= 170;
   y2:= 390;
   x3:= 470;
   y3:= 390;
 
   iniG;
 
   repeat
      los(x1,y1);
      los(x2,y2);
      los(x3,y3);
 
      delay(1);
 
      SetColor(0);
      los(x1,y1);
      los(x2,y2);
      los(x3,y3);
   until keyPressed;
END.
0
hoch
Заблокирован
01.10.2014, 09:47 #147
Ромб. Анимация.
Для выхода из программы нажмите Enter.
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
Uses Graph,Crt;
const ox = 320;
      oy = 240;
var
   a,b: integer;
   x1,x3,y2,y4: integer;
   e: boolean;
 
procedure iniG;
var
   Driv,Mode:integer;
   Path:string;
begin
   Driv:= VGA;
   Mode:= VGAHi;
   Path:= 'C:\tp\bgi';
   InitGraph (Driv,Mode,Path);
   if GraphResult < 0 then Halt (1);
end;
 
BEGIN
   iniG;
   a:= 150;
   b:= 150;
   e:= true;
   repeat
      if e then begin
         inc(a); dec(b); end
      else begin
         dec(a); inc(b); end;
 
      if a = 200 then e:= not e;
      if a = 50  then e:= not e;
      x1:= ox-a;
      x3:= ox+a;
      y2:= oy-b;
      y4:= oy+b;
 
      setColor(15);
      line(x1,oy,ox,y2);
      line(ox,y2,x3,oy);
      line(x3,oy,ox,y4);
      line(ox,y4,x1,oy);
 
      delay(10);
 
      setColor(0);
      line(x1,oy,ox,y2);
      line(ox,y2,x3,oy);
      line(x3,oy,ox,y4);
      line(ox,y4,x1,oy);
   until KeyPressed;
 
   OutTextXY(10,10,'Press_Enter');
   readln;
   CloseGraph;
END.
0
hoch
Заблокирован
04.10.2014, 07:50 #148
Лабиринт. Это надо видеть ...
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
uses crt, Graph;
var
   lo: array[0..21,0..31] of byte;
   i,j,l: byte;
   k: integer;
 
procedure iniG;
var
   Driv,Mode:integer;
   Path:string;
begin
   Driv:= VGA;
   Mode:= VGAHi;
   Path:= 'C:\tp\bgi';
   InitGraph (Driv,Mode,Path);
   if GraphResult < 0 then Halt (1);
end;
 
BEGIN
   randomize;
   iniG;
   for i:= 0 to 21 do
   for j:= 0 to 31 do begin
      lo[0, j]:= 2; lo[21, j]:= 2;
      lo[i, 0]:= 2; lo[i, 31]:= 2;
   end;
 
   for k:= 1 to 1000 do begin
      i:= random(20)+1;
      j:= random(30)+1;
      l:= random(4);
      if lo[i,j] in [0,1] then begin
        case l of
 
        0: if lo[i-1,j] in [0,1] then begin
             line(20*j,20*i,20*j,20*i-20);
             inc(lo[i,j]);
             inc(lo[i-1,j]); continue
           end;
        1: if lo[i,j-1] in [0,1] then begin
             line(20*j,20*i,20*j-20,20*i);
             inc(lo[i,j]);
             inc(lo[i,j-1]); continue
           end;
        2: if lo[i+1,j] in [0,1] then begin
             line(20*j,20*i,20*j,20*i+20);
             inc(lo[i,j]);
             inc(lo[i+1,j]); continue
           end;
        3: if lo[i,j+1] in [0,1] then begin
             line(20*j,20*i,20*j+20,20*i);
             inc(lo[i,j]);
             inc(lo[i,j+1]); continue
           end
        end
      end
   end;
   readln;
   CloseGraph
END.
0
Puporev
Модератор
54217 / 41850 / 28922
Регистрация: 18.05.2008
Сообщений: 98,517
04.10.2014, 08:06 #149
И для чего везде continue ?
1
hoch
Заблокирован
04.10.2014, 12:04 #150
Я приношу свои извинения.
В первом варианте не было оператора case of
и они были нужны. Потом код изменился и я
забыл их удалить.
0
hoch
Заблокирован
05.10.2014, 13:07 #151
Дан треугольник координатами своих вершин и угол на который
относительно заданного треугольника повернут второй треугольник.
Этот треугольник обладает свойствами.
1. Он подобен первому треугольнику.
2. Он вписан в первый треугольник.
Программа уникальная, красивый код которой пленит сердце
настоящего программиста.
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
Uses Graph,Crt;
var
   x1,x2,x3,y1,y2,y3: longint;
   x4,x5,x6,y4,y5,y6: longint;
   k,ka,kb,kc: real;
   a,b,c,ua,ub,uc,f: real;
 
procedure iniG;
var
   Driv,Mode:integer;
   Path:string;
begin
   Driv:= VGA;
   Mode:= VGAHi;
   Path:= 'C:\tp\bgi';
   InitGraph (Driv,Mode,Path);
   if GraphResult < 0 then Halt (1);
end;
 
function arccos(x:real): real;
begin
   if x = 0 then arccos:= 1.5707963268
   else arccos:= arctan(sqrt(1-x*x)/x)
end;
 
BEGIN
   iniG;
   f:= 0.5;
   x1:= 100; y1:= 400;
   x2:= 540; y2:= 400;
   x3:= 400; y3:= 100;
 
   a:= sqrt(sqr(x1-x2) + sqr(y1-y2));
   b:= sqrt(sqr(x2-x3) + sqr(y2-y3));
   c:= sqrt(sqr(x3-x1) + sqr(y3-y1));
 
   ua:= arccos((b*b+c*c-a*a)/(2*b*c));
   ub:= arccos((a*a+c*c-b*b)/(2*a*c));
   uc:= arccos((a*a+b*b-c*c)/(2*a*b));
 
   k:= 1/(c*sin(f)/(a*sin(ub))+sin(uc+f)/sin(uc));
 
   ka:= k*sin(ua+f)/sin(ua);
   kb:= k*sin(ub+f)/sin(ub);
   kc:= k*sin(uc+f)/sin(uc);
 
   x4:= round(x2-kb*(x2-x1));
   y4:= round(y2-kb*(y2-y1));
   x5:= round(x3-kb*(x3-x2));
   y5:= round(y3-kb*(y3-y2));
   x6:= round(x1-kb*(x1-x3));
   y6:= round(y1-kb*(y1-y3));
 
   line(x1,y1,x2,y2);
   line(x2,y2,x3,y3);
   line(x3,y3,x1,y1);
   setcolor(14);
   line(x4,y4,x5,y5);
   line(x5,y5,x6,y6);
   line(x6,y6,x4,y4);
 
   OutTextXY(10,10,'Press_Enter');
   readln;
   CloseGraph;
END.
0
Puporev
Модератор
54217 / 41850 / 28922
Регистрация: 18.05.2008
Сообщений: 98,517
05.10.2014, 13:18 #152
А ничего что это частный случай этой, широко известной программы?
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
uses graph;
var gd,gm,a,n,xc,yc,i:integer;
    m,ax,bx,cx,ay,by,cy:real;
begin
gd:=detect;
initgraph(gd,gm,'');
a:=200;
n:=20;
m:=0.08;
{центр экрана}
xc:=getmaxX div 2;
yc:=getmaxY div 2;
{координаты исходного треугольника}
ax:=xc+a*cos(pi/2);
ay:=yc-a*sin(pi/2);
bx:=xc+a*cos(7*pi/6);
by:=yc-a*sin(7*pi/6);
cx:=xc+a*cos(11*pi/6);
cy:=yc-a*sin(11*pi/6);
for i:=1 to n+1 do
 begin
  {строим треугольник}
  line(round(ax),round(ay),round(bx),round(by));
  line(round(bx),round(by),round(cx),round(cy));
  line(round(cx),round(cy),round(ax),round(ay));
  {новые координаты}
  ax:=ax+(bx-ax)*m; ay:=ay+(by-ay)*m;
  bx:=bx+(cx-bx)*m; by:=by+(cy-by)*m;
  cx:=cx+(ax-cx)*m; cy:=cy+(ay-cy)*m;
 end;
readln
end.
0
hoch
Заблокирован
05.10.2014, 16:34 #153
Спасибо!
Но мне это было неизвестно.
Я просто решал геометрическую задачу, вывел ряд
формул и естественно подумал о написании программы
Я рад, что кто-то это сделал раньше меня, хотя я был
настолько уверен, что я первый, что не стал даже
наводить справки об этом свойстве треугольников.
Спасибо!
0
hoch
Заблокирован
06.10.2014, 16:55 #154
Анимация.
Квадрат катится по горизонтальной прямой.
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
Uses Graph,Crt;
const d = 141;
      a = 100;
      f1 = 0.7854;
      f2 = 2*f1;
var
   x,x2,x3,x4: longint;
   y,y2,y3,y4: longint;
   f: real;
 
procedure iniG;
var
   Driv,Mode:integer;
   Path:string;
begin
   Driv:= VGA;
   Mode:= VGAHi;
   Path:= 'C:\tp\bgi';
   InitGraph (Driv,Mode,Path);
   if GraphResult < 0 then Halt (1);
end;
 
BEGIN
   iniG;
   f:= 0;
   x:= 200;
   y:= 400;
   repeat
      if f > f2 then begin
         f:= 0;
         inc(x,100);
      end;
 
      x2:= x - round(a*cos(f));
      y2:= y - round(a*sin(f));
      x3:= x - round(d*cos(f1+f));
      y3:= y - round(d*sin(f1+f));
      x4:= x - round(a*cos(f2+f));
      y4:= y - round(a*sin(f2+f));
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x4,y4);
      line(x4,y4,x,y);
 
      delay(100);
 
      setColor(0);
      x2:= x - round(a*cos(f));
      y2:= y - round(a*sin(f));
      x3:= x - round(d*cos(f1+f));
      y3:= y - round(d*sin(f1+f));
      x4:= x - round(a*cos(f2+f));
      y4:= y - round(a*sin(f2+f));
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x4,y4);
      line(x4,y4,x,y);
      line(10,400,630,400);
      setColor(15);
      f:= f + 0.03;
   until x>500;
 
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x4,y4);
      line(x4,y4,x,y);
      line(10,400,630,400);
   OutTextXY(10,10,'Press_Enter');
   readln;
   CloseGraph;
END.
0
hoch
Заблокирован
07.10.2014, 17:42 #155
Анимация.
Треугольник скатывается по наклонной прямой
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
Uses Graph,Crt;
const a = 100;
      f0 = 0.1651;
      f1 = 1.0472;
      f2 = 2.0944;
 
var
   x,x2,x3: longint;
   y,y2,y3: longint;
   f: real;
 
procedure iniG;
var
   Driv,Mode:integer;
   Path:string;
begin
   Driv:= VGA;
   Mode:= VGAHi;
   Path:= 'C:\tp\bgi';
   InitGraph (Driv,Mode,Path);
   if GraphResult < 0 then Halt (1);
end;
 
BEGIN
   iniG;
   f:= 0;
   x:= 150;
   y:= round(280+x/6);
   repeat
      if f > f2 then begin
         f:= 0;
         inc(x,99);
         y:= round(280+x/6);
      end;
 
      x2:= x - round(a*cos(f+f0));
      y2:= y - round(a*sin(f+f0));
      x3:= x - round(a*cos(f1+f+f0));
      y3:= y - round(a*sin(f1+f+f0));
 
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x,y);
      line(0,280,600,380);
 
      delay(100);
 
      setColor(0);
      x2:= x - round(a*cos(f+f0));
      y2:= y - round(a*sin(f+f0));
      x3:= x - round(a*cos(f1+f+f0));
      y3:= y - round(a*sin(f1+f+f0));
 
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x,y);
 
      setColor(15);
      f:= f + 0.03;
   until x>500;
 
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x,y);
      line(0,280,600,380);
   OutTextXY(10,10,'Press_Enter');
   readln;
   CloseGraph;
END.
0
hoch
Заблокирован
08.10.2014, 18:17 #156
В этой программе задаются рандомно 25 точек
(они рисуются маленькими кружочками). Программа
анализирует координаты точек и рисует букву А.
Чего не удалось сделать? Так это задать критерий:
Какая из двух букв А, лучше? Тут надо подумать ...
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
Uses Graph,Crt;
const n = 25;
var
   i,j,k,l,m: integer;
   x,y: array[1..n]of integer;
label 2014;
 
procedure iniG;
var
   Driv,Mode:integer;
begin
   Driv:= 0;
   Mode:= VGAHi;
   InitGraph (Driv,Mode,'');
   if GraphResult <> 0 then Halt (1);
end;
 
BEGIN
   randomize;
   iniG;
 
   for i:= 1 to n do begin
      x[i]:= random(200) + 200;
      y[i]:= random(300) + 100;
   end;
 
   for i:= 1 to n do
      circle(x[i],y[i],2);
 
   for i:= 1 to n do
   for j:= 1 to n do
   for k:= 1 to n do begin
      if abs(y[i]-y[j])>30 then continue;
      if (y[i]-y[k]<150) or (y[j]-y[k]<150) then continue;
      if (x[i]>x[k]) or (x[j]<x[k]) then continue
         else
      for l:= 1 to n do
      for m:= 1 to n do begin
         if abs(y[l]-y[m])>15 then continue;
         if (y[i]-y[l]<50) or (y[j]-y[m]<50) then continue;
         if (y[l]-y[k]<50) or (y[m]-y[k]<50) then continue;
         if (x[l]<x[i]) or (x[m]>x[j]) then continue;
         if x[m]-x[l]<100 then continue
            else
         begin
            setColor(11);
            line(x[i],y[i],x[k],y[k]);
            line(x[j],y[j],x[k],y[k]);
            line(x[l],y[l],x[m],y[m]);
            goto 2014
         end
      end
   end;
 
2014:
   OutTextXY(20,20,'Press_Enter');
   readln;
   CloseGraph;
END.
0
vlados2441
2 / 2 / 4
Регистрация: 11.01.2015
Сообщений: 110
04.03.2015, 22:11 #157
Программа "Шарик"
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
program key1;
uses Graph,crt;
var
   gd,gm,x,y,dx,dy,r: integer;
   ch: char;
begin
     initGraph(gd,gm,'..\bgi');
     x:=320;
     y:=240;
     dx:=0;
     dy:=0;
     r:=20;
   repeat
    setColor (15);
    circle (x,y,r);
    delay (10);
    setColor (0);
    circle (x,y,r);
    x:= x + dx;
    y:= y + dy;
     if (x > 640 - r) or (x < r) then dx:= -dx;
     if (y > 480 - r) or (y < r) then dy:= -dy;
     if keyPressed then begin
    ch:= readKey;
    if ch = '1' then begin
     dx:=-1;
     dy:=1;
   end;
     if ch = '2' then begin
     dx:=-4;
     dy:=4;
   end;
   if ch = '3' then begin
     dx:=2;
     dy:=-2;
   end;
     if ch = '9' then begin
     dx:=0;
     dy:=0;
   end;
   if ch = 'a' then begin
     dx:=-1;
     dy:=0;
   end;
   if ch = 'd' then begin
     dx:=1;
     dy:=0;
   end;
     if ch = 'w' then begin
     dx:=0;
     dy:=-1;
   end;
   if ch = 's' then begin
     dx:=0;
     dy:=1;
   end;
   if ch = 'c' then begin
     dx:=1;
     dy:=1;
   end;
   if ch = 'q' then begin
    dx:=-1;
    dy:=-1;
   end;
   if ch = 'z' then begin
     dx:=-1;
     dy:=1;
   end;
   if ch = 'e' then begin
     dx:=1;
     dy:=-1;
   end;
  end;
 until ch = '0';
readln;
closeGraph;
end.
0
Dimon_KV
15 / 11 / 12
Регистрация: 11.06.2015
Сообщений: 49
02.08.2015, 12:16 #158
Программа "Фейерверк"

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
uses
  crt, graph, graphs;
 
const
  raysAmount = 24;
  step = pi/(raysAmount div 2);   { угол между двумя соседними линиями }
  pause = 40;
  maxTimeOfLife = 16;
  salutsAmount = 6;
  delLen = 20;
  lowLen = 50;
  lowDel = 10;
  delDel = 8;
 
type
  salut = record
    lifeTime: integer;
    isPresent: boolean;
    division: integer;
    color: word;
    delta, lengt,
    xC, yC: integer;
  end;
 
var
  xScrC, yScrC, xSClow, ySClow, xSCdel, ySCdel: integer;
  saluts: array[1..salutsAmount] of salut;
  time, i: integer;
 
procedure drawRays(salutsNum: integer; color: word);
var
  i: integer;
  x1, y1, x2, y2: integer;
begin
  setcolor(color);
  for i := 1 to raysAmount do
  with saluts[salutsNum] do
    begin
      x1 := round(delta * lifeTime * cos(i * step)) + xC;
      y1 := round(delta * lifeTime * sin(i * step)) + yC;
      x2 := x1 + round(lengt * cos(i * step));
      y2 := y1 + round(lengt * sin(i * step));
      line(x1, y1, x2, y2);
    end;
end;
 
begin
  open_graph;
  xScrC := GetMaxX div 2;
  yScrC := GetMaxY div 2;
 
  xSClow := GetMaxX div 3;
  ySClow := GetMaxY div 3;
 
  xSCdel := GetMaxX div 3;
  ySCdel := GetMaxY div 3;
  time := 1;
  randomize;
  for i := 1 to salutsAmount do
  begin
    saluts[i].division := 20 + random(40);
    saluts[i].isPresent := false;
    saluts[i].lifeTime := 0;
  end;
  setLineStyle(0, 0, thickWidth);
  repeat
    for i := 1 to salutsAmount do
      if time mod saluts[i].division = 0 then
        if not saluts[i].isPresent then saluts[i].isPresent := true;
 
    for i := 1 to salutsAmount do
      with saluts[i] do
      if (isPresent) and (lifeTime = 0) then
       begin
        xC := xSClow + random(xSCdel);
        yC := ySClow + random(ySCdel);
        color := 1 + random(15);
        delta := lowDel + random(delDel);
        lengt := lowLen + random(delLen);
       end;
 
    for i := 1 to salutsAmount do
      if saluts[i].isPresent then
        drawRays(i, saluts[i].color);
 
    delay(pause);
    inc(time);
    if time > maxInt - 1 then time := 1;
 
    for i := 1 to salutsAmount do
     with saluts[i] do
      if isPresent then
      begin
        drawRays(i, black);
        inc(lifeTime);
        if lifeTime >= maxTimeOfLife then
        begin
          lifeTime := 0;
          isPresent := false;
        end;
      end;
  until keypressed;
end.
Текст модуля Graphs:

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
unit graphs;
{$N+}
interface
 
procedure open_graph;
procedure close_graph;
function gx(x: extended; sx: integer): integer;
function gy(y: extended; sy: integer): integer;
 
implementation
 
uses Graph;
 
var
  x, y: extended;
  sx, sy: integer;
 
procedure open_graph;
var
  graph_device, graph_mode: integer;
begin
  graph_device := detect;
  InitGraph(graph_device, graph_mode, '');
  if GraphResult <> 0 then
  begin
    WriteLn('Ошибка инициализации графического режима.');
    ReadLn;
    Halt;
  end;
end;
 
procedure close_graph;
begin
  CloseGraph;
  if GraphResult <> 0 then
  begin
    WriteLn('Ошибка инициализации графического режима.');
    ReadLn;
    Halt;
  end;
end;
 
function gx(x: extended; sx: integer): integer;
begin
  gx := trunc(sx * x) + GetMaxX div 2;
end;
 
function gy(y: extended; sy: integer): integer;
begin
  gy := GetMaxY div 2 - trunc(sy * y);
end;
 
end.
0
02.08.2015, 12:16
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
02.08.2015, 12:16

Графика в Турбо Паскаль. Нарисовать телефон
Кто может нарисовать такое??

Построение графика функции в турбо-Паскаль
Как построить график данной функции в...

Графика в Турбо Паскаль. Нарисовать флаг Македонии
Помогите пожалуста, нужно нарисовать флаг Македонии у паскале.


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

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

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2018, vBulletin Solutions, Inc.
Рейтинг@Mail.ru