Форум программистов, компьютерный форум, киберфорум
Наши страницы
PascalABC.NET
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг 4.97/985: Рейтинг темы: голосов - 985, средняя оценка - 4.97
BaboshinSD
334 / 273 / 49
Регистрация: 15.11.2012
Сообщений: 477
Записей в блоге: 1
#1

Полезные коды для PascalABC.NET

23.03.2013, 15:03. Просмотров 178808. Ответов 121

В этой теме размещаются полезные исходники программ, различные процедуры и функции, а так же готовые решения на часто задаваемые вопросы, написанные на PascalABC.NET.

Поддержать тему и добавить свои примеры, исходники и пр. может каждый, после того, как ознакомиться с правилами темы:
Правила темы!
  1. Запрещается добавлять коды программ никак не связанные с PascalABC.NET, для этих программ есть другие темы и разделы.
  2. Не рекомендуется добавлять слишком простые примеры, типа "Как добавить текст на кнопку?" и пр.
  3. Перед тем как выложить код, подумайте будет ли он кому-то интересен или полезен.
  4. Приветствуются сложные примеры или проекты, а так же программы с интересным принципом работы.
  5. Если программа использует сторонние ресурсы (изображения, библиотеки и пр.) обязательно прикрепляйте их во вложении
  6. Обязательно подробно комментируйте свой код, чтобы другим было проще разобраться в нём.
  7. Тема ведётся в формате Вопрос-Ответ, поэтому все сообщения оформляются в таком виде:
    В: Как что-то сделать?
    О:
    Делаем что-то
    Pascal
    1
    
    // Тут код
  8. Если вы хотите отредактировать свой код, можно обратиться к модераторам раздела или к ТС.


Путеводитель по теме:


Работа с формами:

Готовые решения:
Готовые решения на часто задаваемые вопросы.

Работа с графикой:
Исходники программ, работающих с графикой и графическими библиотеками (GraphABC, OpenGL и пр.).
Проектирование игр:
Инструкции, советы и пр.:
Инструкции, касающиеся работы с PascalABC.NET, советы для новичков и пр.
Работа со строками:
Базовые алгоритмы:
23
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
23.03.2013, 15:03
Ответы с готовыми решениями:

Модуль для PascalABC.NET
Здравствуйте уважаемые форумчане, возник вопрос почему не работает модуль. ...

Процедура GetMem для PascalABC.NET
Долго долго курил страницы форума, изучал динамические списки. Когда код для...

Исправить код для PascalABC.net
как минимум, первое место которое ему не нравиться это как я обьявляю тип...

Есть ли PascalABC.NET для Mac OS X?
Есть ли PascalABC.NET для Mac OS X?

В чем разница PascalABC.net и PascalABC
Скажите в чем разница PascalABC.net И PascalABC. Помню когда-то давно программы...

121
КонецСвета
Почетный модератор
7928 / 3899 / 2464
Регистрация: 30.10.2011
Сообщений: 5,379
15.06.2013, 20:19 #41
В: Нужен график розы Гранди.
О:
Пятилепестковая роза Гранди
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
uses GraphABC;
begin
  SetWindowSize(800,600);
  Coordinate.Origin := Window.Center; // Координаты начала координат - в центре окна
  Coordinate.SetMathematic;           // устанавливаем обычную математическую систему координат
  line(-400,0,400,0);                 //строим оси координат
  line(0,-300,0,300);
  var a: real :=0;
  var n:=5;
 Repeat
    var r:=2*sin(n*a);             // вычисляем значение функции
      var x:=round(r*100*Cos(a));  // переводим в "экранные"
      var y:=round(r*100*Sin(a));  // координаты и округляем. Деление на 10 позволяет уменьшить радиус
      PutPixel(x,y,ClMaroon);             // рисуем точку на графике
      a:=a+0.001
  until a>=180
end.
образец
Полезные коды для PascalABC.NET

Не по теме:

небольшое послесловие
большая часть работ сделана изначально под Pabc и, следовательно, совместима с ним при небольшой переделке)

2
КонецСвета
Почетный модератор
7928 / 3899 / 2464
Регистрация: 30.10.2011
Сообщений: 5,379
15.06.2013, 20:19 #42
В: Нужна кардиоида.
О:
кардиоида
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
uses GraphABC;
begin
  SetWindowSize(800,600);
  Coordinate.Origin := Window.Center; // Координаты начала координат - в центре окна
  Coordinate.SetMathematic;           // устанавливаем обычную математическую систему координат
  line(-400,0,400,0);                 //строим оси координат
  line(0,-300,0,300);
  var a: real :=0;
 Repeat
    var r:=12*(1-cos(a));             // вычисляем значение функции
      var x:=round(r*10*Cos(a));  // переводим в "экранные"
      var y:=round(r*10*Sin(a));  // координаты и округляем. Деление на 10 позволяет уменьшить радиус
      PutPixel(x,y,ClMaroon);             // рисуем точку на графике
      a:=a+0.001
  until a>=360
end.
образец
Полезные коды для PascalABC.NET

Не по теме:

небольшое послесловие
большая часть работ сделана изначально под Pabc и, следовательно, совместима с ним при небольшой переделке)

2
КонецСвета
Почетный модератор
7928 / 3899 / 2464
Регистрация: 30.10.2011
Сообщений: 5,379
15.06.2013, 22:47 #43

Не по теме:

лирическое отступление
всякий раз, открывая справку по цветам Pabc.NET, содрогаюсь: сейчас придется напрячь знание английского и воображение, чтобы подобрать из всего многообразия цветов те, что наиболее подходят для решения поставленной задачи... результатом одного из визитов в справку стала эта программа. ..в идеале, конечно, следовало сделать вывод в какой-нибудь label или копирование в буфер обмена.. но руки не дошли)


В: Как наглядно сопоставить названия цветов в Pabc.NET с их образцами?
О:
Палитра - справочник цветов Pabc.NET
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
uses graphABC;
//массив цветов 
const col: array [1..10,1..14] of color=
      ((clAquamarine,     clBisque,       clBlue,                 clBurlyWood,      clChocolate,        clCornsilk,       clDarkBlue,       clDarkGray,         clDarkMagenta,    clDarkOrchid,     clDarkSeaGreen,         clDarkViolet,     clDeepSkyBlue,    clFirebrick     ),
       (clFuchsia,        clGold,         clGreen,                clHotPink,        clIvory,            clLavenderBlush,  clLightBlue,      clLightGray,        clLightPink,      clLightSkyBlue,   clLightYellow,          clLinen,          clMediumBlue,     clMediumPurple  ),
       (clMoneyGreen,     clNavy,         clMediumSpringGreen,    clMediumTurquoise,clOliveDrab,        clOrchid,         clPaleTurquoise,  clPeachPuff,        clMediumVioletRed,clRed,            clSaddleBrown,          clSeaGreen,       clSilver,         clSlateGray     ),
       (clSteelBlue,      clThistle,      clTurquoise,            clWhite,          clYellowGreen,      clAzure,          clBlack,          clBlueViolet,       clCadetBlue,      clCoral,          clCrimson,              clDarkCyan,       clDarkGreen,      clDarkOliveGreen),
       (clDarkRed,        clDarkSlateBlue,clDeepPink,             clDimGray,        clFloralWhite,      clGainsboro,      clGoldenrod,      clGreenYellow,      clIndianRed,      clKhaki,          clLawnGreen,            clLightCoral,     clLightGreen,     clLightSalmon   ),
       (clLightSlateGray, clLime,         clMagenta,              clMediumOrchid,   clMediumSeaGreen,   clPlum,           clMidnightBlue,   clMoccasin,         clOldLace,        clOrange,         clPaleGoldenrod,        clPaleVioletRed,  clPeru,           clPowderBlue    ),
       (clRosyBrown,      clSalmon,       clSeaShell,             clSkyBlue,        clSnow,             clTan,            clTomato,         clViolet,           clWhiteSmoke,     clBeige,          clBlanchedAlmond,       clBrown,          clChartreuse,     clCornflowerBlue),
       (clCyan,           clDarkGoldenrod,clDarkKhaki,            clDarkOrange,     clDarkTurquoise,    clDarkSlateGray,  clDarkSalmon,     clDodgerBlue,       clForestGreen,    clGhostWhite,     clGray,                 clHoneydew,       clIndigo,         clLavender      ),
       (clLemonChiffon,   clLightCyan,    clLightGoldenrodYellow, clLightSeaGreen,  clLightSteelBlue,   clLimeGreen,      clMaroon,         clMediumAquamarine, clMediumSlateBlue,clMistyRose,      clMintCream,            clNavajoWhite,    clOlive,          clOrangeRed     ),
       (clPaleGreen,      clPapayaWhip,   clPink,                 clPurple,         clRoyalBlue,        clSandyBrown,     clSienna,         clSlateBlue,        clSpringGreen,    clTeal,           clTransparent,          clWheat,          clYellow,         clYellow        ));
