Форум программистов, компьютерный форум, киберфорум
Наши страницы
Turbo Pascal
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг 4.82/1163: Рейтинг темы: голосов - 1163, средняя оценка - 4.82
Давид
Программист 1С
856 / 644 / 187
Регистрация: 03.03.2009
Сообщений: 1,154
08.11.2009, 23:32 #21
Тем кто обращается с просьбами нарисовать более сложные рисунки (например в трехмерном пространстве) расскажу удобный способ рисования!
Пусть например нужно нарисовать следующий объект на Паскале.
0
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
08.11.2009, 23:32
Ответы с готовыми решениями:

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

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

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

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

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

157
Давид
Программист 1С
856 / 644 / 187
Регистрация: 03.03.2009
Сообщений: 1,154
08.11.2009, 23:35 #22
Конечно не всем удасться мысленно представить каждую линию в координатах на этом рисунке, и далеко не всем удасться перерисовать это на тетрадный лист!Поэтому можно сделать следующие действия:
1) Сохранить рисунок если он размещен на сайте или любом другом носителе.
2) Если есть возможность - распечатать изображение на формате А4, иначе открыть его в любом табличном или текстовом редакторе (word,exel).
3) В рамках рисунка начертить две оси кординат - с соответствующими координатами (расчертить клетки).
Линии которые не видно можно обвести.
Должно получиться примерно так!
0
Давид
Программист 1С
856 / 644 / 187
Регистрация: 03.03.2009
Сообщений: 1,154
08.11.2009, 23:37 #23
Нас всегда учили так делать. Данная процедура занимает отсилы 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
program x;
uses crt,graph;
Var gd,gm:integer;
begin
clrscr;
detectgraph (gd,gm);
initgraph (gd,gm,'tp\7');
Line (60,150,60,450);
Line (60,150,240,150);
Line (60,450,240,450);
Line (240,150,240,450);
Line (60,150,240,60);
Line (240,150,390,60);
Line (240,60,390,60);
Line (390,60,390,350);
Line (390,350,240,450);
Line (82,140,255,140);
Line (255,140,255,440);
Line (90,180,150,180);
Line (150,180,150,240);
Line (150,240,90,240);
Line (90,240,90,180);
Line (120,180,120,210);
Line (90,240,120,210);
Line (120,210,150,210);
Line (90,270,150,270);
Line (150,270,150,330);
Line (150,330,90,330);
Line (90,330,90,270);
Line (90,330,120,300);
Line (120,270,120,300);
Line (120,300,150,300);
Line (90,360,150,360);
Line (150,360,150,420);
Line (150,420,90,420);
Line (90,420,90,360);
Line (120,360,120,390);
Line (120,390,90,420);
Line (120,390,150,390);
Line (180,330,180,450);
Line (180,330,240,330);
Line (180,390,185,390);
Line (255,175,390,93);
Line (270,185,380,117);
Line (330,150,330,175);
Line (255,240,390,150);
Line (255,300,390,210);
Line (255,360,390,270);
Line (255,420,390,330);
Readln
end.
0
ЛоРД_Оледжан
Программист
56 / 54 / 15
Регистрация: 23.07.2009
Сообщений: 336
10.11.2009, 13:12 #24
Лучший ответ Сообщение было отмечено Памирыч как решение

Решение

Анимация пейзажа - домик, дерево, з дымаря домика выпускаются клубочки дыма, а по небу передвигается туча.

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
program grafika_01;
uses crt,graph;
var
gr1,gr2,x,y,a,b,c,d,i:integer;
begin
a:=200;b:=1;c:=260;d:=100;i:=0;
gr1:=detect;
gr2:=vgahi;
initgraph(gr1,gr2,'C:PascalBGI');
SetFillStyle(1,1);
Bar(0,0,640,480);
SetFillStyle(1,2);
Bar(0,460,640,480);
SetFillStyle(1,6);
Bar(80,340,200,460);
Bar(85,270,115,320);
SetFillStyle(1,9);
Bar(120,380,160,420);
SetColor(0);
Rectangle(120,380,160,420);
Line(140,380,140,420);
Line(140,400,160,400);
Line(60,340,140,280);
line(140,280,220,340);
Line(220,340,60,340);
SetFillStyle(1,6);
FloodFill(140,310,0);
SetFillStyle(1,9);
Sector(140,325,0,180,20,20);
line(140,325,140,305);
Line(140,325,154,315);
Line(140,325,126,315);
SetFillStyle(1,14);
FillEllipse(490,100,40,40);
SetFillStyle(1,7);
FillEllipse(492,104,4,4);
FillEllipse(488,86,6,6);
FillEllipse(500,75,2,3);
FillEllipse(480,120,4,2);
FillEllipse(520,90,2,2);
SetFillStyle(1,6);
Bar(450,340,460,460);
SetFillStyle(1,2);
Arc(415,320,40,320,20);
Arc(455,320,40,140,20);
Arc(455,320,220,320,20);
Arc(495,320,220,500,20);
Arc(435,320,75,135,30);
Arc(475,320,45,105,30);
Arc(435,320,225,315,30);
Arc(475,320,225,320,30);
Arc(455,300,20,160,25);
FloodFill(455,320,0);
x:=0;
y:=460;
SetColor(2);
repeat
Line(x,y,x+10,y-10);
Line(x+10,y,x+30,y-20);
x:=x+20;
until x>=640;
repeat
SetfillStyle(1,1);
Bar(0,140,520,200);
Bar(0,0,200,265);
SetColor(1);
SetColor(0);
if c<0 then begin c:=260;i:=0;d:=100 end;
SetFillStyle(1,15);
Arc(a-40,170,40,320,20);
Arc(a,170,40,140,20);
Arc(a,170,220,320,20);
Arc(a+40,170,220,500,20);
Arc(a-20,170,45,135,30);
Arc(a+20,170,45,135,30);
Arc(a-20,170,225,315,30);
Arc(a+20,170,225,320,30);
FloodFill(a+1,171,0);
SetFillStyle(1,7);
FillEllipse(d,c,8+i,5+i);
FillEllipse(d,c-10,14+i,10+i);
FillEllipse(d,c-25,19+i,15+i);
FillEllipse(d,c-45,25+i,19+i);
c:=c-11;
d:=d+5*b;
i:=i-1;
if a=460 then b:=-1;
if a=40 then b:=1;
a:=a+10*b; delay(64000); delay(64000);
until keypressed;
readln;
end.
1
Puporev
Модератор
54384 / 41966 / 28987
Регистрация: 18.05.2008
Сообщений: 98,859
28.11.2009, 13:15 #25
Лучший ответ Сообщение было отмечено Памирыч как решение

Решение

Последнее время были темы с просьбой нарисовать аэродром в горах и управляемый самолет. Вот программа, любезно предоставленная lexus_ilia.
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
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
Program laba13a;
uses
 graph,crt;
Var
 xc,yc,x,y,vx,vy:array[1..950] of integer;
 l:array[1..950] of boolean;
 gd,gm,x1,x2,y1,y2,x3,x4,y3,y4,y8,dx:integer;
 n,i,j,m:integer;
 c:char;
 p:boolean;
Procedure cam(x1,x2,y1,y2:integer);
begin
 SetFillStyle(1,10);
 bar(x1,y1,x2,y2);          { Tela camoLetuka }
 
 x3:=((x2-x1) div 2)-5+X1;  { KoopduHaTbl }
 x4:=((x2-x1) div 2)+5+X1;   { HoJKu }
 bar(x3,y2+1,x4,y2+9);           {HojKa}
 
 bar(x3-25,y2+9,x4+25,y2+15);    {nlatfoPma}
 
 setcolor(10);
 y8:=round((y2-y1) div 2)+y1;
 FillEllipse(x1,y8,20,15);     {Cama kabuHa}
                         {noDDepjKa Dl9 lonocTeU}
 bar(x3+3,y1-10,x4-3,y1);    {Cama noddepjka}
 bar(x3-33,y1-13,x4+33,y1-10); {Cama lonaCtb}
 
 bar(x2,y2-9,x2+45,y2);  {KoopDuHaTbl}
 FillEllipse(x2+41,y2-10,10,10);{nPaBou 4aCtu}
