Форум программистов, компьютерный форум, киберфорум
Наши страницы
Turbo Pascal
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг 4.82/1163: Рейтинг темы: голосов - 1163, средняя оценка - 4.82
EvgenVrn
0 / 0 / 0
Регистрация: 13.06.2012
Сообщений: 15
05.07.2012, 00:19 121
народ, будьте добры, где можно скачать книгу по турбо паскаль, мне надо граф выучить, скиньте ссылку на evgen-gorlov@mail.ru. Буду очень признателен
0
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
05.07.2012, 00:19
Ответы с готовыми решениями:

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

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

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

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

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

157
Puporev
Модератор
55444 / 42560 / 29412
Регистрация: 18.05.2008
Сообщений: 100,677
05.07.2012, 08:33 122
http://www.cyberforum.ru/attachments/3834d1241779566
1
Kodzaev
3008 / 1897 / 1646
Регистрация: 30.04.2011
Сообщений: 3,054
18.07.2012, 11:33 123
Программа демонстрирует работу процедур управления текстовым выводом на экран
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
program ColorTable;
 
uses
  Crt;{подключение к программе библиотеки Crt}
 
const
  P = ' ';
 
var
  i, j: Integer;
 
begin
  ClrScr; {очистка экрана}
  Window(1, 1, 80, 7); {определение окна для заголовочной части таблицы}
  TextColor(Yellow); {установка желтого цвета символов}
  GoToXY(24, 1); WriteLn('ТЕКСТОВЫЙ ВЫВОД НА ЭКРАН ДИСПЛЕЯ');
  GoToXY(30, 2); WriteLn('ТАБЛИЦА ЦВЕТНОСТИ');
  TextColor(LightCyan); {установка яркоголубого цвета символов}
  WriteLn('0-Черный ', P, '4-Красный ', P, '8-Темносерый ', P, '12-Розовый ');
  WriteLn('1-Синий ', P, '5-Фиолетовый ', P, '9-Яркосиний ', P, '13-Малиновый ');
  WriteLn('2-Зеленый ', P, '6-Коричневый ', P, '10-Яркозеленый ', P, '14-Желтый ');
  Write('3-Голубой ', P, '7-Светлосерый', P, '11-Яркоголубой', P, '15-Белый ');
  TextColor(3 + 128); WriteLn(' i+128-Мерцание'); TextColor(White);
  for i := 0 to 9 do {цикл по цветам фона таблицы цветности}
  begin
    Window(i * 8 + 1, 7, i * 8 + 8, 25); {oпределение окна для столбца таблицы}
    GoToXY(1, 1); {курсор в верхнем левом углу окна}
    TextBackGround(Black); {установка черного цвета фона}
    WriteLn(' Фон', i:2);
    WriteLn('----------');
    TextBackGround(i); {установка текущего цвета фона окна }
    for j := 0 to 15 do
    begin
      TextColor(j); {установка текущего цвета надписей в окне }
      WriteLn('цвет', j:2);
    end;
  end; NormVideo; ReadLn
end.

Программа демонстрирует возможности изображения линий в графическом режиме
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
program Lines;
 
uses
  Graph, Crt;{подключение к программе библиотек Crt и Graph} 
 
var
  Key: Char; 
  LineStyle: Word; {номер стиля рисования линии} 
  Style: String; {название стиля } 
  GrDriver, GrMode: Integer; {тип и режим работы графического драйвера} 
  GrError: Integer;{код ошибки графики} 
 
begin
  GrDriver := Detect; {автоопределение типа графического драйвера} 
  InitGraph(GrDriver, GrMode, 'C:\TP\BGI'); {установка графического режима} 
  GrError := GraphResult; 
  if GrError <> GrOk then begin
    Writeln('Обнаружена ошибка!'); Halt
  end; 
  SetBkColor(LightGray); SetColor(Red); {цвет фона и цвет рисования } 
  {------------------------------------------------------------} 
  OutTextXY(120, 100, 'Рисуем линию от точки (200,200) к точке (400,280)'); 
  Line(200, 200, 400, 280); 
  Key := ReadKey; {приостановление исполнения программы} 
  ClearViewPort; {очистка окна} 
  {-----------------------------------------------------------} 
  OutTextXY(240, 80, 'Рисуем ломанную'); 
  Rectangle(110, 120, 520, 400); {рисование рамки } 
  MoveTo(Round(GetMaxX / 2), Round(GetMaxY / 2)); {указатель в центре окна} 
  repeat {цикл прерывается нажатием любой клавиши} 
    LineTo(Random(GetMaxX - 250) + 120, Random(GetMaxY - 210) + 120); 
    Delay(100); 
  until KeyPressed; 
  Key := ReadKey; ClearViewPort; 
  {-----------------------------------------------------------} 
  OutTextXY(190, 80, 'Mеняем стили рисования линий'); 
  for LineStyle := 0 to 3 do 
  begin
    SetLineStyle(LineStyle, 0, 1); 
    case LineStyle of 
      0: Style := 'Сплошная'; 
      1: Style := 'Точечная'; 
      2: Style := 'Штрихпунктирная'; 
      3: Style := 'Пунктирная' 
    end; 
    Line(120, 150 + LineStyle * 50, 430, 150 + LineStyle * 50); 
    OutTextXY(450, 145 + LineStyle * 50, Style); 
  end; 
  Key := ReadKey; ClearViewPort; {очистка окна} 
  {-----------------------------------------------------------} 
  OutTextXY(180, 80, 'Меняем толщину рисования линий'); 
  SetLineStyle(0, 0, 1); {толщина 1 пиксел } 
  Line(140, 200, 430, 200); OutTextXY(450, 195, 'Нормальная'); 
  SetLineStyle(0, 0, 3); {толщина 3 пиксела} 
  Line(140, 250, 430, 250); OutTextXY(450, 245, 'Тройная'); 
  ReadLn; CloseGraph; {закрытие графического режима}
end.
2
Facenapalm
35 / 35 / 10
Регистрация: 22.02.2012
Сообщений: 71
18.07.2012, 14:49 124
Раз создали тему, выкладываю свои часики на турбо паскале. Тема избитая, да и реализация кривоватая, но, в принципе, моргание на современных компьютерах почти не заметно.

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
program clock;
uses CRT, DOS, graph;
var grdevice, grmode: integer;
    a: byte;
    h, m, s, s100, h1, m1, s1, tmp: word;
    t, sn, cs: real;
 
function inttostr(x: integer; bool: boolean): string;
 var ts: string[2];
 begin
  str(x, ts);
  if bool and (length(ts)=1) then ts:='0'+ts;
  inttostr:=ts;
 end;
 
procedure DrawLineFromCenter(x, y, min, max: word; angle: real);
 var a: real;
 begin
  a:=angle-pi/2;
  sn:=sin(a);
  cs:=cos(a);
  line(trunc(x+min*cs), trunc(y+min*sn), trunc(x+max*cs), trunc(y+max*sn));
 end;
 
begin
 initgraph(grdevice, grmode, '');
 setcolor(white);
 for a:=1 to 60 do DrawLineFromCenter(320, 240, 180, 190, a*pi/30);
 for a:=1 to 12 do
  begin
   t:=a*pi/6;
   setcolor(white);
   DrawLineFromCenter(320, 240, 180, 200, t);
   setcolor(lightcyan);
   outtextxy(trunc(320+cs*220), trunc(240+sn*220), inttostr(a, false));
  end;
 setcolor(lightcyan);
 outtextxy(555, 465, 'by Goodman');
 repeat
  gettime(h1, m1, s1, s100);
  if not ((h=h1) and (m=m1) and (s=s1)) then
   begin
    h:=h1;
    m:=m1;
    s:=s1;
    setcolor(0);
    setfillstyle(0, 0);
    fillellipse(320, 240, 170, 170);
    setcolor(lightgray);
    outtextxy(290, 399, inttostr(h, true)+':'+inttostr(m, true)+':'+inttostr(s, true));
    setcolor(blue);
    setlinestyle(0, 0, 3);
    DrawLineFromCenter(320, 240, 0, 90, h*pi/6+m*pi/360);
    setcolor(cyan);
    DrawLineFromCenter(320, 240, 0, 140, m*pi/30+s*pi/1800);
    setcolor(green);
    setlinestyle(0, 0, 1);
    DrawLineFromCenter(320, 240, 0, 169, s*pi/30);
   end;
 until keypressed;
 closegraph;
end.
1
Kodzaev
3008 / 1897 / 1646
Регистрация: 30.04.2011
Сообщений: 3,054
18.07.2012, 16:19 125
Эта программа демонстрирует возможности изображения символов в графическом режиме (требует наличия в текущем каталоге файлов шрифтов *.chr)
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
program Symbols;
 
uses
  Graph, Crt;{подключение к программе библиотек Crt и Graph} 
 
var
  Key: Char; 
  Font: String; {названия шрифтов } 
  Size, MyFont: Word; 
  GrDriver, GrMode: Integer;{тип и режим работы графического драйвера} 
 
begin
  GrDriver := Detect; {автоопределение типа графического драйвера} 
  InitGraph(GrDriver, GrMode, 'C:\TP\BGI'); {установка графического режима } 
  if GraphResult <> GrOk then Halt; 
  {-----------------------------------------------------------} 
  SetTextStyle(DefaultFont, HorizDir, 2); 
  OutTextXY(140, 80, 'Меняем размер символов'); 
  OutTextXY(220, 100, 'и цвет фона'); 
  for Size := 0 to 13 do {Size - цвет фона и размер символов} 
  begin
    SetBkColor(Size); {изменение цвета фона } 
    Rectangle(135, 425, 470, 450); {рисование рамки } 
    SetTextStyle(DefaultFont, HorizDir, 1); 
    OutTextXY(150, 435, 'Для продолжения нажмите любую клавишу !'); 
    SetTextStyle(DefaultFont, HorizDir, Size); 
    OutTextXY(250 - Size * 15, 200, 'HELLO'); 
    Key := ReadKey; ClearViewPort; 
  end; ReadLn; 
  {-----------------------------------------------------------} 
  SetBkColor(LightGray); SetColor(Red);{цвет фона и цвет рисования } 
  SetTextStyle(DefaultFont, HorizDir, 2); 
              {установка шрифта, направления и размера символов} 
  OutTextXY(70, 100, 'Располагаем строку горизонтально'); 
  SetTextStyle(DefaultFont, VertDir, 2); 
  OutTextXY(310, 150, 'и вертикально'); 
  Key := ReadKey; ClearViewPort; 
  {-----------------------------------------------------------} 
  SetTextStyle(DefaultFont, HorizDir, 2); 
              {установка шрифта, направления и размера символов} 
  OutTextXY(220, 30, 'Меняем шрифты'); 
  for MyFont := 0 to 9 do {цикл по номерам шрифтов} 
  begin
    case MyFont of 
      0: Font := '0 - Точечный (Default)'; 
      1: Font := '1 - Утроенный (Triplex)'; 
      2: Font := '2 - Уменьшенный (Small)'; 
      3: Font := '3 - Прямой (SansSerif)'; 
      4: Font := '4 - Готический (Gothic)'; 
      5: Font := '5 - Рукописный'; 
      6: Font := '6 - Курьер'; 
      7: Font := '7 - Красивый (Tаймс Italic)'; 
      8: Font := '8 - Таймс Roman'; 
      9: Font := '9 - Курьер увеличенный'; 
    end;
    SetTextStyle(MyFont, HorizDir, 2); 
    OutTextXY(40, 70 + MyFont * 35, 'abcdfxyz 0123456789');{вывод текста} 
    SetTextStyle(DefaultFont, HorizDir, 1); 
    OutTextXY(410, 80 + MyFont * 35, Font){вывод названия шрифта} 
  end; 
  OutTextXY(380, 60, 'N шрифта Описание'); ReadLn; 
  CloseGraph; {закрытие графического режима} 
end.

Эта программа рисует закрашенный прямоугольник, меняя случайным образом цвет, тип штриховки и высоту тона звукового сопровождения
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
program MusicColor;
 
uses
  Crt, Graph;{подключение к программе библиотек Crt и Graph} 
 
var
  GrDriver, GrMode: Integer;{тип и режим работы графического драйвера} 
 
begin
  GrDriver := Detect; {автоопределение типа графического драйвера} 
  InitGraph(GrDriver, GrMode, 'C:\TP\BGI'); {установка графического режима} 
  SetColor(White); {установка белого цвета рамки } 
  Rectangle(130, 130, 460, 370); {рисование рамки } 
  Randomize; {инициализация датчика случайных чисел} 
  repeat {цикл прерывается нажатием любой клавиши} 
    Sound(Random(2000)); {изменение высоты звука } 
    Delay(Random(1000)); {задержка } 
    SetFillStyle(Random(4), Random(16)); {смена типа штриховки и цвета} 
    Bar(140, 140, 450, 360); {рисование закрашенного прямоугольника} 
  until KeyPressed; 
  NoSound; {отмена звука } 
  CloseGraph; ReadLn; {закрытие графического режима} 
end.

Эта программа рисует на экране звезду и закрашивает её, используя 12 типов штриховки
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
program Star;
 
uses
  Crt, Graph;
       {подключение к программе библиотек Crt и Graph} 
const{ массив координат вершин многоугольника (звезды) } 
  TopsStar: Array[1..18] of Integer = (300, 125, 325, 225, 425, 250, 
          325, 275, 300, 375, 275, 275, 180, 250, 275, 225, 300, 125);
 
var
  i, j, GrDriver, GrMode: Integer;
 
begin
  GrDriver := Detect; 
  InitGraph(GrDriver, GrMode, 'C:\TP\BGI'); {установка графического режима} 
  SetTextStyle(DefaultFont, HorizDir, 2); {установка шрифта, 
                                           направления и размера символов} 
  OutTextXY(220, 60, 'S T A R '); 
  SetTextStyle(DefaultFont, VertDir, 2); 
  OutTextXY(140, 150, 'S T A R '); 
  SetTextStyle(DefaultFont, VertDir, 2); 
  OutTextXY(500, 150, 'S T A R '); 
  i := 0; 
  repeat 
    j := i mod 12; { j - остаток от деления i на 12 } 
    SetFillStyle(j, Random(13)); { штриховка и фон } 
    FillPoly(9, TopsStar); {рисование и штриховка звезды} 
    Inc(i); {увеличение i на 1} 
    Delay(500)
  until KeyPressed; {завершение цикла нажатием любой клавиши} 
  CloseGraph
end.

Программа демонстрирует получение эффекта движения изображения прицела под управлением клавишей-стрелок клавиатуры с выводом координат центра прицела.
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
program Sight;
 
uses
  Crt, Graph;{подключение к программе
 
                    библиотек Crt и Graph} 
const
  Step = 5; {шаг изменения координат центра прицела } 
  Instr = 'УПРАВЛЕНИЕ ДВИЖЕНИЕМ ПРИЦЕЛА - СТРЕЛКИ, ВЫХОД - ESC';
 
var
  GrDriver, GrMode: Integer; {тип и режим работы графического драйвера} 
  X, Y: Integer; {координаты центра прицела} 
  XStr, YStr: String; 
  Ch: Char;
{-----------------------------------------------------------} 
procedure MakeSight(X, Y: Integer);{процедура рисования прицела} 
begin
  SetColor(White); 
  Circle(X, Y, 80); 
  SetColor(LightGreen); 
  Line(X - 80, Y, X + 80, Y); Line(X, Y - 63, X, Y + 63); {вывод осей прицела} 
  SetColor(LightRed); Circle(X, Y, 2); {окружность в центре прицела}
  Str(X, XStr); Str(Y, YStr); {перевод координат в строковый тип} 
  SetColor(Yellow); 
  OutTextXY(X + 5, Y - 35, 'x=' + XStr); {вывод координат центра прицела } 
  OutTextXY(X + 5, Y - 20, 'y=' + YStr)
end;
{-----------------------------------------------------------} 
begin
  GrDriver := Detect; 
  InitGraph(GrDriver, GrMode, 'C:\TP\BGI'); 
  SetColor(LightGray); 
  X := GetMaxX div 2; Y := GetMaxY div 2; {координаты центра экрана} 
  Rectangle(50, 425, 600, 460); {рисование рамки } 
  OutTextXY(120, 440, Instr); 
  MakeSight(X, Y); {рисование прицела в центре экрана} 
  while TRUE do {цикл работы программы до прерывания по клавише ESC} 
  begin
    Ch := ReadKey; 
    case Ch of 
      #27: begin CloseGraph; Halt(1) end; {выход по клавише ESC} 
      #75: X := X - Step; {изменение координат x, y нажатием стрелок} 
      #77: X := X + Step; {"влево", "вправо", "вверх", "вниз" } 
      #72: Y := Y - Step; 
      #80: Y := Y + Step 
    end;
    ClearViewPort; { очистка графического экрана } 
    SetColor(LightGray); {восстановление рамки с надписью} 
    Rectangle(50, 425, 600, 460); 
    OutTextXY(120, 440, Instr); 
    MakeSight(X, Y){рисование прицела в текущих координатах} 
  end; CloseGraph; 
end.

Программа рисует человечка, делающего утреннюю зарядку
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
program Animation;
 
uses
  Crt, Graph;
       {подключение к программе библиотек Crt и Graph} 
const{вертикальные и горизонтальные координаты положения рук} 
  Vert: Array[1..3] of Integer = (190, 157, 120); 
  Horizont: Array[1..3] of Integer = (200, 190, 200);
 
var
  GrDriver, GrMode, GrError, i, j: Integer;
 
