Графика в Турбо Паскаль - Turbo Pascal - Страница 8

@Dj Programmer · 08.11.2013, 23:33

Студворк — интернет-сервис помощи студентам

Сообщение от ildwine

А теперь то же самое, но в циклах...

Спасибо, учту

@RAFISTAUR · 25.12.2013, 15:54

Вот программа графического Лохотрона:

@Svager · 12.05.2014, 02:25

Игра Расстановка 16 букв
собственного производства

dimabubyakin · 15.06.2014, 00:39

Ну что-то типа рисовалки, работает мышка)

Кликните здесь для просмотра всего текста

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
program GRAPHEDITOR;
uses graph,crt,dos;
 
procedure InitGraphMode;
var
   g,d:integer;
begin
     g:=detect;
     initgraph(g,d,'');
end;
 
procedure DrawArea;
var
   covers:array[1..4]of PointType;
begin
 
setbkcolor(14);
 
covers[1].x:=20;   covers[1].y:=20;
covers[2].x:=20;   covers[2].y:=460;
covers[3].x:=500;  covers[3].y:=460;
covers[4].x:=500;  covers[4].y:=20;
 
setcolor(8);
setfillstyle(1,15);
fillpoly(4,covers);
 
 
 
covers[1].x:=560;   covers[1].y:=30;
covers[2].x:=580;   covers[2].y:=30;
covers[3].x:=580;   covers[3].y:=50;
covers[4].x:=560;   covers[4].y:=50;
fillpoly(4,covers);
outtextxy(590,37,'WIDTH');
 
 
covers[1].x:=560;   covers[1].y:=70;
covers[2].x:=580;   covers[2].y:=70;
covers[3].x:=580;   covers[3].y:=90;
covers[4].x:=560;   covers[4].y:=90;
setfillstyle(3,8);
fillpoly(4,covers);
outtextxy(590,77,'FILL');
 
 
outtextxy(550,410,'COLOR');
 
 
covers[1].x:=520;   covers[1].y:=430;
covers[2].x:=540;   covers[2].y:=430;
covers[3].x:=540;   covers[3].y:=450;
covers[4].x:=520;   covers[4].y:=450;
setfillstyle(1,8);
fillpoly(4,covers);
 
 
 
covers[1].x:=560;   covers[1].y:=430;
covers[2].x:=580;   covers[2].y:=430;
covers[3].x:=580;   covers[3].y:=450;
covers[4].x:=560;   covers[4].y:=450;
setfillstyle(1,4);
fillpoly(4,covers);
 
 
 
covers[1].x:=600;   covers[1].y:=430;
covers[2].x:=620;   covers[2].y:=430;
covers[3].x:=620;   covers[3].y:=450;
covers[4].x:=600;   covers[4].y:=450;
setfillstyle(1,15);
fillpoly(4,covers);
 
end;
 
procedure ClearDrawArea;
var
   covers:array[1..4]of PointType;
begin
covers[1].x:=20;   covers[1].y:=20;
covers[2].x:=20;   covers[2].y:=460;
covers[3].x:=500;  covers[3].y:=460;
covers[4].x:=500;  covers[4].y:=20;
setcolor(8);
setfillstyle(1,15);
fillpoly(4,covers);
end;
 
procedure ShowCursor;
var
     r:registers;
begin
r.ax:=1;
intr($33,r);
end;
 
procedure HideCursor;
var
     r:registers;
begin
r.ax:=2;
intr($33,r);
end;
 
procedure M_GETXY(var x,y:integer);
var
     r:registers;
begin
r.ax:=3;
intr($33,r);
x:=r.cx;
y:=r.dx;
end;
 
function GetKeyDown:integer;
var
     r:registers;
begin 
r.ax:=3;
intr($33,r);
GetKeyDown:=r.bl;
end;
 
 
var
     x,y:integer;
     key:char;
     Color,Width:word;
     s:string;
     covers:array[1..4]of PointType;
begin
InitGraphMode;
DrawArea;
setbkcolor(0);
ShowCursor;
setbkcolor(14);
MoveTo(240,220);
setcolor(8);
width:=2;
repeat
     if keypressed then 
     begin 
          key:=readkey;
          if key=#27 then break;
     end;
