source: trunk/ItemList.pas

unit ItemList;

interface

uses
  Classes, SysUtils, Generics.Collections, DOM, XML, Common, Graphics, Math;

type
  TItemList = class;
  TUndefinedEnum = (eeNone);

  TDataType = (dtNone, dtString, dtBoolean, dtInteger, dtFloat, dtColor,
    dtTime, dtDate, dtDateTime, dtEnumeration, dtReference);

  { TItemField }

  TItemField = class
    SysName: string;
    Name: string;
    Index: Integer;
    DataType: TDataType;
    Position: TPoint;
    Size: TPoint;
    EnumStates: TStringList;
    VisibleIfIndex: Integer;
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TItemField);
  end;

  { TItemFields }

  TItemFields = class(TObjectList<TItemField>)
    function AddField(Index: Integer; SysName, Name: string; DataType: TDataType): TItemField;
    function SearchByIndex(Index: Integer): TItemField;
  end;

  { TItem }

  TItem = class
  private
    procedure AssignValue(Source: TItem; Field: TItemField);
    function CompareValue(Item: TItem; Field: TItemField): Boolean;
    procedure LoadValueFromNode(Node: TDOMNode; Field: TItemField); virtual;
    procedure SaveValueToNode(Node: TDOMNode; Field: TItemField); virtual;
  public
    Id: Integer;
    Name: string;
    class function GetFields: TItemFields; virtual;
    function GetField(Index: Integer): TItemField;
    procedure GetValue(Index: Integer; out Value); virtual;
    function GetValueInteger(Index: Integer): Integer;
    function GetValueString(Index: Integer): string;
    function GetValueColor(Index: Integer): TColor;
    function GetValueBoolean(Index: Integer): Boolean;
    function GetValueEnumeration(Index: Integer): TUndefinedEnum;
    function GetValueReference(Index: Integer): TItem;
    function GetValueAsText(Index: Integer): string;
    procedure SetValue(Index: Integer; var Value); virtual;
    procedure SetValueInteger(Index: Integer; Value: Integer);
    procedure SetValueString(Index: Integer; Value: string);
    procedure SetValueColor(Index: Integer; Value: TColor);
    procedure SetValueBoolean(Index: Integer; Value: Boolean);
    procedure SetValueEnumeration(Index: Integer; Value: TUndefinedEnum);
    procedure SetValueReference(Index: Integer; Value: TItem);
    procedure Assign(Source: TItem); virtual;
    function Compare(Item: TItem): Boolean; virtual;
    function ToString: string; override;
    procedure LoadFromNode(Node: TDOMNode); virtual;
    procedure SaveToNode(Node: TDOMNode); virtual;
    class function GetClassSysName: string; virtual;
    class function GetClassName: string; virtual;
    function GetReferenceList(Index: Integer): TItemList; virtual;
    constructor Create; virtual;
  end;

  TItemClass = class of TItem;

  { TItemList }

  TItemList = class(TObjectList<TItem>)
  private
    procedure RecalculateNewId(Reset: Boolean);
    procedure RecalculateItemsId;
  public
    NewId: Integer;
    class function GetItemClass: TItemClass; virtual;
    function IncrementName(Name: string): string;
    function GetNextAvailableName(Name: string): string;
    function FindById(Id: Integer): TItem;
    function FindByName(Name: string): TItem;
    function GetNewId: Integer;
    function ToString: string; override;
    procedure Assign(Source: TItemList); virtual;
    function Compare(ItemList: TItemList): Boolean; virtual;
    function AddItem(Name: string = ''): TItem; virtual;
    function CreateItem(Name: string = ''): TItem; virtual;
    procedure LoadFromNode(Node: TDOMNode); virtual;
    procedure SaveToNode(Node: TDOMNode); virtual;
    constructor Create(FreeObjects: Boolean = True);
  end;

const
  DataTypeStr: array[TDataType] of string = ('None', 'String', 'Boolean',
    'Integer', 'Float', 'Color', 'Time', 'Date', 'DateTime', 'Enumeration',
    'Reference');

resourcestring
  SUnsupportedDataType = 'Unsupported field value data type %s';
  SUnsupportedValueIndex = 'Unsupported value index %d';


implementation

resourcestring
  SYes = 'Yes';
  SNo = 'No';
  SItem = 'Item';
  SName = 'Name';

{ TItemField }

