File: playground.pas

package info (click to toggle)
lazarus 2.0.0%2Bdfsg-2
  • links: PTS, VCS
  • area: main
  • in suites: buster
  • size: 214,460 kB
  • sloc: pascal: 1,862,622; xml: 265,709; cpp: 56,595; sh: 3,008; java: 609; makefile: 535; perl: 297; sql: 222; ansic: 137
file content (303 lines) | stat: -rw-r--r-- 8,810 bytes parent folder | download | duplicates (3)
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
unit PlayGround;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
  LMessages, LCLType, LCLIntf, ExtCtrls, StdCtrls;

type

  { TPictureControl }

  TPictureControl = class(TCustomControl)
    procedure PictureChanged(Sender: TObject);
  private
    FPicture: TPicture;
    procedure SetPicture(const AValue: TPicture);
    procedure WMEraseBkgnd(var Msg: TLMessage); message LM_ERASEBKGND;
  protected
  public
    constructor Create(TheOwner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
  published
    property Picture: TPicture read FPicture write SetPicture;
    property OnMouseMove;
    property OnMouseDown;
    property OnMouseUp;
    property OnKeyDown;
    property OnKeyUp;
    property OnKeyPress;
  end;

  { TPlayGroundForm }

  TPlayGroundForm = class(TForm)
    ComboBox1: TComboBox;
    Label1: TLabel;
    Panel1: TPanel;
    Panel2: TPanel;
    Timer1: TTimer;
    procedure ComboBox1Change(Sender: TObject);
    procedure PlayGroundFormClose(Sender: TObject; var CloseAction: TCloseAction);
    procedure PlayGroundFormCreate(Sender: TObject);
    procedure PlayGroundFormDestroy(Sender: TObject);
    procedure PictureControlKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure Timer1Timer(Sender: TObject);
  private
    FXIntertia: Double;
    FYIntertia: Double;
    FSpritePos: TPoint;
    FSpritePosChange: TPoint;
    FSpritePosInit: Boolean;
    procedure UpdateImage;
  public
    PictureControl: TPictureControl;
    SpriteImg: TCustomBitmap;
    BackgroundImg: TCustomBitmap;
    BufferImg: TCustomBitmap;
  end;

var
  PlayGroundForm: TPlayGroundForm;

implementation

{$R playground.lfm}

uses
  Math;

{ TPlayGroundForm }

procedure TPlayGroundForm.PlayGroundFormCreate(Sender: TObject);
begin
  PictureControl:=TPictureControl.Create(Self);
  with PictureControl do begin
    Parent:=Panel1; //Self;
    Align:=alClient;
    OnKeyDown := @PictureControlKeyDown;
  end;

  SpriteImg:=TPortableNetworkGraphic.Create;
  BackgroundImg:=TPortableNetworkGraphic.Create;
  BufferImg:=TBitmap.Create;

  SpriteImg.LoadFromFile(SetDirSeparators('../../images/ide_icon48x48.png'));
  BackgroundImg.LoadFromFile(SetDirSeparators('../../images/splash_logo.png'));
  BufferImg.Width:=BackgroundImg.Width;
  BufferImg.Height:=BackgroundImg.Height;

  FXIntertia := 0;
  FYIntertia := 0;

  Timer1.Enabled := Combobox1.ItemIndex = 0;
  
  UpdateImage;
end;

procedure TPlayGroundForm.PlayGroundFormClose(Sender: TObject;
  var CloseAction: TCloseAction);
begin
  Timer1.Enabled:=false;
end;

procedure TPlayGroundForm.PlayGroundFormDestroy(Sender: TObject);
begin
  SpriteImg.Free;
  BackgroundImg.Free;
  BufferImg.Free;
end;

procedure TPlayGroundForm.Timer1Timer(Sender: TObject);
begin
  if csDestroying in ComponentState then exit;
  UpdateImage;
end;

procedure TPlayGroundForm.ComboBox1Change(Sender: TObject);
begin
  Timer1.Enabled := Combobox1.ItemIndex in [0, 1, 3, 4];
  PictureControl.SetFocus;
end;

procedure TPlayGroundForm.PictureControlKeyDown(Sender: TObject;
  var Key: Word; Shift: TShiftState);
const
  DELTA = 20;
begin
  if ComboBox1.ItemIndex = 3 then Exit; // for smooth arrow key input
  case Key of
    VK_LEFT  : FSpritePosChange := Point(-DELTA, 0);
    VK_RIGHT : FSpritePosChange := Point( DELTA, 0);
    VK_UP    : FSpritePosChange := Point(0, -DELTA);
    VK_DOWN  : FSpritePosChange := Point(0,  DELTA);
  end;
  UpdateImage;
end;

function AdjustStep(p1, p2: Integer; Divisor: Integer): Integer;
var
  f: Double;
  delta: Integer;
begin
  if p1 = p2 then
    exit(0);

  delta := p2 - p1;
  f := delta/Divisor;
  if abs(f) < 1 then
    Result := sign(f)
  else
    Result := round(f);
  {
    Result
  if Delta > 0 then begin
    if Delta < Divisor then
      Result := 1
    else
      Result := Delta div Divisor;
  end else
  if Delta < 0 then begin
    if -Delta < Divisor then
      Result := -1
    else
      Result := Delta div Divisor;
  end else
    Result := 0;
    }
end;

procedure TPlayGroundForm.UpdateImage;
const
  SECONDS_PER_DAY = 24*60*60;
var
  DestImg: TBitmap;
  t: Double;
  CenterX: Integer;
  CenterY: Integer;
  dx, dy: Integer;
  MousePos: TPoint;
begin
  // paint first on the buffer
  
  // paint background
  BufferImg.Canvas.CopyRect(Rect(0,0,BufferImg.Width,BufferImg.Height),
       BackgroundImg.Canvas,Rect(0,0,BackgroundImg.Width,BackgroundImg.Height));
  // paint sprite
  CenterX:=BufferImg.Width div 2;
  CenterY:=BufferImg.Height div 2;
  if not FSpritePosInit then begin
    // SpritePos refers to the top/left corner of the sprite image.
    FSpritePos := Point(CenterX - SpriteImg.Width div 2, CenterY - SpriteImg.Height div 2);
    FSpritePosInit := true;
  end;
  case Combobox1.ItemIndex of
    0: begin
         // Movement of sprite by code along a calculated curve
         t := Now * SECONDS_PER_DAY;
         FSpritePos.X := CenterX + round(cos(t)*CenterX*2/3) - SpriteImg.Width div 2;
         FSpritePos.Y := CenterY + round(sin(t*0.7)*CenterY*2/3) - SpriteImg.Height div 2;
       end;
    1: begin
         // Movement of sprite by mouse: the sprite follows the mouse
         // Convert screen coordinates to images coordinates
         MousePos := PictureControl.ScreenToClient(Mouse.CursorPos);
         MousePos.X := round(MousePos.X / PictureControl.Width * PictureControl.Picture.Width);
         MousePos.Y := round(MousePos.Y / PictureControl.Height * PictureControl.Picture.Height);
         dx := AdjustStep(FSpritePos.X, MousePos.X, 5);
         dy := AdjustStep(FSpritePos.Y, MousePos.Y, 5);
         FSpritePos.X := FSpritePos.X + dx;
         FSpritePos.Y := FSpritePos.Y + dy;
       end;
    2: begin
         // Movement of sprite by keyboard: UP/DOWN/LEFT/RIGHT arrows advance
         // the sprite position by a given amount
         FSpritePos.X := FSpritePos.X + FSpritePosChange.X;
         FSpritePos.Y := FSpritePos.Y + FSpritePosChange.Y;
       end;
    3: begin
         // Movement of sprite by keyboard: UP/DOWN/LEFT/RIGHT arrows advance smooth version
         if (GetKeyState(VK_LEFT) < 0) then FSpritePos.X := FSpritePos.X - 10;
         if (GetKeyState(VK_RIGHT) < 0) then FSpritePos.X := FSpritePos.X + 10;
         if (GetKeyState(VK_UP) < 0) then FSpritePos.Y := FSpritePos.Y - 10;
         if (GetKeyState(VK_DOWN) < 0) then FSpritePos.Y := FSpritePos.Y + 10;
       end;
    4: begin
         // Movement of sprite by keyboard: UP/DOWN/LEFT/RIGHT arrows advance with inertia
         if (GetKeyState(VK_LEFT) < 0) then FXIntertia := FXIntertia - 0.5;
         if (GetKeyState(VK_RIGHT) < 0) then FXIntertia := FXIntertia + 0.5;
         if (GetKeyState(VK_UP) < 0) then FYIntertia := FYIntertia - 0.5;
         if (GetKeyState(VK_DOWN) < 0) then FYIntertia := FYIntertia + 0.5;
         if (FXIntertia > 6) then FXIntertia := 6;
         if (FXIntertia < -6) then FXIntertia := -6;
         if (FYIntertia > 6) then FYIntertia := 6;
         if (FYIntertia < -6) then FYIntertia := -6;
         if (FXIntertia > 0) then FXIntertia := FXIntertia - 0.2;
         if (FXIntertia < 0) then FXIntertia := FXIntertia + 0.2;
         if (FYIntertia > 0) then FYIntertia := FYIntertia - 0.2;
         if (FYIntertia < 0) then FYIntertia := FYIntertia + 0.2;
         FSpritePos.X := FSpritePos.X + round(FXIntertia);
         FSpritePos.Y := FSpritePos.Y + round(FYIntertia);
       end;
  end;

  // Make sure that the sprite does not leave the image.
  FSpritePos.X := EnsureRange(FSpritePos.X, 0, BufferImg.Width - SpriteImg.Width);
  FSpritePos.Y := EnsureRange(FSpritePos.Y, 0, BufferImg.Height - SpriteImg.Height);

  // Draw sprite at current position to buffer.
  BufferImg.Canvas.Draw(FSpritePos.X, FSpritePos.Y, SpriteImg);

  // copy to image
  DestImg:=PictureControl.Picture.Bitmap;
  DestImg.Width:=BufferImg.Width;
  DestImg.Height:=BufferImg.Height;
  DestImg.Canvas.Draw(0,0,BufferImg);
end;


{ TPictureControl }

procedure TPictureControl.SetPicture(const AValue: TPicture);
begin
  if FPicture=AValue then exit;
  FPicture.Assign(AValue);
end;

procedure TPictureControl.WMEraseBkgnd(var Msg: TLMessage);
begin
  Msg.Result := 1;
end;

procedure TPictureControl.PictureChanged(Sender: TObject);
begin
  Invalidate;
end;

constructor TPictureControl.Create(TheOwner: TComponent);
begin
  inherited Create(TheOwner);
  FPicture:=TPicture.Create;
  FPicture.OnChange:=@PictureChanged;
end;

destructor TPictureControl.Destroy;
begin
  FreeAndNil(FPicture);
  inherited Destroy;
end;

procedure TPictureControl.Paint;
begin
  if Picture.Graphic<>nil then
    // Canvas.Draw(0,0,Picture.Graphic); // copy is fast
    Canvas.StretchDraw(Rect(0,0,Width,Height),Picture.Graphic); // stretch is slow
  inherited Paint;
end;

end.