Форум программистов, компьютерный форум, киберфорум
Наши страницы
Turbo Pascal
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг: Рейтинг темы: голосов - 1, средняя оценка - 5.00
vincent
24 / 22 / 0
Регистрация: 14.10.2009
Сообщений: 7
#1

Графика в Турбо Паскаль - Turbo Pascal

14.10.2009, 04:33. Просмотров 209095. Ответов 157
Метки нет (Все метки)

Читаю форум и вижу, что много кому требуется помощь в освоении графики в Паскаль. Предлагаю постить сюда разнообразные задачи, которые вам приходилось решать.
Лично мне интересно было бы посмотреть на реализации следующих задач: рисование сложных геометрических объектов, построение графиков функций, вписать/описать одну фигуру внутри/вокруг другой, аффинные преобразования (перенос, масштабирование, поворот), анимация (в том числе которая зависит от пользователя), игры, а вообще все что кажется вам интересным и достойным внимания.
Например:
Как разбить экран на правильные шестиугольные соты?
http://www.cyberforum.ru/turbo-pascal/thread992769.html

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 sota;
uses graph;
const
r = 10;
var
gd,gm: integer;
ga: string;
ErrCode: integer;
i, j: integer;
n, m, x, y: integer;
fi: integer;
begin
gd := VGA;
gm := VGAHi;
ga := '../bgi';
initgraph(gd,gm,ga);
ErrCode := GraphResult;
 if ErrCode = GrOk then begin
   x:=0;
   y:=0;
   n:=Round(GetMaxX/r);
   m:=Round(GetMaxY/r);
   for j := 0 to n do begin
    for i := 0 to m do begin
    x :=Round(r*(i*3+1.5*(j mod 2)));
    y := Round(j*r*0.866);
    fi := 0;
    MoveTo(x + Round(r*cos(2*fi*pi/360)), y + Round(r*sin(2*fi*pi/360)));
     repeat
     inc(fi,60);
     LineTo(x + Round(r*cos(2*fi*pi/360)), y + Round(r*sin(2*fi*pi/360)));
     until 360 <= fi;
    end;
    end;
   ReadLn;
 end;
end.
Ссылки на разнообразные алгоритмы тоже приветствуются!)
Многим по разным причинам (задания в школе/институте) приходится начинать изучать компьютерную графику именно с Паскаля. Чтобы помочь начинающим быстрее разобраться, я и создал эту тему. Так что, если есть какие-либо примеры, то выкладывай.

Важно:
Данная тема не предназначенна для вопросов. Тут размещаются готовые программы или полезная информация по теме: "Графика в Turbo Pascal". Если у Вас возникли вопросы, то создайте новую тему и ждите пока Вам кто-нибудь ответит. Все последующие посты не в тему будут наказываться карточкой.
12
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
14.10.2009, 04:33
Я подобрал для вас темы с готовыми решениями и ответами на вопрос Графика в Турбо Паскаль (Turbo Pascal):

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

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

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

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

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