begin
  GrDriver := Detect; InitGraph(GrDriver, GrMode, 'C:\TP\BGI'); 
  GrError := GraphResult; if GrError <> GrOk then Halt; 
  SetColor(LightGray); { установка светлосерого цвета для рамки} 
  Rectangle(20, 20, 480, 400); {рисование рамки} 
  SetColor(LightCyan); {установка яркоголубого цвета для текста} 
  OutTextXY(200, 40, 'П Р И В Е Т !'); 
  SetColor(LightGray); Circle(250, 130, 20); {голова} 
  SetColor(Yellow); Arc(250, 130, 0, 180, 26); {волосы} 
  Arc(250, 130, 0, 180, 24); Arc(250, 130, 0, 180, 22); 
  Line(250, 105, 244, 115); Line(250, 105, 250, 116); {чубчик} 
  Line(250, 105, 256, 115); 
  SetColor(LightCyan); Circle(241, 125, 4); {левый глаз } 
  Circle(259, 125, 4); {правый глаз} 
  SetColor(LightRed); 
  SetFillStyle(SolidFill, LightRed); 
  FillEllipse(250, 140, 6, 3); {рот } 
  Setcolor(Green); 
  Line(250, 152, 250, 220); {туловище } 
  Line(250, 220, 210, 290); {левая нога } 
  Line(250, 220, 290, 290); {правая нога} 
  repeat {цикл прерывается нажатием любой клавиши} 
    for i := 1 to 3 do {Последовательный вывод трех положений рук:} 
    begin{ вниз, на уровне плеч, вверх } 
      SetColor(LightCyan); Sound(200 * i); 
      Line(250, 157, Horizont[i], Vert[i]); {левая рука} 
      Line(250, 157, 500 - Horizont[i], Vert[i]); {правая рука} 
      Delay(300); {задержка} 
      SetColor(Black); {смена цвета на черный для повторного 
                          pисования рук в том же положении 
                          ("стирания" их с экрана) } 
      Line(250, 157, Horizont[i], Vert[i]); {левая рука } 
      Line(250, 157, 500 - Horizont[i], Vert[i]); {правая рука} 
    end
  until Keypressed; 
  SetColor(LightCyan); 
  Line(250, 157, Horizont[3], Vert[3]); {левая рука поднята } 
  Line(250, 157, 500 - Horizont[3], Vert[3]); {правая рука поднята} 
  for i := 1 to 10 do { звуковая трель } 
  begin
    Sound(1000); 
    Delay(50); 
    Sound(1500); 
    Delay(50)
  end; 
  NoSound; { выключение звука } 
  CloseGraph;
end.

Эта программа демонстрирует возможности изображения объёмных предметов и столбиковых диаграмм
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
program Design;
 
uses
  Graph, Crt;{подключение к программе библиотек Crt и Graph} 
 
const
  Height: Array[1..8] of Integer = (40, 150, 90, 240, 190, 120, 50, 90);
                             {массив высот столбиков диаграммы} 
var
  Color: Word; {код цвета} 
  Key: Char; 
  i, x, y, y1, h: Integer; 
  GrDriver, GrMode: Integer; {тип и режим работы графического драйвера} 
  GrError: Integer;{код ошибки графики} 
 
begin
  GrDriver := Detect; InitGraph(GrDriver, GrMode, 'C:\TP\BGI'); 
  GrError := GraphResult; if GrError <> GrOk then Halt; 
  y := 120; h := 50; y1 := 140; 
  SetTextStyle(DefaultFont, HorizDir, 2); {шрифт, направление, размер} 
  OutTextXY(160, 20, 'Конструируем интерьер'); 
  SetFillStyle(5, LightRed); {тип штриховки и цвет (ярко красный)} 
  for i := 4 downto 1 do 
  begin{рисование параллелепипедов заданного размера} 
    Bar3D(75, y1 + i * h, 145, y1 + (i + 1) * h, 60, TopOff); Delay(200); 
  end; 
  Bar3D(75, y1, 145, y1 + h, 60, TopOn); Delay(200); 
  Bar3D(180, y, 290, y + h, 30, TopOn); Delay(200); 
  Bar3D(330, 225, 400, y + 4 * h, 30, TopOn); Delay(200); 
  Bar3D(300, y + 3 * h, 370, y + 5 * h, 30, TopOn); Delay(200); 
  Bar3D(370, y + 3 * h, 440, y + 5 * h, 30, TopOn); Delay(200); 
  Bar3D(300, y, 370, y + h, 30, TopOn); Delay(200); 
  Bar3D(370, y, 440, y + h, 30, TopOn); Delay(200); 
  Bar3D(442, y, 500, y + 5 * h, 30, TopOn); Delay(200); 
  Rectangle(135, 425, 470, 450); {рисование pамки для сообщения} 
  SetTextStyle(DefaultFont, HorizDir, 1); 
  OutTextXY(150, 435, 'Для продолжения нажмите любую клавишу !'); 
  Key := ReadKey; ClearViewPort; {очистка окна} 
  {-----------------------------------------------------------------} 
  SetTextStyle(DefaultFont, HorizDir, 2); 
  OutTextXY(100, 20, 'Рисуем столбиковую диаграмму'); 
  x := 50; Randomize; {инициализация датчика случайных чисел} 
  for i := 1 to 8 do {цикл по столбикам диаграммы} 
  begin
    Color := Random(12) + 1; {задание кода цвета (кроме черного)} 
    SetFillStyle(i, Color); {задание типа штриховки и цвета} 
    SetColor(Color); 
    Bar3D(x, 350 - Height[i], x + 50, 380, 20, TopOn); {рисование столбика} 
    x := x + 70; {изменение координаты x }; 
    Delay(200){задержка} 
  end; 
  Key := ReadKey; CloseGraph; {Закрытие графического режима}
end.

Эта программа демонстрирует работу с пикселами, случайными эллипсами и секторами.
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
program RandomFigures;
 
uses
  Graph, Crt;
 
var
  Key: Char; 
  GrDriver, GrMode: Integer; 
  Radius, MaxX, MaxY, Ugol: Word;{параметры процедур} 
 
begin
  GrDriver := Detect; {автоопределение типа графического драйвера} 
  InitGraph(GrDriver, GrMode, 'C:\TP\BGI'); {установка графического режима} 
  SetTextStyle(DefaultFont, HorizDir, 2); 
               {установка шрифта, направления и размера символов} 
  OutTextXY(160, 50, 'Рисуем звездное небо'); 
  Rectangle(110, 90, 520, 380); {рисование рамки } 
  Randomize; {инициализация датчика случайных чисел} 
  
  repeat {цикл прерывается нажатием любой клавиши} 
    PutPixel(Random(GetMaxX - 250) + 120, Random(GetMaxY - 210) + 100, 
    Random(15)); {вывод пикселя в области, ограниченной рамкой} 
    Delay(5){задержка} 
  until KeyPressed; 
  Key := ReadKey; ClearDevice; {очистка графического экрана} 
  {---------------------------------------------------------------} 
  SetColor(White); {цвет рисования} 
  OutTextXY(140, 30, 'Рисуем случайные эллипсы'); 
  Rectangle(100, 70, 560, 420); { рисование рамки } 
  MaxX := GetMaxX; 
  MaxY := GetMaxY; 
  Radius := MaxY div 10; 
  SetLineStyle(0, 0, 1); {толщина и стиль линии} 
  SetViewPort(101, 71, 559, 419, ClipOn); {установка окна внутри рамки} 
  Randomize; {инициализация датчика случайных чисел} 
  repeat {цикл прерывается нажатием любой клавиши} 
    SetBkColor(Black); {цвет фона } 
    SetColor(Random(13) + 1); {цвет рисования} 
    SetFillStyle(Random(12), Random(13) + 1); {образец и цвет штриховки} 
    FillEllipse(Random(MaxX), Random(MaxY), {координаты центра эллипса} 
    Random(Radius), Random(Radius)); {полуоси эллипса} 
  until KeyPressed; 
  Key := ReadKey; 
  ClearDevice; {очистка графического экрана} 
  {------------------------------------------------------------------} 
  SetColor(White); SetViewPort(1, 1, GetMaxX, GetMaxY, ClipOn); 
  OutTextXY(140, 20, 'Рисуем случайные секторы'); 
  Rectangle(90, 60, 570, 420); {рисование рамки} 
  SetViewPort(92, 62, 569, 419, ClipOn); {установка окна внутри рамки} 
  repeat {цикл прерывается нажатием любой клавиши} 
    SetFillStyle(Random(12), Random(13) + 1); {изменение штриховки и цвета} 
    Ugol := Random(360); {угол сектора} 
    Sector(Random(MaxX - 200), Random(MaxY - 180), Random(Ugol), Ugol, 
    Random(Radius * 2), Random(Radius * 2)); {рисование сектора} 
  until KeyPressed; 
  ClearViewPort; {очистка окна} 
  CloseGraph; {закрытие графического режима} 
end.

Программа изображает планету, вращающуюся вокруг Солнца на фоне мерцающих звезд и расходящейся галактики
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
program Space;{составил студент Тетуев Р., мат.фак. КБГУ}
 
uses
  Graph, Crt;
 
const
  RadOrb = 250{радиус орбиты Земли}; RadSun = 70{радиус Солнца};
  RadGal = 100{радиус галактики }; RadZem = 18{радиус Земли };
  Naklon = 0.2{коэффициент наклона плоскости орбиты Земли};
  PressZem = 0.65{коэффициент сплющенности полюсов Земли};
  Compress = 0.8 {коэффициент сжатия при переходе из };
                   {расширения режима VGA в режим CGA }
var
  ZemX, ZemY, UgMer, PixelY, DUgZem, UpDown,
  XRad, Grad, UgZem, PixelX, StAngle, Ua, Ub,
  ParallelY, Color, ZemPix, EndAngle,
  VisualPage, GrMode, GrError, GrDriver, i: Integer;
  Ugol, CompressZem, Expansion,
  DUgol, Projection, PolUgol: Real;
 
begin
  {установка графического режима и проверка возможных ошибок}
  GrDriver := EGA; GrMode := EGAHi;
  InitGraph(GrDriver, GrMode, 'C:\TP\BGI');
  GrError := GraphResult; if GrError <> GrOk then Halt;
  SetBkColor(Black);
  SetFillStyle(1, Yellow); {установка стиля заполнения и цвета Cолнцa}
  Ugol := 0; DUgol := 2 * Pi / 180; {орбитальное угловое смещение Земли}
  UgZem := 0; DUgZem := 14; {осевое угловое смещение Земли}
  {------------------------------------------------------------------}
  VisualPage := 1;
  repeat {цикл прерывается нажатием любой клавиши}
    SetVisualPage(1 - (VisualPage mod 2));
         {установка номера видимой видеостраницы}
    VisualPage := VisualPage + 1; {листание видеостраниц}
    SetActivePage(1 - (VisualPage mod 2));
         {установка номера невидимой (активной) видеостраницы,}
         {используемой для построения смещенного изображения }
    ClearDevice; {очистка графического экрана}
     {--------------------------------------------------------------}
    {Рисование "расходящейся" галактики}
    RandSeed := 1; {исходное значение датчика случайных чисел}
    Expansion := VisualPage / 100; {cкорость расширения галактики}
    for i := 1 to VisualPage do
    begin
      XRad := Trunc(Expansion * RadGal * Random);
             {текущее расстояние от звезды до центра галактики}
      PolUgol := 2 * Pi * Random - VisualPage / 30;
             {текущий центральный угол положения звезды галактики}
      PixelX := 370 + Trunc(XRad * cos(PolUgol + 1.8)); {координаты}
      PixelY := 250 + Trunc(XRad * 0.5 * sin(PolUgol)); { звезды }
      PutPixel(PixelX, PixelY, White){рисование звезды}
    end;
     {--------------------------------------------------------------}
    {Рисование мерцающих звезд}
    Randomize; {инициализация датчика случайных чисел}
    for i := 1 to 70 do
      PutPixel(Random(640), Random(350), White); {вспыхивающие звезды}
     {--------------------------------------------------------------}
    for i := 1 to 100 do {Рисование орбиты}
      PutPixel(320 + Round(RadOrb * cos((i + VisualPage / 5) * Pi / 50 + 0.3)),
      160 + Round(RadOrb * Naklon * sin((i + VisualPage / 5) * Pi / 50 - Pi / 2)), 15);
     {--------------------------------------------------------------}
    PieSlice(310, 160, 0, 360, RadSun); {Рисование Солнца}
     {--------------------------------------------------------------}
    {Рисование Земли (ее параллелей и меридианов)}
    Ugol := Ugol + DUgol; {угол поворота Земли относительно Солнца}
    Grad := Round(180 * Ugol / Pi) mod 360; {в рад.(Ugol) и в град.(Grad)}
    ZemX := 320 + Round(RadOrb * cos((Ugol + Pi / 2 + 0.3))); { координаты }
    ZemY := 160 + Round(RadOrb * Naklon * sin(Ugol)); {центра Земли}
    CompressZem := 2.5 - cos(Ugol + 0.3);
           {коэффициент учета удаленности Земли от наблюдателя}
    ZemPix := Round(RadZem * CompressZem); {текущий радиус Земли}
    UgZem := UgZem + DUgZem; {угол поворота Земли относительно своей оси}
    for i := 0 to 11 do { рисование меридианов }
    begin
      UgMer := (UgZem + i * 30) mod 360;
      if (90 < UgMer) and (UgMer < 270) {установка начального и конечного}
      then begin StAngle := 90; EndAngle := 270 end { углов дуги }
      else begin StAngle := 270; EndAngle := 90 end; {эллипса меридиана}
      Ua := (Grad + 220) mod 360; Ub := (Grad + 400) mod 360;
           {установка цветов рисования затененной и освещенной
            частей меридиана}
      Color := LightBlue;
      if Ua <= Ub then if (Ua < UgMer) and (UgMer < Ub) then Color := White;
      if Ua > Ub then if (Ua < UgMer) or (UgMer < Ub) then Color := White;
      SetColor(Color);
      XRad := round((ZemPix * cos(UgMer * Pi / 180))); 
      Ellipse(ZemX, ZemY, StAngle, EndAngle, abs(XRad), round(PressZem * ZemPix));
    end;
    for i := 2 to 7 do {рисование параллелей}
    begin
      XRad := abs(Round(ZemPix * sin(i * Pi / 9)));
           {большая полуось эллипса параллели}
      UpDown := Round(ZemPix * PressZem * cos(i * Pi / 9));
           {высота параллели над плоскостью экватора}
      ParallelY := ZemY + UpDown; {координата Y центра эллипса параллели}
      SetColor(LightBlue);
      Ellipse(ZemX, ParallelY, 0, 360, XRad, Round(Naklon * XRad));
           {затененная часть параллели}
      SetColor(White);
      Ellipse(ZemX, ParallelY, Grad + 220, Grad + 400, XRad, Round(Naklon * XRad));
      {освещенная часть параллели}
    end;
     {------------------------------------------------------------------}
    {Повторное рисование Cолнца, если оно ближе к наблюдателю, чем Земля}
    if CompressZem < 2 then PieSlice(310, 160, 0, 360, RadSun);
     {------------------------------------------------------------------}
    RandSeed := VisualPage mod 12;
    for i := 1 to 250 do {Рисование протуберанцев}
    begin
      Projection := (1 - sqr(Random)) * Pi / 2;
      XRad := RadSun + Round((20) * sin(Projection)) - 15;
      PolUgol := 2 * Pi * Random + VisualPage / 20;
        {PolUgol, XRad - полярные координаты протуберанца}
      PixelX := 310 + Round( XRad * cos(PolUgol));
      PixelY := 160 + Round( Compress * XRad * sin(PolUgol));
      PutPixel(PixelX, PixelY, LightRed)
    end;
  until KeyPressed
end.

Программа рисует прямоугольную систему координат, отображает в ней заданное множество точек и строит все возможные пары треугольников с вершинами в этом множестве такие, чтобы один треугольник лежал строго внутри другого
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
program Triangles;{Составил студент Тезадов С., 1 к. мат. фак. КБГУ}
 
uses
  Crt, Graph;
 
const
  DemoN = 10;
  DemoX: array [1..DemoN] of Integer = (20, 150, 90, 500, 50, 110, 370, 300, 70, 500);  
  DemoY: array [1..DemoN] of Integer = (20, 40, 300, 400, 380, 130, 290, 140, 60, 170);
 
var
  X, Y: Array[1..50] of Integer; {координаты точек множества}
  InX, InY: Array[1..50] of Integer; {координаты вершин внутренних}
  Flag: Boolean; {треугольников}
  Ch: Char;
  Coord, Num: String;
  i, j, k, p, i1, j1, k1, n, n1: Integer;
  GrDriver, GrMode, GrError: Integer;
{--------------------------}
procedure InputOutput;{Описание процедуры считывания координат точек
                        множества из текстового файла dan.dat в массивы 
                        X и Y и вывода точек на графический экран }
var
  f: Text;
  a, b: Real;
begin
  Assign(f, 'dan.dat'); {установление связи между физическим }
                         {файлом dan.dat и файловой пеpеменной f}
   {$I-}  {- отключаем автоматическую проверку существования файла}
  Reset(f); i := 0; {открытие файла f для чтения}
   {$I+}
  if IOResult = 0 then begin{если файл существует}
    while not eof(f) do {цикл "пока не будет достигнут конца файла"}
    begin
      Read(f, a, b); Inc(i); {считывание из файла f пары координат}
      X[i] := Trunc(a - 1); Y[i] := Trunc(428 - b){преобразование декартовых}
    end; {координат в координаты графического экрана}
    n := i; {n - количество введенных точек множества}
    Close(f); {закрытие файла f}
  end
  Else begin{если файла не существует, то используем множество точек,}
    n := DemoN; {заданное в DemoN, DemoX, DemoY.}
    for i := 1 to DemoN do 
    begin
      x[i] := DemoX[i];
      y[i] := 428 - DemoY[i];
    end;
  end;
  SetColor(LightCyan);
  OutTextXY(200, 30, 'ИСХОДНОЕ МНОЖЕСТВО ТОЧЕК');
  for i := 1 to n do {рисование и нумерация точек множества}
  begin
    Circle(X[i], Y[i], 2);
    Str(i, Num); OutTextXY(X[i] + 4, Y[i] + 3, Num)
  end;
  Ch := ReadKey; ClearViewPort; {очистка графического окна}