end;
procedure del(x1,y1,x2,y2:integer); {YdaLeHue caMoLeTuka}
begin
 SetFillStyle(1,1);
 bar(x1,y1-9,x2,y2+15);
 setcolor(1);
 y8:=round((y2-y1) div 2)+y1;
 FillEllipse(x1,y8,20,15);
 bar(x3-33,y1-13,x4+33,y1-10);
 bar(x2,y2-9,x2+45,y2);
 FillEllipse(x2+41,y2-10,10,10);
end;
procedure boom(x1,y1:integer);
begin
 ClearDevice;
 for i:=1 to 500 do
 begin
  X[i]:= x1+ i mod 10;
  Y[i]:= y1+ i div 10;
  PutPixel(X[i], Y[i], 15);
  VX[i]:= -10 + random(25);
  VY[i]:= -10 + random(25);
  l[i]:=true;
  if vx[i]=0 then
   vx[i]:=10;
  if vy[i]=0 then
   vy[i]:=10
 end;
 for i:=1 to 150 do
 begin
  sound(random(80));
  delay(1);
  nosound
 end;
 Delay(1000);
 SetColor(0);
 Repeat
  p:=false;
  for i:=1 to 500 do
  begin
  if l[i] then
  begin
   if(X[i]+VX[i] > 0) and (X[i]+VX[i] < Getmaxx) and
     (Y[i]+VY[i] > 0) and
     (getpixel(x[i]+vx[i],y[i]+vy[i])<>6) and (getpixel(x[i]+vx[i],y[i]+vy[i])<>4)
   then
   begin
    PutPixel(X[i],Y[i],0);
    X[i]:= X[i]+VX[i];
    Y[i]:= Y[i]+VY[i];
    PutPixel(X[i], Y[i], 14);
    p:=true
   end
    else
    begin
     l[i]:=false;
     VX[i]:= 0;
     VY[i]:= 0;
     sound(200);
     delay(2);
     nosound
    end;
  end;
  if i=300 then
    setbkcolor(random(20+1))
  end;
 Until not(p);
 exit;
end;
procedure goPa;
var
 i,j:integer;
begin
 SetFillStyle(1,6);
 i:=1;
 while i<=getmaxx do
 begin
  repeat
   j:=random(450)
  until j>200;
  bar(i,j,i+40,getmaxy);
  inc(i,15);
 end;
 i:=random(getmaxx-115);
 repeat
  j:=random(getmaxy-22);
 until j>300;
 SetFillStyle(1,4);
 bar(i,j,i+60,j+21);
 SetFillStyle(1,0);
 bar(i-25,0,i+115,j)
end;
Procedure nobeda;
begin
 closegraph;
 Gotoxy(30,12);
 Writeln('nocaDka bblLa ycneLLIHoU');
 readln;