if width<3  then width:=3;
if width>20 then width:=20;
M_GETXY(x,y);
setcolor(color);
 
if (x-width>20) and (x+width<500) and (y-width>20) and (y+width<460) 
then if GetKeyDown=1 then 
          begin
          HideCursor;
          setcolor(color);
          setfillstyle(1,color);
          FillEllipse(x,y,width,width);
          FillEllipse(x,y,width,width);
          FillEllipse(x,y,width,width);
          FillEllipse(x,y,width,width);
          FillEllipse(x,y,width,width);
          ShowCursor;
          end;
 
 
if (x>560) and (x<580) and (y>70) and (y<90)
then if GetKeyDown=1 then 
          begin
          covers[1].x:=20;   covers[1].y:=20;
          covers[2].x:=20;   covers[2].y:=460;
          covers[3].x:=500;  covers[3].y:=460;
          covers[4].x:=500;  covers[4].y:=20;
          setcolor(8);
          setfillstyle(1,color);
          fillpoly(4,covers);
          end;
 
if (x>560) and (x<580) and (y>30) and (y<50)
then if GetKeyDown=1 then inc(width) 
else if GetKeyDown=2 then dec(width);
          
 
if (x>520) and (x<540) and (y>430) and (y<450)
then if GetKeyDown=1 then Color:=8;
 
 
if (x>560) and (x<580) and (y>430) and (y<450)
then if GetKeyDown=1 then Color:=4;
 
 
if (x>600) and (x<620) and (y>430) and (y<450)
then if GetKeyDown=1 then Color:=15;
until 1<0;
Closegraph;
end.

@hoch · 28.09.2014, 11:16

Нарисовано 11 квадратов. Они расположены по спирали
Архимеда (сама спираль не нарисована). Размеры квадратов
по мере удаления от центра возрастают. Использована
рекурсивная процедура

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Uses Graph,Crt;
var
   x,y,z: integer;
   q: real;
   Driv:integer;
   Mode:integer;
   Pach:string;
 
procedure f(p:integer);
begin
   if p > 0 then
      begin
         x:= round(60*q*cos(q) + 300);
         y:= round(60*q*sin(q) + 200);
         q:= q + 0.4;
         Rectangle(x,y,x+z,y+z);
      end
   else exit;
   inc(z,4);
   dec(p);
   f(p);
end;
 
BEGIN
   Driv:=VGA;
   Mode:=VGAHi;
   Pach:='C:\tp\bgi';
   InitGraph (Driv,Mode,Pach);
   if GraphResult <> grOK then Halt (1);
   z:= 20;
   f(11);
   OutText('Press_Enter');
 
   readln;
   CloseGraph;
END.

@hoch · 29.09.2014, 12:19

Это анимация. В квадрат вписан треугольник.
Треугольник движется в квадрате так, что его
вершины принадлежат квадрату. Для выхода из
программы нажмите Enter.

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
uses Crt,Graph;
var
   x1,y1,x2,y2,x3,y3: integer;
 
procedure iniG;
var
   Driv,Mode:integer;
   Path:string;
begin
   Driv:= VGA;
   Mode:= VGAHi;
   Path:= 'C:\tp\bgi';
   InitGraph (Driv,Mode,Path);
   if GraphResult < 0 then Halt (1);
end;
 
procedure los(var x,y: integer);
begin
   if (y=90) and (x<470) then inc(x);
   if (y=90) and (x=470) then inc(y);
   if (y<390) and (x=470) then inc(y);
   if (y=390) and (x=470) then dec(x);
   if (y=390) and (x>170) then dec(x);
   if (y=390) and (x=170) then dec(y);
   if (y>90) and (x=170) then dec(y);
   if (y=90) and (x=170) then inc(x);
 
   SetColor(14);
   Rectangle(170,90,470,390);
   SetColor(15);
   line(x1,y1,x2,y2);
   line(x2,y2,x3,y3);
   line(x3,y3,x1,y1);
end;
 
BEGIN
   randomize;
   x1:= 320;
   y1:= 90;
   x2:= 170;
   y2:= 390;
   x3:= 470;
   y3:= 390;
 
   iniG;
 
   repeat
      los(x1,y1);
      los(x2,y2);
      los(x3,y3);
 
      delay(1);
 
      SetColor(0);
      los(x1,y1);
      los(x2,y2);
      los(x3,y3);
   until keyPressed;
