Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Delphi программирование > Паскаль, Turbo Pascal, PascalABC.NET
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 14.06.2021, 17:44   #1
kirik221
 
Регистрация: 28.12.2020
Сообщений: 4
По умолчанию написать программу Игра «Линии»

Здравствуйте, необходимо создать игру Линии на паскале, можно через формы.

Игра «Линии» –игра на логику, в которой необходимо очищать игровое поле от шариков. Поле представляет собой квадрат, состоящий из клеток. Необходимо переставлять шарики одного цвета в линии из 5 и более по горизонтали или вертикали. В начале шариков мало, но в течение игры их количество увеличивается. За ход игрок может передвинуть один шарик, выделив его и указав его новое местоположение. При этом для совершения хода необходимо, чтобы между начальной и конечной клетками существовал путь из свободных клеток. При выстраивании линии из четырёх и более шариков одного цвета (по горизонтали, вертикали или диагонали) она исчезает. После каждого хода выставляются новые три шарика, но при исчезновении линии этого не происходит.
Смысл игры заключается в том, что необходимо набрать как можно больше очков, из одноцветных шаров фигуры.
kirik221 вне форума Ответить с цитированием
Старый 14.06.2021, 21:26   #2
digitalis
Старожил
 
Аватар для digitalis
 
Регистрация: 04.02.2011
Сообщений: 4,534
По умолчанию