//массив названий цветов
textcol: array [1..10,1..14] of string=
      (('clAquamarine',     'clBisque        ','clBlue                 ','clBurlyWood      ','clChocolate        ','clCornsilk       ','clDarkBlue       ','clDarkGray         ','clDarkMagenta    ','clDarkOrchid     ','clDarkSeaGreen         ','clDarkViolet     ','clDeepSkyBlue    ','clFirebrick'     ),
       ('clFuchsia',        'clGold          ','clGreen                ','clHotPink        ','clIvory            ','clLavenderBlush  ','clLightBlue      ','clLightGray        ','clLightPink      ','clLightSkyBlue   ','clLightYellow          ','clLinen          ','clMediumBlue     ','clMediumPurple'  ),
       ('clMoneyGreen',     'clNavy          ','clMediumSpringGreen    ','clMediumTurquoise','clOliveDrab        ','clOrchid         ','clPaleTurquoise  ','clPeachPuff        ','clMediumVioletRed','clRed            ','clSaddleBrown          ','clSeaGreen       ','clSilver         ','clSlateGray'     ),
       ('clSteelBlue',      'clThistle       ','clTurquoise            ','clWhite          ','clYellowGreen      ','clAzure          ','clBlack          ','clBlueViolet       ','clCadetBlue      ','clCoral          ','clCrimson              ','clDarkCyan       ','clDarkGreen      ','clDarkOliveGreen'),
       ('clDarkRed',        'clDarkSlateBlue ','clDeepPink             ','clDimGray        ','clFloralWhite      ','clGainsboro      ','clGoldenrod      ','clGreenYellow      ','clIndianRed      ','clKhaki          ','clLawnGreen            ','clLightCoral     ','clLightGreen     ','clLightSalmon'   ),
       ('clLightSlateGray', 'clLime          ','clMagenta              ','clMediumOrchid   ','clMediumSeaGreen   ','clPlum           ','clMidnightBlue   ','clMoccasin         ','clOldLace        ','clOrange         ','clPaleGoldenrod        ','clPaleVioletRed  ','clPeru           ','clPowderBlue'    ),
       ('clRosyBrown',      'clSalmon        ','clSeaShell             ','clSkyBlue        ','clSnow             ','clTan            ','clTomato         ','clViolet           ','clWhiteSmoke     ','clBeige          ','clBlanchedAlmond       ','clBrown          ','clChartreuse     ','clCornflowerBlue'),
       ('clCyan',           'clDarkGoldenrod ','clDarkKhaki            ','clDarkOrange     ','clDarkTurquoise    ','clDarkSlateGray  ','clDarkSalmon     ','clDodgerBlue       ','clForestGreen    ','clGhostWhite     ','clGray                 ','clHoneydew       ','clIndigo         ','clLavender'      ),
       ('clLemonChiffon',   'clLightCyan     ','clLightGoldenrodYellow ','clLightSeaGreen  ','clLightSteelBlue   ','clLimeGreen      ','clMaroon         ','clMediumAquamarine ','clMediumSlateBlue','clMistyRose      ','clMintCream            ','clNavajoWhite    ','clOlive          ','clOrangeRed'     ),
       ('clPaleGreen',      'clPapayaWhip    ','clPink                 ','clPurple         ','clRoyalBlue        ','clSandyBrown     ','clSienna         ','clSlateBlue        ','clSpringGreen    ','clTeal           ','clTransparent          ','clWheat          ','clYellow         ','clYellow'        ));
 
//процедура рисования образца цвета
procedure usecolor(x,y: integer; c: color);
begin
setbrushcolor(c);
rectangle(x-40,y+40,x,y);
setbrushcolor(clwhite);
end;
//обработчик нажатия кнопки мыши
procedure MouseDown(x,y,mb: integer);
begin
   if (mb=1) and (x>40) and (x<600) and (y>40) and (y<440) then  //если нажата левая кнопка в заданных координатах - вывод соответствующего значения
    begin
    //стираем прошлое значение, выводим новое
    setbrushcolor(clwhite);
    rectangle(0,460,640,550);
    textout(50,460,textcol[y div 40,x div 40]);
    end;
   if (mb=2) then closewindow; //если правая кнопка - закрять окно
end;
 
begin
//размер и заголовок окна
setwindowsize(640,550);
window.Caption:='ЗНАЧЕНИЯ ЦВЕТОВ     (1рПК-выход)';
setpencolor(clwhite);
//параметры шрифта
setfontsize(40);
setfontname('Tachoma');
//в цикле рисуем образцы цвета
for var j:=1 to 10 do
  for var i:=1 to 14 do
      usecolor(i*40+40,j*40,col[j,i]);
 
OnMouseDown := MouseDown;
end.
образец
Полезные коды для PascalABC.NET
4
КонецСвета
Почетный модератор
7928 / 3899 / 2464
Регистрация: 30.10.2011
Сообщений: 5,379
15.06.2013, 22:47 #44
В: Нужна анимация: шарик меняет направление по щелчку мыши.
О:
Сильно хитрый бильярдный шар
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
uses graphABC;
var x,y,kx,ky: integer;
 
//процедура рисования кнопок
procedure keys;
begin
setbrushcolor(clwhite);
rectangle(200,150,240,190);
rectangle(260,150,300,190);
rectangle(200,210,240,250);
rectangle(260,210,300,250);
setpenwidth(4);
//левая верхняя стрелка
line(210,160,230,180);
line(210,160,210,170);
line(210,160,220,160);
//правая верхняя стрелка
line(290,160,270,180);
line(290,160,290,170);
line(290,160,280,160);
//левая нижняя стрелка
line(230,220,210,240);
line(210,240,210,230);
line(210,240,220,240);
//правая нижняя стрелка
line(270,220,290,240);
line(290,240,290,230);
line(280,240,290,240);
setpenwidth(1);
end;
//процедура рисования фона - бильярдный стол
procedure Fon;
begin
clearwindow;
setbrushcolor(clbrown);
rectangle(10,10,490,390);
setbrushcolor(clgreen);
rectangle(20,20,480,380);
setbrushcolor(clbrown);
keys;
end;
//обработка нажатия кнопки мыши
procedure MouseDown(x,y,mb: integer);
begin
  if mb=1 then //если левая кнопка
     begin
     if (x>200) and (x<240) and (y>150) and (y<190) then 
        begin
        kx:=-1; ky:=-1;
        end;
     if (x>260) and (x<300) and (y>150) and (y<190) then
        begin
        kx:=1; ky:=-1;
        end;
     if (x>200) and (x<240) and (y>210) and (y<250) then
        begin
        kx:=-1; ky:=1;
        end;
     if (x>260) and (x<300) and (y>210) and (y<250) then
        begin
        kx:=1; ky:=1;
        end;
     end;
end;
//процедура рисования шарика
procedure Shar(var xx,yy,kkx,kky: integer);
begin
if (xx<30) or (xx>470) then kkx:=kkx*(-1);
if (yy<30) or (yy>370) then kky:=kky*(-1);
xx:=xx+kkx;
yy:=yy+kky;
setbrushcolor(clwhite);
circle(xx,yy,10);
end;
 
begin
lockdrawing;
Fon;
//обработчик нажатия
OnMouseDown:=MouseDown;
x:=250;
y:=200;
//бесконечный цикл
repeat
Fon;
Shar(x,y,kx,ky);
sleep(10);
redraw;
until false;
end.
образец
Полезные коды для PascalABC.NET

Не по теме:

небольшое послесловие
большая часть работ сделана изначально под Pabc и, следовательно, совместима с ним при небольшой переделке)

4
КонецСвета
Почетный модератор
7928 / 3899 / 2464
Регистрация: 30.10.2011
Сообщений: 5,379
15.06.2013, 22:47 #45
В: Нужна программа, где автомобиль движется по нажатию клавиш на клавиатуре.
Движение автомобиля по нажатию клавиш --> <--.
О:
Кликните здесь для просмотра всего текста
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
uses graphABC;
 
var x0:integer;
 
//процедура рисования фона
procedure Fon;
begin
clearwindow(clskyblue);
setpencolor(clgreen);
setbrushcolor(clgreen);
rectangle(0,420,900,600);
//дорога
setpencolor(clgray);
setbrushcolor(clgray);
rectangle(0,450,900,550);
setpencolor(clyellow);
setbrushcolor(clyellow);
circle(800,100,50);
end;
//процедура рисования колес
procedure Koleso(xk1,yk1,xk2,yk2,uu: integer);
var r,i:integer;
    u:real;
begin
r:=15;u:=uu;
setbrushcolor(clblack);
setpencolor(clblack);
circle(xk1,yk1,r+10);
circle(xk2,yk2,r+10);
setbrushcolor(clwhite);
circle(xk1,yk1,r);
circle(xk2,yk2,r);
for i:=1 to 4 do
    begin
    line(xk1,yk1,xk1+round(r*cos(u)),yk1-round(r*sin(u)));
    line(xk2,yk2,xk2+round(r*cos(u)),yk2-round(r*sin(u)));
    u:=u+(pi/2);
    end;
end;
//процедура рисования автомобиля
procedure Auto(x: integer);
var uu: integer;
begin
    uu:=-(x mod 100);
    setpenwidth(3);
    setpencolor(clred);
    setbrushcolor(clred);
    ellipse(x-100,350,x+100,450);
    setbrushcolor(clwhite);
    ellipse(x-90,360,x+90,440);
    setpencolor(clred);
    setbrushcolor(clred);
    rectangle(x-150,400,x+150,450);
    rectangle(x-10,355,x+10,450);
    Koleso(x-100,450,x+100,450,uu);
    redraw;
end;
//обработка нажатия клавиш
procedure KeyDown(Key: integer);
begin
  case Key of
       VK_Left: if x0>200 then x0:=x0-2;
       VK_Right: if x0<700 then x0:=x0+2;
  end;
  clearwindow;
  Fon;
  Auto(x0);
end;
 
//основная программа
begin
//запрет на рисование в рабочем окне
lockdrawing;
//размер окна
setwindowsize(900,600);
//начальное значение позиции авто
x0:=200;
Fon;
Auto(x0);
OnKeyDown:=KeyDown;
end.
образец
Полезные коды для PascalABC.NET

Не по теме:

небольшое послесловие
большая часть работ сделана изначально под Pabc и, следовательно, совместима с ним при небольшой переделке)

2
Puporev
Модератор
54374 / 41960 / 28983
Регистрация: 18.05.2008
Сообщений: 98,839
19.06.2013, 12:17 #46
Тема называется
Полезные коды для PascalABC.NET
И это не значит что сюда нужно переписывать все программы из раздела Паскаль.
Поэтому последнюю тему от Новичок, я удаляю, в ней нет ничеuо от.net
1
TheKotee1
6 / 1 / 0
Регистрация: 20.06.2013
Сообщений: 5
24.06.2013, 14:00 #47
В: Как сделать запрос перед закрытием формы?
О:
Подтверждение закрытия формы

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
{$apptype windows}
{$reference 'System.Windows.Forms.dll'}
 
uses
  System.Windows.Forms;
 
var
  MyForm: Form;
 
procedure FormClosing(sender: object; e: system.ComponentModel.CancelEventArgs);
begin
  e.Cancel := messagebox.Show('Вы действительно хотите выйти?', 'Выход', MessageboxButtons.YesNo) = dialogresult.No;
  //e.cancel - логическая переменная. Если e.cancel = true, происходит отмена закрытия формы
end;
 
begin
  MyForm := new Form;            //Создаем форму
  MyForm.Closing += FormClosing; //Ставим обработчик на событие
  application.Run(MyForm);
end.
1
BaboshinSD
334 / 273 / 49
Регистрация: 15.11.2012
Сообщений: 477
Записей в блоге: 1
24.06.2013, 17:30  [ТС] #48
В: Как программно двигать курсор мыши?
О:
Двигаем курсор мыши (программно)

Pascal
1
2
3
4
5
6
7
//Подключение функции "SetCursorPos" из "неуправляемой" dll (user32.dll), которая устанавливает позицию курсора мыши в заданные коордитнаты
function SetCursorPos(x, y: integer): boolean;
external 'user32.dll';
 
begin
  SetCursorPos(10, 10); // Перемещаем мышь в координаты 10, 10