157
Puporev
Модератор
54129 / 41762 / 28874
Регистрация: 18.05.2008
Сообщений: 98,289
14.10.2009, 07:39 #2
Поддерживаю тему, если наполнится нормальным материалом, поместим в ФАК.
ССЫЛКИ НА СТОРОННИЕ ФОРУМЫ НЕ ПРИЛАГАТЬ!!!
1
ЛоРД_Оледжан
Программист
56 / 54 / 15
Регистрация: 23.07.2009
Сообщений: 336
14.10.2009, 09:11 #3
А архивы с исходниками можно кидать?
0
Puporev
Модератор
54129 / 41762 / 28874
Регистрация: 18.05.2008
Сообщений: 98,289
14.10.2009, 09:22 #4
ЛоРД_Оледжан, Да, давайте. Особо если есть комментарии. Для новичков это очень важно.
1
dim-hj
28 / 25 / 1
Регистрация: 28.07.2009
Сообщений: 109
14.10.2009, 10:39 #5
Предлагаю не просто исходники постить, а по возможности процесс составления программы. Они же не строчка за строчкой из головы появляются.
1
vincent
24 / 22 / 0
Регистрация: 14.10.2009
Сообщений: 7
14.10.2009, 11:55  [ТС] #6
Для начала выкладываю коротенькую книгу-руководство, в приложении к которой уже есть некоторое количество простых примеров. Если вы только решили начать изучать графику в Турбо Паскаль, это то, что нужно.
4
Puporev
Модератор
54129 / 41762 / 28874
Регистрация: 18.05.2008
Сообщений: 98,289
14.10.2009, 12:19 #7
Не все заглядывают в тему Справочные материалы. Там вложена книга, в которой тоже очень доходчиво, в расчете на школьников, изложены приемы работы с графикой, много примеров.
http://www.cyberforum.ru/attachments/3834d1241779566
6
Puporev
Модератор
54129 / 41762 / 28874
Регистрация: 18.05.2008
Сообщений: 98,289
16.10.2009, 09:45 #8
Часто просят нарисовать график функции. Вот последний мой вариант почти по полной программе, с масштабированием сетки. Есть еще над чем работать, но лучше хоть что, чем ничего.
http://www.cyberforum.ru/post288984.html
2
vincent
24 / 22 / 0
Регистрация: 14.10.2009
Сообщений: 7
17.10.2009, 00:34  [ТС] #9
Цитата Сообщение от Puporev Посмотреть сообщение
Часто просят нарисовать график функции. Вот последний мой вариант почти по полной программе, с масштабированием сетки. Есть еще над чем работать, но лучше хоть что, чем ничего.
http://www.cyberforum.ru/post288984.html
В этой программе Y всегда от -1 до 1, неплохо было бы ввести интервал и по Y, тогда легко можно будет увидеть график любой функции.

Добавлено через 11 минут
Еще одна простая программка для начинающих.
При нажатии на Enter плавно перемещает треугольник c вершинами (10,10);(10,100);(100,100) на 10 пунктов по X, и по Y.

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
uses crt,graph;
const n=4;
type
Point=record
x,y:integer;
end;
mas=array[1..n] of Point;
procedure Z(x,y:integer;var m:mas;c:byte);
 
var i:byte;
begin
Setcolor(c);
m[1].x:=x;m[1].y:=y;
m[2].x:=x;m[2].y:=y+90;
m[3].x:=x+90;m[3].y:=y+90;
m[4].x:=x;m[4].y:=y;
moveto(m[1].x,m[1].y);
for i:=1 to n do
lineto(m[i].x,m[i].y);
Setfillstyle(1,c);
end;
var gd,gm:integer;
    x,y,x1,y1,i:integer;
    p:mas;
    c1,c2:byte;
    k:char;
    move:boolean;
begin
gd:=VGA;
gm:=VGAHi;
Initgraph(gd,gm,'..\bgi');
Setbkcolor(8);
x:=10;y:=10;
c1:=7;c2:=8;
move:=true;
repeat
if keypressed then
  begin
    k:=readkey;
    if k=#13 then {if enter}
     for i:=1 to 10 do
      begin
        y1:=y;
        x1:=x;
        y:=y+1;
        x:=x+1;
        delay(6000);
        Z(x1,y1,p,c2);
        Z(x,y,p,c1);
        move:=true;
      end;
    end;
if move then
  begin
    Z(x1,y1,p,c2);
    Z(x,y,p,c1);
    move:=false;
  end;
OutTextXY(320,240,'Press Enter to continue');
until k=#27; {until escape}
closegraph;
end.
Delay похоже зависит от компьютера, приходится подбирать значение, которое устраивает.
Если время очень важно можно использовать это.

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
function timer:real;
var hour,minute,second,sec100:word;
begin
   gettime(hour,minute,second,sec100);
   timer:=(hour*3600.0+minute*60.0+second)*100.0+1.0*sec100;
end;
 
procedure wait_seconds(t:real);
var t1:real;
begin
 t1:=timer;
 repeat until timer>t1+100*t;
end;
Добавлено через 9 минут
Еще один отличный пример.
Вращаем и отражаем фигуру в пространстве. Управление цифрами 1-9.
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
Program Rotation and Reflection;
 
uses Crt, Graph;
var
   gd, gm: Integer;
   par: array[1..8, 1..3] of real;
   ribs: array[1..12, 1..2] of integer;
   i: integer;
   ch: char;
   corner : real;
 
procedure draw;
var
   x1, x2, y1, y2: integer;
   ver1, ver2: integer;
