{************************************************************}
{                 Delphi VCL Extensions                      }
{                                                            }
{                     Properties                             }
{                                                            }
{       Copyright (c) 2012-2013 SoftGold software company    }
{                                                            }
{************************************************************}
unit Properties;
{$INCLUDE SGDXF.INC}

interface

uses
  Windows, SysUtils, Classes, sgConsts, sgLists, sgFunction, sgXMLParser
{$IFDEF SGDEL_XE2}
  ,System.Types
{$ENDIF}
  ;

type
  TsgOperationMode = (opAdd, opAddIfNotExist);

  TsgObject = class;

  TsgObjectClass = class of TsgObject;

  TsgObjectPropertyEnum = (opObject, opSizeMode, opWidth, opHeight, opSaveRatio,
    opPixelFormat, opHorDPU, opVertDPU, opDPURatio, opSpecUnitInMM,
    opSpecUnitInInch, opImageIndex, opUsable, opTif1BitCompress,
    opTifColorCompress, opJpegQuality, opGifTransparent);

  TsgObject = class(TsgInterfacedObject)
  private
  protected
    class function GetClassByXMLName(const AName: string): TsgObjectClass;
    function GetEnumType: TsgObjectPropertyEnum;// virtual;
  public
    constructor Create; virtual;
    procedure Assign(const AObj: TsgObject);
    class function GetPropertyName: string; virtual;
    function GetStrValue: string; virtual;
    class function GetXMLName: string;
    procedure RemoveProperty(AList: TList; AProperty: TsgObjectClass);
    function SetStrValue(S: string): Boolean; virtual;
    function IsLikeGroup: Boolean; virtual;
    function IsSameValue(AObject: TsgObject): Boolean; virtual; abstract;
    property EnumType: TsgObjectPropertyEnum read GetEnumType;
//    property ReadOnly: Boolean read FReadOnly write FReadOnly;
  end;

  TsgListObjectClass = class of TsgListObject;

  TsgListObject = class(TsgObject)
  protected
    function GetNodeName: string; virtual;
    procedure EntityLoaded; virtual;
    procedure DoErrorXMLNode(const ANodeErrors: TsgNode;
      const AChild: Boolean; const ANode: TsgNodeSample;
      const AId: TsgXMLId);
    function ToXMLNode(const ANode: TsgNode; const AMode: TsgXMLModes = []): Integer; virtual;
    function FromXMLNode(const AType: TsgXMLType; const ANode: TsgNodeSample;
      const AIsChild: Boolean; const AResult: IsgResultNode = nil): Integer; virtual;
    function FromXMLSubEntities(const ANode: TsgNodeSample;
      const AResult: IsgResultNode = nil): Integer; virtual;
  public
    procedure AddProperty(const AList: TList;  const AProperty: TsgObject;
      const AMode: TsgOperationMode = opAddIfNotExist);
    procedure AddPropertyCopy(const AList: TList; const AProperty: TsgObject);
    class function XMLDescription: string; virtual;
    function IsSameValue(AObject: TsgObject): Boolean; override;
    function ToXML(const AParrentNode: TsgNode;
      const AMode: TsgXMLModes = cnstDefaultXMLMode): TsgNode; virtual;
    function FromXML(const ANode: TsgNodeSample;
      const AResult: IsgResultNode = nil): Integer; virtual;
  end;


  TsgGlobalsgObjects = class(TList)
  public
    procedure ClearFull;
  end;

  TsgGlobalsgTypes = class(TStringList)
  public
    procedure AddClass(AClass: TsgObjectClass);
    function GetClass(S: string): TsgObjectClass;
    function GetClassByName(const AName: string): TClass;
  end;

  PsgObjectInfo = ^TsgObjectInfo;
  TsgObjectInfo = record
    ObjClass: TClass;
    ObjType:  TsgObjectPropertyEnum;
  end;


  TsgGlobalsgObjectsInfo = class
  private
    FInfoByQuickFind: TsgObjectInfo;
    FListInfo: TsgList;
  protected
    function CompareInfo(const A, B: Pointer): Integer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure AddInfo(const AClass: TClass; const AType: TsgObjectPropertyEnum);
    function GetInfo(const AClass: TClass): PsgObjectInfo;
  end;