end;{of InputOutput}
{--------------------------}
procedure Drawing_Axes;{описание процедуры рисования осей координат}
begin
  SetColor(White);
  MoveTo(30, 0); LineTo(30, 430); LineTo(639, 430); {оси ОХ,OY}
  OutTextXY(27, 0, '^'); OutTextXY(630, 427, '>'); {стрелки осей OX, OY}
  SetColor(LightGreen);
  OutTextXY(18, 0, 'y'); OutTextXY(630, 434, 'x');
  OutTextXY(25, 433, '0');
  SetColor(LightMagenta); {установка розового цвета}
  for i := 1 to 20 do {нанесение делений и числовых отметок на ось OY}
  begin
    Str(20 * (21 - i), Coord); j := i * 20 + 10;
    OutTextXY(2, j - 5, Coord);
    Line(28, j, 30, j)
  end;
  for i := 1 to 29 do {нанесение делений и числовых отметок на ось OX}
  begin
    Str(20 * i, Coord); j := i * 20 + 30;
    if Odd(i) then OutTextXY(j - 8, 436, Coord); Line(j, 430, j, 432)
  end;
  SetViewPort(31, 4, 630, 429, FALSE){установка текущего графического окна}
end;{of Drawing_Axes}
{--------------------------}
function Inside(i, j, k, p: Integer ): Boolean;
   {функция Inside возвращает TRUE, если точка с номером p
    находится внутри треугольника с вершинами в точках i, j, k}
var
  S1, S2: Real;
      {---------------------------------------------------}
  function Area(x1, y1, x2, y2, x3, y3: Real): Real;
    {функция вычисления площади треугольника}
    {с вершинами в точках (x1,y1), (x2,y2), (x3,y3)}
  begin
    Area := abs((x1 * (y2 - y3) + x2 * (y3 - y1) + x3 * (y1 - y2)) / 2)
  end;{of Area}
 {--------------------------------------------------------}
begin
  S1 := Area(X[i], Y[i], X[j], Y[j], X[k], Y[k]);
      {S1 - площадь треугольника с вершинами в точках i, j, k}
  S2 := Area(X[i], Y[i], X[j], Y[j], X[p], Y[p]) +
         Area(X[j], Y[j], X[k], Y[k], X[p], Y[p]) + 
         Area(X[k], Y[k], X[i], Y[i], X[p], Y[p]);
      {S2 - сумма площадей трех треугольников с вершинами
       в точках (i,j,p), (j,k,p), (i,k,p) }
  Inside := S1 > S2 - 0.001
end;{of Inside}
{--------------------------}
procedure Triangle(x1, y1, x2, y2, x3, y3: Integer; Color: Byte);
begin{описание процедуры рисования треугольника цвета Color}
  SetColor(Color); 
  Line(x1, y1, x2, y2);
  Line(x2, y2, x3, y3);
  Line(x3, y3, x1, y1)
end;{of Triangle}
{--------------------------}
begin
  GrDriver := Detect;
  InitGraph(GrDriver, GrMode, 'C:\TP\BGI');
  GrError := GraphResult;
  if GrError <> GrOk then begin WriteLn(' Ошибка графики!'); Halt end;
  Drawing_Axes; {вызов процедуры рисования осей координат}
  InputOutput; {вызов процедуры ввода и вывода исходных данных}
  Flag := FALSE;
  for i := 1 to n - 2 do {циклы по номерам вершин внешнего треугольника}
    for j := i + 1 to n - 1 do
      for k := j + 1 to n do
      begin
        SetColor(LightCyan); {установка яркоголубого цвета}
        for p := 1 to n do {рисование и нумерация точек множества}
        begin
          Circle(X[p], Y[p], 2); {рисование точки}
          Str(p, Num);
          OutTextXY(X[p] + 4, Y[p] + 3, Num){вывод номера точки}
        end;
        n1 := 0; {занесение координат точек, находящихся
                  внутри треугольника, в массивы InX и InY}
        for i1 := 1 to n do
        begin
          if (i1 <> i) and (i1 <> j) and (i1 <> k) and Inside(i, j, k, i1)
          then begin
            Inc(n1); InX[n1] := X[i1]; InY[n1] := Y[i1]
          end;
        end;
        if n1 >= 3 then {если число точек внутри треугольника не меньше трех,}
        begin
          Flag := TRUE; {то строятся внутренние треугольники}
          for i1 := 1 to n1 - 2 do {циклы по номерам вершин внутренних}
            for j1 := i1 + 1 to n1 - 1 do {треугольников}
              for k1 := j1 + 1 to n1 do
              begin{рисование внешнего треугольника красным цветом}
                Triangle(X[i], Y[i], X[j], Y[j], X[k], Y[k], LightRed);
                  {рисование внутреннего треугольника зеленым цветом}
                Triangle(InX[i1], InY[i1], InX[j1], InY[j1], InX[k1], InY[k1],
                         LightGreen);
                OutTextXY(80, 450, 'Найдено решение. Нажмите любую клавишу!');
                Ch := ReadKey;
                SetColor(Black); {"стирание" сообщения}
                OutTextXY(80, 450, 'Найдено решение. Нажмите любую клавишу!');
                  {"стирание" внутреннего треугольника}
                Triangle(InX[i1], InY[i1], InX[j1], InY[j1], InX[k1], InY[k1],
                         Black)
              end{конец циклов по номерам вершин внутренних треугольников}
        end;
           {"стирание" внешнего треугольника}
        Triangle(X[i], Y[i], X[j], Y[j], X[k], Y[k], Black)
      end; {конец циклов по номерам вершин внешнего треугольника}
  SetColor(White);
  if not Flag then OutText('Для данного множества нет решений задачи')
  else OutText('РАБОТА ПРОГРАММЫ ЗАВЕРШЕНА');
  OutTextXY(80, 450, ' Нажмите любую клавишу ...');
  Ch := ReadKey;
  CloseGraph{закрытие графического режима} 
end.
3
karlsonnakrishe
50 / 50 / 41
Регистрация: 20.08.2012
Сообщений: 123
12.09.2012, 21:25 126
программка рисует звезду, количество лучей, размер, положение, цвет, размеры большого и малого радиусов можно изменять непосредственно в самой программе.

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
uses graph,crt;
var
 gd,gm: integer;
 x,y,n,rs,rb,color: integer;
 i,a,b,x1,x2,y1,y2,ytext: integer;
 c: char;
 stop: boolean;
 
procedure zvezda;
begin
 a:=1;  {эти переменные изменяются при построении звезды, нужны для вычисления координаты следующей вершины}
 b:=1;
 x2:=x;
 y2:=y-rb;
 for i:=1 to n do
  begin
   x1:=x+round(rs*(sin(360/n/2/180*pi*a))); {rs - малый радиус. вычисление координаты точки на малом радиусе}
   y1:=y-round(rs*(cos(360/n/2/180*pi*a)));
 
   line(x2,y2,x1,y1);
 
   x2:=x+round(rb*(sin(360/n/180*pi*b)));
   y2:=y-round(rb*(cos(360/n/180*pi*b)));  {То же самое на большом радиусе}
 
   line(x1,y1,x2,y2);
 
   a:=a+2; b:=b+1;
  end;
 settextstyle(3,0,2);
 outtextxy(0,0,'press F1 to help');
 
end;
 