constructor TItemField.Create;
begin
  EnumStates := TStringList.Create;
end;

destructor TItemField.Destroy;
begin
  FreeAndNil(EnumStates);
  inherited;
end;

procedure TItemField.Assign(Source: TItemField);
begin
  SysName := Source.SysName;
  Name := Source.Name;
  Index := Source.Index;
  DataType := Source.DataType;
  Position := Source.Position;
  Size := Source.Size;
  EnumStates.Assign(Source.EnumStates);
end;

{ TItemList }

procedure TItemList.Assign(Source: TItemList);
var
  I: Integer;
begin
  while Count > Source.Count do Delete(Count - 1);
  while Count < Source.Count do AddItem('');
  for I := 0 to Count - 1 do
    TItem(Items[I]).Assign(Source.Items[I]);
end;

function TItemList.Compare(ItemList: TItemList): Boolean;
var
  I: Integer;
begin
  Result := Count = ItemList.Count;
  if not Result then Exit;
  for I := 0 to Count - 1 do begin
    Result := Result and TItem(Items[I]).Compare(ItemList.Items[I]);
    if not Result then Break;
  end;
end;

function TItemList.AddItem(Name: string): TItem;
begin
  Result := CreateItem(Name);
  Result.Id := GetNewId;
  Add(Result);
end;

function TItemList.CreateItem(Name: string): TItem;
begin
  Result := GetItemClass.Create;
  Result.Name := Name;
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 := CreateItem;
    NewItem.LoadFromNode(Node2);
    Add(NewItem);
    Node2 := Node2.NextSibling;
  end;
end;

procedure TItemList.SaveToNode(Node: TDOMNode);
var
  I: Integer;
  NewNode2: TDOMNode;
begin
  RecalculateItemsId;
  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
  inherited;
  NewId := 1;
end;

procedure TItemList.RecalculateNewId(Reset: Boolean);
var
  I: Integer;
begin
  NewId := 1;
  for I := 0 to Count - 1 do
  with TItem(Items[I]) do begin
    NewId := Max(NewId, Id + 1);
  end;
end;

procedure TItemList.RecalculateItemsId;
var
  I: Integer;
begin
  for I := 0 to Count - 1 do
    Items[I].Id := I + 1;
  NewId := Count + 1;
end;

class function TItemList.GetItemClass: TItemClass;
begin
  Result := TItem;
end;

function TItemList.IncrementName(Name: string): string;
var
  I: Integer;
  Num: Integer;
begin
  I := LastPos(' ', Name);
  if I > 0 then begin
    if TryStrToInt(Copy(Name, I + 1, Length(Name)), Num) then
      Result := Trim(Copy(Name, 1, I - 1)) + ' ' + IntToStr(Num + 1)
    else Result := Name + ' 2';
  end else Result := Name + ' 2';
end;

function TItemList.GetNextAvailableName(Name: string): string;
begin
  Result := Name;
  while Assigned(FindByName(Result)) do
    Result := IncrementName(Result);
end;

function TItemList.FindById(Id: Integer): TItem;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].Id <> Id) do Inc(I);
  if I < Count then Result := Items[I]
    else Result := nil;
end;

function TItemList.FindByName(Name: string): TItem;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].Name <> Name) do Inc(I);
  if I < Count then Result := Items[I]
    else Result := nil;
end;

function TItemList.GetNewId: Integer;
begin
  Result := NewId;
  Inc(NewId);
end;

function TItemList.ToString: string;
var
  I: Integer;
begin
  Result := '';
  for I := 0 to Count - 1 do
  with TItem(Items[I]) do begin
    Result := Result + ToString + LineEnding;
  end;
end;

{ TItemFields }

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;

function TItemFields.SearchByIndex(Index: Integer): TItemField;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].Index <> Index) do Inc(I);
  if I < Count then Result := Items[I]
    else Result := nil;
end;

{ TItem }

procedure TItem.AssignValue(Source: TItem; Field: TItemField);
begin
  if Field.DataType = dtString then begin
    SetValueString(Field.Index, Source.GetValueString(Field.Index));
  end else
  if Field.DataType = dtColor then begin
    SetValueColor(Field.Index, Source.GetValueColor(Field.Index));
  end else
  if Field.DataType = dtInteger then begin
    SetValueInteger(Field.Index, Source.GetValueInteger(Field.Index));
  end else
  if Field.DataType = dtBoolean then begin
    SetValueBoolean(Field.Index, Source.GetValueBoolean(Field.Index));
  end else
  if Field.DataType = dtEnumeration then begin
    SetValueEnumeration(Field.Index, Source.GetValueEnumeration(Field.Index));
  end else
  if Field.DataType = dtReference then begin
    SetValueReference(Field.Index, Source.GetValueReference(Field.Index));
  end else
    raise Exception.Create(Format(SUnsupportedDataType, [DataTypeStr[Field.DataType]]));
