expertcad/SRC/Main/U_Common_Classes.pas

unit U_Common_Classes;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Contnrs, RtlConsts;

type
  //Tolik 12/12/2019 --
  TMyObject = Class(TObject)
  public
    RelationList: TList;
    Constructor Create;
    Destructor Destroy;override;
  End;

  TMyList = class(TList)
  private
    //FList: PPointerList;
    //FCount: Integer;
    //FCapacity: Integer;
    RelationList: TList;
  protected
    procedure Put(Index: Integer; Item: Pointer); overload;
  public
    function Add(Item: Pointer): Integer; overload;
    {function Add(Item: TMyObject): Integer; overload;
    function Add(Item: TMyList): Integer; overload;}
    procedure Clear; overload;
    procedure Delete(Index: Integer); overload;
    procedure Insert(Index: Integer; Item: Pointer); overload;
    function ExtractItem(Item: Pointer; Direction: TList.TDirection): Pointer; //overload;
    procedure Assign(ListA: TList; AOperator: TListAssignOp = laCopy; ListB: TList = nil); overload;
    function Remove(Item: Pointer): Integer; overload;
    function RemoveItem(Item: Pointer; Direction: TList.TDirection): Integer; overload;
    property Items[Index: Integer]: Pointer read Get write Put; default;
    Constructor create;
    Destructor destroy; override;
  end;

  TMyObjectList = class(TMyList)
  private
    FOwnsObjects: Boolean;
  protected
    procedure Notify(Ptr: Pointer; Action: TListNotification); override;
    function GetItem(Index: Integer): TObject; //inline;
    procedure SetItem(Index: Integer; AObject: TObject); //inline;
  public
    constructor Create; overload;
    constructor Create(AOwnsObjects: Boolean); overload;
    destructor destroy; reintroduce;
    procedure Clear;
    function Add(AObject: TObject): Integer; overload;
    function Extract(Item: TObject): TObject; //inline;
    function ExtractItem(Item: TObject; Direction: TList.TDirection): TObject; //inline;
    function Remove(AObject: TObject): Integer; overload; inline;
    function RemoveItem(AObject: TObject; ADirection: TList.TDirection): Integer; //inline;
    function IndexOf(AObject: TObject): Integer;// inline;
    function IndexOfItem(AObject: TObject; ADirection: TList.TDirection): Integer; //inline;
    function FindInstanceOf(AClass: TClass; AExact: Boolean = True; AStartAt: Integer = 0): Integer;
    procedure Insert(Index: Integer; AObject: TObject); //inline;
    function First: TObject; //inline;
    function Last: TObject; //inline;
    property OwnsObjects: Boolean read FOwnsObjects write FOwnsObjects;
    property Items[Index: Integer]: TObject read GetItem write SetItem; default;
  end;
  //
