Форум программистов, компьютерный форум, киберфорум
Наши страницы

Turbo Pascal

Войти
Регистрация
Восстановить пароль
 
 
Рейтинг: Рейтинг темы: голосов - 1, средняя оценка - 5.00
Новичок
Модератор
1261 / 809 / 182
Регистрация: 17.07.2012
Сообщений: 4,296
Записей в блоге: 1
Завершенные тесты: 2
31.07.2013, 00:18 #136
Симуляция кардиограммы.Автор:Kam_1995
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
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
uses crt,graph;
 
var driver,mode,t,y,x,u,v: integer;
 
 
procedure puls1;
begin
t:=70;
while t<78 do
begin
lineto(t,240-y);
t:=t+2;
y:=y+8;
delay(25);
end;
 
y:=0;
while t<86 do
begin
lineto(t,216+y);
t:=t+2;
y:=y+8;
delay(25);
end;
settextstyle(0,0,2);
outtextxy(2,2,'Serdce biyeniye: 72');
outtextxy(2,20,'Nijneye davleniye: 60');
outtextxy(2,38,'Verxneye davleniye: 126');
 
moveto(86,240);
while t<93 do
begin
lineto(t,240);
t:=t+1;
delay(25);
end;
 
y:=0;
while t<98 do
begin
lineto(t,240+y);
t:=t+2;
y:=y+10;
delay(25);
end;
 
y:=0;
while t<108 do
begin
lineto(t,270-y);
t:=t+1;
y:=y+18;
delay(25);
end;
 
Sound(1000);
Delay(90);
NoSound;
 
 
y:=0;
while t<122 do
begin
lineto(t,125+y);
t:=t+1;
y:=y+18;
delay(25);
end;
 
y:=0;
while t<130 do
begin
lineto(t,360-y);
t:=t+1;
y:=y+17;
delay(25);
end;
end;
 
 
 
procedure puls2;
begin
 
t:=180;
y:=0;
while t<188 do
begin
lineto(t,240-y);
t:=t+2;
y:=y+8;
delay(25);
end;
 
y:=0;
while t<196 do
begin
lineto(t,216+y);
t:=t+2;
y:=y+8;
delay(25);
end;
 
setfillstyle(1,0);
bar(400,30,0,0);
outtextxy(2,2,'Serdce biyeniye: 64');
outtextxy(2,20,'Nijneye davleniye: 60');
outtextxy(2,38,'Verxneye davleniye: 129');
 
moveto(196,240);
 
while t<203 do
begin
lineto(t,240);
t:=t+1;
delay(25);
end;
 
y:=0;
while t<208 do
begin
lineto(t,240+y);
t:=t+2;
y:=y+10;
delay(25);
end;
 
y:=0;
while t<218 do
begin
lineto(t,270-y);
t:=t+1;
y:=y+18;
delay(25);
end;
 
Sound(1000);
Delay(90);
NoSound;
 
y:=0;
while t<232 do
begin
lineto(t,125+y);
t:=t+1;
y:=y+18;
delay(25);
end;
 
y:=0;
while t<240 do
begin
lineto(t,360-y);
t:=t+1;
y:=y+17;
delay(25);
end;
end;
 
procedure puls3(z:integer);
begin
 
t:=z;
y:=0;
while t<z+8 do
begin
lineto(t,240-y);
t:=t+2;
y:=y+8;
delay(25);
end;
 
y:=0;
while t<z+8+8 do
begin
lineto(t,216+y);
t:=t+2;
y:=y+8;
delay(25);
end;
 
bar(600,60,0,0);
settextstyle(0,0,2);
outtextxy(2,2,'Serdce biyeniye: 80');
outtextxy(2,20,'Nijneye davleniye: 20');
outtextxy(2,38,'Verxneye davleniye: 154');
moveto(t,240);
 
while t<z+8+8+3 do
begin
lineto(t,240);
t:=t+1;
delay(25);
end;
 
y:=0;
while t<z+8+8+3+5 do
begin
lineto(t,240+y);
t:=t+2;
y:=y+10;
delay(25);
end;
 
