MathgeomGLS

1
unit fConways;
2

3
interface
4

5
uses
6
  Winapi.Windows,
7
  Winapi.Messages,
8
  System.Types,
9
  System.SysUtils,
10
  System.Variants,
11
  System.Classes,
12
  Vcl.Graphics,
13
  Vcl.Forms,
14
  Vcl.Dialogs,
15
  Vcl.Menus,
16
  Vcl.ComCtrls,
17
  Vcl.ToolWin,
18
  Vcl.ExtDlgs,
19
  Vcl.ExtCtrls,
20
  Vcl.StdCtrls,
21
  Vcl.Buttons,
22
  Vcl.Samples.Spin,
23
  Vcl.Controls,
24

25
  
26
  GLS.VectorTypes,
27
  GLS.Graphics,
28
  GLS.Cadencer,
29
  GLS.Texture,
30
  GLS.SceneViewer,
31
  GLS.Scene,
32
  GLS.Objects,
33
  GLS.AsyncTimer,
34
  GLS.Utils,
35
  GLS.HUDObjects,
36
  GLS.Coordinates,
37
  GLS.BaseClasses;
38

39
type
40
  TForm1 = class(TForm)
41
    GLScene: TGLScene;
42
    vp: TGLSceneViewer;
43
    cam: TGLCamera;
44
    hudMap: TGLHUDSprite;
45
    AsyncTimer: TGLAsyncTimer;
46
    OpenDlg: TOpenPictureDialog;
47
    SaveDlg: TSavePictureDialog;
48
    Panel2: TPanel;
49
    Panel5: TPanel;
50
    Label4: TLabel;
51
    Edit2: TEdit;
52
    UpDown2: TUpDown;
53
    Edit3: TEdit;
54
    UpDown3: TUpDown;
55
    Label5: TLabel;
56
    Panel7: TPanel;
57
    Panel8: TPanel;
58
    Label1: TLabel;
59
    Edit4: TEdit;
60
    UpDown4: TUpDown;
61
    Button3: TButton;
62
    but_run: TSpeedButton;
63
    cb: TCheckBox;
64
    MainMenu: TMainMenu;
65
    N1: TMenuItem;
66
    Open1: TMenuItem;
67
    Save1: TMenuItem;
68
    N2: TMenuItem;
69
    Exit1: TMenuItem;
70
    Help1: TMenuItem;
71
    About1: TMenuItem;
72
    New1: TMenuItem;
73
    procedure FormCreate(Sender: TObject);
74
    procedure vpMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
75
    procedure AsyncTimerTimer(Sender: TObject);
76
    procedure vpMouseDown(Sender: TObject; Button: TMouseButton;
77
      Shift: TShiftState; X, Y: Integer);
78
    procedure Button3Click(Sender: TObject);
79
    procedure UpDown2Click(Sender: TObject; Button: TUDBtnType);
80
    procedure UpDown3Click(Sender: TObject; Button: TUDBtnType);
81
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
82
    procedure UpDown4Click(Sender: TObject; Button: TUDBtnType);
83
    procedure FormResize(Sender: TObject);
84
    procedure About1Click(Sender: TObject);
85
    procedure Open1Click(Sender: TObject);
86
    procedure Save1Click(Sender: TObject);
87
  public
88
    procedure Init(a_Width, a_Height: Integer);
89
    procedure SetPixel(a_Xpos, a_Ypos: Integer; a_Get: boolean);
90
    procedure resizeMap;
91
  end;
92

93
var
94
  Form1: TForm1;
95
  mapsz: TPoint;
96
  br: boolean;
97
  ma: single;
98
  buf: array [0 .. 1] of TGLImage;
99
  bufi: Integer = 0;
100

101
implementation
102

103
{$R *.dfm}
104

105
procedure TForm1.FormCreate;
106
begin
107
  // create default map 32x32
108
  Init(32, 32);
109

110
  Opendlg.InitialDir := extractfilepath(paramStr(0)) + 'maps';
111
  Savedlg.InitialDir := opendlg.InitialDir;
112
end;
113

114
function RGBA(r, g, b: Byte): TGLPixel32;
115
begin
116
  result.r := r;
117
  result.g := g;
118
  result.b := b;
119
  result.a := 255;
120
end;
121

122
procedure TForm1.Init(a_Width, a_Height: Integer);
123
var
124
  a1, a2: Integer;
125
  bmp: TBitmap;
126

127
begin
128
  bufi := 0;
129
  mapsz := point(a_Width, a_Height);
130

131
  // prepare buf's
132
  if assigned(buf[0]) then
133
    buf[0].Free;
134
  buf[0] := TGLImage.Create;
135
  if assigned(buf[1]) then
