Как написать игру на паскале на телефон - Правописание и грамматика

Преамбула

К моему счастью, среди возможных вариантов времяпровождения с друзьями существует один совсем особенный вариант — это игра в преферанс. Еще лучше, когда компания состоит из сильных игроков, а колода радует всевозможными нетривиальными раскладами.
Во время игры игроки зачастую употребляют спиртное и к концу вечера возникает необходимость подсчета пули, что превращается в занятное дело из-за приподнятого настроения, царящего за столом. Дабы избежать ошибочных расчетов и легкого подрыва нервной системы, возникла идея автоматизации процесса. Именно поэтому было решено написать программу для мобильного телефона.

Фабула

Опыта написания программ для телефона у меня не было, как и вопроса «чем писать?» — уже давно хотелось попробовать в деле MIDLet Pascal. Сказано — сделано, но тут меня поджидало несколько подводных камней.

Версии MIDlet Pascal

На данный момент существует две версии IDE: оригинальная 2.02 и полностью свободная 3.2 (далее буду именовать как 2-я и 3-я ветки).
Для написания программ для меня удобнее оказалась 3-я ветка: нормальная настраиваемая подсветка синтаксиса и внешнего вида IDE, поддержка переводов интерфейса, человеческая история файлов и т.д. Но, если быть честным, писать код в Notepad++ ничуть не хуже, чем в обеих ветках, потому что ни там ни тут нет автодополнения.
Зато есть простейшие редакторы ресурсов. Причем во второй ветке простой и удобный редактор картинок (я все иконки для проекта нарисовал в нем), но нет HEX-редактора, а в 3-й ветке — неплохой HEX-редактор при отвратительном графическом.
От 3-й ветки мне всё равно пришлось отказаться по нескольким причинам. Первая и главная — абсолютно не работают сторонние библиотеки, которые работают во 2-й ветке. Вторая — компилятор 3-й ветки падает при сборке проекта, если в проекте используются строки на русском языке.
Сначала я пробовал писать программу в 3-й версии, а собирать во 2-й, но мне это быстро надоело и я полностью перебрался на 2-ю ветку.

Для сравнения приложу скриншоты обеих версий:

Написание программы

Так как я ни разу не брался за j2me и даже не интересовался что это и с чем едят, то и работа с MIDlet Pascal для меня началась с разбора азов. Примитивные примеры из серии «Hello, World!» быстро дали понять — будет не слишком просто. Для меня стало открытием, что любая программа так или иначе выполняется исключительно в циклах, внутри которых происходит обработка прерываний, вызванных событиями, нажатиями кнопок и т.д.

Простейший пример программы в цикле:

program Test; { объявляем переменные} var k: integer; s: string; { основное тело программы } begin { задаем цвет в формате RGB } SetColor(255, 0, 0); s := 'Hello, Word!'; { рисуем текст в середине экрана в буфере! } DrawText(s, GetWidth/2 - GetStringWidth(s)/2, GetHeight/2 - GetStringHeight(s)/2); { отрисовываем на экране } Repaint; repeat k := GetKeyClicked; // ловим нажатие клавиши Delay(100); // задержка until KeyToAction(k) = GA_FIRE; // ждем нажатия на ОК end.

Если заменить блок repeat на Delay (1000), то программа закроется сама через одну секунду работы.

Язык MIDlet Pascal напоминает усеченный pascal.

Поддерживаемые типы данных:

* boolean
* char
* integer
* real
* string
* image
* command
* recordStore
* http
* resource

Комплексные типы:

* records
* arrays

Объекты не поддерживаются. Можно писать свои процедуры и функции. Нет привычных по Delphi конструкций with, case и прочих. По спартански, но и этого достаточно. Как написал кто-то на форуме по мидлетпаскалю: «В мидлетпаскале базово реализовано всё что нужно для написания программ» и я с этим полностью согласен.

Принципы работы

Любая программа может работать в 2-х режимах — графическом и «режиме формы“. В первом случае мы всё рисуем сами в буфере телефона, а потом выводим на экран, во втором мы указываем компоненты формы, их последовательность, но внешний вид формы уже будет зависеть от конкретной модели телефона. У меня Fly MC300, а у друга — Nokia 3720. Приложения в режиме формы выглядят различно. Субъективно, у Nokia гораздо удобнее и качественнее.
Чтобы избежать непредсказуемости внешнего вида, надо использовать графический режим (который в MIDlet Pascal по умолчанию), но следует помнить, что простейшие вещи проще реализовать в режиме формы, чем в графическом режиме. В графическом режиме необходимо всё рисовать самому, а в режиме формы это делает за вас телефон.
Переключение между режимами производится командами:

ShowCanvas
ShowForm

Библиотеки

Для упрощения реализации различных типовых задач энтузиастами было написано много подключаемых библиотек. Со списком и инструкциями к применению можно ознакомиться тут.
В моем проекте были использованы библиотеки menu32 и font32. Первая служит для организации простого меню, а вторая — для вывода рисованного текста. Menu32 использует для своей работы font32 (и такое бывает). Font32 работает со шрифтом, описание которого содержится в 2-х файлах, один из которых представляет из себя картинку формата png со всеми символами, выведенными в строку, и dat файл со смещениями по оси Х, обозначающими границы букв. Подобную связку файлов можно получить с помощью специальной программы-генератора, которую можно взять в ветке форума, посвященного font32. Хорошо читаемые шрифты получаются только из растровых шрифтов, результат преобразования векторных шрифтов требует обязательной правки обоих файлов, потому что буквы наползают друг на друга, а dat файл содержит неверные смещения.
Мне было лень заниматься правкой, поэтому я использовал растровые шрифты: MS Sans Serif и Small Fonts.