y:=0;
while t<z+8+8+3+5+10 do
begin
lineto(t,270-y);
t:=t+1;
y:=y+18;
delay(25);
end;
 
Sound(1000);
Delay(90);
NoSound;
 
y:=0;
while t<z+8+8+3+5+10+14 do
begin
lineto(t,125+y);
t:=t+1;
y:=y+18;
delay(25);
end;
 
y:=0;
while t<z+8+8+3+5+10+14+8 do
begin
lineto(t,360-y);
t:=t+1;
y:=y+17;
delay(25);
end;
 
end;
 
procedure puls4(z:integer);
begin
 
t:=z;
y:=0;
settextstyle(0,0,2);
outtextxy(300,100,'Paciyent jiv');
moveto(t,240);
while t<z+8 do
begin
lineto(t,240-y);
t:=t+2;
y:=y+8;
delay(25);
end;
 
y:=0;
while t<z+8+8 do
begin
lineto(t,216+y);
t:=t+2;
y:=y+8;
delay(25);
end;
 
bar(600,60,0,0);
settextstyle(0,0,2);
outtextxy(2,2,'Serdce biyeniye: 69');
outtextxy(2,20,'Nijneye davleniye: 62');
outtextxy(2,38,'Verxneye davleniye: 122');
 
moveto(t,240);
while t<z+8+8+3 do
begin
lineto(t,240);
t:=t+1;
delay(25);
end;
 
y:=0;
while t<z+8+8+3+5 do
begin
lineto(t,240+y);
t:=t+2;
y:=y+10;
delay(25);
end;
 
y:=0;
while t<z+8+8+3+5+10 do
begin
lineto(t,270-y);
t:=t+1;
y:=y+18;
delay(25);
end;
 
Sound(1000);
Delay(90);
NoSound;
 
y:=0;
while t<z+8+8+3+5+10+14 do
begin
lineto(t,125+y);
t:=t+1;
y:=y+18;
delay(25);
end;
 
y:=0;
while t<z+8+8+3+5+10+14+8 do
begin
lineto(t,360-y);
t:=t+1;
y:=y+17;
delay(25);
end;
 
end;
 
BeGIN
clrscr;
randomize;
driver:=detect;
initgraph(driver,mode,'');
 
x:=0;
while x<70 do
begin
lineto(x,240);
x:=x+1;
delay(25);
end;
 
puls1;
 
 
x:=130;
while x<180 do
begin
lineto(x,240);
x:=x+1;
delay(25);
end;
 
puls2;
 
x:=240;
while x<290 do
begin
lineto(x,240);
x:=x+1;
delay(25);
end;
 
bar(600,60,0,0);
outtextxy(2,2,'Serdce biyeniye: 0');
outtextxy(2,20,'Nijneye davleniye: 0');
outtextxy(2,38,'Verxneye davleniye: 0');
outtextxy(300,100,'Ostanovka serdca!!!');
settextstyle(0,0,1);
outtextxy(260,118,'Najmite <Enter> shtobi ispolzovat referbulyator');
moveto(290,240);
x:=290;
repeat
lineto(x,240);
x:=x+1;
sound(1000);
delay(25);
until keypressed;
nosound;
 
bar(255,90,700,160);
 
puls3(x);
 
u:=random(3);
u:=u-2;
if u<0 then v:=1;
if u>0 then v:=0;
 
case v of
1 : begin
settextstyle(0,0,2);
outtextxy(300,100,'Letalniy isxod');
t:=t+1;
bar(600,60,0,0);
outtextxy(2,2,'Serdce biyeniye: 0');
outtextxy(2,20,'Nijneye davleniye: 0');
outtextxy(2,38,'Verxneye davleniye: 0');
moveto(t,240);
while t<630     do
begin
lineto(t,240);
t:=t+1;
sound(1000);
delay(25);
end;
nosound;
end;
 