END.

@hoch · 01.10.2014, 09:47

Ромб. Анимация.
Для выхода из программы нажмите Enter.

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
Uses Graph,Crt;
const ox = 320;
      oy = 240;
var
   a,b: integer;
   x1,x3,y2,y4: integer;
   e: boolean;
 
procedure iniG;
var
   Driv,Mode:integer;
   Path:string;
begin
   Driv:= VGA;
   Mode:= VGAHi;
   Path:= 'C:\tp\bgi';
   InitGraph (Driv,Mode,Path);
   if GraphResult < 0 then Halt (1);
end;
 
BEGIN
   iniG;
   a:= 150;
   b:= 150;
   e:= true;
   repeat
      if e then begin
         inc(a); dec(b); end
      else begin
         dec(a); inc(b); end;
 
      if a = 200 then e:= not e;
      if a = 50  then e:= not e;
      x1:= ox-a;
      x3:= ox+a;
      y2:= oy-b;
      y4:= oy+b;
 
      setColor(15);
      line(x1,oy,ox,y2);
      line(ox,y2,x3,oy);
      line(x3,oy,ox,y4);
      line(ox,y4,x1,oy);
 
      delay(10);
 
      setColor(0);
      line(x1,oy,ox,y2);
      line(ox,y2,x3,oy);
      line(x3,oy,ox,y4);
      line(ox,y4,x1,oy);
   until KeyPressed;
 
   OutTextXY(10,10,'Press_Enter');
   readln;
   CloseGraph;
END.

@hoch · 04.10.2014, 07: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
uses crt, Graph;
var
   lo: array[0..21,0..31] of byte;
   i,j,l: byte;
   k: integer;
 
procedure iniG;
var
   Driv,Mode:integer;
   Path:string;
begin
   Driv:= VGA;
   Mode:= VGAHi;
   Path:= 'C:\tp\bgi';
   InitGraph (Driv,Mode,Path);
   if GraphResult < 0 then Halt (1);
end;
 
BEGIN
   randomize;
   iniG;
   for i:= 0 to 21 do
   for j:= 0 to 31 do begin
      lo[0, j]:= 2; lo[21, j]:= 2;
      lo[i, 0]:= 2; lo[i, 31]:= 2;
   end;
 
   for k:= 1 to 1000 do begin
      i:= random(20)+1;
      j:= random(30)+1;
      l:= random(4);
      if lo[i,j] in [0,1] then begin
        case l of
 
        0: if lo[i-1,j] in [0,1] then begin
             line(20*j,20*i,20*j,20*i-20);
             inc(lo[i,j]);
             inc(lo[i-1,j]); continue
           end;
        1: if lo[i,j-1] in [0,1] then begin
             line(20*j,20*i,20*j-20,20*i);
             inc(lo[i,j]);
             inc(lo[i,j-1]); continue
           end;
        2: if lo[i+1,j] in [0,1] then begin
             line(20*j,20*i,20*j,20*i+20);
             inc(lo[i,j]);
             inc(lo[i+1,j]); continue
           end;
        3: if lo[i,j+1] in [0,1] then begin
             line(20*j,20*i,20*j+20,20*i);
             inc(lo[i,j]);
             inc(lo[i,j+1]); continue
           end
        end
      end
   end;
   readln;
   CloseGraph
END.

@Puporev · 04.10.2014, 08:06

И для чего везде continue ?

@hoch · 04.10.2014, 12:04

Я приношу свои извинения.
В первом варианте не было оператора case of
и они были нужны. Потом код изменился и я
забыл их удалить.

@hoch · 05.10.2014, 13:07

Дан треугольник координатами своих вершин и угол на который
относительно заданного треугольника повернут второй треугольник.
Этот треугольник обладает свойствами.
1. Он подобен первому треугольнику.
2. Он вписан в первый треугольник.
Программа уникальная, красивый код которой пленит сердце
настоящего программиста.

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
Uses Graph,Crt;
var
   x1,x2,x3,y1,y2,y3: longint;
   x4,x5,x6,y4,y5,y6: longint;
   k,ka,kb,kc: real;
   a,b,c,ua,ub,uc,f: real;
 