Проблемы и их решения

Проблем было не много, но они были. Первой, поставившей в тупик, стала задача нахождения координат точки пересечения двух прямых. Задача крайне тривиальная и успешно решается еще в средней школе, но оказалось, что я полностью забыл элементарную геометрию — даже уравнение прямой вспомнилось с большим трудом. Пришлось немного погуглить и найти решение.
Вторая проблема возникла при обработке нажатий клавиш. Дело в том, что для определения нажатой клавиши есть две функции: GetKeyClicked и GetKeyPressed, которые возвращают код клавиши, а так же существует функция KeyToAction, возвращающая код действия клавиши. Я не знаю является ли это особенностью именно MIDlet Pascal или всей jme платформы в целом, но реализация работы с клавиатурой реализована следующим образом: первые две функции возвращают коды клавиш, соответствующие цифровой клавиатуре, а третья функция возвращает коды, соответствующие нажатию джойстика.

program KeyBoardTest; var k, ka: integer; begin repeat k := GetKeyClicked; ka := KeyToAction(k); Delay(100); until ka = GA_FIRE; end.

Данная маленькая программа проверяет нажатие клавиатуры и если была нажата клавиша ОК (обычно это середина джойстика) — закрывается. Подводный камень кроется в том, что на различных телефонах нажатие клавиш может отрабатываться по разному. Например, на моем Fly нажатия на кнопки 2, 4, 6, 8 и 5 генерят еще и коды действия джойстика, чего не делает протестированная Nokia. А так как обработка нажатий происходит в цикле когда обрабатываются коды клавиш и действия, то может возникнуть вариант, когда произойдет лишняя обработка события, связанного с действием. Лечится cия беда двумя способами: при отлове срабатывания клавиши присваивать значение переменой k несуществующий код клавиши (KE_NONE) и/или обрабатывать нажатия клавиш по кодам. Например для телефонов Nokia и SonyEricsson нажатие джойстика соответсвует коду «-5», но есть и обратная сторона медали — коды, возвращаемые при нажатии, могут отличаться у телефонов различных марок. К счастью, у Nokia и SonyEricsson коды совпадают.
Приведенные выше функции возвращают коды, соответствующие псевдонимам клавиш/действий, но список этот неполный и не содержит софт клавиш, кнопки стирания и т.д. Коды подобных клавиш были получены энтузиастами опытным путем, но не для не всех производителей телефонов.

Программа

Программа BulletSolver предназначена для расчета преферансной пули. Возможен вариант пули на троих и на четверых (для четверых возможен расчет с призами). Результат расчета выводится в вистах и в деньгах, цена виста оговаривается.

Несколько скриншотов:

Особенности работы

Перемещение по пуле происходит последовательно, начиная с игрока запад, против часовой стрелки, путем нажатия джойстика вверх или вниз. Ввод значений происходит по нажатию клавиши ОК. Результаты начинают выводиться только тогда, когда у всех игроков введено хотя-бы по одному значению. Функцию левой софт клавиши так же выполняет звездочка.
Программа не поддерживает сенсорные экраны, потому что у меня нет возможности протестировать работу с сенсором, да и не представляю я как производить ввод цифр без кнопок.

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

Послесловие

В качестве эмулятора использовался Sun Java Wireless Toolkit 2.5.2 for CLDC.
На полное написание программы в свободное от работы-жены-ребенка время понадобилось три дня. Сам процесс написания крайне занимателен, потому что средств отладки нет, всё приходится лепить самому на коленке. Кривули IDE тоже ставят палки в колеса, но всё равно интересно. Программировал я в свое удовольствие, поставленную задачу благополучно решил, заработал +5 к опыту.
Очень хотелось бы увидеть в будущем MIDlet Pacal 3-й, а может уже и 4-й ветки, но с нормально работающим компилятором, поддержкой уже существующих библиотек и всех положительных моментов 2-й ветки. Долгой жизни проекту, если в общем, ведь где еще можно найти среду разработки jme программ объемом в 2 мегабайта?
Отдельная благодарность всем обитателям форума forum.boolean.name за примеры и информацию.
Благодарю за внимание!

Источник

uses
  graphABC, ABCobjects, timers;



var
  f, fn: text;
  t,check: Timer;
  base_color, cgr: Color;
  
  ug, time_play_sec,take_speed,time: real;
  login, Str, str2, str3, st1, ch, password, zs, ks: string;
  chapter, level, n, xgr, ygr, rgr, x_power, y_power,spin, time_play_sec2,chapter_test: integer;  
  xb, yb, xg, yg, power, ww, wh, shot, time_play_min, shot_max,level_test: integer;
  
  Basa: RegularPolygonABC;
  show4, target, target_bad: ObjectABC;
  show, show2, show3, registr_but, login_but, status_box: RectangleABC;
  Star, sun: StarABC;
  show_pos: CircleABC;
    
  Average_ugol: array of integer;
  Average_power: array of integer;
  mb: array[1..62] of string;
  ground: array [1..9] of CircleABC;
  panel: array [1..5] of RectangleABC;
  
  lvlup_b, play, Cont, login_next, regist_next, from_0, from_6: boolean;