136
    buf[1].Free;
137
  buf[1] := TGLImage.Create;
138

139
  bmp := TBitmap.Create;
140
  bmp.Width := a_Width;
141
  bmp.Height := a_Height;
142

143
  // fill buf's
144
  for a1 := 0 to a_Width - 1 do
145
    for a2 := 0 to a_Height - 1 do
146
      if (a1 xor a2) and 1 > 0 then
147
        bmp.Canvas.Pixels[a1, a2] := $FFFFFF
148
      else
149
        bmp.Canvas.Pixels[a1, a2] := $E0E0E0;
150
  buf[0].Assign(bmp);
151
  buf[1].Assign(bmp);
152

153
  bmp.Free;
154

155
  hudMap.Width := a_Width;
156
  hudMap.Height := a_Height;
157
  hudMap.Material.Texture.Image.Assign(buf[0]);
158

159
  resizeMap;
160
end;
161

162

163
procedure TForm1.SetPixel(a_Xpos, a_Ypos: Integer; a_Get: boolean);
164
var
165
  sx, sy, p, a: Integer;
166

167
begin
168
  // convert coords
169
  sx := round((a_Xpos - hudMap.Position.X + hudMap.Width / 2 - ma / 2) / ma);
170
  sy := round((hudMap.Height / 2 + hudMap.Position.Y - a_Ypos - ma / 2) / ma);
171

172
  // correct coords
173
  if sx < 0 then
174
    sx := 0;
175
  if sx > mapsz.X - 1 then
176
    sx := mapsz.X - 1;
177
  if sy < 0 then
178
    sy := 0;
179
  if sy > mapsz.Y - 1 then
180
    sy := mapsz.Y - 1;
181

182
  p := sy * mapsz.X + sx;
183

184
  // get point state or draw
185
  if a_Get then
186
    br := buf[bufi].Data[p].r > 0;
187
  if br then
188
    buf[bufi].Data[p] := RGBA(0, 0, 0)
189
  else
190
  begin
191
    a := 255 - 31 * ((sx xor sy) and 1);
192
    buf[bufi].Data[p] := RGBA(a, a, a);
193
  end;
194

195
  hudMap.Material.Texture.Image.Assign(buf[bufi]);
196
end;
197

198
procedure TForm1.resizeMap;
199
begin
200
  // find min size
201
  if vp.Width > vp.Height then
202
    ma := vp.Height
203
  else
204
    ma := vp.Width;
205

206
  // proportion
207
  if mapsz.X > mapsz.Y then
208
    ma := ma / mapsz.X
209
  else
210
    ma := ma / mapsz.Y;
211

212
  hudMap.Width := ma * mapsz.X;
213
  hudMap.Height := ma * mapsz.Y;
214
end;
215

216
procedure TForm1.About1Click(Sender: TObject);
217
begin
218
  MessageDlg('ConwaysLife. @ GLScene Team', mtInformation,
219
      [mbOk], 0, mbOk);
220
end;
221

222
procedure TForm1.AsyncTimerTimer(Sender: TObject);
223
var
224
  a1, a2, a3, a4, p: Integer;
225
  c: boolean;
226

227
  function GetN(X, Y: Integer): Integer;
228

229
    function Get(X, Y: Integer): boolean;
230
    begin
231

232
      // border check
233
      if not cb.Checked then
234
      begin
235
        if X < 0 then
236
          X := mapsz.X - 1;
237
        if X > mapsz.X - 1 then
238
          X := 0;
239
        if Y < 0 then
240
          Y := mapsz.Y - 1;
241
        if Y > mapsz.Y - 1 then
242
          Y := 0;
243
        result := buf[bufi].Data[Y * mapsz.X + X].r = 0;
244
      end
245
      else if (X >= 0) and (X < mapsz.X) and (Y >= 0) and (Y < mapsz.Y) then
246
        result := buf[bufi].Data[Y * mapsz.X + X].r = 0
247
      else
248
        result := false;
249
    end;
250

251
  begin
252
    result := 0;
253

254
    if Get(X - 1, Y - 1) then
255
      inc(result);
256
    if Get(X - 1, Y) then
257
      inc(result);
258
    if Get(X - 1, Y + 1) then
259
      inc(result);
260
    if Get(X, Y - 1) then
261
      inc(result);
262
    if Get(X, Y + 1) then
263
      inc(result);
264
    if Get(X + 1, Y - 1) then
265
      inc(result);
266
    if Get(X + 1, Y) then
267
      inc(result);
268
    if Get(X + 1, Y + 1) then
269
      inc(result);
270
  end;
271

272
begin
273
  if not but_run.Down then
274
    exit;
275

276
  // main loop