procedure iniG;
var
   Driv,Mode:integer;
   Path:string;
begin
   Driv:= VGA;
   Mode:= VGAHi;
   Path:= 'C:\tp\bgi';
   InitGraph (Driv,Mode,Path);
   if GraphResult < 0 then Halt (1);
end;
 
function arccos(x:real): real;
begin
   if x = 0 then arccos:= 1.5707963268
   else arccos:= arctan(sqrt(1-x*x)/x)
end;
 
BEGIN
   iniG;
   f:= 0.5;
   x1:= 100; y1:= 400;
   x2:= 540; y2:= 400;
   x3:= 400; y3:= 100;
 
   a:= sqrt(sqr(x1-x2) + sqr(y1-y2));
   b:= sqrt(sqr(x2-x3) + sqr(y2-y3));
   c:= sqrt(sqr(x3-x1) + sqr(y3-y1));
 
   ua:= arccos((b*b+c*c-a*a)/(2*b*c));
   ub:= arccos((a*a+c*c-b*b)/(2*a*c));
   uc:= arccos((a*a+b*b-c*c)/(2*a*b));
 
   k:= 1/(c*sin(f)/(a*sin(ub))+sin(uc+f)/sin(uc));
 
   ka:= k*sin(ua+f)/sin(ua);
   kb:= k*sin(ub+f)/sin(ub);
   kc:= k*sin(uc+f)/sin(uc);
 
   x4:= round(x2-kb*(x2-x1));
   y4:= round(y2-kb*(y2-y1));
   x5:= round(x3-kb*(x3-x2));
   y5:= round(y3-kb*(y3-y2));
   x6:= round(x1-kb*(x1-x3));
   y6:= round(y1-kb*(y1-y3));
 
   line(x1,y1,x2,y2);
   line(x2,y2,x3,y3);
   line(x3,y3,x1,y1);
   setcolor(14);
   line(x4,y4,x5,y5);
   line(x5,y5,x6,y6);
   line(x6,y6,x4,y4);
 
   OutTextXY(10,10,'Press_Enter');
   readln;
   CloseGraph;
END.

@Puporev · 05.10.2014, 13:18

А ничего что это частный случай этой, широко известной программы?

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
uses graph;
var gd,gm,a,n,xc,yc,i:integer;
    m,ax,bx,cx,ay,by,cy:real;
begin
gd:=detect;
initgraph(gd,gm,'');
a:=200;
n:=20;
m:=0.08;
{центр экрана}
xc:=getmaxX div 2;
yc:=getmaxY div 2;
{координаты исходного треугольника}
ax:=xc+a*cos(pi/2);
ay:=yc-a*sin(pi/2);
bx:=xc+a*cos(7*pi/6);
by:=yc-a*sin(7*pi/6);
cx:=xc+a*cos(11*pi/6);
cy:=yc-a*sin(11*pi/6);
for i:=1 to n+1 do
 begin
  {строим треугольник}
  line(round(ax),round(ay),round(bx),round(by));
  line(round(bx),round(by),round(cx),round(cy));
  line(round(cx),round(cy),round(ax),round(ay));
  {новые координаты}
  ax:=ax+(bx-ax)*m; ay:=ay+(by-ay)*m;
  bx:=bx+(cx-bx)*m; by:=by+(cy-by)*m;
  cx:=cx+(ax-cx)*m; cy:=cy+(ay-cy)*m;
 end;
readln
end.

@hoch · 05.10.2014, 16:34

Спасибо!
Но мне это было неизвестно.
Я просто решал геометрическую задачу, вывел ряд
формул и естественно подумал о написании программы
Я рад, что кто-то это сделал раньше меня, хотя я был
настолько уверен, что я первый, что не стал даже
наводить справки об этом свойстве треугольников.
Спасибо!

@hoch · 06.10.2014, 16:55

Анимация.
Квадрат катится по горизонтальной прямой.

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
Uses Graph,Crt;
const d = 141;
      a = 100;
      f1 = 0.7854;
      f2 = 2*f1;
var
   x,x2,x3,x4: longint;
   y,y2,y3,y4: longint;
   f: real;
 
procedure iniG;
var
   Driv,Mode:integer;
   Path:string;