end.
4
BaboshinSD
334 / 273 / 49
Регистрация: 15.11.2012
Сообщений: 477
Записей в блоге: 1
24.06.2013, 17:30  [ТС] #49
В: Как сделать клик мышью?
О:
Эмулируем клик мыши

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
//Подключение функции API Windows "mouse_event", которая позволяет управлять мышью
function mouse_event(dwFlags, dx, dy, dwData, dwExtraInfo: integer): boolean;
external 'user32.dll';
 
//Значения параметра dwFlags, определяющие поведение функции mouse_event
const
  MOUSEEVENTF_LEFTDOWN = 2;
  MOUSEEVENTF_LEFTUP = 4;
 
begin
  mouse_event(MOUSEEVENTF_LEFTDOWN or MOUSEEVENTF_LEFTUP, 0, 0, 0, 0); // Одиночный клик мышью
end.
Для клика по определённым координатам можно воспользоваться этим кодом. Ещё с помощью этого кода можно выделять текст, а так же делать много других полезных вещей. Мб позже выложу примеры
1
BaboshinSD
334 / 273 / 49
Регистрация: 15.11.2012
Сообщений: 477
Записей в блоге: 1
24.06.2013, 17:30  [ТС] #50
Цитата Сообщение от КонецСвета Посмотреть сообщение
а графика в Pabc.NET - она больше для души, чем для дела
Цитата Сообщение от Новичок Посмотреть сообщение
Это в принципе правда,на олимпиадах нет задач на графику.Но дружу я во основном с матрицами,строками...
Несомненно, все зависит от аудитории. Если программированию обучается школьник, то графика очень важна - мышление конкретное, и хочется сразу видеть результаты своего труда. Абстрактное мышление быстро утомляет. Если программировать учится студент - здесь другая картина. Графика нужна по большей мере как вспомогательное средство для визуализации результатов, динамики выполнения алгоритмов. Но что однозначно - графика нужна.
(с) Статьи с оф. сайта PascalABC.NET
0
serёга
46 / 41 / 12
Регистрация: 27.08.2012
Сообщений: 290
26.06.2013, 11:02 #51
В: Как 3D-координаты проецировать на 2D плоскость экрана?
О: Функция XYZ:

Pascal
1
2
3
4
  Function XYZ (x, y, z: integer): System.Drawing.Point;
  Begin
    Result:= new System.Drawing.Point (Round(cw + x * 200/ (z+200)), Round(ch - y *200/(z+200)));
 End;
Где cw и ch центры ширины и высоты дисплея.
3
Ragnazar
37 / 37 / 13
Регистрация: 09.03.2013
Сообщений: 114
Записей в блоге: 2
29.06.2013, 21:29 #52
В: Как получить значение переменной через название(string)?
О:
Функция getValue
Pascal
1
2
3
4
5
6
function getValue(variable:string):object;
begin
try
Result:=system.Reflection.methodBase.GetCurrentMethod.ReflectedType.GetField(variable).GetValue(new object);
except on System.NullReferenceException do end;
end;
Пример использования
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
function getValue(variable:string):object;
begin
try
Result:=system.Reflection.methodBase.GetCurrentMethod.ReflectedType.GetField(variable).GetValue(new object);
except on System.NullReferenceException do
Result:='Variable not found'; end;
end;
 
var 
s1:='ONE';
s2:='STRING';
s3:='12736BlahBVlalBlalgksgl';
 
begin
for var i:=1 to 3 do
writeln(getValue('s'+i));
end.

1
AltTwo
5 / 1 / 2
Регистрация: 13.06.2013
Сообщений: 20
20.07.2013, 12:42 #53
В: Как определить ширину экрана?
О:
Кликните здесь для просмотра всего текста
Pascal
1
2
Screen.GetBounds(new Point(0,0)).Width
//аналогично для высоты
1
Ragnazar
37 / 37 / 13
Регистрация: 09.03.2013
Сообщений: 114
Записей в блоге: 2
23.07.2013, 23:57 #54
AltTwo,
Или
Pascal
1
Screen.PrimaryScreen.Bounds.Width
а вообще Bounds это system.drawing.Rectangle и из него можно вытащить и X и Y и Top и Left

Добавлено через 7 минут
И прочие полезности. А еще есть массив всех экранов. Но я подзабыл код а комп далеко
1
КонецСвета
Почетный модератор
7928 / 3899 / 2464
Регистрация: 30.10.2011
Сообщений: 5,379
29.07.2013, 14:27 #55
Забавы математиков Сделано в Маткаде вдохновили...

В: Нарисовать сердце в паскале
О:
x=16sin^3t, y=13cost-5cos2t-2cos3t-cos4t
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
uses GraphABC;
begin
  SetWindowSize(800,600);
  Coordinate.Origin := Window.Center; // Координаты начала координат - в центре окна
  Coordinate.SetMathematic;           // устанавливаем обычную математическую систему координат
  line(-400,0,400,0);                 //строим оси координат
  line(0,-300,0,300);
 var r:=15; 
 for var i:=1 to 8 do  //цикл для рисования "вложенных" сердец
  begin
  var a: real :=0;
  Repeat
      var x:=round(r*16*sin(a)*sin(a)*sin(a)); // вычисляем функцию, переводим в "экранные"
      var y:=round(r*13*cos(a)-r*5*cos(2*a)-r*2*cos(3*a)-r*cos(4*a));  // координаты и округляем.
      PutPixel(x,y,ClMaroon);             // рисуем точку на графике
      a:=a+0.001
  until a>=180;
  dec(r,2);   //уменьшение "масштаба"
  end;
end.
образец
Полезные коды для PascalABC.NET
3
Виталий777555
13 / 13 / 6
Регистрация: 19.11.2012
Сообщений: 94
01.08.2013, 11:49 #56
предыстория
Моя первая игра Арканойд, точнее здесь только 1/3 моей заслуги, т.к мы с преподавателем писали её на PascalABC + там использовалась библиотека Ukeyb, но я перевёл ее на PascalABC.NET уже только с библиотекой GraphABC без Ukeyb. Вот код игры :

В: Помогите написать игру Арканоид!
О:
Арканоид
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
program arcanoid;
uses
   graphabc;   //,ukeyb;
var
   //картинки
   pula, ball, zast, fon: Picture;
   flame: array[1..5]of Picture;//Массив пламени
   brick: array[1..3]of Picture;//Массив кирпичей
   bita: array[1..4]of Picture;//Массив бит
   bonus: array[1..3]of Picture;//Массив бонусов
   //Свойства объектов
   xs, ys, vxs, vys, ks: integer;//Свойство шарика
   ps: boolean;
   xb, yb, vb, db, nb: integer;//Свойства биты
   kir: array[1..3, 1..16, 1..10]of byte;//расположение кирпичей
   xbon, ybon, vbon: array[1..5]of integer;//свойства бонусов
   lbon: array[1..5]of boolean;
   xp, yp: array[1..10]of integer;//свойства пуль
   lp: array[1..10] of boolean;
   level, i, j, n: integer;
   f: text;
   s: string;
   xk, yk, v, kp, zadp, kk: integer;
  kUpKey, kDownKey, kLeftKey, kRightKey,kSpaceKey,kLControlKey: boolean;// Состояние клавиш Влево,Вправо,Вверх,Вниз
/// Событие - обработчик нажатия клавиатуры
procedure KeyDown(Key: integer);
begin
   case Key of
      vk_Left:  kLeftKey := True;
      vk_Right: kRightKey := True;
      vk_Up:    kUpKey := True;
      vk_Down:  kDownKey := True;
      VK_Space : kSpaceKey :=true;
      VK_LControlKey: kLControlKey:=true;
   end;
end;
/// Событие - обработчик отжатия клавиатуры
procedure KeyUp(Key: integer);
begin
   case Key of
      vk_Left:  kLeftKey := False;
      vk_Right: kRightKey := False;
      vk_Up:    kUpKey := False;
      vk_Down:  kDownKey := False;
      VK_Space : kSpaceKey :=False;
      VK_LControlKey:kLControlKey:=False;
   end;
end;
///Событие бонус
procedure createbonus;
var
   ver, k: integer;
begin
   if kir[level, xk, yk] = 0 then //кирпич совсем разбит
   begin
      ver := 1 + random(13);
      if ver <= 3 then
         for k := 1 to 5 do
            if not lbon[k] then
            begin
               lbon[k] := true;
               xbon[k] := (xk - 1) * 50 + 12;
               ybon[k] := (yk - 1) * 25;
               vbon[k] := ver;
               break;
            end;
   end;