277
  for a1 := 0 to mapsz.X - 1 do
278
    for a2 := 0 to mapsz.Y - 1 do
279
    begin
280

281
      a3 := GetN(a1, a2);
282
      a4 := 255 - 31 * ((a1 xor a2) and 1);
283

284
      p := a2 * mapsz.X + a1;
285

286
      // main algorithm
287
      if buf[bufi].Data[p].r = 0 then
288
        c := (a3 = 2) or (a3 = 3)
289
      else
290
        c := a3 = 3;
291

292
      if c then
293
        buf[1 - bufi].Data[p] := RGBA(0, 0, 0)
294
      else
295
        buf[1 - bufi].Data[p] := RGBA(a4, a4, a4);
296

297
    end;
298

299
  bufi := 1 - bufi;
300
  hudMap.Material.Texture.Image.Assign(buf[bufi]);
301
end;
302

303
// LoadMap
304

305
procedure TForm1.Open1Click(Sender: TObject);
306
var
307
  a1, a2, p: Integer;
308
  bmp: TBitmap;
309
begin
310
  if not opendlg.Execute then
311
    exit;
312

313
  bufi := 0;
314
  bmp := TBitmap.Create;
315
  bmp.LoadFromFile(opendlg.FileName);
316

317
  mapsz := point(bmp.Width, bmp.Height);
318
  buf[0].Assign(bmp);
319
  buf[1].Assign(bmp);
320

321
  bmp.Free;
322
  hudMap.Width := mapsz.X;
323
  hudMap.Height := mapsz.Y;
324

325
  for a1 := 0 to mapsz.X - 1 do
326
    for a2 := 0 to mapsz.Y - 1 do
327
    begin
328
      p := a2 * mapsz.X + a1;
329
      with buf[bufi] do
330
        if (Data[p].r + Data[p].g + Data[p].b) < 192 then
331
          Data[p] := RGBA(0, 0, 0)
332
        else if (a1 xor a2) and 1 = 1 then
333
          Data[p] := RGBA(224, 224, 224)
334
        else
335
          Data[p] := RGBA(255, 255, 255);
336
    end;
337

338
  HudMap.Material.Texture.Image.Assign(buf[bufi]);
339

340
  ResizeMap;
341
end;
342

343

344
// Save Map
345

346
procedure TForm1.Save1Click(Sender: TObject);
347
var
348
  bmp: TBitmap;
349
begin
350
  if not savedlg.Execute then
351
    exit;
352

353
  bmp := TBitmap.Create;
354
  bmp.PixelFormat := pf1bit;
355
  buf[bufi].AssignToBitmap(bmp);
356
  bmp.SaveToFile(savedlg.FileName);
357
  bmp.Free;
358
end;
359

360

361

362
// MouseDown to SetPixel
363
procedure TForm1.vpMouseDown(Sender: TObject; Button: TMouseButton;
364
  Shift: TShiftState; X, Y: Integer);
365
begin
366
  if Button = TMouseButton.mbLeft then
367
    SetPixel(X, Y, true);
368
end;
369

370
// MouseMove to SetPixel
371
procedure TForm1.vpMouseMove(Sender: TObject; Shift: TShiftState;
372
  X, Y: Integer);
373
begin
374
  if Shift = [ssleft] then
375
    SetPixel(X, Y, false);
376
end;
377

378
// newWidth
379
procedure TForm1.UpDown2Click(Sender: TObject; Button: TUDBtnType);
380
begin
381
  Edit2.Text := inttostr(32 shl UpDown2.Position);
382
end;
383

384
// newImage
385
procedure TForm1.Button3Click(Sender: TObject);
386
begin
387
  Init(StrToInt(Edit2.Text), StrToInt(Edit3.Text));
388
end;
389

390

391
// newHeight
392
procedure TForm1.UpDown3Click(Sender: TObject; Button: TUDBtnType);
393
begin
394
  Edit3.Text := IntToStr(32 shl UpDown3.Position);
395
end;
396

397
// newInterval
398
procedure TForm1.UpDown4Click(Sender: TObject; Button: TUDBtnType);
399
begin
400
  with UpDown4 do
401
    if Position <= 10 then
402
      AsyncTimer.Interval := 1000 div Position
403
    else
404
      AsyncTimer.Interval := (20 - Position) * 10 + 1;
405
end;
406

407

408
procedure TForm1.FormResize(Sender: TObject);
409
begin
410
  hudMap.Position.SetPoint(vp.Width div 2, vp.Height div 2, 0);
411
  resizeMap;
412
end;
413

414
//
415
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
416
begin
417
  AsyncTimer.Enabled := false;
418
  buf[0].Free;
419
  buf[1].Free;
420
end;
421

422
end.
423