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

@BaboshinSD · Регистрация: 15.11.2012

Author24 — интернет-сервис помощи студентам

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

Поддержать тему и добавить свои примеры, исходники и пр. может каждый, после того, как ознакомиться с правилами темы:

Правила темы!

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

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

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

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

Работа с графикой:
Исходники программ, работающих с графикой и графическими библиотеками (GraphABC, OpenGL и пр.).

Графические примитивы

Рисуем кота на PascalABC.NET, с помощью GraphABC
Симпатичная мордашка кота
Кролик и морковка
Рисунок птицы
Шахматная доска
Графика. Подпрограммы пользователя

Дом, дерево, забор (пейзаж)
Букет цветов в вазе
Простейшая анимация

Анимированная открытка С Новым Годом!
Анимированные часы-секундомер
Анимация. Подпрограммы пользователя

Бильярдный шар, движение до попадания в лузу
Анимация Салют
Полет птицы
Математические кривые

Пятилепестковая роза Гранди
Кардиоида
Астроида
Фигура Лиссажу
События модуля GraphABC

Интерактивный справочник цветов Pabc.NET
Шарик меняет направление по щелчку мыши
Движение автомобиля по нажатию клавиш <-- -->

Проектирование игр:

Инструкции, советы и пр.:
Инструкции, касающиеся работы с PascalABC.NET, советы для новичков и пр.

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

Базовые алгоритмы:

Процедура Inc: Как это работает.

@Вячеслав Зозуля · 28.04.2018, 19:33

Сообщение от BaboshinSD

В: Как программно выключить компьютер?

ну зачем такие сложности. это можно написать в одну строчку:

Pascal

1	Execute('cmd.exe','/c shutdown /s /t 0');

@Соколиный глаз · 09.08.2018, 11:16

В: Как изменить символ строки?
О:

Pascal

begin
  var S := 'XYZ';
  Writeln(S);
  StringDefaultPropertySet(S, 1, 'A'); // Возвращает новую измененную строку.
  Writeln(S);
end.

Добавлено через 2 минуты
В: Как проверить, что начиная с i-ого символа строка содержит только пробелы?
О:

Pascal

begin
  var from := 1;
  Writeln(StringIsEmpty('XYZ', from));
end.

Добавлено через 7 минут
В: Как реализуется StringDefaultPropertySet?
О:

Pascal

procedure StringDefaultPropertySet(var s: string; index: integer; c: char);
begin
  var chars := s.ToCharArray;
  chars[index] := c;
  s := new String(chars);
end;

@npoh · 21.04.2019, 16:44

Сообщение от BaboshinSD

Eclipse.rar и Serious Slam.rar

Пожалуйста прищлите pas файлы

@Соколиный глаз · 21.04.2019, 19:08

npoh, он давно уже неактивен (Последняя активность: 21.01.2014 00:55).

@Sun Serega · 21.04.2019, 20:15

Сообщение от npoh

Пожалуйста пришлите pas файлы

А чем вам архивы не нравятся? Вы не умеете скачивать WinRAR? У него пробная версия, хоть и написано что месяц - вообще бесконечна. А без архиватора жить вообще сложно.

Но вообще, я сам пытался на тех играх научится использовать OpenGL - в итоге туториалы для C++ OpenGL больше помогли, ибо Eclipse и Serious Slam написаны на очень старой версии компилятора. Заставить их компилироваться нереально.

Если хотите рабочие примеры - посмотрите, к примеру, сюда. Эта игра, конечно, не доделана, но она хотя бы компилируется и запускается...

@Пс · 05.08.2019, 19:12

класс кнопки в GraphWPF

Pascal

type
  ///Класс  кнопки
  WPFButton = class
    x, y, w, h: integer;
    text: string;
    cl: color;
    b: boolean;
    public event Click: procedure;
    
    procedure destroy;
    begin
      b := true;
      OnMouseDown -= MouseDown; 
      OnMouseUp -= MouseUp;
    end;
    
    procedure MouseDown(x1, y1: real; mb: integer);
    begin
      if (x1 > x) and (x1 < x + w) and (y1 > y) and (y1 < y + h) and (b <> true)
      then begin
        brush.Color := cl;
        FillRectangle(x + 2, y + 2, w, h);
        rectangle(x + 2, y + 2, w, h);
        textout(x + 3 + 2, y + 3 + 2, text);
      end;
    end;
    
    procedure MouseUp(x1, y1: real; mb: integer);
    begin
      if (x1 > x) and (x1 < x + w) and (y1 > y) and (y1 < y + h) and (b <> true)
      then begin
        brush.Color := cl;
        FillRectangle(x, y, w, h);
        rectangle(x, y, w, h);
        textout(x + 3, y + 3, text);
        Click;
      end;
    end;
    
    constructor Create(x1, y1, w1, h1: integer; txt: string; cl1: color);
    begin
      (x, y, w, h, text, cl) := (x1, y1, w1, h1, txt, cl1);
      brush.Color := cl;
      rectangle(x + 2, y + 2, w, h);
      FillRectangle(x, y, w, h);
      rectangle(x, y, w, h);
      textout(x + 3, y + 3, text);
      OnMouseDown += MouseDown;
      OnMouseUp += MouseUp;
    end;
  end;

было бы не плохо услышать ваши комментария по поводу улучшения

@canadamoscow · 06.09.2020, 21:24

Игра Сапер (Минер) на PascalABC.net Используются модули GraphWPF и Timers

@Пс · 06.09.2020, 21:31

canadamoscow, Можно код сюда,пожалуйста.

Добавлено через 3 минуты
canadamoscow, Я тоже не давно делал,только,может завтра закину

@canadamoscow · 06.09.2020, 21:39

Игра Сапер (Минер) на PascalABC.net Используются модули GraphWPF и Timers

Кликните здесь для просмотра всего текста

Pascal

uses graphWPF, Timers;
 
const 
w = 24; //высота и ширина ячейки
h = 3*w+12; //отступ над полем
 
var 
//pole: 0 - пустая клетка, 1..8 - кол-во мин вокруг, 9 - мина
//visible: 0 - скрытая клетка, 1 - флаг, 2 - вопрос, 9 - открытая, 10,12 - предпросмотр
  Pole, visible: array[,] of byte;
//размер поля m x n; количество открытых клеток (для анализа победы)
//status: 0 - ждем первого хода, 1-первый ход сделан, расставили мины
//status 150 - поражение, 200 - победа
  n, m, otkrito, status: byte;
//всего мин; всего флагов для расстановки осталось; счетчик
  Bomb, nFlag, time: integer;
//состояния кнопок мыши; ставить ли '?' после флага правым кликом мыши
  LBdown, LBUp, RBdown, RBup, vopros: boolean;
//указатель на клетку под предпросмотром, во время удержания кнопки мыши
//чтобы при движении курсора мыши внутки клетки не предпросматривать эту клетку повторно
  (PreviewX, PreviewY) := (-2,-2); //предпросмотра нет? указатель за пределами поля
  t: timer;
  