implementation

  function isMytype(aObj: Pointer):Boolean;
  begin
    Result := False;
    if aObj <> nil then
    begin
      try
        if TObject(aObj) is tMyObject then
          Result := True
        else
        if TObject(aObj) is TMyList then
          Result := True;
      except
        on E: Exception do;
      end;
    end;
  end;

	 // Tolik 12/12/2019 --
  //---------- My Object ----------------------------------
  constructor TMyObject.create;
  begin
    inherited;
    RelationList := TList.create;
  end;

  Destructor TMyObject.destroy;
  var i, j, ObjectIndex: Integer;
      RelList: TMyList;
      canDelObj: Boolean;
  begin
    if assigned(RelationList) then
    begin
      for i := RelationList.Count - 1 downto 0 do
      begin
        try
          if isMytype(RelationList[i]) then
          begin
            RelList := TMyList(RelationList[i]);
            if RelList <> nil then
            begin
              candelObj := True;
              while canDelObj do
              begin
                ObjectIndex := RelList.IndexOf(Self);
                if ObjectIndex <> -1 then
                  candelObj := True
                else
                  candelObj := False;
                if candelObj then
                  RelList[ObjectIndex] := nil;
              end;
            end;
          end
          else
            beep;
        Except
          On E: Exception do;
        end;
      end;
      freeAndNil(RelationList);
    end
    else
    begin
      beep;
    end;
    //inherited;
  end;
  // ---------------- My List ---------------------------------------
  function TMyList.Add(Item: Pointer): Integer;
 //function TMyList.Add(Item: TMyObject): Integer;
  begin
    Result := inherited Add(Item);

    if Item <> nil then
      if assigned(TMyObject(Item).RelationList) then
      begin
        if TMyObject(Item).RelationList.IndexOf(Self) = -1 then
          TMyObject(Item).RelationList.Add(Self);
      end
      else
        beep;
  end;
 {
  function TMyList.Add(Item: TMyList): Integer;
  var s: string;
  begin
    Result := inherited Add(Item);

    if Item <> nil then
    begin
      s := TObject(Item).ClassName;
      if assigned(TMyObject(Item).RelationList) then
      begin
        if TMyObject(Item).RelationList.IndexOf(Self) = -1 then
          TMyObject(Item).RelationList.Add(Self);
      end
      else
        beep;
    end;
  end;
 }
  procedure TMyList.Clear;
  var i: Integer;
      //ListObj: TMyObject;
      ListObj: TObject;
  begin
    for i := 0 to Count - 1 do
    begin
      ListObj := TObject(Items[i]);
      if ListObj <> nil then
      begin
        if assigned(TMyObject(ListObj).RelationList) then
          TMyObject(ListObj).RelationList.Remove(Self)
        else
          beep;
      end;
    end;
    inherited;
  end;

  procedure TMyList.Delete(Index: Integer);
  var ListObj: TMyObject;
  begin
    if Index > -1 then
      if Index < Count then
      begin
        ListObj := Items[Index];
        if ListObj <> nil then
        begin
          if assigned(ListObj.RelationList) then
            ListObj.RelationList.Remove(Self)
          else
            beep;
        end;
      end;
    inherited;
  end;

  procedure TMyList.Insert(Index: Integer; Item: Pointer);
  begin
    inherited;
    if Item <> nil then
    begin
      if assigned(TmyObject(Item).RelationList) then
      begin
        if TmyObject(Item).RelationList.IndexOf(Self) = -1 then
          TmyObject(Item).RelationList.Add(Self);
      end
      else
        beep;
    end;
  end;

  procedure TMyList.Put(Index: Integer; Item: Pointer);
  var ListObj: TMyObject;
  begin
    ListObj := nil;
    if Index > -1 then
      if Index < Count then
        ListObj := TMyObject(Items[Index]);

    inherited;

    if ListObj <> nil then
    try
      if Self.IndexOf(ListObj) = -1 then
      begin
        if assigned(ListObj.RelationList) then
          ListObj.RelationList.Remove(Self)
        else
          beep;
      end;
    Except
      on E: Exception do;
    end;

    if Item <> nil then
    try
      if assigned(TMyObject(Item).RelationList) then
      begin
        if TMyObject(Item).RelationList.IndexOf(Self) = -1 then
          TMyObject(Item).RelationList.Add(Self);
      end
      else
        beep;
    Except
      on E: Exception do;
    end;
  end;


  function TMyList.ExtractItem(Item: Pointer; Direction: TList.TDirection): Pointer;
  begin
    Result := inherited ExtractItem(Item, Direction);
    if Result <> nil then
      if Self.IndexOf(Result) = -1 then
      begin
        if assigned(TmyObject(Result).RelationList) then
          TmyObject(Result).RelationList.Remove(Self)
        else
          beep;
      end;
  end;

  procedure TMyList.Assign(ListA: TList; AOperator: TListAssignOp; ListB: TList);
  var
  I: Integer;
  LTemp, LSource: TList;
  begin
    // ListB given?
    if ListB <> nil then
    begin
      LSource := ListB;
      Assign(ListA);
    end
    else
      LSource := ListA;

    // on with the show
    case AOperator of

      // 12345, 346 = 346 : only those in the new list
      laCopy:
        begin
          Clear;
          Capacity := LSource.Capacity;
          for I := 0 to LSource.Count - 1 do
            Add(LSource[I]);
        end;

      // 12345, 346 = 34 : intersection of the two lists
      laAnd:
        for I := Count - 1 downto 0 do
          if LSource.IndexOf(Items[I]) = -1 then
            Delete(I);

      // 12345, 346 = 123456 : union of the two lists
      laOr:
        for I := 0 to LSource.Count - 1 do
          if IndexOf(LSource[I]) = -1 then
            Add(LSource[I]);

      // 12345, 346 = 1256 : only those not in both lists
      laXor:
        begin
          LTemp := TList.Create; // Temp holder of 4 byte values
          try
            LTemp.Capacity := LSource.Count;
            for I := 0 to LSource.Count - 1 do
              if IndexOf(LSource[I]) = -1 then
                LTemp.Add(LSource[I]);
            for I := Count - 1 downto 0 do
              if LSource.IndexOf(Items[I]) <> -1 then
                Delete(I);
            I := Count + LTemp.Count;
            if Capacity < I then
              Capacity := I;
            for I := 0 to LTemp.Count - 1 do
              Add(LTemp[I]);
          finally
            LTemp.Free;
          end;
        end;

      // 12345, 346 = 125 : only those unique to source
      laSrcUnique:
        for I := Count - 1 downto 0 do
          if LSource.IndexOf(Items[I]) <> -1 then
            Delete(I);

      // 12345, 346 = 6 : only those unique to dest
      laDestUnique:
        begin
          LTemp := TList.Create;
          try
            LTemp.Capacity := LSource.Count;
            for I := LSource.Count - 1 downto 0 do
              if IndexOf(LSource[I]) = -1 then
                LTemp.Add(LSource[I]);
            Assign(LTemp);
          finally
            LTemp.Free;
          end;
        end;
    end;
  end;