procedure pfile;
begin
  Assign(fn, login + '.txt');
  append(fn);
  writeln(fn, '0');
  write(fn, '0');
  close(fn);
end;

procedure prewrite;
begin
  Assign(f, login + '.txt');
  Rewrite(f);
  writeln(f, level);
  Write(f, chapter);
  Close(f);
end;

procedure pread;
var
  level_s, chapter_s: string;
begin
  Assign(f, login + '.txt');
  Reset(f);
  repeat
    Readln(f, level_s);
    level := StrToInt(level_s);
    readln(f, chapter_s);
    chapter := StrToInt(chapter_s);
  until Eof(f);
  Close(f);
end;

procedure pgenerate;
begin
  var show_login: RectangleABC := new RectangleABC(0, 51, 150, 35, clorangeRed);
  show_login.Text := 'Ваш логин: ' + Login;
  st1 := 'AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz0123456789.';
  for var it := 1 to st1.length - 1 do 
  begin
    mb[it] := st1[it];
  end;
  status_box.Text := 'Введите пароль: ';
  readln(ch);
  password := ch;
  status_box.text := 'Вы создали нового пользователя!';
  show_login.Destroy; 
  pfile;
end;

procedure pcreate;
begin
  var show_login: RectangleABC := new RectangleABC(0, 51, 150, 25, clorangeRed);
  assign(F, 'users.txt');
  append(f);
  close(f);
  reset(f);
  show_login.text := 'Введите логин: ';
  status_box.Text := 'Введите логин: ';
  readln(login);
  while not eof(f) do
  begin
    if (str <> str2) then eof(f);
    readln(f, str);
    if pos(login, str) > 0 then begin
      str2 := str;
      readln(f, str);
      str3 := str;
      if (str <> str2) then eof(f);
    end;
  end;
  close(f);
  if login = str2 then begin
    status_box.Text := 'Это имя уже занято!';
    regist_next := false;
  end
  else begin
    Append(F);
    status_box.text := 'Помощь: Если ввести /gen, то пароль будет сгенерирован автоматически.';
    pgenerate;
    zs := '';
    ks := ',.!@?-:;+';
    for var i := 1 to password.Length do 
    begin
      n := pos(password[i], ks);
      zs := zs + inttostr(n);
    end; 
    zs := '';
    ks := ',.!@?-:;+Zqazwsxedc90rfvtgbhnu7jAmiklop345QWERTYSXDCyFVG1BUHNMJI2OPKL68';
    for var i := 1 to password.Length do 
    begin
      n := pos(password[i], ks);
      zs := zs + inttostr(n);
    end;
    password := zs;
    writeln(f, login);
    writeln(f, password);
    close(f); 
  end;
  show_login.Destroy;
end;

procedure plogin;
begin
  Assign(f, 'users.txt');
  append(f);
  Close(f);
  Assign(f, 'users.txt');
  reset(f);
  var show_login: RectangleABC := new RectangleABC(0, 51, 150, 35, clorangeRed);
  show_login.Text := 'Ваш логин: ';
  status_box.Text := 'Введите логин';
  readln(Login); 
  show_login.Text += Login;
  while not eof(f) do
  begin
    if (str <> str2) then eof(f);
    readln(f, str);
    if pos(login, str) > 0 then begin
      str2 := str;
      readln(f, str);
      str3 := str;
      if (str <> str2) then eof(f);
    end;
  end;
  status_box.Text := 'введите пароль';
  readln(password);
  zs := '';
  ks := ',.!@?-:;+Zqazwsxedc90rfvtgbhnu7jAmiklop345QWERTYSXDCyFVG1BUHNMJI2OPKL68';
  for var i := 1 to password.Length do 
  begin
    n := pos(password[i], ks);
    zs := zs + inttostr(n);
  end;
  password := zs;
  if (str3 = password) then begin
    status_box.Text := 'Выполнен вход в учетную запись: ' + Login;
  end
  else begin status_box.Text := 'Ошибка входа: Неверный логин или пароль'; login_next := false; end;
  close(f);
  show_login.Destroy;
end;

procedure stats;
var
  x, y, w, h: integer;
begin
  x := 0;
  y := wh - 30;
  w := 160;
  h := 30;
  for var i := 1 to 5 do //Создаем нижнюю панель
  begin
    if i < 5 then panel[i] := new RectangleABC(x, y, w + 1, h, RGB(120 + 15 * i, 50 + level * 5, 100));
    if i = 5 then panel[i] := new RectangleABC(x, y, w, h, RGB(120 + 15 * i, 50 + level * 5, 100));
    panel[i].BorderWidth := 2;
    x += w;
  end;
end;

procedure Start;
begin
  SetWindowSize(800, 600);
  ClearWindow(clWhite);
  wh := WindowHeight;
  ww := WindowWidth;
  if level = 0 then level := 0;
  if chapter = 0 then chapter := 0;
  Window.IsFixedSize := true;
  sun := new StarABC(35, 35, 20, 25, 16, clGold);
  SetLength(Average_power, 0);
  SetLength(Average_ugol, 0);
  shot := 0;
  time_play_min := 0;
  time_play_sec := 0;
end;

