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

Turbo Pascal

Войти
Регистрация
Восстановить пароль
 
 
Рейтинг: Рейтинг темы: голосов - 1, средняя оценка - 5.00
hoch
Заблокирован
05.10.2014, 13:07 #151
Дан треугольник координатами своих вершин и угол на который
относительно заданного треугольника повернут второй треугольник.
Этот треугольник обладает свойствами.
1. Он подобен первому треугольнику.
2. Он вписан в первый треугольник.
Программа уникальная, красивый код которой пленит сердце
настоящего программиста.
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
Uses Graph,Crt;
var
   x1,x2,x3,y1,y2,y3: longint;
   x4,x5,x6,y4,y5,y6: longint;
   k,ka,kb,kc: real;
   a,b,c,ua,ub,uc,f: real;
 
procedure iniG;
var
   Driv,Mode:integer;
   Path:string;
begin
   Driv:= VGA;
   Mode:= VGAHi;
   Path:= 'C:\tp\bgi';
   InitGraph (Driv,Mode,Path);
   if GraphResult < 0 then Halt (1);
end;
 
function arccos(x:real): real;
begin
   if x = 0 then arccos:= 1.5707963268
   else arccos:= arctan(sqrt(1-x*x)/x)
end;
 
BEGIN
   iniG;
   f:= 0.5;
   x1:= 100; y1:= 400;
   x2:= 540; y2:= 400;
   x3:= 400; y3:= 100;
 
   a:= sqrt(sqr(x1-x2) + sqr(y1-y2));
   b:= sqrt(sqr(x2-x3) + sqr(y2-y3));
   c:= sqrt(sqr(x3-x1) + sqr(y3-y1));
 
   ua:= arccos((b*b+c*c-a*a)/(2*b*c));
   ub:= arccos((a*a+c*c-b*b)/(2*a*c));
   uc:= arccos((a*a+b*b-c*c)/(2*a*b));
 
   k:= 1/(c*sin(f)/(a*sin(ub))+sin(uc+f)/sin(uc));
 
   ka:= k*sin(ua+f)/sin(ua);
   kb:= k*sin(ub+f)/sin(ub);
   kc:= k*sin(uc+f)/sin(uc);
 
   x4:= round(x2-kb*(x2-x1));
   y4:= round(y2-kb*(y2-y1));
   x5:= round(x3-kb*(x3-x2));
   y5:= round(y3-kb*(y3-y2));
   x6:= round(x1-kb*(x1-x3));
   y6:= round(y1-kb*(y1-y3));
 
   line(x1,y1,x2,y2);
   line(x2,y2,x3,y3);
   line(x3,y3,x1,y1);
   setcolor(14);
   line(x4,y4,x5,y5);
   line(x5,y5,x6,y6);
   line(x6,y6,x4,y4);
 
   OutTextXY(10,10,'Press_Enter');
   readln;
   CloseGraph;