function TMyList.Remove(Item: Pointer): Integer;
begin
  Result := RemoveItem(Item, TList.TDirection.FromBeginning);
end;


function TMyList.RemoveItem(Item: Pointer; Direction: TList.TDirection): Integer;
begin
  Result := IndexOfItem(Item, Direction);
  if Result >= 0 then
    Delete(Result);
end;

Constructor TMyList.create;
begin
  inherited;
  RelationList:= TList.Create;
end;

Destructor TMyList.destroy;
var i, SelIndex: Integer;
    SelObject: TMyObject;
begin
  Clear;
  try
    for i := 0 to RelationList.Count - 1 do
    begin
      SelIndex := TList(RelationList[i]).IndexOf(Self);
      if SelIndex > -1 then
        TList(RelationList[i])[SelIndex] := nil;
    end;
  except
    On E: Exception do;
  end;
  RelationList.Free;
  inherited;
end;
 // ---------------- TMyObjectList ----------------------------------
function TMyObjectList.Add(AObject: TObject): Integer;
begin
  Result := inherited Add(AObject);
end;

constructor TMyObjectList.Create;
begin
  inherited Create;
  FOwnsObjects := True;
end;

constructor TMyObjectList.Create(AOwnsObjects: Boolean);
begin
  inherited Create;
  FOwnsObjects := AOwnsObjects;
end;

destructor TMyObjectList.destroy;
begin
  if FOwnsObjects then
  begin

  end;
  inherited;
end;
procedure TMyObjectList.Clear;
begin
  inherited;
end;

function TMyObjectList.Extract(Item: TObject): TObject;
begin
  Result := TObject(inherited Extract(Item));
end;

function TMyObjectList.ExtractItem(Item: TObject; Direction: TList.TDirection): TObject;
begin
  Result := TObject(inherited ExtractItem(Item, Direction));
end;

function TMyObjectList.FindInstanceOf(AClass: TClass; AExact: Boolean;
  AStartAt: Integer): Integer;
var
  I: Integer;
begin
  Result := -1;
  for I := AStartAt to Count - 1 do
    if (AExact and
        (Items[I].ClassType = AClass)) or
       (not AExact and
        Items[I].InheritsFrom(AClass)) then
    begin
      Result := I;
      break;
    end;
end;

function TMyObjectList.First: TObject;
begin
  Result := TObject(inherited First);
end;

function TMyObjectList.GetItem(Index: Integer): TObject;
begin
  Result := inherited Items[Index];
end;

function TMyObjectList.IndexOf(AObject: TObject): Integer;
begin
  Result := inherited IndexOf(AObject);
end;

function TMyObjectList.IndexOfItem(AObject: TObject; ADirection: TList.TDirection): Integer;
begin
  Result := inherited IndexOfItem(AObject, ADirection);
end;

procedure TMyObjectList.Insert(Index: Integer; AObject: TObject);
begin
  inherited Insert(Index, AObject);
end;

function TMyObjectList.Last: TObject;
begin
  Result := TObject(inherited Last);
end;

procedure TMyObjectList.Notify(Ptr: Pointer; Action: TListNotification);
begin
  if (Action = lnDeleted) and OwnsObjects then
    TObject(Ptr).Free;
  inherited Notify(Ptr, Action);
end;

function TMyObjectList.Remove(AObject: TObject): Integer;
begin
  Result := inherited Remove(AObject);
end;

function TMyObjectList.RemoveItem(AObject: TObject; ADirection: TList.TDirection): Integer;
begin
  Result := inherited RemoveItem(AObject, ADirection);
end;

procedure TMyObjectList.SetItem(Index: Integer; AObject: TObject);
begin
  inherited Items[Index] := AObject;
end;

end.