end;
begin
 
   //задаем размеры и свойства окна
   setwindowsize(800, 600);//Задание размеров окна
   Window.Clear;//Очистка окна
   centerwindow;//Центрирование окна
   setwindowcaption('Arcanoid  группа 223, переведена мною на PascalABC.NET :) ');//Название заголовка на окне
   //загружаем отдельные картинки
   fon := Picture.Create(800, 600);//Создание переменной для фона
   fon.load('Фон.bmp');//Загрузка фона
   zast := Picture.Create(800, 600);//Создание переменной для заставки
   zast.load('Заставка.bmp');//Загрузка заставки
   ball := Picture.Create(20, 20);//Создание переменной для шарика
   ball.load('Шарик.bmp'); //загрузка шарика
   ball.Transparent := true;//Задаёт прозрачность шарика активным
   ball.TransparentColor := clWhite;//Выбор цвета который должен быть прозрачным
   pula := Picture.Create(5, 10);//Создание переменной для пули
   pula.load('Пуля.bmp');//Загрузка пули 
   pula.Transparent := true;//Задаёт прозрачность пули активны
   pula.TransparentColor := clWhite;
   OnKeyDown := KeyDown;
   OnKeyUp:=KeyUp;
   //загружаем группы картинок--------1
   for i := 1 to 5 do//----Цикл загрузки пламени
   begin
      flame[i] := Picture.Create(800, 30);//Создание переменных для пламени
      flame[i].load('Пламя' + inttostr(i) + '.bmp');//Загрузка видов пламени в массив
      flame[i].Transparent := true;//Задаем прозрачность пламени
      flame[i].TransparentColor := clWhite;//Прозрачный цвет, белый
   end;
   for i := 1 to 4 do//----Цикл загрузки бит
   begin//--------2
      bita[i] := Picture.Create(100, 15);//Создание переменной для биты 1
      bita[i].load('Бита' + inttostr(i) + '.bmp');//Загрузка бит
      bita[i].transparent := true;//биты прозрачные
      bita[i].TransparentColor := clWhite;//Прозрачный цвет, белый
   end;
   for i := 1 to 3 do//----Цикл загрузки кирпичей
   begin//----------3
      brick[i] := Picture.Create(75, 15);//Создание переменных для кирпичей
      brick[i].load('Кир' + inttostr(i) + '.bmp');//Загрузка кирпичей
      brick[i].transparent := true;//делаем кирпичи прозрачными
      brick[i].TransparentColor := clBlack;//Прозрачный цвет, черный
   end;
   for i := 1 to 3 do//----Цикл загрузки бонусов
   begin//----------4
      bonus[i] := Picture.Create(25, 25);//Создание переменных для бонусов
      bonus[i].load('бонус' + inttostr(i) + '.bmp');//Загузка бонусов
      bonus[i].transparent := true;//Прозрачность бонусов
      bonus[i].TransparentColor := clWhite;//Прозрачный цвет, белый
   end;
   //загружаем карту с кирпичами
   assign(f, 'Кладка.txt');//связка с файлом Кладка.txt
   reset(f);//чтение файла Кладка.txt
   for n := 1 to 3 do//Цикл считывания вида кирпичей
   begin
      for i := 1 to 10 do//Цикл считывания строчки(ряда) кирпичей
      begin
         readln(f, s);
         for j := 1 to 16 do//Цикл считывания столбца кирпичей
            kir[n, j, i] := strtoint(s[j]);//Запись данных кирпичей в массив
      end;
      readln(f, s);
   end;
   close(f);//Закрытие файла Кладка.txt
   //показываем заставку и ждем нажатия клавиши или определенное время
   zast.draw(0, 0);//показ заставки
   n := 0;
   repeat
      sleep(1000);
      n := n + 1;
   until (kSpaceKey)or(n = 5);//Показываем заставку пока не пройдет 5 секунд или не будет нажат пробел
    lockdrawing;
   //разделяем видимую и активную видеостраницы
      //задаем начальные параметры игры
   ps := true;//в начале шарик прилип
   ks := 5;//кол-во шариков в начале 3
   level := 1;
   vb := 2; //начальное состояние биты
   v := 3;//начальная скорость шарика
   db := 150;
   xb := 325;
   yb := 555;
   nb := 0;
   for i := 1 to 10 do
      lp[i] := false;//пули не летят
   zadp := 0;
   for i := 1 to 5 do
      lbon[i] := false;//бонусов нет
   repeat //=====================
      //показываем кадр с текущим положением всех объектов
      fon.draw(0, 0);//отображение фона
      for i := 1 to 16 do
         for j := 1 to 10 do
            if kir[level, i, j] > 0 then
               brick[kir[level, i, j]].draw((i - 1) * 50, (j - 1) * 25);//отображение кирпичей
               flame[1+random(5)].draw( 0, 570);//Отображение пламени в случаяном порядке
        //Отображение нашей биты и изменение её координат в соответствии нажатой клавиши
      ball.draw(xs, ys);//Отображения шарика в данных координатах
      bita[vb].draw(xb, yb);//Отображение нашей биты и изменение её координат в соответствии нажатой клавиши
      for i := 1 to 5 do
         if lbon[i] then
            bonus[vbon[i]].draw(xbon[i], ybon[i]);//отображ-е наши случайные бонусы?
            setbrushcolor(clblack);
      for i := 1 to 10 do//пули
         if lp[i] then
            pula.draw(xp[i], yp[i]);//пули
      redraw;
      //если шарик не прилип то передвиним шарик
      if not ps then
      begin
         xs := xs + vxs;
         ys := ys + vys;
         //если шарик задел стену или биту, отражается
         if xs <= 0 then
            vxs := v;
         if xs + 20 >= 800 then
            vxs := -v;
         if ys <= 0 then
            vys := v;
         if (xs + 10 >= xb) and (xs + 10 <= xb + db) and (ys + 20 >= yb) and (ys + 20 <= yb + 5) then
         begin
            vys := -v;
            vxs := v * nb;
         end;
         //если шарик задел кирпич, кирпич разбивается, а шарик отражается
         //с некоторой вероятностью появляется бонус
         xk := (xs + 10) div 50 + 1;
         yk := ys div 25 + 1;
         if (yk > 0) and (yk <= 10) and (xk > 0) and (xk <= 16) then
            if kir[level, xk, yk] > 0 then //кирпич сверху отразимся вниз
            begin
               vys := v;
               kir[level, xk, yk] := kir[level, xk, yk] - 1;
               createbonus;
            end;
         xk := (xs + 10) div 50 + 1;
         yk := (ys + 20) div 25 + 1;
         if (yk > 0) and (yk <= 10) and (xk > 0) and (xk <= 16) then
            if kir[level, xk, yk] > 0 then //кирпич снизу отразимся вверх
            begin
               vys := -v;
               kir[level, xk, yk] := kir[level, xk, yk] - 1;
               createbonus;
            end;
         xk := xs div 50 + 1;
         yk := (ys + 10) div 25 + 1;
         if (yk > 0) and (yk <= 10) and (xk > 0) and (xk <= 16) then
            if kir[level, xk, yk] > 0 then //кирпич слева отразимся вправо
            begin
               vxs := v;
               kir[level, xk, yk] := kir[level, xk, yk] - 1;
               createbonus;
            end;
         xk := (xs + 20) div 50 + 1;
         yk := (ys + 10) div 25 + 1;
         if (yk > 0) and (yk <= 10) and (xk > 0) and (xk <= 16) then
            if kir[level, xk, yk] > 0 then //кирпич справа отразимся влево
            begin
               vxs := -v;
               kir[level, xk, yk] := kir[level, xk, yk] - 1;
               createbonus;
            end;
         //если шарик попал в пламя, то хп уменьшается или заканчивается
         if ys >= yb + 15 then
         begin
            ps := true;
            ks := ks - 1;
            sleep(1000);
            if ks = 0 then break;
         end
      end
      //а если шарик прилип то двигаем его вместе с битой
      else
      begin
         xs := xb + db div 2 - 10;
         ys := yb - 20;
      end;
      
      //передвигаем бонусы
      for i := 1 to 5 do
         if lbon[i] then
         begin
            ybon[i] := ybon[i] + 3;
            if ybon[i] > yb + 15 then//улетел в огонь
               lbon[i] := false
            else
            if (xbon[i] + 13 >= xb) and (xbon[i] + 13 <= xb + db) and (ybon[i] + 25 >= yb) and (ybon[i] + 25 <= yb + 15) then
            begin
               lbon[i] := false;
               case vbon[i] of
                  1:
                     begin//увеличем биту
                        if vb < 3 then
                           vb := vb + 1
                        else
                           vb := 3;
                        db := 50 + vb * 50;
                     end;
                  2:
                     begin//уменшим биту
                        if vb > 1 then vb := vb - 1;
                        db := 50 + vb * 50;
                     end;
                  3:
                     begin//пулемёт
                        vb := 4;
                        db := 75;
                     end;
               end;
            end;
         end;
      //передвигаем летящие пули(если долетела до верха, исчеазает)
      for i := 1 to 10 do
         if lp[i] then
         begin
            yp[i] := yp[i] - 7;
            if yp[i] < -10 then
               lp[i] := false;
         end;
      //если пуля попала в кирпич, он и она исчезают
      for i := 1 to 10 do
         if lp[i] then
         begin
            xk := (xp[i] + 2) div 50 + 1;
            yk := yp[i] div 25 + 1;
            if (xk > 0) and (xk <= 16) and (yk > 0) and (yk <= 10) then
               if kir[level, xk, yk] > 0 then
               begin
                  lp[i] := false;
                  kir[level, xk, yk] := 0;
               end;
         end;
      //передвигаем биту, под управлением клавиш стрелок
      if (kLeftKey) then
      begin
         if xb > 0 then
         begin
            xb := xb - 5;
            
         end;
         nb := -1;
      end
      else
      if (kRightKey) then
      begin
         if xb + db < 800 then
         begin
            xb := xb + 5;
            
         end;
         nb := 1;
      end
      else
         nb := 0;
      //если нажат пробел и бита-пулемет, выпускаем пулю
      zadp := zadp + 1;
      if zadp = 10 then
      begin
         zadp := 0;
         if (kspacekey) and (vb = 4) then
         begin
            kp := 0;
            for i := 1 to 10 do
               if not lp[i] then
               begin
                  kp := kp + 1;
                  if kp = 1 then
                  begin
                     lp[i] := true;
                     xp[i] := xb + 20;
                     yp[i] := yb;
                  end
                  else
                  if kp = 2 then
                  begin
                     lp[i] := true;
                     xp[i] := xb + 55;
                     yp[i] := yb;
                     break;
                  end;
               end;
         end;
      end;
      //если нажат пробел и шарик приклеен к бите то в зависимости
      //от направления движения биты выпускаем туда шарик
      if (kspacekey) then
         if ps then
         begin
            ps := false;
            vys := -v;
            vxs := nb * v;
         end;
      //если нажаты стрелки вверх или вниз вместе с левым ctrl меняем скорость шарика в пределах допустимого
      if ((kLControlKey)) and ((kUpKey)) then  //увеличиваем скорость
      begin
         if v < 30 then
            v := v + 1;
      end;
      if ((kLControlKey)) and ((kDownKey)) then  //уменьшаем скорость
      begin
         if v > 1 then
            v := v - 1;
      end;
      //если кирпичей не осталось, увеличиваем уровень
      kk := 0;
      for i := 1 to 16 do
         for j := 1 to 10 do
            if kir[level, i, j] > 0 then
               kk := kk + 1;
               
      if kk = 0 then
      begin
         level := level + 1;
         ks := 3;
         ps := true;
      end;
     until level = 4;//==============
   //сообщаем об выгреше или проигрыше
   if ks = 0 then
   begin//проиграли
      zast.load('заст1.bmp');
      zast.draw(0, 0);
   end
   else
   begin//Выйграли
      zast.load('заст2.bmp');
      zast.draw(0, 0);
   end;
   while true do
   begin
         redraw;
   end;    
end.
образец
Полезные коды для PascalABC.NET
текст программы и необходимые ресурсы в архиве


Надеюсь этот код программы поможет кому нибудь в разработке своих игр
5
BaboshinSD
334 / 273 / 49
Регистрация: 15.11.2012
Сообщений: 477
Записей в блоге: 1
15.08.2013, 12:51  [ТС] #57

Не по теме:

Что-то давно ничего не выкладывал, и вот меня в ЛС спросили об одной вещи, погуглив немного я понял что это довольно частый вопрос, вот пример:


В: Как получить код html-страницы, загруженной, в WebBrowser?
О:
Сохраняем html-код страницы из WebBrowser'а