var
  GlobalsgObjects: TsgGlobalsgObjects;
  GlobalsgTypes: TsgGlobalsgTypes;
  GlobalsgObjectsInfo: TsgGlobalsgObjectsInfo;

function HasPropeprty(const AProperties: TList; const AProperty: TClass): Boolean;
function GetPropertyByClass(const AProperties: TList; const AProperty: TClass): Pointer;
function IndexOfProperty(const AProperties: TList; const AProperty: TClass): Integer;

function GetXMLType(const AName: string): TsgXMLType;

implementation

type
  TsgNodeAccess = class(TsgNode);

var
  GlobalListNamesOfClasses: TsgStringList = nil;

function HasPropeprty(const AProperties: TList; const AProperty: TClass): Boolean;
begin
  Result := IndexOfProperty(AProperties, AProperty) > -1;
end;

function IndexOfProperty(const AProperties: TList; const AProperty: TClass): Integer;
begin
  Result := 0;
  while (Result < AProperties.Count) and (TObject(AProperties[Result]).ClassType <> AProperty) do
    Inc(Result);
  if Result >= AProperties.Count then
    Result := -1;
end;

function GetPropertyByClass(const AProperties: TList; const AProperty: TClass): Pointer;
var
  I: Integer;
begin
  Result := nil;
  I := IndexOfProperty(AProperties, AProperty);
  if I > -1 then
    Result := AProperties[I];
end;

function GetXMLType(const AName: string): TsgXMLType;
begin
  Result.Id := GetXMLId(AName);
  if Result.Id = xmlUndefined then
  begin
    Result.ClassId := GlobalsgTypes.GetClassByName(AName);
    if Assigned(Result.ClassId) then
      Result.Id := xmlClassId;
  end
  else
    Result.ClassId := nil;
end;

{ TsgObject }

procedure TsgObject.Assign(const AObj: TsgObject);
begin
  SetStrValue(AObj.GetStrValue);
end;

constructor TsgObject.Create;
begin
end;

class function TsgObject.GetClassByXMLName(const AName: string): TsgObjectClass;
begin
  Result := TsgObjectClass(GlobalsgTypes.GetClassByName(AName));
end;

function TsgObject.GetEnumType: TsgObjectPropertyEnum;
var
  vInfo: PsgObjectInfo;
begin
  Result := opObject;
  vInfo := GlobalsgObjectsInfo.GetInfo(ClassType);
  if Assigned(vInfo) then
    Result := vInfo.ObjType;
end;

class function TsgObject.GetPropertyName: string;
begin
  Result := ClassName;
  if (Copy(Result, 1, 6) = 'TsgDXF') or (Copy(Result, 1, 6) = 'TsgCAD') then
    Delete(Result, 1, 6)
  else
    if Copy(Result, 1, 5) = 'Tsg2D' then
    begin
      Delete(Result, 1, 5);
      Result := 'h' + Result;
    end
    else
      if Copy(Result, 1, 3) = 'Tsg' then
        Delete(Result, 1, 3);
end;

function TsgObject.GetStrValue: string;
begin
  Result := GetPropertyName; // normal for entities and should be overriden for atoms
end;

class function TsgObject.GetXMLName: string;
begin
  Result := cnstXMLPrefix + GetPropertyName;
end;

function TsgObject.IsLikeGroup: Boolean;
begin
  Result := False;
end;

//class function TsgObject.ReadOnly: Boolean;
//begin
//  Result := False;
//  if Self <> nil then
//  begin
//
//  end;
//end;

procedure TsgObject.RemoveProperty(AList: TList; AProperty: TsgObjectClass);
var
  I: Integer;
begin
  for I := AList.Count - 1 downto 0 do
    if TsgObject(AList[I]).ClassType = AProperty then
      AList.Delete(I);
end;

function TsgObject.SetStrValue(S: string): Boolean;
begin
  Result := False;
end;

{ TsgListObject }

procedure TsgListObject.AddProperty(const AList: TList;
  const AProperty: TsgObject; const AMode: TsgOperationMode);
begin
  case AMode of
    opAddIfNotExist:
      begin
        if not HasPropeprty(AList, AProperty.ClassType) then
          AList.Add(AProperty);
      end;
  else//opAdd
    AList.Add(AProperty);
  end;
end;

procedure TsgListObject.AddPropertyCopy(const AList: TList;
  const AProperty: TsgObject);
var
  vObjNew: TsgObject;
