Форум программистов
 
О проблемах, например, с регистрацией пишите сюда - alarforum@yandex.ru, проверяйте папку спам! Обязательно пройдите активизацию e-mail, а тут можно восстановить пароль.

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

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

Здесь нужно купить рекламу за 20 тыс руб в месяц! ) пишите сюда - alarforum@yandex.ru
Без учёта ботов - 20000 человек в день, 350000 в месяц.

Ответ
 
Опции темы
Старый 23.09.2020, 18:50   #1
canadamoscow
Пользователь
 
Аватар для canadamoscow
 
Регистрация: 16.05.2020
Сообщений: 29
По умолчанию Lines (Линии/Квадраты) на PascalABC.NET (модуль GraphWPF)

Lines (Линии/Квадраты) на PascalABC.NET (модуль GraphWPF)
Изображения
Тип файла: png Линии.png (20.1 Кб, 18 просмотров)
Вложения
Тип файла: zip Lines.zip (36.2 Кб, 0 просмотров)
canadamoscow вне форума Ответить с цитированием
Старый 23.09.2020, 18:54   #2
canadamoscow
Пользователь
 
Аватар для canadamoscow
 
Регистрация: 16.05.2020
Сообщений: 29
По умолчанию

Lines (часть 1)
Код:
uses GraphWPF;

const 
w = 45; //ширина ячейки
h = 55; //отступ над полем
n = 9; //поле 9 на 9

var
  Pole: array[,] of integer; //пусто, красный,желтый, зеленый, голубой, синий.фиолетовый. коричневый  
  BallClick, //выбран шар для хода 
  EndGame: boolean; //0 - игра  9 - конец игры
  BallClickIndex: (integer, integer); //индекс выбранного шара
  Dollar: integer; //очки, кол-во шаров  
  Ball3NextColor: list<integer>; //три следующих случайных шара
  DeleteBall: Function:boolean; //указатель либо на Линии, либо на Квадраты

//вывод изображений по индексу
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
 var (x, y) := (j*w+3, i*w+h-1);  
 if i > 9 then begin
   if i = 20 then 
    begin //вывод кол-ва очков
     FillRectangle(165,24,80,23,Colors.Black);
     DrawText(165,25,80,25,'0'*(5 - j.toString.Length)+j.ToString);
    end
   else FillCircle(180 + (i-10) * 25, 14 , 9, ColorN[j]); // один из 3х минишаров над полем
   exit;
 end;
 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, 18, ColorN[Pole[i,j]]);
  11..17: //выделение шара для хода
    DrawCircle(x+w div 2, y+w div 2, 17, Colors.White);
  -7..-1: //вывод на поле одного из 3х минишаров
    begin
     FillRectangle(x+2,y+2,w-5, w-5, RGB(192,192,192));
     FillCircle(x+w div 2, y+w div 2, 6, ColorN[abs(Pole[i,j])]);
    end
 end     
end;

//все клетки заняты, конец игры
Procedure TheEnd;
begin
  endgame := true;  
  FillRectangle(140, 5 , 130, 20, Colors.Black);
  Font.Color := Colors.Yellow;
  DrawText(144, 3 , 128, 20, 'Повторим?');
end;

//удаление квадратов из 4х шаров
Function DeleteBallSquares: boolean; 
begin 
 Result := false;
 var metka := new boolean[n,n]; //помечаем к удалению
//метка шаров к удалению
 for var i:=0 to 7 do
  for var j:=0 to 7 do
   if (Pole[i,j]=Pole[i+1,j]) and (Pole[i,j]=Pole[i,j+1]) and (Pole[i,j]=Pole[i+1,j+1]) 
    and (Pole[i,j]>0) then
    begin
     Result := true; 
     metka[i,j]:=true;
     metka[i+1,j]:=true;
     metka[i,j+1]:=true;
     metka[i+1,j+1]:=true;
    end;
 If Result then sleep(200); 
//удаление
 for var i:=0 to 8 do
  for var j:=0 to 8 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;

//удаление линий из 5 шаров
Function DeleteBallLine: boolean; 
begin
 Result := false;
 var metka := new boolean[n,n]; //помечаем к удалению
//метка шаров к удалению по горизонталям
 for var i:=0 to 4 do
  for var j:=0 to 8 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 8 do
  for var j:=0 to 4 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 4 do
  for var j:=0 to 4 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:=8 downto 4 do
  for var j:=0 to 4 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 8 do
  for var j:=0 to 8 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 RandomBallGen;
begin
 Ball3NextColor.Clear; //чистый список для 3х шаров
 Loop 3 do Ball3NextColor.Add( - Random(1,7)); // наполнили список
 var Zero := Pole.Indices(t-> t=0).toList; //список индексов пустых клеток
 for var c := 0 to (Zero.Count-1).ClampTop(2) do 
 begin   
  var RndIndex := Random(0, Zero.Count-1); //рандомно выбираем индекс для минишара
  Pole[Zero[RndIndex].Item1, Zero[RndIndex].Item2] := Ball3NextColor[c];
  DrawXY(10+c, -Ball3NextColor[c]); //вывод над полем предросмотра 3х цветов
  Zero.RemoveAt(RndIndex); //исключаем для рандома повторный выбор индекса
 end;  