END.
0
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
05.10.2014, 13:07
Я подобрал для вас темы с готовыми решениями и ответами на вопрос Графика в Турбо Паскаль (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
Puporev
Модератор
53860 / 41493 / 14596
Регистрация: 18.05.2008
Сообщений: 97,282
05.10.2014, 13:18 #152
А ничего что это частный случай этой, широко известной программы?
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
uses graph;
var gd,gm,a,n,xc,yc,i:integer;
    m,ax,bx,cx,ay,by,cy:real;
begin
gd:=detect;
initgraph(gd,gm,'');
a:=200;
n:=20;
m:=0.08;
{центр экрана}
xc:=getmaxX div 2;
yc:=getmaxY div 2;
{координаты исходного треугольника}
ax:=xc+a*cos(pi/2);
ay:=yc-a*sin(pi/2);
bx:=xc+a*cos(7*pi/6);
by:=yc-a*sin(7*pi/6);
cx:=xc+a*cos(11*pi/6);
cy:=yc-a*sin(11*pi/6);
for i:=1 to n+1 do
 begin
  {строим треугольник}
  line(round(ax),round(ay),round(bx),round(by));
  line(round(bx),round(by),round(cx),round(cy));
  line(round(cx),round(cy),round(ax),round(ay));
  {новые координаты}
  ax:=ax+(bx-ax)*m; ay:=ay+(by-ay)*m;
  bx:=bx+(cx-bx)*m; by:=by+(cy-by)*m;
  cx:=cx+(ax-cx)*m; cy:=cy+(ay-cy)*m;
 end;
readln
end.
0
hoch
Заблокирован
05.10.2014, 16:34 #153
Спасибо!
Но мне это было неизвестно.
Я просто решал геометрическую задачу, вывел ряд
формул и естественно подумал о написании программы
Я рад, что кто-то это сделал раньше меня, хотя я был
настолько уверен, что я первый, что не стал даже
наводить справки об этом свойстве треугольников.
Спасибо!
0
hoch
Заблокирован
06.10.2014, 16:55 #154
Анимация.
Квадрат катится по горизонтальной прямой.
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
Uses Graph,Crt;
const d = 141;
      a = 100;
      f1 = 0.7854;
      f2 = 2*f1;
var
   x,x2,x3,x4: longint;
   y,y2,y3,y4: longint;
   f: real;
 
procedure iniG;
var
   Driv,Mode:integer;
   Path:string;
begin
   Driv:= VGA;
   Mode:= VGAHi;
   Path:= 'C:\tp\bgi';
   InitGraph (Driv,Mode,Path);
   if GraphResult < 0 then Halt (1);
end;
 
BEGIN
   iniG;
   f:= 0;
   x:= 200;
   y:= 400;
   repeat
      if f > f2 then begin
         f:= 0;
         inc(x,100);
      end;
 
      x2:= x - round(a*cos(f));
      y2:= y - round(a*sin(f));
      x3:= x - round(d*cos(f1+f));
      y3:= y - round(d*sin(f1+f));
      x4:= x - round(a*cos(f2+f));
      y4:= y - round(a*sin(f2+f));
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x4,y4);
      line(x4,y4,x,y);
 
      delay(100);
 
      setColor(0);
      x2:= x - round(a*cos(f));
      y2:= y - round(a*sin(f));
      x3:= x - round(d*cos(f1+f));
      y3:= y - round(d*sin(f1+f));
      x4:= x - round(a*cos(f2+f));
      y4:= y - round(a*sin(f2+f));
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x4,y4);
      line(x4,y4,x,y);
      line(10,400,630,400);
      setColor(15);
      f:= f + 0.03;
   until x>500;
 
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x4,y4);
      line(x4,y4,x,y);
      line(10,400,630,400);
   OutTextXY(10,10,'Press_Enter');
   readln;
   CloseGraph;
END.
0
hoch
Заблокирован
07.10.2014, 17:42 #155
Анимация.
Треугольник скатывается по наклонной прямой
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
Uses Graph,Crt;
const a = 100;
      f0 = 0.1651;
      f1 = 1.0472;
      f2 = 2.0944;
 
var
   x,x2,x3: longint;
   y,y2,y3: longint;
   f: real;
 
procedure iniG;
var
   Driv,Mode:integer;
   Path:string;
begin
   Driv:= VGA;
   Mode:= VGAHi;
   Path:= 'C:\tp\bgi';
   InitGraph (Driv,Mode,Path);
   if GraphResult < 0 then Halt (1);
end;
 
BEGIN
   iniG;
   f:= 0;
   x:= 150;
   y:= round(280+x/6);
   repeat
      if f > f2 then begin
         f:= 0;
         inc(x,99);
         y:= round(280+x/6);
      end;
 
      x2:= x - round(a*cos(f+f0));
      y2:= y - round(a*sin(f+f0));
      x3:= x - round(a*cos(f1+f+f0));
      y3:= y - round(a*sin(f1+f+f0));
 
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x,y);
      line(0,280,600,380);
 
      delay(100);
 
      setColor(0);
      x2:= x - round(a*cos(f+f0));
      y2:= y - round(a*sin(f+f0));
      x3:= x - round(a*cos(f1+f+f0));
      y3:= y - round(a*sin(f1+f+f0));
 
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x,y);
 
      setColor(15);
      f:= f + 0.03;
   until x>500;
 
      line(x,y,x2,y2);
      line(x2,y2,x3,y3);
      line(x3,y3,x,y);
      line(0,280,600,380);
   OutTextXY(10,10,'Press_Enter');
   readln;
   CloseGraph;
