Стартовый пул
This commit is contained in:
BIN
bgracontrols/test/test_extra/game_maze/background.jpg
Normal file
BIN
bgracontrols/test/test_extra/game_maze/background.jpg
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 29 KiB |
624
bgracontrols/test/test_extra/game_maze/bgragame.pas
Normal file
624
bgracontrols/test/test_extra/game_maze/bgragame.pas
Normal file
@@ -0,0 +1,624 @@
|
||||
unit bgragame;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, Graphics, LCLType, BGRABitmap, BGRABitmapTypes,
|
||||
SysUtils, Forms, Controls;
|
||||
|
||||
const
|
||||
L1 = VK_LEFT;
|
||||
R1 = VK_RIGHT;
|
||||
U1 = VK_UP;
|
||||
D1 = VK_DOWN;
|
||||
L2 = VK_A;
|
||||
R2 = VK_D;
|
||||
U2 = VK_W;
|
||||
D2 = VK_S;
|
||||
|
||||
type
|
||||
TGameKey = (gkLeft, gkUp, gkRight, gkDown);
|
||||
|
||||
PGameMap = ^TGameMap;
|
||||
|
||||
TGameMap = record
|
||||
mapGraphics: string;
|
||||
mapProperty: string;
|
||||
mapSolve: string;
|
||||
mapPrevPos: string;
|
||||
mapKeyChar: char;
|
||||
mapSolidChar: char;
|
||||
mapWidth: integer;
|
||||
mapHeight: integer;
|
||||
blockWidth: integer;
|
||||
blockHeight: integer;
|
||||
background: TBGRABitmap;
|
||||
ballSphereMap: TBGRABitmap;
|
||||
ballPosition,ballSpeed: TPointF;
|
||||
ballPositionDefined: boolean;
|
||||
mouseDown: boolean;
|
||||
mousePos: TPointF;
|
||||
mapKeysDown: set of TGameKey;
|
||||
end;
|
||||
|
||||
procedure DrawMap(var map: TGameMap; bitmap: TBGRABitmap; redrawAll: boolean);
|
||||
function ClickMapCell(var map: TGameMap; pos: TPoint): boolean;
|
||||
procedure MouseDownMap(var map: TGameMap; pos: TPoint);
|
||||
procedure MouseUpMap(var map: TGameMap; pos: TPoint);
|
||||
function GetGameKey(var Key: word; invertLR, invertUD: boolean): TGameKey;
|
||||
procedure KeyDownMap(var map: TGameMap; var Key: word);
|
||||
procedure KeyUpMap(var map: TGameMap; var Key: word);
|
||||
function KeyPressMapCell(var map: TGameMap; Key: TGameKey): boolean;
|
||||
function KeyPressMapCell(var map: TGameMap; var Key: word): boolean;
|
||||
function IsMapSolved(var map: TGameMap): boolean;
|
||||
|
||||
procedure ToggleFullScreen(Form: TForm; ARect: TRect);
|
||||
procedure CenterControl(Control: TControl);
|
||||
function CalculateAspectRatioH(const W1, H1, W2: integer): integer; //result H2
|
||||
function CalculateAspectRatioW(const W1, H1, H2: integer): integer; //result W2
|
||||
function CalculateDestRect(ImageW, ImageH, DestW, DestH: integer;
|
||||
Stretch, Proportional, Center: boolean): TRect;
|
||||
procedure HighDPI(FromDPI: integer);
|
||||
procedure ScaleDPI(Control: TControl; FromDPI: integer);
|
||||
procedure ScaleAspectRatio(Control: TControl; OriginalParentW, OriginalParentH: integer);
|
||||
procedure ScaleAspectRatio(Control: TControl; DestW, DestH: integer;
|
||||
Stretch, Proportional, Center: boolean);
|
||||
|
||||
implementation
|
||||
|
||||
uses BGRAGradients;
|
||||
|
||||
procedure DrawMap(var map: TGameMap; bitmap: TBGRABitmap; minx,miny,maxx,maxy: integer; fullbackground: boolean); forward;
|
||||
procedure DrawBall(var map: TGameMap; bitmap: TBGRABitmap); forward;
|
||||
procedure InvalidateMap(var map: TGameMap; ARect: TRect);
|
||||
var minx,miny,maxx,maxy,xb,yb: integer;
|
||||
begin
|
||||
if map.blockWidth <> 0 then
|
||||
minx := ARect.Left div map.blockWidth;
|
||||
if map.blockWidth <> 0 then
|
||||
maxx := (ARect.Right div map.blockWidth) +1;
|
||||
if map.blockHeight <> 0 then
|
||||
miny := ARect.top div map.blockHeight;
|
||||
if map.blockHeight <> 0 then
|
||||
maxy := (ARect.bottom div map.blockHeight) +1;
|
||||
if miny < 0 then miny :=0;
|
||||
if minx < 0 then minx := 0;
|
||||
if maxx > map.mapWidth-1 then maxx := map.mapWidth-1;
|
||||
if maxy > map.mapHeight-1 then maxy := map.mapHeight-1;
|
||||
for yb := miny to maxy do
|
||||
for xb := minx to maxx do
|
||||
map.mapPrevPos[xb+yb*map.mapWidth+1] := '1';
|
||||
end;
|
||||
|
||||
const acceleration = 0.01;
|
||||
maxSpeed = 0.1;
|
||||
|
||||
procedure MoveBall(var map: TGameMap);
|
||||
var speed: single;
|
||||
ix,iy,nix,niy: integer;
|
||||
|
||||
dir: TPointF;
|
||||
dirlen: single;
|
||||
begin
|
||||
if map.ballPositionDefined then
|
||||
begin
|
||||
if map.mouseDown then
|
||||
begin
|
||||
dir := map.mousePos-map.ballPosition;
|
||||
dirlen := sqrt(dir*dir);
|
||||
if dirlen > acceleration then dir *= acceleration/dirlen;
|
||||
map.ballSpeed += dir;
|
||||
end else
|
||||
begin
|
||||
if gkLeft in map.mapKeysDown then map.ballSpeed.x -= acceleration;
|
||||
if gkRight in map.mapKeysDown then map.ballSpeed.x += acceleration;
|
||||
if gkUp in map.mapKeysDown then map.ballSpeed.y -= acceleration;
|
||||
if gkDown in map.mapKeysDown then map.ballSpeed.y += acceleration;
|
||||
end;
|
||||
|
||||
speed := sqrt(map.ballSpeed*map.ballSpeed);
|
||||
if speed > maxSpeed then map.ballSpeed *= maxSpeed/speed;
|
||||
ix := round(map.ballPosition.x);
|
||||
iy := round(map.ballPosition.y);
|
||||
map.ballPosition += map.ballSpeed;
|
||||
nix := round(map.ballPosition.x);
|
||||
niy := round(map.ballPosition.y);
|
||||
if nix > ix then
|
||||
begin
|
||||
if not KeyPressMapCell(map, gkRight) then
|
||||
begin
|
||||
map.ballPosition.X := ix+0.499;
|
||||
map.ballSpeed.X := -abs(map.ballSpeed.X);
|
||||
end;
|
||||
end;
|
||||
if nix < ix then
|
||||
begin
|
||||
if not KeyPressMapCell(map, gkLeft) then
|
||||
begin
|
||||
map.ballPosition.X := ix-0.499;
|
||||
map.ballSpeed.X := abs(map.ballSpeed.X);
|
||||
end;
|
||||
end;
|
||||
if niy > iy then
|
||||
begin
|
||||
if not KeyPressMapCell(map, gkDown) then
|
||||
begin
|
||||
map.ballPosition.y := iy+0.499;
|
||||
map.ballSpeed.y := -abs(map.ballSpeed.y);
|
||||
end;
|
||||
end;
|
||||
if niy < iy then
|
||||
begin
|
||||
if not KeyPressMapCell(map, gkUp) then
|
||||
begin
|
||||
map.ballPosition.y := iy-0.499;
|
||||
map.ballSpeed.y := abs(map.ballSpeed.y);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure DrawMap(var map: TGameMap; bitmap: TBGRABitmap; redrawAll: boolean);
|
||||
begin
|
||||
MoveBall(map);
|
||||
if redrawAll then
|
||||
DrawMap(map,bitmap,0,0,map.mapWidth-1,map.mapHeight-1,true)
|
||||
else
|
||||
DrawMap(map,bitmap,0,0,map.mapWidth-1,map.mapHeight-1,false);
|
||||
DrawBall(map, bitmap);
|
||||
end;
|
||||
|
||||
procedure DrawBall(var map: TGameMap; bitmap: TBGRABitmap);
|
||||
var phong: TPhongShading;
|
||||
radius,xi,yi: integer;
|
||||
r: TRect;
|
||||
begin
|
||||
if map.ballPositionDefined then
|
||||
begin
|
||||
phong := TPhongShading.Create;
|
||||
phong.LightPosition := point(bitmap.Width div 2, bitmap.Height div 2);
|
||||
radius := map.blockWidth;
|
||||
if map.blockHeight < radius then radius := map.blockHeight;
|
||||
radius := round(radius*0.3);
|
||||
xi := round((map.ballPosition.X+0.5)*map.blockWidth);
|
||||
yi := round((map.ballPosition.Y+0.5)*map.blockHeight);
|
||||
r := rect(xi-radius,yi-radius,xi+radius+1,yi+radius+1);
|
||||
if (map.ballSphereMap <> nil) and ((map.ballSphereMap.Width <> r.right-r.left) or (map.ballSphereMap.Height <> r.bottom-r.top)) then
|
||||
FreeAndNil(map.ballSphereMap);
|
||||
if map.ballSphereMap = nil then map.ballSphereMap := CreateSpherePreciseMap(r.right-r.left,r.bottom-r.top);
|
||||
phong.Draw(bitmap,map.ballSphereMap,radius,r.left,r.top,CSSLightGray);
|
||||
phong.Free;
|
||||
InvalidateMap(map, rect(xi-radius,yi-radius,xi+radius+1,yi+radius+1));
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure DrawMap(var map: TGameMap; bitmap: TBGRABitmap; minx,miny,maxx,maxy: integer; fullbackground: boolean);
|
||||
var
|
||||
n, nx, ny: integer;
|
||||
r: TRect;
|
||||
colorOscillation: single;
|
||||
oldClip: TRect;
|
||||
shouldRedraw: boolean;
|
||||
|
||||
begin
|
||||
colorOscillation:= sin(frac(Now)*24*60*60 * 2*Pi)*0.5+0.5;
|
||||
|
||||
if minx < 0 then minx := 0;
|
||||
if miny < 0 then miny := 0;
|
||||
if maxx > map.mapWidth-1 then maxx := map.mapWidth-1;
|
||||
if maxy > map.mapHeight-1 then maxy := map.mapHeight-1;
|
||||
|
||||
oldClip := bitmap.ClipRect;
|
||||
bitmap.ClipRect := rect(map.blockWidth * minx, map.blockHeight * miny,
|
||||
map.blockWidth * (maxx+1), map.blockHeight * (maxy+1));
|
||||
if fullbackground then bitmap.PutImage(0, 0, map.background, dmSet);
|
||||
|
||||
if map.mapPrevPos = '' then
|
||||
begin
|
||||
setlength(map.mapPrevPos, map.mapWidth*map.mapHeight);
|
||||
for n := 1 to length(map.mapPrevPos) do
|
||||
map.mapPrevPos[n] := '0';
|
||||
end;
|
||||
|
||||
r.Top := map.blockHeight * miny;
|
||||
r.Bottom := r.Top + map.blockHeight;
|
||||
for ny := miny to maxy do
|
||||
begin
|
||||
r.Left := map.blockWidth * minx;
|
||||
r.Right := r.Left + map.blockWidth;
|
||||
n := ny*map.mapWidth+minx+1;
|
||||
for nx := minx to maxx do
|
||||
begin
|
||||
shouldRedraw:= (map.mapProperty[n] = map.mapKeyChar) or (map.mapGraphics[n] = 'X');
|
||||
if fullbackground or shouldRedraw or (map.mapPrevPos[n] = '1') then
|
||||
begin
|
||||
if shouldRedraw then map.mapPrevPos[n] := '1' else map.mapPrevPos[n] := '0';
|
||||
// begin to draw here
|
||||
if not fullbackground then bitmap.PutImagePart(r.left, r.top, map.background, r, dmSet);
|
||||
|
||||
if map.mapProperty[n] = map.mapKeyChar then
|
||||
begin
|
||||
bitmap.Rectangle(r, BGRAPixelTransparent, BGRA(0, 255, 0, round(200*colorOscillation)),
|
||||
dmDrawWithTransparency);
|
||||
if not map.ballPositionDefined then
|
||||
begin
|
||||
map.ballPosition := pointF(nx,ny);
|
||||
map.ballPositionDefined := true;
|
||||
end;
|
||||
end
|
||||
else if map.mapProperty[n] = map.mapSolidChar then
|
||||
bitmap.Rectangle(r, BGRAPixelTransparent, BGRA(0, 0, 0, 100),
|
||||
dmDrawWithTransparency)
|
||||
else
|
||||
bitmap.Rectangle(r, BGRAPixelTransparent, BGRA(255, 255, 255, 200),
|
||||
dmDrawWithTransparency);
|
||||
|
||||
if map.blockWidth > map.blockHeight then
|
||||
bitmap.FontHeight := map.blockHeight
|
||||
else
|
||||
bitmap.FontHeight := map.blockWidth;
|
||||
|
||||
if map.mapGraphics[n] = 'X' then
|
||||
bitmap.Rectangle(r, BGRAPixelTransparent, BGRA(255, 0, 0, round(200*colorOscillation)),
|
||||
dmDrawWithTransparency);
|
||||
// end to draw here
|
||||
end;
|
||||
Inc(n);
|
||||
inc(r.Left,map.blockWidth);
|
||||
inc(r.right,map.blockWidth);
|
||||
end;
|
||||
inc(r.top,map.blockHeight);
|
||||
inc(r.bottom,map.blockHeight);
|
||||
end;
|
||||
bitmap.ClipRect := oldClip;
|
||||
end;
|
||||
|
||||
function ClickMapCell(var map: TGameMap; pos: TPoint): boolean;
|
||||
var
|
||||
n, nx, ny: integer;
|
||||
r: TRect;
|
||||
begin
|
||||
Result := False;
|
||||
n := 1;
|
||||
for ny := 0 to map.mapHeight - 1 do
|
||||
begin
|
||||
for nx := 0 to map.mapWidth - 1 do
|
||||
begin
|
||||
r.Left := map.blockWidth * nx;
|
||||
r.Top := map.blockHeight * ny;
|
||||
r.Right := r.Left + map.blockWidth;
|
||||
r.Bottom := r.Top + map.blockHeight;
|
||||
|
||||
if (pos.x >= r.Left) and (pos.x <= r.Right) and (pos.y >= r.Top) and
|
||||
(pos.y <= r.Bottom) then
|
||||
begin
|
||||
// begin here
|
||||
|
||||
// mapKeyChar is n
|
||||
if (map.mapProperty[n] = map.mapKeyChar) then
|
||||
exit;
|
||||
|
||||
// mapSolidChar is n
|
||||
if (map.mapProperty[n] = map.mapSolidChar) then
|
||||
exit;
|
||||
|
||||
// mapKeyChar is on the left, move to n
|
||||
if (nx <> 0) then
|
||||
if (map.mapProperty[n - 1] = map.mapKeyChar) then
|
||||
begin
|
||||
map.mapProperty[n - 1] := map.mapProperty[n];
|
||||
map.mapProperty[n] := map.mapKeyChar;
|
||||
end;
|
||||
|
||||
// mapKeyChar is on the right, move to n
|
||||
if (nx <> map.mapWidth - 1) then
|
||||
if (map.mapProperty[n + 1] = map.mapKeyChar) then
|
||||
begin
|
||||
map.mapProperty[n + 1] := map.mapProperty[n];
|
||||
map.mapProperty[n] := map.mapKeyChar;
|
||||
end;
|
||||
|
||||
// mapKeyChar is on top, move to n
|
||||
if (map.mapProperty[n - map.mapWidth] = map.mapKeyChar) then
|
||||
begin
|
||||
map.mapProperty[n - map.mapWidth] := map.mapProperty[n];
|
||||
map.mapProperty[n] := map.mapKeyChar;
|
||||
end;
|
||||
|
||||
// mapKeyChar is on bottom, move to n
|
||||
if (map.mapProperty[n + map.mapWidth] = map.mapKeyChar) then
|
||||
begin
|
||||
map.mapProperty[n + map.mapWidth] := map.mapProperty[n];
|
||||
map.mapProperty[n] := map.mapKeyChar;
|
||||
end;
|
||||
|
||||
// end here
|
||||
Result := True;
|
||||
exit;
|
||||
end;
|
||||
|
||||
Inc(n);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure MouseDownMap(var map: TGameMap; pos: TPoint);
|
||||
begin
|
||||
map.mouseDown := true;
|
||||
map.mousePos := pointf(pos.x/map.blockWidth-0.5,pos.y/map.blockHeight-0.5);
|
||||
end;
|
||||
|
||||
procedure MouseUpMap(var map: TGameMap; pos: TPoint);
|
||||
begin
|
||||
map.mouseDown := false;
|
||||
map.mousePos := pointf(pos.x/map.blockWidth-0.5,pos.y/map.blockHeight-0.5);
|
||||
end;
|
||||
|
||||
function GetGameKey(var Key: word; invertLR, invertUD: boolean): TGameKey;
|
||||
begin
|
||||
if (Key = L1) or (Key = L2) then
|
||||
Result := gkLeft;
|
||||
if (Key = R1) or (Key = R2) then
|
||||
Result := gkRight;
|
||||
if (Key = U1) or (Key = U2) then
|
||||
Result := gkUp;
|
||||
if (Key = D1) or (Key = D2) then
|
||||
Result := gkDown;
|
||||
|
||||
if invertLR then
|
||||
case Result of
|
||||
gkLeft: Result := gkRight;
|
||||
gkRight: Result := gkLeft;
|
||||
end;
|
||||
|
||||
if invertUD then
|
||||
case Result of
|
||||
gkUp: Result := gkDown;
|
||||
gkDown: Result := gkUp;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure KeyDownMap(var map: TGameMap; var Key: word);
|
||||
begin
|
||||
map.mapKeysDown := map.mapKeysDown + [GetGameKey(Key,false,false)];
|
||||
end;
|
||||
|
||||
procedure KeyUpMap(var map: TGameMap; var Key: word);
|
||||
begin
|
||||
map.mapKeysDown := map.mapKeysDown - [GetGameKey(Key,false,false)];
|
||||
end;
|
||||
|
||||
function KeyPressMapCell(var map: TGameMap; Key: TGameKey): boolean;
|
||||
var
|
||||
n, nx, ny: integer;
|
||||
begin
|
||||
Result := False;
|
||||
n := 1;
|
||||
for ny := 0 to map.mapHeight - 1 do
|
||||
begin
|
||||
for nx := 0 to map.mapWidth - 1 do
|
||||
begin
|
||||
if map.mapProperty[n] = map.mapKeyChar then
|
||||
begin
|
||||
|
||||
// begin here
|
||||
|
||||
case Key of
|
||||
gkLeft:
|
||||
if (nx <> 0) and (map.mapProperty[n - 1] <> map.mapSolidChar) then
|
||||
begin
|
||||
map.mapProperty[n] := map.mapProperty[n - 1];
|
||||
map.mapProperty[n - 1] := map.mapKeyChar;
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
gkRight:
|
||||
if (nx <> map.mapWidth - 1) and (map.mapProperty[n + 1] <>
|
||||
map.mapSolidChar) then
|
||||
begin
|
||||
map.mapProperty[n] := map.mapProperty[n + 1];
|
||||
map.mapProperty[n + 1] := map.mapKeyChar;
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
gkUp:
|
||||
if (ny <> 0) and (map.mapProperty[n - map.mapWidth] <> map.mapSolidChar) then
|
||||
begin
|
||||
map.mapProperty[n] := map.mapProperty[n - map.mapWidth];
|
||||
map.mapProperty[n - map.mapWidth] := map.mapKeyChar;
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
gkDown:
|
||||
if (ny <> map.mapHeight - 1) and
|
||||
(map.mapProperty[n + map.mapHeight] <> map.mapSolidChar) then
|
||||
begin
|
||||
map.mapProperty[n] := map.mapProperty[n + map.mapWidth];
|
||||
map.mapProperty[n + map.mapWidth] := map.mapKeyChar;
|
||||
Result := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
// end here
|
||||
|
||||
if Result then
|
||||
exit;
|
||||
|
||||
end;
|
||||
Inc(n);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function KeyPressMapCell(var map: TGameMap; var Key: word): boolean;
|
||||
begin
|
||||
Result := KeyPressMapCell(map, GetGameKey(Key, False, False));
|
||||
if result then Key := 0;
|
||||
end;
|
||||
|
||||
function IsMapSolved(var map: TGameMap): boolean;
|
||||
begin
|
||||
Result := map.mapProperty = map.mapSolve;
|
||||
end;
|
||||
|
||||
procedure ToggleFullScreen(Form: TForm; ARect: TRect);
|
||||
begin
|
||||
Form.SetBounds(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
|
||||
if Form.BorderStyle <> bsNone then
|
||||
begin
|
||||
Form.BorderStyle := bsNone;
|
||||
Form.WindowState := wsMaximized;
|
||||
end
|
||||
else
|
||||
begin
|
||||
Form.BorderStyle := bsSizeable;
|
||||
Form.WindowState := wsMaximized;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure CenterControl(Control: TControl);
|
||||
begin
|
||||
if not Control.HasParent then
|
||||
Exit;
|
||||
Control.SetBounds(
|
||||
Round((Control.Parent.Width - Control.Width) div 2),
|
||||
Round((Control.Parent.Height - Control.Height) div 2),
|
||||
Control.Width, Control.Height);
|
||||
end;
|
||||
|
||||
function CalculateAspectRatioH(const W1, H1, W2: integer): integer;
|
||||
begin
|
||||
Result := Round(H1 / W1 * W2);
|
||||
end;
|
||||
|
||||
function CalculateAspectRatioW(const W1, H1, H2: integer): integer;
|
||||
begin
|
||||
Result := Round(W1 / H1 * H2);
|
||||
end;
|
||||
|
||||
function CalculateDestRect(ImageW, ImageH, DestW, DestH: integer;
|
||||
Stretch, Proportional, Center: boolean): TRect;
|
||||
var
|
||||
w: integer;
|
||||
h: integer;
|
||||
begin
|
||||
// Stretch or Proportional when Image (Width or Height) is bigger than Destination
|
||||
if Stretch or (Proportional and ((ImageW > DestW) or (ImageH > DestH))) then
|
||||
begin
|
||||
// Proportional when Image (Width or Height) is bigger than 0
|
||||
if Proportional and (ImageW > 0) and (ImageH > 0) then
|
||||
begin
|
||||
w := DestW;
|
||||
h := CalculateAspectRatioH(ImageW, ImageH, DestW);
|
||||
if h > DestH then
|
||||
begin
|
||||
h := DestH;
|
||||
w := CalculateAspectRatioW(ImageW, ImageH, DestH);
|
||||
end;
|
||||
ImageW := w;
|
||||
ImageH := h;
|
||||
end
|
||||
// Stretch not Proportional or when Image (Width or Height) is 0
|
||||
else
|
||||
begin
|
||||
ImageW := DestW;
|
||||
ImageH := DestH;
|
||||
end;
|
||||
end;
|
||||
|
||||
Result := Rect(0, 0, ImageW, ImageH);
|
||||
|
||||
// Center: Destination (Width or Height) - Image divided by 2
|
||||
if Center then
|
||||
begin
|
||||
Result.Left := Round((DestW - ImageW) div 2);
|
||||
Result.Top := Round((DestH - ImageH) div 2);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure HighDPI(FromDPI: integer);
|
||||
var
|
||||
i: integer;
|
||||
begin
|
||||
if Screen.PixelsPerInch = FromDPI then
|
||||
exit;
|
||||
|
||||
for i := 0 to Screen.FormCount - 1 do
|
||||
ScaleDPI(Screen.Forms[i], FromDPI);
|
||||
end;
|
||||
|
||||
procedure ScaleDPI(Control: TControl; FromDPI: integer);
|
||||
var
|
||||
i: integer;
|
||||
WinControl: TWinControl;
|
||||
begin
|
||||
if Screen.PixelsPerInch = FromDPI then
|
||||
exit;
|
||||
|
||||
with Control do
|
||||
begin
|
||||
Left := ScaleX(Left, FromDPI);
|
||||
Top := ScaleY(Top, FromDPI);
|
||||
Width := ScaleX(Width, FromDPI);
|
||||
Height := ScaleY(Height, FromDPI);
|
||||
end;
|
||||
|
||||
if Control is TWinControl then
|
||||
begin
|
||||
WinControl := TWinControl(Control);
|
||||
if WinControl.ControlCount = 0 then
|
||||
exit;
|
||||
|
||||
with WinControl.ChildSizing do
|
||||
begin
|
||||
HorizontalSpacing := ScaleX(HorizontalSpacing, FromDPI);
|
||||
LeftRightSpacing := ScaleX(LeftRightSpacing, FromDPI);
|
||||
TopBottomSpacing := ScaleY(TopBottomSpacing, FromDPI);
|
||||
VerticalSpacing := ScaleY(VerticalSpacing, FromDPI);
|
||||
end;
|
||||
|
||||
for i := 0 to WinControl.ControlCount - 1 do
|
||||
ScaleDPI(WinControl.Controls[i], FromDPI);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure ScaleAspectRatio(Control: TControl; OriginalParentW, OriginalParentH: integer);
|
||||
var
|
||||
l, t, w, h: integer;
|
||||
begin
|
||||
l := MulDiv(Control.Left, Control.Parent.Width, OriginalParentW);
|
||||
t := MulDiv(Control.Top, Control.Parent.Height, OriginalParentH);
|
||||
w := MulDiv(Control.Width, Control.Parent.Width, OriginalParentW);
|
||||
h := MulDiv(Control.Height, Control.Parent.Height, OriginalParentH);
|
||||
Control.SetBounds(l, t, w, h);
|
||||
end;
|
||||
|
||||
procedure ScaleAspectRatio(Control: TControl; DestW, DestH: integer;
|
||||
Stretch, Proportional, Center: boolean);
|
||||
var
|
||||
i: integer;
|
||||
r: TRect;
|
||||
WinControl: TWinControl;
|
||||
w, h: integer;
|
||||
begin
|
||||
if Control is TWinControl then
|
||||
begin
|
||||
WinControl := TWinControl(Control);
|
||||
w := WinControl.Width;
|
||||
h := WinControl.Height;
|
||||
|
||||
r := CalculateDestRect(WinControl.Width, WinControl.Height, DestW,
|
||||
DestH, Stretch, Proportional, Center);
|
||||
WinControl.SetBounds(r.Left, r.Top, r.Right, r.Bottom);
|
||||
|
||||
if WinControl.ControlCount = 0 then
|
||||
exit;
|
||||
|
||||
for i := 0 to WinControl.ControlCount - 1 do
|
||||
ScaleAspectRatio(WinControl.Controls[i], w, h);
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
144
bgracontrols/test/test_extra/game_maze/testbgragame.lpi
Normal file
144
bgracontrols/test/test_extra/game_maze/testbgragame.lpi
Normal file
@@ -0,0 +1,144 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="12"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<CompatibilityMode Value="True"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<Title Value="testbgragame"/>
|
||||
<ResourceType Value="res"/>
|
||||
<UseXPManifest Value="True"/>
|
||||
<XPManifest>
|
||||
<DpiAware Value="True"/>
|
||||
</XPManifest>
|
||||
</General>
|
||||
<i18n>
|
||||
<EnableI18N LFM="False"/>
|
||||
</i18n>
|
||||
<BuildModes Count="2">
|
||||
<Item1 Name="Debug" Default="True"/>
|
||||
<Item2 Name="Release">
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="testbgragame"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<CodeGeneration>
|
||||
<SmartLinkUnit Value="True"/>
|
||||
<Optimizations>
|
||||
<OptimizationLevel Value="3"/>
|
||||
<VariablesInRegisters Value="True"/>
|
||||
</Optimizations>
|
||||
</CodeGeneration>
|
||||
<Linking>
|
||||
<Debugging>
|
||||
<GenerateDebugInfo Value="False"/>
|
||||
<StripSymbols Value="True"/>
|
||||
</Debugging>
|
||||
<LinkSmart Value="True"/>
|
||||
<Options>
|
||||
<Win32>
|
||||
<GraphicApplication Value="True"/>
|
||||
</Win32>
|
||||
</Options>
|
||||
</Linking>
|
||||
</CompilerOptions>
|
||||
</Item2>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<FormatVersion Value="2"/>
|
||||
<Modes Count="1">
|
||||
<Mode0 Name="default"/>
|
||||
</Modes>
|
||||
</RunParams>
|
||||
<RequiredPackages Count="2">
|
||||
<Item1>
|
||||
<PackageName Value="bgracontrols"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<PackageName Value="LCL"/>
|
||||
</Item2>
|
||||
</RequiredPackages>
|
||||
<Units Count="3">
|
||||
<Unit0>
|
||||
<Filename Value="testbgragame.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
<Unit1>
|
||||
<Filename Value="utestbgragame.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<ComponentName Value="Form1"/>
|
||||
<HasResources Value="True"/>
|
||||
<ResourceBaseClass Value="Form"/>
|
||||
</Unit1>
|
||||
<Unit2>
|
||||
<Filename Value="bgragame.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit2>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="testbgragame"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Parsing>
|
||||
<SyntaxOptions>
|
||||
<IncludeAssertionCode Value="True"/>
|
||||
</SyntaxOptions>
|
||||
</Parsing>
|
||||
<CodeGeneration>
|
||||
<Checks>
|
||||
<IOChecks Value="True"/>
|
||||
<RangeChecks Value="True"/>
|
||||
<OverflowChecks Value="True"/>
|
||||
<StackChecks Value="True"/>
|
||||
</Checks>
|
||||
<Optimizations>
|
||||
<VariablesInRegisters Value="True"/>
|
||||
</Optimizations>
|
||||
</CodeGeneration>
|
||||
<Linking>
|
||||
<Debugging>
|
||||
<DebugInfoType Value="dsDwarf2Set"/>
|
||||
<UseHeaptrc Value="True"/>
|
||||
<StripSymbols Value="True"/>
|
||||
<UseExternalDbgSyms Value="True"/>
|
||||
</Debugging>
|
||||
<Options>
|
||||
<Win32>
|
||||
<GraphicApplication Value="True"/>
|
||||
</Win32>
|
||||
</Options>
|
||||
</Linking>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
21
bgracontrols/test/test_extra/game_maze/testbgragame.lpr
Normal file
21
bgracontrols/test/test_extra/game_maze/testbgragame.lpr
Normal file
@@ -0,0 +1,21 @@
|
||||
program testbgragame;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
uses
|
||||
{$IFDEF UNIX}{$IFDEF UseCThreads}
|
||||
cthreads,
|
||||
{$ENDIF}{$ENDIF}
|
||||
Interfaces, // this includes the LCL widgetset
|
||||
Forms, utestbgragame, bgragame
|
||||
{ you can add units after this };
|
||||
|
||||
{$R *.res}
|
||||
|
||||
begin
|
||||
RequireDerivedFormResource := True;
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TForm1, Form1);
|
||||
Application.Run;
|
||||
end.
|
||||
|
||||
35
bgracontrols/test/test_extra/game_maze/utestbgragame.lfm
Normal file
35
bgracontrols/test/test_extra/game_maze/utestbgragame.lfm
Normal file
@@ -0,0 +1,35 @@
|
||||
object Form1: TForm1
|
||||
Left = 328
|
||||
Height = 480
|
||||
Top = 135
|
||||
Width = 640
|
||||
ClientHeight = 480
|
||||
ClientWidth = 640
|
||||
Color = clBlack
|
||||
OnCreate = FormCreate
|
||||
OnDestroy = FormDestroy
|
||||
OnKeyDown = FormKeyDown
|
||||
OnKeyUp = FormKeyUp
|
||||
OnResize = FormResize
|
||||
LCLVersion = '1.0.1.3'
|
||||
object BGRAVirtualScreen1: TBGRAVirtualScreen
|
||||
Left = 0
|
||||
Height = 480
|
||||
Top = 0
|
||||
Width = 640
|
||||
OnRedraw = BGRAVirtualScreen1Redraw
|
||||
Alignment = taLeftJustify
|
||||
Color = clWhite
|
||||
ParentColor = False
|
||||
TabOrder = 0
|
||||
OnMouseDown = BGRAVirtualScreen1MouseDown
|
||||
OnMouseMove = BGRAVirtualScreen1MouseMove
|
||||
OnMouseUp = BGRAVirtualScreen1MouseUp
|
||||
end
|
||||
object Timer2: TTimer
|
||||
Interval = 200
|
||||
OnTimer = Timer2Timer
|
||||
left = 24
|
||||
top = 8
|
||||
end
|
||||
end
|
||||
155
bgracontrols/test/test_extra/game_maze/utestbgragame.pas
Normal file
155
bgracontrols/test/test_extra/game_maze/utestbgragame.pas
Normal file
@@ -0,0 +1,155 @@
|
||||
unit utestbgragame;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, Forms, Controls, LCLType, ExtCtrls, BGRAVirtualScreen, BGRABitmap,
|
||||
BGRABitmapTypes, Dialogs, bgragame;
|
||||
|
||||
type
|
||||
|
||||
{ TForm1 }
|
||||
|
||||
TForm1 = class(TForm)
|
||||
BGRAVirtualScreen1: TBGRAVirtualScreen;
|
||||
Timer2: TTimer;
|
||||
procedure BGRAVirtualScreen1MouseDown(Sender: TObject;
|
||||
Button: TMouseButton; {%H-}Shift: TShiftState; X, Y: integer);
|
||||
procedure BGRAVirtualScreen1MouseMove(Sender: TObject; Shift: TShiftState;
|
||||
X, Y: integer);
|
||||
procedure BGRAVirtualScreen1MouseUp(Sender: TObject; Button: TMouseButton;
|
||||
{%H-}Shift: TShiftState; X, Y: Integer);
|
||||
procedure BGRAVirtualScreen1Redraw(Sender: TObject; Bitmap: TBGRABitmap);
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure FormDestroy(Sender: TObject);
|
||||
procedure FormKeyDown(Sender: TObject; var Key: word; {%H-}Shift: TShiftState);
|
||||
procedure FormKeyUp(Sender: TObject; var Key: Word; {%H-}Shift: TShiftState);
|
||||
procedure FormResize(Sender: TObject);
|
||||
procedure Timer2Timer(Sender: TObject);
|
||||
private
|
||||
{ private declarations }
|
||||
procedure UpdateVirtualScreen;
|
||||
public
|
||||
{ public declarations }
|
||||
level1: TGameMap;
|
||||
size: TRect;
|
||||
end;
|
||||
|
||||
var
|
||||
Form1: TForm1;
|
||||
|
||||
implementation
|
||||
|
||||
{$R *.lfm}
|
||||
|
||||
{ TForm1 }
|
||||
|
||||
procedure TForm1.BGRAVirtualScreen1Redraw(Sender: TObject; Bitmap: TBGRABitmap);
|
||||
begin
|
||||
DrawMap(level1, bitmap, True);
|
||||
end;
|
||||
|
||||
procedure TForm1.FormCreate(Sender: TObject);
|
||||
begin
|
||||
Size := Rect(0, 0, 640, 480);
|
||||
ToggleFullScreen(Self, Size);
|
||||
|
||||
level1.mapWidth := 20;
|
||||
level1.mapHeight := 20;
|
||||
level1.mapGraphics :=
|
||||
'000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000X000000000000000000000000000000000000000000000000000000000000000000000000000000';
|
||||
level1.mapProperty :=
|
||||
'2222222222222222222220002020220200022022212022000020020000022020202022002202202220200000200202020002200202200020000220222200220022002020200220200020202220020022202022002002020002022200200000200022000220020200220020002022202220202002202000222000000020200020220222220222002020200002202020200200220220222200002020220000002220202020020222220002202020022000020002022000220000020002000222222222222222222222';
|
||||
level1.mapSolve :=
|
||||
'2222222222222222222220002020220200022022202022000020020000022020202022002202202220200000200202020002200202200020000220222200220022002020200220200020202220020022202022002002020002022200200000200022000220020200220020002022202220202002202000222000000020200020220222220222002020200002202020200200220220222200002020220000002221202020020222220002202020022000020002022000220000020002000222222222222222222222';
|
||||
level1.mapKeyChar := '1'; // Player
|
||||
level1.mapSolidChar := '2'; // Wall
|
||||
level1.ballPositionDefined := false;
|
||||
//see FormResize
|
||||
|
||||
Timer2.Interval:= 16;
|
||||
end;
|
||||
|
||||
procedure TForm1.FormDestroy(Sender: TObject);
|
||||
begin
|
||||
level1.background.Free;
|
||||
level1.ballSphereMap.free;
|
||||
end;
|
||||
|
||||
procedure TForm1.FormKeyDown(Sender: TObject; var Key: word; Shift: TShiftState);
|
||||
begin
|
||||
if (Key = VK_ESCAPE) then
|
||||
Application.Terminate;
|
||||
|
||||
if (Key = VK_F11) then
|
||||
ToggleFullScreen(Self, Size);
|
||||
|
||||
KeyDownMap(level1, Key);
|
||||
end;
|
||||
|
||||
procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
|
||||
begin
|
||||
KeyUpMap(level1, Key);
|
||||
end;
|
||||
|
||||
procedure TForm1.FormResize(Sender: TObject);
|
||||
begin
|
||||
Size := Rect(0, 0, Width, Height);
|
||||
ScaleAspectRatio(BGRAVirtualScreen1, Size.Right, Size.Bottom, True, True, True);
|
||||
|
||||
// this has scaling
|
||||
level1.blockWidth := BGRAVirtualScreen1.Width div level1.mapWidth;
|
||||
level1.blockHeight := BGRAVirtualScreen1.Height div level1.mapHeight;
|
||||
|
||||
// this has scaling
|
||||
level1.background.Free;
|
||||
level1.background := TBGRABitmap.Create('background.jpg');
|
||||
BGRAReplace(level1.background, level1.background.Resample(BGRAVirtualScreen1.Width, BGRAVirtualScreen1.Height));
|
||||
end;
|
||||
|
||||
procedure TForm1.Timer2Timer(Sender: TObject);
|
||||
begin
|
||||
Timer2.Enabled:= false;
|
||||
UpdateVirtualScreen;
|
||||
if IsMapSolved(level1) then
|
||||
begin
|
||||
Timer2.Enabled := False;
|
||||
ShowMessage('Win!');
|
||||
Application.Terminate;
|
||||
end;
|
||||
Timer2.Enabled:= true;
|
||||
end;
|
||||
|
||||
procedure TForm1.UpdateVirtualScreen;
|
||||
begin
|
||||
if Assigned(BGRAVirtualScreen1.Bitmap) then
|
||||
begin
|
||||
DrawMap(level1, BGRAVirtualScreen1.bitmap, false);
|
||||
BGRAVirtualScreen1.Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.BGRAVirtualScreen1MouseDown(Sender: TObject;
|
||||
Button: TMouseButton; Shift: TShiftState; X, Y: integer);
|
||||
begin
|
||||
if Button = mbLeft then
|
||||
MouseDownMap(level1, Point(x, y));
|
||||
end;
|
||||
|
||||
procedure TForm1.BGRAVirtualScreen1MouseMove(Sender: TObject;
|
||||
Shift: TShiftState; X, Y: integer);
|
||||
begin
|
||||
if ssLeft in shift then
|
||||
MouseDownMap(level1, Point(x, y));
|
||||
end;
|
||||
|
||||
procedure TForm1.BGRAVirtualScreen1MouseUp(Sender: TObject;
|
||||
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
||||
begin
|
||||
if Button = mbLeft then
|
||||
MouseUpMap(level1, Point(x, y));
|
||||
end;
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user