Игра Lines (Линии/Квадраты). Команда sleep "перекрывает" промежуточный вывод изображений

@canadamoscow · Регистрация: 23.03.2020

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

Шар при выполнении хода должен перемещаться по пути из клетки в клетку делая задержку для отображения (так задумано), но по факту - задержка продожительностью равная сумме всех задержек в каждой клетке и сразу вывод конечного результата. Псевдоанимация не реализуется.
(строки 65, 231, 237)

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

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
uses GraphWPF;
//Lines (Squares)
const 
w = 45; //высота и ширина ячейки, рекомендовано: 16 или 24 или 32 
h = 55; //отступ над полем
n = 9; //поле 9 на 9
 
var
  Pole: array[,] of integer; //пусто, красный,желтый, зеленый, голубой, синий.фиолетовый. коричневый  
  BallClick: boolean; //выбран шар для хода
  BallClickIndex: (integer, integer); //индекс выбранного шара
  Status: integer; //0 - игра  2 - конец игры
  Dollar: integer; //очки, кол-во шаров  
  Ball3Next: list<integer>; //три следующих случайных шара
  DeleteBall: Function:boolean;
  //nextBalls: boolean; //показать места показа след.хода
  //t: timer; //таймер
  //time: 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
  var (x, y) := (j*w+3, i*w+h-1);
  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
  status := 2;
  Sleep(3000);
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(500);  //------------------- не работает как ожидается
 
//удаление
 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;
                  //------------------здесь сделать вывод очков
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
     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
     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
     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;
//удаление
 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;
                        //------------------вывод очков
end;
 
//Генерация трех случайных шаров в случайных позициях
procedure RandomBallGen;
begin
 Ball3Next.Clear;
 Loop 3 do Ball3Next.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] := Ball3Next[c];
  Zero.RemoveAt(RndIndex); //исключаем для рандома повторный выбор индекса
 end;  
end;
 
//выводим три новых шара
Procedure RandomBall;
begin
 if DeleteBall then exit;
 var miniball := Pole.Indices(t-> t<0);
 if not miniball.any then begin theEnd; exit; end;
 miniball.ForEach(t-> //увеличить mini
   begin 
     Ball3Next.RemoveAt(Ball3Next.FindIndex(g-> g = Pole[t[0],t[1]]));
     Pole[t[0],t[1]] := - Pole[t[0],t[1]]; 
     DrawXY(t[0],t[1])
   end);
 While Ball3Next.Any do
  begin 
   Println(Ball3Next);
   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] := - Ball3Next[0];
   DrawXY(Zero[r].Item1, Zero[r].Item2);
   Ball3Next.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; 
 
//поиск маршрута и перемещение шара
function MoveBall(i,j: integer): boolean;
begin
  Result := false;
  var d := new integer[n,n]; //дистанция от точки назначения
  var Napravlenie := new integer[n,n]; //направление 0,1,2,3 = vokrug.Index
  var vorkug := |(-1,0),(0,-1),(1,0),(0,1)|; //(вниз вправо вверх влево)
  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 temp := 0;
  repeat 
   Pole[u, v] := temp;
   DrawXY(u,v);
   var k := Napravlenie[u,v];
    u -= vorkug[k].Item1;
    v -= vorkug[k].Item2;
   temp := Pole[u, v];
   Pole[u, v] := BallColor;
   DrawXY(u,v);
   
  
   sleep(100); //задержка при передвижении шара на новое место   ------ но этого не происходит
  
  
  until d[u,v] = 0;
 
 
 sleep(500); //шар на новом месте, задержка перед продолжением   ----- но этого не происходит
 
 
end;
 
//обработать клик на игровом поле
procedure mbPole(i,j:integer); 
 begin
    if Status = 2 then exit;
    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;
        //удаляем собранную линию или выводим 3 новых шара
        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.White;
 Font.Size := 20;
 DrawText(2,2,9*w+11, h - 9,'Линии(новая)        Квадраты(новая)');
 for var i := 0 to 8 do
  for var j := 0 to 8 do
   begin
    kletka(i, j);
    Pole[i,j] := 0;
   end; 
 Status := 0;
 Dollar := 0;
 BallClick := false;
 RandomBallGen;
 RandomBall;
end;
 
procedure MouseDown(x,y: real;mb:integer);
 begin  
   if y < h then if x < 209 then Init(1) else Init(2);
   if (x.Trunc in [3..n*w+1]) and (y.Trunc in [h-1..h+n*w-2]) then 
   mbPole(trunc(y - h+1) div w, trunc(x - 3) div w);
 end; 
 
begin
 Window.Title := 'Линии';
 window.SetSize(9 * w-7, 9 * w + h-11);
 Window.CenterOnScreen; 
 Window.IsFixedSize := True;
 //t := new Timer(1000,OnTimer);
 Pen.Width := 3;
 Ball3Next := new List<integer>;
 Pole := new integer[n, n];
 Init(1); //1- линии  2-квадраты
 OnMouseDown += MouseDown;