begin
   for i := 1 to 12 do begin
   ver1 := ribs[i,1];
   ver2 := ribs[i,2];
   x1 := round(par[ver1,1])+320;
   y1 := 240-round(par[ver1,2]);
   x2 := round(par[ver2,1])+320;
   y2 := 240-round(par[ver2,2]);
   line(x1,y1,x2,y2);
  end;
end;
 
procedure reflection_XOZ_YOZ;
begin
   for i:=1 to 8 do begin
       par[i,2]:=-par[i,2];
       par[i,1]:=-par[i,1];
   end;
end;
 
procedure reflection_XOZ_XOY;
begin
   for i:=1 to 8 do begin
       par[i,2]:=-par[i,2];
       par[i,3]:=-par[i,3];
   end;
end;
 
procedure reflection_XOY_YOZ;
begin
   for i:=1 to 8 do begin
       par[i,3]:=-par[i,3];
       par[i,1]:=-par[i,1];
   end;
end;
 
procedure turnOX(corner: real);
var
   y,z: real;
begin
   for i:=1 to 8 do Begin
       y:=par[i,2];
       z:=par[i,3];
       par[i,2]:=y*cos(corner)-z*sin(corner);
       par[i,3]:=y*sin(corner)+z*cos(corner);
   end;
end;
 
procedure turnOY(corner: real);
var
   x,z: real;
begin
   for i:=1 to 8 do begin
       x:=par[i,1];
       z:=par[i,3];
       par[i,1]:=x*cos(corner)+z*sin(corner);
       par[i,3]:=-x*sin(corner)+z*cos(corner);
   end;
end;
 
procedure turnOZ(corner: real);
var
   x,y: real;
begin
   for i:=1 to 8 do begin
       x:=par[i,1];
       y:=par[i,2];
       par[i,1]:=x*cos(corner)-y*sin(corner);
       par[i,2]:=x*sin(corner)+y*cos(corner);
   end;
end;
 
begin
   par[1,1]:=0;    par[1,2]:=0;    par[1,3]:=0;
   par[2,1]:=0;    par[2,2]:=110;  par[2,3]:=0;
   par[3,1]:=175;  par[3,2]:=110;  par[3,3]:=0;
   par[4,1]:=175;  par[4,2]:=0;    par[4,3]:=0;
   par[5,1]:=0;    par[5,2]:=0;    par[5,3]:=150;
   par[6,1]:=0;    par[6,2]:=110;  par[6,3]:=150;
   par[7,1]:=175;  par[7,2]:=110;  par[7,3]:=150;
   par[8,1]:=175;  par[8,2]:=0;    par[8,3]:=150;
 
   ribs[1,1]:=1;   ribs[1,2]:=2;
   ribs[2,1]:=2;   ribs[2,2]:=3;
   ribs[3,1]:=3;   ribs[3,2]:=4;
   ribs[4,1]:=4;   ribs[4,2]:=1;
   ribs[5,1]:=5;   ribs[5,2]:=6;
   ribs[6,1]:=6;   ribs[6,2]:=7;
   ribs[7,1]:=7;   ribs[7,2]:=8;
   ribs[8,1]:=8;   ribs[8,2]:=5;
   ribs[9,1]:=1;   ribs[9,2]:=5;
   ribs[10,1]:=2;  ribs[10,2]:=6;
   ribs[11,1]:=3;  ribs[11,2]:=7;
   ribs[12,1]:=4;  ribs[12,2]:=8;
 
 
   gd := VGA;
   gm := VGAHi;
   InitGraph(gd, gm, '../bgi');
 
   If GraphResult <> grOk then
      Halt(1);
 
   turnOX(pi/12);
   turnOY(pi/12);
   turnOZ(pi/12);
   While ch<>#27 do begin
      ClearDevice;
      Draw;
      OuttextXY(10,450,'Press <1>-<6> for rotation, <7>-<9> for reflection');
      OuttextXY(10,465,'Press <Esc> to Exit');
      ch:=readkey;
      Case ch Of
         '1': turnOX(pi/15);
         '4': turnOX(-pi/15);
         '2': turnOY(pi/15);
         '5': turnOY(-pi/15);
         '3': turnOZ(pi/15);
         '6': turnOZ(-pi/15);
         '7': reflection_XOZ_YOZ;
         '8': reflection_XOZ_XOY;
         '9': reflection_XOY_YOZ;
      end;
   end;
   closegraph;