procedure DrawXY(i, j: byte);
const
//для вывода: цифры, мина, флаг и вопрос
  poleSt: array of char = (' ','1','2','3','4','5','6','7','8',#8277, #9873,'?');
//цвета цифр, мины и флага
  ColorN: array of Color = (Colors.Black, Colors.Blue, Colors.Green, Colors.Red, Colors.DarkBlue,
     Colors.Brown, Colors.DarkCyan, Colors.Black, Colors.DarkGray, Colors.Black, Colors.MediumVioletRed);
 
begin
 var unvisible := Procedure(a,b: byte) → //рисуем закрытые клетки
  begin 
   var (x, y) := (b*w+12, a*w+h);
   FillRectangle(x,y,w-1, 2, Colors.White);
   FillRectangle(x,y,2, w-1, Colors.White);
   FillRectangle(x+1,y+w-2,w-1, 2, Colors.Gray);
   FillRectangle(x+w-2,y+1,2, w-1, Colors.Gray);
   FillRectangle(x+2,y+2,w-4, w-4, Colors.LightGray);
   SetPixel(x,y+w-1,Colors.DarkGray);
   SetPixel(x+1,y+w-2,Colors.DarkGray);
   SetPixel(x+w-2,y+1,Colors.DarkGray);
   SetPixel(x+w-1,y,Colors.DarkGray);
  end;
 var (ii, jj) := (j*w+12, i*w+h); //индекс ячейки переводим в координаты на поле
 
 case visible[i,j] of
//вывести закрытую ячейку без пометок
    0: unvisible(i,j); 
//вывести флажок
    1: begin unvisible(i,j); DrawText(ii, jj, w, w, poleSt[10], ColorN[10]) end;
//вывести вопрос    
    2: begin unvisible(i,j);  DrawText(ii, jj, w, w, poleSt[11], Colors.Black) end;
//вывести перечеркнутую мину (флаг был не верно поставлен)
    7: begin 
         FillRectangle(ii,jj,w, w, Colors.Gray);
         FillRectangle(ii+1,jj+1,w-1, w-1, Colors.LightGray);
         DrawText(ii+1, jj+1, w, w, poleSt[9], Colors.Black);
         Pen.Width := 3;
         line(ii+7,jj+2, ii+w-2,jj+w-2, Colors.MediumVioletRed);
         line(ii+3,jj+w-2, ii+w-2,jj+5, Colors.MediumVioletRed);
        end;
//вывести цифру мин вокруг или мину
    9: begin
         FillRectangle(ii,jj,w, w, Colors.Gray);
         FillRectangle(ii+1,jj+1,w-1, w-1, Colors.LightGray);
         if pole[i,j] <> 9 then
           begin//вывод кол-ва мин вокруг
             DrawText(ii+1, jj+1, w, w, poleSt[pole[i,j]], ColorN[pole[i,j]]);
             dec(otkrito); //счетчик открытых
           end
         else
           begin //вывод мины, первая(подрыв) на цветном фоне
             if Status < 100 then FillRectangle(ii+1,jj+1,w-1, w-1, Colors.HotPink);
             DrawText(ii+1, jj+1, w, w, poleSt[pole[i,j]], ColorN[pole[i,j]]);
           end;
        end;
//вывести клетку предпросмотр         
  10: begin 
         FillRectangle(ii,jj,w, w, Colors.Gray);
         FillRectangle(ii+1,jj+1,w-1, w-1, Colors.LightGray);
        end;
//вывести клетку предпросмотр c "вопросом"        
  12: begin 
         FillRectangle(ii,jj,w, w, Colors.Gray);
         FillRectangle(ii+1,jj+1,w-1, w-1, Colors.LightGray);
         DrawText(ii, jj, w, w, poleSt[11], Colors.Black);
        end;    
   end;
end;
 
//рисуем вверху "круг с вопросом"
procedure DrawVopros; 
begin 
  Pen.Color := vopros ? Colors.DarkCyan : Colors.Red;
  Pen.Width := 2;
  Circle((m+2) div 2 * w, h - 27, w div 2, Colors.White);
  Font.Size := w + w div 4;
  DrawText(m div 2 * w+12, h - 38, w, w, '?', Colors.Black);
  Font.Size := w;  
  if not vopros then DrawSector((m+2) div 2 * w, h - 27, w div 2, -45, 135);
end;
 
//слева сверху рисуем количество оставшихся флагов
procedure DrawNflag();
begin
  FillRectangle(18,20,w*2+w div 2, w*2, Colors.Black);
  Font.Name := 'Impact';
  Font.Size := 5 * w div 3;
  DrawText(18,20,w*2+w div 2, w*2, nFlag, Colors.PaleVioletRed);
  Font.Name := 'Courier New';
  Font.Size := w;
  Font.Style := Bold;   
end;
 
//справа сверху рисуем прошедшее время
procedure OnTimer();
begin
  FillRectangle(window.Width - 18, 20, -(w*2+w div 2), w*2, Colors.Black);
  Font.Name := 'Impact';
  Font.Size := 5 * w div 3;  
  DrawText(window.Width - 18, 20, -(w*2+w div 2), w*2, time.toString, Colors.PaleVioletRed);
  inc(time);
  Font.Name := 'Courier New';
  Font.Size := w;
  Font.Style := Bold;   
end;
 
//генерируем поле с минами и цифрами; (nn, mm) первая открытая клетка "без мины"
procedure GenPole(nn, mm: byte);
begin
 SetLength(Pole, n, m);
 var bombHSet := HSet(Random(0, n*m-1));//множество с минами
 while bombHSet.Count <> bomb do
   begin var t := Random(0, n*m-1); if t <> (nn*m+mm) then bombHSet.Add(t);end;
//расставляем мины по полю   
 for var i := 0 to n-1 do
  for var j := 0 to m-1 do
   if bombHSet.Contains(i*m+j) then Pole[i,j] := 9 else Pole[i,j] := 0; 
//расставляем цифры по полю  
 for var i := 0 to n-1 do
  for var j := 0 to m-1 do     
    if Pole[i, j] = 9 then 
     for var ii := (i-1).ClampBottom(0) to (i+1).ClampTop(n-1) do
       for var jj := (j-1).ClampBottom(0) to (j+1).ClampTop(m-1) do
        if Pole[ii, jj] <> 9 then Pole[ii, jj] += 1; //вокруг мины каждой клетке +1
  t.Start;
end;
 
//Инициализация новой игры
Procedure Init(level: byte); 
begin
  case level of //Поле n x m, и кол-во бомб
    1: (n, m, Bomb) := ( 9, 9,10); //Новичок
    2: (n, m, Bomb) := (16,16,40); //Любитель
    3: (n, m, Bomb) := (16,30,99); //Профессионал
  end;
 status := 0; //статус ожидания первого хода
 otkrito := n*m - Bomb; //количество клеток, для открывания
 nFlag := Bomb; //количество флагов для пометок
 var LevelOld := false; //размер поля изменился (для ускорения вывода поля);
 if window.Width <> m * w + 25 then
    window.SetSize(m * w + 25, n * w + h + 11) else LevelOld := true;
 //Рисуем игровое поле
 FillRectangle(3,3,m * w + 17, n * w + h + 5,Colors.LightGray);
 FillRectangle(9,h-3, 3, n*w+5,Colors.Gray); 
 FillRectangle(9,h-3, m*w+5, 3,Colors.Gray);
 FillRectangle(10,h + n * w, m * w+4, 3, Colors.White); 
 FillRectangle(12 + m * w, h-2, 3, n * w+5, Colors.White);
 SetPixel(10, h + n * w, Colors.Gray);
 SetPixel(10, h+1 + n * w, Colors.LightGray);
 SetPixel(11, h + n * w, Colors.LightGray);
 SetPixel(12 + m * w, h-2, Colors.Gray);
 SetPixel(12 + m * w, h-1, Colors.LightGray);
 SetPixel(13 + m * w, h-2, Colors.LightGray);
 //рисуем область над игровым полем
 FillRectangle(9,9, 3, h - 18,Colors.Gray); 
 FillRectangle(9,9, m*w+5, 3,Colors.Gray);
 FillRectangle(10,h-11 , m * w+5, 3, Colors.White); 
 FillRectangle(12 + m * w, 10, 3, h-19, Colors.White);
 SetPixel(10, h-11, Colors.Gray);
 SetPixel(10, h-10, Colors.LightGray);
 SetPixel(11, h-11, Colors.LightGray);
 SetPixel(12+m*w, 10, Colors.Gray);
 SetPixel(13+m*w, 10,  Colors.LightGray);
 SetPixel(12+m*w, 11,  Colors.LightGray);
 
 var knopka := Procedure(a,b: byte) → //кнопки старта 1-2-3
  begin
   var (x, y) := (b*w+12, a*w+15);
   FillRectangle(x,y,w-1, 2, Colors.White);
   FillRectangle(x,y,2, w-1, Colors.White);
   FillRectangle(x+1,y+w-2,w-1, 2, Colors.Gray);
   FillRectangle(x+w-2,y+1,2, w-1, Colors.Gray);
   FillRectangle(x+2,y+2,w-4, w-4, Colors.LightGray);
   SetPixel(x,y+w-1,Colors.DarkGray);
   SetPixel(x+1,y+w-2,Colors.DarkGray);
   SetPixel(x+w-2,y+1,Colors.DarkGray);
   SetPixel(x+w-1,y,Colors.DarkGray);
  end;
 //кнопки сверху "1-2-3 Новая игра"  
  if not LevelOld then for var f := 0 to 2 do
    begin 
      var ColorN := Arr(Colors.Blue, Colors.Green, Colors.Red);
      var yy := m div 2 - 1+ f;
      knopka(0, yy);
      DrawText(yy*w+14, 16, 21, w, (f+1).ToString, ColorN[f]);      
    end; 
//выводим "круг с вопросом"
  DrawVopros; 
//слева сверху колво оставшихся флагов
  FillRectangle(16,18, 2, w*2+2, Colors.Gray);
  FillRectangle(16,18, w*2+w div 2+2, 2, Colors.Gray);
  FillRectangle(18,19+w*2+1, w*2+w div 2+2, 2, Colors.White);
  FillRectangle(18+w*2+w div 2, 20, 2, w*2, Colors.White);
  DrawNflag;
 //справа сверху таймер 
 FillRectangle(Window.Width - 18,20, 2, w*2+2, Colors.White);
  FillRectangle(Window.Width - 18,18, -(w*2+w div 2+2), 2, Colors.Gray);
  FillRectangle(Window.Width - 18,19+w*2+1, -(w*2+w div 2), 2, Colors.White);
  FillRectangle(Window.Width - (18+w*2+w div 2), 20, -2, w*2, Colors.Gray);
  DrawText(window.Width - 18, 20, -(w*2+w div 2), w*2, '0'.toString, Colors.PaleVioletRed);
  t.Stop; time:=0; OnTimer;
//выводим поле закрытых клеток
 SetLength(visible,n,m);
 for var i := 0 to n-1 do
  for var j := 0 to m-1 do
   if LevelOld then //обновляем поле старых размеров скрывая только открытые клетки
     begin if visible[i,j] <> 0 then begin visible[i,j] := 0; DrawXY(i, j) end end
   else //создаем поле с новыми размерами
     begin visible[i,j] := 0; DrawXY(i, j) end;
//обнуляем состояние кнопок мыши 
 (LBdown, LBUp, RBdown, RBup):=(false,false,false,false);  
end;
 
//при зажатой левой или обеих кнопках мыши выделяем клетки "под раскрытие"
procedure MouseMove(x,y: real; mb:integer);
begin
 if Status > 100 then exit;
//зачистка предпросмотра 
 var PreviewClear := Procedure → 
   begin
    (PreviewX, PreviewY) := (-2, -2); //сброс указателя предпросмотра
    for var u := 0 to n-1 do 
     for var v:= 0 to m-1 do
       if visible[u,v] > 9 then begin visible[u,v] -= 10; DrawXY(u,v) end
   end;
//выход за границы игрового поля при предпросмотре  
  if not((x.Trunc in [12..11+m*w]) and (y.Trunc in [h..h+n*w-1])) then
   begin PreviewClear; exit; end; 
//если клетка уже на предпросмотре то выходим
 var (i,j) := (trunc(y - h) div w, trunc(x - 12) div w);
 if (PreviewX = i) and (PreviewY = j) then exit; 
//выводим: предпросмотр 1 клетки или 3х3
 if (LBdown or (LBdown and RBdown)) and not (LBup and RBup) then
   begin
    (PreviewX, PreviewY) := (i, j); //указатель предпросмотра на текущую клетку
    var d := RBdown ? 1 : 0; //с зажатой правой кнопкой мыши предпросмотр 3х3
    for var u := 0 to n-1 do 
     for var v:= 0 to m-1 do
      if (u in i-d..i+d) and (v in j-d..j+d) then 
       begin if visible[u,v] in [0,2] then begin visible[u,v] += 10; DrawXY(u,v) end end
      else if visible[u,v] > 9 then begin visible[u,v] -= 10; DrawXY(u,v); end
   end
//прекращение предпросмотра, отжата клавиша мыши
 else begin (PreviewX, PreviewY) := (-2, -2); PreviewClear; end;
end;
 
//победа или поражение (starus 200 или 150)
procedure theEnd;
begin
  t.Stop;
 for var i := 0 to n-1 do
  for var j := 0 to m-1 do //вывести все флажки и ошибочные флаги
   if (visible[i,j] =1) and (Status=150) then 
      //флаг заменить на мину или перечеркнутую мину (ошибка игрока)
      begin visible[i,j] := pole[i,j]=9 ? 9 : 7; DrawXY(i,j) end
   else       
      if (visible[i,j] in [0,2]) and (pole[i,j] = 9) then 
        //вывести мины(поражение) или флаги(победа)
        begin visible[i,j] := status=150 ? 9 : 1; DrawXY(i,j) end;
 if status = 200 then begin nFlag := 0; DrawNflag end;
end;
 
//обработать клик мыши над игровым полем
procedure mbPole(i,j:byte);
begin
  if Status > 100 then exit; //состояние "вне игры"
 var mbFlags:= Concat(ord(LBdown).ToString,ord(LBUp).ToString,
       ord(RBdown).ToString,ord(RBup).ToString);
 case mbFlags of 
  '0010': //нажата правая кнопка мыши, ставим пусто-флаг-вопрос
    if visible[i,j] < 3 then
    begin     
      //если убираем/ставим флажок то выводим кол-во оставшихся флагов
      if visible[i,j] = 0 then begin dec(nFlag); DrawNflag end 
      else if visible[i,j] = 1 then begin inc(nFlag); DrawNflag end;
      inc(visible[i,j]);
      if visible[i,j] > 1+ord(vopros) then visible[i,j]:=0;
      DrawXY(i,j);
    end;
  '0100': //отжата левая кнопка мыши. открыть скрытую ячейку
    begin
     if Status = 0 then begin GenPole(i,j); Status := 1 end;
     if visible[i,j] in [1,9] then exit;
     visible[i,j] := 9;
     DrawXY(i,j);
     var pusto: Procedure(ii,jj: byte);
      pusto := (ii,jj) → //рекурсия на открытие пустых клеток поля
        for var u := (ii-1).ClampBottom(0) to (ii+1).ClampTop(n-1) do
         for var v := (jj-1).ClampBottom(0) to (jj+1).ClampTop(m-1) do
         begin  
           if  visible[u,v] in [1,9] then continue else visible[u,v] := 9;
           DrawXY(u,v);
           if pole[u,v] = 0 then pusto(u,v);
         end;
      if pole[i, j] = 0 then pusto(i,j);//открыта пустая, запускаем рекурсию
      if pole[i, j] = 9 then begin Status := 150; theEnd; exit end; //поражение
      if otkrito = 0 then begin Status := 200; theEnd; exit end // победа      
    end;
 //отжали одну из двух нажатых кнопок мыши,  открыть ячейки учитывая флаги вокруг
    '1001','0110': 
      begin
       (LBdown, LBup, RBdown, RBup) := (false, true, false, false);
       (PreviewX, PreviewY) := (-2, -2); MouseMove(i*n,j*m,0); //отменить предпросмотр
       var c := 0;
       for var ii := (i-1).ClampBottom(0) to (i+1).ClampTop(n-1) do
        for var jj := (j-1).ClampBottom(0) to (j+1).ClampTop(m-1) do
         if visible[ii,jj] = 1 then inc(c); //подсчитали сколько флагов вокруг
       if (visible[i,j] = 9) and (pole[i,j] = c) then //и сравнили с нажатой цифрой
        for var u := (i-1).ClampBottom(0) to (i+1).ClampTop(n-1) do
         for var v := (j-1).ClampBottom(0) to (j+1).ClampTop(m-1) do
         begin
          if  visible[u,v] = 9 then continue;
          if visible[u,v] <> 1 then mbPole(u,v);//генерировать открытие клетки
         end;
       LBup := false;
      end;
   end; 
end;
 
procedure MouseUp(x,y: real;mb:integer);
begin
  case mb of
   0: if LBdown then (LBdown, LBup, RBup) := (false, true, false)
       else if RBdown then (LBup, RBdown, RBup) := (false, false, true);
   1: (LBdown, RBdown, RBup) := (true, false, true);
   2: (LBdown, LBUp) := (false, true);
  end;
 
//проверяем правильность отражения поля после предпросмотра
  if (mb > 0) or LBup then MouseMove(x,y,0);
//клик в поле, запуск обработки
  if (x.Trunc in [12..11+m*w]) and (y.Trunc in [h..h+n*w-1]) then 
   mbPole(trunc(y - h) div w, trunc(x - 12) div w);
end;
 
procedure MouseDown(x,y: real;mb:integer);
begin
  case mb of
   1: if LBdown and RBup then (RBdown, RBup) := (true, false) else
       if LBdown then (LBup, RBdown, RBUp) := (false, true, false) else
       if LBup then (LBdown, LBup) := (true, false)
       else (LBdown, RBup) := (true, false);   
   2: (LBup, RBdown, RBup) := (false, true, false);
  end; 
  
  if LBdown then //проверка клика над полем
  begin 
 //клик на "круг с вопросом"
    if (x.trunc in [(m+2) div 2 * w - (w div 2) .. (m+2) div 2 * w + (w div 2)]) and
       (y.trunc in [ h-27 - w div 2 .. h-27 + w div 2])  then
         begin vopros := not vopros; DrawVopros end;
 //клик в ряду "1-2-3" новая игра
    if (x.trunc in [m div 2 * w - w div 2.. (m+6) div 2 * w - w div 2]) and
       (y.trunc in [16 .. w+14])  then 
         begin Init((x.Trunc - (m div 2 * w - w div 2)) div w + 1); exit; end;//запуск новой игры
  end;       
  
//удерживается левая или обе кнопки мыши
  if LBdown or (LBdown and RBdown) then 
    begin (PreviewX, PreviewY) := (-2,-2); MouseMove(x,y,0) end;
  
//обработать клик в поле
  if (x.Trunc in [12..11+m*w]) and (y.Trunc in [h..h+n*w-1]) then
   mbPole(trunc(y - h) div w, trunc(x - 12) div w);
end;
 
begin
  t := new Timer(1000,OnTimer);
  Window.Title := 'Сапёр';
  window.SetSize(9 * w + 25, 9 * w + h + 11);
  Window.CenterOnScreen; 
  Window.IsFixedSize := True; 
  Font.Name := 'Courier New';
  Font.Style := Bold; 
  Font.Size := w;
  Init(1); //1-новичок, 2-любитель,3-профи
  OnMouseDown += MouseDown;
  OnMouseUp += MouseUp;
  OnMouseMove += MouseMove;
end.

@canadamoscow · 10.09.2020, 10:23

Игра Сапер на PascalABC.net (законченный вариант)

Кликните здесь для просмотра всего текста

Pascal

uses graphWPF, Timers;
 
const 
w = 24; //высота и ширина ячейки
h = 3*w+12; //отступ над полем
 
var 
  visible, //0 - скрытая клетка, 1 - флаг, 2 - вопрос, 9 - открытая, 10,12 - предпросмотр
  Pole: array[,] of byte; //0 - пустая клетка, 1..8 - кол-во мин вокруг, 9 - мина
  n, m, //размер поля m x n; количество открытых клеток (для анализа победы)
  status: byte;//0 - ждем первого хода, 1-первый ход сделан, расставили мины
            //2 - поражение, 3 - победа
  otkrit, //осталось ОТКРЫТЬ клеток до победы
  Bomb,//всего мин;
  nFlag,//флаги для установки (= Bomb);
  time: integer; // счетчик времени после первого хода
  LBdown, LBUp, RBdown, RBup, //состояния кнопок мыши; 
  vopros: boolean; //ставить ли '?' после флага правым кликом мыши
  t: timer; //таймер
  (PreviewX, PreviewY) := (-2,-2); //предпросмотра нет? указатель за пределами поля
//указатель на клетку под предпросмотром, во время удержания кнопки мыши
//чтобы при движении курсора мыши внутки клетки не было повторного предпросмотра
 
//вывод разных элементов
procedure DrawXY(i, j: byte); 
const
//для вывода: цифры, мина, флаг и вопрос
  poleSt: array of char = (' ','1','2','3','4','5','6','7','8',#8277, #9873,'?');
//цвета цифр, мины и флага
  ColorN: array of Color = (Colors.Black, Colors.Blue, Colors.Green, Colors.Red, Colors.DarkBlue,
   Colors.Brown, Colors.DarkCyan, Colors.Black, Colors.DarkGray, Colors.Black, Colors.MediumVioletRed);
 
begin
 var unvisible := Procedure(a,b: byte) → //рисуем закрытые клетки
  begin 
   var (x, y) := (b*w+12, a*w+h);
   FillRectangle(x,y,w-1, 2, Colors.White);
   FillRectangle(x,y,2, w-1, Colors.White);
   FillRectangle(x+1,y+w-2,w-1, 2, Colors.Gray);
   FillRectangle(x+w-2,y+1,2, w-1, Colors.Gray);
   FillRectangle(x+2,y+2,w-4, w-4, Colors.LightGray);
   SetPixel(x,y+w-1,Colors.DarkGray);
   SetPixel(x+1,y+w-2,Colors.DarkGray);
   SetPixel(x+w-2,y+1,Colors.DarkGray);
   SetPixel(x+w-1,y,Colors.DarkGray);
  end;
 var (ii, jj) := (j*w+12, i*w+h); //индекс ячейки переводим в координаты на поле
 
 case visible[i,j] of
//вывести закрытую ячейку без пометок
    0: unvisible(i,j); 
//вывести флажок
    1: begin unvisible(i,j); DrawText(ii, jj, w, w, poleSt[10], ColorN[10]) end;
//вывести вопрос    
    2: begin unvisible(i,j);  DrawText(ii, jj, w, w, poleSt[11], Colors.Black) end;
//вывести перечеркнутую мину (флаг был не верно поставлен)
    7: begin 
         FillRectangle(ii,jj,w, w, Colors.Gray);
         FillRectangle(ii+1,jj+1,w-1, w-1, Colors.LightGray);
         DrawText(ii+1, jj+1, w, w, poleSt[9], Colors.Black);
         Pen.Width := 3;
         line(ii+7,jj+2, ii+w-2,jj+w-2, Colors.MediumVioletRed);
         line(ii+3,jj+w-2, ii+w-2,jj+5, Colors.MediumVioletRed);
        end;
//вывести цифру мин вокруг или мину
    9: begin
         FillRectangle(ii,jj,w, w, Colors.Gray);
         FillRectangle(ii+1,jj+1,w-1, w-1, Colors.LightGray);
         if pole[i,j] <> 9 then
           begin//вывод кол-ва мин вокруг
             DrawText(ii+1, jj+1, w, w, poleSt[pole[i,j]], ColorN[pole[i,j]]);
             dec(otkrit); //счетчик открытых
           end
         else
           begin //вывод мины, первая(подрыв) на цветном фоне
             if Status < 2 then FillRectangle(ii+1,jj+1,w-1, w-1, Colors.HotPink);
             DrawText(ii+1, jj+1, w, w, poleSt[pole[i,j]], ColorN[pole[i,j]]);
           end;
        end;
//вывести клетку предпросмотр         
  10: begin 
         FillRectangle(ii,jj,w, w, Colors.Gray);
         FillRectangle(ii+1,jj+1,w-1, w-1, Colors.LightGray);
        end;
//вывести клетку предпросмотр c "вопросом"        
  12: begin 
         FillRectangle(ii,jj,w, w, Colors.Gray);
         FillRectangle(ii+1,jj+1,w-1, w-1, Colors.LightGray);
         DrawText(ii, jj, w, w, poleSt[11], Colors.Black);
        end;    
   end;
end;
 
//рисуем вверху "круг с вопросом"
procedure DrawVopros; 
begin 
  Pen.Color := vopros ? Colors.DarkCyan : Colors.Red;
  Pen.Width := 2;
  Circle(12 + m div 2 * w + w div 2 , h - w - 3, w div 2, Colors.White);
  Font.Size := w + w div 4;
  DrawText(12 + m div 2 * w, h - 3*w div 2-2 , w, w, '?', Colors.Black);      
  Font.Size := w;  
  if not vopros then DrawSector(12 + m div 2 * w + w div 2, h - w - 3, w div 2, -45, 135);
end;
 
//true - слева сверху вывод nFlag, false - справа сверху вывод time
procedure Tablo(nFlagOrTtime:boolean); 
Const 
 DrawRebro: array of byte = (   //Ребра одной цифры табло для вывода
{Верх} 0,0,w div 2,0, {ПравыйВерх}  w div 2,0,w div 2,3*w div 4-2, 
{ПравыйНиз} w div 2,3*w div 4,w div 2,3*w div 2, 
{Низ} 0,3*w div 2,w div 2,3*w div 2, {ЛевыйНиз} 0,3*w div 4,0,3*w div 2, 
{ЛевыйВерх}0,0,0,3*w div 4-2,{Центр}0,3*w div 4, w div 2,3*w div 4);
 
Rebro: array of array of byte = ( //какие ребра одной цифры подсветить
{0}(1, 1, 1, 1, 1, 1, 0), {1}(0, 1, 1, 0, 0, 0, 0), {r}(1, 1, 0, 1, 1, 0, 1), 
{2}(1, 1, 1, 1, 0, 0, 1), {4}(0, 1, 1, 0, 0, 1, 1), {5}(1, 0, 1, 1, 0, 1, 1),
{6}(1, 0, 1, 1, 1, 1, 1), {7}(1, 1, 1, 0, 0, 0, 0), {8}(1, 1, 1, 1, 1, 1, 1),
{9}(1, 1, 1, 1, 0, 1, 1), {-}(0, 0, 0, 0, 0, 0, 1)); 
 
otstup = window.Width.Trunc - 13 - (w*2+w div 2); // отступ для таймера
 
begin
 var cc, jj: integer;
 if nFlagOrTtime then (cc, jj) := (abs(nFlag), 23)
  else (cc, jj) := (Time, otstup);
 var c := Arr(cc div 100, cc div 10 mod 10, cc mod 10); //Цифры для вывода
 if nFlagOrTtime and (nFlag<0) then c[0] := 10; //вывести минус вначале
 Pen.Width := w div 5;
 for var j := 0 to 2 do //Перебор Цифр из S для вывода
 begin 
  var cj := 8; Pen.Color := Colors.Black; //закрасить чёрной '8' старую цифру
  loop 2 do 
   begin    
    for var k := 0 to 6 do
     if Rebro[cj, k] <> 0 then //выводим одно из семи рёбер цифры табло
      line(DrawRebro [k*4] + (w-5) * j + jj, DrawRebro [k*4 + 1] + 26,
       DrawRebro [k*4 + 2] + (w-5) * j + jj, DrawRebro [k*4 + 3] + 26);
   cj := c[j]; Pen.Color := Colors.Red; //теперь красным рисуем новую цифру
  end;
  end;
end;
 
//запускается раз в секунду после t.start
procedure OnTimer(); 
begin
  Tablo(false); //справа сверху рисуем выводим time
  time += 1; //число секунд для вывода +1
end;
 
//генерируем поле с минами и цифрами; (n1, m1) первая открытая клетка "без мины"
procedure GenPole(n1, m1: byte);
begin
 SetLength(Pole, n, m);
 var bombSSet := new SortedSet <word>;//множество с минами
 while bombSSet.Count <> bomb do
   begin 
     var IndexBomb := Random(0, n*m-1); 
     if IndexBomb <> (n1*m+m1) then bombSSet.Add(IndexBomb);
   end;
//расставляем мины по полю   
 for var i := 0 to n-1 do
  for var j := 0 to m-1 do
   if bombSSet.Contains(i*m+j) then 
     begin Pole[i,j] := 9; bombSSet.Remove(i*m+j) end
    else Pole[i,j] := 0;
//расставляем цифры по полю вокруг каждой мины
 for var i := 0 to n-1 do
  for var j := 0 to m-1 do     
    if Pole[i, j] = 9 then 
     for var ii := (i-1).ClampBottom(0) to (i+1).ClampTop(n-1) do
       for var jj := (j-1).ClampBottom(0) to (j+1).ClampTop(m-1) do
        if Pole[ii, jj] <> 9 then Pole[ii, jj] += 1; //вокруг мины каждой клетке +1
  t.Start;
end;
 
//Инициализация новой игры
Procedure Init(level: byte); 
begin
  case level of //Поле n x m, и кол-во бомб
    1: (n, m, Bomb) := ( 9, 9,10); //Новичок
    2: (n, m, Bomb) := (16,16,40); //Любитель
    3: (n, m, Bomb) := (16,30,99); //Профессионал
  end;
 status := 0; //статус ожидания первого хода
 otkrit := n*m - Bomb; //количество клеток, для открывания (подсчет до победы)
 nFlag := Bomb; //количество флагов для пометок (выводится слева сверху)
 var LevelOld := false; //размер поля изменился (для ускорения вывода поля);
 if window.Width <> m * w + 25 then
    window.SetSize(m * w + 25, n * w + h + 11) else LevelOld := true;
 //Рисуем игровое поле
 FillRectangle(3,3,m * w + 17, n * w + h + 5,Colors.LightGray);
 FillRectangle(9,h-3, 3, n*w+5,Colors.Gray); 
 FillRectangle(9,h-3, m*w+5, 3,Colors.Gray);
 FillRectangle(10,h + n * w, m * w+4, 3, Colors.White); 
 FillRectangle(12 + m * w, h-2, 3, n * w+5, Colors.White);
 SetPixel(10, h + n * w, Colors.Gray);
 SetPixel(10, h+1 + n * w, Colors.LightGray);
 SetPixel(11, h + n * w, Colors.LightGray);
 SetPixel(12 + m * w, h-2, Colors.Gray);
 SetPixel(12 + m * w, h-1, Colors.LightGray);
 SetPixel(13 + m * w, h-2, Colors.LightGray);
 //рисуем область сверху над игровым полем
 FillRectangle(9,9, 3, h - 18,Colors.Gray); 
 FillRectangle(9,9, m*w+5, 3,Colors.Gray);
 FillRectangle(10,h-11 , m * w+5, 3, Colors.White); 
 FillRectangle(12 + m * w, 10, 3, h-19, Colors.White);
 SetPixel(10, h-11, Colors.Gray);
 SetPixel(10, h-10, Colors.LightGray);
 SetPixel(11, h-11, Colors.LightGray);
 SetPixel(12+m*w, 10, Colors.Gray);
 SetPixel(13+m*w, 10,  Colors.LightGray);
 SetPixel(12+m*w, 11,  Colors.LightGray);
 //выводим кнопки сверху "1-2-3 Новая игра" 
 var knopka := Procedure(a,b: byte) → //рикусем кнопкy
  begin
   var (x, y) := (b*w+12, a*w+15);
   FillRectangle(x,y,w-1, 2, Colors.White);
   FillRectangle(x,y,2, w-1, Colors.White);
   FillRectangle(x+1,y+w-2,w-1, 2, Colors.Gray);
   FillRectangle(x+w-2,y+1,2, w-1, Colors.Gray);
   FillRectangle(x+2,y+2,w-4, w-4, Colors.LightGray);
   SetPixel(x,y+w-1,Colors.DarkGray);
   SetPixel(x+1,y+w-2,Colors.DarkGray);
   SetPixel(x+w-2,y+1,Colors.DarkGray);
   SetPixel(x+w-1,y,Colors.DarkGray);
  end;
  if not LevelOld then //если новый размер окна то перерисовываем
   for var f := 0 to 2 do
   begin 
    var ColorN := Arr(Colors.Blue, Colors.Green, Colors.Red);
    var yy := m div 2 - 1+ f;
    knopka(0, yy);
    DrawText(yy*w+12, 16, w, w, (f+1).ToString, ColorN[f]);      
   end; 
//выводим сверху "круг с вопросом"
  DrawVopros; 
//слева сверху колво оставшихся флагов
  FillRectangle(16,18, 2, w*2+2, Colors.Gray);
  FillRectangle(16,18, w*2+w div 2+2, 2, Colors.Gray);
  FillRectangle(18,19+w*2+1, w*2+w div 2+2, 2, Colors.White);
  FillRectangle(18+w*2+w div 2, 20, 2, w*2, Colors.White);
  FillRectangle(18,20,w*2+w div 2, w*2, Colors.Black);
  Tablo(true); //вывод цифр
 //справа сверху таймер 
  FillRectangle(Window.Width.Trunc - 18,20, 2, w*2+2, Colors.White);
  FillRectangle(Window.Width.Trunc - 18,18, -(w*2+w div 2+2), 2, Colors.Gray);
  FillRectangle(Window.Width.Trunc - 18,19+w*2+1, -(w*2+w div 2), 2, Colors.White);
  FillRectangle(Window.Width.Trunc - (18+w*2+w div 2), 20, -2, w*2, Colors.Gray);
  //DrawText(window.Width - 18, 20, -(w*2+w div 2), w*2, '0'.toString, Colors.PaleVioletRed);
  FillRectangle(window.Width.Trunc - 18, 20, -(w*2+w div 2), w*2, Colors.Black);
  t.Stop; time:=0; OnTimer; //остановка таймера и вывод 000 справа сверху
//выводим поле закрытых клеток
 SetLength(visible,n,m);
 for var i := 0 to n-1 do
  for var j := 0 to m-1 do
   if LevelOld then 
    //обновляем поле старых размеров скрывая только открытые клетки
    begin if visible[i,j] <> 0 then begin visible[i,j] := 0; DrawXY(i, j) end end
   else 
    //выводим все клетки на поле с новыми размерами
    begin visible[i,j] := 0; DrawXY(i, j) end;
//обнуляем состояние кнопок мыши 
 (LBdown, LBUp, RBdown, RBup):=(false,false,false,false);  
end;
 
//при зажатой левой или обеих кнопках мыши запускаем Предпросмотр
procedure MouseMove(x,y: real; mb:integer);
begin
 if Status > 1 then exit;
//зачистка предпросмотра 
 var PreviewClear := Procedure → 
   begin
    (PreviewX, PreviewY) := (-2, -2); //сброс указателя предпросмотра
    for var u := 0 to n-1 do 
     for var v:= 0 to m-1 do
       if visible[u,v] > 9 then begin visible[u,v] -= 10; DrawXY(u,v) end
   end;
//выход за границы игрового поля при предпросмотре  
  if not((x.Trunc in [12..11+m*w]) and (y.Trunc in [h..h+n*w-1])) then
   begin PreviewClear; exit; end; 
//если клетка уже на предпросмотре то выходим
 var (i,j) := (trunc(y - h) div w, trunc(x - 12) div w);
 if (PreviewX = i) and (PreviewY = j) then exit; 
//выводим: предпросмотр 1 клетки или 3х3
 if (LBdown or (LBdown and RBdown)) and not (LBup and RBup) then
   begin
    (PreviewX, PreviewY) := (i, j); //указатель предпросмотра на текущую клетку
    var d := RBdown ? 1 : 0; //с зажатой правой кнопкой мыши предпросмотр 3х3
    for var u := 0 to n-1 do 
     for var v:= 0 to m-1 do
      if (u in i-d..i+d) and (v in j-d..j+d) then 
       begin if visible[u,v] in [0,2] then begin visible[u,v] += 10; DrawXY(u,v) end end
      else if visible[u,v] > 9 then begin visible[u,v] -= 10; DrawXY(u,v); end
   end
//прекращение предпросмотра, отжата клавиша мыши
 else begin (PreviewX, PreviewY) := (-2, -2); PreviewClear; end;
end;
 
//победа (status = 3) или поражение (status = 2)
procedure theEnd;
begin
  t.Stop; //остановить таймер
 for var i := 0 to n-1 do
  for var j := 0 to m-1 do //вывести все флажки и ошибочные флаги
   if (visible[i,j] =1) and (Status=2) then 
      //флаг заменить на мину или перечеркнутую мину (ошибка игрока)
      begin visible[i,j] := pole[i,j]=9 ? 9 : 7; DrawXY(i,j) end
   else       
      if (visible[i,j] in [0,2]) and (pole[i,j] = 9) then 
        //вывести мины(поражение) или флаги(победа)
        begin visible[i,j] := status=2 ? 9 : 1; DrawXY(i,j) end;
 if status = 3 then begin nFlag := 0; Tablo(true) end; //победа, осталось 0 флагов
end;
 
//обработать клик мыши над игровым полем
procedure mbPole(i,j:byte);
begin
  if Status > 1 then exit; //состояние "вне игры"
 var mbFlags:= Concat(ord(LBdown).ToString,ord(LBUp).ToString,
       ord(RBdown).ToString,ord(RBup).ToString);
 case mbFlags of 
  '0010': //нажата правая кнопка мыши, ставим пусто-флаг-вопрос
    if visible[i,j] < 3 then
    begin     
      //если убираем/ставим флажок то выводим кол-во оставшихся флагов
      if visible[i,j] = 0 then begin dec(nFlag); Tablo(true) end 
      else if visible[i,j] = 1 then begin inc(nFlag); Tablo(true) end;
      inc(visible[i,j]);
      if visible[i,j] > 1+ord(vopros) then visible[i,j]:=0;
      DrawXY(i,j);
    end;
  '0100': //отжата левая кнопка мыши. открыть скрытую ячейку
    begin
     if Status = 0 then begin GenPole(i,j); Status := 1 end;
     if visible[i,j] in [1,9] then exit;
     visible[i,j] := 9;
     DrawXY(i,j);
     var pusto: Procedure(ii,jj: byte);
      pusto := (ii,jj) → //рекурсия на открытие пустых клеток поля
        for var u := (ii-1).ClampBottom(0) to (ii+1).ClampTop(n-1) do
         for var v := (jj-1).ClampBottom(0) to (jj+1).ClampTop(m-1) do
         begin  
           if  visible[u,v] in [1,9] then continue else visible[u,v] := 9;
           DrawXY(u,v);
           if pole[u,v] = 0 then pusto(u,v);
         end;
      if pole[i, j] = 0 then pusto(i,j);//открыта пустая, запускаем рекурсию
      if pole[i, j] = 9 then begin Status := 2; theEnd; exit end; //поражение
      if otkrit = 0 then begin Status := 3; theEnd; exit end // победа      
    end;
 //отжали одну из двух нажатых кнопок мыши,  открыть ячейки учитывая флаги вокруг
    '1001','0110': 
      begin
       (LBdown, LBup, RBdown, RBup) := (false, true, false, false);
       (PreviewX, PreviewY) := (-2, -2); MouseMove(i*n,j*m,0); //отменить предпросмотр
       var c := 0;
       for var ii := (i-1).ClampBottom(0) to (i+1).ClampTop(n-1) do
        for var jj := (j-1).ClampBottom(0) to (j+1).ClampTop(m-1) do
         if visible[ii,jj] = 1 then inc(c); //подсчитали сколько флагов вокруг
       if (visible[i,j] = 9) and (pole[i,j] = c) then //и сравнили с нажатой цифрой
        for var u := (i-1).ClampBottom(0) to (i+1).ClampTop(n-1) do
         for var v := (j-1).ClampBottom(0) to (j+1).ClampTop(m-1) do
         begin
          if  visible[u,v] = 9 then continue;
          if visible[u,v] <> 1 then mbPole(u,v);//генерировать открытие клетки
         end;
       LBup := false;
      end;
   end; 
end;
 
procedure MouseUp(x,y: real;mb:integer);
begin
  case mb of
   0: if LBdown then (LBdown, LBup, RBup) := (false, true, false)
       else if RBdown then (LBup, RBdown, RBup) := (false, false, true);
   1: (LBdown, RBdown, RBup) := (true, false, true);
   2: (LBdown, LBUp) := (false, true);
  end;
 
//проверяем правильность отражения поля после предпросмотра
  if (mb > 0) or LBup then MouseMove(x,y,0);
//клик в поле, запуск обработки
  if (x.Trunc in [12..11+m*w]) and (y.Trunc in [h..h+n*w-1]) then 
   mbPole(trunc(y - h) div w, trunc(x - 12) div w);
end;
 
procedure MouseDown(x,y: real;mb:integer);
begin
  case mb of
   1: if LBdown and RBup then (RBdown, RBup) := (true, false) else
       if LBdown then (LBup, RBdown, RBUp) := (false, true, false) else
       if LBup then (LBdown, LBup) := (true, false)
       else (LBdown, RBup) := (true, false);   
   2: (LBup, RBdown, RBup) := (false, true, false);
  end; 
  
  if LBdown then //проверка клика над полем
  begin 
 //клик на "круг с вопросом"
    if (x.trunc in [(m+2) div 2 * w - (w div 2) .. (m+2) div 2 * w + (w div 2)]) and
       (y.trunc in [ h-27 - w div 2 .. h-27 + w div 2])  then
         begin vopros := not vopros; DrawVopros end;
 //клик в ряду "1-2-3" новая игра
    if (x.trunc in [m div 2 * w - w div 2.. (m+6) div 2 * w - w div 2]) and
       (y.trunc in [16 .. w+14])  then 
         begin Init((x.Trunc - (m div 2 * w - w div 2)) div w + 1); exit; end;//запуск новой игры
  end;       
  
//удерживается левая или обе кнопки мыши
  if LBdown or (LBdown and RBdown) then 
    begin (PreviewX, PreviewY) := (-2,-2); MouseMove(x,y,0) end;
  
//обработать клик в поле
  if (x.Trunc in [12..11+m*w]) and (y.Trunc in [h..h+n*w-1]) then
   mbPole(trunc(y - h) div w, trunc(x - 12) div w);
end;
 
begin
  t := new Timer(1000,OnTimer);
  Window.Title := 'Сапёр';
  window.SetSize(9 * w + 25, 9 * w + h + 11);
  Window.CenterOnScreen; 
  Window.IsFixedSize := True; 
  Font.Name := 'Courier New';
  Font.Style := Bold; 
  Font.Size := w;
  Init(1); //1-новичок, 2-любитель,3-профи
  OnMouseDown += MouseDown;
  OnMouseUp += MouseUp;
  OnMouseMove += MouseMove;
end.

@Пс · 25.07.2021, 15:04

Модуль для упрощения работы с событиями мыши в WPF

Кликните здесь для просмотра всего текста

Pascal

unit MouseEventsWPF;
 
interface
 
uses WPFObjects;
 
type
  PictureEvents = class
    private OList := new List<PictureWPF>;
  public
    event MouseDown, MouseUp, MouseEnter, MouseLeave: procedure(o: PictureWPF; mb: integer);
    event NonMouseUp: procedure(x, y: real; mb: integer);
    
    constructor Create(params a: array of PictureWPF) := a.ForEach(i -> begin OList.Add(i) end);
    
    procedure InitMouseDown;
    begin
      OnMouseDown += (x, y, mb)-> begin
        var o: PictureWPF;
        try
          o := PictureWPF(ObjectUnderPoint(x, y));
          if (o <> nil) then 
            if (o in OList) and (o.Visible) then
              if MouseDown <> nil then
                MouseDown(o, mb);
        except
        end;
      end;
    end;
    
    procedure InitMouseUp;
    begin
      OnMouseUp += (x, y, mb)-> begin
        try
          var o: PictureWPF;
          o := PictureWPF(ObjectUnderPoint(x, y));
          if (o <> nil)   then 
          begin
            if (o in OList) and (o.Visible) then
              if MouseUp <> nil then
                MouseUp(o, mb);
            
            if (not (o in OList)) then
              if (NonMouseUp <> nil) then
                NonMouseUp(x, y, mb);
          end;
        except
        end;
      end;
    end;
    
    procedure InitMouseEnter;
    begin
      OnMouseMove += (x, y, mb)-> begin
        try
          var o: PictureWPF;
          o := PictureWPF(ObjectUnderPoint(x, y));
          if (o <> nil) then 
          begin
            if (o in OList) and (o.Visible) then
              if MouseEnter <> nil then
                MouseEnter(o, mb);
            //!!!!!!!!!!!!!!Доделать MouseLeave
          end;
        except
        end;
      end;
    end;
  end;
  
  ObjectEvents = class
    private OList := new List<ObjectWPF>;
  public
    event MouseDown, MouseUp, MouseEnter, MouseLeave: procedure(o: ObjectWPF; mb: integer);
    event NonMouseUp: procedure(x, y: real; mb: integer);
    
    constructor Create(params a: array of ObjectWPF) := a.ForEach(i -> begin OList.Add(i) end);
    
    procedure InitMouseDown;
    begin
      OnMouseDown += (x, y, mb)-> begin
        try
          var  o := ObjectUnderPoint(x, y);
          if (o <> nil) then 
            if (o in OList) and (o.Visible) then
              if MouseDown <> nil then
                MouseDown(o, mb);
        except
        end;
      end;
    end;
    
    procedure InitMouseUp;
    begin
      OnMouseUp += (x, y, mb)-> begin
        try
          var  o := ObjectUnderPoint(x, y);
          if (o <> nil) then 
            if  (o in OList) and (o.Visible) then 
              if MouseUp <> nil then
                MouseUp(o, mb);
          if NonMouseUp <> nil then
            NonMouseUp(x, y, mb);
        except
        end;
      end;
    end;
    
    procedure InitMouseEnter;
    begin
      OnMouseMove += (x, y, mb)-> begin
        try
          var  o := ObjectUnderPoint(x, y);
          if (o <> nil) then
          begin
            if (o in OList) and (o.Visible) then
            begin
              if MouseEnter <> nil then
                MouseEnter(o, mb)
            end;
            if not (o in OList) then
              if MouseLeave <> nil then
                MouseLeave(o, mb);
          end
          else begin
            if MouseLeave <> nil then
              MouseLeave(o, mb);
          end;
        except
        end;
      end;
    end;
  end;
 
implementation
 
begin
 
end.

Добавлено через 3 минуты
Класс кнопок в WPF (с использованием модуля MouseEventsWPF:https://www.cyberforum.ru/post15635221.html)

Кликните здесь для просмотра всего текста

Pascal

unit WPFButtons;
/////////////////////////!!!!!!!!!!!!!!!!!!!!!!!!!!!!Сделать объемную кнопку
interface
 
uses WPFObjects, MouseEventsWPF;
 
type
  RectangleButtonWPF = class
  private
    oe: ObjectEvents;
    rec: RectangleWPF;
    down_flag := false;
  
  public
    event Click, MouseEnter, MouseLeave: procedure;
    constructor Create(x, y, w, h: real; txt: string; cl: Color);
    begin
      rec := new RectangleWPF(x, y, w, h, cl);
      rec.Text := txt;
      oe := new ObjectEvents(rec);
      oe.InitMouseDown;
      oe.InitMouseUp;
      oe.MouseDown += (o, mb)-> begin
        if mb = 1 then
        begin
          down_flag := true;
          rec.Left += 2;
          rec.Top += 2;
        end;
      end;
      
      oe.MouseUp += (o, mb)-> begin
        if (down_flag) then
        begin
          down_flag := false;
          rec.Left -= 2;
          rec.Top -= 2;
          if Click <> nil then
            Click;
        end;
      end;
      
      oe.NonMouseUp += (x, y, mb)-> begin
        if down_flag then
        begin
          rec.Left -= 2;
          rec.Top -= 2;
        end;
        down_flag := false;
      end;
    end;
    
    procedure Destroy;
    begin
      oe := nil;
      rec.Destroy;
    end;
    
    property Left: real read rec.Left write rec.Left := value;
    property Top: real read rec.Top write rec.Top := value;
    property Width: real read rec.Width write rec.Width := value;
    property Height: real read rec.Height write rec.Height := value;
    property ButtonColor: color read rec.Color write rec.Color := value;
    property TextColor: color read rec.FontColor write rec.FontColor := value;
    property BorderColor: color read rec.BorderColor write rec.BorderColor := value;
    property BorderWidth: real read rec.BorderWidth write rec.BorderWidth := value;
    property Visible: boolean read rec.Visible write rec.Visible := value;
  
  end;
  
  CircleButtonWPF = class
  private
    oe: ObjectEvents;
    cir: RoundRectWPF;
    
    down_flag := false;
  
  public
    event Click, MouseEnter, MouseLeave: procedure;
    constructor Create(x, y, w, h: real; txt: string; cl: Color);
    begin
      cir := new RoundRectWPF(x, y, w, h, 20, cl);
      cir.Text := txt;
      oe := new ObjectEvents(cir);
      oe.InitMouseDown;
      oe.InitMouseUp;
      oe.InitMouseEnter;
      oe.MouseDown += (o, mb)-> begin
        if mb = 1 then
        begin
          down_flag := true;
          cir.Left += 2;
          cir.Top += 2;
        end;
      end;
      
      oe.MouseUp += (o, mb)-> begin
        if (down_flag) then
        begin
          down_flag := false;
          cir.Left -= 2;
          cir.Top -= 2;
          if Click <> nil then
            Click;
        end;
      end;
      
      oe.NonMouseUp += (x, y, mb)-> begin
        if down_flag then
        begin
          cir.Left -= 2;
          cir.Top -= 2;
        end;
        down_flag := false;
      end;
      
      oe.MouseEnter += (o, mb)-> begin
        if MouseEnter <> nil then 
          MouseEnter;
      end;
      
      oe.MouseLeave += (o, mb)-> begin
        if MouseLeave <> nil then 
          MouseLeave;
      end;
    end;
    
    procedure Destroy;
    begin
      oe := nil;
      cir.Destroy;
    end;
    
    property Left: real read cir.Left write cir.Left := value;
    property Top: real read cir.Top write cir.Top := value;
    property Width: real read cir.Width write cir.Width := value;
    property Height: real read cir.Height write cir.Height := value;
    property ButtonColor: color read cir.Color write cir.Color := value;
    property TextColor: color read cir.FontColor write cir.FontColor := value;
    property BorderColor: color read cir.BorderColor write cir.BorderColor := value;
    property BorderWidth: real read cir.BorderWidth write cir.BorderWidth := value;
    property Visible: boolean read cir.Visible write cir.Visible := value;
  
  end;
 
implementation
 
begin
 
end.

agvego5 · 23.09.2023, 18:21

строка 1 program qq;

строка называется заголовком программы и не является обязательной.
В PascalABC.NET использование заголовка программы считается устаревшим.

25 строка
if play=true then begin ... end;
достаточно написать if play then ...

1. не нужна дополнительная проверка play
2. операторные скобки begin end также не нужны, т.к. после then идет оператор цикл

@OwenGlendower · 23.09.2023, 19:00

agvego5, кому вы отвечаете?

agvego5 · 24.09.2023, 09:18

Makloth

@npoh 0 / 0 / 0 Регистрация: 20.04.2019 Сообщений: 23
	21.04.2019, 16:44	123
	Сообщение от BaboshinSD Eclipse.rar и Serious Slam.rar Пожалуйста прищлите pas файлы 0

@Соколиный глаз Alvin Seville 343 / 273 / 134 Регистрация: 25.07.2014 Сообщений: 4,537 Записей в блоге: 9
	21.04.2019, 19:08	124
	npoh, он давно уже неактивен (Последняя активность: 21.01.2014 00:55). 0

@Sun Serega 2351 / 1454 / 526 Регистрация: 07.04.2017 Сообщений: 4,791
	21.04.2019, 20:15	125
	Сообщение от npoh Пожалуйста пришлите pas файлы А чем вам архивы не нравятся? Вы не умеете скачивать WinRAR? У него пробная версия, хоть и написано что месяц - вообще бесконечна. А без архиватора жить вообще сложно. Но вообще, я сам пытался на тех играх научится использовать OpenGL - в итоге туториалы для C++ OpenGL больше помогли, ибо Eclipse и Serious Slam написаны на очень старой версии компилятора. Заставить их компилироваться нереально. Если хотите рабочие примеры - посмотрите, к примеру, сюда. Эта игра, конечно, не доделана, но она хотя бы компилируется и запускается... 0

@Пс 257 / 149 / 70 Регистрация: 29.07.2018 Сообщений: 1,246
	06.09.2020, 21:31	128
	canadamoscow, Можно код сюда,пожалуйста. Добавлено через 3 минуты canadamoscow, Я тоже не давно делал,только,может завтра закину 0

agvego5 20 / 18 / 2 Регистрация: 18.09.2023 Сообщений: 183
	23.09.2023, 18:21	132
	строка 1 program qq; строка называется заголовком программы и не является обязательной. В PascalABC.NET использование заголовка программы считается устаревшим. 25 строка if play=true then begin ... end; достаточно написать if play then ... 1. не нужна дополнительная проверка play 2. операторные скобки begin end также не нужны, т.к. после then идет оператор цикл 0

@OwenGlendower Администратор 17714 / 13840 / 5314 Регистрация: 17.03.2014 Сообщений: 28,349 Записей в блоге: 1
	23.09.2023, 19:00	133
	agvego5, кому вы отвечаете? 0

agvego5 20 / 18 / 2 Регистрация: 18.09.2023 Сообщений: 183
	24.09.2023, 09:18	134
	Makloth 0

Новые блоги и статьи
Test mik-a-el 07.01.2025 Test	Счётчик на базе сумматоров + регистров и генератора сигналов согласования. Hrethgir 07.01.2025 Создан с целью проверки скорости асинхронной логики: ранее описанного сумматора и предополагаемых fast регистров. Регистры созданы на базе ранее описанного, предполагаемого fast триггера. То-есть. . .	Как перейти с Options API на Composition API в Vue.js BasicMan 06.01.2025 Почему переход на Composition API актуален В мире современной веб-разработки фреймворк Vue. js продолжает эволюционировать, предлагая разработчикам все более совершенные инструменты для создания. . .	Архитектура современных процессоров inter-admin 06.01.2025 Процессор (центральный процессор, ЦП) является основным вычислительным устройством компьютера, которое выполняет обработку данных и управляет работой всех остальных компонентов системы. Архитектура. . .	История создания реляционной модели баз данных, правила Кодда Programming 06.01.2025 Предпосылки создания реляционной модели В конце 1960-х годов компьютерная индустрия столкнулась с серьезными проблемами в области управления данными. Существовавшие на тот момент модели данных -. . .	Полезные поделки на Arduino, которые можно сделать самому raxper 06.01.2025 Arduino как платформа для творчества Arduino представляет собой удивительную платформу для технического творчества, которая открывает безграничные возможности для создания уникальных проектов. Эта. . .
Подборка решений задач на Python IT_Exp 06.01.2025 Целью данной подборки является предоставление возможности ознакомиться с различными задачами и их решениями на Python, что может быть полезно как для начинающих, так и для опытных программистов. . . .	С чего начать программировать микроконтроллеры raxper 06.01.2025 Введение в мир микроконтроллеров Микроконтроллеры стали неотъемлемой частью современного мира, окружая нас повсюду: от простых бытовых приборов до сложных промышленных систем. Эти маленькие. . .	Из чего собрать игровой компьютер inter-admin 06.01.2025 Сборка игрового компьютера требует особого внимания к выбору комплектующих и их совместимости. Правильно собранный игровой ПК не только обеспечивает комфортный геймплей в современных играх, но и. . .	Обновление сайта www.historian.by Reglage 05.01.2025 Обещал подвести итоги 2024 года для сайта. Однако начну с того, что изменилось за неделю. Добавил краткий урок по последовательности действий при анализе вредоносных файлов и значительно улучшил урок. . .	Как использовать GraphQL в C# с HotChocolate Programming 05.01.2025 GraphQL — это современный подход к разработке API, который позволяет клиентам запрашивать только те данные, которые им необходимы. Это делает взаимодействие с API более гибким и эффективным по. . .	Модель полного двоичного сумматора с помощью логических операций (python) AlexSky-coder 04.01.2025 def binSum(x:list, y:list): s=^y] p=x and y for i in range(1,len(x)): s. append((x^y)^p) p=(x and y)or(p and (x or y)) return s x=list() y=list()