end;

function TItem.CompareValue(Item: TItem; Field: TItemField): Boolean;
begin
  if Field.DataType = dtString then begin
    Result := GetValueString(Field.Index) = Item.GetValueString(Field.Index);
  end else
  if Field.DataType = dtColor then begin
    Result := GetValueColor(Field.Index) = Item.GetValueColor(Field.Index);
  end else
  if Field.DataType = dtInteger then begin
    Result := GetValueInteger(Field.Index) = Item.GetValueInteger(Field.Index);
  end else
  if Field.DataType = dtBoolean then begin
    Result := GetValueBoolean(Field.Index) = Item.GetValueBoolean(Field.Index);
  end else
  if Field.DataType = dtEnumeration then begin
    Result := GetValueEnumeration(Field.Index) = Item.GetValueEnumeration(Field.Index);
  end else
  if Field.DataType = dtReference then begin
    Result := GetValueReference(Field.Index) = Item.GetValueReference(Field.Index);
  end else
    raise Exception.Create(Format(SUnsupportedDataType, [DataTypeStr[Field.DataType]]));
end;

procedure TItem.LoadValueFromNode(Node: TDOMNode; Field: TItemField);
var
  ReadId: Integer;
  ReferenceList: TItemList;
begin
  if Field.DataType = dtString then begin
    SetValueString(Field.Index, ReadString(Node, Field.SysName, ''));
  end else
  if Field.DataType = dtColor then begin
    SetValueColor(Field.Index, ReadInteger(Node, Field.SysName, 0));
  end else
  if Field.DataType = dtInteger then begin
    SetValueInteger(Field.Index, ReadInteger(Node, Field.SysName, 0));
  end else
  if Field.DataType = dtBoolean then begin
    SetValueBoolean(Field.Index, ReadBoolean(Node, Field.SysName, False));
  end else
  if Field.DataType = dtEnumeration then begin
    SetValueEnumeration(Field.Index, TUndefinedEnum(ReadInteger(Node, Field.SysName, 0)));
  end else
  if Field.DataType = dtReference then begin
    ReadId := ReadInteger(Node, Field.SysName, 0);
    ReferenceList := GetReferenceList(Field.Index);
    if (ReadId > 0) and Assigned(ReferenceList) then
      SetValueReference(Field.Index, TItem(ReferenceList[ReadId]));
  end else
    raise Exception.Create(Format(SUnsupportedDataType, [DataTypeStr[Field.DataType]]));
end;

procedure TItem.SaveValueToNode(Node: TDOMNode; Field: TItemField);
var
  Item: TItem;
begin
  if Field.DataType = dtString then begin
    WriteString(Node, Field.SysName, GetValueString(Field.Index));
  end else
  if Field.DataType = dtColor then begin
    WriteInteger(Node, Field.SysName, GetValueColor(Field.Index));
  end else
  if Field.DataType = dtInteger then begin
    WriteInteger(Node, Field.SysName, GetValueInteger(Field.Index));
  end else
  if Field.DataType = dtBoolean then begin
    WriteBoolean(Node, Field.SysName, GetValueBoolean(Field.Index));
  end else
  if Field.DataType = dtEnumeration then begin
    WriteInteger(Node, Field.SysName, Integer(GetValueEnumeration(Field.Index)));
  end else
  if Field.DataType = dtReference then begin
    Item := TItem(GetValueReference(Field.Index));
    if Assigned(Item) then WriteInteger(Node, Field.SysName, Item.Id)
      else WriteInteger(Node, Field.SysName, 0);
  end else
    raise Exception.Create(Format(SUnsupportedDataType, [DataTypeStr[Field.DataType]]));
end;

class function TItem.GetFields: TItemFields;
begin
  Result := TItemFields.Create;
  Result.AddField(1, 'Name', SName, dtString);
end;

function TItem.GetField(Index: Integer): TItemField;
var
  Fields: TItemFields;