begin
  vObjNew := TsgObjectClass(AProperty.ClassType).Create;
  vObjNew.Assign(AProperty);
  AList.Add(vObjNew);
end;

procedure TsgListObject.DoErrorXMLNode(const ANodeErrors: TsgNode;
  const AChild: Boolean; const ANode: TsgNodeSample;
  const AId: TsgXMLId);
var
  vMessage: string;
  vError: TsgNode;
begin
  if Assigned(ANodeErrors) and (ANode.NodeType in [ntAttribute, ntElement]) then
  begin
    case AId of
      xmlLineWeight:  vMessage := cnstXMLLineWeigthValueError;
      xmlName:        vMessage := cnstXMLNotCorrectName;
      xmlGlobalWidth: vMessage := cnstXMLGlobalWidthValueError;
      xmlLayerName:   vMessage := cnstXMLValueError;
      xmlUndefined:   vMessage := cnstXMLUnsupported + ' ' +
        cnstXMLItemType[AChild] + ' ' +ANode.FullName;
    else
      vMessage := cnstXMLNames[AId].Name;
    end;
    vError := ANodeErrors.AddChildNV(cnstXMLError);
    vError.AddAttribNV(cnstXMLMessage, vMessage);
    if ANode.HasPosition then
      vError.AddAttribNV(cnstXMLPosition).ValueData.ValueAsPoint :=
        Point(ANode.Position.X, ANode.Position.Y);
  end;
end;

class function TsgListObject.XMLDescription: string;
var
  S: string;
begin
  S := GetPropertyName;
  {$IFDEF SGDEL_2009}
  if CharInSet(S[1], ['a', 'A', 'o', 'O', 'i', 'I', 'e', 'E', 'u', 'U']) then
  {$ELSE}
  if S[1] in ['a', 'A', 'o', 'O', 'i', 'I', 'e', 'E', 'u', 'U'] then
  {$ENDIF}
    Result := 'Represents an ' + GetPropertyName + ' in a Drawing Database.'
  else
    Result := 'Represents a ' + GetPropertyName + ' in a Drawing Database.';
end;

function TsgListObject.FromXML(const ANode: TsgNodeSample;
  const AResult: IsgResultNode = nil): Integer;

  function FromXMLNodeInternal(const ANodeItem: TsgNodeSample;
    const AChild: Boolean; const AResult: IsgResultNode = nil): Integer;
  var
    vXMLType: TsgXMLType;
  begin
    Result := cnstXML_UNSUPPORTED;
    vXMLType := GetXMLType(ANodeItem.Name);
    case vXMLType.Id of
      xmlUndefined:
        begin
        end;
      xmlSubEntities:
        begin
          if AChild then
            Result := FromXMLSubEntities(TsgNode(ANodeItem), AResult);
        end
    else
      Result := FromXMLNode(vXMLType, ANodeItem, AChild, AResult);
    end;
    if (Result = cnstXML_UNSUPPORTED) and Assigned(AResult) then
      DoErrorXMLNode(AResult.Errors, AChild, ANodeItem, xmlUndefined);
  end;

var
  I: Integer;
  vRez: Integer;
begin
  Result := cnstXML_OK;
  vRez := Result;
  I:= 0;
  while (vRez <> cnstXML_ERROR) and (I < ANode.AttributeNodesCount) do
  begin
    vRez := FromXMLNodeInternal(ANode.AttributeNodes[I], False, AResult);
    Inc(I);
  end;
  I:= 0;
  while (vRez <> cnstXML_ERROR) and (I < ANode.ChildNodesCount) do
  begin
    vRez := FromXMLNodeInternal(ANode.ChildNodes[I], True, AResult);
    Inc(I);
  end;
  if vRez <> cnstXML_ERROR then
    EntityLoaded
  else
    Result := vRez;
end;

function TsgListObject.FromXMLNode(const AType: TsgXMLType;
  const ANode: TsgNodeSample; const AIsChild: Boolean;
  const AResult: IsgResultNode = nil): Integer;
begin
  Result := cnstXML_UNSUPPORTED;
end;

function TsgListObject.FromXMLSubEntities(const ANode: TsgNodeSample;
  const AResult: IsgResultNode = nil): Integer;
begin
  Result := cnstXML_OK;
end;

function TsgListObject.GetNodeName: string;
begin
  Result := GetXMLName;