end.

@ProMix0 · 22.09.2020, 07:29

Читаю ваш код, пока могу посоветовать использовать перечисления (enums)

Добавлено через 3 минуты
Зачем вы определяете процедуру рисования клетки прямо в коде?

Добавлено через 7 минут
Задержка есть. Она отвратительно неудобная, но она есть. Если не верите - увеличьте время задержки в десять раз

@canadamoscow · 22.09.2020, 11:32 **[ТС]**

Упрощаю вопрос следующим кодом:

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
uses GraphWPF;
const w = 45;
 
procedure MoveBall(u,v: integer);
begin
  var c := clRandom;
  loop 4 do begin
   var (x, y) := (v*w+3, u*w+54);
   FillRectangle(x+2,y+2,w-5, w-5, RGB(192,192,192));
   u := (u+1).ClampTop(8);
   (x, y) := (v*w+3, u*w+54);
   FillCircle(x+w div 2, y+w div 2, 18, c);
   
   sleep(300);
   
   Print(u);
   end;
 end;
 
Procedure Init; 
begin  
 MoveBall(2,2);
 MoveBall(0,5);
end;
 
procedure MouseDown(x,y: real;mb:integer);
 begin  
   if (x.Trunc in [3..9*w+1]) and (y.Trunc in [54..55+9*w-2]) then 
   MoveBall(trunc(y - 54) div w, trunc(x - 3) div w);
 end; 
 
begin
 window.SetSize(9 * w-7, 9 * w + 44);
 Window.CenterOnScreen; 
 Init; 
 OnMouseDown += MouseDown;
end.

Обнаружил такую странность.
При запуске программы sleep в процедуре MoveBall работает как и должно, но при дальнем вызове MoveBall из MouseDown, sleep начинает тупить, вернее не он а вывод изображения без пауз как при старте.

@Sun Serega · 22.09.2020, 11:59

Вы думаете что каждый вызов MouseDown будет в новом потоке? Почитайте на досуге про обработку сообщений винды окнами.

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

В случае WF и WPF - поток обработки сообщений ещё может обрабатывать сообщение, просящее побыстрее выполнить пользовательский код из текущей программы. В WPF такой код суют в Dispatcher.Invoke, а в GraphWPF раньше была процедура Invoke, но сейчас её переименовали в Redraw.

А переименовали её потому, что код выполняющийся в потоке обработки сообщений не даёт выполнятся всему остальному коду, в том числе перерисовке окна. Таким образом основное применение Redraw - изменять несколько вещей в окне одновременно.

И ваш код в обработчике OnMouseDown работает будто он весь находится внутри вызова Redraw. Если вам надо начинать новое действие, параллельное всему остальному - создавайте новый поток.

Добавлено через 5 минут
Да и на будущее - кидайте минимальный код сразу. Я бы ответил ещё когда вы первый раз запостили, но разбираться в том, что вы имеете в виду было лень, поэтому я тупо оставил вкладку с этой темой открытой.

Ну и есть большая вероятность что вы бы сами догадались, если бы нашли прям самый минимальный код, вроде такого:

Pascal
1
2
3
4
5
6
7
8
9
10
uses WPFObjects;
 
begin
  var c := new CircleWPF(20,20,10, Colors.Red);
  OnMouseDown += (x,y,mb)->
  begin
    Sleep(500);
    c.MoveOn(5,0);
  end;
end.

@canadamoscow · 22.09.2020, 13:45 **[ТС]**

Сообщение от Sun Serega

Если вам надо начинать новое действие, параллельное всему остальному - создавайте новый поток.

Это как?

Pascal
1
2
3
4
5
6
7
8
9
uses WPFObjects;
begin
  var c := new CircleWPF(20,20,10, Colors.Red);
  OnMouseDown += (x,y,mb)->
   loop 3 do begin 
    Sleep(500);
    c.MoveOn(50,0);
   end;
end.

Как тогда организовать промежуточные паузы в этом коде?

Добавлено через 28 минут
Я так понимаю это имелось в виду?

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
uses WPFObjects, Timers;
var 
  c: BoundedObjectWPF;
  t: timer;
  tt: integer;
  
procedure Anim;
begin
   c.MoveOn(50,0);
   inc(tt);
   if tt = 3 then t.stop;
end;
 
begin
  c := new CircleWPF(20,20,10, Colors.Red);
  t := new timer(500, anim);  
  OnMouseDown += (x,y,mb)->   begin 
    tt := 0;    
    t.Start;
   end
end.

@Sun Serega · 22.09.2020, 14:45

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

Я так понимаю это имелось в виду?

Ну, в принципе так тоже можно. Может даже так лучше, если таймеры проводят какую то свою оптимизацию.