begin
  Result := TItemField.Create;
  Fields := GetFields;
  try
    Result.Assign(Fields.SearchByIndex(Index));
  finally
    Fields.Free;
  end;
end;

procedure TItem.GetValue(Index: Integer; out Value);
begin
  raise Exception.Create(Format(SUnsupportedValueIndex, [Index]));
end;

function TItem.GetValueString(Index: Integer): string;
begin
  GetValue(Index, Result);
end;

function TItem.GetValueInteger(Index: Integer): Integer;
begin
  GetValue(Index, Result);
end;

function TItem.GetValueColor(Index: Integer): TColor;
begin
  GetValue(Index, Result);
end;

function TItem.GetValueBoolean(Index: Integer): Boolean;
begin
  GetValue(Index, Result);
end;

function TItem.GetValueEnumeration(Index: Integer): TUndefinedEnum;
begin
  GetValue(Index, Result);
end;

function TItem.GetValueReference(Index: Integer): TItem;
begin
  GetValue(Index, Result);
end;

function TItem.GetValueAsText(Index: Integer): string;
var
  Field: TItemField;
  Item: TItem;
begin
  Field := GetField(Index);
  try
    if Field.DataType = dtInteger then Result := IntToStr(GetValueInteger(Index))
    else if Field.DataType = dtString then Result := GetValueString(Index)
    else if Field.DataType = dtColor then Result := ''
    else if Field.DataType = dtEnumeration then Result := Field.EnumStates[Integer(GetValueEnumeration(Index))]
    else if Field.DataType = dtReference then begin
      Item := TItem(GetValueReference(Index));
      if Assigned(Item) then Result := Item.Name
        else Result := '';
    end else if Field.DataType = dtBoolean then begin
      if GetValueBoolean(Index) then Result := SYes else Result := SNo;
    end else
      raise Exception.Create(Format(SUnsupportedDataType, [DataTypeStr[Field.DataType]]));
  finally
    Field.Free;
  end;
end;

procedure TItem.SetValue(Index: Integer; var Value);
begin
  raise Exception.Create(Format(SUnsupportedValueIndex, [Index]));
end;

procedure TItem.SetValueInteger(Index: Integer; Value: Integer);
begin
  SetValue(Index, Value);
end;

procedure TItem.SetValueString(Index: Integer; Value: string);
begin
  SetValue(Index, Value);
end;

procedure TItem.SetValueColor(Index: Integer; Value: TColor);
begin
  SetValue(Index, Value);
end;

procedure TItem.SetValueBoolean(Index: Integer; Value: Boolean);
begin
  SetValue(Index, Value);
end;

procedure TItem.SetValueEnumeration(Index: Integer;
  Value: TUndefinedEnum);
begin
  SetValue(Index, Value);
end;

procedure TItem.SetValueReference(Index: Integer; Value: TItem);
begin
  SetValue(Index, Value);
end;

procedure TItem.Assign(Source: TItem);
var
  I: Integer;
  Fields: TItemFields;
begin
  Id := Source.Id;
  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;

function TItem.Compare(Item: TItem): Boolean;
var
  I: Integer;
  Fields: TItemFields;
begin
  Result := True;
  Result := Result and (Id = Item.Id);
  if Item is ClassType then begin
    Fields := GetFields;
    try
      for I := 0 to Fields.Count - 1 do begin
        Result := Result and CompareValue(Item, Fields[I]);
        if not Result then Break;
      end;
    finally
      Fields.Free;
    end;
  end;
end;

function TItem.ToString: string;
var
  Fields: TItemFields;
  I: Integer;
begin
  Result := 'Id: ' + IntToStr(Id) + LineEnding;
  Fields := GetFields;
  try
    for I := 0 to Fields.Count - 1 do begin
      Result := Result + Fields[I].SysName + ': ' + GetValueAsText(Fields[I].Index) + LineEnding;
    end;
  finally
    Fields.Free;
  end;
end;

procedure TItem.LoadFromNode(Node: TDOMNode);
var
  Fields: TItemFields;
  I: Integer;
begin
  Id := ReadInteger(Node, 'Id', 0);
  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);
  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;

class function TItem.GetClassName: string;
begin
  Result := SItem;
end;

function TItem.GetReferenceList(Index: Integer): TItemList;
begin
  Result := nil;
end;

constructor TItem.Create;
begin
end;

end.