begin
   Driv:= VGA;
   Mode:= VGAHi;
   Path:= 'C:\tp\bgi';
   InitGraph (Driv,Mode,Path);
   if GraphResult < 0 then Halt (1);
end;
 
BEGIN
   iniG;
   f:= 0;
   x:= 200;
   y:= 400;
   repeat
      if f > f2 then begin
         f:= 0;
         inc(x,100);
      end;
 
      x2:= x - round(a*cos(f));
      y2:= y - round(a*sin(f));
      x3:= x - round(d*cos(f1+f));
      y3:= y - round(d*sin(f1+f));
      x4:= x - round(a*cos(f2+f));
      y4:= y - round(a*sin(f2+f));
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x4,y4);
      line(x4,y4,x,y);
 
      delay(100);
 
      setColor(0);
      x2:= x - round(a*cos(f));
      y2:= y - round(a*sin(f));
      x3:= x - round(d*cos(f1+f));
      y3:= y - round(d*sin(f1+f));
      x4:= x - round(a*cos(f2+f));
      y4:= y - round(a*sin(f2+f));
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x4,y4);
      line(x4,y4,x,y);
      line(10,400,630,400);
      setColor(15);
      f:= f + 0.03;
   until x>500;
 
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x4,y4);
      line(x4,y4,x,y);
      line(10,400,630,400);
   OutTextXY(10,10,'Press_Enter');
   readln;
   CloseGraph;
END.

@hoch · 07.10.2014, 17:42

Анимация.
Треугольник скатывается по наклонной прямой

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
Uses Graph,Crt;
const a = 100;
      f0 = 0.1651;
      f1 = 1.0472;
      f2 = 2.0944;
 
var
   x,x2,x3: longint;
   y,y2,y3: longint;
   f: real;
 
procedure iniG;
var
   Driv,Mode:integer;
   Path:string;
begin
   Driv:= VGA;
   Mode:= VGAHi;
   Path:= 'C:\tp\bgi';
   InitGraph (Driv,Mode,Path);
   if GraphResult < 0 then Halt (1);
end;
 
BEGIN
   iniG;
   f:= 0;
   x:= 150;
   y:= round(280+x/6);
   repeat
      if f > f2 then begin
         f:= 0;
         inc(x,99);
         y:= round(280+x/6);
      end;
 
      x2:= x - round(a*cos(f+f0));
      y2:= y - round(a*sin(f+f0));
      x3:= x - round(a*cos(f1+f+f0));
      y3:= y - round(a*sin(f1+f+f0));
 
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x,y);
      line(0,280,600,380);
 
      delay(100);
 
      setColor(0);
      x2:= x - round(a*cos(f+f0));
      y2:= y - round(a*sin(f+f0));
      x3:= x - round(a*cos(f1+f+f0));
      y3:= y - round(a*sin(f1+f+f0));
 
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x,y);
 
      setColor(15);
      f:= f + 0.03;
   until x>500;
 
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x,y);
      line(0,280,600,380);
   OutTextXY(10,10,'Press_Enter');
   readln;
   CloseGraph;
END.

@hoch · 08.10.2014, 18:17

В этой программе задаются рандомно 25 точек
(они рисуются маленькими кружочками). Программа
анализирует координаты точек и рисует букву А.
Чего не удалось сделать? Так это задать критерий:
Какая из двух букв А, лучше? Тут надо подумать ...

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
Uses Graph,Crt;
const n = 25;
var
   i,j,k,l,m: integer;
   x,y: array[1..n]of integer;
label 2014;
 
procedure iniG;
var
   Driv,Mode:integer;
begin
   Driv:= 0;
   Mode:= VGAHi;
   InitGraph (Driv,Mode,'');
   if GraphResult <> 0 then Halt (1);
end;
 