0: begin
v:=t;
bar(600,60,0,0);
outtextxy(2,2,'Serdce biyeniye: 0');
outtextxy(2,20,'Nijneye davleniye: 0');
outtextxy(2,38,'Verxneye davleniye: 0');
moveto(t,240);
while t<v+50 do
begin
lineto(t,240);
t:=t+1;
delay(25);
end;
puls4(t);
v:=t;
while t<v+100 do
begin
lineto(t,240);
t:=t+1;
delay(25);
end;end;end;
readln;
END.
Найти одну программу
1
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
31.07.2013, 00:18
Здравствуйте! Я подобрал для вас темы с ответами на вопрос Графика в Турбо Паскаль (Turbo Pascal):

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

Графика в Турбо Паскаль - Turbo Pascal
Не могли бы вы посоветовать книгу или дать ссылку на форуме где подробно описана работа с графикой , особенно рисовка движения разными...

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

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

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

Построение графика функции в турбо-Паскаль - Turbo Pascal
Как построить график данной функции в паскаль?(2*(1+0.7*(sin(10^7*t))*(sin(10^8*t))

157
proggamer12
17 / 17 / 2
Регистрация: 06.07.2012
Сообщений: 509
Завершенные тесты: 1
23.08.2013, 16:56 #137
Кому-нибудь нужен Space Invaders (подобие) на Pascal?
0
Новичок
Модератор
1261 / 809 / 182
Регистрация: 17.07.2012
Сообщений: 4,296
Записей в блоге: 1
Завершенные тесты: 2
23.08.2013, 17:50 #138
proggamer12,выкладывай,лично мне не нужен,но вдруг кому-то пригодится.
0
Dj Programmer
13 / 13 / 5
Регистрация: 05.10.2013
Сообщений: 141
08.11.2013, 23:07 #139
Пару простых программ :

1. Рисуем кораблик

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
uses graph,crt;
 var Gd,Gm,i: integer;
begin
 Gd:=Detect;
 initgraph(Gd, Gm, '');
  line(150,200,200,250);
   line(200,250,300,250);
    line(300,250,350,200);
     line(350,200,150,200);
      line(180,200,180,140);
       line(180,140,250,140);
        line(250,140,250,200);
       line(250,140,250,200);
      circle(210,220,10);
     circle(240,220,10);
    circle(270,220,10);
   line(200,140,200,90);
  bar(200,90,230,110);
 readkey;
 closegraph;
end.


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
 Uses crt,graph;
Var gd,gm,cor:integer;
    zvuk:string;
Begin
  textcolor(17+3);
  writeln('Zapustit raketu so zvukom da,net');
  readln(zvuk);
 gd:=detect;
  initgraph(gd, gm, '');
  cor:=350;
 setbkcolor(1);
 While cor>=-130 Do
  Begin
   if zvuk='da' then sound(1000);
    setcolor(4);
     circle(250,cor, 20);
      circle(250,cor+50, 20);
       circle(250,cor+100,20);
        rectangle(220,cor-30,280,cor+130);
         line(220,cor-30,250,cor-60);
          line(250,cor-60,280,cor-30);
           line(280,cor+80,310,cor+100);
          line(310,cor+100,310,cor+170);
         line(310,cor+170,280,cor+130);
        line(220,cor+80,190,cor+100);
       line(190,cor+100,190,cor+170);
      line(190,cor+170,220,cor+130);
     delay(5000);
    setcolor(0);
   circle(250,cor, 20);
  circle(250,cor+50, 20);
 circle(250,cor+100,20);
rectangle(220,cor-30,280,cor+130);
 line(220,cor-30,250,cor-60);
  line(250,cor-60,280,cor-30);
   line(220,cor+20,190,cor+50);
    line(280,cor+80,310,cor+100);
     line(310,cor+100,310,cor+170);
      line(310,cor+170,280,cor+130);
       line(220,cor+80,190,cor+100);
        line(190,cor+170,220,cor+130);
         line(190,cor+100,190,cor+170);
          cor:=cor-10;
  End;
 nosound;
 closegraph;
  textcolor(17+8);
   writeln('Raketa uletela nagmite klavichu!!!');
    sound(1000);
     delay(4000);
    nosound;
   readkey;
End.


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
Uses Graph;
var
  D,M,y,i : Integer;
begin
 D := Detect;
 InitGraph(D,M,'');
 if GraphResult <> grOk then WriteLn(GraphErrorMsg(GraphResult))
 else
  begin
    y:=200;
   for i:=1 to 30 do
    begin
     if i<5 then SetColor(4);
     if (i>5)and(i<10) then SetColor(14);
     if (i>10)and(i<15) then SetColor(2);
     if (i>20)and(i<25) then SetColor(1);
     if i>25 then SetColor(13);
      Ellipse(325,y,10,170,240,150);  {Эллиптические дуги}
      inc(y); {тоже что и y:=y+1}
    end;
    Readln;
    CloseGraph;
  end;
end.


Добавлено через 10 минут


Заполнение водой стакана из бутылки
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
USES GRAPH,crt;
label 1;
VAR GD,GM,X,Y,I,K,t,h,m:INTEGER;
 
s,d:array[1..30] of integer;
BEGIN
clrscr;
gd:=detect;
initgraph(gd,gm,'');
s[1]:=466;
d[1]:=400*5;
 
s[2]:=294;
d[2]:=400*5;
 
d[3]:=30*5;
 
s[4]:=294;
d[4]:=400*5;
 
s[5]:=466;
d[5]:=400*5;
 
d[6]:=30*5;
 
s[7]:=466;
d[7]:=1000*5;
 
s[8]:=294;
d[8]:=400*5;
 
d[9]:=30*5;
 
s[10]:=294;
d[10]:=400*5;
 
s[11]:=466;
d[11]:=400*5;
 
d[12]:=30*5;
 
s[13]:=466;
d[13]:=400*5;
 
s[14]:=294;
d[14]:=400*5;
 
s[15]:=311;
d[15]:=400*5;
 
s[16]:=294;
d[16]:=400*5;
 
d[17]:=30*5;
 
s[18]:=294;
d[18]:=400*5;
 
s[19]:=262;
d[19]:=400*5;
 
d[20]:=30*5;
 
s[21]:=262;
d[21]:=400*5;
 
s[22]:=440;
d[22]:=400*5;
 
d[23]:=30*5;
 
s[24]:=440;
d[24]:=400*5;
 
s[25]:=440;
d[25]:=400*5;
 
d[26]:=30*5;
setcolor(15);
{стакан}
ellipse(140,330,0,360,68,10);
ellipse(140,430,180,360,35,10);
line(72,330,105,430);
line(208,330,175,430);
line(140,340,140,440);
line(102,338,123,438);
line(178,338,157,438);
{бутылка}
ellipse(500,400,180,360,70,25);
ellipse(500,200,180,360,70,25);
ellipse(530,200,0,80,40,30);
ellipse(470,200,100,180,40,30);
ellipse(500,170,180,360,37,10);
ellipse(500,30,0,360,30,10);
ellipse(500,30,0,360,20,5);
ellipse(500,40,180,360,30,10);
ellipse(500,250,180,360,70,25);
line(530,30,530,40);
line(470,30,470,40);
line(570,200,570,400);
line(430,200,430,400);
setcolor(14);
line(568,259,568,400);
line(432,259,432,400);
ellipse(500,398,180,360,68,25);
ellipse(500,255,180,360,68,25);
setcolor(15);
setfillstyle(11,15);
floodfill(500,300,14);
line(537,170,520,100);
line(463,170,480,100);
line(520,100,520,50);
line(480,100,480,50);
delay(4000);
setcolor(0);
 
 
setfillstyle(11,0);
floodfill(500,300,14);
line(568,259,568,400);
line(432,259,432,400);
ellipse(500,398,180,360,68,25);
ellipse(500,255,180,360,68,25);
{бутылка стерлась}
setcolor(0);
ellipse(500,400,180,360,70,25);
ellipse(500,200,180,360,70,25);
ellipse(530,200,0,80,40,30);
ellipse(470,200,100,180,40,30);
ellipse(500,170,180,360,37,10);
ellipse(500,250,180,360,70,25);
ellipse(500,30,0,360,30,10);
ellipse(500,30,0,360,20,5);
ellipse(500,40,180,360,30,10);
line(530,30,530,40);
line(470,30,470,40);
line(570,200,570,400);
line(430,200,430,400);
line(537,170,520,100);
line(463,170,480,100);
line(520,100,520,50);
line(480,100,480,50);
delay(500);
setcolor(15);
 
{бутылка 1 }
ellipse(500,100,270,90,25,70);
ellipse(300,100,270,90,25,70);
line(500,170,300,170);
line(500,30,300,30);
ellipse(305,130,190,260,30,40);
ellipse(305,70,100,170,30,40);
ellipse(275,100,270,90,10,37);
line(275,65,205,82);
line(154,115,525,115);
line(276,136,205,117);
line(133,115,140,115);
line(205,82,155,82);
line(210,118,154,118);
setfillstyle(11,15);
floodfill(400,120,15);
floodfill(300,120,15);
ellipse(136,100,0,360,10,30);
ellipse(136,100,0,360,5,20);
ellipse(146,100,270,90,10,30);
line(136,130,146,130);
line(136,70,146,70);
floodfill(280,120,15);
floodfill(133,117,15);
delay(90);
for i:=115 to 440 do begin
putpixel(trunc(133+4*sin(i/30)),i,15);
putpixel(trunc(140+4*sin(i/30)),i,15);
delay(5);
end;
m:=430;
t:=34;
for i:=1 to 26 do begin
if (i=3) or (i=6) or (i=9) or (i=12) or (i=17) or (i=20) or (i=23) or (i=26)
then  begin nosound ; goto 1; end;
sound(s[i]);
1:ellipse(140,m,180,360,t,10);
t:=t+1;
m:=m-3;
delay(d[i]);
end;
 
readln;
closegraph;
end.


Добавлено через 2 минуты
Если стакан медленно заполняется то можно уменьшить параметр delay
0
ildwine
Модератор
2907 / 1759 / 636
Регистрация: 04.03.2013
Сообщений: 4,371
Записей в блоге: 1
08.11.2013, 23:31 #140
Цитата Сообщение от Dj Programmer Посмотреть сообщение
Пару простых программ
А теперь то же самое, но в циклах...
1
Dj Programmer
13 / 13 / 5
Регистрация: 05.10.2013
Сообщений: 141
08.11.2013, 23:33 #141
Цитата Сообщение от ildwine Посмотреть сообщение
А теперь то же самое, но в циклах...
Спасибо, учту
0
RAFISTAUR
8 / 8 / 3
Регистрация: 16.12.2013
Сообщений: 79
25.12.2013, 15:54 #142
Вот программа графического Лохотрона:
0
Вложения
Тип файла: rar LOHOTRON.rar (2.1 Кб, 48 просмотров)
Svager
393 / 373 / 212
Регистрация: 14.09.2013
Сообщений: 1,200
12.05.2014, 02:25 #143
Игра Расстановка 16 букв
собственного производства
1
Вложения
Тип файла: rar GAME16.rar (2.1 Кб, 30 просмотров)
dimabubyakin
159 / 120 / 44
Регистрация: 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
Модератор
52404 / 40251 / 13583
Регистрация: 18.05.2008
Сообщений: 93,050
04.10.2014, 08:06 #149
И для чего везде continue ?
1
hoch
Заблокирован
04.10.2014, 12:04 #150
Я приношу свои извинения.
В первом варианте не было оператора case of
и они были нужны. Потом код изменился и я
забыл их удалить.
0
04.10.2014, 12:04
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
04.10.2014, 12:04
Привет! Вот еще темы с ответами:

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

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

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

Графика в Турбо Паскаль. Разносторонний треугольник, вращающийся вокруг центра тяжести - Turbo Pascal
Изобразить на экране разносторонний треугольник, вращающийся вокруг центра тяжести в плоскости экрана. Центр тяжести это точка...


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

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

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