Тут, для примера я сохранил код в .txt файл.
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
{$apptype windows}
{$reference 'System.Windows.Forms.dll'}
{$reference 'System.Drawing.dll'}
 
uses
  System.Windows.Forms,
  System.Drawing;
 
var
  MainForm: Form;
  Wb: System.Windows.Forms.WebBrowser;
  Tx: PABCSystem.Text;
  
procedure DocCompl(sender: Object; e: System.Windows.Forms.WebBrowserDocumentCompletedEventArgs);
begin 
  Assign(Tx, 'page.txt'); // Связываем переменную с именем файла
  Rewrite(Tx); // Открываем файл на запись
  Write(Tx, Wb.DocumentText); // Записываем в файл html-код страницы
  Close(Tx); // Закрываем файл
end;
  
begin
  MainForm := new Form;
  MainForm.Size := new System.Drawing.Size(600, 400);
  
  Wb := new WebBrowser; // Создаём веб-браузер
  Wb.Dock := System.Windows.Forms.DockStyle.Fill; // Растягиваем на всю форму
  Wb.Navigate('http://www.cyberforum.ru/'); // Загружаем страницу
  Wb.DocumentCompleted += DocCompl; // Событие происходящее если вся страница загружена
  
  MainForm.Controls.Add(Wb);
  
  Application.EnableVisualStyles;
  
  Application.Run(MainForm);
end.
4
Ragnazar
37 / 37 / 13
Регистрация: 09.03.2013
Сообщений: 114
Записей в блоге: 2
16.08.2013, 20:35 #58
В: Как запустить несколько процедур сразу, а не по очереди
О: Потоки!
runAsync
Для объяснения возмем процедуру runAsync (Написана мной)
(system.threading)
Pascal
1
2
3
4
5
procedure runAsync(proc:procedure);
begin
var t:=new Thread(proc);
t.Start;
end;
Эта процедура запускает процедуру proc в другом потоке не затормаживая главный поток.
Думаю многие люди и так знают зачем нужны потоки, а кто не понял спросите в личку, распишу.

Если вы будете пользоваться потоками, то у вас вполне может вылезти ошибка ThreadStateException
Эта ошибка появляется если поток закончился (Выполнил весь данный код)
Что-бы запустить поток снова, создайте его снова через new Thread(procedure)
6
BaboshinSD
334 / 273 / 49
Регистрация: 15.11.2012
Сообщений: 477
Записей в блоге: 1
16.08.2013, 23:02  [ТС] #59

Не по теме:

Вот, в закромах завалялось. Одна из первых моих игрушек :) Если кому-то интересно покопаться в говнокоде - держите.


В: Можно ли с помощью GraphABC написать игру "Крестики-Нолики"?
О:
Игра крестики нолики, с использованием GraphABC

Код программы получился довольно длинный (из-за отрисовки фигур по-координатам), поэтому кусок вынес в модуль. Основная программа:
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
// Игра "Крестики-Нолики"
uses
  GraphABC, Drawing;
 
var
  Field: Array [1..3, 1..3] of Integer; // Игровое поле
  CellWidth, CellHeight: Integer; // Ширина и высота одной клетки
  X_or_O: Boolean; // Ход крестиков или ноликов
 
procedure CreateWindow();// Создание и отрисовка окна
begin
  SetWindowSize(WinWidth, WinHeight);
  SetWindowCaption('Крестики - Нолики');
  // Запрещаем разворачивать окно
  GraphABC.MainForm.MaximizeBox := False;
  // Горизонтальные линии
  for var x := 1 to Round(WinWidth / CellWidth) do
    Line(0, x * CellHeight, WinWidth, x * CellHeight);
  // Вертикальные линии
  for var y := 1 to Round(WinWidth / CellHeight) do
    Line(y * CellWidth, 0, y * CellWidth, WinHeight);
end;
 
procedure Win();// Победа
begin
  SetWindowCaption('Крестики выиграли!');
  LockDrawing();
end;
 
procedure Lose();// Поражение
begin
  SetWindowCaption('Нолики выиграли!');
  LockDrawing();
end;
 
procedure Check();// Проверка на выигрыш
begin
  // Выигрышные положения крестиков (1)
  if (Field[1, 1]) and (Field[2, 1]) and (Field[3, 1]) = 1 then
    Win();
  if (Field[1, 2]) and (Field[2, 2]) and (Field[3, 2]) = 1 then
    Win();
  if (Field[1, 3]) and (Field[2, 3]) and (Field[3, 3]) = 1 then
    Win();
  if (Field[1, 1]) and (Field[1, 2]) and (Field[1, 3]) = 1 then
    Win();
  if (Field[2, 1]) and (Field[2, 2]) and (Field[2, 3]) = 1 then
    Win();
  if (Field[3, 1]) and (Field[3, 2]) and (Field[3, 3]) = 1 then
    Win();
  if (Field[1, 1]) and (Field[2, 2]) and (Field[3, 3]) = 1 then
    Win();
  if (Field[3, 1]) and (Field[2, 2]) and (Field[1, 3]) = 1 then
    Win();
  // Выигрышные положения ноликов (2)
  if (Field[1, 1]) and (Field[2, 1]) and (Field[3, 1]) = 2 then
    Lose();
  if (Field[1, 2]) and (Field[2, 2]) and (Field[3, 2]) = 2 then
    Lose();
  if (Field[1, 3]) and (Field[2, 3]) and (Field[3, 3]) = 2 then
    Lose();
  if (Field[1, 1]) and (Field[1, 2]) and (Field[1, 3]) = 2 then
    Lose();
  if (Field[2, 1]) and (Field[2, 2]) and (Field[2, 3]) = 2 then
    Lose();
  if (Field[3, 1]) and (Field[3, 2]) and (Field[3, 3]) = 2 then
    Lose();
  if (Field[1, 1]) and (Field[2, 2]) and (Field[3, 3]) = 2 then
    Lose();
  if (Field[3, 1]) and (Field[2, 2]) and (Field[1, 3]) = 2 then
    Lose();
end;
 
procedure MoveO();// Ход ноликов
var
  r, r1: Integer;
 
begin
  // Ставим нолик в случайную клетку
  repeat
    r := Random(1, 3);
    r1 := Random(1, 3);
  until Field[r, r1] = 0;
  Field[r, r1] := 2;
  DrawO(r, r1);
  Check();
end;
 
procedure MouseDown(x, y, mb: Integer);// Обрабатываем нажатия
begin
  // Если нажата первая клетка и она пустая (в массиве 0)
  if (x <= CellWidth) and (y <= CellHeight) and (Field[1, 1] = 0) then
  begin
    Field[1, 1] := 1; // Заполняем клетку
    DrawX(1, 1); // Рисуем фигуру
    Check(); // Делаем проверку
    MoveO(); // Ходят нолики
  end;
  // 2-ая клетка
  if (x <= CellWidth * 2) and (y <= CellHeight) and (x > CellWidth) and (Field[2, 1] = 0) then
  begin
    Field[2, 1] := 1;
    DrawX(2, 1);
    Check();
    MoveO();
  end;
  // 3-я клетка
  if (x <= CellWidth * 3) and (y <= CellHeight) and (x > CellWidth * 2) and (Field[3, 1] = 0) then
  begin
    Field[3, 1] := 1;
    DrawX(3, 1);
    Check();
    MoveO();
  end;
  // 4-ая клетка
  if (x <= CellWidth) and (y <= CellHeight * 2) and (y > CellHeight) and (Field[1, 2] = 0) then
  begin
    Field[1, 2] := 1;
    DrawX(1, 2);
    Check();
    MoveO();
  end;
  // 5-ая клетка
  if (x <= CellWidth * 2) and (y <= CellHeight * 2) and (x > CellWidth) and (y > CellHeight) and (Field[2, 2] = 0) then
  begin
    Field[2, 2] := 1;
    DrawX(2, 2);
    Check();
    MoveO();
  end;
  // 6-ая клетка
  if (x <= CellWidth * 3) and (y <= CellHeight * 2) and (x > CellWidth * 2) and (y > CellHeight) and (Field[3, 2] = 0) then
  begin
    Field[3, 2] := 1;
    DrawX(3, 2);
    Check();
    MoveO();
  end;
  // 7-ая клетка
  if (x <= CellWidth) and (y > CellHeight * 2) and (Field[1, 3] = 0) then
  begin
    Field[1, 3] := 1;
    DrawX(1, 3);
    Check();
    MoveO();
  end;
  // 8-ая клетка
  if (x <= CellWidth * 2) and (y > CellHeight * 2) and (x > CellWidth) and (Field[2, 3] = 0) then
  begin
    Field[2, 3] := 1;
    DrawX(2, 3);
    Check();
    MoveO();
  end;
  // 9-ая клетка
  if (x <= CellWidth * 3) and (y > CellHeight * 2) and (x > CellWidth * 2) and (Field[3, 3] = 0) then
  begin
    Field[3, 3] := 1;
    DrawX(3, 3);
    Check();
    MoveO();
  end;
end;
 
begin
  CellWidth := Round(WinWidth / 3); // Ширина одной клетки
  CellHeight := Round(WinHeight / 3); // Высота одной клетки
  
  CreateWindow; // Создаём окно
  SetPenWidth(10); // Устанавливаем толщину крестиков
  
  OnMouseDown := MouseDown; // Обрабатываем нажатия мыши
end.
Модуль Drawing.pas:
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
// Модуль для рисования фигур
unit Drawing;
 
interface
 
uses
  GraphABC;
 
const
  WinWidth = 300; // Ширина окна
  WinHeight = 300; // Высота окна
  PenW = 10; // Толщина фигур
  RadO = 40; // Радиус ноликов 
 
procedure DrawX(x, y: Integer);// Рисование крестиков
procedure DrawO(x, y: Integer);// Рисование ноликов
 
implementation
 