END.
0
hoch
Заблокирован
08.10.2014, 18:17 #156
В этой программе задаются рандомно 25 точек
(они рисуются маленькими кружочками). Программа
анализирует координаты точек и рисует букву А.
Чего не удалось сделать? Так это задать критерий:
Какая из двух букв А, лучше? Тут надо подумать ...
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
Uses Graph,Crt;
const n = 25;
var
   i,j,k,l,m: integer;
   x,y: array[1..n]of integer;
label 2014;
 
procedure iniG;
var
   Driv,Mode:integer;
begin
   Driv:= 0;
   Mode:= VGAHi;
   InitGraph (Driv,Mode,'');
   if GraphResult <> 0 then Halt (1);
end;
 
BEGIN
   randomize;
   iniG;
 
   for i:= 1 to n do begin
      x[i]:= random(200) + 200;
      y[i]:= random(300) + 100;
   end;
 
   for i:= 1 to n do
      circle(x[i],y[i],2);
 
   for i:= 1 to n do
   for j:= 1 to n do
   for k:= 1 to n do begin
      if abs(y[i]-y[j])>30 then continue;
      if (y[i]-y[k]<150) or (y[j]-y[k]<150) then continue;
      if (x[i]>x[k]) or (x[j]<x[k]) then continue
         else
      for l:= 1 to n do
      for m:= 1 to n do begin
         if abs(y[l]-y[m])>15 then continue;
         if (y[i]-y[l]<50) or (y[j]-y[m]<50) then continue;
         if (y[l]-y[k]<50) or (y[m]-y[k]<50) then continue;
         if (x[l]<x[i]) or (x[m]>x[j]) then continue;
         if x[m]-x[l]<100 then continue
            else
         begin
            setColor(11);
            line(x[i],y[i],x[k],y[k]);
            line(x[j],y[j],x[k],y[k]);
            line(x[l],y[l],x[m],y[m]);
            goto 2014
         end
      end
   end;
 
2014:
   OutTextXY(20,20,'Press_Enter');
   readln;
   CloseGraph;
END.
0
vlados2441
2 / 2 / 0
Регистрация: 11.01.2015
Сообщений: 108
04.03.2015, 22:11 #157
Программа "Шарик"
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
program key1;
uses Graph,crt;
var
   gd,gm,x,y,dx,dy,r: integer;
   ch: char;
begin
     initGraph(gd,gm,'..\bgi');
     x:=320;
     y:=240;
     dx:=0;
     dy:=0;
     r:=20;
   repeat
    setColor (15);
    circle (x,y,r);
    delay (10);
    setColor (0);
    circle (x,y,r);
    x:= x + dx;
    y:= y + dy;
     if (x > 640 - r) or (x < r) then dx:= -dx;
     if (y > 480 - r) or (y < r) then dy:= -dy;
     if keyPressed then begin
    ch:= readKey;
    if ch = '1' then begin
     dx:=-1;
     dy:=1;
   end;
     if ch = '2' then begin
     dx:=-4;
     dy:=4;
   end;
   if ch = '3' then begin
     dx:=2;
     dy:=-2;
   end;
     if ch = '9' then begin
     dx:=0;
     dy:=0;
   end;
   if ch = 'a' then begin
     dx:=-1;
     dy:=0;
   end;
   if ch = 'd' then begin
     dx:=1;
     dy:=0;
   end;
     if ch = 'w' then begin
     dx:=0;
     dy:=-1;
   end;
   if ch = 's' then begin
     dx:=0;
     dy:=1;
   end;
   if ch = 'c' then begin
     dx:=1;
     dy:=1;
   end;
   if ch = 'q' then begin
    dx:=-1;
    dy:=-1;
   end;
   if ch = 'z' then begin
     dx:=-1;
     dy:=1;
   end;
   if ch = 'e' then begin
     dx:=1;
     dy:=-1;
   end;
  end;
 until ch = '0';
readln;
closeGraph;
end.
0
Dimon_KV
15 / 11 / 10
Регистрация: 11.06.2015
Сообщений: 49
02.08.2015, 12:16 #158
Программа "Фейерверк"

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

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

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

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

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

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


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

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

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