BEGIN
   randomize;
   iniG;
 
   for i:= 1 to n do begin
      x[i]:= random(200) + 200;
      y[i]:= random(300) + 100;
   end;
 
   for i:= 1 to n do
      circle(x[i],y[i],2);
 
   for i:= 1 to n do
   for j:= 1 to n do
   for k:= 1 to n do begin
      if abs(y[i]-y[j])>30 then continue;
      if (y[i]-y[k]<150) or (y[j]-y[k]<150) then continue;
      if (x[i]>x[k]) or (x[j]<x[k]) then continue
         else
      for l:= 1 to n do
      for m:= 1 to n do begin
         if abs(y[l]-y[m])>15 then continue;
         if (y[i]-y[l]<50) or (y[j]-y[m]<50) then continue;
         if (y[l]-y[k]<50) or (y[m]-y[k]<50) then continue;
         if (x[l]<x[i]) or (x[m]>x[j]) then continue;
         if x[m]-x[l]<100 then continue
            else
         begin
            setColor(11);
            line(x[i],y[i],x[k],y[k]);
            line(x[j],y[j],x[k],y[k]);
            line(x[l],y[l],x[m],y[m]);
            goto 2014
         end
      end
   end;
 
2014:
   OutTextXY(20,20,'Press_Enter');
   readln;
   CloseGraph;
END.

@vlados2441 · 04.03.2015, 22:11

Программа "Шарик"

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
program key1;
uses Graph,crt;
var
   gd,gm,x,y,dx,dy,r: integer;
   ch: char;
begin
     initGraph(gd,gm,'..\bgi');
     x:=320;
     y:=240;
     dx:=0;
     dy:=0;
     r:=20;
   repeat
    setColor (15);
    circle (x,y,r);
    delay (10);
    setColor (0);
    circle (x,y,r);
    x:= x + dx;
    y:= y + dy;
     if (x > 640 - r) or (x < r) then dx:= -dx;
     if (y > 480 - r) or (y < r) then dy:= -dy;
     if keyPressed then begin
    ch:= readKey;
    if ch = '1' then begin
     dx:=-1;
     dy:=1;
   end;
     if ch = '2' then begin
     dx:=-4;
     dy:=4;
   end;
   if ch = '3' then begin
     dx:=2;
     dy:=-2;
   end;
     if ch = '9' then begin
     dx:=0;
     dy:=0;
   end;
   if ch = 'a' then begin
     dx:=-1;
     dy:=0;
   end;
   if ch = 'd' then begin
     dx:=1;
     dy:=0;
   end;
     if ch = 'w' then begin
     dx:=0;
     dy:=-1;
   end;
   if ch = 's' then begin
     dx:=0;
     dy:=1;
   end;
   if ch = 'c' then begin
     dx:=1;
     dy:=1;
   end;
   if ch = 'q' then begin
    dx:=-1;
    dy:=-1;
   end;
   if ch = 'z' then begin
     dx:=-1;
     dy:=1;
   end;
   if ch = 'e' then begin
     dx:=1;
     dy:=-1;
   end;
  end;
 until ch = '0';
readln;
closeGraph;
end.

@Dimon_KV · 02.08.2015, 12:16

Программа "Фейерверк"

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
uses
  crt, graph, graphs;
 
const
  raysAmount = 24;
  step = pi/(raysAmount div 2);   { угол между двумя соседними линиями }
  pause = 40;
  maxTimeOfLife = 16;
  salutsAmount = 6;
  delLen = 20;
  lowLen = 50;
  lowDel = 10;
  delDel = 8;
 
type
  salut = record
    lifeTime: integer;
    isPresent: boolean;
    division: integer;
    color: word;
    delta, lengt,
    xC, yC: integer;
  end;
 
var
  xScrC, yScrC, xSClow, ySClow, xSCdel, ySCdel: integer;
  saluts: array[1..salutsAmount] of salut;
  time, i: integer;
 
procedure drawRays(salutsNum: integer; color: word);
var
  i: integer;
  x1, y1, x2, y2: integer;
begin
  setcolor(color);
  for i := 1 to raysAmount do
  with saluts[salutsNum] do
    begin
      x1 := round(delta * lifeTime * cos(i * step)) + xC;
      y1 := round(delta * lifeTime * sin(i * step)) + yC;
      x2 := x1 + round(lengt * cos(i * step));
      y2 := y1 + round(lengt * sin(i * step));
      line(x1, y1, x2, y2);
    end;
end;
 
