Recent

Author Topic: Persisten and accessible TRect tiles  (Read 4212 times)

Handoko

  • Hero Member
  • *****
  • Posts: 3773
  • My goal: build my own game engine using Lazarus
Re: Persisten and accessible TRect tiles
« Reply #15 on: January 24, 2019, 02:51:45 pm »
Here is my demo, showing how to:
- Load and draw map
- How to check rules for object placing
- Add/remove house, factory and trees

The map data is saved as text file. Here is the example:
1622223
1622335
1642333
1622222
1877777


Code: Pascal  [Select][+][-]
  1. unit Unit1;
  2.  
  3. {$mode objfpc}{$H+}
  4.  
  5. interface
  6.  
  7. uses
  8.   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  9.   ComCtrls, ExtCtrls, Menus;
  10.  
  11. type
  12.   TTerrainType = (ttSea, ttGrassland, ttSandy, ttGrasslandLake, ttSandyLake,
  13.     ttBeachVert, ttBeachHorz, ttBeachCorner1, ttBeachCorner2, ttError);
  14.  
  15. type
  16.   TObjectType = (otHouse, otFactory, otTrees);
  17.   TObjects    = set of TObjectType;
  18.  
  19. const
  20.   MapWidth        = 7;
  21.   MapHeight       = 5;
  22.   MapX            = 160;
  23.   MapY            = 30;
  24.   TileSize        = 64;
  25.   ImageCount      = 12;
  26.   HouseImgIndex   = 9;
  27.   FactoryImgIndex = 10;
  28.   TreeImgIndex    = 11;
  29.  
  30. type
  31.  
  32.   { TForm1 }
  33.  
  34.   TForm1 = class(TForm)
  35.     btnLoad1: TButton;
  36.     btnLoad2: TButton;
  37.     MenuItem1: TMenuItem;
  38.     mniCancel: TMenuItem;
  39.     mniRemoveAll: TMenuItem;
  40.     mniRemoveTrees: TMenuItem;
  41.     mniRemoveHouse: TMenuItem;
  42.     pnlInfo: TPanel;
  43.     pmnRemoveHousePlant: TPopupMenu;
  44.     rdgMode: TRadioGroup;
  45.     procedure btnLoad1Click(Sender: TObject);
  46.     procedure btnLoad2Click(Sender: TObject);
  47.     procedure FormClick(Sender: TObject);
  48.     procedure FormCreate(Sender: TObject);
  49.     procedure FormDestroy(Sender: TObject);
  50.     procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  51.     procedure FormPaint(Sender: TObject);
  52.     procedure mniRemoveAllClick(Sender: TObject);
  53.     procedure mniRemoveHouseClick(Sender: TObject);
  54.     procedure mniRemoveTreesClick(Sender: TObject);
  55.   private
  56.     FGameWorld  : array[1..MapWidth, 1..MapHeight] of TObjects;
  57.     FMapWorld   : array[1..MapWidth, 1..MapHeight] of TTerrainType;
  58.     FImageData  : array of TBitmap;
  59.     FMapLoaded  : Boolean;
  60.     FMouseGridX : Integer;
  61.     FMouseGridY : Integer;
  62.     function  GetTerrain(X, Y: Integer): TTerrainType;
  63.     function  GetTerrain: TTerrainType;         // under mouse pointer position
  64.     function  GetObjects(X, Y: Integer): TObjects;
  65.     function  GetObjects: TObjects;             // under mouse pointer position
  66.     procedure PutObject(X, Y: Integer; AnObject: TObjectType);
  67.     procedure PutObject(AnObject: TObjectType); // under mouse pointer position
  68.     function  MouseInsideViewport: Boolean;
  69.     function  ObjectOnTerrainRules(AnObject: TObjectType; Terrain: TTerrainType):
  70.                 string;
  71.     function  ObjectOnPositionRules(X, Y: Integer; AnObject: TObjectType): string;
  72.     function  ObjectOnPositionRules(AnObject: TObjectType): string;  // under mouse pointer position
  73.     procedure LoadImageData;
  74.     procedure LoadMap(const MapName: string);
  75.     procedure DrawMap;
  76.     procedure DrawGameWorld;
  77.     procedure FreeAll;
  78.     procedure ShowErrorAndQuit(const Info: string);
  79.   end;
  80.  
  81. var
  82.   Form1: TForm1;
  83.  
  84. implementation
  85.  
  86. {$R *.lfm}
  87.  
  88. { TForm1 }
  89.  
  90. procedure TForm1.btnLoad1Click(Sender: TObject);
  91. begin
  92.   FreeAll;
  93.   LoadImageData;
  94.   LoadMap('MapBeach.txt');
  95.   DrawGameWorld;
  96.   Caption := 'Beach';
  97. end;
  98.  
  99. procedure TForm1.btnLoad2Click(Sender: TObject);
  100. begin
  101.   FreeAll;
  102.   LoadImageData;
  103.   LoadMap('MapGrassy.txt');
  104.   DrawGameWorld;
  105.   Caption := 'Grassy Land';
  106. end;
  107.  
  108. procedure TForm1.FormClick(Sender: TObject);
  109. var
  110.   Error : string;
  111.   S     : string;
  112. begin
  113.   if not(MouseInsideViewport) or not(FMapLoaded) then Exit;
  114.   case rdgMode.ItemIndex of
  115.     0: begin
  116.       S := 'This location has:' +LineEnding;
  117.       if otHouse in GetObjects then   S := S + 'a house'   +LineEnding;
  118.       if otFactory in GetObjects then S := S + 'a factory' +LineEnding;
  119.       if otTrees in GetObjects then   S := S + 'some tree';
  120.       if GetObjects = [] then         S := 'Nothing here';
  121.       ShowMessage(S);
  122.       end;
  123.     1: begin
  124.       Error := ObjectOnTerrainRules(otHouse, GetTerrain);
  125.       if Error = '' then
  126.       begin
  127.         Error := ObjectOnPositionRules(otHouse);
  128.         if Error = '' then PutObject(otHouse);
  129.       end;
  130.     end;
  131.     2: begin
  132.       Error := ObjectOnTerrainRules(otFactory, GetTerrain);
  133.       if Error = '' then
  134.       begin
  135.         Error := ObjectOnPositionRules(otFactory);
  136.         if Error = '' then PutObject(otFactory);
  137.       end;
  138.     end;
  139.     3: begin
  140.       Error := ObjectOnTerrainRules(otTrees, GetTerrain);
  141.       if Error = '' then
  142.       begin
  143.         Error := ObjectOnPositionRules(otTrees);
  144.         if Error = '' then PutObject(otTrees);
  145.       end;
  146.     end;
  147.     4: begin
  148.       if otFactory in GetObjects then
  149.         Exclude(FGameWorld[FMouseGridX+1, FMouseGridY+1], otFactory);
  150.       if (otHouse in GetObjects) and (otTrees in GetObjects) then
  151.         pmnRemoveHousePlant.PopUp
  152.       else
  153.         if otHouse in GetObjects then
  154.           Exclude(FGameWorld[FMouseGridX+1, FMouseGridY+1], otHouse)
  155.         else
  156.           if otTrees in GetObjects then
  157.             Exclude(FGameWorld[FMouseGridX+1, FMouseGridY+1], otTrees);
  158.     end;
  159.   end;
  160.   if Error <> '' then
  161.     ShowMessage(Error)
  162.   else
  163.     DrawGameWorld;
  164. end;
  165.  
  166. procedure TForm1.FormCreate(Sender: TObject);
  167. begin
  168.   SetLength(FImageData, 0);
  169.   pnlInfo.Align      := alBottom;
  170.   pnlInfo.BevelOuter := bvNone;
  171.   pnlInfo.Caption    := '';
  172.   FMapLoaded         := False;
  173. end;
  174.  
  175. procedure TForm1.FormDestroy(Sender: TObject);
  176. begin
  177.   FreeAll;
  178. end;
  179.  
  180. procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  181.   Y: Integer);
  182. const
  183.   LastX : Integer = 0;
  184.   LastY : Integer = 0;
  185. begin
  186.  
  187.   FMouseGridX := (X-MapX) div TileSize;
  188.   FMouseGridY := (Y-MapY) div TileSize;
  189.   if X < MapX then FMouseGridX := -1;
  190.   if Y < MapY then FMouseGridY := -1;
  191.  
  192.   if (FMouseGridX = LastX) and (FMouseGridY = LastY) then Exit;
  193.   DrawGameWorld;
  194.   LastX := FMouseGridX;
  195.   LastY := FMouseGridY;
  196.  
  197. end;
  198.  
  199. procedure TForm1.FormPaint(Sender: TObject);
  200. begin
  201.   DrawGameWorld;
  202. end;
  203.  
  204. procedure TForm1.mniRemoveAllClick(Sender: TObject);
  205. begin
  206.   Exclude(FGameWorld[FMouseGridX+1, FMouseGridY+1], otHouse);
  207.   Exclude(FGameWorld[FMouseGridX+1, FMouseGridY+1], otTrees);
  208. end;
  209.  
  210. procedure TForm1.mniRemoveHouseClick(Sender: TObject);
  211. begin
  212.   Exclude(FGameWorld[FMouseGridX+1, FMouseGridY+1], otHouse);
  213. end;
  214.  
  215. procedure TForm1.mniRemoveTreesClick(Sender: TObject);
  216. begin
  217.   Exclude(FGameWorld[FMouseGridX+1, FMouseGridY+1], otTrees);
  218. end;
  219.  
  220. function TForm1.GetTerrain(X, Y: Integer): TTerrainType;
  221. begin
  222.   Result := ttError;
  223.   if (X < 1) or (Y < 1) or (X > MapWidth) or (Y > MapHeight) then Exit;
  224.   Result := FMapWorld[X, Y];
  225. end;
  226.  
  227. function TForm1.GetTerrain: TTerrainType;
  228. begin
  229.   // warning: mouse grid start from 0 but world grid start from 1
  230.   Result := GetTerrain(FMouseGridX+1, FMouseGridY+1);
  231. end;
  232.  
  233. function TForm1.GetObjects(X, Y: Integer): TObjects;
  234. begin
  235.   Result := [];
  236.   if (X < 1) or (Y < 1) or (X > MapWidth) or (Y > MapHeight) then Exit;
  237.   Result := FGameWorld[X, Y];
  238. end;
  239.  
  240. function TForm1.GetObjects: TObjects;
  241. begin
  242.   // warning: mouse grid start from 0 but world grid start from 1
  243.   Result := GetObjects(FMouseGridX+1, FMouseGridY+1);
  244. end;
  245.  
  246. procedure TForm1.PutObject(X, Y: Integer; AnObject: TObjectType);
  247. begin
  248.   if (X < 1) or (Y < 1) or (X > MapWidth) or (Y > MapHeight) then Exit;
  249.   Include(FGameWorld[X, Y], AnObject);
  250. end;
  251.  
  252. procedure TForm1.PutObject(AnObject: TObjectType);
  253. begin
  254.   // warning: mouse grid start from 0 but world grid start from 1
  255.   PutObject(FMouseGridX+1, FMouseGridY+1, AnObject);
  256. end;
  257.  
  258. function TForm1.MouseInsideViewport: Boolean;
  259. begin
  260.   Result := False;
  261.  
  262.   // warning: mouse grid start from 0 but world grid start from 1
  263.   if (FMouseGridX >= 0) and (FMouseGridY >= 0) and
  264.     (FMouseGridX < MapWidth) and (FMouseGridY < MapHeight) then
  265.       Result := True;
  266. end;
  267.  
  268. function TForm1.ObjectOnTerrainRules(AnObject: TObjectType;
  269.   Terrain: TTerrainType): string;
  270. begin
  271.   Result := '';
  272.   case Terrain of
  273.     ttSea:           Result := 'Dont''t put anything on sea!';
  274.     ttGrassland:     Result := '';
  275.     ttSandy:         if AnObject = otFactory then
  276.                        Result := 'Factory cannot be built on sandy land.';
  277.     ttGrasslandLake,
  278.     ttSandyLake:     Result := 'Nothing can be put on lake!';
  279.     ttBeachVert, ttBeachHorz, ttBeachCorner1, ttBeachCorner2:
  280.                      if AnObject = otFactory then
  281.                        Result := 'Beach cannot support factory.';
  282.   end;
  283. end;
  284.  
  285. function TForm1.ObjectOnPositionRules(X, Y: Integer; AnObject: TObjectType
  286.   ): string;
  287. var
  288.   Objects: TObjects;
  289. begin
  290.   Result  := '';
  291.   Objects := GetObjects(X, Y);
  292.   case AnObject of
  293.     otHouse: begin
  294.       if otHouse in Objects then   Result := 'It''s already has a house here.';
  295.       if otFactory in Objects then Result := 'Please remove the factory first.';
  296.     end;
  297.     otFactory: begin
  298.       if otFactory in Objects then Result := 'It''s already has a factory here.';
  299.       if otTrees in Objects then   Result := 'Please remove the trees first.';
  300.       if otHouse in Objects then   Result := 'Please remove the house first.';
  301.     end;
  302.     otTrees: begin
  303.       if otFactory in Objects then Result := 'Cannot plant trees on the location.';
  304.       if otTrees in Objects then   Result := 'It''s already has some trees here.';
  305.     end;
  306.   end;
  307. end;
  308.  
  309. function TForm1.ObjectOnPositionRules(AnObject: TObjectType): string;
  310. begin
  311.   // warning: mouse grid start from 0 but world grid start from 1
  312.   Result := ObjectOnPositionRules(FMouseGridX+1, FMouseGridY+1, AnObject);
  313. end;
  314.  
  315. procedure TForm1.LoadImageData;
  316. var
  317.   S: string;
  318.   i: Integer;
  319. begin
  320.  
  321.   FreeAll;
  322.   SetLength(FImageData, ImageCount);
  323.  
  324.   // Load terrain images
  325.   for i := 1 to 9 do
  326.   begin
  327.     S := 'terrain0' + i.ToString+'.bmp' ;
  328.     if not(FileExists(S)) then ShowErrorAndQuit('File ' + S + ' missing!');
  329.     FImageData[i-1] := TBitmap.Create;
  330.     FImageData[i-1].LoadFromFile(S);
  331.   end;
  332.  
  333.   // Load house image
  334.   S := 'house.bmp' ;
  335.   if not(FileExists(S)) then ShowErrorAndQuit('File ' + S + ' missing!');
  336.   FImageData[HouseImgIndex] := TBitmap.Create;
  337.   FImageData[HouseImgIndex].LoadFromFile(S);
  338.  
  339.   // Load factory image
  340.   S := 'factory.bmp' ;
  341.   if not(FileExists(S)) then ShowErrorAndQuit('File ' + S + ' missing!');
  342.   FImageData[FactoryImgIndex] := TBitmap.Create;
  343.   FImageData[FactoryImgIndex].LoadFromFile(S);
  344.  
  345.   // Load trees image
  346.   S := 'trees.bmp' ;
  347.   if not(FileExists(S)) then ShowErrorAndQuit('File ' + S + ' missing!');
  348.   FImageData[TreeImgIndex] := TBitmap.Create;
  349.   FImageData[TreeImgIndex].LoadFromFile(S);
  350.  
  351. end;
  352.  
  353. procedure TForm1.LoadMap(const MapName: string);
  354. var
  355.   MapFile  : TextFile;
  356.   S       : string;
  357.   X, Y    : Integer;
  358. begin
  359.  
  360.   if not(FileExists(MapName)) then
  361.     ShowErrorAndQuit('Map file ' + MapName + ' not found.');
  362.  
  363.   AssignFile(MapFile, MapName);
  364.   Reset(MapFile);
  365.   for Y := 1 to MapHeight do
  366.   begin
  367.     ReadLn(MapFile, S);
  368.     for X := 1 to MapWidth do
  369.       FMapWorld[X, Y] := TTerrainType(Ord(S[X])-Ord('1'));
  370.   end;
  371.   CloseFile(MapFile);
  372.  
  373.   FMapLoaded := True;
  374.  
  375. end;
  376.  
  377. procedure TForm1.DrawMap;
  378. var
  379.   Terrain : TTerrainType;
  380.   SRect   : TRect;
  381.   DRect   : TRect;
  382.   X, Y    : Integer;
  383. begin
  384.  
  385.   // Draw terrain
  386.   for Y := 1 to MapHeight do
  387.     for X := 1 to MapWidth do
  388.     begin
  389.       SRect := Rect(0, 0, TileSize, TileSize);
  390.       with DRect do
  391.       begin
  392.         Left   := MapX + (X-1)*TileSize;
  393.         Top    := MapY + (Y-1)*TileSize;
  394.         Width  := TileSize;
  395.         Height := TileSize;
  396.       end;
  397.       Terrain := FMapWorld[X, Y];
  398.       if (Terrain >= Low(Terrain)) and (Terrain <= High(Terrain)) then
  399.         Canvas.CopyRect(DRect, FImageData[Ord(Terrain)].Canvas, SRect)
  400.       else
  401.         ShowErrorAndQuit('Map data error!.');
  402.     end;
  403.  
  404.   // Draw selected grid
  405.   if not(MouseInsideViewport) then
  406.   begin
  407.     pnlInfo.Caption := '';
  408.     Exit;
  409.   end;
  410.   with DRect do
  411.   begin
  412.     Left   := MapX + (FMouseGridX)*TileSize;
  413.     Top    := MapY + (FMouseGridY)*TileSize;
  414.     Width  := TileSize;
  415.     Height := TileSize;
  416.   end;
  417.   Canvas.Pen.Color   := clRed;
  418.   Canvas.Brush.Color := clNone;
  419.   Canvas.DrawFocusRect(DRect);
  420.  
  421.   // Show info
  422.   case GetTerrain(FMouseGridX+1, FMouseGridY+1) of
  423.     ttSea:           pnlInfo.Caption := 'Sea';
  424.     ttGrassland:     pnlInfo.Caption := 'Grassland';
  425.     ttSandy:         pnlInfo.Caption := 'Sandy';
  426.     ttGrasslandLake: pnlInfo.Caption := 'Lake';
  427.     ttSandyLake:     pnlInfo.Caption := 'Lake';
  428.     ttBeachVert:     pnlInfo.Caption := 'Beach';
  429.     ttBeachHorz:     pnlInfo.Caption := 'Beach';
  430.     ttBeachCorner1:  pnlInfo.Caption := 'Beach';
  431.     ttBeachCorner2:  pnlInfo.Caption := 'Beach';
  432.     ttError:         ShowErrorAndQuit('Terrain Error!');
  433.   end;
  434.  
  435. end;
  436.  
  437. procedure TForm1.DrawGameWorld;
  438. var
  439.   Objects : TObjects;
  440.   SRect   : TRect;
  441.   DRect   : TRect;
  442.   X, Y    : Integer;
  443. begin
  444.  
  445.   if not(FMapLoaded) then Exit;
  446.  
  447.   DrawMap;
  448.  
  449.   // Draw all objects
  450.   for Y := 1 to MapHeight do
  451.     for X := 1 to MapWidth do
  452.     begin
  453.       SRect := Rect(0, 0, TileSize, TileSize);
  454.       with DRect do
  455.       begin
  456.         Left   := MapX + (X-1)*TileSize;
  457.         Top    := MapY + (Y-1)*TileSize;
  458.         Width  := TileSize;
  459.         Height := TileSize;
  460.       end;
  461.       Objects := FGameWorld[X, Y];
  462.  
  463.       // z-order
  464.       if otTrees in Objects then
  465.         Canvas.CopyRect(DRect, FImageData[TreeImgIndex].Canvas, SRect);
  466.       if otFactory in Objects then
  467.         Canvas.CopyRect(DRect, FImageData[FactoryImgIndex].Canvas, SRect);
  468.       if otHouse in Objects then
  469.         Canvas.CopyRect(DRect, FImageData[HouseImgIndex].Canvas, SRect);
  470.  
  471.     end;
  472. end;
  473.  
  474. procedure TForm1.FreeAll;
  475. var
  476.   i, j: Integer;
  477. begin
  478.  
  479.   // Free loaded images
  480.   for i := 0 to Length(FImageData)-1 do
  481.     FImageData[i].Free;
  482.   SetLength(FImageData, 0);
  483.  
  484.   // Clear game world
  485.   for i := 1 to MapHeight do
  486.     for j := 1 to MapWidth do
  487.       FGameWorld[j, i] := [];
  488.  
  489. end;
  490.  
  491. procedure TForm1.ShowErrorAndQuit(const Info: string);
  492. begin
  493.   ShowMessage(Info);
  494.   FreeAll;
  495.   Halt;
  496. end;
  497.  
  498. end.

  • Line #12 is the available terrain types.
  • Line #16 is the objects you can be put on the grid.
  • Line #17 we use set because a single grid can be occupied by several objects, for example a house and some trees behind it.
  • Line #56 each grid of the game world can has several objects.
  • Line #57 this is the terrain layer.
  • Line #177 always free all requested memory space before exit.
  • Line #180 calculate FMouseGridX, FMouseGridY and call DrawGameWorld if needed.
  • Line #268 this is the rules for object - terrain placement.
  • Line #285 this rules are for multiple objects occupying same grid.