end.
6
Давид
Программист 1С
856 / 644 / 187
Регистрация: 03.03.2009
Сообщений: 1,154
17.10.2009, 12:45 #10
Люди часто задаются вопросом по поводу анимации или просто обычных рисунков в Паскале.
Выложу несколько видов своего художества...а так же коментарии к ним....
Итак:
1) Анимационная картинка - кораблик совершает путь по заданной траектории...все происходит довольно быстро...но время может задать каждый желающий...вообщем смотрите...
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
program corablik;
uses Graph, Crt;
var
  grDriver: integer;
  grMode: integer;
  ErrCode: integer;
  x,y,y0,a,b: integer;{a,b-переменные для линии моря, чтоб они не зависели от х,у}
procedure more(a,b:integer);
begin
moveto(0,y0);
setcolor(blue);
for a:=0 to 680 do{слева направо рисуем синусоиду синего чвета}
 begin
  b:=y0-round(sin(a*pi/180)*30);{30-коэффициент масштабирования по оси Х, 
чем больше, тем волна круче}
  lineto(a,b);
 end;
end;
begin
  grDriver := Detect;
  InitGraph(grDriver, grMode, '..\BGI');
  ErrCode := GraphResult;
  y0 := 250;
  if ErrCode = grOk then
  begin
    x:=600;
    while x>=0 do{лучше использовать цикл while, можно менять величину шага, 
что тоже влияет на скорость и частоту смены картинки}
     begin
      cleardevice;
      more(a,b);{рисуем волну}
      setcolor(white);{устанавливаем цвет кораблика}
      y:=y0-40-round(sin(x*pi/180)*30);{движемся по волне}
      MoveTo(x - 40, y + 20);
      LineTo(x - 20, y + 40);
      LineTo(x + 20, y + 40);
      LineTo(x + 40, y + 20);
      LineTo(x - 40, y + 20);
      MoveTo(x + 15, y + 20);
      LineTo(x + 15, y - 40);
      LineTo(x - 20, y + 20);
      LineTo(x + 15, y + 20);
      delay(100); {нормальная скорость, если модули *.TPL не глючные как у Вас,
 время должно быть в миллисекундах, а не в каких-нибудь наносекундах} 
      x:=x-2;{шаг движения}
    end;
  end
  else Writeln('Graphics error: ', GraphErrorMsg(ErrCode));
 Settextstyle(0,0,3);{устанавливаем стиль шрифта}
 cleardevice;
 setcolor(red);
 OuttextXY(200,240,'Rejs zavershen!');{выводим надпись}
 readln;
 CloseGraph;
end.
2) Анимация - прямоугольничек красного цвета совершает полный путь по экрану монитора!
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
program kv;
uses
    crt, graph;
var
   x, y, dx, dy, w, h, driver, mode: integer;
begin
     initgraph(driver, mode, 'G:/BP/BGI');
     if graphresult<>0 then begin
        writeln('none');
        halt
     end;
     dx:=1;
     dy:=0;
     w:=100;
     h:=10;
repeat
      setfillstyle(1, black);
      bar(x, y, x+w, y+h);
      x:=x+dx;
      y:=y+dy;
      setfillstyle(1, red);
      bar(x, y, x+w, y+h);
      delay(100);
      if (x+w>=getmaxx)and(y<=0) then
      begin
           dx:=0;
           dy:=1;
      end
      else
      if (y+h>=getmaxy)and(x+w>=getmaxx) then
      begin
           dx:=-1;
           dy:=0;
      end
      else
      if (x<=0)and(y+h>=getmaxy) then
      begin
           dx:=0;
           dy:=-1;
      end
      else
      if (y<=0)and(x<=0) then
      begin
           dx:=1;
           dy:=0;
      end;
