Changeset 285 for trunk

Timestamp:

Mar 10, 2019, 11:57:03 PM (6 years ago)

Author:

chronos

Message:

• Modified: More work on item class with defined form fields.

Location:

trunk

Files:

• UItemList.pas (modified) (11 diffs)
• UNation.pas (modified) (5 diffs)
• UPlayer.pas (modified) (7 diffs)

trunk/UItemList.pas

@@ -6 +6 @@
 
 uses
-  Classes, SysUtils, fgl, DOM, UXMLUtils, UCommon;
+  Classes, SysUtils, fgl, DOM, UXMLUtils, UCommon, Graphics;
 
 type
+  TDataType = (dtNone, dtString, dtBoolean, dtInteger, dtFloat, dtColor,
+    dtTime, dtDate, dtDateTime);
 
   TItemField = class
+    SysName: string;
     Name: string;
     Index: Integer;
+    DataType: TDataType;
+    Position: TPoint;
+    Size: TPoint;
   end;
 
@@ -18 +24 @@
 
   TItemFields = class(TFPGObjectList<TItemField>)
-    function AddField(Name: string): TItemField;
+    function AddField(Index: Integer; SysName, Name: string; DataType: TDataType): TItemField;
   end;
 
@@ -24 +30 @@
 
   TItem = class
+  private
+    procedure AssignValue(Source: TItem; Field: TItemField);
+    procedure LoadValueFromNode(Node: TDOMNode; Field: TItemField); virtual;
+    procedure SaveValueToNode(Node: TDOMNode; Field: TItemField); virtual;
+  public
     Id: Integer;
     Name: string;
@@ -32 +43 @@
     procedure LoadFromNode(Node: TDOMNode); virtual;
     procedure SaveToNode(Node: TDOMNode); virtual;
+    class function GetClassSysName: string; virtual;
   end;
 
@@ -40 +52 @@
   TItemList = class(TFPGObjectList<TItem>)
     NewId: Integer;
-    function GetItemClass: TItemClass; virtual;
+    class function GetItemClass: TItemClass; virtual;
     function IncrementName(Name: string): string;
     function GetNextAvailableName(Name: string): string;
@@ -48 +60 @@
     procedure Assign(Source: TItemList); virtual;
     function AddItem(Name: string): TItem; virtual;
+    procedure LoadFromNode(Node: TDOMNode); virtual;
+    procedure SaveToNode(Node: TDOMNode); virtual;
     constructor Create(FreeObjects: Boolean = True);
   end;
@@ -74 +88 @@
 end;
 
+procedure TItemList.LoadFromNode(Node: TDOMNode);
+var
+  Node2: TDOMNode;
+  NewItem: TItem;
+begin
+  Count := 0;
+  Node2 := Node.FirstChild;
+  while Assigned(Node2) and (Node2.NodeName = UnicodeString(GetItemClass.GetClassSysName)) do begin
+    NewItem := GetItemClass.Create;
+    NewItem.LoadFromNode(Node2);
+    Add(NewItem);
+    Node2 := Node2.NextSibling;
+  end;
+end;
+
+procedure TItemList.SaveToNode(Node: TDOMNode);
+var
+  I: Integer;
+  NewNode2: TDOMNode;
+begin
+  for I := 0 to Count - 1 do
+  with TItem(Items[I]) do begin
+    NewNode2 := Node.OwnerDocument.CreateElement(UnicodeString(GetItemClass.GetClassSysName));
+    Node.AppendChild(NewNode2);
+    SaveToNode(NewNode2);
+  end;
+end;
+
 constructor TItemList.Create(FreeObjects: Boolean);
 begin
@@ -80 +122 @@
 end;
 
-function TItemList.GetItemClass: TItemClass;
+class function TItemList.GetItemClass: TItemClass;
 begin
   Result := TItem;
@@ -133 +175 @@
 { TItemFields }
 
-function TItemFields.AddField(Name: string): TItemField;
+function TItemFields.AddField(Index: Integer; SysName, Name: string; DataType: TDataType): TItemField;
 begin
   Result := TItemField.Create;
+  Result.Index := Index;
   Result.Name := Name;