end;

//выводим три новых шара
Procedure RandomBall;
begin
 if DeleteBall then exit; //после удаления собранного комплекта новые шары не выводим
 var miniball := Pole.Indices(t-> t<0); //сканируем поле на наличие минишаров
 miniball.ForEach(t-> //увеличить минишары на поле
   begin 
     Ball3NextColor.RemoveAt(Ball3NextColor.FindIndex(g-> g = Pole[t[0],t[1]]));
     Pole[t[0],t[1]] := - Pole[t[0],t[1]]; 
     DrawXY(t[0],t[1])
   end);
 //если было увеличино меньше 3х минишаров генерируем и выводим недостающие
 While Ball3NextColor.Any do 
  begin 
   var Zero := Pole.Indices(t-> t=0).toList;; //сканируем поле на наличие пустых клеток
   if Zero.Count = 0 then begin theEnd; exit end; //поле заполнено - конец игры
   var r := Random(0, Zero.Count-1); //из имеющихся пустых клеток выбираем рандомный
   Pole[Zero[r].Item1, Zero[r].Item2] := - Ball3NextColor[0]; 
   DrawXY(Zero[r].Item1, Zero[r].Item2); //и выводим шар с цветом заранее запланированном
   Ball3NextColor.RemoveAt(0); //удаляем выставленный цвет из списка "цвета для трех шаров"
  end; 
 DeleteBall;    //проверка на возможность удаления собранной линии/квадрата
 if Pole.Indices(t-> t<1).Count = 0 then begin theEnd; exit; end; //все клетки заняты, конец
 RandomBallGen; //генерация и 
 Pole.Indices(t-> t<0).ForEach(t-> DrawXY(t[0],t[1])); //вывод трех новых минишаров
end;
canadamoscow вне форума Ответить с цитированием
Старый 23.09.2020, 18:54   #3
canadamoscow
Пользователь
 
Аватар для canadamoscow
 
Регистрация: 16.05.2020
Сообщений: 29
По умолчанию

Lines (часть 2)
Код:
//поиск маршрута и перемещение шара
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;
//перемещаем шар
  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;
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;
 
 //Инициализация новой игры
Procedure Init(level: integer); 
begin  
 if level = 1 then begin Window.Title := 'Линии'; DeleteBall:= DeleteBallLine end
 else begin Window.Title := 'Квадраты'; DeleteBall:= DeleteBallSquares end;
 //Рисуем игровое поле
 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.Gold;
 Font.Size := 20;
 DrawText(8,2,9*w+11, h - 9,'ЛИНИИ'+' '*30+'КВАДРАТЫ');
 endGame := false;
 BallClick := false; 
 Dollar := 0;
 DrawXY(20, Dollar);
 for var i := 0 to 8 do
  for var j := 0 to 8 do
   begin
    kletka(i, j); 
    Pole[i,j] := 0; 
   end; 
 RandomBallGen; //генерим 3 минишара
 RandomBall; //выводим на поле 3 Шара
end;

procedure MouseDown(x,y: real;mb:integer);
 begin
   if y < h-10 then if x < 135 then Init(1) else if x > 270 then Init(2);
   If endGame 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(9 * w-7, 9 * w + h-11);
 Window.CenterOnScreen; 
 Window.IsFixedSize := True;
 Pen.Width := 3;
 Ball3NextColor := new List<integer>;
 Pole := new integer[n, n];
 Redraw(()->Init(1)); //1- линии  2-квадраты 
 OnMouseDown += MouseDown;
end.
canadamoscow вне форума Ответить с цитированием
Старый 29.09.2020, 19:28   #4
canadamoscow
Пользователь
 
Аватар для canadamoscow
 
Регистрация: 16.05.2020
Сообщений: 29
По умолчанию

Подправил чуток недочеты
Вложения
Тип файла: zip Lines.zip (35.8 Кб, 0 просмотров)

Последний раз редактировалось canadamoscow; 29.09.2020 в 19:31.
canadamoscow вне форума Ответить с цитированием
Ответ

Здесь нужно купить рекламу за 20 тыс руб в месяц! ) пишите сюда - alarforum@yandex.ru
Без учёта ботов - 20000 человек в день, 350000 в месяц.

Опции темы


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Сапер на PascalABC.net (модуль GraphWPF, Timers) canadamoscow Паскаль, Turbo Pascal, PascalABC.NET 10 23.09.2020 08:55
PascalABC.NET oK1110 Фриланс 4 13.09.2020 07:44
PascalABC.NET oK1110 Паскаль, Turbo Pascal, PascalABC.NET 2 13.09.2020 01:23
Бот собирает линии, или AI в Lines xXxDiKxXx Gamedev - cоздание игр: Unity, OpenGL, DirectX 0 29.05.2010 22:23


Проекты отопления, пеллетные котлы, бойлеры, радиаторы
интернет магазин respective.ru
Пеллетный котёл Emtas
котлы EMTAS
Здесь нужно купить рекламу за 7 тыс руб в месяц! )
пишите сюда - alarforum@yandex.ru
ИКС 840