until keypressed;
closegraph;
end.
3) Люди часто просят нарисовать самый обычный рисунок из разных тем...т.к. это форум скажем компьютерщиков то вот простенький рисунок (как я его называю "программист")!
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Program bugalteria;
Uses crt,graph;
Var gd,gm:integer;
begin
clrscr;
 Detectgraph (gd,gm);
 Initgraph (gd,gm,'C:\tp7');
  {Зарисовка стола}
  Bar (120,330,360,360);
  Bar (180,360,330,480);
  {Зарисовка компьютера}
  Line (180,240,180,330);
  Line (180,270,210,330);
  Line (172,210,202,300);
  Line (180,210,210,300);
  Line (210,300,202,300);
  Line (180,210,172,210);
  Line (270,322,270,330);
  Line (270,322,330,330);
  {Зарисовка стула}
  Bar (420,405,510,420);
  Bar (456,420,480,480);
  {Зарисовка бухгалтера работающего за компьютером}
  Line (510,405,540,300);
  Line (334,480,390,390);
  Line (390,390,510,390);
  Line (360,480,420,405);
  Line (510,390,450,240);
  Line (480,390,420,300);
  Line (420,300,430,240);
  Line (450,270,330,300);
  Line (330,300,310,310);
  Circle (435,195,40);
Readln
end.
9
ЛоРД_Оледжан
Программист
56 / 54 / 15
Регистрация: 23.07.2009
Сообщений: 336
17.10.2009, 22:23 #11
LoRD6006 вот архив в которм програмка реализует рисунок: Дорожный знак на столбе со светофором. У светофора должен гореть один фонарь. В тексте программы есть коментарии.
LoRD6007 программа реализует график функции |sin(x)|+cos|x| есть масштаб(от 20 до 100) также присутствуют коментарии.
0
ЛоРД_Оледжан
Программист
56 / 54 / 15
Регистрация: 23.07.2009
Сообщений: 336
17.10.2009, 22:47 #12
LoRD6001 МУРАВЕЙНИК
Демонстрация свойств случайных чисел (центральная предельная теорема)
\колокообразная прямая
Разбиваем ось на небольшие интервалы и подсчитываем частоту попаданий случайного значения в
каждый интервал если кол-во опытов велико, то график частот будет выглядеть так как
требуется.
LoRD6002 ПАПОРОТНИК
Вывести изображение папоротника
Вероятностный графический алгоритм, основанный на построении множества с помощу четырех
преобразованныч координат точек на плоскости, каждое из которых применяется с определенной
вероятностью.
LoRD6003 Экран - сосуд с кипящей жидкостью. На дне в случайной точке образуеться пузырек; при движении вверх он растет, а
дойдя до поверхности лопается. Если два пузырька соприкасаются, они сливаются в один. Реализовать этот процесс.
0
dim-hj
28 / 25 / 1
Регистрация: 28.07.2009
Сообщений: 109
18.10.2009, 06:21 #13
Цитата Сообщение от vincent Посмотреть сообщение
Ещё одна простая программка для начинающих.
При нажатии на Enter плавно перемещает треугольник c вершинами (10,10);(10,100);(100,100) на 10 пунктов по X, и по Y.


Delay похоже зависит от компьютера, приходится подбирать значение, которое устраивает.
Если время очень важно можно использовать это.
Delay зависит от кривости TPL, а, точнее, CRT.TPU внутри него. Самая популярная версия — это кривой патч Клаусса Хартнегга. Его кривости есть оправдание, но он всё равно кривой.

Прилагаю для сравнения версию, скомпилированную с нормальными библиотеками. Задержку поменял на 100, иначе состариться можно, пока этот треугольник целую минуту на десять пикселов будет сдвигаться.
1
Ольга Куликова
0 / 0 / 0
Регистрация: 26.10.2009
Сообщений: 4
01.11.2009, 15:54 #14
Достаточно простой, но норм работающий. Для начинающих то что надо))

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
uses GraphABC;
 
var xx, yy, xx1, yy1, xx2, yy2, xx3, yy3: real;
    