begin
  open_graph;
  xScrC := GetMaxX div 2;
  yScrC := GetMaxY div 2;
 
  xSClow := GetMaxX div 3;
  ySClow := GetMaxY div 3;
 
  xSCdel := GetMaxX div 3;
  ySCdel := GetMaxY div 3;
  time := 1;
  randomize;
  for i := 1 to salutsAmount do
  begin
    saluts[i].division := 20 + random(40);
    saluts[i].isPresent := false;
    saluts[i].lifeTime := 0;
  end;
  setLineStyle(0, 0, thickWidth);
  repeat
    for i := 1 to salutsAmount do
      if time mod saluts[i].division = 0 then
        if not saluts[i].isPresent then saluts[i].isPresent := true;
 
    for i := 1 to salutsAmount do
      with saluts[i] do
      if (isPresent) and (lifeTime = 0) then
       begin
        xC := xSClow + random(xSCdel);
        yC := ySClow + random(ySCdel);
        color := 1 + random(15);
        delta := lowDel + random(delDel);
        lengt := lowLen + random(delLen);
       end;
 
    for i := 1 to salutsAmount do
      if saluts[i].isPresent then
        drawRays(i, saluts[i].color);
 
    delay(pause);
    inc(time);
    if time > maxInt - 1 then time := 1;
 
    for i := 1 to salutsAmount do
     with saluts[i] do
      if isPresent then
      begin
        drawRays(i, black);
        inc(lifeTime);
        if lifeTime >= maxTimeOfLife then
        begin
          lifeTime := 0;
          isPresent := false;
        end;
      end;
  until keypressed;
end.

Текст модуля Graphs:

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
unit graphs;
{$N+}
interface
 
procedure open_graph;
procedure close_graph;
function gx(x: extended; sx: integer): integer;
function gy(y: extended; sy: integer): integer;
 
implementation
 
uses Graph;
 
var
  x, y: extended;
  sx, sy: integer;
 
procedure open_graph;
var
  graph_device, graph_mode: integer;
begin
  graph_device := detect;
  InitGraph(graph_device, graph_mode, '');
  if GraphResult <> 0 then
  begin
    WriteLn('Ошибка инициализации графического режима.');
    ReadLn;
    Halt;
  end;
end;
 
procedure close_graph;
begin
  CloseGraph;
  if GraphResult <> 0 then
  begin
    WriteLn('Ошибка инициализации графического режима.');
    ReadLn;
    Halt;
  end;
end;
 
function gx(x: extended; sx: integer): integer;
begin
  gx := trunc(sx * x) + GetMaxX div 2;
end;
 
function gy(y: extended; sy: integer): integer;
begin
  gy := GetMaxY div 2 - trunc(sy * y);
end;
 
end.

@falkoris · 23.12.2020, 14:26

Делюсь самой мощной графической библиотекой для Turbo и Borland Pascal (real mode и protected mode). Поддерживаются все графические режимы (MCGA, VGA, SVGA, Modes-X).

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
(* ULTRA FAST GRAPH LIBRARY /I80386 AND HIGHER, REAL MODE & PROTECTED MODE *)
(*                                                                         *)
(*                  BEST GAME SDK FOR TURBO/BORLAND PASCAL                 *)
(*                ╔══╗╦  ╦  ╦╔══  ╔══ ╦  ╦╔════╬══╦══╗ ╦═╦═╗               *)
(*                ║══╝║  ║  ║╚══╗ ╚══╗║  ║╚══╗ ║  ╠══╝ ║ ║ ║               *)
(*                ╩   ╚═╝╚══╩╩══╝  ══╝╚══╣ ══╝ ╚═ ╚════╝   ║               *)
(*               │         ╔╦═══╗   ═════╝                 │               *)
(*               ├ ───── : ║║   ║║ ═╣╔══╦╗ ╔╦═══╗  .───────┤               *)
(*               | |  .    ╠╬═══╝╝  ║║     ║║   ║║    *    │               *)
(*               │-+-    . ╩╝       ╩╝     ╩╩═══╩╝   .  +  │               *)
(*               │ |   .        version 2.0       .      :                 *)
(*               │  BY VADIM BODROV, RUSSIA  (c) 1996-98   |               *)
 
(*----------------------- unit revision 2.20 (final) ----------------------*)
 