begin
 randomize;
 stop:=false;
 x:=320; y:=240;
 color:=random(15)+1; rb:=50; rs:=10; n:=4;
 
 gd:=detect;
 initgraph(gd,gm,'');
 
 setcolor(color);
 zvezda;
 
 repeat
  if keypressed then
   begin
  cleardevice;
  c:=readkey;
 
  case c of
   '1': begin dec(x,5); inc(y,5); end;
   '2': inc(y,5);
   '3': begin inc(x,5); inc(y,5); end;
   '4': dec(x,5);
   '5': begin x:=320; y:=240; end;
   '6': inc(x,5);
   '7': begin dec(x,5); dec(y,5); end;
   '8': dec(y,5);
   '9': begin dec(y,5); inc(x,5); end;
   '+': begin inc(rs,2); inc(rb,5); end;
   '-': begin dec(rs,2); dec(rb,5); end;
   'x': stop:=true;
   #9: begin
         if color<15 then
          color:=color+1
         else
          color:=1;
         setcolor(color);
       end;
   'a': dec(rs,5);
   'q': inc(rs,5);
   'w': inc(rb,5);
   's': dec(rb,5);
   'e': inc(n);
   'd': dec(n);
   #59: begin
         setcolor(white);
         ytext:=0;
         outtextxy(0,ytext,'1-9: изменение положения фигуры');
         inc(ytext,textheight('1')+5);
         outtextxy(0,ytext,'''+'' и ''-'': изменение размеров.');
         inc(ytext,textheight('1')+5);
         outtextxy(0,ytext,'''q'' и ''a'': изменение радиуса вписанной окружности.');
         inc(ytext,textheight('1')+5);
         outtextxy(0,ytext,'''w'' и ''s'': изменение радиуса описанной окружности.');
         inc(ytext,textheight('1')+5);
         outtextxy(0,ytext,'''e'' и ''d'': изменение количества лучей.');
         inc(ytext,textheight('1')+5);
         outtextxy(0,ytext,'Tab для изменения цвета.');
         inc(ytext,textheight('1')+5);
         outtextxy(0,ytext,'''x'' для выхода.');
         inc(ytext,textheight('1')+5);
         outtextxy(0,450,'Enter для продолжения.');
         readln;
         cleardevice;
        end;
  end;
  end;
  zvezda;
 
  until stop;
 
end.
Добавлено через 22 часа 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
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
uses crt, graph;
const
 x0 = 150; {константы для прорисовки клеток поля}
 y0 =70;
 
 
type
 
 t = record
  x: integer;
  y: integer;
 end;
 
var
  telo: array[1..200] of t; {массив записей, номер элемента массива - это номер клетки тела змеи, в записи координаты (поля, а не абсолютные)}
  gd,gm, temp: integer;
  x,y, i,j, xvar, yvar, variable, xeda, yeda: integer;
  COUNT: integer; {кол-во клеток в теле змеи}
  right,left,up,down,stop: boolean;
  c: char;
  s: string;
 
 
 
procedure skorost; {начальный экран - графический выбор скорости (1-10)}
var
 c: char;
 x1, y1, x2, y2, count: integer;
begin
 
 settextstyle(7,0,3);
 outtextxy(80,50,'Скорость (enter для продолжения):');
 x1:=230; x2:=240;
 y1:=290; y2:=300;
 count:=5;
 setfillstyle(1, red);
 for i:=1 to 5 do
  begin
   bar(x1,y1,x2,y2);
   inc(x1,20); inc(x2,20);
   dec(y1,10);
  end;
 
 setfillstyle(1,7);
 for i:=1 to 5 do
  begin
   bar(x1,y1,x2,y2);
   inc(x1,20); inc(x2,20);
   dec(y1,10);
  end;
 
 
 repeat
  if keypressed then
   begin
    c:=readkey;
    if (c=#77) and (count<10) then
     begin
      inc(count);
      setfillstyle(1, red);
      bar(210+count*20,300-count*10,220+count*20, 300);
     end;
 
    if (c=#75) and (count>1) then
     begin
       setfillstyle(1,7);
       bar(210+count*20,300-count*10,220+count*20, 300);
       dec(count);
     end;
   end;
 until c=#13;
 temp:=25+(5*(10-count));
end;
 
 
procedure pokraska_blue(xx, yy: integer); {синий цвет - змея. хх,уу координаты поля}
begin
 setfillstyle(1, blue);
 bar3d(xx*8+x0,yy*8+y0, xx*8+7+x0, yy*8+7+y0,0,topoff); {Закрашивает клетку поля, перевод из координат поля в абсолютные координаты}
 setfillstyle(1, green);
end;
 
procedure pause; {эта процедурка для похоронного марша, не обращайте особого внимания}
begin
 nosound;
 delay(50);
end;
 
procedure pokraska_green(xx,yy: integer); {аналогично покраске в синий цвет, только это - клетки поля}
 begin
  bar3d(xx*8+x0,yy*8+y0, xx*8+7+x0, yy*8+7+y0,0,topoff);
 end;
 
procedure obed; {обед - и в африке обед}
begin
 randomize;
 setfillstyle(1, red);
 repeat
   xeda:=random(41)+1;
   yeda:=random(41)+1;
 until (not (getpixel(xeda*8+x0+5, yeda*8+y0+5)=1)); {еда не должна совпадать с телом змеи}
 bar3d(xeda*8+x0,yeda*8+y0, xeda*8+7+x0, yeda*8+7+y0,0,topoff);
 setfillstyle(1, green);
end;
 
procedure poh; {финальный эпизод}
const
 c=131;
 d=147;
 ddiez=156;
 h=123;
begin
 closegraph;
 gotoxy(35,12);
 textcolor(7);
 write('GAME OVER');
 gotoxy(36,14); write('счёт: ',count-5);
 delay(500);
 sound(c); delay(700); nosound; delay(100); {Похоронный марш}
 sound(c); delay(600); nosound; delay(100);
 sound(c); delay(100); nosound; delay(100);
 sound(c); delay(700); pause;
 sound(ddiez); delay(500); pause;
 sound(d); delay(150); pause;
 sound(d); delay(500); pause;
 sound(c); delay(150); pause;
 sound(c); delay(500); pause;
 sound(h); delay(200); pause;
 sound(c); delay(1000); pause;
end;
 
 
procedure auto; {автоматическое продвижение змеи}
begin
 repeat
    if keypressed then break;
    pokraska_green(telo[1].x,telo[1].y);
    xvar:=telo[1].x; yvar:=telo[1].y;
 
     if up then dec(telo[1].y);   {в зависимости от того, куда едет змея, меняются координаты головы}
     if left then dec(telo[1].x);
     if right then inc(telo[1].x);
     if down then inc(telo[1].y);
 
     for i:=2 to count do
      if (telo[1].x=telo[i].x) and (telo[1].y=telo[i].y) then poh; {если врезалась в свой хвост - смерть}
 
 if (telo[1].x<1) or (telo[1].x>41) or (telo[1].y<1) or (telo[1].y>41) then poh; {в стену - аналогично}
 
    pokraska_blue(telo[1].x, telo[1].y); {новое положение головы}
 
    for i:=2 to count do
    begin
    if i=count then  {если передвигается последняя клетка хвоста, то прежнее её место заливаем зелёным}
     pokraska_green(telo[i].x, telo[i].y);
     pokraska_blue(xvar,yvar);
     variable:=xvar; xvar:=telo[i].x; telo[i].x:=variable; {перемещение значений в записи на соответствующие клетке значения}
     variable:=yvar; yvar:=telo[i].y; telo[i].y:=variable;
    end;
 
    if (telo[1].x=xeda) and (telo[1].y=yeda) then {если пообедал, то включаем звук, меняем счёт, добавляем клетку к телу и даём новую цель}
    begin
     sound(500);
     inc(count);
     telo[count].x:=xvar; telo[count].y:=yvar;
     pokraska_blue(xvar,yvar);
     setfillstyle(1, black);
     str(count-5,s);
     bar(550,100,580,130);
     setcolor(white);
     outtextxy(550,100,s);
     setcolor(black);
     setfillstyle(1,green);
     obed;
     delay(50);
     nosound;
    end;
    delay(temp);
   until 2=0;
end;
 
procedure key_prob;
begin
 c:=readkey; {меняем направление стрелками}
 
 if (c=#72) and (not(down))  then begin up:=true; down:=false; left:=false; right:=false; end;
 if (c=#75) and (not(right)) then begin up:=false; down:=false; left:=true; right:=false; end;
 if (c=#80) and (not(up))    then begin up:=false; down:=true; left:=false; right:=false; end;
 if (c=#77) and (not(left))  then begin up:=false; down:=false; left:=false; right:=true; end;
 
end;
 
{==============================ИНИЦИАЛИЗАЦИЯ=================================}
 
begin  {начало самой программы}
 gd:=detect;
 initgraph(gd,gm,'');
 skorost;  {выбор скорости}
 str(temp,s);  {даём предварительные значения всяким разным переменным}  
 cleardevice;
 setfillstyle(1, green);
 settextstyle(7,0,3);
 outtextxy(520,70,'СЧЁТ: ');
 outtextxy(550,100,'0');
 x:=x0; y:=y0;
 setlinestyle(0,0,1);
 setcolor(black);
 left:= true;
 right:= false;
 up:= false;
 down:= false;
 randomize;
 count:=5;
 
 for i:=1 to 41 do
   for j:= 1 to 41 do
    begin
     pokraska_green(i,j); {создание игрового поля}
    end;
 
 for i:=1 to 5 do
  begin
   telo[i].x:= i+18;
   telo[i].y:=21;;
   pokraska_blue(telo[i].x,telo[i].y);
  end;
 
  obed;
 
{================================MOVE======================================}
 
repeat
  auto;
  key_prob;
until 2=0;
 
end.
P.S. у кого-то с этого форума не запускалась, возникала ниеизвестная мне "run time error", сам писал в скулпаке, т.к. под семёркой другие разновидности паскаля отказывались работать в графическом режиме, комментировал специально сюда, поэтому некоторые строки может слишком длинны, так сотрите комменты к коду... если хоть кто-нибудь будет проверять, просьба - отпишитесь хотя б в личку...
2
domovou2.0
Дзæуджыхъæу
231 / 203 / 148
Регистрация: 20.09.2012
Сообщений: 421
Записей в блоге: 1
05.11.2012, 17:10 127
программа про летающее нло
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
uses crt, graph;
type
    zv=record
             x,y:integer;
             end;
const
     r=20;
     pause=65000;
var i1,d,m,e,xm,ym,x,y,kx,ly,lx,rx,ry,size,i,dx,dy,width,height:integer;
    saucer:pointer;
    mas:array [1..200] of zv;
begin
randomize;
d:=detect; m:=detect;
initgraph(d,m,'c:\bp\bgi');
e:=graphresult;
if e <> grok then writeln(grapherrormsg(e))
   else
   begin
   x:=r*5;
   y:=r*2;
   xm:=getmaxx div 4; ym:=getmaxy div 4;
   ellipse (x,y,0,360,r,r div 3+2);
   ellipse (x,y-4,190,357,r,r div 3);
   line(x+7,y-6,x+10,y-12);
   line(x-7,y-6,x-10,y-12);
   circle(x+10,y-12,2);
   circle(x-10,y-12,2);
   floodfill(x+1,y+4,white);
   lx:=x-r-1;
   ly:=y-14;
   rx:=x+r+1;
   ry:=y+r div 3+3;
   width:=rx-lx+1;
   height:=ry-ly+1;
   size:=imagesize(lx,ly,rx,ry);
   getmem(saucer,size);
   getimage(lx,ly,rx,ry,saucer^);
   putimage(lx,ly,saucer^,xorput);
   rectangle(xm+1,ym+1,3*xm-1,3*ym-1);
   setviewport(xm+1,ym+1,3*xm-1,3*ym-1,clipon);
   xm:=2*xm; ym:=2*ym;
   for i1:=1 to 200 do
       begin
       mas[i1].x:=random(xm);
       mas[i1].y:=random(ym);
       end;
       {putpixel(random(xm),random(ym),green);}
       x:=xm div 2; y:=ym div 2;
       dx:=10; dy:=10;
       repeat
             putimage(x,y,saucer^,xorput);
             for i1:= 1 to 150 do
                 delay(pause);
             putimage(x,y,saucer^,xorput);
             x:=x+dx; y:=y+dy;
             for i1:=1 to 200 do
                 putpixel(mas[i1].x,mas[i1].y,random(16));
             if (x<0) or (x+width+1>xm) or (y<0) or (y+height+1>ym)
             then
             begin
             setcolor(random(16));
             rectangle(0,0,316,236);
             end;
             while (x<0) or (x+width+1>xm) or (y<0) or (y+height+1>ym) do
                   begin
                   x:=x-dx; y:=y-dy;
                   dx:=getmaxx div 10 - random(getmaxx div 5);
                   dy:=getmaxy div 30 - random (getmaxy div 15);
                   end;
             until keypressed;
   closegraph;
   end
end.
1
Puporev
05.11.2012, 18:32
  #128

Не по теме:

Цитата Сообщение от domovou2.0 Посмотреть сообщение
pause=65000;
Устарело лет на 20.....

0
aleksskay
13 / 13 / 11
Регистрация: 10.08.2011
Сообщений: 226
Записей в блоге: 1
10.11.2012, 21:09 129
нужно попасть в многоугольники.
не очень хотелось думать .
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
   Program CirclePolet;
   uses crt,graph;
   type
       circle1 = object
         x, y:integer;
         center1,center2:boolean;
         rx,ry, count:integer;
         colortoc:word;
         Procedure tochka;
         Procedure create(a,b:integer);  {dlya dvigeniya kruga}
         Procedure move(dx,dy:integer);
         Procedure Mnogougolnik;
         Procedure Mnogougolnik2;
         Procedure Mnogougolnik3;
         Procedure Krug(zx,zy:integer);
         Procedure rectan;
         Procedure ellip(nach,kon,RadX,RadY:integer);
      end;
 
   Procedure   Circle1.create(a,b:integer);
     begin
       x:=a;
       y:=b;
 
     end;
 
  Procedure circle1.tochka;
  begin
    setcolor(getcolor);
    circle(x,y,10);
  end;
 
 
  Procedure  Circle1.move(dx,dy:integer);
    var
     rx2, ry2,rx3,ry3,rx4, ry4,rx5, ry5,a,b:integer;
     rx6, ry6, rx7, ry7,rx8, ry8, rx9,ry9,rx10, ry10,rx11,ry11:integer;
     rx12,ry12, I,rx13,ry13:integer;
     button : char;
   begin
      a := x +dx;
      b := y + dy;
       setcolor(getbkcolor);
       circle(x,y,10);
 
       if a > 630  then x:= 630 else
         if  a < 10  then x:=10 else
           x:=a;
       if b > 470 then y:=470 else
         if b < 12 then y:=12 else
           y:=b;
 
        setcolor(15);
        circle(x,y,10);
        if ((x >= 42) and  (x <= 55))  and ( y in [125..135])          then
          center1 := true;
        if ((x >= 542 ) and (x <= 555)) and (y in [125..135]) then
        center2 := true;
        if (center1)  and (center2) then
        begin
         setcolor(15);
          settextstyle(0,0,3);
          outtextxy(200,100, 'Vi Vigrali !');
          setcolor(15);
       end;
 
         setcolor(white);
         circle(x, y,10);
         setfillstyle(1,red);
         floodfill(x + 1,y +1,white);
         { Muchaemsya dlya vivoda message "Vi Proigrali"}
         rx:=  x+2;  ry := y - 11 ;  rx2 := x +9; ry2 := y - 8;
         rx3 :=  x +  10;   ry3 := y - 6;
         rx4 := x + 11; ry4 := y; rx5 := x + 9; ry5 := y + 2;
         rx6 := x + 5; ry6 := y + 6;  rx12 := x + 6; ry12 := y + 9;
         rx7 := x; rY7 := y + 11;
         rx8 := x - 2; ry8 := y + 8;  rx9 := x - 7; ry9 := y + 6;
         rx9 := x - 11; ry9 := y;  rx10 := x - 8 ; ry10 := y -2;
         rx11 := x - 8; rY11 := y - 4; rx13 := x - 6 ;  ry13 := y - 10;
 
         for i:=1 to 1 do
         begin
           colortoc := getpixel(rx,ry);
           if colortoc = 15 then break;
           colortoc := getpixel(rx2,ry2);
           if colortoc = 15 then break;
            colortoc := getpixel(rx3,ry3);
           if colortoc = 15 then break;
            colortoc := getpixel(rx4,ry4);
           if colortoc = 15 then break;
            colortoc := getpixel(rx5,ry5);
           if colortoc = 15 then break;
            colortoc := getpixel(rx6,ry6);
           if colortoc = 15 then break;
            colortoc := getpixel(rx7,ry7);
           if colortoc = 15 then break;
            colortoc := getpixel(rx8,ry8);
           if colortoc = 15 then break;
            colortoc := getpixel(rx9,ry9);
           if colortoc = 15 then break;
            colortoc := getpixel(rx10,ry10);
           if colortoc = 15 then break;
            colortoc := getpixel(rx11,ry11);
           if colortoc = 15 then break;
            colortoc := getpixel(rx12,ry12);
           if colortoc = 15 then break;
            colortoc := getpixel(rx13,ry13);
           if colortoc = 15 then break;
        end;
 
          if colortoc = 15 then
        begin
           setcolor(15);
           settextstyle(0,0,3);
           outtextxy(200,200,'Vi Proigrali !');
           setcolor(15);
 
           repeat   {dlya "Exit"}
             button := readkey;
             if button = #0 then
             button := readkey;
           until button = #27;
        end;
   end;
 
 
  Procedure circle1.Mnogougolnik;
  const
    mnog:array [1..9] of pointtype =
    ((x:35;y:100),(x:60;y:100),(x:75; Y:115),(x:75; y:140)
    ,(x: 60;y:155),(x:35;y:155),(x:20;Y:140),(x:20;y:115),(x:35;y:100));
  var
    r:integer;
 
  begin
    drawpoly(9,mnog);
  end;
 
  Procedure circle1.Mnogougolnik2;
  const
    mnog:array [1..9] of pointtype =
    ((x:535;y:100),(x:560;y:100),(x:575; Y:115),(x:575; y:140)
    ,(x: 560;y:155),(x:535;y:155),(x:520;Y:140),(x:520;y:115),(x:535;y:100));
  var
    r:integer;
 
  begin
    drawpoly(9,mnog);
  end;
 
  Procedure circle1.Mnogougolnik3;
  const
    treug:array [1..6] of pointtype =
    ((x:150; y:300),(x:200;y:250),(x:250;y:300),(x:250;Y:400),
    (x:150; y:400),(x:150;y:300));
 
  begin
    drawpoly(6,treug);
    setfillstyle(1,14);
    floodfill(200,290,white);
  end;
 
  Procedure circle1.krug(zx,zy:integer);
   var
      n3,n2,n:integer;
 
    begin
      N:=random(3)+10;
      n2:=random(4) +12;
      n3:=random(3) +12;
      randomize;
      setcolor(13);
      circle(48,128,8);
      setfillstyle(2,14);
      floodfill(49,128,13);
      setfillstyle(2,12);
      circle(547, 128,8);
      floodfill(547,128,13);
      setcolor(15);
      case count of
       1 :begin
            zx := 145;
            zy:=175;
            circle(zx,zy,40);
            setfillstyle(1,n);
            floodfill(zx+1,zy+1,white);
            zx := 350;
            zy := 350;
            circle(zx,zy,40);
            setfillstyle(1,n2);
            floodfill(zx+1,zy+1,white);
            zx :=550  ;
            zy :=200  ;
            circle(zx,zy,40);
            setfillstyle(1,n3);
            floodfill(zx+1,zy+1,white);
          end;
        2 : begin
              zx := 200;
              zy := 150;
              circle(zx,zy,40);
              setfillstyle(1,n3);
              floodfill(zx+1,zy+1,white);
              zx := 350;
              zy := 390;
              circle(zx,zy,40);
              setfillstyle(1,n2);
              floodfill(zx+1,zy+1,white);
              zx :=590  ;
              zy :=200  ;
              circle(zx,zy,40);
              setfillstyle(1,n2);
              floodfill(zx+1,zy+1,white);
              zx := 120  ;
              zy := 200  ;
              circle(zx,zy,40);
              setfillstyle(1,n);
              floodfill(zx+1,zy+1,white);
              zx := 40  ;
              zy := 220  ;
              circle(zx,zy,40);
              setfillstyle(1,n2);
              floodfill(zx+1,zy+1,white);
            end;
 
         3: begin
              zx := 160;
              zy := 170;
              circle(zx,zy,40);
              setfillstyle(1,n3);
              floodfill(zx+1,zy+1,white);
              zx := 310;
              zy := 415;
              circle(zx,zy,40);
              setfillstyle(1,n);
              floodfill(zx+1,zy+1,white);
              zx :=550  ;
              zy :=200  ;
              circle(zx,zy,40);
              setfillstyle(1,n2);
              floodfill(zx+1,zy+1,white);
              circle1.mnogougolnik3;
              zx := 90;
              zy := 345;
              circle(zx,zy,40);
              setfillstyle(1,n2);
              floodfill(zx+1,zy+1,white);
            end;
        end;
     end;
 
  Procedure circle1.rectan;
  var
    x2, y2,x3,y3:integer;
    n3,n2,n:integer;
 
    begin
        N:=random(3)+10;
        n2:=random(4) +12;
        n3:=random(3) +12;
      case count of
        1 :begin
             x2:=15;   x3 := 100;
             y2 := 220; y3 := 400;
           rectangle(x2,y2,x3,y3);
           setfillstyle(1,1);
           floodfill(x2+1,y2+1,white);
           x2 := 450;   x3 := 500;
           y2 := 220;   y3 := 24;
           rectangle(x2,y2,x3,y3);
           setfillstyle(1,1);
           floodfill(x2+10,y2-10,white);
         end;
 
        2 :begin
             x2:=450;   x3 := 500;
             y2:=5; y3 := 100;
             rectangle(x2,y2,x3,y3);
             setfillstyle(1,2);
             floodfill(x2+1,y2+1,white);
             x2:=352;   x3 := 399;
             y2:=176;     y3 := 250;
             rectangle(x2,y2,x3,y3);
             setfillstyle(1,2);
             floodfill(x2+1,y2+1,white);
         end;
 
         3 :begin
             x2:=450;   x3 := 500;
             y2:=28;      y3 := 180;
             rectangle(x2,y2,x3,y3);
             setfillstyle(1,3);
             floodfill(x2+1,y2+1,white);
             x2:=350;   x3 := 630;
             y2:=250;      y3 := 280;
             rectangle(x2,y2,x3,y3);
             setfillstyle(1,3);
             floodfill(x2+1,y2+1,white);
           end;
       end;
     end;
 
  Procedure circle1.ellip(nach,kon,radX,RadY:integer);
    var
      x4,y4:integer;
      x6,y6:integer;
      x7,y7:integer;
      n3,n2,n:integer;
 
    begin
        randomize;
        N:=random(3)+10;
        n2:=random(4) +12;
        n3:=random(3) +12;
        case count of
          1:begin
                x4 := 310;
                y4 := 80;
                ellipse(x4,y4,nach,kon,radX,radY);
                setfillstyle(1,n);
                floodfill(x4 + 1, y4 +1,white);
                x4 := 150;
                y4 := 50;
                ellipse(x4,y4,nach,kon,100,radY);
                setfillstyle(1,n2);
                floodfill(x4 + 1, y4 +1,white);
                x6:=250;
                y6:=160;
                ellipse(x6,y6,nach,kon,radX,RadY);
                setfillstyle(1,n3);
                floodfill(x6 + 1, y6 +1,white);
                x7 := 595;
                y7 := 300;
                ellipse(x7,y7,nach,kon,radX,RadY);
                setfillstyle(1,n);
                floodfill(x7 + 1, y7 +1,white);
             end;
          2 : begin
                x4 := 480;
                y4 := 180;
                ellipse(x4,y4,nach,kon,58,radY);
                setfillstyle(1,n);
                floodfill(x4 + 1, y4 +1,white);
                x6 := 350;
                y6 := 100;
                ellipse(x6,y6,nach,kon,radX,RadY);
                setfillstyle(1,n3);
                floodfill(x6 + 1, y6 +1,white);
                x7 := 580;
                y7 := 380;
                ellipse(x7,y7,nach,kon,radX,RadY);
                setfillstyle(1,n3);
                floodfill(x7 + 1, y7 +1,white);
                x7 := 80;
                y7 := 380;
                ellipse(x7,y7,nach,kon,radX,RadY);
                setfillstyle(1,n2);
                floodfill(x7 + 1, y7 +1,white);
                x7 := 110;
                y7 := 55;
                ellipse(x7,y7,nach,kon,81,RadY);
                setfillstyle(1,n);
                floodfill(x7 + 1, y7 +1,white);
             end;
 
         3:begin
              x4 := 100;
              y4 := 70;
              ellipse(x4,y4,nach,kon,radX,radY);
              setfillstyle(1,n3);
              floodfill(x4 + 1, y4 +1,white);
              x6:=90;
              y6:=230;
              ellipse(x6,y6,nach,kon,radX,RadY);
              setfillstyle(1,n);
              floodfill(x6 + 1, y6 +1,white);
              x7 := 500;
              y7 := 350;
              ellipse(x7,y7,nach,kon,radX,RadY);
              setfillstyle(1,n2);
              floodfill(x7 + 1, y7 +1,white);
              x7 := 320;
              y7 := 150;
              ellipse(x7,y7,nach,kon,120,RadY);
              setfillstyle(1,n);
              floodfill(x7 + 1, y7 +1,white);
 
            end;
        end;
    end;
  var
    i,j:integer;
    c:char;
    Cir:circle1;
    x5,y5:integer;
    red:boolean;
 
  BEGIN    {Osnovnoy block programmi }
    randomize;
    i:=0; cir.count:=random(3) + 1;
    cir.center1:=false;
    cir.center2:= false;
    red := false;
    initgraph(i,j,'');
    setcolor(2);
    cir.mnogougolnik;
    cir.mnogougolnik2;
    setfillstyle(1,4);
    floodfill(40,123,2);
    setfillstyle(1,5);
    floodfill(540,123,2);
    setcolor(15);
    cir.krug(x5,y5);
    cir.rectan;
    cir.ellip(0,360,40,50);
    cir.create(320,240);
    cir.tochka;
 
    repeat
 
      c:=readkey;
        if c = #0 then
      c:=readkey;
      case c of
        #72:  cir.move(0,-1);
        #80:  cir.Move(0,1) ;
        #75:  cir.Move(-1,0) ;
        #77:  cir.Move(1,0);
        #59: begin
                if red = false then
                begin
                  outtextxy(365,435,'NUGNO POPAST V KRUGI MNOGOUGOLNIKA');
                  red := true;
                end
                 else
                 begin
                    setcolor(0);
                    outtextxy(365,435,'NUGNO POPAST V KRUGI MNOGOUGOLNIKA');
                    setcolor(15);
                    red := false;
                 end;
              end;
      end;
    until c = #13;
    closeGraph;
  end.
1
Шпилька
1 / 1 / 0
Регистрация: 15.05.2012
Сообщений: 71
02.01.2013, 17:03 130
А по 3-D объектам в Pascal случайно ничего нет?
0
m_ak_si_m
3 / 3 / 1
Регистрация: 11.10.2012
Сообщений: 33
16.01.2013, 15:15 131
"Выстрел пушки" с учетом скорости.
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
uses
 crt, graph;
 var
  a,gd,gm,v: integer;
  rast1: real;
  {------------------------------------------}
procedure pushka(x,y:integer);
var
  Radius: Integer;
begin
    setcolor(red);
  for Radius := 1 to 2  do
    Circle(x, y, Radius * 10);
  line(x,y-20,x+35,y-50);
  line(x+35,y-50,x+45,y-35);
  line(x+45,y-35,x+15,y-10);
end;
{-----------------------------------}
procedure mishen( Radius : Integer);
var
  i : Integer;
  fl: boolean;
begin
{mishen}
 
  fl:=true;
  for I:=1 to (getmaxy-100) do   {vniz}
  begin
       setcolor(white);
       for Radius := 1 to 5 do
 
       Circle(getmaxx-100, 50+i, Radius * 10);
       delay (50);
 
       if keypressed then
        if readkey=#13 then
       begin
         fl:=false;
         break;
       end;
       setcolor(black);
       for Radius := 1 to 5 do
        Circle(getmaxx-100, 50+i, Radius * 10);
end;
    if fl then
    for I:=(getmaxy-100) downto 50 do   {vverh}
  begin
       setcolor(white);
       if fl then
       for Radius := 1 to 5 do
        Circle(getmaxx-100, 50+i, Radius * 10);
       delay (50);
       if keypressed then
        if readkey=#13 then
     begin
         fl:=false;
         break;
     end;
       setcolor(black);
       if fl then
        for Radius := 1 to 5 do
         Circle (getmaxx-100, 50+i, Radius * 10);
 
  end;
end;
{-------------------------------------------------------------}
procedure yadro(v:integer);
var
 i: longint;
 x,y,t:real;
 
begin
  t:=0;
  for i:=1 to 90 do
  begin
   t:=t+0.1;
   setcolor(red);
   setfillstyle(9,red);
   x:=round(v*cos(round(45*pi/180))*t);
   y:=int(round(v*sin(45*pi/180)*t)-9.8*sqr(t)/2);
  fillellipse(round((x)+95),round(getmaxy-95-(y)),10,10);
   delay(35);
   setcolor(black);
   setfillstyle(1,black);
  fillellipse(round((x)+95),round(getmaxy-95-(y)),10,10);
  end;
  end;
begin
 writeln('vvedite v');
 readln(v);
 Gd := Detect;
  InitGraph(Gd, Gm, 'X:\BP');
  if GraphResult <> grOk then
    Halt(1);
 
  pushka(50,getmaxy-50);
  mishen(10);
  yadro(v);
 
  readln;
  closegraph;
end.
1
Kodzaev
3008 / 1897 / 1646
Регистрация: 30.04.2011
Сообщений: 3,054
03.02.2013, 19:24 132
Мигающий светофор с таймером
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
uses
  Graph, Crt;
 
var
  d, r, x, y: integer;
 
procedure Mig;
var
  i: byte;
  s: string;
begin
  for i := 3 downto 1 do
  begin
    Str(i, s);
    SetFillStyle(1, Black);
    FillEllipse(GetMaxX div 2, GetMaxY div 2 + 120, 50, 50);
    SetFillStyle(1, DarkGray);
    Bar(GetMaxX div 2 + 100, GetMaxY div 2 - 50, GetMaxX div 2 + 200, GetMaxY div 2 + 50);
    Delay(500);
    SetFillStyle(1, Green);
    FillEllipse(GetMaxX div 2, GetMaxY div 2 + 120, 50, 50);
    OutTextXY(GetMaxX div 2 + 150, GetMaxY div 2, s);
    Delay(500);
  end;
  SetFillStyle(1, Black);
  FillEllipse(GetMaxX div 2, GetMaxY div 2 + 120, 50, 50);
end;
 
procedure Wait;
var
  i: byte;
  s: string;
begin
  i := 10;
  Str(i, s);
  SetFillStyle(1, DarkGray);
  repeat
    OutTextXY(GetMaxX div 2 + 150, GetMaxY div 2, s);
    Dec(i);
    Str(i, s);
    Delay(1000);
    Bar(GetMaxX div 2 + 100, GetMaxY div 2 - 50, GetMaxX div 2 + 200, GetMaxY div 2 + 50);
  until i = 0;
end;
 
procedure WaitGreen;
var
  i: byte;
  s: string;
begin
  i := 10;
  Str(i, s);
  SetFillStyle(1, DarkGray);
  repeat
    OutTextXY(GetMaxX div 2 + 150, GetMaxY div 2, s);
    Dec(i);
    Str(i, s);
    Delay(1000);
    Bar(GetMaxX div 2 + 100, GetMaxY div 2 - 50, GetMaxX div 2 + 200, GetMaxY div 2 + 50);
  until i = 3;
end;
 
begin
  d := Detect;
  InitGraph(d, r, ' ');
  x := GetMaxX div 2;
  y := GetMaxY div 2;
  SetFillStyle(1, DarkGray);
  Rectangle(x - 100, y - 200, x + 100, y + 200);
  Bar(x + 100, y - 50, x + 200, y + 50);
  Circle(x, y - 120, 50);
  Circle(x, y, 50);
  Circle(x, y + 120, 50);
  SetTextStyle(7, 0, 5);
  repeat
    SetFillStyle(1, Red);
    FillEllipse(x, y - 120, 50, 50);
    Wait;
    SetFillStyle(1, Black);
    FillEllipse(x, y - 120, 50, 50);
    SetFillStyle(1, Yellow);
    FillEllipse(x, y, 50, 50);
    Delay(2000);
    SetFillStyle(1, Black);
    FillEllipse(x, y, 50, 50);
    SetFillStyle(1, Green);
    FillEllipse(x, y + 120, 50, 50);
    WaitGreen;
    Mig;
    SetFillStyle(1, DarkGray);
    Bar(x + 100, y - 50, x + 200, y + 50);
    SetFillStyle(1, Yellow);
    FillEllipse(x, y, 50, 50);
    Delay(2000);
    SetFillStyle(1, Black);
    FillEllipse(x, y, 50, 50);
  until KeyPressed;
  Readln
end.
2
Vovk_Vladislav
10 / 10 / 7
Регистрация: 20.09.2012
Сообщений: 173
14.02.2013, 01:37 133
Вот "мини-мультик", анимация со звуком. При запуске программы нужно ввести код - 5889.
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
uses graph,crt;
 var her,hek, y_gor,j,i,x_tree,y_tree,x_dom,y_dom,x_tar,y_tar:integer;
       simvol1,simvol2,simvol3,simvol4:char;
 procedure derevo;
  begin setcolor(brown);
  {STVOL} ReCTANGLe(X_TRee,y_tree,x_tree+10,y_tree-40);
  setfillstyle(1,brown);floodfill(x_tree+1,y_tree-1,brown);
  setcolor(10);
     {krona}  circle(x_tree+5,y_tree-40,25);
     setfillstyle(1,10);floodfill(x_tree+5,y_tree-20,10);   end;
procedure dom;
 begin
 setcolor(brown);
  {stenu} rectangle (x_dom,y_dom,x_dom+40,y_dom-40);
          setfillstyle(1,11);floodfill(x_dom+1,y_dom-1,brown);
    {okna} setcolor(brown);
            rectangle(x_dom+15,y_dom-15,x_dom+25,y_dom-30);
            setfillstyle(1,8);floodfill(x_dom+16,y_dom-16,brown);
 
         {krusha}   setcolor(black);
                line(x_dom-10,y_dom-40,X_dom+50,y_dom-40);
               line( x_dom-10,y_dom-40,x_dom+20,Y_dom-80);
               line(x_dom+20,y_dom-80,x_dom+50,y_dom-40);
               setfillstyle(1,red);floodfill(x_dom+40,y_dom-45,black);  end;
procedure fon;
 begin
 setcolor(blue);
   line (0,y_gor,640,y_gor);{gorizont}
setfillstyle(1,green);floodfill(5,y_gor+15,blue);
setfillstyle(1,blue);floodfill(1,1,blue);
 x_tree:=70;y_tree:=y_gor+80; derevo;
 X_tree:=220;y_tree:=y_gor+140; derevo;
 x_tree:=600;y_tree:=y_gor+220;derevo;
 x_tree:=550;y_tree:=y_gor+50;derevo;
 x_dom:=100;y_dom:=y_gor+200;dom;
 x_dom:=490;y_dom:=y_gor+160;dom;
 x_dom:=320;y_dom:=y_gor+100;dom;
  {zvezdu} for i:=1 to 250 do begin putpixel(random(640),random(y_gor),white); end;
 {luna}setcolor (yellow);circle (550,50,40);setfillstyle(1,yellow);floodfill(550,50,yellow);
 
  end;
procedure zvuk;
 begin
  sound(200);delay(1000);
  sound(500);delay(1000);
  sound(300);delay(1000);
  nosound end;
 procedure tar_ris;
  begin
    setcolor(6);
   ellipse(x_tar,y_tar,0,180,45,30) ;
   ellipse(x_tar,y_tar+5,0,360,80,40);
      line(x_tar-50,y_tar,x_tar+50,y_tar);
      setfillstyle(2,8);floodfill(x_tar+1,y_tar+1, 6);
          setfillstyle(9,7);floodfill(x_tar+1,y_tar-6, 6);end;
procedure tarelka;
 begin
    repeat
     tar_ris;
  setcolor(blue);  delay(20);
       ellipse(x_tar,y_tar,0,180,45,30) ;
      ellipse(x_tar,y_tar+5,0,360,80,40);
       line(x_tar-50,y_tar,x_tar+50,y_tar);
      setfillstyle(2,8);floodfill(x_tar+1,y_tar+1, blue);
       setfillstyle(9,7);floodfill(x_tar+1,y_tar-6, blue);
       putpixel(random(x_tar),90+random(145-90),white);
         x_tar:=x_tar+1;
  until x_tar=250;
      repeat
         tar_ris;
      setcolor(blue);  delay(40);
 
      ellipse(x_tar,y_tar,0,180,45,30) ;
      ellipse(x_tar,y_tar+5,0,360,80,40);
       line(x_tar-50,y_tar,x_tar+50,y_tar);
      setfillstyle(2,8);floodfill(x_tar+1,y_tar+1, blue);
       setfillstyle(9,7);floodfill(x_tar+1,y_tar-6, blue);
     y_tar:=y_tar+1;
     until y_tar> y_gor-80;
 
      end;
{nachalo}
 
  Begin
  Writeln ('Vvedite kod dlya zapuska  ');
   simvol1:=readkey;simvol2:=readkey;simvol3:=readkey;simvol4:=readkey;
  if not ((simvol1='5') and(simvol2='8') and(simvol3='8') and (simvol4='9')) then halt;
 
  y_gor:=240; x_tar:=50;y_tar:=120;
   her:=0; initgraph(her,hek, '');
  directvideo:=false;
 fon;
 zvuk;
 tarelka; tar_ris;
 zvuk;
 for i:=1 to 15 do begin
  setcolor(yellow);
            rectangle(x_dom+15,y_dom-15,x_dom+25,y_dom-30);
            setfillstyle(1,yellow);floodfill(x_dom+16,y_dom-16,yellow);
            delay(150);
                       setcolor(brown);
            rectangle(x_dom+15,y_dom-15,x_dom+25,y_dom-30);
            setfillstyle(1,8);floodfill(x_dom+16,y_dom-16,brown);
            delay (150);
            end;
 readln;
 closegraph;
 end.
3
leshiy1993
0 / 0 / 0
Регистрация: 06.04.2013
Сообщений: 1
09.04.2013, 22:42 134
Написал вот зд комнатку с кубиками. Есть перспективная проекция. Тоесть зависимость от Зед координаты.
Управление:
t-закраска граней вкл/выкл
р- автоматическое передвижение кубиков
(далее для 1 кубика)
w - вперёд
s - назад
a - влево
d - вправо
+ - увеличить в 2 раза
- - уменьшить в 2 раза
далее повороты относительно осей. на нам паде желательно.
8 -X
6 Y
4 -Y
2 -X
7 -XY
9 -YX
1 XY
3 YX

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
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
uses graph, crt;
 
const
  num_kubs=1;    {количество кубиков}
  KARKAS=0;
  SOLID=1;
 
type
   point_type=record
         x,y,z:real;
       end;
   poligon_type=record
                 num_points:integer;
                 color:integer;
                 point:array[1..4] of point_type;
               end;
   object_type=record        {описание 3д объекта}
                 num_poligons:integer;
                 x0,z0,y0:real;
                 poligon:array[1..6] of poligon_type;
                 visible:boolean;
               end;
   {эти матрицы нужны для поворота точек объекта}
   point_matrix_type=array[1..4] of real;
   change_matrix_type=array[1..4,1..4] of real;
   
   mnogo_kubikov=array [1..num_kubs] of object_type;
var
  kub:mnogo_kubikov;
  r:array[1..num_kubs] of integer;
  page,i,j,t,fil,k:integer;
  vv:char;
  mat1,mat3:point_matrix_type;
  mat2:change_matrix_type;
  flag:boolean;
 
  {рисует либо каркасный либо закрашенный}
procedure Draw_object(obj:object_type; fil:integer);
type
dots=record
x,y:integer;
end;
var
i,j:integer;
sqare:array[1..4] of dots;
begin
  if fil=1 then
  with obj do
  begin
    for i:=1 to num_poligons do
      with poligon[i] do
      begin
      for j :=1 to num_points do
      begin
        sqare[j].x:=getmaxx div 2-round(300*(getmaxx/2-x0-point[j].x)/(z0+point[j].z));
        sqare[j].y :=getmaxy div 2-round(300*(getmaxy/2-y0-point[j].y)/(z0+point[j].z));
      end;
      SetFillStyle(solidfill,color);
      setcolor(10);
      fillpoly(num_points,sqare);
      end;
  end
  else
  with obj do
  begin
    for i:=1 to num_poligons do
      with poligon[i] do
      begin
 
        setcolor(color);
        for j:=1 to num_points-1 do
        if (z0+point[j].z>10)and(z0+point[j+1].z>10) then
          line(getmaxx div 2-round(300*(getmaxx/2-x0-point[j].x)/(z0+point[j].z)),
               getmaxy div 2-round(300*(getmaxy/2-y0-point[j].y)/(z0+point[j].z)),
               getmaxx div 2-round(300*(getmaxx/2-x0-point[j+1].x)/(z0+point[j+1].z)),
 
               getmaxy div 2-round(300*(getmaxy/2-y0-point[j+1].y)/(z0+point[j+1].z)));
 
              if (z0+point[1].z>10)and(z0+point[num_points].z>10) then
        line(getmaxx div 2-round(300*(getmaxx/2-x0-point[num_points].x)/(z0+point[num_points].z)),
               getmaxy div 2-round(300*(getmaxy/2-y0-point[num_points].y)/(z0+point[num_points].z)),
               getmaxx div 2-round(300*(getmaxx/2-x0-point[1].x)/(z0+point[1].z)),
               getmaxy div 2-round(300*(getmaxy/2-y0-point[1].y)/(z0+point[1].z)));
      end;
  end;
 
end;
 
 
{рисует комнатку }
procedure Draw_Field;
var
i,j:integer;
xp,yp:real;
begin
  for i:=-10 to 10 do
  begin
    setcolor(8);
    line(getmaxx div 2-round(300*(-i*10)/100),
         getmaxy div 2-round(300*(-50)/100),
         getmaxx div 2-round(300*(-i*10)/300),
         getmaxy div 2-round(300*(-50)/300));
  end;
  for i:=10 to 30 do
  begin
    setcolor(8);
    line(getmaxx div 2-round(300*(100)/(i*10)),
         getmaxy div 2-round(300*(-50)/(i*10)),
         getmaxx div 2-round(300*(-100)/(i*10)),
         getmaxy div 2-round(300*(-50)/(i*10)));
  end;
 
  for i:=-10 to 10 do
  begin
    setcolor(8);
    line(getmaxx div 2-round(300*(-i*10)/100),
         getmaxy div 2-round(300*(50)/100),
         getmaxx div 2-round(300*(-i*10)/300),
         getmaxy div 2-round(300*(50)/300));
  end;
  for i:=10 to 30 do
  begin
    setcolor(8);
    line(getmaxx div 2-round(300*(100)/(i*10)),
         getmaxy div 2-round(300*(50)/(i*10)),
         getmaxx div 2-round(300*(-100)/(i*10)),
         getmaxy div 2-round(300*(50)/(i*10)));
  end;
 
  for i:=10 to 30 do
  begin
    setcolor(8);
    line(getmaxx div 2-round(300*(100)/(i*10)),
         getmaxy div 2-round(300*(-50)/(i*10)),
         getmaxx div 2-round(300*(100)/(i*10)),
         getmaxy div 2-round(300*(50)/(i*10)));
  end;
  for i:=10 to 30 do
  begin
    setcolor(8);
    line(getmaxx div 2-round(300*(-100)/(i*10)),
         getmaxy div 2-round(300*(-50)/(i*10)),
         getmaxx div 2-round(300*(-100)/(i*10)),
         getmaxy div 2-round(300*(50)/(i*10)));
  end;
  if flag then
  begin
  setfillstyle(solidfill,green);
  fillellipse(20,15,5,5);
  end;
end;
 
{перемещает объект в пространстве}
procedure Translate_Object(var obj:object_type; dx,dy,dz:real);
begin
  obj.x0:=obj.x0+dx;
  obj.y0:=obj.y0+dy;
  obj.z0:=obj.z0+dz;
end;
 
{умножает матрицу координат на матрицу изменения}
procedure Mat_Mult(matrix1:point_matrix_type; matrix2:change_matrix_type; var rezult:point_matrix_type);
 
var j,k:integer;
begin
  for j:=1 to 4 do
  begin
    rezult[j]:=0;
    for k:=1 to 4 do
      rezult[j]:=rezult[j]+matrix1[k]*matrix2[k,j];
  end;
end;
 
{изменяет объект}
procedure Change_Object(var obj:object_type);
var i,j:integer;
begin
for i:=1 to obj.num_poligons do
    for j:=1 to obj.poligon[i].num_points do
    begin
      mat1[1]:=obj.poligon[i].point[j].x;
      mat1[2]:=obj.poligon[i].point[j].y;
      mat1[3]:=obj.poligon[i].point[j].z;
      mat1[4]:=1;
 
      Mat_Mult(mat1,mat2,mat3);
 
      obj.poligon[i].point[j].x:=mat3[1];
      obj.poligon[i].point[j].y:=mat3[2];
      obj.poligon[i].point[j].z:=mat3[3];
    end;
end;
 
{Увеличивает объект}
procedure Scale_Object(var obj:object_type; scale:real);
 
var i,j:integer;
 
begin
  for i:=1 to 4 do
    for j:=1 to 4 do
      mat2[i,j]:=0;
  mat2[1,1]:=scale;
  mat2[2,2]:=scale;
  mat2[3,3]:=scale;
  mat2[4,4]:=1;
 
  Change_Object(obj);
end;
 
{вращает объект относительно оси ИКС}
procedure X_Rotate_Object(var obj:object_type; angle:real);
 
var
  cs,sn:real;
  i,j:integer;
 
begin
  cs:=cos(angle);
  sn:=sin(angle);
  for i:=1 to 4 do
    for j:=1 to 4 do
      mat2[i,j]:=0;
  mat2[1,1]:=1;
  mat2[2,2]:=cs;
  mat2[2,3]:=sn;
  mat2[3,2]:=-sn;
  mat2[3,3]:=cs;
  mat2[4,4]:=1;
 
  Change_Object(obj);
end;
 
 
{вращает объект относительно оси ИГРИК}
procedure Y_Rotate_Object(var obj:object_type; angle:real);
 
var
  cs,sn:real;
  i,j:integer;
 
begin
cs:=cos(angle);
  sn:=sin(angle);
  for i:=1 to 4 do
    for j:=1 to 4 do
      mat2[i,j]:=0;
  mat2[1,1]:=cs;
  mat2[1,3]:=-sn;
  mat2[2,2]:=1;
  mat2[3,1]:=sn;
  mat2[3,3]:=cs;
  mat2[4,4]:=1;
 
  Change_Object(obj);
end;
 
{вращает объект относительно оси Зед}
procedure Z_Rotate_Object(var obj:object_type; angle:real);
 
var
  cs,sn:real;
  i,j:integer;
 
begin
cs:=cos(angle);
  sn:=sin(angle);
  for i:=1 to 4 do
    for j:=1 to 4 do
      mat2[i,j]:=0;
  mat2[1,1]:=1;
  mat2[1,2]:=sn;
  mat2[2,1]:=-sn;
  mat2[2,2]:=cs;
  mat2[4,4]:=1;
 
  Change_Object(obj);
end;
 
 
{Пробная процедура для сортировки всех кубиков
по расстоянию от наблюдателя. нужно для поочерёдной прорисовки.
Что-то типа Z буффера. Не идеальная штука, поэтому я закоментировал её
в программе.}
procedure Dist_Sort(var obj:mnogo_kubikov; low,high:integer);
var
m,wsp:Object_type;
i,j:integer;
begin
  i:=low;
  j:=high;
  m:=obj[(i+j) div 2];
  repeat
    while sqrt(sqr(obj[i].x0-getmaxx/2)+sqr(obj[i].y0-getmaxy/2)+
    sqr(obj[i].z0))<sqrt(sqr(m.x0-getmaxx/2)+sqr(m.y0-getmaxy/2)+
    sqr(m.z0)) do Inc(i);
    while sqrt(sqr(obj[j].x0-getmaxx/2)+sqr(obj[j].y0-getmaxy/2)+
    sqr(obj[j].z0))>sqrt(sqr(m.x0-getmaxx/2)+sqr(m.y0-getmaxy/2)+
    sqr(m.z0)) do Dec(j);
    if i<=j then begin
      wsp:=obj[i];
      obj[i]:=obj[j];
      obj[j]:=wsp;
      Inc(i);
      Dec(j);
    end;
  until i>j;
  if low<j then Dist_Sort(obj,low,j);
  if i<high then Dist_Sort(obj, i, high);
end;
 
begin
{VGA хорош, потому что там 2 видеостраницы
На одной он рисует, а другую показывает. Потом меняет их.}
  i:=vga;
  j:=vgamed;
  initgraph(i,j,'');
  randomize;
  
{описание всех кубиков}
  for k:=1 to num_kubs do
  with kub[k] do
  begin
  {kube}
    num_poligons:=6;
    x0:=getmaxx/2;
    y0:=getmaxy/2+50;
    z0:=200;
    for i:=1 to num_poligons do
    begin
      poligon[i].color:=random(14)+1;
      poligon[i].num_points:=4;
    end;
 
    poligon[1].point[1].x:=0;
    poligon[1].point[1].y:=0;
    poligon[1].point[1].z:=0;
    poligon[1].point[2].x:=0;
    poligon[1].point[2].y:=0;
    poligon[1].point[2].z:=10;
    poligon[1].point[3].x:=10;
    poligon[1].point[3].y:=0;
    poligon[1].point[3].z:=10;
    poligon[1].point[4].x:=10;
    poligon[1].point[4].y:=0;
    poligon[1].point[4].z:=0;
 
    poligon[2].point[1].x:=0;
    poligon[2].point[1].y:= 0;
    poligon[2].point[1].z:=10;
    poligon[2].point[2].x:=0;
    poligon[2].point[2].y:=-10;
    poligon[2].point[2].z:=10;
    poligon[2].point[3].x:=10;
    poligon[2].point[3].y:=-10;
    poligon[2].point[3].z:=10;
    poligon[2].point[4].x:=10;
    poligon[2].point[4].y:=0;
    poligon[2].point[4].z:=10;
 
    poligon[3].point[1].x:=0;
    poligon[3].point[1].y:=0;
    poligon[3].point[1].z:=0;
    poligon[3].point[2].x:=0;
    poligon[3].point[2].y:=-10;
    poligon[3].point[2].z:=0;
    poligon[3].point[3].x:=0;
    poligon[3].point[3].y:=-10;
    poligon[3].point[3].z:=10;
    poligon[3].point[4].x:=0;
    poligon[3].point[4].y:=0;
    poligon[3].point[4].z:=10;
 
    poligon[4].point[1].x:=10;
    poligon[4].point[1].y:=0;
    poligon[4].point[1].z:=0;
    poligon[4].point[2].x:=10;
    poligon[4].point[2].y:=-10;
    poligon[4].point[2].z:=0;
    poligon[4].point[3].x:=10;
    poligon[4].point[3].y:=-10;
    poligon[4].point[3].z:=10;
    poligon[4].point[4].x:=10;
    poligon[4].point[4].y:=0;
    poligon[4].point[4].z:=10;
 
    poligon[5].point[1].x:=0;
    poligon[5].point[1].y:=-10;
    poligon[5].point[1].z:=0;
    poligon[5].point[2].x:=0;
    poligon[5].point[2].y:=-10;
    poligon[5].point[2].z:=10;
    poligon[5].point[3].x:=10;
    poligon[5].point[3].y:=-10;
    poligon[5].point[3].z:=10;
    poligon[5].point[4].x:=10;
    poligon[5].point[4].y:=-10;
    poligon[5].point[4].z:=0;
 
    poligon[6].point[1].x:=0;
    poligon[6].point[1].y:=0;
    poligon[6].point[1].z:=0;
    poligon[6].point[2].x:=0;
    poligon[6].point[2].y:=-10;
    poligon[6].point[2].z:=0;
    poligon[6].point[3].x:=10;
    poligon[6].point[3].y:=-10;
    poligon[6].point[3].z:=0;
    poligon[6].point[4].x:=10;
    poligon[6].point[4].y:=0;
    poligon[6].point[4].z:=0;
  end;
  
  {fil - рисуем каркасными изначально}
  fil:=KARKAS;
  page:=0;
  randomize;
  
  {Увеличим все кубики в 2 раза }
  for k:=1 to num_kubs do
  scale_object(kub[k],2);
  
  
  while vv<>#27 do
  begin
  {смена видеостраницы}
    page:=1-page;
    setactivepage(page);
    
    cleardevice;
    
    {Недоработанная функция, см. в её описании
      но можно её просмотреть(убрать кавычки)}
    
    {Dist_Sort(kub, 1, num_kubs);}
    
    {рисуем комнатку}
    Draw_Field;
    
    {рисуем все кубики}
    for i:=Num_kubs downto 1 do
    Draw_Object(kub[i],Fil);
 
    vv:='0';
    while keypressed do
    vv:=readkey;
    case vv of
    'w':Translate_Object(kub[1],0,0,10);
    's':Translate_Object(kub[1],0,0,-10);
    'a':Translate_Object(kub[1],-10,0,0);
    'd':Translate_Object(kub[1],10,0,0);
    '1':begin Y_Rotate_Object(kub[1],0.1); X_Rotate_Object(kub[1],0.1); end;
    '2':X_Rotate_Object(kub[1],0.1);
    '3':begin Y_Rotate_Object(kub[1],-0.1); X_Rotate_Object(kub[1],0.1); end;
    '4':Y_Rotate_Object(kub[1],0.1);
    '6':Y_Rotate_Object(kub[1],-0.1);
    '7':begin Y_Rotate_Object(kub[1],0.1); X_Rotate_Object(kub[1],-0.1); end;
    '8':X_Rotate_Object(kub[1],-0.1);
    '9':begin Y_Rotate_Object(kub[1],-0.1); X_Rotate_Object(kub[1],-0.1); end;
    '+':Scale_Object(kub[1],2);
    '-':Scale_Object(kub[1],0.5);
    'h':if flag then flag:=false else flag:=true;
    't':Fil:=1-fil;
    #27:Translate_Object(kub[1],10,0,0);
    end;
    
    {далее идут функции автоматического управления кубиками}
    if flag then
    begin
    if t=0 then
    for k:=1 to num_kubs do
    begin
    r[k]:=random(10);
    t:=10;
    end;
    for k:=1 to num_kubs do
    case r[k] of
    1:if kub[k].z0<280 then Translate_Object(kub[k],0,0,2);
    2:if kub[k].z0>100 then Translate_Object(kub[k],0,0,-2);
    3:if kub[k].x0<getmaxx/2+80 then Translate_Object(kub[k],2,0,0);
    4:if kub[k].x0>getmaxx/2-100 then Translate_Object(kub[k],-2,0,0);
    5:if kub[k].y0<getmaxy/2+50 then Translate_Object(kub[k],0,2,0);
    6:if kub[k].y0>getmaxy/2-50 then Translate_Object(kub[k],0,-2,0);
    end;
    end;
    if t>0 then t:=t-1;
    setviewport(0      ,0,getmaxx,getmaxy,clipon);
    setvisualpage(page);
    delay(80);
  end;
end.
0
ermolay
3430 / 2369 / 2134
Регистрация: 04.12.2011
Сообщений: 3,965
07.06.2013, 23:19 135
Кажется не было еще графики в Паскале с использованием кривых Безье (поправьте если я не прав =)).
Не всегда бывает удобно рисовать линии с использованием только стандартных процедур. Для того, чтобы нарисовать их кривыми Безье достаточно использовать готовый алгоритм и создать свой массив точек, через которые линия и будет проходить.
Ниже три листинга: алгоритм создания случайных 5-ти точек (его можно использовать как отправную точку) и создание двух картинок (картинке нашел в инете, реализовал одними кривыми Безье):

Кривая по пяти случайным точкам
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 Graph;
 
TYPE
  Point3D = Record
    X, Y, Z: Real;
  End;
 
VAR  CtrlPt: Array [-1..80] Of Point3D;
 
PROCEDURE Spline_Calc (Ap, Bp, Cp, Dp: Point3D; T, D: Real; Var X, Y: Real);
VAR T2, T3: Real;
BEGIN
  T2 := T * T;           { Square of t }
  T3 := T2 * T;          { Cube of t }
  X := ((Ap.X*T3) + (Bp.X*T2) + (Cp.X*T) + Dp.X)/D;  { Calc x value }
  Y := ((Ap.Y*T3) + (Bp.Y*T2) + (Cp.Y*T) + Dp.Y)/D;  { Calc y value }
END;
 
PROCEDURE BSpline_ComputeCoeffs (N: Integer; Var Ap, Bp, Cp, Dp: Point3D);
BEGIN
  Ap.X := -CtrlPt[N-1].X + 3*CtrlPt[N].X - 3*CtrlPt[N+1].X + CtrlPt[N+2].X;
  Bp.X := 3*CtrlPt[N-1].X - 6*CtrlPt[N].X + 3*CtrlPt[N+1].X;
  Cp.X := -3*CtrlPt[N-1].X + 3*CtrlPt[N+1].X;
  Dp.X := CtrlPt[N-1].X + 4*CtrlPt[N].X + CtrlPt[N+1].X;
  Ap.Y := -CtrlPt[N-1].Y + 3*CtrlPt[N].Y - 3*CtrlPt[N+1].Y + CtrlPt[N+2].Y;
  Bp.Y := 3*CtrlPt[N-1].Y - 6*CtrlPt[N].Y + 3*CtrlPt[N+1].Y;
  Cp.Y := -3*CtrlPt[N-1].Y + 3*CtrlPt[N+1].Y;
  Dp.Y := CtrlPt[N-1].Y + 4*CtrlPt[N].Y + CtrlPt[N+1].Y;
END;
 
PROCEDURE Catmull_Rom_ComputeCoeffs (N: Integer; Var Ap, Bp, Cp, Dp: Point3D);
BEGIN
  Ap.X := -CtrlPt[N-1].X + 3*CtrlPt[N].X - 3*CtrlPt[N+1].X + CtrlPt[N+2].X;
  Bp.X := 2*CtrlPt[N-1].X - 5*CtrlPt[N].X + 4*CtrlPt[N+1].X - CtrlPt[N+2].X;
  Cp.X := -CtrlPt[N-1].X + CtrlPt[N+1].X;
  Dp.X := 2*CtrlPt[N].X;
  Ap.Y := -CtrlPt[N-1].Y + 3*CtrlPt[N].Y - 3*CtrlPt[N+1].Y + CtrlPt[N+2].Y;
  Bp.Y := 2*CtrlPt[N-1].Y - 5*CtrlPt[N].Y + 4*CtrlPt[N+1].Y - CtrlPt[N+2].Y;
  Cp.Y := -CtrlPt[N-1].Y + CtrlPt[N+1].Y;
  Dp.Y := 2*CtrlPt[N].Y;
END;
 
PROCEDURE BSpline (N, Resolution, Colour: Integer);
VAR I, J: Integer; X, Y, Lx, Ly: Real; Ap, Bp, Cp, Dp: Point3D;
BEGIN
  SetColor(Colour);
  CtrlPt[-1] := CtrlPt[1];
  CtrlPt[0] := CtrlPt[1];
  CtrlPt[N+1] := CtrlPt[N];
  CtrlPt[N+2] := CtrlPt[N];
  For I := 0 To N Do Begin
    BSpline_ComputeCoeffs(I, Ap, Bp, Cp, Dp);
    Spline_Calc(Ap, Bp, Cp, Dp, 0, 6, Lx, Ly);
    For J := 1 To Resolution Do Begin
      Spline_Calc(Ap, Bp, Cp, Dp, J/Resolution, 6, X, Y);
      Line(Round(Lx), Round(Ly), Round(X), Round(Y));
      Lx := X; Ly := Y;
    End;
  End;
END;
 
PROCEDURE Catmull_Rom_Spline (N, Resolution, Colour: Integer);
VAR I, J: Integer; X, Y, Lx, Ly: Real; Ap, Bp, Cp, Dp: Point3D;
BEGIN
  SetColor(Colour);
  CtrlPt[0] := CtrlPt[1];
  CtrlPt[N+1] := CtrlPt[N];
  For I := 1 To N-1 Do Begin
    Catmull_Rom_ComputeCoeffs(I, Ap, Bp, Cp, Dp);
    Spline_Calc(Ap, Bp, Cp, Dp, 0, 2, Lx, Ly);
    For J := 1 To Resolution Do Begin
      Spline_Calc(Ap, Bp, Cp, Dp, J/Resolution, 2, X, Y);
      Line(Round(Lx), Round(Ly), Round(X), Round(Y));
      Lx := X; Ly := Y;
    End;
  End;
END;
 
VAR I, J, Res, NumPts: Integer;
BEGIN
  I := Detect;
  InitGraph(I, J, '');
  I := GetMaxX; J := GetMaxY;
  Randomize;
  CtrlPt[1].X := Random(I); CtrlPt[1].Y := Random(J);
  CtrlPt[2].X := Random(I); CtrlPt[2].Y := Random(J);
  CtrlPt[3].X := Random(I); CtrlPt[3].Y := Random(J);
  CtrlPt[4].X := Random(I); CtrlPt[4].Y := Random(J);
  CtrlPt[5].X := Random(I); CtrlPt[5].Y := Random(J);
  Res := 20;
  NumPts := 5;
  BSpline(NumPts, Res, LightGreen);
  CatMull_Rom_Spline(NumPts, Res, LightRed);
  SetColor(Yellow);
  For I := 1 To NumPts Do Begin
    Line(Round(CtrlPt[I].X-3), Round(CtrlPt[I].Y),
      Round(CtrlPt[I].X+3), Round(CtrlPt[I].Y));
    Line(Round(CtrlPt[I].X), Round(CtrlPt[I].Y-3),
      Round(CtrlPt[I].X), Round(CtrlPt[I].Y+3));
  End;
  ReadLn;
  CloseGraph;
END.

Абстрактные линии
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
uses
  Graph;
type
  Point3D = Record
    X, Y, Z: Real;
  End;
  TAr=array [-1..80] Of Point3D;
 
procedure Spline_Calc(Ap, Bp, Cp, Dp: Point3D; T, D: Real; var X, Y: Real);
var
  T2, T3: Real;
begin
  T2 := T * T;           { Square of t }
  T3 := T2 * T;          { Cube of t }
  X := ((Ap.X * T3) + (Bp.X * T2) + (Cp.X * T) + Dp.X) / D;  { Calc x value }
  Y := ((Ap.Y * T3) + (Bp.Y * T2) + (Cp.Y * T) + Dp.Y) / D;  { Calc y value }
end;
 
procedure BSpline_ComputeCoeffs(A: TAr; N: Integer; var Ap, Bp, Cp, Dp: Point3D);
begin
  Ap.X := -A[N - 1].X + 3 * A[N].X - 3 * A[N + 1].X + A[N + 2].X;
  Bp.X := 3 * A[N - 1].X - 6 * A[N].X + 3 * A[N + 1].X;
  Cp.X := -3 * A[N - 1].X + 3 * A[N + 1].X;
  Dp.X := A[N - 1].X + 4 * A[N].X + A[N + 1].X;
  Ap.Y := -A[N - 1].Y + 3 * A[N].Y - 3 * A[N + 1].Y + A[N + 2].Y;
  Bp.Y := 3 * A[N - 1].Y - 6 * A[N].Y + 3 * A[N + 1].Y;
  Cp.Y := -3 * A[N - 1].Y + 3 * A[N + 1].Y;
  Dp.Y := A[N - 1].Y + 4 * A[N].Y + A[N + 1].Y;
end;
 
procedure Catmull_Rom_ComputeCoeffs(A: TAr; N: Integer; var Ap, Bp, Cp, Dp: Point3D);
begin
  Ap.X := -A[N - 1].X + 3 * A[N].X - 3 * A[N + 1].X + A[N + 2].X;
  Bp.X := 2 * A[N - 1].X - 5 * A[N].X + 4 * A[N + 1].X - A[N + 2].X;
  Cp.X := -A[N - 1].X + A[N + 1].X;
  Dp.X := 2 * A[N].X;
  Ap.Y := -A[N - 1].Y + 3 * A[N].Y - 3 * A[N + 1].Y + A[N + 2].Y;
  Bp.Y := 2 * A[N - 1].Y - 5 * A[N].Y + 4 * A[N + 1].Y - A[N + 2].Y;
  Cp.Y := -A[N - 1].Y + A[N + 1].Y;
  Dp.Y := 2 * A[N].Y;
end;
 
procedure BSpline(A: TAr; N, Resolution, Colour: Integer);
var
  I, J: Integer; X, Y, Lx, Ly: Real; Ap, Bp, Cp, Dp: Point3D;
begin
  SetColor(Colour);
  A[-1]  := A[1];
  A[0]   := A[1];
  A[N + 1] := A[N];
  A[N + 2] := A[N];
  for I := 0 To N Do
  begin
    BSpline_ComputeCoeffs(A, I, Ap, Bp, Cp, Dp);
    Spline_Calc(Ap, Bp, Cp, Dp, 0, 6, Lx, Ly);
    for J := 1 To Resolution Do
    begin
      Spline_Calc(Ap, Bp, Cp, Dp, J / Resolution, 6, X, Y);
      Line(Round(Lx), Round(Ly), Round(X), Round(Y));
      Lx := X; Ly := Y;
    end;
  end;
end;
 
procedure Catmull_Rom_Spline(A: TAr; N, Resolution, Colour: Integer);
var
  I, J: Integer; X, Y, Lx, Ly: Real; Ap, Bp, Cp, Dp: Point3D;
begin
  SetColor(Colour);
  A[0] := A[1];
  A[N + 1] := A[N];
  for I := 1 To N - 1 Do
  begin
    Catmull_Rom_ComputeCoeffs(A, I, Ap, Bp, Cp, Dp);
    Spline_Calc(Ap, Bp, Cp, Dp, 0, 2, Lx, Ly);
    for J := 1 To Resolution Do
    begin
      Spline_Calc(Ap, Bp, Cp, Dp, J / Resolution, 2, X, Y);
      Line(Round(Lx), Round(Ly), Round(X), Round(Y));
      Lx := X; Ly := Y;
    end;
  end;
end;
 
var
  I, J, Res, NumPts, k: Integer;
  a, b: TAr;
begin
  I := Detect;
  InitGraph(I, J, '');
  I := GetMaxX; J := GetMaxY;
  floodFill(1, 1, Black);
 
  a[1].X :=   0; a[1].Y := 0;
  a[2].X := 490; a[2].Y := 20;
  a[3].X := 240; a[3].Y := 400;
  a[4].X := 640; a[4].Y := 480;
 
  b[1].X := -50; b[1].Y := -30;
  b[2].X := 100; b[2].Y := 200;
  b[3].X := 390; b[3].Y := 280;
  b[4].X := 640; b[4].Y := 430;
  Res := 20;
  NumPts := 4;
  k := 5;
  for i := 1 to 10 do
  begin
    BSpline(A, NumPts, Res, white);
    a[1].Y := a[1].Y - 5;
    a[2].Y := a[2].Y + 25;
    a[3].Y := a[3].Y + 10;
    a[4].Y := a[4].Y - 1;
 
    a[1].X := a[1].X + k;
    a[2].X := a[2].X + k;
    a[3].X := a[3].X + k;
    a[4].X := a[4].X + k;
 
    BSpline(B, NumPts, Res, white);
    b[1].Y := b[1].Y - 5;
    b[2].Y := b[2].Y + 15;
    b[3].Y := b[3].Y + 7;
    b[4].Y := b[4].Y - 10;
 
    b[1].X := b[1].X + k;
    b[2].X := b[2].X + k;
    b[3].X := b[3].X + k;
    b[4].X := b[4].X + k;
  end;
  Readln;
  CloseGraph;
end.

Дельфин
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
USES Graph, crt;
 
TYPE
  Point3D = Record
    X, Y, Z: Real;
  End;
 
VAR  A: Array [-1..80] Of Point3D;
 
PROCEDURE Spline_Calc (Ap, Bp, Cp, Dp: Point3D; T, D: Real; Var X, Y: Real);
VAR T2, T3: Real;
BEGIN
  T2 := T * T;           { Square of t }
  T3 := T2 * T;          { Cube of t }
  X := ((Ap.X*T3) + (Bp.X*T2) + (Cp.X*T) + Dp.X)/D;  { Calc x value }
  Y := ((Ap.Y*T3) + (Bp.Y*T2) + (Cp.Y*T) + Dp.Y)/D;  { Calc y value }
END;
 
PROCEDURE BSpline_ComputeCoeffs (N: Integer; Var Ap, Bp, Cp, Dp: Point3D);
BEGIN
  Ap.X := -A[N-1].X + 3*A[N].X - 3*A[N+1].X + A[N+2].X;
  Bp.X := 3*A[N-1].X - 6*A[N].X + 3*A[N+1].X;
  Cp.X := -3*A[N-1].X + 3*A[N+1].X;
  Dp.X := A[N-1].X + 4*A[N].X + A[N+1].X;
  Ap.Y := -A[N-1].Y + 3*A[N].Y - 3*A[N+1].Y + A[N+2].Y;
  Bp.Y := 3*A[N-1].Y - 6*A[N].Y + 3*A[N+1].Y;
  Cp.Y := -3*A[N-1].Y + 3*A[N+1].Y;
  Dp.Y := A[N-1].Y + 4*A[N].Y + A[N+1].Y;
END;
 
PROCEDURE Catmull_Rom_ComputeCoeffs (N: Integer; Var Ap, Bp, Cp, Dp: Point3D);
BEGIN
  Ap.X := -A[N-1].X + 3*A[N].X - 3*A[N+1].X + A[N+2].X;
  Bp.X := 2*A[N-1].X - 5*A[N].X + 4*A[N+1].X - A[N+2].X;
  Cp.X := -A[N-1].X + A[N+1].X;
  Dp.X := 2*A[N].X;
  Ap.Y := -A[N-1].Y + 3*A[N].Y - 3*A[N+1].Y + A[N+2].Y;
  Bp.Y := 2*A[N-1].Y - 5*A[N].Y + 4*A[N+1].Y - A[N+2].Y;
  Cp.Y := -A[N-1].Y + A[N+1].Y;
  Dp.Y := 2*A[N].Y;
END;
 
PROCEDURE BSpline (N, Resolution, Colour: Integer);
VAR I, J: Integer; X, Y, Lx, Ly: Real; Ap, Bp, Cp, Dp: Point3D;
BEGIN
  SetColor(Colour);
  A[-1]  := A[1];
  A[0]   := A[1];
  A[N+1] := A[N];
  A[N+2] := A[N];
  For I := 0 To N Do Begin
    BSpline_ComputeCoeffs(I, Ap, Bp, Cp, Dp);
    Spline_Calc(Ap, Bp, Cp, Dp, 0, 6, Lx, Ly);
    For J := 1 To Resolution Do Begin
      Spline_Calc(Ap, Bp, Cp, Dp, J/Resolution, 6, X, Y);
      Line(Round(Lx), Round(Ly), Round(X), Round(Y));
      Lx := X; Ly := Y;
    End;
  End;
END;
 
PROCEDURE Catmull_Rom_Spline (N, Resolution, Colour: Integer);
VAR I, J: Integer; X, Y, Lx, Ly: Real; Ap, Bp, Cp, Dp: Point3D;
BEGIN
  SetColor(Colour);
  A[0] := A[1];
  A[N+1] := A[N];
  For I := 1 To N-1 Do Begin
    Catmull_Rom_ComputeCoeffs(I, Ap, Bp, Cp, Dp);
    Spline_Calc(Ap, Bp, Cp, Dp, 0, 2, Lx, Ly);
    For J := 1 To Resolution Do Begin
      Spline_Calc(Ap, Bp, Cp, Dp, J/Resolution, 2, X, Y);
      Line(Round(Lx), Round(Ly), Round(X), Round(Y));
      Lx := X; Ly := Y;
    End;
  End;
END;
 
VAR I, J, Res, NumPts, pic: Integer;
BEGIN
  I := Detect;
  InitGraph(I, J, '');
  I := GetMaxX; J := GetMaxY;
  FloodFill(3, 3, White);
  A[1].X := 535;  A[1].Y := 450;
  A[2].X := 545;  A[2].Y := 385;
  A[3].X := 480;  A[3].Y := 355;
  A[4].X := 485;  A[4].Y := 210;
  A[5].X := 415;  A[5].Y := 120;
  A[6].X := 415;  A[6].Y := 110;
  A[7].X := 485;  A[7].Y := 85;
  A[8].X := 390;  A[8].Y := 70;
  A[9].X := 360;  A[9].Y := 86;
  A[10].X := 300; A[10].Y := 57;
  A[11].X := 200; A[11].Y := 50;
  A[12].X := 142; A[12].Y := 94;
  A[13].X := 129; A[13].Y := 151;
  A[14].X := 129; A[14].Y := 151;
  A[15].X := 115; A[15].Y := 168;
  A[16].X := 120; A[16].Y := 185;
  A[17].X := 160; A[17].Y := 174;
  A[18].X := 160; A[18].Y := 174;
  A[19].X := 143; A[19].Y := 173;
  A[20].X := 147; A[20].Y := 163;
  A[21].X := 168; A[21].Y := 155;
  A[22].X := 168; A[22].Y := 155;
  A[23].X := 171; A[23].Y := 136;
  A[24].X := 193; A[24].Y := 133;
  A[25].X := 193; A[25].Y := 133;
  A[26].X := 186; A[26].Y := 137;
  A[27].X := 187; A[27].Y := 142;
  A[28].X := 193; A[28].Y := 144;
  A[29].X := 201; A[29].Y := 140;
  A[30].X := 201; A[30].Y := 133;
  A[31].X := 195; A[31].Y := 133;
  A[32].X := 193; A[32].Y := 133;
  A[33].X := 193; A[33].Y := 133;
  A[34].X := 193; A[34].Y := 133;
  A[35].X := 193; A[35].Y := 133;
  A[36].X := 193; A[36].Y := 133;
  A[37].X := 193; A[37].Y := 133;
  A[38].X := 193; A[38].Y := 133;
  A[39].X := 193; A[39].Y := 133;
  A[40].X := 193; A[40].Y := 133;
  A[41].X := 193; A[41].Y := 133;
  A[42].X := 200; A[42].Y := 116;
  A[43].X := 285; A[43].Y := 124;
  A[44].X := 285; A[44].Y := 124;
  A[45].X := 250; A[45].Y := 110;
  A[46].X := 250; A[46].Y := 110;
  A[47].X := 340; A[47].Y := 110;
  A[48].X := 413; A[48].Y := 182;
  A[49].X := 322; A[49].Y := 139;
  A[50].X := 322; A[50].Y := 139;
  A[51].X := 430; A[51].Y := 210;
  A[52].X := 460; A[52].Y := 275;
  A[53].X := 427; A[53].Y := 260;
  A[54].X := 427; A[54].Y := 260;
  A[55].X := 475; A[55].Y := 310;
  A[56].X := 470; A[56].Y := 360;
  A[57].X := 470; A[57].Y := 360;
  A[58].X := 420; A[58].Y := 385;
  A[59].X := 419; A[59].Y := 419;
  A[60].X := 419; A[60].Y := 419;
  A[61].X := 430; A[61].Y := 403;
  A[62].X := 480; A[62].Y := 408;
  A[63].X := 487; A[63].Y := 385;
  A[64].X := 505; A[64].Y := 417;
  A[65].X := 525; A[65].Y := 415;
  A[66].X := 535; A[66].Y := 450;
  Res := 20; NumPts := 66;
  BSpline(NumPts, Res, Black);
 
  setLineStyle(0, 0, 3);
  A[1].X := 156; A[1].Y := 175;
  A[2].X := 240; A[2].Y := 164;
  A[3].X := 300; A[3].Y := 189;
  A[4].X := 300; A[4].Y := 189;
  A[5].X := 285; A[5].Y := 165;
  Res := 20;
  NumPts := 5;
  BSpline(NumPts, Res, Black);
  A[1].X := 350; A[1].Y := 210;
  A[2].X := 390; A[2].Y := 228;
  A[3].X := 430; A[3].Y := 261;
  Res := 20; NumPts := 3;
  BSpline(NumPts, Res, Black);
 
  A[1].X := 300; A[1].Y := 189;
  A[2].X := 320; A[2].Y := 225;
  A[3].X := 380; A[3].Y := 290;
  A[4].X := 355; A[4].Y := 195;
  A[5].X := 355; A[5].Y := 195;
  A[6].X := 305; A[6].Y := 167;
  A[7].X := 305; A[7].Y := 167;
  A[8].X := 325; A[8].Y := 210;
  A[9].X := 323; A[9].Y := 215;
  A[10].X := 300; A[10].Y := 189;
  Res := 20; NumPts := 10;
  BSpline(NumPts, Res, Black);
 
  A[1].X := 242; A[1].Y := 170;
  A[2].X := 257; A[2].Y := 210;
  A[3].X := 285; A[3].Y := 262;
  A[4].X := 297; A[4].Y := 225;
  A[5].X := 285; A[5].Y := 200;
  A[6].X := 290; A[6].Y := 185;
  Res := 20; NumPts := 6;
  BSpline(NumPts, Res, Black);
 
  setfillstyle(solidfill,black);
  FloodFill(330, 200, Black);
  FloodFill(200, 100, Black);
  FloodFill(275, 200, Black);
  FloodFill(193, 140, Black);
  floodfill(360,160,black);
  floodfill(318,212,black);
  floodfill(435,266,black);
 
  A[1].X := 127; A[1].Y := 162;
  A[2].X := 131; A[2].Y := 155;
  A[3].X := 137; A[3].Y := 150;
  A[4].X := 137; A[4].Y := 150;
  A[5].X := 144; A[5].Y := 120;
  A[6].X := 155; A[6].Y := 103;
  Res := 20; NumPts := 6;
  BSpline(NumPts, Res, White);
 
  A[1].X := 185; A[1].Y := 78;
  A[2].X := 199; A[2].Y := 71;
  A[3].X := 213; A[3].Y := 67;
  Res := 20; NumPts := 3;
  BSpline(NumPts, Res, White);
 
  A[1].X := 266; A[1].Y := 64;
  A[2].X := 290; A[2].Y := 68;
  A[3].X := 315; A[3].Y := 75;
 
  Res := 20; NumPts := 3;
  BSpline(NumPts, Res, White);
 
  A[1].X := 419; A[1].Y := 136;
  A[2].X := 428; A[2].Y := 147;
  A[3].X := 435; A[3].Y := 160;
 
  Res := 20;
  NumPts := 3;
  BSpline(NumPts, Res, White);
 
  A[1].X := 444; A[1].Y := 176; inc(i);
  A[2].X := 457; A[2].Y := 200;
  Res := 20; NumPts := 2;
  BSpline(NumPts, Res, White);
  readln;
  closeGraph;
end.
8
Миниатюры
Графика в Турбо Паскаль   Графика в Турбо Паскаль  
Новичок
Модератор
1511 / 980 / 465
Регистрация: 17.07.2012
Сообщений: 4,978
Завершенные тесты: 3
31.07.2013, 00:18 136
Симуляция кардиограммы.Автор:Kam_1995
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
uses crt,graph;
 
var driver,mode,t,y,x,u,v: integer;
 
 
procedure puls1;
begin
t:=70;
while t<78 do
begin
lineto(t,240-y);
t:=t+2;
y:=y+8;
delay(25);
end;
 
y:=0;
while t<86 do
begin
lineto(t,216+y);
t:=t+2;
y:=y+8;
delay(25);
end;
settextstyle(0,0,2);
outtextxy(2,2,'Serdce biyeniye: 72');
outtextxy(2,20,'Nijneye davleniye: 60');
outtextxy(2,38,'Verxneye davleniye: 126');
 
moveto(86,240);
while t<93 do
begin
lineto(t,240);
t:=t+1;
delay(25);
end;
 
y:=0;
while t<98 do
begin
lineto(t,240+y);
t:=t+2;
y:=y+10;
delay(25);
end;
 
y:=0;
while t<108 do
begin
lineto(t,270-y);
t:=t+1;
y:=y+18;
delay(25);
end;
 
Sound(1000);
Delay(90);
NoSound;
 
 
y:=0;
while t<122 do
begin
lineto(t,125+y);
t:=t+1;
y:=y+18;
delay(25);
end;
 
y:=0;
while t<130 do
begin
lineto(t,360-y);
t:=t+1;
y:=y+17;
delay(25);
end;
end;
 
 
 
procedure puls2;
begin
 
t:=180;
y:=0;
while t<188 do
begin
lineto(t,240-y);
t:=t+2;
y:=y+8;
delay(25);
end;
 
y:=0;
while t<196 do
begin
lineto(t,216+y);
t:=t+2;
y:=y+8;
delay(25);
end;
 
setfillstyle(1,0);
bar(400,30,0,0);
outtextxy(2,2,'Serdce biyeniye: 64');
outtextxy(2,20,'Nijneye davleniye: 60');
outtextxy(2,38,'Verxneye davleniye: 129');
 
moveto(196,240);
 
while t<203 do
begin
lineto(t,240);
t:=t+1;
delay(25);
end;
 
y:=0;
while t<208 do
begin
lineto(t,240+y);
t:=t+2;
y:=y+10;
delay(25);
end;
 
y:=0;
while t<218 do
begin
lineto(t,270-y);
t:=t+1;
y:=y+18;
delay(25);
end;
 
Sound(1000);
Delay(90);
NoSound;
 
y:=0;
while t<232 do
begin
lineto(t,125+y);
t:=t+1;
y:=y+18;
delay(25);
end;
 
y:=0;
while t<240 do
begin
lineto(t,360-y);
t:=t+1;
y:=y+17;
delay(25);
end;
end;
 
procedure puls3(z:integer);
begin
 
t:=z;
y:=0;
while t<z+8 do
begin
lineto(t,240-y);
t:=t+2;
y:=y+8;
delay(25);
end;
 
y:=0;
while t<z+8+8 do
begin
lineto(t,216+y);
t:=t+2;
y:=y+8;
delay(25);
end;
 
bar(600,60,0,0);
settextstyle(0,0,2);
outtextxy(2,2,'Serdce biyeniye: 80');
outtextxy(2,20,'Nijneye davleniye: 20');
outtextxy(2,38,'Verxneye davleniye: 154');
moveto(t,240);
 
while t<z+8+8+3 do
begin
lineto(t,240);
t:=t+1;
delay(25);
end;
 
y:=0;
while t<z+8+8+3+5 do
begin
lineto(t,240+y);
t:=t+2;
y:=y+10;
delay(25);
end;
 
y:=0;
while t<z+8+8+3+5+10 do
begin
lineto(t,270-y);
t:=t+1;
y:=y+18;
delay(25);
end;
 
Sound(1000);
Delay(90);
NoSound;
 
y:=0;
while t<z+8+8+3+5+10+14 do
begin
lineto(t,125+y);
t:=t+1;
y:=y+18;
delay(25);
end;
 
y:=0;
while t<z+8+8+3+5+10+14+8 do
begin
lineto(t,360-y);
t:=t+1;
y:=y+17;
delay(25);
end;
 
end;
 
procedure puls4(z:integer);
begin
 
t:=z;
y:=0;
settextstyle(0,0,2);
outtextxy(300,100,'Paciyent jiv');
moveto(t,240);
while t<z+8 do
begin
lineto(t,240-y);
t:=t+2;
y:=y+8;
delay(25);
end;
 
y:=0;
while t<z+8+8 do
begin
lineto(t,216+y);
t:=t+2;
y:=y+8;
delay(25);
end;
 
bar(600,60,0,0);
settextstyle(0,0,2);
outtextxy(2,2,'Serdce biyeniye: 69');
outtextxy(2,20,'Nijneye davleniye: 62');
outtextxy(2,38,'Verxneye davleniye: 122');
 
moveto(t,240);
while t<z+8+8+3 do
begin
lineto(t,240);
t:=t+1;
delay(25);
end;
 
y:=0;
while t<z+8+8+3+5 do
begin
lineto(t,240+y);
t:=t+2;
y:=y+10;
delay(25);
end;
 
y:=0;
while t<z+8+8+3+5+10 do
begin
lineto(t,270-y);
t:=t+1;
y:=y+18;
delay(25);
end;
 
Sound(1000);
Delay(90);
NoSound;
 
y:=0;
while t<z+8+8+3+5+10+14 do
begin
lineto(t,125+y);
t:=t+1;
y:=y+18;
delay(25);
end;
 
y:=0;
while t<z+8+8+3+5+10+14+8 do
begin
lineto(t,360-y);
t:=t+1;
y:=y+17;
delay(25);
end;
 
end;
 
BeGIN
clrscr;
randomize;
driver:=detect;
initgraph(driver,mode,'');
 
x:=0;
while x<70 do
begin
lineto(x,240);
x:=x+1;
delay(25);
end;
 
puls1;
 
 
x:=130;
while x<180 do
begin
lineto(x,240);
x:=x+1;
delay(25);
end;
 
puls2;
 
x:=240;
while x<290 do
begin
lineto(x,240);
x:=x+1;
delay(25);
end;
 
bar(600,60,0,0);
outtextxy(2,2,'Serdce biyeniye: 0');
outtextxy(2,20,'Nijneye davleniye: 0');
outtextxy(2,38,'Verxneye davleniye: 0');
outtextxy(300,100,'Ostanovka serdca!!!');
settextstyle(0,0,1);
outtextxy(260,118,'Najmite <Enter> shtobi ispolzovat referbulyator');
moveto(290,240);
x:=290;
repeat
lineto(x,240);
x:=x+1;
sound(1000);
delay(25);
until keypressed;
nosound;
 
bar(255,90,700,160);
 
puls3(x);
 
u:=random(3);
u:=u-2;
if u<0 then v:=1;
if u>0 then v:=0;
 
case v of
1 : begin
settextstyle(0,0,2);
outtextxy(300,100,'Letalniy isxod');
t:=t+1;
bar(600,60,0,0);
outtextxy(2,2,'Serdce biyeniye: 0');
outtextxy(2,20,'Nijneye davleniye: 0');
outtextxy(2,38,'Verxneye davleniye: 0');
moveto(t,240);
while t<630     do
begin
lineto(t,240);
t:=t+1;
sound(1000);
delay(25);
end;
nosound;
end;
 
0: begin
v:=t;
bar(600,60,0,0);
outtextxy(2,2,'Serdce biyeniye: 0');
outtextxy(2,20,'Nijneye davleniye: 0');
outtextxy(2,38,'Verxneye davleniye: 0');
moveto(t,240);
while t<v+50 do
begin
lineto(t,240);
t:=t+1;
delay(25);
end;
puls4(t);
v:=t;
while t<v+100 do
begin
lineto(t,240);
t:=t+1;
delay(25);
end;end;end;
readln;
END.
Найти одну программу
1
proggamer12
17 / 17 / 4
Регистрация: 06.07.2012
Сообщений: 509
Завершенные тесты: 1
23.08.2013, 16:56 137
Кому-нибудь нужен Space Invaders (подобие) на Pascal?
0
Новичок
Модератор
1511 / 980 / 465
Регистрация: 17.07.2012
Сообщений: 4,978
Завершенные тесты: 3
23.08.2013, 17:50 138
proggamer12,выкладывай,лично мне не нужен,но вдруг кому-то пригодится.
0
Dj Programmer
13 / 13 / 14
Регистрация: 05.10.2013
Сообщений: 141
08.11.2013, 23:07 139
Пару простых программ :

1. Рисуем кораблик

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
uses graph,crt;
 var Gd,Gm,i: integer;
begin
 Gd:=Detect;
 initgraph(Gd, Gm, '');
  line(150,200,200,250);
   line(200,250,300,250);
    line(300,250,350,200);
     line(350,200,150,200);
      line(180,200,180,140);
       line(180,140,250,140);
        line(250,140,250,200);
       line(250,140,250,200);
      circle(210,220,10);
     circle(240,220,10);
    circle(270,220,10);
   line(200,140,200,90);
  bar(200,90,230,110);
 readkey;
 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
50
51
52
53
 Uses crt,graph;
Var gd,gm,cor:integer;
    zvuk:string;
Begin
  textcolor(17+3);
  writeln('Zapustit raketu so zvukom da,net');
  readln(zvuk);
 gd:=detect;
  initgraph(gd, gm, '');
  cor:=350;
 setbkcolor(1);
 While cor>=-130 Do
  Begin
   if zvuk='da' then sound(1000);
    setcolor(4);
     circle(250,cor, 20);
      circle(250,cor+50, 20);
       circle(250,cor+100,20);
        rectangle(220,cor-30,280,cor+130);
         line(220,cor-30,250,cor-60);
          line(250,cor-60,280,cor-30);
           line(280,cor+80,310,cor+100);
          line(310,cor+100,310,cor+170);
         line(310,cor+170,280,cor+130);
        line(220,cor+80,190,cor+100);
       line(190,cor+100,190,cor+170);
      line(190,cor+170,220,cor+130);
     delay(5000);
    setcolor(0);
   circle(250,cor, 20);
  circle(250,cor+50, 20);
 circle(250,cor+100,20);
rectangle(220,cor-30,280,cor+130);
 line(220,cor-30,250,cor-60);
  line(250,cor-60,280,cor-30);
   line(220,cor+20,190,cor+50);
    line(280,cor+80,310,cor+100);
     line(310,cor+100,310,cor+170);
      line(310,cor+170,280,cor+130);
       line(220,cor+80,190,cor+100);
        line(190,cor+170,220,cor+130);
         line(190,cor+100,190,cor+170);
          cor:=cor-10;
  End;
 nosound;
 closegraph;
  textcolor(17+8);
   writeln('Raketa uletela nagmite klavichu!!!');
    sound(1000);
     delay(4000);
    nosound;
   readkey;
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
Uses Graph;
var
  D,M,y,i : Integer;
begin
 D := Detect;
 InitGraph(D,M,'');
 if GraphResult <> grOk then WriteLn(GraphErrorMsg(GraphResult))
 else
  begin
    y:=200;
   for i:=1 to 30 do
    begin
     if i<5 then SetColor(4);
     if (i>5)and(i<10) then SetColor(14);
     if (i>10)and(i<15) then SetColor(2);
     if (i>20)and(i<25) then SetColor(1);
     if i>25 then SetColor(13);
      Ellipse(325,y,10,170,240,150);  {Эллиптические дуги}
      inc(y); {тоже что и y:=y+1}
    end;
    Readln;
    CloseGraph;
  end;
end.


Добавлено через 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
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
USES GRAPH,crt;
label 1;
VAR GD,GM,X,Y,I,K,t,h,m:INTEGER;
 
s,d:array[1..30] of integer;
BEGIN
clrscr;
gd:=detect;
initgraph(gd,gm,'');
s[1]:=466;
d[1]:=400*5;
 
s[2]:=294;
d[2]:=400*5;
 
d[3]:=30*5;
 
s[4]:=294;
d[4]:=400*5;
 
s[5]:=466;
d[5]:=400*5;
 
d[6]:=30*5;
 
s[7]:=466;
d[7]:=1000*5;
 
s[8]:=294;
d[8]:=400*5;
 
d[9]:=30*5;
 
s[10]:=294;
d[10]:=400*5;
 
s[11]:=466;
d[11]:=400*5;
 
d[12]:=30*5;
 
s[13]:=466;
d[13]:=400*5;
 
s[14]:=294;
d[14]:=400*5;
 
s[15]:=311;
d[15]:=400*5;
 
s[16]:=294;
d[16]:=400*5;
 
d[17]:=30*5;
 
s[18]:=294;
d[18]:=400*5;
 
s[19]:=262;
d[19]:=400*5;
 
d[20]:=30*5;
 
s[21]:=262;
d[21]:=400*5;
 
s[22]:=440;
d[22]:=400*5;
 
d[23]:=30*5;
 
s[24]:=440;
d[24]:=400*5;
 
s[25]:=440;
d[25]:=400*5;
 
d[26]:=30*5;
setcolor(15);
{стакан}
ellipse(140,330,0,360,68,10);
ellipse(140,430,180,360,35,10);
line(72,330,105,430);
line(208,330,175,430);
line(140,340,140,440);
line(102,338,123,438);
line(178,338,157,438);
{бутылка}
ellipse(500,400,180,360,70,25);
ellipse(500,200,180,360,70,25);
ellipse(530,200,0,80,40,30);
ellipse(470,200,100,180,40,30);
ellipse(500,170,180,360,37,10);
ellipse(500,30,0,360,30,10);
ellipse(500,30,0,360,20,5);
ellipse(500,40,180,360,30,10);
ellipse(500,250,180,360,70,25);
line(530,30,530,40);
line(470,30,470,40);
line(570,200,570,400);
line(430,200,430,400);
setcolor(14);
line(568,259,568,400);
line(432,259,432,400);
ellipse(500,398,180,360,68,25);
ellipse(500,255,180,360,68,25);
setcolor(15);
setfillstyle(11,15);
floodfill(500,300,14);
line(537,170,520,100);
line(463,170,480,100);
line(520,100,520,50);
line(480,100,480,50);
delay(4000);
setcolor(0);
 
 
setfillstyle(11,0);
floodfill(500,300,14);
line(568,259,568,400);
line(432,259,432,400);
ellipse(500,398,180,360,68,25);
ellipse(500,255,180,360,68,25);
{бутылка стерлась}
setcolor(0);
ellipse(500,400,180,360,70,25);
ellipse(500,200,180,360,70,25);
ellipse(530,200,0,80,40,30);
ellipse(470,200,100,180,40,30);
ellipse(500,170,180,360,37,10);
ellipse(500,250,180,360,70,25);
ellipse(500,30,0,360,30,10);
ellipse(500,30,0,360,20,5);
ellipse(500,40,180,360,30,10);
line(530,30,530,40);
line(470,30,470,40);
line(570,200,570,400);
line(430,200,430,400);
line(537,170,520,100);
line(463,170,480,100);
line(520,100,520,50);
line(480,100,480,50);
delay(500);
setcolor(15);
 
{бутылка 1 }
ellipse(500,100,270,90,25,70);
ellipse(300,100,270,90,25,70);
line(500,170,300,170);
line(500,30,300,30);
ellipse(305,130,190,260,30,40);
ellipse(305,70,100,170,30,40);
ellipse(275,100,270,90,10,37);
line(275,65,205,82);
line(154,115,525,115);
line(276,136,205,117);
line(133,115,140,115);
line(205,82,155,82);
line(210,118,154,118);
setfillstyle(11,15);
floodfill(400,120,15);
floodfill(300,120,15);
ellipse(136,100,0,360,10,30);
ellipse(136,100,0,360,5,20);
ellipse(146,100,270,90,10,30);
line(136,130,146,130);
line(136,70,146,70);
floodfill(280,120,15);
floodfill(133,117,15);
delay(90);
for i:=115 to 440 do begin
putpixel(trunc(133+4*sin(i/30)),i,15);
putpixel(trunc(140+4*sin(i/30)),i,15);
delay(5);
end;
m:=430;
t:=34;
for i:=1 to 26 do begin
if (i=3) or (i=6) or (i=9) or (i=12) or (i=17) or (i=20) or (i=23) or (i=26)
then  begin nosound ; goto 1; end;
sound(s[i]);
1:ellipse(140,m,180,360,t,10);
t:=t+1;
m:=m-3;
delay(d[i]);
end;
 
readln;
closegraph;
end.


Добавлено через 2 минуты
Если стакан медленно заполняется то можно уменьшить параметр delay
0
ildwine
Супер-модератор
3051 / 1927 / 1240
Регистрация: 04.03.2013
Сообщений: 4,714
Записей в блоге: 1
08.11.2013, 23:31 140
Цитата Сообщение от Dj Programmer Посмотреть сообщение
Пару простых программ
А теперь то же самое, но в циклах...
1
08.11.2013, 23:31
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
08.11.2013, 23:31

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

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

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


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

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

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