begin
  var x1:= 50;
  var y1:= 50; 
  var x2:= 70;
  var y2:= 50;
  var x3:= 70;
  var y3:= 70;
  var x4:= 50;
  var y4:= 70;  
  var alfa:=0.5;
  while(true) do
    begin
      ClearWindow;
      {xx:= x1*cos(alfa) + y1*(-sin(alfa)) + (-20)*cos(alfa) + 20*sin(alfa) + 20;
      yy:= x1*sin(alfa) + y1*cos(alfa) + (-20)*sin(alfa) - 20*cos(alfa) + 20;}
      xx1:= x2*cos(alfa) + y2*(-sin(alfa)) + (-50)*cos(alfa) + 50*sin(alfa) + 50;
      yy1:= x2*sin(alfa) + y2*cos(alfa) + (-50)*sin(alfa) - 50*cos(alfa) + 50;
      Line(round(x1),round(y1),round(xx1),round(yy1));
      
      xx2:= x3*cos(alfa) + y3*(-sin(alfa)) + (-50)*cos(alfa) + 50*sin(alfa) + 50;
      yy2:= x3*sin(alfa) + y3*cos(alfa) + (-50)*sin(alfa) - 50*cos(alfa) + 50;
      Line(round(xx1),round(yy1),round(xx2),round(yy2));
      
      xx3:= x4*cos(alfa) + y4*(-sin(alfa)) + (-50)*cos(alfa) + 50*sin(alfa) + 50;
      yy3:= x4*sin(alfa) + y4*cos(alfa) + (-50)*sin(alfa) - 50*cos(alfa) + 50;
      Line(round(xx2), round(yy2), round(xx3), round(yy3));
      
      Line(round(xx3), round(yy3), round(x1), round(y1));
      
      alfa +=0.1;
      redraw;
     // sleep(1);
    
    end;
end.
0
ЛоРД_Оледжан
Программист
56 / 54 / 15
Регистрация: 23.07.2009
Сообщений: 336
02.11.2009, 00:02 #15
Пример программы, которая в текстовом режиме запрашивает значения десяти параметров и строит по ним столбиковую диаграмму (гистограмму) в графическом режиме.

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
program LoRD; {Построение столбиковой диаграммы}
uses Crt, Graph;
const Count=10;
Width =40; {Ширина столбца диаграммы}
var
I,X1,X2,Y1,Y2 : integer;
M : array[1..Count] of byte;
DriverVar, ModeVar: integer;
S_M : string;
begin
Writeln('Ввод данных (целые числа) для построения диаграммы');
for I:=l to Count do
begin
repeat {Ввод с контролем, входит ли введенное значение в [1..10]}
Write('Введите значение' , I, '-го параметра (от 1 до 10) :');
Readln(M[I]) ;
if not M[I] in [1..10] {Если введенное значение не входит в ин-тервал [1..10]}
then Writeln('Значение параметра должно быть от 1 до 10');
until M[I] in [1..10];
end;
27
DriverVar:=Detect; {Инициализация графического режима}
InitGraph(DriverVar,ModeVar,'');
SetViewPort(10,10,630,400,True); {Создать окно}
SetTextStyle(DefaultFont,HorizDir,1);
Yl:=325; {Построение гистограммы}
for I:=l to Count do {Повторять, пока не построим все столбики}
begin
XI:=I*50;
Str(M[I],S_M) ; {Преобразовать значение М[1] в строку для вы-вода в графическом режиме на экран}
SetFillStyle(I,I); {Задать стиль и цвет заполнения}
Bar3D(Xl,Yl,Xl+Width,Yl-M[I]*30,10,TopOn); {Построить столбико-вую диаграмму}
OutTextXY (X1+15,Y1-M[I]*3O-15,S_M); {Напечатать над столбиком значение отображаемой величины}
end; {Конец цикла}
{Вывод пояснительных надписей}
SetTextStyle(DefaultFont,HorizDir,2);
OutTextXY(150,20,'Пример гистограммы');
SetTextStyle(DefaultFont,VertDir,1);
OutTextXY(40,175,'Величина параметра');
SetTextStyle(DefaultFont,HorizDir,1);
OutTextXY(250,GetMaxY-140,'Параметры');
OutTextXY(150,GetMaxY-100,'Для завершения нажмите Enter');
Readln;
CloseGraph;
end.
0
ЛоРД_Оледжан
Программист
56 / 54 / 15
Регистрация: 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
ЛоРД_Оледжан
Программист
56 / 54 / 15
Регистрация: 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С
856 / 644 / 187
Регистрация: 03.03.2009
Сообщений: 1,154
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 / 9
Регистрация: 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
08.11.2009, 22:21
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
08.11.2009, 22:21
Привет! Вот еще темы с решениями:

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

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

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

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


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

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

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