procedure basegen(xb, yb: integer);//создаем базу
begin
  Line(xb - 50, yb, xb + 50, yb);
  Line(xb, yb - 50, xb, yb + 50);
  Line(xb - 50, yb - 1, xb + 50, yb - 1);
  Line(xb - 1, yb - 50, xb - 1, yb + 50);
  Line(xb - 50, yb, xb + 50, yb);
  Line(xb, yb - 50, xb, yb + 50);
  Line(xb - 50, yb - 1, xb + 50, yb - 1);
  Line(xb - 1, yb - 50, xb - 1, yb + 50);
  basa := new RegularPolygonABC(xb, yb, 30, 5, base_color);
end;

procedure mapgen(level_p: integer);//генерируем карту
begin
  target_bad := new RectangleABC(0, 0, 0, 0, clWhite);
  shot_max := 5;
  xb := 100;
  yb := 300;
  xgr := 0;
  ygr := 530;
  rgr := 100;
  cgr := clLavender;
  for var i := 1 to 9 do 
  begin
    ground[i] := new CircleABC(xgr, ygr, rgr, cgr);
    ground[i].bordered := false;
    xgr += 100;
  end;
  xgr := 0;
  for var i := 1 to 9 do 
  begin
    Arc(xgr, ygr - 1, 100, 60, 120);
    xgr += 100;
  end;
  basegen(xb, yb);//добавляем базу
  
  if level_p=-2 then begin target := new rectangleABC(650, 100, 10, 300, clRed); end;
  
  
  if level_p = 0 then begin
    from_0 := true;
    show := new RectangleABC(100, 0, ww - 100, 20, clwheat);
    show.Text := 'Кликните в любом месте мышкой и удерживая перетащите в любое другое место, так вы сможете выбрать силу.';
    show2 := new RectangleABC(100, 20, ww - 100, 20, clwheat);
    show2.Text := 'Внизу на панеле отображается ваши текущие угол и сила, При соприкосновении с поверхностью ядро взрывается';
    show3 := new RectangleABC(100, 40, ww - 100, 20, clwheat);
    show4 := new RectangleABC(0, 60, ww, 20, cllime);
    show3.Text := 'На каждом уровне есть ограниченное кол-во выстрелов, если вы не успели попасть в цель, вы переходите на уровень назад';
    show4.text := 'Чтобы пройти уровень надо попадать по красным мишеням. Сейчас попадите в красную стенку';
    show3.TextScale := 0.9;
    target := new rectangleABC(650, 100, 10, 300, clRed);
  end;
  stats;//добавляем нижнюю панель
  panel[3].Text := 'Глава: ' + IntToStr(chapter);
  panel[4].Text := 'Уровень: ' + IntToStr(level); 
  if level_p = 1 then begin
    if (from_0 = true) then begin
      show.Destroy;
      show2.Destroy;
      show3.Destroy;
      show4.Destroy;
    end;
    target := new CircleABC(300, 200, 30, clRed);
  end;
  if level > 1 then panel[5].Text := 'Выстрел ' + IntToStr(shot) + ' из ' + IntToStr(shot_max);  
  if (level_p = 2) then target := new CircleABC(400, 400, 30, clRed);
  if (level_p = 3) then target := new CircleABC(100, 50, 30, clRed);
  if (level_p = 4) then target := new CircleABC(500, 110, 30, clRed);
  if (level_p = 5) and (from_6 = false) then target := new CircleABC(700, 330, 20, clRed);
  if (level_p = 5) and (from_6 = true) then begin show.Destroy; target := new CircleABC(700, 330, 20, clRed); end;
  if (level_p = 6) then begin
    from_6 := true; show := new RectangleABC(100, 0, ww - 100, 20, clwheat);
    show.Text := 'Черные цели перенаправляют вас сразу на уровень назад!';
    target := new CircleABC(720, 350, 30, clred); target_bad := new CircleABC(720, 150, 30, clblack);
  end;
  
  time_play_min := 0;
  time_play_sec := 0;
  if level > 6 then begin
    if (from_6 = true) then begin
      from_6 := false;
      show.Destroy;
    end;
    target := new CircleABC(Random(100, ww - 50), Random(100, wh - 250), 30, clRed);
  end;
end;

procedure lvldown;
begin
  target.Destroy;
  target_bad.Destroy;
  ClearWindow(clWhite);
  var stat_box := new RoundRectABC(10, 10, ww - 20, wh - 20, 15, clslateblue);
  stat_box.BorderWidth := 2;
  var box: array[1..5] of RoundRectABC;
  var x_box, y_box: integer;
  x_box := 20;
  y_box := 20;
  for var i := 1 to 5 do 
  begin
    box[i] := new RoundRectABC(x_box, y_box, ww - 40, 100, 15, RGB(100 + 20 * i, 100, 100));
    box[i].BorderWidth := 2;
    y_box += 105;
    if i = 1 then begin box[i].Color := clred; box[i].Text := 'Вы не прошли уровень: ' + IntToStr(level); end;
    if i = 2 then box[i].Text := 'Средняя сила: ' + IntToStr(Round(Average_power.Average)) + 'p';
    if i = 3 then box[i].Text := 'Средний угол: ' + IntToStr(Round(Average_ugol.Average));
    if i = 4 then box[i].Text := 'Выстрелов: ' + IntToStr(shot); 
    if i = 5 then begin
      if time_play_min = 0 then box[i].Text := 'Время: ' + time_play_sec.ToString + 'c.'
      else box[i].Text := 'Время: ' + time_play_min.ToString + 'm. ' + time_play_sec.ToString + 'c.';
    end;
  end;
  Sleep(5000);
  for var i := 1 to 5 do box[I].Destroy;
  stat_box.destroy;
  level -= 1;
  SetLength(Average_power, 0);
  SetLength(Average_ugol, 0);
  shot := 0;
  prewrite;
  mapgen(level);
  Basa.RedrawNow;
  for var i := 1 to 5 do panel[i].RedrawNow;
  sun.RedrawNow;
  for var i := 1 to 9 do ground[i].RedrawNow;