+  Result.SysName := SysName;
+  Result.DataType := DataType;
   Add(Result);
 end;
@@ -142 +187 @@
 { TItem }
 
+procedure TItem.AssignValue(Source: TItem; Field: TItemField);
+var
+  ValueString: string;
+  ValueColor: TColor;
+  ValueInteger: Integer;
+begin
+  if Field.DataType = dtString then begin
+    Source.GetValue(Field.Index, ValueString);
+    SetValue(Field.Index, ValueString);
+  end else
+  if Field.DataType = dtColor then begin
+    Source.GetValue(Field.Index, ValueColor);
+    SetValue(Field.Index, ValueColor);
+  end else
+  if Field.DataType = dtInteger then begin
+    Source.GetValue(Field.Index, ValueInteger);
+    SetValue(Field.Index, ValueInteger);
+  end else
+  raise Exception.Create('Unsupported field value data type');
+end;
+
+procedure TItem.LoadValueFromNode(Node: TDOMNode; Field: TItemField);
+var
+  ValueString: string;
+  ValueColor: TColor;
+  ValueInteger: Integer;
+begin
+  if Field.DataType = dtString then begin
+    ValueString := ReadString(Node, Field.SysName, '');
+    SetValue(Field.Index, ValueString);
+  end else
+  if Field.DataType = dtColor then begin
+    ValueColor := ReadInteger(Node, Field.SysName, 0);
+    SetValue(Field.Index, ValueColor);
+  end else
+  if Field.DataType = dtInteger then begin
+    ValueInteger := ReadInteger(Node, Field.SysName, 0);
+    SetValue(Field.Index, ValueInteger);
+  end else
+  raise Exception.Create('Unsupported field value data type');
+end;
+
+procedure TItem.SaveValueToNode(Node: TDOMNode; Field: TItemField);
+var
+  ValueString: string;
+  ValueColor: TColor;
+  ValueInteger: Integer;
+begin
+  if Field.DataType = dtString then begin
+    GetValue(Field.Index, ValueString);
+    WriteString(Node, Field.SysName, ValueString);
+  end else
+  if Field.DataType = dtColor then begin
+    GetValue(Field.Index, ValueColor);
+    WriteInteger(Node, Field.SysName, ValueColor);
+  end else
+  if Field.DataType = dtInteger then begin
+    GetValue(Field.Index, ValueInteger);
+    WriteInteger(Node, Field.SysName, ValueInteger);
+  end else
+  raise Exception.Create('Unsupported field value data type');
+end;
+
 function TItem.GetFields: TItemFields;
 begin
   Result := TItemFields.Create;
+  Result.AddField(1, 'Name', 'Name', dtString);
 end;
 
@@ -156 +265 @@
 
 procedure TItem.Assign(Source: TItem);
+var
+  I: Integer;
+  Fields: TItemFields;
 begin
   Id := Source.Id;
-  Name := Source.Name;
+  if Source is ClassType then begin
+    Fields := GetFields;
+    try
+      for I := 0 to Fields.Count - 1 do
+        AssignValue(Source, Fields[I]);
+    finally
+      Fields.Free;
+    end;
+  end;
 end;
 
 procedure TItem.LoadFromNode(Node: TDOMNode);
+var
+  Fields: TItemFields;
+  I: Integer;
 begin
   Id := ReadInteger(Node, 'Id', 0);
-  Name := ReadString(Node, 'Name', '');
+  Fields := GetFields;
+  try
+    for I := 0 to Fields.Count - 1 do begin
+      LoadValueFromNode(Node, Fields[I]);
+    end;
+  finally
+    Fields.Free;
+  end;
 end;
 
 procedure TItem.SaveToNode(Node: TDOMNode);
+var
+  Fields: TItemFields;
+  I: Integer;
 begin
   WriteInteger(Node, 'Id', Id);
-  WriteString(Node, 'Name', Name);
+  Fields := GetFields;
+  try
+    for I := 0 to Fields.Count - 1 do begin
+      SaveValueToNode(Node, Fields[I]);
+    end;
+  finally
+    Fields.Free;
+  end;
+end;
+
+class function TItem.GetClassSysName: string;
+begin
+  Result := 'Item';
 end;
 