The rules of object placement are coded in ObjectOnTerrainRules and ObjectOnPositionRules. For future development, it is easier if you use save the rules in an external file and loaded it into an array.

You've already built random map generator. But to make it more powerful you need to make it able to do terrain transition. For example: land > beach > sea.

When removing grid that contains multiple objects, a pop up menu will show up. If you want to do object select by using mouse directly on the object, here is an advanced tutorial by @Mr.Madguy:
http://forum.lazarus.freepascal.org/index.php/topic,36871.msg246302.html#msg246302
« Last Edit: January 24, 2019, 03:02:29 pm by Handoko »

TomTom

  • Full Member
  • ***
  • Posts: 115
Re: Persisten and accessible TRect tiles
« Reply #16 on: January 24, 2019, 03:02:21 pm »
:) This looks so clean :) I like it :) and I'll definitely check Your code :)
I've also added possibility to add 'buildings' to my map :) ... Kind of :). For now it's just painting rectangle on a tile. I also added restrictions, so player can't place factory on water :) I think I know what I'm doing and what and how to do other stuff. Maybe my code won't look as nice as Yours but this is my first game in FreePascal :)

Thank You Handoko once again :)

I'll look into Your code later... Now I need to take my car to the mechanic :S


 

TinyPortal © 2005-2018