end;

procedure lvlup;
begin
  lvlup_b := false;
  ClearWindow(clWhite);
  
  target.Destroy;
  target_bad.Destroy;
  var stat_box := new RoundRectABC(10, 10, ww - 20, wh - 20, 15, clslateblue);
  stat_box.BorderWidth := 2;
  var box: array[1..5] of RoundRectABC;
  var x_box, y_box: integer;
  x_box := 20;
  y_box := 20;
  for var i := 1 to 5 do 
  begin
    box[i] := new RoundRectABC(x_box, y_box, ww - 40, 100, 15, RGB(100, 100 + 20 * i, 170));
    box[i].BorderWidth := 2;
    y_box += 105;
    if i = 1 then begin box[i].Color := cllime; box[i].Text := 'Вы прошли уровень: ' + IntToStr(level); end;
    if i = 2 then box[i].Text := 'Средняя сила: ' + IntToStr(Round(Average_power.Average)) + 'p';
    if i = 3 then box[i].Text := 'Средний угол: ' + IntToStr(Round(Average_ugol.Average));
    if i = 4 then box[i].Text := 'Выстрелов: ' + IntToStr(shot); 
    if i = 5 then begin
      if time_play_min = 0 then box[i].Text := 'Время: ' + time_play_sec.ToString + 'c.'
      else box[i].Text := 'Время: ' + time_play_min.ToString + 'm. ' + time_play_sec.ToString + 'c.';
    end;
  end;
  Sleep(5000);
  for var i := 1 to 5 do box[I].Destroy;
  stat_box.destroy;
  level += 1;
  if (level = 1) and (chapter = 0) then chapter += 1;
  if (level mod 6 = 0) and (level > 1) then chapter += 1;
  SetLength(Average_power, 0);
  SetLength(Average_ugol, 0);
  shot := 0;
  prewrite;
  mapgen(level);
  Basa.RedrawNow;
  for var i := 1 to 5 do panel[i].RedrawNow;
  sun.RedrawNow;
  for var i := 1 to 9 do ground[i].RedrawNow;
  
end;

function myfunc(xr, yr, p, ug: real): real;//функция полета
var
  t: real;
begin
  play := true;
  t := 0;//Время
  xg := 0;//Коориданата Х
  yg := 0;//Коориданата У
  Star := new StarABC(Round(xr), Round(yr), 20, 10, 10, clRandom);//Создаем объект-ядро
  if level < 0 then Check.Start;
  repeat
  if level < 0 then TextOut(0,500,'ПРОРИСОВКА: '+time_play_sec2.ToString+' ');
    xg := Round((xr) + ((p * t * cos(ug)) / 2));
    yg := Round((yr) - (p * t * sin(ug) - (9.8 * t * t / 2)));
    xg -= 2;
    Star.MoveTo(xg, yg);//перемещения ядра в (xg,yg)
    Star.Angle += spin;//Вращаем ядро
    MoveTo(xg, yg);
    PutPixel(xg, yg, clRed);//рисуем путь
    t += time;//Прибавляем время
    sleep(2);//Задержка в 2 милисекунды 
    if (Star.Intersect(target) = true) then lvlup_b := true;
    if (Star.Intersect(target_bad) = true) then begin lvlup_b := false; shot += shot_max * 2; end;
    if (Star.Intersect(target) = true) then take_speed := time_play_sec2;
  until (star.Intersect(ground[1]) = true) or (star.Intersect(ground[2]) = true) 
   or (star.Intersect(ground[3]) = true) or (star.Intersect(ground[4]) = true)
    or (star.Intersect(ground[5]) = true) or (star.Intersect(ground[6]) = true)
     or (star.Intersect(ground[8]) = true) or (star.Intersect(ground[8]) = true)
      or (star.Intersect(ground[9]) = true) or (xg > ww + 10) or (Star.Intersect(target) = true)
      or (star.Intersect(target_bad) = true);
     if level < 0 then  check.Stop;
     if level < 0 then  time_play_sec2:=0;
  Star.Destroy;//убираем звезду
  shot += 1;
  if level > 1 then panel[5].Text := 'Выстрел ' + IntToStr(shot) + ' из ' + IntToStr(shot_max);
  
  //подсчет средних
  setLength(Average_ugol, shot);
  Average_ugol[shot - 1] := Round(RadToDeg(ug));
  setLength( Average_power, shot);
  Average_power[shot - 1] := Round(power);
  if (shot > shot_max - 1) and (lvlup_b = false) and (level > 1) then lvldown;
  if (level > 0) then if (lvlup_b = true) and (shot < shot_max + 1) then lvlup;
  if (level < 2) and (lvlup_b = true) then lvlup;
  myfunc := t;
  Play := false;
