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

Turbo Pascal

Войти
Регистрация
Восстановить пароль
 
 
Рейтинг: Рейтинг темы: голосов - 1, средняя оценка - 5.00
ЛоРД_Оледжан
Программист
56 / 54 / 7
Регистрация: 23.07.2009
Сообщений: 336
02.11.2009, 18:06 #16
Программа рисует прямоугольную спираль с начальным значением длины первых двух сторон 10 пикселей и конечными 320 с центром посередине экрана. Каждую следующею пару сторон повышать на 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
program spiral;
uses graph;
const
koef=1.1; {коефициент возростания сторон}
pochatok=10;
kinec=320;
var
driver,mode:integer;
procedure Myspiral(storona:integer);
begin
if storona<=kinec then
begin
storona:=-storona; {смена направления рисования}
linerel(0,storona);    {вверх или вниз}
linerel(storona,0);    {влево или вправо}
Myspiral(round(koef*storona))
end
end;
begin
driver:=detect;
initgraph(driver,mode,' ');
setbkcolor(1);
setcolor(1);
linerel(300,240);
setcolor(15);
Myspiral(pochatok);
readln;
end.
0
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
02.11.2009, 18:06
Здравствуйте! Я подобрал для вас темы с ответами на вопрос Графика в Турбо Паскаль (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
ЛоРД_Оледжан
Программист
56 / 54 / 7
Регистрация: 23.07.2009
Сообщений: 336
03.11.2009, 10:07 #17
Программа имитирует движение луны по звездному небе. Когда изображение луны достигает края экрана, направление ее движения изменяется.
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
program LoRD;
uses crt,graph;
var dr,m:integer;             {графический драйвер и режим}
x,y,                          {координаты обьекта во время движения}
dx,dy:integer;                {прирост координат}
ptr:pointer;                  {указатель на область памяти
                               где сохраняется изображение}
size:integer;                 {размер памяти}
leftX, leftY,                 {координаты левого верхнего}
rightX,rightY:integer;        {правого нижнего углов прямоугольника, в
                              который вписано изображение}
i:integer;                    {параметр цикла}
{*************изображение звездного неба******************************}
procedure Sky;
begin
randomize;                    {инициализация генератора случайных чисел}
SetBkColor(i);                {цвет фона}
SetColor(14);                 {цвет звезд}
for i:=1 to 200 do            {изображение звезд}
Circle(random(640),random(480),1);
end;
{*****************изображение луны**************************************}
procedure Moon;
begin
SetColor(14);
Arc(450,100,270,90,50);
Arc(390,100,320,40,80);
SetFillStyle(1,14);
floodFill(480,100,14);
end;
{******************сохранение изображения в динамической памяти**********}
procedure SaveClip;
begin
leftX:=445;                   {координаты прямоугольника}
leftY:=45;                    {в который вписана луна}
rightX:=505;
rightY:=155;
size:=imagesize(leftX, leftY, rightX, rightY);   {выдиление памяти}
getmem(ptr,size);
getimage(leftX,leftY,rightX,rightY,ptr^);    {сохраняем изображение в памяти}
putimage(leftX,leftY,ptr^,xorput);           {спрятать изображение}
end;
{**************************движение луны**********************************}
procedure Move;
begin
x:=leftX; y:=leftY;           {стартовые координаты}
dx:=10; dy:=10;               {прирост координат}
repeat                        {сдвигизображения}
x:=x+dx;                      {смена координат луны}
y:=y+dy;
putimage(X,Y,ptr^,xorput);    {изобразить фигуру в новых координатах}
delay(2000);                  {задержка движения}
putimage(X,Y,ptr^,xorput);    {спрятать фигуру в старых координатах}
if (x>640) or (x<0)           {если фигура приблизилась к краю экрана}
then dx:=-dx                  {сменить ее направление}
else
if(y<0) or (y>480) then dy:=-dy;
until keypressed;
end;
{*********************основная программа***********************************}
BEGIN
dr:=Detect;
InitGraph(dr,m,'');
Sky;
Moon;
SaveClip;
Move;
readkey;
end.
0
Давид
Программист 1С
853 / 641 / 80
Регистрация: 03.03.2009
Сообщений: 1,152
04.11.2009, 22:19 #18
Если вам сделали программу на построение графиков и вы хотите проверить правильна ли она, а так же подъискать для себя более оптимальное решение то этот сайт вам в помощь!
Графика на языке Паскаль с элементами
математики ---> http://graphinpas.narod.ru/

Так же хочу представить этот сайт "ГРАФИЧЕСКИЕ ВОЗМОЖНОСТИ ПАСКАЛЯ"
Смотрите -- есть абсолютно все!
По ссылке сайт другой направленности.
1
Ольга Куликова
0 / 0 / 0
Регистрация: 26.10.2009
Сообщений: 4
08.11.2009, 16:16 #19
А вот пример перевода из цветовой модели RGB в HSL.

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
Uses GraphABC,ABCObjects;
const n=800;
      nn=600;
      m=600;
 
type pixels=array[0..n-1,0..m-1] of longint;
 
var ARed: pixels;
    AGreen: pixels;
    ABlue: pixels;
    Parr: pixels;
    RAr,GAr,BAr, AH, ASS, AL: pixels;
    col: color;
    i, j, x, y, w, h: integer;
procedure RGBTOHSL(var w, hei: integer;AR, AG, AB: pixels; var AH, ASS, AL: pixels);
var R, G, B, H, S, L, Minimum, Maximum, delMax, delR, delG, delB: real;
begin
  for var i:=0 to w-1 do
    for var j:=0 to hei-1 do
    begin
      R := AR[i,j];   
      G := AG[i,j];
      B := AB[i,j];
  
      Minimum := min(min( R, G), B);
      Maximum := max(max( R, G), B);  
      delMax := Maximum - Minimum;         
   
      AL[i,j] := Round(( Maximum + Minimum ) / 2);
 
      if  delMax = 0 then      
      begin
        AH[i,j] := 0;                               
        ASS[i,j] := 0;
      end
      else    
      begin
         if ( AL[i,j] < 0.5 ) then
            ASS[i,j] := Round(delMax / ( Maximum + Minimum ))
         else
            ASS[i,j] := Round(delMax / ( 2 - Maximum - Minimum ));
 
         delR := ( ( ( Maximum - R ) / 6 ) + ( delMax / 2 ) ) / delMax;
         delG := ( ( ( Maximum - G ) / 6 ) + ( delMax / 2 ) ) / delMax;
         delB := ( ( ( Maximum - B ) / 6 ) + ( delMax / 2 ) ) / delMax;
 
         if  ( R = Maximum ) then
           AH[i,j] :=Round( delB - delG)
         else if ( G = Maximum ) then 
           AH[i,j] := Round(( 1 / 3 ) + delR - delB)
         else if ( B = Maximum ) then
           AH[i,j] := Round(( 2 / 3 ) + delG - delR);
 
         if ( AH[i,j] < 0 ) then
           AH[i,j] += 1;
         if ( AH[i,j] > 1 ) then
           AH[i,j] -= 1;
      end;
   //writeln(AH[i,j]);
   end;
end;
 
function HueToRGB( v1, v2, H: real):real;            
begin
      if ( H < 0 ) then
       H += 1;
      if ( H > 1 ) then
        H -= 1;
      if ( ( 6 * H ) < 1 )then
        Result:= ( v1 + ( v2 - v1 ) * 6 * H );
      if ( ( 2 * H ) < 1 ) then
        Result:= ( v2 );
      if ( ( 3 * H ) < 2 ) then
        Result:= ( v1 + ( v2 - v1 ) * ( ( 2 / 3 ) - H ) * 6 );
      Result:= ( v1 );
end;
 
 
procedure HSLTORGB(w, hei: integer; AH, ASS, AL: pixels; var AR, AG, AB: pixels);
var R, G, B, v2, v1: real;
begin
  for var i:=0 to w-1 do
    for var j:=0 to hei-1 do
    begin
      if ( ASS[i,j] = 0 ) then                      
      begin
       R := AL[i,j] * 255;                      
       G := AL[i,j] * 255;
       B := AL[i,j] * 255;
      end
      else
      begin
        if ( AL[i,j] < 0.5 ) then 
          v2 := AL[i,j] * ( 1 + ASS[i,j] )
        else      
          v2 := ( AL[i,j] + ASS[i,j] ) - ( ASS[i,j] * AL[i,j] );
 
        v1 := 2 * AL[i,j]- v2;
        
        R := 255 * HueToRGB( v1, v2, AH[i,j] + ( 1 / 3 ) );
        G := 255 * HueToRGB( v1, v2, AH[i,j] );
        B := 255 * HueToRGB( v1, v2, AH[i,j] - ( 1 / 3 ) );
        AR[i,j]:=Round(R);
        AG[i,j]:=Round(G);
        AB[i,j]:=Round(B);
      end; 
      //writeln(AR[i,j]);
    end;
end;
 
begin
 
//загружает картинку на экран
  var p:=new Picture('parhod.jpg');
  SetWindowSize(n,m);
  p.draw(0,0);
  
//загружает информацию в массив
  for i:=1 to WindowWidth-1 do
  begin
    for j:=1 to WindowHeight-1 do
    begin
      col:=GetPixel(i,j);
      ARed[i,j]:=col.R;
      AGreen[i,j]:=col.G;
      ABlue[i,j]:=col.B;
      //writeln(AREd[i,j]);
    end;
  end;
w:= WindowWidth;
  h:= WindowHeight;
RGBTOHSL(w, h, ARed, AGreen, ABlue, AH, ASS, AL);
HSLTORGB(w, h, AH, ASS, AL, ARed, AGreen, ABlue);
  
  for i:=1 to WindowWidth-1 do
  begin
    for j:=1 to WindowHeight-1 do
    begin
      SetPixel(i, j, RGB(ARed[i,j], AGreen[i,j], ABlue[i,j]));
    end;
  end;
  LockDrawing;
  UnlockDrawing;
end.
0
fescar
8 / 7 / 5
Регистрация: 17.10.2009
Сообщений: 105
08.11.2009, 22:21 #20
ббелый круг вписаный в черный квадрат)
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
uses crt,graph;
 