end;

function TsgListObject.IsSameValue(AObject: TsgObject): Boolean;
begin
  Result := AObject = Self;
end;

procedure TsgListObject.EntityLoaded;
begin
end;

function TsgListObject.ToXML(const AParrentNode: TsgNode;
   const AMode: TsgXMLModes = cnstDefaultXMLMode): TsgNode;
begin
  Result := AParrentNode.AddChildNV(GetNodeName);
  ToXMLNode(Result, AMode)
end;

function TsgListObject.ToXMLNode(const ANode: TsgNode; const AMode: TsgXMLModes = []): Integer;
begin
  TsgNodeAccess(ANode).Entity := Self;
  Result := cnstXML_OK;
end;

{ TsgGlobalsgObjects }

procedure TsgGlobalsgObjects.ClearFull;
var
  I: Integer;
begin
  for I := Count - 1 downto 0 do
    TObject(Items[I]).Free;
  Clear;
end;

{ TsgGlobalsgTypes }

procedure TsgGlobalsgTypes.AddClass(AClass: TsgObjectClass);
begin
  GlobalListNamesOfClasses.AddObject(AClass.GetXMLName, Pointer(AClass));
  AddObject(AnsiLowerCase(AClass.GetPropertyName), Pointer(AClass));
end;

function TsgGlobalsgTypes.GetClass(S: string): TsgObjectClass;
var
  vIndOf: Integer;
begin
  vIndOf := IndexOf(AnsiLowerCase(S));
  if vIndOf = -1 then
    Result := nil
  else
    Result := TsgObjectClass(Objects[vIndOf]);
end;

function TsgGlobalsgTypes.GetClassByName(const AName: string): TClass;
var
  vIndex: Integer;
begin
  Result := nil;
  vIndex := GlobalListNamesOfClasses.IndexOf(AName);
  if vIndex > -1 then
    Result := TClass(GlobalListNamesOfClasses.Objects[vIndex]);
end;


{ TsgGlobalsgObjectsInfo }

procedure TsgGlobalsgObjectsInfo.AddInfo(const AClass: TClass;
  const AType: TsgObjectPropertyEnum);
var
  vInfo: PsgObjectInfo;
begin
  New(vInfo);
  vInfo^.ObjClass := AClass;
  vInfo^.ObjType := AType;
  FListInfo.Add(vInfo);
end;

function TsgGlobalsgObjectsInfo.CompareInfo(const A, B: Pointer): Integer;
var
  vInfoA: PsgObjectInfo absolute A;
  vInfoB: PsgObjectInfo absolute B;
begin
  Result := sgCompareNativeUInts(TsgNativeUInt(vInfoA^.ObjClass), TsgNativeUInt(vInfoB^.ObjClass));
end;

constructor TsgGlobalsgObjectsInfo.Create;
begin
  inherited Create;
  FListInfo := TsgList.Create;
  FListInfo.Sorted := True;
  FListInfo.Duplicates := dupAccept;
  FListInfo.ProcCompare := CompareInfo;
end;

destructor TsgGlobalsgObjectsInfo.Destroy;
begin
  FListInfo.ClearTypeList(ptvRecord);
  FListInfo.Free;
  inherited Destroy;
end;

function TsgGlobalsgObjectsInfo.GetInfo(const AClass: TClass): PsgObjectInfo;
var
  I: Integer;
begin
  Result := nil;
  FInfoByQuickFind.ObjClass := AClass;
  I := FListInfo.IndexOf(@FInfoByQuickFind);
  if I > -1 then
    Result := PsgObjectInfo(FListInfo[I]);
end;


initialization
  GlobalListNamesOfClasses := TsgStringList.Create;
  GlobalListNamesOfClasses.Sorted := True;
  GlobalListNamesOfClasses.Duplicates := dupIgnore;
//
  GlobalsgObjectsInfo := TsgGlobalsgObjectsInfo.Create;
  GlobalsgObjects := TsgGlobalsgObjects.Create;
  GlobalsgTypes := TsgGlobalsgTypes.Create;
  GlobalsgTypes.Sort;

finalization
   GlobalsgObjects.ClearFull;
   GlobalsgObjects.Free;
   GlobalsgTypes.Free;
   GlobalsgObjectsInfo.Free;
   FreeAndNil(GlobalListNamesOfClasses);

end.