end;

procedure MouseMove(xm, ym, mb: integer);
var
  a, b, c: real;
begin
  a := Abs(xm - xb);
  b := Abs(ym - yb);
  c := Sqrt(Sqr(a) + Sqr(b));
  ug := (arcsin(b / c));
  panel[1].Text := 'Угол: ' + IntToStr(Round(RadToDeg(ug)));
  if mb = 1 then  panel[2].Text := 'Сила: ' + IntToStr(Round(sqrt(sqr((xm - x_power)) + sqr((ym - y_power))))) + 'p';//Показываем силу
end;

procedure MouseDown(xm, ym, mb: integer);
begin
  show_pos := new CircleABC(xm, ym, 2, clwheat);
  x_power := xm;
  y_power := ym;
end;

procedure MouseUp(xm, ym, mb: integer);
var
  a, b, c: real;
begin
  a := Abs(xm - xb);
  b := Abs(ym - yb);
  c := Sqrt(Sqr(a) + Sqr(b));
  ug := (arcsin(b / c));
  power := Round(sqrt(sqr((xm - x_power)) + sqr((ym - y_power))));//Высчитывем силу
  panel[1].FontColor := clWhite;
  panel[1].text := 'Угол полета: ' + IntToStr(Round(RadToDeg(ug)));
  panel[2].FontColor := clWhite;
  panel[2].text := 'Сила полета: ' + IntToStr(Round(power)) + 'p';
  if (mb = 1) and (play = false) and (power > 0) then myfunc(xb, yb, power, ug);//запускаем ядро
  panel[2].FontColor := clBlack;
  panel[1].FontColor := clBlack;
  panel[2].Text := '';
  show_pos.Destroy;
end;

procedure rotate;
begin
  sun.Angle += 1;
  time_play_sec += 0.5;
  if time_play_sec = 60.0 then begin time_play_min += 1; time_play_sec := 0; end;
end;

procedure MouseDownS(xm, ym, mb: integer);
begin
  if mb = 1 then base_color := GetPixel(xm, ym);
end;

procedure Hello;
begin
  SetWindowSize(800, 600);
  Window.IsFixedSize := true;
  var start1 := new RoundRectABC(8, 8, windowwidth - 16, WindowHeight - 15, 10, clLavender);
  start1.BorderWidth := 3;
  var start1_name := new RoundRectABC(15, 15, windowwidth - 30, 50, 10, clGreenYellow);
  start1_name.BorderWidth := 2;
  start1_name.Text := 'Добро пожаловать, ' + Login + '!';
  Sleep(200);
  var start1_color := new RoundRectABC(15, 70, WindowWidth - 30, 50, 10, clFirebrick);
  start1_color.BorderWidth := 2;
  start1_color.Text := 'Выберите цвет базы';
  for var iy := 1 to 18 do 
  begin
    Rectangle(50, 105 + iy * 25, 151, 135 + iy * 25);
    FloodFill(52, 105 + iy * 25 + 2, clRandom);
  end;
  for var iy := 1 to 18 do 
  begin
    Rectangle(50 + 100 * 1, 105 + iy * 25, 151 + 100 * 1, 135 + iy * 25);
    FloodFill(52 + 100 * 1, 105 + iy * 25 + 2, clRandom);
  end;
  for var iy := 1 to 18 do 
  begin
    Rectangle(50 + 100 * 2, 105 + iy * 25, 151 + 100 * 2, 135 + iy * 25);
    FloodFill(52 + 100 * 2, 105 + iy * 25 + 2, clRandom);
  end;
  for var iy := 1 to 18 do 
  begin
    Rectangle(50 + 100 * 3, 105 + iy * 25, 151 + 100 * 3, 135 + iy * 25);
    FloodFill(52 + 100 * 3, 105 + iy * 25 + 2, clRandom);
  end;
  for var iy := 1 to 18 do 
  begin
    Rectangle(50 + 100 * 4, 105 + iy * 25, 151 + 100 * 4, 135 + iy * 25);
    FloodFill(52 + 100 * 4, 105 + iy * 25 + 2, clRandom);
  end;
  for var iy := 1 to 18 do 
  begin
    Rectangle(50 + 100 * 5, 105 + iy * 25, 151 + 100 * 5, 135 + iy * 25);
    FloodFill(52 + 100 * 5, 105 + iy * 25 + 2, clRandom);
  end;
  for var iy := 1 to 18 do 
  begin
    Rectangle(50 + 100 * 6, 105 + iy * 25, 151 + 100 * 6, 135 + iy * 25);
    FloodFill(52 + 100 * 6, 105 + iy * 25 + 2, clRandom);
  end;
  OnMouseDown := MouseDownS;
  var timerShow := new RoundRectABC(WindowWidth - 55, 70, 40, 50, 10, clcyan);
  timerShow.BorderWidth := 2;
  timerShow.Text := '3';
  Sleep(1000);
  timerShow.Text := '2';
  Sleep(1000);
  timerShow.Text := '1';
  Sleep(1000);
  timerShow.Destroy;
  start1.Destroy;
  start1_color.Destroy;
  start1_name.Destroy;
end;

procedure MouseDownBeg(xm, ym, mb: integer);
begin
  if login_but.PtInside(xm, ym) = true then login_next := true;
  if registr_but.PtInside(xm, ym) = true then regist_next := true;