procedure DrawX();// Рисование крестиков (x, y - значения матрицы)
begin
  var CellWidth := Round(WinWidth / 3); // Ширина одной клетки
  var CellHeight := Round(WinHeight / 3); // Высота одной клетки
  SetPenColor(clRed);// Крестики красные
  // Если значения 1, 1 (первая клетка)
  if (x = 1) and (y = 1) then
  begin
    Line(0 + PenW, 0 + PenW, CellWidth - PenW, CellHeight - PenW);
    Line(CellWidth - PenW, 0 + PenW, 0 + PenW, CellHeight - PenW);
  end;
  // 2, 1 (2-ая клетка)
  if (x = 2) and (y = 1) then
  begin
    Line(CellWidth + PenW, 0 + PenW, CellWidth * 2 - PenW, CellHeight - PenW);
    Line(CellWidth * 2 - PenW, 0 + PenW, CellWidth + PenW, CellHeight - PenW);
  end;
  // 3, 1 (3-я клетка)
  if (x = 3) and (y = 1) then
  begin
    Line(CellWidth * 2 + PenW, 0 + PenW, CellWidth * 3 - PenW, CellHeight - PenW);
    Line(CellWidth * 3 - PenW, 0 + PenW, CellWidth * 2 + PenW, CellHeight - PenW);
  end;
  // 1, 2 (4-ая клетка)
  if (x = 1) and (y = 2) then
  begin
    Line(0 + PenW, CellHeight + PenW, CellWidth - PenW, CellHeight * 2 - PenW);
    Line(CellWidth - PenW, CellHeight + PenW, 0 + PenW, CellHeight * 2 - PenW);
  end;
  // 2, 2 (5-ая клетка)
  if (x = 2) and (y = 2) then
  begin
    Line(CellWidth + PenW, CellHeight + PenW, CellWidth * 2 - PenW, CellHeight * 2 - PenW);
    Line(CellWidth * 2 - PenW, CellHeight + PenW, CellWidth + PenW, CellHeight * 2 - PenW);
  end;
  // 3, 2 (6-ая клетка)
  if (x = 3) and (y = 2) then
  begin
    Line(CellWidth * 2 + PenW, CellHeight + PenW, CellWidth * 3 - PenW, CellHeight * 2 - PenW);
    Line(CellWidth * 3 - PenW, CellHeight + PenW, CellWidth * 2 + PenW, CellHeight * 2 - PenW);
  end;
  // 1, 3 (7-ая клетка)
  if (x = 1) and (y = 3) then
  begin
    Line(0 + PenW, CellHeight * 2 + PenW, CellWidth - PenW, CellHeight * 3 - PenW);
    Line(CellWidth - PenW, CellHeight * 2 + PenW, 0 + PenW, CellHeight * 3 - PenW);
  end;
  // 2, 3 (8-ая клетка)
  if (x = 2) and (y = 3) then
  begin
    Line(CellWidth + PenW, CellHeight * 2 + PenW, CellWidth * 2 - PenW, CellHeight * 3 - PenW);
    Line(CellWidth * 2 - PenW, CellHeight * 2 + PenW, CellWidth + PenW, CellHeight * 3 - PenW);
  end;
  // 3, 3 (9-ая клетка)
  if (x = 3) and (y = 3) then
  begin
    Line(CellWidth * 2 + PenW, CellHeight * 2 + PenW, CellWidth * 3 - PenW, CellHeight * 3 - PenW);
    Line(CellWidth * 3 - PenW, CellHeight * 2 + PenW, CellWidth * 2 + PenW, CellHeight * 3 - PenW);
  end;
end;
 
procedure DrawO();// Рисование ноликов (x, y - значения матрицы)
begin
  var CellWidth := Round(WinWidth / 3); // Ширина одной клетки
  var CellHeight := Round(WinHeight / 3); // Высота одной клетки
  SetPenColor(clBlue);// Нолики синие
  // Если значения 1, 1 (первая клетка)
  if (x = 1) and (y = 1) then
  begin
    Circle(Round(CellWidth / 2), Round(CellHeight / 2), 40);
  end;
  // 2, 1 (2-ая клетка)
  if (x = 2) and (y = 1) then
  begin
    Circle(Round(CellWidth / 2 + CellWidth), Round(CellHeight / 2), 40);
  end;
  // 3, 1 (3-я клетка)
  if (x = 3) and (y = 1) then
  begin
    Circle(Round(CellWidth / 2 + CellWidth * 2), Round(CellHeight / 2), 40);
  end;
  // 1, 2 (4-ая клетка)
  if (x = 1) and (y = 2) then
  begin
    Circle(Round(CellWidth / 2), Round(CellHeight / 2 + CellHeight), 40);
  end;
  // 2, 2 (5-ая клетка)
  if (x = 2) and (y = 2) then
  begin
    Circle(Round(CellWidth / 2 + CellWidth), Round(CellHeight / 2 + CellHeight), 40);
  end;
  // 3, 2 (6-ая клетка)
  if (x = 3) and (y = 2) then
  begin
    Circle(Round(CellWidth / 2 + CellWidth * 2), Round(CellHeight / 2 + CellHeight), 40);
  end;
  // 1, 3 (7-ая клетка)
  if (x = 1) and (y = 3) then
  begin
    Circle(Round(CellWidth / 2), Round(CellHeight / 2 + CellHeight * 2), 40);
  end;
  // 2, 3 (8-ая клетка)
  if (x = 2) and (y = 3) then
  begin
    Circle(Round(CellWidth / 2 + CellWidth), Round(CellHeight / 2 + CellHeight * 2), 40);
  end;
  // 3, 3 (9-ая клетка)
  if (x = 3) and (y = 3) then
  begin
    Circle(Round(CellWidth / 2 + CellWidth * 2), Round(CellHeight / 2 + CellHeight * 2), 40);
  end;
end;
end.
1
Миниатюры
Полезные коды для PascalABC.NET   Полезные коды для PascalABC.NET  
serёга
46 / 41 / 12
Регистрация: 27.08.2012
Сообщений: 290
20.08.2013, 12:28 #60
В: Крестики - нолики без использования GraphABC.
О:
Крестики-нолики
DZ.pas
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
{$apptype windows}
{$reference 'System.Windows.Forms.Dll'}
{$reference 'System.Drawing.Dll'}
Uses MainUnit;
Const Res_1 = 'res\D.png';
      Res_2 = 'res\Z.png';
      Message_1 = 'Вы проиграли!';
      Message_2 = 'Вы выиграли! ';
      Color_1 = System.Drawing.Color.Red;
      Color_2 = System.Drawing.Color.Green;
 
Var MainForm, GOF, LF : System.Windows.Forms.Form;
    MainPanel : System.Windows.Forms.Panel;
    MainGraph : System.Drawing.Graphics;
    Image_D, Image_Z : System.Drawing.Image;
    m : array [1..3, 1..3] of integer;
    m1, m2 : string;
    c1, c2 : System.Drawing.Color;
 
Function DZN : boolean; {Проверяет, есть ли ещё ходы}
 Var i, j, k : integer;
  Begin
    For j := 1 to 3 do
     For i := 1 to 3 do
      If m[i][j] = 0 Then k := k + 1;
    If k = 0 Then Result := False
    Else Result := True;
  End;
{============================================================================================================}  
Procedure Close_GOF (sender : System.Object; e : System.EventArgs);
 Begin
   GOF.Close ();
   MainForm.Close ();
 End;
 
Procedure New_Game (sender : System.Object; e : System.EventArgs);
 Begin
  GOF.Close ();
  For var j := 1 to 3 do
   For var i := 1 to 3 do
    m[i][j] := 0;
  MainGraph.Clear (System.Drawing.Color.LightGray);
  Draw_Grid (MainGraph);
 End;
 