trunk/UNation.pas

@@ -6 +6 @@
 
 uses
-  Classes, SysUtils, fgl, DOM, UXMLUtils, Graphics, UItemList;
+  Classes, SysUtils, DOM, UXMLUtils, Graphics, UItemList;
 
 type
@@ -17 +17 @@
     procedure GetValue(Index: Integer; out Value); override;
     procedure SetValue(Index: Integer; var Value); override;
-    procedure Assign(Source: TItem); override;
-    procedure LoadFromNode(Node: TDOMNode); override;
-    procedure SaveToNode(Node: TDOMNode); override;
+    class function GetClassSysName: string; override;
   end;
 
@@ -25 +23 @@
 
   TNations = class(TItemList)
-    function GetItemClass: TItemClass; override;
-    procedure LoadFromNode(Node: TDOMNode);
-    procedure SaveToNode(Node: TDOMNode);
-    constructor Create(FreeObjects: Boolean = True);
+    class function GetItemClass: TItemClass; override;
   end;
 
@@ -44 +39 @@
 function TNation.GetFields: TItemFields;
 begin
-  inherited;
-  Result.AddField('Name');
-  Result.AddField('Color');
+  Result := inherited;
+  Result.AddField(2, 'Color', 'Color', dtColor);
 end;
 
 procedure TNation.GetValue(Index: Integer; out Value);
 begin
-  if Index = 0 then string(Value) := Name
-  else if Index = 1 then TColor(Value) := Color
+  if Index = 1 then string(Value) := Name
+  else if Index = 2 then TColor(Value) := Color
   else raise Exception.Create('Unsupported value index ' + IntToStr(Index));
 end;
@@ -58 +52 @@
 procedure TNation.SetValue(Index: Integer; var Value);
 begin
-  if Index = 0 then Name := string(Value)
-  else if Index = 1 then Color := TColor(Value)
+  if Index = 1 then Name := string(Value)
+  else if Index = 2 then Color := TColor(Value)
   else raise Exception.Create('Unsupported value index ' + IntToStr(Index));
 end;
 
-procedure TNation.Assign(Source: TItem);
+class function TNation.GetClassSysName: string;
 begin
-  inherited;
-  Color := TNation(Source).Color;
-end;
-
-procedure TNation.LoadFromNode(Node: TDOMNode);
-begin
-  inherited;
-  Color := ReadInteger(Node, 'Color', 0);
-end;
-
-procedure TNation.SaveToNode(Node: TDOMNode);
-begin
-  inherited;
-  WriteInteger(Node, 'Color', Color);
+  Result := 'Nation';
 end;
 
 { TNations }
 
-function TNations.GetItemClass: TItemClass;
+class function TNations.GetItemClass: TItemClass;
 begin
   Result := TNation;
 end;
 
-procedure TNations.LoadFromNode(Node: TDOMNode);
-var
-  Node2: TDOMNode;
-  NewItem: TNation;
-begin
-  Count := 0;
-  Node2 := Node.FirstChild;
-  while Assigned(Node2) and (Node2.NodeName = 'Nation') do begin
-    NewItem := TNation.Create;
-    NewItem.LoadFromNode(Node2);
-    Add(NewItem);
-    Node2 := Node2.NextSibling;
-  end;
-end;
-
-procedure TNations.SaveToNode(Node: TDOMNode);
-var
-  I: Integer;
-  NewNode2: TDOMNode;
-begin
-  for I := 0 to Count - 1 do
-  with Items[I] do begin
-    NewNode2 := Node.OwnerDocument.CreateElement('Nation');
-    Node.AppendChild(NewNode2);
-    SaveToNode(NewNode2);
-  end;
-end;
-
-constructor TNations.Create(FreeObjects: Boolean);
-begin
-  inherited;
-end;
-
 end.
 

trunk/UPlayer.pas

@@ -7 +7 @@
 uses
   Classes, SysUtils, Graphics, UMap, DOM, fgl, XMLConf, UXMLUtils, Math,