Цитата:
Сообщение от kirik221 Посмотреть сообщение
Смысл игры заключается в том...
А в чём смысл для участника форума писать эту, извиняюсь, игру? Во ФРИЛАНС, и там, как говорит Larboss ... (см. https://programmersforum.ru/showthread.php?t=339728 )
digitalis вне форума Ответить с цитированием
Старый 15.01.2022, 12:42   #3
canadamoscow
Пользователь
 
Аватар для canadamoscow
 
Регистрация: 16.05.2020
Сообщений: 57
По умолчанию

Игра ЛИНИИ на PascalABC.NET (часть 1)
Код:
{$apptype windows}
uses GraphWPF;
 
const 
w = 50; //ширина ячейки
h = 55; //отступ над клетками c шарами
 
var
  (n, nn) := (9,9); //начальный размер поля 9х9, nn изменяется в правом верхнем углу поля
  Pole: array[,] of integer;  //матрица хранения номера цвета, 0 = пустая клетка
  BallClick, //флаг - выбран шар для хода 
  PoleBlocked: boolean; //флаг "поле заблокировано true = конец игры или идет перемещение шара
  BallClickIndex: (integer, integer); //индекс выбранного игроком шара
  Dollar: integer; //очки, кол-во собранных шаров
 
//вывод изображений по индексу
procedure DrawXY(i,j: integer); 
const ColorN: array of Color  = (Colors.Black, Colors.Red, Colors.Gold, Colors.ForestGreen, 
  Colors.DarkCyan, Colors.Blue, Colors.Fuchsia, Colors.Brown); 
begin
 if i = 20 then begin //вывод кол-ва очков
     FillRectangle(Window.Width.trunc div 2 - w,5,w*2,w-18,Colors.Black);
     Font.Size := w*2 div 3;
     DrawText(0,0,Window.Width,w-8, j.toString.PadLeft(5,'0'));
     exit;
 end;
 var (x, y) := (j*w+3, i*w+h-1); //координаты левого верхнего угла клетки [i,j] на экране
 case Pole[i,j] of
  0: //очистка клетки серой заливкой
    FillRectangle(x+2,y+2,w-5, w-5, RGB(192,192,192));
  1..7: //вывод шара на поле
    FillCircle(x+w div 2, y+w div 2, trunc(0.38*w), ColorN[Pole[i,j]]);
  11..17: //выделение шара для хода
    DrawCircle(x+w div 2, y+w div 2, trunc(0.38*w)-1, Colors.White);
 end     
end;
 
//все клетки заняты, конец игры
Procedure TheEnd;
begin
  PoleBlocked := true;  
  Font.Color := Colors.Gold;
  Font.Size := 2 * w div 5;
  FillRectangle(Window.Width.trunc div 2 - w+5 ,5,w*2-7,w-18,Colors.DarkRed);
  DrawText(Window.Width.trunc div 2 - w,5,w*2,w-18, 'КОНЕЦ');
end;
 
//удаление линий из 5 шаров
Function DeleteBallLine: boolean; 
begin
 Result := false;
 var metka := new boolean[n,n]; //помечаем к удалению
//метка шаров к удалению по горизонталям
 for var i:=0 to n-5 do
  for var j:=0 to n-1 do
   if (Pole[i,j]=Pole[i+1,j]) and (Pole[i,j]=Pole[i+2,j]) and (Pole[i,j]=Pole[i+3,j]) 
   and (Pole[i,j]=Pole[i+4,j]) and (Pole[i,j]>0) then
    begin
     Result := true; 
     metka[i,j]:=true;
     metka[i+1,j]:=true;
     metka[i+2,j]:=true;
     metka[i+3,j]:=true;
     metka[i+4,j]:=true;
    end;
//метка шаров к удалению по вертикалям
 for var i:=0 to n-1 do
  for var j:=0 to n-5 do
   if (Pole[i,j]=Pole[i,j+1]) and (Pole[i,j]=Pole[i,j+2]) and (Pole[i,j]=Pole[i,j+3]) 
   and (Pole[i,j]=Pole[i,j+4]) and (Pole[i,j]>0) then
    begin
     Result := true; 
     metka[i,j]:=true;
     metka[i,j+1]:=true;
     metka[i,j+2]:=true;
     metka[i,j+3]:=true;
     metka[i,j+4]:=true;
    end;
//метка шаров к удалению по диагоналям
 for var i:=0 to n-5  do
  for var j:=0 to n-5 do
   if (Pole[i,j]>0) and (Pole[i,j]=Pole[i+1,j+1]) and (Pole[i,j]=Pole[i+2,j+2]) 
   and (Pole[i,j]=Pole[i+3,j+3]) and (Pole[i,j]=Pole[i+4,j+4]) then
    begin
     Result := true; 
     metka[i,j]:=true;
     metka[i+1,j+1]:=true;
     metka[i+2,j+2]:=true;
     metka[i+3,j+3]:=true;
     metka[i+4,j+4]:=true;
    end;
 for var i:=n-1 downto 4 do
  for var j:=0 to n-5 do
   if (Pole[i,j]>0) and (Pole[i,j]=Pole[i-1,j+1]) and (Pole[i,j]=Pole[i-2,j+2]) 
   and (Pole[i,j]=Pole[i-3,j+3]) and (Pole[i,j]=Pole[i-4,j+4]) then
    begin
     Result := true; 
     metka[i,j]:=true;
     metka[i-1,j+1]:=true;
     metka[i-2,j+2]:=true;
     metka[i-3,j+3]:=true;
     metka[i-4,j+4]:=true;
    end;
 If Result then sleep(200);    
//удаление
 for var i:=0 to n-1 do
  for var j:=0 to n-1 do
   if metka[i,j] then
    begin
     Dollar:=Dollar + 1;
     Pole[i,j]:=0;
     DrawXY(i,j);
     metka[i,j] := false;
 end;
 DrawXY(20, Dollar); //вывод очков
end;
 
//выводим три новых шара
Procedure RandomBall;
begin
   if DeleteBallLine then exit; //после удаления собранного комплекта новые шары не выводим
   var Zero := Pole.Indices(t-> t=0).toArray;; //сканируем поле на наличие пустых клеток
   if Zero.Count = 0 then begin theEnd; exit end;//поле заполнено - конец игры
   Zero.Shuffle[:min(3, zero.Count)] //массив адресов пустых клеток перемешать и выбрать первые три
    .ForEach(t-> begin Pole[t.Item1, t.Item2] := Random(1,7); DrawXY(t.Item1, t.Item2) end);
   DeleteBallLine;    //проверка на возможность удаления собранной линии
   if Pole.Indices(t-> t=0).Count = 0 then theEnd
end; 
 
//поиск маршрута и перемещение шара
Function MoveBall(i,j: integer): boolean;
begin
  Result := false;
  var vorkug := |(-1,0),(0,-1),(1,0),(0,1)|; //(вниз вправо вверх влево)
  var Napravlenie := new integer[n,n]; //направление 0,1,2,3 = vokrug.Index
  var d := new integer[n,n]; //дистанция от точки назначения
  d.Fill((a,b) -> 99); // клетки с дистанцией = бесконечность (99)
  d[i, j] := 0; //клетка старта
  var q := new Queue<(integer,integer)>;
  q.Enqueue((i, j)); //в очередь клетку старта
  repeat //заполняем массив d и Napravlenie
   var (ii, jj) := q.Peek;
   q.Dequeue;
    For var w := 0 to 3 do //направление 0,1,2,3 → vokrug.Index
    begin       
      var (u, v) :=((ii+vorkug[w].Item1).Clamp(0,n-1), (jj+vorkug[w].Item2).Clamp(0,n-1) );
      if ((Pole[u, v] < 1) or (BallClickIndex = (u,v))) and (d[u, v] > d[ii, jj]+1) then
       begin
        d[u, v] := d[ii, jj] + 1; 
        Napravlenie[u, v] := w; 
        q.Enqueue( (u,v) );
       end;    
    end;
  until not q.Any;
  if d[BallClickIndex.Item1, BallClickIndex.Item2] = 99 then exit; //маршрут не существует
  Result := true;
//перемещаем шар
  PoleBlocked := true;
  var (u,v) := BallClickIndex; //индекс выбранный шар
  var BallColor := Pole[u,v] - 10; //цвет выбранного шара
  var tempColor := 0; // 0 - пустая клетка
  repeat     
   Pole[u, v] := tempColor; 
   DrawXY(u,v);
   var k := Napravlenie[u,v];
    u -= vorkug[k].Item1;
    v -= vorkug[k].Item2;
   tempColor := Pole[u, v];
   Pole[u, v] := BallColor;
   DrawXY(u,v);
   Sleep(100); //задержка при перемещении шара
  until d[u,v] = 0;
  PoleBlocked := false;
end;
 
//обработать клик на игровом поле
procedure mbPole(i,j:integer); 
 begin
    if (Pole[i,j] > 0) and (Pole[i,j] < 8) then 
     begin
// сделан выбор шара для перемещения       
       if not BallClick then 
         begin
          BallClick := true;
          BallClickIndex := (i,j);
          Pole[i,j] += 10;
          DrawXY(i,j);
         end
       else
//отменить старый выбор и выбрать другой шар для перемещения
         if BallClickIndex <> (i,j) then
           begin        
            Pole[i,j] += 10;
            DrawXY(i,j);
            Pole[BallClickIndex.Item1, BallClickIndex.Item2] -= 10;
            DrawXY(BallClickIndex.Item1, BallClickIndex.Item2);
            BallClickIndex := (i,j);
          end
     end
    else
//указана клетка назначения для выбранного шара, перемещаем шар      
     if BallClick and (BallClickIndex <> (i,j)) then
      if MoveBall(i,j) then begin BallClick := false; RandomBall end;
 end;
canadamoscow вне форума Ответить с цитированием
Старый 15.01.2022, 12:43   #4
canadamoscow
Пользователь
 
Аватар для canadamoscow
 
Регистрация: 16.05.2020
Сообщений: 57
По умолчанию

Игра ЛИНИИ на PascalABC.NET (часть 2)
Код:
 //Инициализация новой игры
Procedure Init; 
begin
 n := nn;  
 Pole := new integer[n,n];
 window.SetSize(n * w+8, n * w + h+4);
 Window.CenterOnScreen; 
 //Рисуем игровое поле
 FillRectangle(2,2,n * w+11, h - 9,Colors.black);
 FillRectangle(1,h-7,n * w+12, 2,Colors.Gray);
 SetPixel(0, h - 6, Colors.LightGray);
 SetPixel(1, h -7, Colors.LightGray);
 FillRectangle(0,h-5,n*w+13,1,Colors.Black);
 FillRectangle(2,h-2,n*w+11,1,Colors.Black);
 FillRectangle(2,h-2,1, n*w+1,Colors.Black);
 FillRectangle(5,h+1,n*w-5, n*w-5, RGB(192,192,192));
 var kletka := Procedure(a,b: integer) → //рисуем клетку поля
  begin 
   var (x, y) := (b*w+3, a*w+h-1);
   FillRectangle(x,y,w-2, 2, Colors.White);
   FillRectangle(x,y,2,w-2, Colors.White);
   FillRectangle(x+1,y+w-3,w-2, 2, Colors.Gray);
   FillRectangle(x+w-3,y+1,2, w-2, Colors.Gray);
   FillRectangle(x,y+w-1,w, 1, Colors.Black);
   FillRectangle(x+w-1,y,1, w, Colors.Black);
   SetPixel(x+1,y+w-3, Colors.DarkGray);
   SetPixel(x,y+w-2, Colors.DarkGray);
   SetPixel(x+w-2,y,Colors.DarkGray);
   SetPixel(x+w-3,y+1,Colors.DarkGray);
  end; 
  Font.Color := Colors.Yellow;
  Font.Size := w div 2;
  DrawText(10,0,Window.Width.Trunc,w,'Новая',alignment.LeftCenter);
  DrawText(Window.Width - 35, 10, 30, w div 2,'< ' +nn.ToString+' >',alignment.RightCenter);
 Font.Color := Colors.Gold;
 Font.Size := 20;
 PoleBlocked := false;
 BallClick := false; 
 Dollar := 0;
 DrawXY(20, Dollar);
 for var i := 0 to n-1 do
  for var j := 0 to n-1 do
   begin
    kletka(i, j); 
    Pole[i,j] := 0; 
   end; 
 RandomBall; //выводим на поле 3 Шара
end;
 
procedure MouseDown(x,y: real;mb:integer);
 begin
   if (y < h-10) then
     if x < Window.Width.Trunc div 3 then Init
      else if x > Window.Width-100 then begin
         nn += if x > Window.Width-10 -w div 2 then 1 else -1;
         nn := nn.Clamp(5,14); //Ограничения размера поля от 5x5 до 14х14
         FillRectangle(Window.Width-100, 10, 100, w-22, Colors.Black);
         Font.Color := Colors.Yellow; 
         Font.Size := w div 2;
         DrawText(Window.Width - 35, 10, 30, w div 2,'< ' +nn+' >',alignment.RightCenter);
      end;
   If PoleBlocked then exit; //происходит перемещение шара или конец игры с ожиданием нажатия НОВАЯ
   if (x.Trunc in [3..n*w+1]) and (y.Trunc in [h-1..h+n*w-2]) then //был клик по полю с шарами
   System.Threading.Thread.Create(()-> //создаем новый поток, чтобы процедура Sleep работала корректно
     mbPole(trunc(y - h+1) div w, trunc(x - 3) div w)).Start();
 end; 
 
begin 
 Window.Title := 'Линии';
 window.SetSize(n * w-7, n * w + h-11);
 Window.CenterOnScreen; 
 Window.IsFixedSize := True;
 Pen.Width := 3;
 Redraw(()->Init()); 
 OnMouseDown += MouseDown;
end.
canadamoscow вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
написать код программы, вычисляющей длину линии вертикального разреза фигуры KASATKA_AA Паскаль, Turbo Pascal, PascalABC.NET 2 17.09.2018 11:49
Помогите написать программу, игра крестики-нолики, в делфи AgaVik Общие вопросы Delphi 6 12.06.2015 16:45
Рисую линии поверх картинки при перемещении картинки линии исчезают( sherlocked Общие вопросы Delphi 4 16.01.2015 19:37
Есть макет photoshop psd, на нем линии(разметка). Как узнать, сколько пиксилей до сторон(от указанной линии)? Gefo HTML и CSS 1 17.01.2013 07:54
Сделать из линии, толщиной в несколько пикселей, линии, толщиной 1 пиксель. ImmortalAlexSan Общие вопросы Delphi 12 25.10.2012 19:05