end;
begin
 clrscr;
 repeat
  Gotoxy(30,12);
  writeln('Bblbepute ckoPoCtb ot 0-9');
  c:=readkey;
 until c in [#48..#57];
 case c of
  #48: dx:=0;
  #49: dx:=2;
  #50: dx:=4;
  #51: dx:=6;
  #52: dx:=8;
  #53: dx:=10;
  #54: dx:=12;
  #55: dx:=14;
  #56: dx:=16;
  #57: dx:=18;
 end;
 gd:=Detect;
 InitGraph(gd,gm,'c:\tp7\bgi');
 setbkcolor(1);
 randomize;
 gopa;
 x1:=getmaxx div 2;
 y1:=getmaxy div 2 -150;
 
 cam(x1,x1+60,y1,y1+30);
 if dx=0 then
 begin
  repeat
   dx:=15;
   p:=true;
   if y1+46+dx<getmaxy then
   begin
    m:=x3-25;
    n:=y1+53;
    p:=true;
    while (m<=x4+25) and (p) do
    begin
     if getpixel(m,n)=6 then
     begin
      boom(x1,y1);
      c:=#27;
      p:=false;
     end;
      inc(m);
     end;
    if (getpixel(x1-25,y8)=6) or (getpixel(x1-23,y8+5)=6) or (getpixel(x1-20,y8+10)=6)
    then
     p:=false;
    if (getpixel(x1-15,y8+15)=6) or (getpixel(x1-10,y8+17)=6) or (getpixel(x1-5,y8+19)=6)
    then
     p:=false;
    m:=x1+61;
    while (m<=x1+110) and (p) do
    begin
    if getpixel(m,y1+37)=6 then
    begin
     boom(x1,y1);
     c:=#27;
     p:=false;
    end;
    inc(m);
    end;
   if not(p) then
   begin
    boom(x1,y1);
    p:=false;
   end
   else
   begin
    SetFillStyle(1,1);
    del(x1,y1,x1+60,y1+30);
    y1:=y1+dx;
    cam(x1,x1+60,y1,y1+30)
   end
  end
  else
  begin
   SetFillStyle(1,1);
   del(x1,y1,x1+60,y1+30);
  if y1+46+1<=getmaxy then
  begin
   y1:=y1+1;
   cam(x1,x1+60,y1,y1+30)
  end
  else
   cam(x1,x1+60,y1,y1+30)
  end;
  Delay(60000);
 until not(p)
 end
 
 else
 begin
 
  repeat
   if keypressed then
   begin
    c:=readkey;
    case ord(c) of  {Huz,Bepx,Lebo,npabo}
     49: dx:=2;
     50: dx:=4;
     51: dx:=6;
     52: dx:=8;
     53: dx:=10;
     54: dx:=12;
     55: dx:=14;
     56: dx:=16;
     57: dx:=18;
         {////////BnpaBo//////////////}
     77: if x1+111+dx<getmaxx then
          begin
           p:=true;
           if getpixel(x1+115,y1+25)=6 then
           begin
             boom(x1,y1);
             c:=#27;
             p:=false;
           end;
           Putpixel(x1+115,y1+25,9);
           m:=x1+61;
           while (m<=x1+110) and (p) do
           begin
            if getpixel(m,y1+33)=6 then
            begin
             boom(x1,y1);
             c:=#27;
             p:=false;
            end;
            inc(m);
           end;
           m:=y1+32;
           while (m<=y1+45) and (p) do
           begin
            if getpixel(x1+64,m)=6 then
            begin
             boom(x1,y1);
             c:=#27;
             p:=false;
            end;
            inc(m);
           end;
           if p then
           begin
            SetFillStyle(1,1);
            del(x1,y1,x1+60,y1+30);
            x1:=x1+dx;
            cam(x1,x1+60,y1,y1+30);
            m:=x1+61;
           end;
          end
         else
         begin
          SetFillStyle(1,1);
           del(x1,y1,x1+60,y1+30);;
           if x1+111+1<=getmaxx then
           begin
            x1:=x1+1;
            cam(x1,x1+60,y1,y1+30)
           end
           else
            cam(x1,x1+60,y1,y1+30)
          end;
         {////////BnpaBo//////////////}
 
         {////////BLeBo//////////////}
     75: if x1-dx-20>0 then
          begin
           p:=true;
           if (getpixel(x1-25,y8)=6) or (getpixel(x1-23,y8+5)=6) or (getpixel(x1-20,y8+10)=6)
           then
            p:=false;
           if (getpixel(x1-15,y8+15)=6) or (getpixel(x1-10,y8+17)=6) or (getpixel(x1-5,y8+19)=6)
           then
            p:=false;
            if (getpixel(x1-25,y8)=6) or (getpixel(x1-23,y8-5)=6) or (getpixel(x1-20,y8-10)=6)
           then
            p:=false;
           if (getpixel(x1-15,y8-15)=6) or (getpixel(x1-10,y8-17)=6)
            then
            p:=false;
           m:=y8+19;
            while (m<y8+31) and (p) do
            begin
            if GetPixel(x1-5,m)=6 then
            begin
             boom(x1,y1);
             c:=#27;
             p:=false;
            end;
             inc(m);
            end;
           m:=y8-17;
           while (m>=y8-28) and p do
           begin
            if GetPixel(x1-10,m)=6 then
            begin
             boom(x1,y1);
             c:=#27;
             p:=false;
            end;   
            dec(m);
           end;
           if not(p) then
           begin
            boom(x1,y1);
            c:=#27;
            p:=false;
           end
           else
           begin
            SetFillStyle(1,1);
            del(x1,y1,x1+60,y1+30);
            x1:=x1-dx;
            cam(x1,x1+60,y1,y1+30);
           end
          end
          else
          begin
           SetFillStyle(1,1);
           del(x1,y1,x1+60,y1+30);
           if x1-1-20>=0 then
           begin
            x1:=x1-1;
            cam(x1,x1+60,y1,y1+30)
           end
           else
            cam(x1,x1+60,y1,y1+30)
          end;
       {////////BLeBo//////////////}
 
       {////////BBepX//////////////}
     72: if y1-13-dx>0 then
          begin
           SetFillStyle(1,1);
           del(x1,y1,x1+60,y1+30);
           y1:=y1-dx;
           cam(x1,x1+60,y1,y1+30);
          end
         else
         begin
          SetFillStyle(1,1);
           del(x1,y1,x1+60,y1+30);
           if y1-13-1>=0 then
           begin
            y1:=y1-1;
            cam(x1,x1+60,y1,y1+30)
           end
           else
            cam(x1,x1+60,y1,y1+30)
          end;
         {////////BBepX//////////////}
 
         {////////BHu3//////////////}
     80: if y1+46+dx<getmaxy then
          begin
           p:=true;
           m:=x3-5;
           n:=y1+60;
            while (m<=x4+5) and (p) do
            begin
             if getpixel(m,n)=4 then
              p:=false;
             inc(m);
            end;
           if not p then
           begin
            c:=#27;
            nobeda;
           end;
           m:=x3-25;
           n:=y1+50;
           p:=true;
            while (m<=x4+25) and (p) do
            begin
             if getpixel(m,n)=6 then
             begin
              boom(x1,y1);
              c:=#27;
              p:=false;
             end;
             inc(m);
            end;
           if (getpixel(x1-25,y8)=6) or (getpixel(x1-23,y8+5)=6) or (getpixel(x1-20,y8+10)=6)
           then
            p:=false;
           if (getpixel(x1-15,y8+15)=6) or (getpixel(x1-10,y8+17)=6) or (getpixel(x1-5,y8+19)=6)
           then
            p:=false;
            m:=x1+61;
            while (m<=x1+110) and (p) do
            begin
             if getpixel(m,y1+35)=6 then
             begin
              boom(x1,y1);
              c:=#27;
              p:=false;
             end;
             inc(m);
            end;
           if not(p) then
           begin
              boom(x1,y1);
              c:=#27;
              p:=false;
             end
           else
           begin
            SetFillStyle(1,1);
            del(x1,y1,x1+60,y1+30);
            y1:=y1+dx;
            cam(x1,x1+60,y1,y1+30)
           end
           end
           else
           begin
            SetFillStyle(1,1);
            del(x1,y1,x1+60,y1+30);
           if y1+46+1<=getmaxy then
           begin
            y1:=y1+1;
            cam(x1,x1+60,y1,y1+30)
           end
           else
            cam(x1,x1+60,y1,y1+30)
           end
         {////////BHu3//////////////}
    end;
   end;
  until c=#27;
 end;
 closegraph;
end.
1
sRnNikita
1 / 1 / 0
Регистрация: 23.05.2009
Сообщений: 17
04.12.2009, 19:14 #26
Вращение равносторонних многоугольников по своей оси.

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
uses graph, crt;
const n=8;{изменяя "n" вы получите любой другой многоугольник}
var poly:array[1..n+1] of pointtype;
 r,x,y,i,driver,mode:integer;
 alpha:real;
 s:string;
begin
 write('radius: ');
 readln(r);
 alpha:=0;
 driver:=detect;
 InitGraph (driver,mode, 'd:\bp\bgi');
 if GraphResult<>GroK then halt(1);
 clearviewPort;
 repeat
 x:=GetMaxX shr 1;
 y:=GetMaxY shr 1;
 for i:=1 to n +1 do begin
 poly[i].X:=x+round(R*Cos(alpha+(i-1)*2*pi/n));
 poly[i].Y:=y+Round(R*sin(alpha+(i-1)*2*pi/n));
 end;
 SetColor(10);
 DrawPoly(n+1,poly);
alpha:= alpha+pi/180;
 delay(1000);
 setcolor(0);
 DrawPoly(n+1,poly);
 until KeyPressed;
 closeGraph;
 end.
1
unlucky
37 / 37 / 28
Регистрация: 23.11.2009
Сообщений: 103
08.12.2009, 02:46 #27
Хоть и глупая прога но всё же)) моя лаба на графф
после нажатия 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
uses crt,graph;
var
i,d,m:integer;
k:integer;
p:char;
begin
d:=detect;
initgraph(d,m,'');
cleardevice;
circle(200,225,20);
circle(200,200,50);
circle(400,225,20);
circle(400,200,50);
arc(300,300,180,359,100);
p:=readkey;
if p=#13 then
begin
for i:=1 to getmaxx do
begin
k:=k+10;
cleardevice;
setcolor(red);
line(5+k,300,50+k,300);
line(25+k,300,25+k,265);
line(20+k,300,25+k,280);
line(25+k,275,40+k,270);
line(40+k,270,35+k,300);
line(25+k,275,33+k,280);
line(33+k,280,13+k,300);
circle(25+k,260,5);
circle(23+k,260,1);
circle(27+k,260,1);
delay(15000);
cleardevice;
line(5+k,300,50+k,300);
line(25+k,300,25+k,265);
line(35+k,300,25+k,280);
line(25+k,275,38+k,275);
line(42+k,285,5+k,300);
line(25+k,275,42+k,285);
line(38+k,275,25+k,300);
circle(25+k,260,5);
circle(23+k,260,1);
circle(27+k,260,1);
delay(15000);
clrscr;
if k>getmaxx then k:=1;
if keypressed then break;
end;
end;
closegraph;
readkey
end.
0
WolfCF
3288 / 1350 / 108
Регистрация: 28.04.2009
Сообщений: 4,823
09.12.2009, 08:02 #28
Скачущий мяч
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
uses crt,graph;
  const r=20;h=5;
  var gd,gm,i,n,t,x,y,p:integer;
   begin
  clrscr;
  gd:=Detect;
  initgraph(gd,gm,' ');
  setcolor(green);
  setlinestyle(0,1,1);
  line(0,479,639,479);
  x:=r;y:=r;
  t:=479-2*r;
  n:=t div h;
  p:=h;
  while n<>0 do begin
  for i:=1 to n do begin
  setcolor(yellow);
  circle(x,y,r);
  setfillstyle(1,2);
  floodfill(x,y,2);
  delay(100);
  setcolor(0);
  circle(x,y,r);
  setfillstyle(1,0);
  floodfill(x,y,0);
  y:=y+p;
  x:=x+1;
  end;
 if p>0 then  begin t:=round(3*t/4);n:=t div h end;
 p:=-p end;
 setcolor(12);
 circle(x,y,r);
 setfillstyle(1,2);
 floodfill(x,y,12);
 repeat until keypressed;
  closegraph
 end.
0
mus
52 / 51 / 19
Регистрация: 22.03.2009
Сообщений: 173
10.12.2009, 19:53 #29
Задача из своих инициалов нарисовать буквы и преобразовывать их на плоскости при помощи афинных преобразований.

Хотелось бы узнать а как это сделать в пространстве ?


Программа считывает координаты точек, для построения букв, из файлов.
Также для лучшего отображения использован 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
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
program Iniziali;
 uses graph,crt;
 const m=13; d=16; v=18;  pi=3.14;
 var mx,my,mx1,my1:array[1..m] of integer;
 dx,dy,dx1,dy1:array[1..d] of integer;
 vx,vy,vx1,vy1:array[1..v] of integer;
 a,b,i,j,n,l,GraphDriver,GraphMode,GraphError:integer;
 alpha,beta:real;
 f:text;
begin
  GraphDriver :=  9;
   GraphMode := 1;
  InitGraph(GraphDriver, GraphMode,'');
  GraphError := GraphResult;
  if GraphError <> grOk then begin
    writeln ('osibka pri inizializazii graph');
    writeln(GraphErrorMsg(GraphError));
     halt(1);
    end;
    setbkcolor(15);
    setcolor(1);
 
    a:=450;
    b:=100;
 
    assign(f,'c:\projects\graphika\lab2\m.pas');
    reset(f);
    for i:=1 to m do
     readln(f,mx[i],my[i]);
 
    assign(f,'c:\projects\graphika\lab2\d.pas');
    reset(f);
    for i:=1 to d do
     readln(f,dx[i],dy[i]);
 
     assign(f,'c:\projects\graphika\lab2\v.pas');
    reset(f);
    for i:=1 to v do
     readln(f,vx[i],vy[i]);
 
 
    for i:=2 to m do
     begin
      line(mx[i-1],my[i-1],mx[i],my[i]);
     end;
 
    for i:=2 to d do
     begin
      if i<=12 then line(dx[i-1],dy[i-1],dx[i],dy[i])
       else
       while i<16 do
        begin
         i:=i+1;
         line(dx[i-1],dy[i-1],dx[i],dy[i]);
        end;
     end;
 
    for i:=2 to v do
     begin
      line(vx[i-1],vy[i-1],vx[i],vy[i]);
     end;
 
 
    for j:=1 to 72 do {216}
    begin
 
 
    SetActivePage(j);
 
    cleardevice;
 
       if j < 38 then alpha := alpha + 0.1 else alpha := alpha - 0.1;
       if j < 38 then beta := beta + 0.1 else beta := beta - 0.1;
 
      for i:=1 to v do
      begin
 
 
       vx1[i]:=round(alpha*vx[i]+(1-alpha)*a);
 
       vy1[i]:=round(beta*vy[i]+(1-beta)*b);
 
 
      end;
 
      setcolor(green);
     for i:=2 to v do
 
      begin
       {if (i <> 9) and (i <> 14) then line(vx1[i-1],vy1[i-1],vx1[i],vy1[i]);}
 
       setfillstyle(1,red);
 
       if (i<>9) and (i<>14) then  line(vx1[i-1],vy1[i-1],vx1[i],vy1[i]);
       if i > 17 then floodfill(round((vx1[12]+vx1[15])/2),round((vy1[12]+vy1[15])/2),green);
 
 
 
      end;
 
 
     setcolor(blue);
     for i:=1 to m do
      begin
       mx1[i]:=round(mx[i]*cos(j*5*pi/180)+my[i]*sin(j*5*pi/180)-100*cos(j*5*pi/180)-125*sin(j*5*pi/180)+125);
 
       my1[i]:=round(-mx[i]*sin(j*5*pi/180)+my[i]*cos(j*5*pi/180)+100*sin(j*5*pi/180)-125*cos(j*5*pi/180)+100);
 
      end;
 
     for i:=2 to m do
     begin
      line(mx1[i-1],my1[i-1],mx1[i],my1[i]);
     end;
     setfillstyle(1,yellow);
     floodfill(125,100,blue);
 
     for i:=1 to d do
      begin
       dx1[i]:=round(dx[i]*cos(j*(-5)*pi/180)+dy[i]*sin(j*(-5)*pi/180)-270*cos(j*(-5)*pi/180)-115*sin(j*(-5)*pi/180)+270);
 
 
       dy1[i]:=round(-dx[i]*sin(j*(-5)*pi/180)+dy[i]*cos(j*(-5)*pi/180)+270*sin(j*(-5)*pi/180)-115*cos(j*(-5)*pi/180)+115);
      end;
 
     for i:=2 to d do
      begin
       if i < 13 then  line(dx1[i-1],dy1[i-1],dx1[i],dy1[i]);
      if i = 13 then
         begin
           setfillstyle(1,5);
           floodfill(270,115,blue);
         end;
       if i > 13 then line(dx1[i-1],dy1[i-1],dx1[i],dy1[i]);
      end;
     setfillstyle(1,white);
     floodfill(270,115,blue);
 
    SetVisualPage(j);
    delay(5000);
 
    end;
 
    readln;
    closegraph;
end.
1
mus
52 / 51 / 19
Регистрация: 22.03.2009
Сообщений: 173
08.01.2010, 12:48 #30
Условие задачи: Сделать вращение 3х мерных объектов в пространстве с закраской передней грани.

координаты представляют собой 3 значения: X Y Z (Пример: 50 100 50)


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
program Bukvi3D;
 uses graph,crt;
 const m=36; d=34; v=36;  pi=3.14;
 var mx,my,mx1,my1,mz,mz1,mx2,my2,mz2,mxe,mxe1,mye,mye1:array[1..m] of integer;
 dx,dy,dx1,dy1,dz,dz1,dx2,dy2,dz2:array[1..d] of integer;
 vx,vy,vz,vx1,vy1,vz1,vx2,vy2,vz2:array[1..v] of integer;
 mfe,mfe1:array[1..60] of pointtype;
 dfe,dfe1:array[1..60] of pointtype;
 vfe,vfe1:array[1..60] of pointtype;
 
 
 i,j,n,l,GraphDriver,GraphMode,GraphError:integer;
 f:text;
 
 
procedure Mekr;      { процедура преобразования координат буквы М    }
 begin                    {  из кабинетной 3D проекции на плоскось экрана  }
  for i:=1 to m do
     begin
      mx2[i]:=round(1*mx1[i]+0*my1[i]-cos(pi/3)*mz1[i]+100);
      my2[i]:=round(0*mx1[i]-1*my1[i]-sin(pi/3)*mz1[i]+200);
     end;
 end;
 
procedure Dekr;         { преобразование координат буквы Д}
 begin
  for i:=1 to d do
     begin
      dx2[i]:=round(1*dx1[i]+0*dy1[i]-cos(pi/3)*dz1[i]+250);
      dy2[i]:=round(0*dx1[i]-1*dy1[i]-sin(pi/3)*dz1[i]+200);
     end;
 end;
 
procedure Vekr;         { преобразование координат буквы В}
 begin
  for i:=1 to v do
     begin
      vx2[i]:=round(1*vx1[i]+0*vy1[i]-cos(pi/3)*vz1[i]+400);
      vy2[i]:=round(0*vx1[i]-1*vy1[i]-sin(pi/3)*vz1[i]+200);
     end;
 end;
 
 
procedure fmekr;        { процедура закраски передней грани буквы М}
 begin
   for i:=1 to 12 do
    begin
     mfe[i].x:=mx2[i];
     mfe[i].y:=my2[i];
    end;
   setfillstyle(1,green);
   drawpoly(12,mfe);
   fillpoly(12,mfe);
 end;
procedure fmekr1;        { процедура закраски задней грани буквы М}
 begin
   for i:=1 to 12 do
    begin
     mfe1[i].x:=mx2[i+13];
     mfe1[i].y:=my2[i+13];
    end;
   setfillstyle(1,green);
   drawpoly(12,mfe1);
   fillpoly(12,mfe1);
 end;
 
procedure fdekr;        { процедура закраски передней грани буквы Д}
 begin
   for i:=1 to 17 do
    begin
     dfe[i].x:=dx2[i];
     dfe[i].y:=dy2[i];
    end;
   setfillstyle(1,yellow);
   drawpoly(17,dfe);
   fillpoly(17,dfe);
 end;
 
 
procedure fdekr1;          { процедура закраски задней грани буквы М}
 begin
   for i:=1 to 17 do
    begin
     dfe1[i].x:=dx2[i+17];
     dfe1[i].y:=dy2[i+17];
    end;
   setfillstyle(1,yellow);
   drawpoly(17,dfe1);
   fillpoly(17,dfe1);
 end;
 
procedure fvekr;      { процедура закраски передней грани буквы В}
 begin
   for i:=1 to 18 do
    begin
     vfe[i].x:=vx2[i];
     vfe[i].y:=vy2[i];
    end;
   setfillstyle(1,red);
   drawpoly(18,vfe);
   fillpoly(18,vfe);
 end;
procedure fvekr1;         { процедура закраски задней грани буквы В}
 begin
   for i:=1 to 18 do
    begin
     vfe1[i].x:=vx2[i+18];
     vfe1[i].y:=vy2[i+18];
    end;
   setfillstyle(1,red);
   drawpoly(18,vfe1);
   fillpoly(18,vfe1);
 end;
 
procedure risM;       { рисуем саму букву М на плоскости }
  begin
  Mekr;
   for i:=2 to m do
     begin
      line(mx2[i-1],my2[i-1],mx2[i],my2[i]);
     end;
   for i:=1 to 12 do
     begin
     line(mx2[i],my2[i],mx2[i+13],my2[i+13]);
     end;
  end;
 
procedure risD;       { рисуем  Д на плоскости }
 begin
  Dekr;
  for i:=2 to d do
    if (i <> 14) and (i<>18) and (i<>31) then  line(dx2[i-1],dy2[i-1],dx2[i],dy2[i]);
  for i := 1 to 14 do
    line(dx2[i],dy2[i],dx2[i+17],dy2[i+17]);
 end;
 
procedure  risV;      { рисуем В на плоскости}
 begin
   Vekr;
   for i:=2 to v do
     begin
      if (i<>9) and (i<>14) and (i<>19) and (i<>27) and (i<>32) then line(vx2[i-1],vy2[i-1],vx2[i],vy2[i]);
     end;
   for i:=1 to 14 do
    line(vx2[i],vy2[i],vx2[i+18],vy2[i+18]);
 end;
 
 
begin
  GraphDriver :=  9;
   GraphMode := 1;
  InitGraph(GraphDriver, GraphMode,'');
  GraphError := GraphResult;
  if GraphError <> grOk then begin
    writeln ('osibka pri inizializazii graph');
    writeln(GraphErrorMsg(GraphError));
     halt(1);
    end;
    setbkcolor(15);
    setcolor(1);
 
    assign(f,'c:\projects\graphika\lab3\m.txt');    { Считываем координаты М}
    reset(f);
    for i:=1 to m do
     begin
      readln(f,mx[i],my[i],mz[i]);
      mx1[i]:=mx[i]; my1[i]:=my[i]; mz1[i]:=mz[i];
 
     end;
 
 
 
    assign(f,'c:\projects\graphika\lab3\d.txt');            { Считываем координаты Д}
    reset(f);
    for i:=1 to d do
     begin
      readln(f,dx[i],dy[i],dz[i]);
      dx1[i]:=dx[i]; dy1[i]:=dy[i]; dz1[i]:=dz[i];
     end;
 
    assign(f,'c:\projects\graphika\lab3\v.txt');        { Считываем координаты В}
    reset(f);
    for i:=1 to v do
     begin
      readln(f,vx[i],vy[i],vz[i]);
      vx1[i]:=vx[i]; vy1[i]:=vy[i]; vz1[i]:=vz[i];
     end;
 
 
      risM;   fmekr; fmekr1;           { рисуем первоначально буквы}
      risD;   fdekr; fdekr1;
      risV;   fvekr; fvekr1;
 
 
    outtext('press enter key');
    readln;
 
 
 
 for j:=1 to 72 do
  begin
 
   {            PERVI'I POVOROT             }
 
{ для улучшения визуального восприятия используем 2-х страничный режим экрана}
 
{первый поворот осуществляется вокруг оси Z}
 
 
  SetActivePage(j);  
   cleardevice;
 
   for i:=1 to m do
    begin
     mx1[i]:=round(mx[i]*cos(-5*j*pi/180)+my[i]*sin(-5*j*pi/180));
     my1[i]:=round(-mx[i]*sin(-5*j*pi/180)+my[i]*cos(-5*j*pi/180));
     mz1[i]:=mz[i]*1;
    end;
 
   for i:=1 to d do
    begin
     dx1[i]:=round(dx[i]*cos(-5*j*pi/180)+dy[i]*sin(-5*j*pi/180));
     dy1[i]:=round(-dx[i]*sin(-5*j*pi/180)+dy[i]*cos(-5*j*pi/180));
     dz1[i]:=dz[i]*1;
    end;
 
    for i:=1 to v do
    begin
     vx1[i]:=round(vx[i]*cos(-5*j*pi/180)+vy[i]*sin(-5*j*pi/180));
     vy1[i]:=round(-vx[i]*sin(-5*j*pi/180)+vy[i]*cos(-5*j*pi/180));
     vz1[i]:=vz[i]*1;
    end;
 
 
 
    risM;  risD;  risV;
    fmekr; fmekr1;
    fdekr; fdekr1;
    fvekr; fvekr1;
 
 
  SetVisualPage(j);
  delay(2500);
 
  end;
 
 
for j:=1 to 72 do
 begin
 
 {           VTOROI POVOROT               }
 
{второй поворот осуществляется вокруг оси Y}
 
  SetActivePage(j);
 cleardevice;
 
   for i:=1 to m do
    begin
     mx1[i]:=round(mx[i]*cos(5*j*pi/180)+mz[i]*sin(5*j*pi/180));
     my1[i]:=my[i]*1;
     mz1[i]:=round(-mx[i]*sin(5*j*pi/180)+mz[i]*cos(5*j*pi/180));
    end;
 
    for i:=1 to d do
    begin
     dx1[i]:=round(dx[i]*cos(5*j*pi/180)+dz[i]*sin(5*j*pi/180));
     dy1[i]:=dy[i]*1;
     dz1[i]:=round(-dx[i]*sin(5*j*pi/180)+dz[i]*cos(5*j*pi/180));
    end;
 
    for i:=1 to v do
    begin
     vx1[i]:=round(vx[i]*cos(5*j*pi/180)+vz[i]*sin(5*j*pi/180));
     vy1[i]:=vy[i]*1;
     vz1[i]:=round(-vx[i]*sin(5*j*pi/180)+vz[i]*cos(5*j*pi/180));
    end;
 
 
    risM;  risD;  risV;
    fmekr; fmekr1;
    fdekr; fdekr1;
    fvekr; fvekr1;
 
 
 SetVisualPage(j);
 delay(2500);
 end;
 
 
 for j:=1 to 72 do
  begin
 
  {          TRETII POVOROT             }
 
{третий поворот осуществляется вокруг оси X}
 
   SetActivePage(j);
   cleardevice;
 
   for i:=1 to m do
    begin
     mx1[i]:=mx[i]*1;
     my1[i]:=round(my[i]*cos(5*j*pi/180)+mz[i]*sin(5*j*pi/180));
     mz1[i]:=round(-my[i]*sin(5*j*pi/180)+mz[i]*cos(5*j*pi/180));
    end;
 
    for i:=1 to d do
    begin
     dx1[i]:=dx[i]*1;
     dy1[i]:=round(dy[i]*cos(5*j*pi/180)+dz[i]*sin(5*j*pi/180));
     dz1[i]:=round(-dy[i]*sin(5*j*pi/180)+dz[i]*cos(5*j*pi/180));
    end;
 
    for i:=1 to v do
    begin
     vx1[i]:=vx[i]*1;
     vy1[i]:=round(vy[i]*cos(5*j*pi/180)+vz[i]*sin(5*j*pi/180));
     vz1[i]:=round(-vy[i]*sin(5*j*pi/180)+vz[i]*cos(5*j*pi/180));
    end;
 
 
    risM;  risD;  risV;
    fmekr; fmekr1;
    fdekr; fdekr1;
    fvekr; fvekr1;
 
 
   SetVisualPage(j);
   delay(2500);
  end;
 
 
    readln;
    closegraph;
end.
0
Puporev
Модератор
54384 / 41966 / 28987
Регистрация: 18.05.2008
Сообщений: 98,859
15.01.2010, 08:23 #31
График функции с имитацией курсора, положение которого показывает значение функции в данной точке.
Предложено форумчанином Inside.
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
program lr_19;
uses crt,graph;
type fun=function(x:real):real;
var gd,gm:integer;
{$f+}
function f(x:real):real;
begin
f:=0.25*x*sqr(x)+x-1.2502
end;
{$f-}
procedure Graffun(xn,xk,ok:real;xa,ya,xb,yb:integer;f:fun);
var y,x,hx,hx1,ymin,ymax,mx,my,yy,sx,sy:real;
    i,x1,y1,x2,y2,hy:integer;
    st:string;
procedure maxmin;
begin
x:=xn;
ymax:=-1e30;
ymin:=1e30;
while x<=xk do
      begin
      y:=f(x);
      if y>ymax then ymax:=y;
      if y<ymin then ymin:=y;
      x:=x+hx1
      end;
ymax:=round(ymax/ok+0.4999)*ok;
ymin:=round(ymin/ok-0.5)*ok;
end;
procedure graf;
begin
setlinestyle(0,0,3);
x:=xn;
setcolor(4);
x1:=round(mx*x+sx);
y1:=round(-my*f(x)+sy);
while x<=xk-hx1 do
 begin
  x:=x+hx1;
  x2:=round(mx*x+sx);
  y2:=round(-my*f(x)+sy);
  line(x1,y1,x2,y2);
  x1:=x2;
  y1:=y2
 end
end;
begin
hx1:=(xk-xn)/200;
maxmin;
hx:=(xk-xn)/10;
hy:=(yb-ya) div 8;
mx:=(xb-xa)/(xk-xn);
my:=(yb-ya)/(ymax-ymin);
sy:=ya+my*ymax;
sx:=xa-mx*xn;
setfillstyle(1,7);
bar(xa,ya,xb,yb);
setlinestyle(0,0,1);
settextjustify(1,2);
settextstyle(0,0,1);
x:=xn;
i:=round(mx*x+sx);
while i<=xb+1 do
 begin
  setcolor(15);
  line(i,ya,i,yb);
  setcolor(14);
  str(x:4:2,st);
  outtextxy(i,yb+3,st);
  x:=x+hx;
  i:=round(mx*x+sx)
 end;
settextjustify(2,1);
i:=yb;
while i>=ya do
 begin
  setcolor(15);
  line(xa,i,xb,i);
  yy:=(sy-i)/my;
  setcolor(14);
  str(yy:4:2,st);
  outtextxy(xa-3,i,st);
  i:=i-hy
 end;
graf;
end;
procedure Kurcorx(xn,xk,ok:real;xa,ya,xb,yb:integer;f:fun);
var my,sy,ymin,ymax,x,mx,sx,y,hx,hx1:real;
    i,y1,i1,hi:integer;
    st:string;
    ch:char;
procedure maxmin;
begin
x:=xn;
ymax:=-1e30;
ymin:=1e30;
while x<=xk do
  begin
   y:=f(x);
   if y>ymax then ymax:=y;
   if y<ymin then ymin:=y;
   x:=x+hx1
 end;
ymax:=round(ymax/ok+0.4999)*ok;
ymin:=round(ymin/ok-0.5)*ok;
end;
procedure out;
begin
setcolor(11); setlinestyle(0,0,3);
hx1:=(xk-xn)/200;
maxmin;
x:=(i-sx)/mx;
my:=(yb-ya)/(ymax-ymin);
sy:=ya+my*ymax;
y1:=round(-my*f(x)+sy);
line(i,y1,i,y1+10);
line(i,y1,i-3,y1+5);
line(i,y1,i+3,y1+5)
end;
procedure quit;
begin
setfillstyle(1,1);
bar(xb+15,yb-55,xb+86,yb-43);
setcolor(15);
settextjustify(0,0);
outtextxy(xb+18,yb-45,'QUIT-ESC');
end;
begin
mx:=(xb-xa)/(xk-xn);
sx:=xa-mx*xn;
hi:=4;i:=xa;i1:=yb;
quit;
setwritemode(xorput);
out;
while true do
 begin
  ch:=readkey; if ch=#27 then exit;
  if ch=#0 then
   begin
    ch:=readkey;
    case ch of
    #75:begin
        out;
        i:=i-hi;
        {i1:=i1+hi;}
        if i<xa then i:=xa;
        {if i1>yb then i1:=yb;}
        out
        end;
    #77:begin
        out;
        i:=i+hi;
        {i1:=i1-hi;}
        if i>xb then i:=xb;
        {if i1<ya then i1:=ya;}
        out
        end;
    #71:begin
        out;
        i:=xa;
        out
        end;
    #79:begin
        out;
        i:=xb;
        out
        end;
    end;
x:=(i-sx)/mx;
y:=f(x);
setviewport(xb+15,yb-30,getmaxx,yb,false);
setcolor(14);
clearviewport;
str(x:4:2,st);
outtextxy(4,12,'X='+st);
str(y:5:2,st);
outtextxy(4,27,'F='+st);
setviewport(0,0,getmaxx,getmaxy,true);
end
end
end;
begin
gd:=detect;
initgraph(gd,gm,'');
setbkcolor(9);
Graffun(1.5,6.5,0.5,60,8,getmaxx-90,getmaxy-23,f);
Kurcorx(1.5,6.5,0.5,60,8,getmaxx-90,getmaxy-23,f);
closegraph;
end.
0
ЛоРД_Оледжан
Программист
56 / 54 / 15
Регистрация: 23.07.2009
Сообщений: 336
31.01.2010, 15:25 #32
Эта программа демонстрирует 3Д вращение каркаса куба по различным осям
Скорость вращения зависит от "кривости" модуля CRT
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
Program Kub;
Uses Graph,Crt;
Type
    mas=array[1..8] of real;
Var
   ro,teta,phi,d,rebro:real;
   xk,yk,zk:mas;
   xv,yv,zv:mas;
   V:array [1..4,1..4] of real;
   i,GrDrive,GrMode:integer;
   minx,miny,maxx,maxy,fx,fy,f,c1,c2:real;
   t,f1,wx1,wy1,wx2,wy2:integer;
   q:char;
Function mult(x,y,z:real; n:integer):real;
Begin
 xv[n]:=x*v[1,1]+y*v[2,1]+z*v[3,1]+v[4,1];
 yv[n]:=x*v[1,2]+y*v[2,2]+z*v[3,2]+v[4,2];
 zv[n]:=x*v[1,3]+y*v[2,3]+z*v[3,3]+v[4,3];
End;
Begin
 GrDrive:=Detect;
 InitGraph(GrDrive,GrMode,'');
 t:=0;
 f1:=0;
 d:=1400;
 Repeat
  SetColor(0);
  line(round(xv[1]),round(yv[1]),round(xv[2]),round(yv[2]));
  line(round(xv[2]),round(yv[2]),round(xv[3]),round(yv[3]));
  line(round(xv[3]),round(yv[3]),round(xv[4]),round(yv[4]));
  line(round(xv[4]),round(yv[4]),round(xv[1]),round(yv[1]));
  line(round(xv[5]),round(yv[5]),round(xv[6]),round(yv[6]));
  line(round(xv[6]),round(yv[6]),round(xv[7]),round(yv[7]));
  line(round(xv[7]),round(yv[7]),round(xv[8]),round(yv[8]));
  line(round(xv[8]),round(yv[8]),round(xv[5]),round(yv[5]));
  line(round(xv[1]),round(yv[1]),round(xv[5]),round(yv[5]));
  line(round(xv[2]),round(yv[2]),round(xv[6]),round(yv[6]));
  line(round(xv[3]),round(yv[3]),round(xv[7]),round(yv[7]));
  line(round(xv[4]),round(yv[4]),round(xv[8]),round(yv[8]));
  rebro:=100;
  ro:=1360;
  t:=t+1;
  f1:=f1+1;
  if t=90 then t:=0;
  if f1=90 then f1:=0;
  teta:=t*pi/180;
  phi:=f1*pi/180;
  xk[1]:=rebro;    yk[1]:=-rebro;   zk[1]:=-rebro;
  xk[2]:=rebro;    yk[2]:=rebro;    zk[2]:=-rebro;
  xk[3]:=-rebro;   yk[3]:=rebro;    zk[3]:=-rebro;
  xk[4]:=-rebro;   yk[4]:=-rebro;   zk[4]:=-rebro;
  xk[5]:=rebro;    yk[5]:=-rebro;   zk[5]:=rebro;
  xk[6]:=rebro;    yk[6]:=rebro;    zk[6]:=rebro;
  xk[7]:=-rebro;   yk[7]:=rebro;    zk[7]:=rebro;
  xk[8]:=-rebro;   yk[8]:=-rebro;   zk[8]:=rebro;
 
  v[1,1]:=-sin(teta); v[1,2]:=-cos(phi)*cos(teta); v[1,3]:=-sin(phi)*cos(teta);
  v[2,1]:=cos(teta);  v[2,2]:=-cos(phi)*sin(teta); v[2,3]:=-sin(phi)*sin(teta);
  v[3,1]:=0;          v[3,2]:=sin(phi);            v[3,3]:=-cos(phi);
  v[4,1]:=0;          v[4,2]:=0;                   v[4,3]:=ro;
 
  for i:=1 to 8 do
   begin
    mult(xk[i],yk[i],zk[i],i);
    xv[i]:=d*xv[i]/zv[i];
    yv[i]:=d*yv[i]/zv[i];
  end;
  SetViewPort(250,200,350,300,false);
  SetColor(10);
  line(round(xv[1]),round(yv[1]),round(xv[2]),round(yv[2]));
  line(round(xv[2]),round(yv[2]),round(xv[3]),round(yv[3]));
  line(round(xv[3]),round(yv[3]),round(xv[4]),round(yv[4]));
  line(round(xv[4]),round(yv[4]),round(xv[1]),round(yv[1]));
  line(round(xv[5]),round(yv[5]),round(xv[6]),round(yv[6]));
  line(round(xv[6]),round(yv[6]),round(xv[7]),round(yv[7]));
  line(round(xv[7]),round(yv[7]),round(xv[8]),round(yv[8]));
  line(round(xv[8]),round(yv[8]),round(xv[5]),round(yv[5]));
  line(round(xv[1]),round(yv[1]),round(xv[5]),round(yv[5]));
  line(round(xv[2]),round(yv[2]),round(xv[6]),round(yv[6]));
  line(round(xv[3]),round(yv[3]),round(xv[7]),round(yv[7]));
  line(round(xv[4]),round(yv[4]),round(xv[8]),round(yv[8]));
  delay(1000);
 Until KeyPressed;
 CloseGraph;
End.
Добавлено через 4 часа 40 минут
Алгоритм вращения 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
uses Graph, Crt;
 
procedure DrawCube;
label
  nextj;
type
  cube=array[1..8] of record x,y,z:integer end;
 
{verts-koordinatu (x,y,z) vershin figyru}
const
 verts:cube=(
 (x: 1; y: 1; z: 1),  {1-a vershina}
 (x: 1; y: 1; z:-1),  {2}
 (x: 1; y:-1; z: 1),  {3}
 (x: 1; y:-1; z:-1),  {4}
 (x:-1; y: 1; z: 1),  {5}
 (x:-1; y: 1; z:-1),  {6}
 (x:-1; y:-1; z: 1),  {7}
 (x:-1; y:-1; z:-1)); {8}
 
 {g- eto opisanie iz kakih vershin v sostoiat grani
     (v massive legat nomera tochec v nymeracii verts) }
 g:array[1..6, 1..4] of shortint=
 ((1,2,4,3),
  (1,2,6,5),
  (1,3,7,5),
  (3,4,8,7),
  (2,4,8,6),
  (5,6,8,7));
 
 
var
  Alfa,Beta,Gamma, {proekcii edinichnogo vectora povorota (ego dlina=1)}
  Teta,            {ygol povorota tochek prostranstva}
  DT:real;         {pribavka ygla Teta}
  c:cube;          {massiv dlia koordinat vrashaemuh vershin}
 
 procedure Rotate(var x,y,z:integer);
 {povorot tochki vokrug edinichnogo vektora (Alfa, Beta, Gamma) na ygol Teta}
 var
   cosT, sinT, One_cosT, AOne_cosT, BOne_cosT,GsinT:real;
   xn,yn,zn:integer;
 begin
   {eto slognoe preobrathovanie vziato iz spravochnika po stereometrii}
   cosT:=cos(Teta);
   sinT:=sin(Teta);
   One_cosT :=1.0-cosT;
   AOne_cosT:=Alfa*One_cosT;
   BOne_cosT:=Beta*One_cosT;
   GsinT:=Gamma*sinT;
 
   xn:=trunc(
      x*( cosT      + Alfa  * AOne_cosT)+
      y*( GsinT     + Beta  * AOne_cosT)+
      z*(-Beta*sinT + Gamma * AOne_cosT));
 
   yn:=trunc(
      x*(-GSinT     + Beta  * AOne_cosT)+
      y*( cosT      + Beta  * BOne_cosT)+
      z*( Alfa*sinT + Gamma * BOne_cosT));
 
   zn:=trunc(
      x*( Beta*sinT + Gamma * AOne_cosT)+
      y*(-alfa*sinT + Gamma * BOne_cosT)+
      z*( cosT      + Gamma*Gamma*One_cosT));
 
   x:=xn; y:=yn; z:=zn;
 end;
 
 function minz:integer;
 {nahogdenie samoi "zadnei" tochki, t.e. s min Z}
 var j,m:integer;
 begin
   m:=1;
   for j:=2 to 8 do
     if c[j].z<c[m].z then m:=j;
   minz:=m;
 end;
 
 
var
  Pnts:array[1..5] of record {Byfer dlia risovania tochek grani cherez FillPoly}
    x,y:integer
  end;
  min:integer;      {nomer samoi "zadnei" tochki}
  x0,y0:integer;    {centr izobrajenia}
  a: integer;       {Koef. yvelichenia izobrajenia}
 
  i,j,k:integer;    {Parametru ciklov}
  page:word;
 
begin
 page:=0;
 x0:=120;
 y0:=100;
 
 a:=40;
 Alfa:=0.6;
 Beta:=0.7;
 Gamma:=sqrt(1.0-Alfa*Alfa-Beta*Beta); {3-mernaia teorema Pifagora}
 Teta:=0;
 DT:=2*Pi/100;{2.0*Pi/20;}
 
 {Masshtabiryem i povorachivaem vse vershinu na ygol Teta}
 for i:=1 to 8 do
  begin
   c[i].x:=verts[i].x*a;
   c[i].y:=verts[i].y*a;
   c[i].z:=verts[i].z*a;
   Rotate(c[i].x,c[i].y,c[i].z)
  end;
 min:=MinZ; {Nahodim samyi zadniy vershiny}
 SetVisualPage((Page+1)mod 2);
 
 for k:=0 to 2500 do
  begin
    SetActivePage(page); {delaem aktivnoi nevidimyiy stranicy}
 
 
    for j:=1 to 6 do
      begin
        {propysk nevidimoi grani iz samoiy "zadnei" tockoi}
        for i:=1 to 4 do if min=g[j,i] then goto nextj; {goto neobhodim!}
        {prohodim po vershinam grani}
        for i:=1 to 4 do
          begin
           {Berem proekciy vershinu na ploskosti xoy  }
           Pnts[i].x:=x0+c[g[j,i]].x;
           Pnts[i].y:=y0+trunc(0.775*c[g[j,i]].y) {0.775- k-t sgatia EGA HI}
          end;
        SetFillStyle(SolidFill, word(j+8)); {Kagdoi grani svoia zakraska}
        {Pnts[5]:=Pnts[1];}    {eto nygno pri DrawPoly}
        FillPoly(4,Pnts);
        nextJ:
      end;
 
    SetVisualPage(Page);       {pokazivaem risynok: delaem vidimoi stranicy}
    SetActivePage((Page+1)mod 2); {delaem aktivnoi nevid. str. dlia Bar}
 
    {Povorachivaem vershinu}
    for i:=1 to 8 do
      begin
        c[i].x:=verts[i].x*a;
        c[i].y:=verts[i].y*a;
        c[i].z:=verts[i].z*a;
        Rotate(c[i].x,c[i].y,c[i].z)
      end;
    min:=MinZ;
 
    SetFillStyle(SolidFill, Black);
    Bar(0,0,x0*2,y0*2);           {stiraem staroe izobragenie na nevid. str.}
    Teta:=Teta+DT;                {yvelichivaem ygol povorota}
    Page:=(Page+1)mod 2;          {meniaem stranicy (0->1; 1->0) }
    if KeyPressed then
    exit;
  end;
end;
 
 
var drv,mode:integer;
begin
  drv:=EGA;
  mode:=EGAHI;
  InitGraph(drv,mode,'C:\compilat\tp\bgi');
  DrawCube;
  CloseGraph;
end.
0
MicM
824 / 483 / 324
Регистрация: 29.12.2009
Сообщений: 1,106
Завершенные тесты: 1
14.02.2010, 08:50 #33
Белый прямоугольник движущийся под управлением стрелок, выход по нажатии клавиши Esc.
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
uses crt,graph;
var
gd,gm,x,y,dx,dy:integer;
ch:char;
procedure dvizhenie(dx,dy:integer);
begin
setfillstyle (1,black);
bar (x,y,x+100,y+10);
x:=x+dx;
y:=y+dy;
setfillstyle (1,white);
bar (x,y,x+100,y+10);
end;
begin
gd:=detect;
initgraph (gd,gm,'bgi');
x:=270;y:=240;
bar (x,y,x+100,y+10);
repeat
ch:=readkey;
if ch=#0 then begin
ch:=readkey;
case ch of
#80:dvizhenie(0,5);
#72:dvizhenie (0,-5);
#77:dvizhenie (5,0);
#75:dvizhenie (-5,0);
end;
end;
until ch=#27;
end.
1
WolfCF
25.02.2010, 07:49
  #34

Не по теме:

так вот же идентичный рисунок http://www.cyberforum.ru/pascal/thread56317.html#post309305

0
Puporev
Модератор
54384 / 41966 / 28987
Регистрация: 18.05.2008
Сообщений: 98,859
25.02.2010, 07:58 #35
Да уж, кто-то у кого-то скопипастил. Поскольку Давид был первым, сообщение yura`, удаляю.
0
yura`
11 / 8 / 0
Регистрация: 09.02.2010
Сообщений: 107
17.03.2010, 16:26 #36
Дельфин: с размерами сетки изменяется и размер самого дельфина:


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 a,b:array [1..100] of PointType;
i,j,x,y,gd,gm,k:integer;
begin
clrscr;
write('Vvedite rozmer setki: ');
readln(x); y:=x;
gd:=Detect;
InitGraph(gd,gm,'');
i:=0; j:=0;
SetBkColor(15);
SetPalette(5,0);
SetColor(5);
while i<=x*30 do begin
Line(0+i,0,0+i,y*20);
i:=i+x;
end;
while j<=y*20 do begin
Line(0,0+j,x*30,0+j);
j:=j+y;
end;
i:=1;
a[i].x:=x*29; a[i].y:=y*11; inc(i);
a[i].x:=x*29; a[i].y:=y*12; inc(i);
a[i].x:=x*28; a[i].y:=y*13; inc(i);
a[i].x:=x*24; a[i].y:=y*13; inc(i);
a[i].x:=x*20; a[i].y:=y*14; inc(i);
a[i].x:=x*18; a[i].y:=y*17; inc(i);
a[i].x:=x*17; a[i].y:=y*17; inc(i);
a[i].x:=x*17; a[i].y:=y*14; inc(i);
a[i].x:=x*13; a[i].y:=y*14; inc(i);
a[i].x:=x*5; a[i].y:=y*11; inc(i);
a[i].x:=x*3; a[i].y:=y*14; inc(i);
a[i].x:=x*2; a[i].y:=y*14; inc(i);
a[i].x:=x*2; a[i].y:=y*11; inc(i);
a[i].x:=x*3; a[i].y:=y*10; inc(i);
a[i].x:=x*2; a[i].y:=y*9; inc(i);
a[i].x:=x*2; a[i].y:=y*4; inc(i);
a[i].x:=x*3; a[i].y:=y*4; inc(i);
a[i].x:=x*5; a[i].y:=y*9; inc(i);
a[i].x:=x*13; a[i].y:=y*6; inc(i);
a[i].x:=x*13; a[i].y:=y*3; inc(i);
a[i].x:=x*14; a[i].y:=y*3; inc(i);
a[i].x:=x*17; a[i].y:=y*6; inc(i);
a[i].x:=x*22; a[i].y:=y*7; inc(i);
a[i].x:=x*24; a[i].y:=y*8; inc(i);
a[i].x:=x*25; a[i].y:=y*10; inc(i);
a[i].x:=x*29; a[i].y:=y*11; inc(i);
k:=i;
i:=1;
b[i].x:=x*22; b[i].y:=y*9; inc(i);
b[i].x:=x*22; b[i].y:=y*10; inc(i);
b[i].x:=x*23; b[i].y:=y*10; inc(i);
b[i].x:=x*22; b[i].y:=y*9; inc(i);
SetColor(5);
SetLineStyle(0,1,3);
DrawPoly(k,a);
DrawPoly(i,b);
ReadKey;
end.
0
Quatroom
3 / 3 / 0
Регистрация: 12.10.2009
Сообщений: 47
17.03.2010, 18:03 #37
Вот божья коровка:
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
program gra;
uses crt,Graph;
var
Gd, Gm: Integer;
x, y: real;
px,pa,py,i,q,a,t:integer;
begin
     clrscr;
     Gd := Detect;
     InitGraph(Gd, Gm, '');
     ellipse(100,90, 0, 360, 40, 60);
     circle(100,145,20);
     line(141,90,156,90);
     line(156,90,171,95);
     line(135,60,150,60);
     line(150,60,171,65);
     line(135,120,150,120);
     line(150,120,171,125);
     line(60,90,35,90);
     line(35,90,20,95);
     line(41,60,65,60);
     line(41,60,25,65);
     line(65,120,40,120);
     line(40,120,25,125);
     circle(80,100,5);
     circle(80,120,5);
     circle(90,90,5);
     circle(80,70,5);
     circle(110,70,5);
     circle(100,50,5);
     circle(120,100,5);
     circle(120,80,5);
     circle(90,155,2);
     circle(110,155,2);
     readln ;
     closegraph;
end.
0
yura`
11 / 8 / 0
Регистрация: 09.02.2010
Сообщений: 107
17.03.2010, 18:04 #38
Красивая красная розочка:


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
Uses Graph,MyGraph,Crt;
Var i,x,y,j,x0,y0:integer;
f,df:real;
a,b: array[1..30] of Pointtype;
Const r=150; n=6;
 
begin
Init;
j:=1;
f:=0;
x0:=GetMaxX div 2;
y0:=GetMaxY div 2;
SetColor(4);
df:=2*Pi/n;
For i:=1 to n+1 do
begin{2}
x:=x0+Round(r*cos(f));
y:=y0-Round(r*sin(f));
a[i].x:=x; a[i].y:=y;
f:=f+df;
end{2};
Circle(x0,y0,r);
Arc(a[1].x,a[1].y,a[1].x+11,a[1].x+120+11,r);
Arc(a[2].x,a[2].y,a[2].x+120+26,a[2].x+240+26,r);
Arc(a[3].x,a[3].y,a[3].x+360-4,a[3].x+480-4,r);
Arc(a[4].x,a[4].y,a[4].x+840+11,a[4].x+960+11,r);
Arc(a[5].x,a[5].y,a[5].x+480-4,a[5].x+600-4,r);
Arc(a[6].x,a[6].y,a[6].x+26,a[6].x+120+26,r);
Readln;
CloseGraph;
end.
0
ateccc
0 / 0 / 0
Регистрация: 30.01.2010
Сообщений: 10
27.03.2010, 11:00 #39
Есть собственная разработка лабораторной работы по физике на паскале с имитацией процесса с помощью графики. Если интересно могу кинуть... правда она без коментов.
0
Puporev
Модератор
54384 / 41966 / 28987
Регистрация: 18.05.2008
Сообщений: 98,859
27.03.2010, 11:21 #40
ateccc, Давай показывай, комментарии не обязательно, просто в начале напиши подробное условие задачи.
1
27.03.2010, 11:21
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
27.03.2010, 11:21

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

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

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


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

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

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