end;
procedure timer_check;
begin
  time_play_sec2 += 1;
end;

begin
base_color:=clRandom;
  SetWindowCaption('TimeKiller v0.2');
  target_bad := new RectangleABC(0, 0, 0, 0, clWhite);
  SetWindowSize(800, 600);
  cont := false;
  from_0 := false;
  from_6 := false;
  OnMouseDown := MouseDownBeg;
  var main: RectangleABC := new RectangleABC(0, 0, WindowWidth, windowheight, clLavender);
  login_but := new RectangleABC(0, 0, 401, 50, clolive);
  registr_but := new RectangleABC(399, 0, 400, 50, clOliveDrab);
  login_but.BorderWidth := 2;
  registr_but.BorderWidth := 2;
  login_but.FontColor := clwhite;
  registr_but.FontColor := clgold;
  login_but.Text := 'Войти';
  registr_but.Text := 'Зарегистрироваться';
  status_box := new RectangleABC(0, WindowHeight - 30, WindowWidth, 30, clgold);
  status_box.BorderWidth := 2;
  status_box.Color := ARGB(120, 255, 215, 0);
  status_box.Text := 'Вам необходимо войти или зарегистрироваться';
  repeat
    Sleep(1000);
    if login_next = true then begin plogin; end; 
    if regist_next = true then begin pcreate; end; 
  until (login_next = true) or (regist_next = true);
  pread;
  cont := true;
  if Cont = true then begin
    main.Destroy;
    status_box.Destroy;
    login_but.Destroy;
    registr_but.Destroy;
    Hello;
    start;
    
    TextOut(0,0,'Подождите идет загрузка данных. Прорисовка.');
     time := 0.02;
     spin := 1;
    time_play_sec := 0;
    level_test:=level;
    chapter_test:=chapter;
    chapter:=0;
    level:=-2;
    mapgen(level); 
   
    Check := new Timer(1, timer_check);
    
    myfunc(xb, yb, 200, Pi / 10);//Проверка медленной скорости;
   
    if take_speed > 100 then begin time := 0.08; spin := 2; end;
    check.Stop; 
    Check := new Timer(1, timer_check);
    time_play_sec := 0;
    target.Destroy;
    level:=-2;
    mapgen(level);
    TextOut(0,0,'Подождите идет загрузка данных. Прорисовка.');
    myfunc(xb, yb, 200, Pi / 10);//Проверка быстрой скорости;
   
    if take_speed < 50 then begin time := 0.02; spin := 1; end;
    target.Destroy;
    level:=level_test;
    chapter:=chapter_test;
  
    
    mapgen(level); 
    T := new Timer(500, rotate);
    T.Start;
    OnMouseMove := MouseMove; 
    OnMouseDown := MouseDown;
    OnMouseUp := MouseUp;
  end;
end.

Источник

К оглавлению | Назад | Вперёд

Все программы, код которых выложен здесь, являются работоспособными. Ниже приведены возможные варианты реализации игр «Крестики-нолики» и «Змейка» на PascalABC.Net 3.0.

Крестики-нолики[править]

Описание алгоритма
Отрисовать игровое поле. Позволить сделать шаг игроку. Проверить выиграл ли кто-то. Если да — выиграл текущий игрок, иначе — вернуться к шагу 1.

Управление:

Левая кнопка мыши — установить крестик/нолик.

uses GraphABC;
const
  N = 2;
  Z = '0';
  K = 'X';
  Size = 200;
  Border = 1;
  Sx = 1200;
  Sy = 70;

var
  Matrix: array [0..N, 0..N] of char;
  Player1: boolean;

procedure Draw();
  procedure DrawZ(i, j: integer);
  begin
    SetPenColor(clCyan);
    SetPenWidth(4);
    var size2 := Size div 2;
    DrawCircle((i + 1) * Size - size2, (j + 1) * Size - size2, Round(size2 * 0.7));
  end;
  
  procedure DrawK(i, j: integer);
    procedure RLine(x, y, x1, y1: real):=Line(Round(x), Round(y), Round(x1), Round(y1));

  begin
    SetPenColor(clPink);
    SetPenWidth(4);
    var size2 := Size div 2 * 0.3;
    var cx1 := i * Size + size2;
    var cy1 := j * Size + size2;
    var cx2 := (i + 1) * Size - size2;
    var cy2 := (j + 1) * Size - size2;
    RLine(cx1, cy1, cx2, cy2);
    RLine(cx1, cy2, cx2, cy1);
  end;

  begin
    ClearWindow(clBlack);
    if Player1 then SetWindowCaption('Ходит первый игрок') else SetWindowCaption('Ходит второй игрок');
    for var i := 0 to N do
      for var j := 0 to N do
      begin
        SetPenColor(clLightBlue);
        SetPenWidth(1);
        DrawRectangle(i * Size + Border, j * Size + Border, (i + 1) * Size - Border, (j + 1) * Size - Border);
        if Matrix[i, j] = Z then DrawZ(i, j)
        else if Matrix[i, j] = K then DrawK(i, j);
      end;
    Redraw();
  end;

function Won(c: char): boolean;
var
  count: byte;