Procedure GO; {Пользователь проиграл (Game Over)}
 Begin
  GOF := new System.Windows.Forms.Form;
  GOF.FormBorderStyle := System.Windows.Forms.FormBorderStyle.Fixed3D;
  GOF.MaximizeBox := False; GOF.MinimizeBox := False;
  GOF.StartPosition := System.Windows.Forms.FormStartPosition.CenterScreen;
  GOF.Text := 'Сообщение'; GOF.Size := new System.Drawing.Size (300, 150);
  GOF.BackColor := System.Drawing.Color.White;
  GOF.Icon := New System.Drawing.Icon ('res\E.ico');
  
  
  Var l := new System.Windows.Forms.Label;
  l.AutoSize := True; l.Location := new System.Drawing.Point (50, 20);
  l.Text := m1; l.ForeColor := c1;
  l.Font := new System.Drawing.Font ('Arial', 20);
  
  Var b1 := new System.Windows.Forms.Button;
  b1.Location := new System.Drawing.Point (20, 90);
  b1.Text := 'Ещё раз'; b1.Click += New_Game;
  
  Var b2 := new System.Windows.Forms.Button;
  b2.Location := new System.Drawing.Point (200, 90);
  b2.Text := 'Выход'; b2.Click += Close_GOF;
  
  GOF.Controls.AddRange (new System.Windows.Forms.Control [3] (l, b1, b2));
  GOF.Show (MainForm);
 End;
{============================================================================================================} 
Procedure GD; {Ничья}
 Begin
  GOF := new System.Windows.Forms.Form;
  GOF.FormBorderStyle := System.Windows.Forms.FormBorderStyle.Fixed3D;
  GOF.MaximizeBox := False; GOF.MinimizeBox := False;
  GOF.StartPosition := System.Windows.Forms.FormStartPosition.CenterScreen;
  GOF.Text := 'Сообщение'; GOF.Size := new System.Drawing.Size (300, 150);
  GOF.BackColor := System.Drawing.Color.White;
  GOF.Icon := New System.Drawing.Icon ('res\E.ico');
  
  Var l := new System.Windows.Forms.Label;
  l.AutoSize := True; l.Location := new System.Drawing.Point (110, 20);
  l.Text := 'Ничья.'; l.ForeColor := System.Drawing.Color.Black;
  l.Font := new System.Drawing.Font ('Arial', 20);
  
  Var b1 := new System.Windows.Forms.Button;
  b1.Location := new System.Drawing.Point (20, 90);
  b1.Text := 'Ещё раз'; b1.Click += New_Game;
  
  Var b2 := new System.Windows.Forms.Button;
  b2.Location := new System.Drawing.Point (200, 90);
  b2.Text := 'Выход'; b2.Click += Close_GOF;
  
  GOF.Controls.AddRange (new System.Windows.Forms.Control [3] (l, b1, b2));
  GOF.Show (MainForm);
 End;
{============================================================================================================}  
Procedure GH; {Выиграл}
 Begin
  GOF := new System.Windows.Forms.Form;
  GOF.FormBorderStyle := System.Windows.Forms.FormBorderStyle.Fixed3D;
  GOF.MaximizeBox := False; GOF.MinimizeBox := False;
  GOF.StartPosition := System.Windows.Forms.FormStartPosition.CenterScreen;
  GOF.Text := 'Сообщение'; GOF.Size := new System.Drawing.Size (300, 150);
  GOF.BackColor := System.Drawing.Color.White;
  GOF.Icon := New System.Drawing.Icon ('res\E.ico');
  
  Var l := new System.Windows.Forms.Label;
  l.AutoSize := True; l.Location := new System.Drawing.Point (60, 20);
  l.Text := m2; l.ForeColor := c2;
  l.Font := new System.Drawing.Font ('Arial', 20);
  
  Var b1 := new System.Windows.Forms.Button;
  b1.Location := new System.Drawing.Point (20, 90);
  b1.Text := 'Ещё раз'; b1.Click += New_Game;
  
  Var b2 := new System.Windows.Forms.Button;
  b2.Location := new System.Drawing.Point (200, 90);
  b2.Text := 'Выход'; b2.Click += Close_GOF;
  
  GOF.Controls.AddRange (new System.Windows.Forms.Control [3] (l, b1, b2));
  GOF.Show (MainForm);
 End;
{============================================================================================================}  
Procedure GCC; {Игра компьютера, а также проверка, кто выиграл}
 Begin
  {Проверка выигрыша крестиков}
  If (m[1][1] = 1) and (m[2][1] = 1) and (m[3][1] = 1) Then Begin GH; End
  Else If (m[1][2] = 1) and (m[2][2] = 1) and (m[3][2] = 1) Then Begin GH; End
  Else If (m[1][3] = 1) and (m[2][3] = 1) and (m[3][3] = 1) Then Begin GH; End
  Else If (m[1][1] = 1) and (m[1][2] = 1) and (m[1][3] = 1) Then Begin GH; End
  Else If (m[2][1] = 1) and (m[2][2] = 1) and (m[2][3] = 1) Then Begin GH; End
  Else If (m[3][1] = 1) and (m[3][2] = 1) and (m[3][3] = 1) Then Begin GH; End
  Else If (m[1][1] = 1) and (m[2][2] = 1) and (m[3][3] = 1) Then Begin GH; End
  Else If (m[1][3] = 1) and (m[2][2] = 1) and (m[3][1] = 1) Then Begin GH; End
  {"Стремление" выиграть}
  Else If (m[1][1] = 2) and (m[2][1] = 2) and (m[3][1] = 0) Then Begin Sleep (200); m[3][1] := 2; Draw_DZ (Image_Z, 250, 50); Sleep (200); GO; End
  Else If (m[1][2] = 2) and (m[2][2] = 2) and (m[3][2] = 0) Then Begin Sleep (200); m[3][2] := 2; Draw_DZ (Image_Z, 250, 150); Sleep (200); GO; End
  Else If (m[1][3] = 2) and (m[2][3] = 2) and (m[3][3] = 0) Then Begin Sleep (200); m[3][3] := 2; Draw_DZ (Image_Z, 250, 250); Sleep (200); GO; End
  Else If (m[1][1] = 0) and (m[2][1] = 2) and (m[3][1] = 2) Then Begin Sleep (200); m[1][1] := 2; Draw_DZ (Image_Z, 50, 50); Sleep (200); GO; End
  Else If (m[1][2] = 0) and (m[2][2] = 2) and (m[3][2] = 2) Then Begin Sleep (200); m[1][2] := 2; Draw_DZ (Image_Z, 50, 150); Sleep (200); GO; End
  Else If (m[1][3] = 0) and (m[2][3] = 2) and (m[3][3] = 2) Then Begin Sleep (200); m[1][3] := 2; Draw_DZ (Image_Z, 50, 250); Sleep (200); GO; End
  Else If (m[1][1] = 2) and (m[1][2] = 2) and (m[1][3] = 0) Then Begin Sleep (200); m[1][3] := 2; Draw_DZ (Image_Z, 50, 250); Sleep (200); GO; End
  Else If (m[2][1] = 2) and (m[2][2] = 2) and (m[2][3] = 0) Then Begin Sleep (200); m[2][3] := 2; Draw_DZ (Image_Z, 150, 250); Sleep (200); GO; End
  Else If (m[3][1] = 2) and (m[3][2] = 2) and (m[3][3] = 0) Then Begin Sleep (200); m[3][3] := 2; Draw_DZ (Image_Z, 250, 250); Sleep (200); GO; End
  Else If (m[1][1] = 0) and (m[1][2] = 2) and (m[1][3] = 2) Then Begin Sleep (200); m[1][1] := 2; Draw_DZ (Image_Z, 50, 50); Sleep (200); GO; End
  Else If (m[2][1] = 0) and (m[2][2] = 2) and (m[2][3] = 2) Then Begin Sleep (200); m[2][1] := 2; Draw_DZ (Image_Z, 150, 50); Sleep (200); GO; End
  Else If (m[3][1] = 0) and (m[3][2] = 2) and (m[3][3] = 2) Then Begin Sleep (200); m[3][1] := 2; Draw_DZ (Image_Z, 250, 50); Sleep (200); GO; End
  Else If (m[1][1] = 2) and (m[2][1] = 0) and (m[3][1] = 2) Then Begin Sleep (200); m[2][1] := 2; Draw_DZ (Image_Z, 150, 50); Sleep (200); GO; End
  Else If (m[1][2] = 2) and (m[2][2] = 0) and (m[3][2] = 2) Then Begin Sleep (200); m[2][2] := 2; Draw_DZ (Image_Z, 150, 150); Sleep (200); GO; End
  Else If (m[1][3] = 2) and (m[2][3] = 0) and (m[3][3] = 2) Then Begin Sleep (200); m[2][3] := 2; Draw_DZ (Image_Z, 150, 250); Sleep (200); GO; End
  Else If (m[1][1] = 2) and (m[1][2] = 0) and (m[1][3] = 2) Then Begin Sleep (200); m[1][2] := 2; Draw_DZ (Image_Z, 50, 150); Sleep (200); GO; End
  Else If (m[2][1] = 2) and (m[2][2] = 0) and (m[2][3] = 2) Then Begin Sleep (200); m[2][2] := 2; Draw_DZ (Image_Z, 150, 150); Sleep (200); GO; End
  Else If (m[3][1] = 2) and (m[3][2] = 0) and (m[3][3] = 2) Then Begin Sleep (200); m[3][2] := 2; Draw_DZ (Image_Z, 250, 150); Sleep (200); GO; End
  Else If (m[1][1] = 2) and (m[2][2] = 2) and (m[3][3] = 0) Then Begin Sleep (200); m[3][3] := 2; Draw_DZ (Image_Z, 250, 250); Sleep (200); GO; End
  Else If (m[3][1] = 2) and (m[2][2] = 2) and (m[1][3] = 0) Then Begin Sleep (200); m[1][3] := 2; Draw_DZ (Image_Z, 50, 250); Sleep (200); GO; End
  Else If (m[1][1] = 0) and (m[2][2] = 2) and (m[3][3] = 2) Then Begin Sleep (200); m[1][1] := 2; Draw_DZ (Image_Z, 50, 50); Sleep (200); GO; End
  Else If (m[3][1] = 0) and (m[2][2] = 2) and (m[1][3] = 2) Then Begin Sleep (200); m[3][1] := 2; Draw_DZ (Image_Z, 250, 50); Sleep (200); GO; End
  Else If (m[1][1] = 2) and (m[2][2] = 0) and (m[3][3] = 2) Then Begin Sleep (200); m[2][2] := 2; Draw_DZ (Image_Z, 150, 150); Sleep (200); GO; End
  Else If (m[3][1] = 2) and (m[2][2] = 0) and (m[1][3] = 2) Then Begin Sleep (200); m[2][2] := 2; Draw_DZ (Image_Z, 150, 150); Sleep (200); GO; End
  {Создание "Сартиров" противнику}
  Else If (m[1][1] = 1) and (m[2][1] = 1) and (m[3][1] = 0) Then Begin Sleep (200); m[3][1] := 2; Draw_DZ (Image_Z, 250, 50); End
  Else If (m[1][2] = 1) and (m[2][2] = 1) and (m[3][2] = 0) Then Begin Sleep (200); m[3][2] := 2; Draw_DZ (Image_Z, 250, 150); End
  Else If (m[1][3] = 1) and (m[2][3] = 1) and (m[3][3] = 0) Then Begin Sleep (200); m[3][3] := 2; Draw_DZ (Image_Z, 250, 250); End
  Else If (m[1][1] = 0) and (m[2][1] = 1) and (m[3][1] = 1) Then Begin Sleep (200); m[1][1] := 2; Draw_DZ (Image_Z, 50, 50); End
  Else If (m[1][2] = 0) and (m[2][2] = 1) and (m[3][2] = 1) Then Begin Sleep (200); m[1][2] := 2; Draw_DZ (Image_Z, 50, 150); End
  Else If (m[1][3] = 0) and (m[2][3] = 1) and (m[3][3] = 1) Then Begin Sleep (200); m[1][3] := 2; Draw_DZ (Image_Z, 50, 250); End
  Else If (m[1][1] = 1) and (m[1][2] = 1) and (m[1][3] = 0) Then Begin Sleep (200); m[1][3] := 2; Draw_DZ (Image_Z, 50, 250); End
  Else If (m[2][1] = 1) and (m[2][2] = 1) and (m[2][3] = 0) Then Begin Sleep (200); m[2][3] := 2; Draw_DZ (Image_Z, 150, 250); End
  Else If (m[3][1] = 1) and (m[3][2] = 1) and (m[3][3] = 0) Then Begin Sleep (200); m[3][3] := 2; Draw_DZ (Image_Z, 250, 250); End
  Else If (m[1][1] = 0) and (m[1][2] = 1) and (m[1][3] = 1) Then Begin Sleep (200); m[1][1] := 2; Draw_DZ (Image_Z, 50, 50); End
  Else If (m[2][1] = 0) and (m[2][2] = 1) and (m[2][3] = 1) Then Begin Sleep (200); m[2][1] := 2; Draw_DZ (Image_Z, 150, 50); End
  Else If (m[3][1] = 0) and (m[3][2] = 1) and (m[3][3] = 1) Then Begin Sleep (200); m[3][1] := 2; Draw_DZ (Image_Z, 250, 50); End
  Else If (m[1][1] = 1) and (m[2][1] = 0) and (m[3][1] = 1) Then Begin Sleep (200); m[2][1] := 2; Draw_DZ (Image_Z, 150, 50); End
  Else If (m[1][2] = 1) and (m[2][2] = 0) and (m[3][2] = 1) Then Begin Sleep (200); m[2][2] := 2; Draw_DZ (Image_Z, 150, 150); End
  Else If (m[1][3] = 1) and (m[2][3] = 0) and (m[3][3] = 1) Then Begin Sleep (200); m[2][3] := 2; Draw_DZ (Image_Z, 150, 250); End
  Else If (m[1][1] = 1) and (m[1][2] = 0) and (m[1][3] = 1) Then Begin Sleep (200); m[1][2] := 2; Draw_DZ (Image_Z, 50, 150); End
  Else If (m[2][1] = 1) and (m[2][2] = 0) and (m[2][3] = 1) Then Begin Sleep (200); m[2][2] := 2; Draw_DZ (Image_Z, 150, 150); End
  Else If (m[3][1] = 1) and (m[3][2] = 0) and (m[3][3] = 1) Then Begin Sleep (200); m[3][2] := 2; Draw_DZ (Image_Z, 250, 150); End
  Else If (m[1][1] = 1) and (m[2][2] = 1) and (m[3][3] = 0) Then Begin Sleep (200); m[3][3] := 2; Draw_DZ (Image_Z, 250, 250); End
  Else If (m[3][1] = 1) and (m[2][2] = 1) and (m[1][3] = 0) Then Begin Sleep (200); m[1][3] := 2; Draw_DZ (Image_Z, 50, 250); End
  Else If (m[1][1] = 0) and (m[2][2] = 1) and (m[3][3] = 1) Then Begin Sleep (200); m[1][1] := 2; Draw_DZ (Image_Z, 50, 50); End
  Else If (m[3][1] = 0) and (m[2][2] = 1) and (m[1][3] = 1) Then Begin Sleep (200); m[3][1] := 2; Draw_DZ (Image_Z, 250, 50); End
  Else If (m[1][1] = 1) and (m[2][2] = 0) and (m[3][3] = 1) Then Begin Sleep (200); m[2][2] := 2; Draw_DZ (Image_Z, 150, 150); End
  Else If (m[3][1] = 1) and (m[2][2] = 0) and (m[1][3] = 1) Then Begin Sleep (200); m[2][2] := 2; Draw_DZ (Image_Z, 150, 150); End
  
  {Случайный выбор свободной ячейки}
  Else If DZN = True Then
                       Begin
                        Var i, j: integer;
                        Sleep (200); 
                        Repeat
                         i := Random (3) + 1;
                         j := Random (3) + 1;
                        Until m[i][j] = 0;
                        Draw_DZ (Image_Z, (i * 100) - 1, (j * 100) - 1);
                        m[i][j] := 2;
                       End;
       If DZN = False Then GD ();                
 End;
 
 
  