(* Used materials:
(* - SVGAKit v5.2 Copyright (C) 1992-95 SciTech Software                   *)
(* - 'Zen Of Graphic Programming', Copyright (C) 1995 by Michael Abrash    *)
(* - XLib by Themie Gouthas                                                *)
(* - VGAKit v 4.1 Copiright (C) 1991 by John Bridges                       *)

Ну и все плюшки прилагаются: работа со спрайтами, курсорами, шрифтами, различными форматами изображений (TGA, BMP, GIF и т.д.)

Все библиотеки есть в исходниках и куча примеров.

The MegaGraf unit is a powerful ultra fast graphic library for working with MCGA/VGA, X Modes and SuperVGA video modes (if your video card have a VESA VBE 1.2/2.0 compliant Video BIOS). MegaGraf supports Real Mode and Protected Mode (DPMI 16). It is a high performance 32-bits (i80386 required) graphic library for Turbo/Borland Pascal 7

Плюс к графике, включена поддержка музыки и звука через системы MIDPAK и DIGPAK, что использовались практически всеми популярными играми (Dune II, The 7th Guest, Dangeon Keeper и т.д.)

Еще плюс: библиотека для работы с памятью через DPMI:

MemPlus ia an ddvanced memory unit. This unit provides a set of fastest procedures and functions for direct memory access. MEMPLUS allows a direct access to the real and protected memory without 64K restriction.

Ссылка на архив: http://ge.tt/3tm4Ep93
Дубликат: http://www.filedropper.com/plussystempro

Новые блоги и статьи Все статьи Все блоги /
[golang] Угол между стрелками часов alhaos 12.05.2026 По заданным значениям часа и минуты необходимо определить значение меньшего угла между стрелками аналогового циферблата часов. import "math" func angleClock(hour int, minutes int) float64 { . . .	Debian 13: Установка Lazarus QT5 ВитГо 09.05.2026 Эта инструкция моя компиляция инструкций volvo https:/ / www. cyberforum. ru/ blogs/ 203668/ 10753. html и его же старой инструкции по установке Lazarus с gtk2. . .	Нейросеть на алгоритме "эстафета хвоста" как перспектива. Hrethgir 06.05.2026 На десерт, когда запущу сервер. Статья тут https:/ / habr. com/ ru/ articles/ 1030914/ . Автор я сам, нейросеть только помогает в вопросах которые мне не известны - не знаю людей которые знали-бы. . .	Асинхронный приём данных из COM-порта Argus19 01.05.2026 Асинхронный приём данных из COM-порта Купил на aliexpress термопринтер QR701. Он оказался странным. Поключил к Arduino Nano. Был очень удивлён. Наотрез отказывается печатать русские буквы. Чтобы. . .
попытка написать игровой сервер на C++ pyirrlicht 29.04.2026 попытка написать игровой сервер на плюсах с открытым бесконечным миром. возможно получится прикрутить интерпретатор питон для кастомизации игровой логики. что есть на текущий момент:. . .	Контроль уникальности выбранного документа-основания при изменении реквизита Maks 28.04.2026 Алгоритм из решения ниже разработан на примере нетипового документа "ЗаявкаНаРемонтСпецтехники", разработанного в КА2. Задача: уведомлять пользователя, если указанная заявка (документ-основание). . .	Благородство как наказание Maks 24.04.2026 У хорошего человека отношения с женщинами всегда складываются трудно. А я человек хороший. Заявляю без тени смущения, потому что гордиться тут нечем. От хорошего человека ждут соответствующего. . .	Валидация и контроль данных табличной части документа перед записью Maks 22.04.2026 Алгоритм из решения ниже реализован на примере нетипового документа, разработанного в КА2. Задача: контроль и валидация данных табличной части документа перед записью с учетом регламента компании. . .

@Puporev Почетный модератор 64319 / 47615 / 32743 Регистрация: 18.05.2008 Сообщений: 115,167
	04.10.2014, 08:06
	И для чего везде continue ? 1

@hoch Заблокирован
	04.10.2014, 12:04
	Я приношу свои извинения. В первом варианте не было оператора case of и они были нужны. Потом код изменился и я забыл их удалить. 0

@hoch Заблокирован
	05.10.2014, 16:34
	Спасибо! Но мне это было неизвестно. Я просто решал геометрическую задачу, вывел ряд формул и естественно подумал о написании программы Я рад, что кто-то это сделал раньше меня, хотя я был настолько уверен, что я первый, что не стал даже наводить справки об этом свойстве треугольников. Спасибо! 0