-  UGeometry, UUnit, UNation;
+  UGeometry, UUnit, UNation, UItemList;
 
 type
@@ -92 +92 @@
   { TPlayer }
 
-  TPlayer = class
+  TPlayer = class(TItem)
   private
     FGame: TObject; //TGame;
@@ -104 +104 @@
     procedure SetMode(AValue: TPlayerMode);
   public
-    Id: Integer;
-    Name: string;
     Color: TColor;
     TotalUnits: Integer;
@@ -121 +119 @@
     Units: TUnits;
     Nation: TNation;
+    function GetFields: TItemFields; override;
+    procedure GetValue(Index: Integer; out Value); override;
+    procedure SetValue(Index: Integer; var Value); override;
+    class function GetClassSysName: string; override;
     function IsAllowedMoveTarget(CellFrom, CellTo: TPlayerCell): Boolean;
     procedure ReduceMovesPower;
@@ -135 +137 @@
     function IsAlive: Boolean;
     procedure Clear;
-    procedure LoadFromNode(Node: TDOMNode);
-    procedure SaveToNode(Node: TDOMNode);
+    procedure LoadFromNode(Node: TDOMNode); override;
+    procedure SaveToNode(Node: TDOMNode); override;
     constructor Create;
     destructor Destroy; override;
-    procedure Assign(Source: TPlayer);
+    procedure Assign(Source: TItem); override;
     procedure LoadConfig(Config: TXmlConfig; Path: string);
     procedure SaveConfig(Config: TXmlConfig; Path: string);
@@ -880 +882 @@
 end;
 
-procedure TPlayer.Assign(Source: TPlayer);
+procedure TPlayer.Assign(Source: TItem);
 begin
   Id := Source.Id;
   Name := Source.Name;
-  Color := Source.Color;
-  Mode := Source.Mode;
-  Game := Source.Game;
-  TotalCells := Source.TotalCells;
-  TotalUnits := Source.TotalUnits;
-  TotalCities := Source.TotalCities;
-  TotalDiscovered := Source.TotalDiscovered;
-  TotalWinObjectiveCells := Source.TotalWinObjectiveCells;
-  StartUnits := Source.StartUnits;
-  StartCell := Source.StartCell;
-  Agressivity := Source.Agressivity;
-  Defensive := Source.Defensive;
-  Nation := Source.Nation;
+  Color := TPlayer(Source).Color;
+  Mode := TPlayer(Source).Mode;
+  Game := TPlayer(Source).Game;
+  TotalCells := TPlayer(Source).TotalCells;
+  TotalUnits := TPlayer(Source).TotalUnits;
+  TotalCities := TPlayer(Source).TotalCities;
+  TotalDiscovered := TPlayer(Source).TotalDiscovered;
+  TotalWinObjectiveCells := TPlayer(Source).TotalWinObjectiveCells;
+  StartUnits := TPlayer(Source).StartUnits;
+  StartCell := TPlayer(Source).StartCell;
+  Agressivity := TPlayer(Source).Agressivity;
+  Defensive := TPlayer(Source).Defensive;
+  Nation := TPlayer(Source).Nation;
 end;
 
@@ -1261 +1263 @@
   if FMode = AValue then Exit;
   FMode := AValue;
+end;
+
+function TPlayer.GetFields: TItemFields;
+begin
+  Result := inherited;
+  Result.AddField(2, 'Color', 'Color', dtColor);
+  Result.AddField(3, 'Mode', 'Mode', dtInteger);
+  Result.AddField(4, 'StartUnits', 'StartUnits', dtInteger);
+  Result.AddField(5, 'Agressivity', 'Agressivity', dtInteger);
+  Result.AddField(6, 'Defensive', 'Defensive', dtBoolean);
+end;
+
+procedure TPlayer.GetValue(Index: Integer; out Value);
+begin
+  inherited GetValue(Index, Value);
+end;
+
+procedure TPlayer.SetValue(Index: Integer; var Value);
+begin
+  inherited SetValue(Index, Value);
+end;
+
+class function TPlayer.GetClassSysName: string;
+begin
+  Result := 'Player';
 end;