Procedure Down_MainPanel (sender : System.Object; e : System.Windows.Forms.MouseEventArgs); {Обработка нажатия на главную панель}
  Begin
    If e.Button = System.Windows.Forms.MouseButtons.Left Then
    If (m[RFM (e.X)][RFM (e.Y)] = 0) Then Begin Draw_DZ (Image_D, e.X, e.Y); m[RFM (e.X)][RFM (e.Y)] := 1; GCC (); End
    Else Begin Error (MainForm, 'Ячейка уже занята!'); End;
  End;
{=========}
Procedure Click_1 (sender : System.Object; e : System.EventArgs);
 Begin
  LF.Close ();
  Image_D := System.Drawing.Image.FromFile (Res_1);
  Image_Z := System.Drawing.Image.FromFile (Res_2);
  MainUnit.Draw_Grid (MainGraph);
  MainPanel.MouseDown += Down_MainPanel;
 End;
 
Procedure Click_2 (sender : System.Object; e : System.EventArgs);
 Begin
  LF.Close ();
  Image_D := System.Drawing.Image.FromFile (Res_2);
  Image_Z := System.Drawing.Image.FromFile (Res_1);
  MainUnit.Draw_Grid (MainGraph);
  MainPanel.MouseDown += Down_MainPanel;
 End; 
 
Procedure Load_MainForm (sender : System.Object; e : System.EventArgs); {При загрузке главной формы}
  Begin
    LF := new System.Windows.Forms.Form;
    LF.FormBorderStyle := System.Windows.Forms.FormBorderStyle.Fixed3D;
    LF.MaximizeBox := False; LF.MinimizeBox := False;
    LF.Size := new System.Drawing.Size (300, 140);
    LF.StartPosition := System.Windows.Forms.FormStartPosition.CenterScreen;
    LF.Icon := New System.Drawing.Icon ('res\E.ico');
    
    Var l := new System.Windows.Forms.Label;
    l.AutoSize := True;
    l.Font := new System.Drawing.Font ('Arial', 10);
    l.Location := new System.Drawing.Point (20, 20);
    l.Text := 'Выберите, за кого вы будете играть.';
    
    Var b1 := new System.Windows.Forms.Button;
    b1.Text := 'Крестики';
    b1.Location := new System.Drawing.Point (30, 50);
    b1.Click += Click_1;
    
    Var b2 := new System.Windows.Forms.Button;
    b2.Text := 'Нолики';
    b2.Location := new System.Drawing.Point (170, 50);
    b2.Click += Click_2;
   
     
    LF.Controls.AddRange (new System.Windows.Forms.Control [3] (l, b1, b2));
    LF.Show (MainForm);
  End;
  
Begin
 m1 := Message_1;
 m2 := Message_2;
 c1 := Color_1;
 c2 := Color_2;
 
 {Создание главной формы}
 MainForm := new System.Windows.Forms.Form;
 MainForm.FormBorderStyle := System.Windows.Forms.FormBorderStyle.Fixed3D;
 MainForm.Size := new System.Drawing.Size (330, 350);
 MainForm.StartPosition := System.Windows.Forms.FormStartPosition.CenterScreen;
 MainForm.MaximizeBox := False;
 MainForm.MinimizeBox := False;
 MainForm.Text := 'Крестики - Нолики';
 MainForm.Load += Load_MainForm;
 MainForm.Icon := New System.Drawing.Icon ('res\DZ.ico');
 
 {Создание главной панели}
 MainPanel := new System.Windows.Forms.Panel;
 MainPanel.BorderStyle := System.Windows.Forms.BorderStyle.Fixed3D;
 MainPanel.Location := new System.Drawing.Point (10, 10);
 MainPanel.Size := new System.Drawing.Size (300, 300);
 MainPanel.BackColor := System.Drawing.Color.LightGray;
 
 MainForm.Controls.Add (MainPanel);
 
 MainGraph := System.Drawing.Graphics.FromHwnd (MainPanel.Handle);
 
 System.Windows.Forms.Application.EnableVisualStyles;
 System.Windows.Forms.Application.Run (MainForm);
End.
MainUnit
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
{$reference 'System.Windows.Forms.Dll'}
{$reference 'System.Drawing.Dll'}
Unit MainUnit;
Interface
Var MainGraph : System.Drawing.Graphics;
    ErrorForm : System.Windows.Forms.Form;
 
Function RFI (Data : integer): integer;
Function RFM (Data : integer) : integer;
Procedure Draw_Grid (g : System.Drawing.Graphics); {Прорисовка сетки}
Procedure Draw_DZ (Image : System.Drawing.Image; X, Y : integer);         {Прорисовка DZ}
Procedure Error (f : System.Windows.Forms.Form; s : string);              {Ошибка если ячейка уже занята}
 
Implementation
{===========================================================================}
Function RFI (Data : integer): integer;
 Begin
   If (Data > 0) and (Data < 100) Then Result := 1;
   If (Data > 100) and (Data < 200) Then Result := 101;
   If (Data > 200) and (Data < 300) Then Result := 201;
 End;
{===========================================================================}
Function RFM (Data : integer) : integer;
 Begin
  If (Data > 0) and (Data < 100) Then Result := 1;
  If (Data > 100) and (Data < 200) Then Result := 2;
  If (Data > 200) and (Data < 300) Then Result := 3;
 End;
{===========================================================================} 
Procedure Draw_Grid (g : System.Drawing.Graphics); {Прорисовка сетки}
 Begin
  g.DrawLine (new System.Drawing.Pen (System.Drawing.Color.Black), 100, 0, 100, 300);
  g.DrawLine (new System.Drawing.Pen (System.Drawing.Color.Black), 200, 0, 200, 300);
  g.DrawLine (new System.Drawing.Pen (System.Drawing.Color.Black), 0, 100, 300, 100);
  g.DrawLine (new System.Drawing.Pen (System.Drawing.Color.Black), 0, 200, 300, 200);
  MainGraph := g;
 End;
{===========================================================================} 
Procedure Draw_DZ (Image : System.Drawing.Image; X, Y : integer);         {Прорисовка DZ}
 Begin
  MainGraph.DrawImage (Image, RFI (X), RFI (Y));
 End; 
{===========================================================================}
Procedure Close_ErrorForm (sender: System.Object; e : System.EventArgs);
 Begin
  ErrorForm.Close ();
 End;
{===========================================================================} 
Procedure Error (f : System.Windows.Forms.Form; s : string);              {Ошибка если ячейка уже занята}
 Begin
  ErrorForm := new System.Windows.Forms.Form;
  ErrorForm.Text := 'Ошибка';
  ErrorForm.FormBorderStyle := System.Windows.Forms.FormBorderStyle.Fixed3D;
  ErrorForm.StartPosition := System.Windows.Forms.FormStartPosition.CenterScreen;
  ErrorForm.MaximizeBox := False;
  ErrorForm.MinimizeBox := False;
  ErrorForm.BackColor := System.Drawing.Color.White;
  ErrorForm.Size := new System.Drawing.Size (300, 120);
  
  Var p := new System.Windows.Forms.PictureBox;
  p.Image := System.Drawing.Image.FromFile ('res\Warnings.png');
  p.Location := new System.Drawing.Point (10, 10);
  p.AutoSize := True;
  
  Var l := new System.Windows.Forms.Label;
  l.AutoSize := True;
  l.Location := new System.Drawing.Point (110, 20);
  l.Font := new System.Drawing.Font ('Arial', 10);
  l.Text := s;
  
  Var b := new System.Windows.Forms.Button;
  b.AutoSize := True;
  b.Text := 'ОК';
  b.Location := new System.Drawing.Point (120, 60);
  b.Click += Close_ErrorForm;
  
  ErrorForm.Controls.AddRange (new System.Windows.Forms.Control [3] (p, l, b));
  ErrorForm.Show (f);
 End;
{===========================================================================} 
End.
образец
Полезные коды для PascalABC.NET
Полезные коды для PascalABC.NET
текст программы и необходимые ресурсы в архиве
2
20.08.2013, 12:28
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
20.08.2013, 12:28

Надо найти библиотеку для PascalABC NET
Всем привет. Вот сейчас пишу движок для PascalABC NET. Для графики взял OpenGL....

Создание своего модуля для PascalABC.net
Здравствуйте уважаемые форумчане, подскажите как создать из файла Pas файл PCU....

Ошибка при создании меню в PascalABC.net для игры
ПОМОГИТЕ СРОЧНО!Я хочу заключить процедуры в одну процедуру для меню, для того...


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

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

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