begin
  Result := false;
  for var i := 0 to N do
  begin
    count := 0;
    for var j := 0 to N do
      if Matrix[i, j] = c then Inc(count);
    if count = 3 then Result := true;
  end;
  
  if not Result then
  begin
    for var i := 0 to N do
    begin
      count := 0;
      for var j := 0 to N do
        if Matrix[j, i] = c then Inc(count);
      if count = 3 then Result := true;
    end;
    
    if not Result then
    begin
      count := 0;
      for var i := 0 to N do
        if Matrix[i, i] = c then Inc(count);
      if count = 3 then Result := true;
      
      if not Result then
      begin
        count := 0;
        for var i := 0 to N do
          if Matrix[N - i, i] = c then Inc(count);
        if count = 3 then Result := true;
      end;
    end;
  end;
end;

function IsFull(): boolean;
begin
  Result := true;
  for var i := 0 to N do
    for var j := 0 to N do
      if (Matrix[i, j] <> Z) and (Matrix[i, j] <> K) then
      begin
        Result := false;
        break;
      end;
end;

procedure MouseDown(x, y, mb: integer);
  procedure ShowWinner(s: string; c: Color);
  begin
    SetWindowCaption('Результат игры');
    Sleep(2000);
    SetWindowSize(Sx, Sy);
    CenterWindow();
    ClearWindow(clBlack);
    
    SetFontSize(16);
    SetFontStyle(fsBold);
    SetFontColor(c);
    DrawTextCentered(0, 0, Sx, Sy, s);
    
    Redraw();
    Sleep(2000);
    Halt();
  end;

begin
  var i := x div Size;
  var j := y div Size;
  if (Matrix[i, j] <> Z) and (Matrix[i, j] <> K) then
  begin
    if Player1 then Matrix[i, j] := Z else Matrix[i, j] := K;
    Draw();
    
    var winnerExists := Won(Z) or Won(K);
    if winnerExists then
      if Player1 then ShowWinner('Игрок первый победил!', clLightBlue) else ShowWinner('Игрок второй победил!', clLightBlue);
    
    if IsFull() and not winnerExists then ShowWinner('Ничья!', clOrange);
    
    Player1 := not Player1;
  end;
end;

begin
  var Size2 := Size * 3;
  SetWindowIsFixedSize(true);
  SetWindowSize(Size2, Size2);
  CenterWindow();
  LockDrawing();
  
  Player1 := true;
  Draw();
  
  OnMouseDown := MouseDown;
end.

Змейка[править]

==Упрощенный вариант== (просто змейка которой можно управлять)

Описание алгоритма
Нарисовать змейку. Если нажали клавишу — добавить новую точку, в которую перешла голова змейки, в список и удалить первую точку в списке. Перейти к шагу 1.

Управление:

W — вверх.
S — вниз.
A — влево.
D — вправо.

uses GraphABC;
const
  Size = 20;

var
  Snake: List<Point>;

procedure Draw();
begin
  ClearWindow();
  Polyline(Snake.ToArray());
  
  var c := Snake.Count - 1;
  Circle(Snake[c].X, Snake[c].Y, 5);
  Redraw();
end;

procedure KeyDown(Key: integer);
begin
  var c := Snake.Count - 2;
  case Key of
    VK_Left:
      begin
        Snake.RemoveAt(0);
        Snake.Add(new Point(Snake[c].X - Size, Snake[c].Y));
      end;
    VK_Right:
      begin
        Snake.RemoveAt(0);
        Snake.Add(new Point(Snake[c].X + Size, Snake[c].Y));
      end;
    VK_Up:
      begin
        Snake.RemoveAt(0);
        Snake.Add(new Point(Snake[c].X, Snake[c].Y  - Size));
      end;
    VK_Down:
      begin
        Snake.RemoveAt(0);
        Snake.Add(new Point(Snake[c].X, Snake[c].Y  + Size));
      end;
  end;
  Draw();
end;

begin
  LockDrawing();
  SetSmoothingOff();
  
  Snake := new List<Point>();
  for var x := 1 to 30 do
    Snake.Add(new Point(x * Size, Size));
  
  Draw();
  OnKeyDown := KeyDown;
end.

Возрастающая последовательность[править]

uses GraphABC, ABCObjects;
const
  Border = 100;


var
  Obj: CircleABC;
  DX, DY: integer;
  Move: boolean;
  Numbers: TCircles;

function IsEqual(L2: TCircles): boolean;
begin
  Result := true;
  for var i := 0 to L2.Count - 1 do
    if Numbers[i].Number <> L2[i].Number then
    begin
      Result := false;
      break;
    end;
end;

procedure MouseUp(x, y, mb: integer);
procedure MouseMove(x, y, mb: integer);
begin
  if mb = 1 then
    if not Move then
    begin
      for var i := 0 to Numbers.Count - 1 do
        if Numbers[i].PtInside(x, y) then
        begin
          DX := x - Numbers[i].Position.X;
          DY := y - Numbers[i].Position.Y;
          Obj := Numbers[i];
          
          Move := true;
          break;
        end;
    end
    else
      Obj.Position := new Point(x - Dx, y - Dy);
end;

begin
  var W := Window.Width - 2 * Border;
  var H := Window.Height - 2 * Border;
  
  Numbers := new TCircles();
  for var i := 0 to 6 do
  end
    Numbers.Add(new CircleABC(Border + Random(W), Border + Random(H), 30, clRandom()));
    Numbers.Last().Number := i;
  
  Move := false;
  OnMouseMove := MouseMove;
  OnMouseUp := MouseUp;
end.

Источник