Но под потоками я имел в виду System.Threading.Thread, то есть потоки выполнения. Один поток выполнения может выполнять только 1 кусок кода одновременно.
Поток создаётся конструктором и начинает выполняться когда вы вызовете метод .Start .
При чём как только .Start вызван - новый поток оказывается полностью независимым от потока, вызвавшего .Start.

То есть если вы запустите новый поток в обработчике OnMouseDown - поток окна сможет дальше и обрабатывать новые сообщения (как следующие клики мышкой), и перерисовываться.

Pascal
1
2
3
4
5
  OnMouseDown += (x,y,mb)->
  System.Threading.Thread.Create(()->
  begin
    //ToDo ваш код, хоть со Sleep, хоть с чем
  end).Start();

А в программе с таймерами - надо, хотя бы, избавится от глобального состояния:

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
uses WPFObjects, Timers;
 
begin
  OnMouseDown += (x, y, mb)->
  begin
    var c := new CircleWPF(20, 20, 10, Colors.Red);
    var tt := 0;
    var t: Timer;
    t := new timer(50, ()->
    begin
      if tt < 39 then c.MoveOn(5, 0);
      tt += 1;
      if tt = 40 then
      begin
        t.Stop;
        c.Destroy;
      end;
    end);
    t.Start;
  end;
end.

@canadamoscow · 23.09.2020, 18:22 **[ТС]**

Lines на PascalABC.NEt (GraphWPF)

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

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
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; 
 
//поиск маршрута и перемещение шара
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.

@Kirill11 · 14.06.2021, 17:33

Помогите пожалуйста, сделать код чуть меньше, не на 300 строк. Прошу помощи

@ProMix0 · 15.06.2021, 06:34

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

сделать код чуть меньше, не на 300 строк

А в чём проблема?

Добавлено через 3 минуты
Если вас интересует именно уменьшение количества строк, то можете две строки соединять в одну:

Pascal
1
2
3
4
   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);

->

Pascal
1
2
   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);

Но в таком случае не ясно, зачем оно вам

Новые блоги и статьи Все статьи Все блоги /
Вывод данных через динамический список в справочнике Maks 01.04.2026 Реализация из решения ниже выполнена на примере нетипового справочника "Спецтехника" разработанного в конфигурации КА2. Задача: вывести данные из ТЧ нетипового документа. . .	Функция заполнения текстового поля в реквизите формы документа Maks 01.04.2026 Алгоритм из решения ниже реализован на нетиповом документе "ВыдачаОборудованияНаСпецтехнику" разработанного в конфигурации КА2, в дополнении к предыдущему решению. На форме документа создается. . .	К слову об оптимизации kumehtar 01.04.2026 Вспоминаю начало 2000-х, университет, когда я писал на Delphi. Тогда среди программистов на форумах активно обсуждали аккуратную работу с памятью: нужно было следить за переменными, вовремя. . .	Идея фильтра интернета (сервер = слой+фильтр). Hrethgir 31.03.2026 Суть идеи заключается в том, чтобы запустить свой сервер, о чём я если честно мечтал давно и давно приобрёл книгу как это сделать. Но не было причин его запускать. Очумелые учёные напечатали на. . .
Модель здравосоХранения 6. ESG-повестка и устойчивое развитие; углублённый анализ кадрового бренда anaschu 31.03.2026 В прикрепленном документе раздумья о том, как можно поменять модель в будущем	10 пpимет, которые всегда сбываются Maks 31.03.2026 1. Чтобы, наконец, пришла маршрутка, надо закурить. Если сигарета последняя, маршрутка придет еще до второй затяжки даже вопреки расписанию. 2. Нaдоели зима и снег? Не надо переезжать. Достаточно. . .	Перемещение выделенных строк ТЧ из одного документа в другой Maks 31.03.2026 Реализация из решения ниже выполнена на примере нетипового документа "ВыдачаОборудованияНаСпецтехнику" с единственной табличной частью "ОборудованиеИКомплектующие" разработанного в конфигурации КА2. . . .	Functional First Web Framework Suave DevAlt 30.03.2026 Sauve. IO Апнулись до NET10. Из зависимостей один пакет, работает одинаково хорошо как в режиме проекта так и в интерактивном режиме. из сложностей - чисто функциональный подход. Решил. . .

@ProMix0 80 / 33 / 10 Регистрация: 14.06.2019 Сообщений: 516
	22.09.2020, 07:29
	Читаю ваш код, пока могу посоветовать использовать перечисления (enums) Добавлено через 3 минуты Зачем вы определяете процедуру рисования клетки прямо в коде? Добавлено через 7 минут Задержка есть. Она отвратительно неудобная, но она есть. Если не верите - увеличьте время задержки в десять раз 0

@Kirill11 0 / 0 / 0 Регистрация: 20.11.2020 Сообщений: 124
	14.06.2021, 17:33
	Помогите пожалуйста, сделать код чуть меньше, не на 300 строк. Прошу помощи 0

Игра Lines (Линии/Квадраты). Команда sleep "перекрывает" промежуточный вывод изображений

Решение