var
   x,y,d,r : word;
 
procedure GrInit;
var
  gD,gM,gE:integer;
begin
 
   gD:=detect;
   InitGraph(gD,gM,'');
   gE:=GraphResult;
 
   if gE<>grOk then begin
      writeln('Error = ', GraphErrorMsg(gE));
      halt(1);
   end;
end;
 
 
Begin
 
   GrInit;
 
   SetColor(Yellow);
 
   x:=GetMaxX div 2;
   y:=GetMaxY div 2;
 
   r:=50;
 
   d:=r-10;
 
 
 
   Circle(x, y, r);
 
   Rectangle(x-d,y-d,x+d,y+d);
 
   SetFillStyle(1,white);
 
   FloodFill(x,y,yellow);
 
   readln;
 
   CloseGraph;
End.
0
Давид
Программист 1С
853 / 641 / 80
Регистрация: 03.03.2009
Сообщений: 1,152
08.11.2009, 23:32 #21
Тем кто обращается с просьбами нарисовать более сложные рисунки (например в трехмерном пространстве) расскажу удобный способ рисования!
Пусть например нужно нарисовать следующий объект на Паскале.
0
Давид
Программист 1С
853 / 641 / 80
Регистрация: 03.03.2009
Сообщений: 1,152
08.11.2009, 23:35 #22
Конечно не всем удасться мысленно представить каждую линию в координатах на этом рисунке, и далеко не всем удасться перерисовать это на тетрадный лист!Поэтому можно сделать следующие действия:
1) Сохранить рисунок если он размещен на сайте или любом другом носителе.
2) Если есть возможность - распечатать изображение на формате А4, иначе открыть его в любом табличном или текстовом редакторе (word,exel).
3) В рамках рисунка начертить две оси кординат - с соответствующими координатами (расчертить клетки).
Линии которые не видно можно обвести.
Должно получиться примерно так!
0
Давид
Программист 1С
853 / 641 / 80
Регистрация: 03.03.2009
Сообщений: 1,152
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 / 7
Регистрация: 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
Модератор
53013 / 40824 / 14070
Регистрация: 18.05.2008
Сообщений: 94,965
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 / 13
Регистрация: 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 / 1349 / 47
Регистрация: 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 / 6
Регистрация: 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 / 6
Регистрация: 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
08.01.2010, 12:48
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
08.01.2010, 12:48
Привет! Вот еще темы с ответами:

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

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

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

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


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

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

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