unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
ComCtrls, ExtCtrls, Menus;
type
TTerrainType = (ttSea, ttGrassland, ttSandy, ttGrasslandLake, ttSandyLake,
ttBeachVert, ttBeachHorz, ttBeachCorner1, ttBeachCorner2, ttError);
type
TObjectType = (otHouse, otFactory, otTrees);
TObjects = set of TObjectType;
const
MapWidth = 7;
MapHeight = 5;
MapX = 160;
MapY = 30;
TileSize = 64;
ImageCount = 12;
HouseImgIndex = 9;
FactoryImgIndex = 10;
TreeImgIndex = 11;
type
{ TForm1 }
TForm1 = class(TForm)
btnLoad1: TButton;
btnLoad2: TButton;
MenuItem1: TMenuItem;
mniCancel: TMenuItem;
mniRemoveAll: TMenuItem;
mniRemoveTrees: TMenuItem;
mniRemoveHouse: TMenuItem;
pnlInfo: TPanel;
pmnRemoveHousePlant: TPopupMenu;
rdgMode: TRadioGroup;
procedure btnLoad1Click(Sender: TObject);
procedure btnLoad2Click(Sender: TObject);
procedure FormClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure FormPaint(Sender: TObject);
procedure mniRemoveAllClick(Sender: TObject);
procedure mniRemoveHouseClick(Sender: TObject);
procedure mniRemoveTreesClick(Sender: TObject);
private
FGameWorld : array[1..MapWidth, 1..MapHeight] of TObjects;
FMapWorld : array[1..MapWidth, 1..MapHeight] of TTerrainType;
FImageData : array of TBitmap;
FMapLoaded : Boolean;
FMouseGridX : Integer;
FMouseGridY : Integer;
function GetTerrain(X, Y: Integer): TTerrainType;
function GetTerrain: TTerrainType; // under mouse pointer position
function GetObjects(X, Y: Integer): TObjects;
function GetObjects: TObjects; // under mouse pointer position
procedure PutObject(X, Y: Integer; AnObject: TObjectType);
procedure PutObject(AnObject: TObjectType); // under mouse pointer position
function MouseInsideViewport: Boolean;
function ObjectOnTerrainRules(AnObject: TObjectType; Terrain: TTerrainType):
string;
function ObjectOnPositionRules(X, Y: Integer; AnObject: TObjectType): string;
function ObjectOnPositionRules(AnObject: TObjectType): string; // under mouse pointer position
procedure LoadImageData;
procedure LoadMap(const MapName: string);
procedure DrawMap;
procedure DrawGameWorld;
procedure FreeAll;
procedure ShowErrorAndQuit(const Info: string);
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.btnLoad1Click(Sender: TObject);
begin
FreeAll;
LoadImageData;
LoadMap('MapBeach.txt');
DrawGameWorld;
Caption := 'Beach';
end;
procedure TForm1.btnLoad2Click(Sender: TObject);
begin
FreeAll;
LoadImageData;
LoadMap('MapGrassy.txt');
DrawGameWorld;
Caption := 'Grassy Land';
end;
procedure TForm1.FormClick(Sender: TObject);
var
Error : string;
S : string;
begin
if not(MouseInsideViewport) or not(FMapLoaded) then Exit;
case rdgMode.ItemIndex of
0: begin
S := 'This location has:' +LineEnding;
if otHouse in GetObjects then S := S + 'a house' +LineEnding;
if otFactory in GetObjects then S := S + 'a factory' +LineEnding;
if otTrees in GetObjects then S := S + 'some tree';
if GetObjects = [] then S := 'Nothing here';
ShowMessage(S);
end;
1: begin
Error := ObjectOnTerrainRules(otHouse, GetTerrain);
if Error = '' then
begin
Error := ObjectOnPositionRules(otHouse);
if Error = '' then PutObject(otHouse);
end;
end;
2: begin
Error := ObjectOnTerrainRules(otFactory, GetTerrain);
if Error = '' then
begin
Error := ObjectOnPositionRules(otFactory);
if Error = '' then PutObject(otFactory);
end;
end;
3: begin
Error := ObjectOnTerrainRules(otTrees, GetTerrain);
if Error = '' then
begin
Error := ObjectOnPositionRules(otTrees);
if Error = '' then PutObject(otTrees);
end;
end;
4: begin
if otFactory in GetObjects then
Exclude(FGameWorld[FMouseGridX+1, FMouseGridY+1], otFactory);
if (otHouse in GetObjects) and (otTrees in GetObjects) then
pmnRemoveHousePlant.PopUp
else
if otHouse in GetObjects then
Exclude(FGameWorld[FMouseGridX+1, FMouseGridY+1], otHouse)
else
if otTrees in GetObjects then
Exclude(FGameWorld[FMouseGridX+1, FMouseGridY+1], otTrees);
end;
end;
if Error <> '' then
ShowMessage(Error)
else
DrawGameWorld;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SetLength(FImageData, 0);
pnlInfo.Align := alBottom;
pnlInfo.BevelOuter := bvNone;
pnlInfo.Caption := '';
FMapLoaded := False;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FreeAll;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
const
LastX : Integer = 0;
LastY : Integer = 0;
begin
FMouseGridX := (X-MapX) div TileSize;
FMouseGridY := (Y-MapY) div TileSize;
if X < MapX then FMouseGridX := -1;
if Y < MapY then FMouseGridY := -1;
if (FMouseGridX = LastX) and (FMouseGridY = LastY) then Exit;
DrawGameWorld;
LastX := FMouseGridX;
LastY := FMouseGridY;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
DrawGameWorld;
end;
procedure TForm1.mniRemoveAllClick(Sender: TObject);
begin
Exclude(FGameWorld[FMouseGridX+1, FMouseGridY+1], otHouse);
Exclude(FGameWorld[FMouseGridX+1, FMouseGridY+1], otTrees);
end;
procedure TForm1.mniRemoveHouseClick(Sender: TObject);
begin
Exclude(FGameWorld[FMouseGridX+1, FMouseGridY+1], otHouse);
end;
procedure TForm1.mniRemoveTreesClick(Sender: TObject);
begin
Exclude(FGameWorld[FMouseGridX+1, FMouseGridY+1], otTrees);
end;
function TForm1.GetTerrain(X, Y: Integer): TTerrainType;
begin
Result := ttError;
if (X < 1) or (Y < 1) or (X > MapWidth) or (Y > MapHeight) then Exit;
Result := FMapWorld[X, Y];
end;
function TForm1.GetTerrain: TTerrainType;
begin
// warning: mouse grid start from 0 but world grid start from 1
Result := GetTerrain(FMouseGridX+1, FMouseGridY+1);
end;
function TForm1.GetObjects(X, Y: Integer): TObjects;
begin
Result := [];
if (X < 1) or (Y < 1) or (X > MapWidth) or (Y > MapHeight) then Exit;
Result := FGameWorld[X, Y];
end;
function TForm1.GetObjects: TObjects;
begin
// warning: mouse grid start from 0 but world grid start from 1
Result := GetObjects(FMouseGridX+1, FMouseGridY+1);
end;
procedure TForm1.PutObject(X, Y: Integer; AnObject: TObjectType);
begin
if (X < 1) or (Y < 1) or (X > MapWidth) or (Y > MapHeight) then Exit;
Include(FGameWorld[X, Y], AnObject);
end;
procedure TForm1.PutObject(AnObject: TObjectType);
begin
// warning: mouse grid start from 0 but world grid start from 1
PutObject(FMouseGridX+1, FMouseGridY+1, AnObject);
end;
function TForm1.MouseInsideViewport: Boolean;
begin
Result := False;
// warning: mouse grid start from 0 but world grid start from 1
if (FMouseGridX >= 0) and (FMouseGridY >= 0) and
(FMouseGridX < MapWidth) and (FMouseGridY < MapHeight) then
Result := True;
end;
function TForm1.ObjectOnTerrainRules(AnObject: TObjectType;
Terrain: TTerrainType): string;
begin
Result := '';
case Terrain of
ttSea: Result := 'Dont''t put anything on sea!';
ttGrassland: Result := '';
ttSandy: if AnObject = otFactory then
Result := 'Factory cannot be built on sandy land.';
ttGrasslandLake,
ttSandyLake: Result := 'Nothing can be put on lake!';
ttBeachVert, ttBeachHorz, ttBeachCorner1, ttBeachCorner2:
if AnObject = otFactory then
Result := 'Beach cannot support factory.';
end;
end;
function TForm1.ObjectOnPositionRules(X, Y: Integer; AnObject: TObjectType
): string;
var
Objects: TObjects;
begin
Result := '';
Objects := GetObjects(X, Y);
case AnObject of
otHouse: begin
if otHouse in Objects then Result := 'It''s already has a house here.';
if otFactory in Objects then Result := 'Please remove the factory first.';
end;
otFactory: begin
if otFactory in Objects then Result := 'It''s already has a factory here.';
if otTrees in Objects then Result := 'Please remove the trees first.';
if otHouse in Objects then Result := 'Please remove the house first.';
end;
otTrees: begin
if otFactory in Objects then Result := 'Cannot plant trees on the location.';
if otTrees in Objects then Result := 'It''s already has some trees here.';
end;
end;
end;
function TForm1.ObjectOnPositionRules(AnObject: TObjectType): string;
begin
// warning: mouse grid start from 0 but world grid start from 1
Result := ObjectOnPositionRules(FMouseGridX+1, FMouseGridY+1, AnObject);
end;
procedure TForm1.LoadImageData;
var
S: string;
i: Integer;
begin
FreeAll;
SetLength(FImageData, ImageCount);
// Load terrain images
for i := 1 to 9 do
begin
S := 'terrain0' + i.ToString+'.bmp' ;
if not(FileExists(S)) then ShowErrorAndQuit('File ' + S + ' missing!');
FImageData[i-1] := TBitmap.Create;
FImageData[i-1].LoadFromFile(S);
end;
// Load house image
S := 'house.bmp' ;
if not(FileExists(S)) then ShowErrorAndQuit('File ' + S + ' missing!');
FImageData[HouseImgIndex] := TBitmap.Create;
FImageData[HouseImgIndex].LoadFromFile(S);
// Load factory image
S := 'factory.bmp' ;
if not(FileExists(S)) then ShowErrorAndQuit('File ' + S + ' missing!');
FImageData[FactoryImgIndex] := TBitmap.Create;
FImageData[FactoryImgIndex].LoadFromFile(S);
// Load trees image
S := 'trees.bmp' ;
if not(FileExists(S)) then ShowErrorAndQuit('File ' + S + ' missing!');
FImageData[TreeImgIndex] := TBitmap.Create;
FImageData[TreeImgIndex].LoadFromFile(S);
end;
procedure TForm1.LoadMap(const MapName: string);
var
MapFile : TextFile;
S : string;
X, Y : Integer;
begin
if not(FileExists(MapName)) then
ShowErrorAndQuit('Map file ' + MapName + ' not found.');
AssignFile(MapFile, MapName);
Reset(MapFile);
for Y := 1 to MapHeight do
begin
ReadLn(MapFile, S);
for X := 1 to MapWidth do
FMapWorld[X, Y] := TTerrainType(Ord(S[X])-Ord('1'));
end;
CloseFile(MapFile);
FMapLoaded := True;
end;
procedure TForm1.DrawMap;
var
Terrain : TTerrainType;
SRect : TRect;
DRect : TRect;
X, Y : Integer;
begin
// Draw terrain
for Y := 1 to MapHeight do
for X := 1 to MapWidth do
begin
SRect := Rect(0, 0, TileSize, TileSize);
with DRect do
begin
Left := MapX + (X-1)*TileSize;
Top := MapY + (Y-1)*TileSize;
Width := TileSize;
Height := TileSize;
end;
Terrain := FMapWorld[X, Y];
if (Terrain >= Low(Terrain)) and (Terrain <= High(Terrain)) then
Canvas.CopyRect(DRect, FImageData[Ord(Terrain)].Canvas, SRect)
else
ShowErrorAndQuit('Map data error!.');
end;
// Draw selected grid
if not(MouseInsideViewport) then
begin
pnlInfo.Caption := '';
Exit;
end;
with DRect do
begin
Left := MapX + (FMouseGridX)*TileSize;
Top := MapY + (FMouseGridY)*TileSize;
Width := TileSize;
Height := TileSize;
end;
Canvas.Pen.Color := clRed;
Canvas.Brush.Color := clNone;
Canvas.DrawFocusRect(DRect);
// Show info
case GetTerrain(FMouseGridX+1, FMouseGridY+1) of
ttSea: pnlInfo.Caption := 'Sea';
ttGrassland: pnlInfo.Caption := 'Grassland';
ttSandy: pnlInfo.Caption := 'Sandy';
ttGrasslandLake: pnlInfo.Caption := 'Lake';
ttSandyLake: pnlInfo.Caption := 'Lake';
ttBeachVert: pnlInfo.Caption := 'Beach';
ttBeachHorz: pnlInfo.Caption := 'Beach';
ttBeachCorner1: pnlInfo.Caption := 'Beach';
ttBeachCorner2: pnlInfo.Caption := 'Beach';
ttError: ShowErrorAndQuit('Terrain Error!');
end;
end;
procedure TForm1.DrawGameWorld;
var
Objects : TObjects;
SRect : TRect;
DRect : TRect;
X, Y : Integer;
begin
if not(FMapLoaded) then Exit;
DrawMap;
// Draw all objects
for Y := 1 to MapHeight do
for X := 1 to MapWidth do
begin
SRect := Rect(0, 0, TileSize, TileSize);
with DRect do
begin
Left := MapX + (X-1)*TileSize;
Top := MapY + (Y-1)*TileSize;
Width := TileSize;
Height := TileSize;
end;
Objects := FGameWorld[X, Y];
// z-order
if otTrees in Objects then
Canvas.CopyRect(DRect, FImageData[TreeImgIndex].Canvas, SRect);
if otFactory in Objects then
Canvas.CopyRect(DRect, FImageData[FactoryImgIndex].Canvas, SRect);
if otHouse in Objects then
Canvas.CopyRect(DRect, FImageData[HouseImgIndex].Canvas, SRect);
end;
end;
procedure TForm1.FreeAll;
var
i, j: Integer;
begin
// Free loaded images
for i := 0 to Length(FImageData)-1 do
FImageData[i].Free;
SetLength(FImageData, 0);
// Clear game world
for i := 1 to MapHeight do
for j := 1 to MapWidth do
FGameWorld[j, i] := [];
end;
procedure TForm1.ShowErrorAndQuit(const Info: string);
begin
ShowMessage(Info);
FreeAll;
Halt;
end;
end.