MultiDimMatrix.pas

unit MultiDimMatrix;

interface
uses
  System.Classes, System.Contnrs, MatrixTypes;
  
  type
  TColumnList = class(TList)
    protected
    procedure Notify(Ptr: Pointer; Action: TListNotification); override;
    function Get(Index: Integer): pColumnItem;
   public
    function NewItem(AHeader : double) : pColumnItem;
    function First : pColumnItem; reintroduce;
    function Last : pColumnItem; reintroduce;
    procedure Clear; override;
    property Items[Index: Integer]: pColumnItem read Get; default;
  end;
  
  TRowList = class(TList)
    protected
    procedure Notify(Ptr: Pointer; Action: TListNotification); override;
    function Get(Index: Integer): pRowItem;
   public
    function NewItem(ATag : SmallInt):pRowItem;
    function First : pRowItem; reintroduce;
    function Last : pRowItem; reintroduce;
    procedure Clear; override;
    property Items[Index: Integer]: pRowItem read Get; default;
  end;
  
  {Êëàññ ðåàëèçóåò ÿ÷åéêó ñ êîîðäèíàòàìè Col, Row - X  è Y ñîîòâåòñòâåííî
  Êëàññ ÿâëÿåòñÿ ðîäèòåëåì ÿ÷ååê-õðàíèëèù,
  îïðåäåëÿåìûõ äàëüíåéøåé íåîáõîäèìîñòüþ}
  TCell = class(TObject, IInterface, ICell)
   strict private
    fCol : pColumnItem;
    fRow : pRowItem;
   private
    { IInterface }
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
   public
    constructor Create(ACol : pColumnItem; ARow : pRowItem); virtual;
    function Col : pColumnItem; stdcall;
    function Row : pRowItem; stdcall;
  end;

  TCellClass = class of TCell;


  {Êëàññ - õðàíèëèùå ÿ÷ååê TCell
  è âûäà÷ó ññûëîê íà èíòåðôåéñ ICell }
  TCellList = class(TObject)
   strict private 
    fList : TObjectList;
    fCellClass : TCellClass;
   public
    constructor Create(ACellClass : TCellClass);
    destructor Destroy; override;
    property CellClass : TCellClass read fCellClass;
    function Count : integer;
    procedure Delete(Index : integer);
    procedure Clear;
    function NewItem(ACol : pColumnItem; ARow : pRowItem) : ICell;
    function QueryItem(AIndex : integer; const IID: TGUID; out Obj):boolean;
  end;

  {Êëàññ ìíîãîìåðíîé ìàòðèöû
  Òèï âíóòðåííåãî íàáîðà îïðåäåëÿåòñÿ ïåðåäà÷åé
  ññûëêè íà êëàññ â êîíñòðóêòîð èëè ïóòåì ïåðåêðûòèÿ ôóíêöèè DefaultCellClass
  Îáåñïå÷èâàåò ïîèñê ïî èíäåêñó êîëîíêè, èíäåêñó ñòðîêè è ïî òèïó èíòåðôåéñà}
  {Ñòðóêòóðà òàáëèöû TMultiDimMatrix
        Col->°Ñ   -60     |..|     85     | <-Header
       \/Row
      Tag 1  |TCellClass  |..| TCellClass |
      Tag 2  |TCellClass  |..| TCellClass |
      Tag 3  |TCellClass  |..| TCellClass |
      ............
      Tag 6  |TCellClass  |..| TCellClass |
      TCellClass - Ýêçåïëÿð îáúåêòà TCellClass
      Ýòî ìîæåò áûòü ÿ÷åéêà êàê ñ ïðîñòûìè äàííûìè
      òàê è ñîäåðæàòü â ñåáå îáúåêòû, âêëþ÷àÿ ñïèñêè
      }
  TMultiDimMatrix = class(TObject, IInterface, IMultiDimMatrix)
   private
    fCols : TColumnList;
    fRows : TRowList;
    fCells : TCellList;
    { IInterface }
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
   protected
    function DefaultCellClass : TCellClass; virtual;
    property Cells : TCellList read fCells;
   public
    constructor Create overload; virtual;
    constructor Create(ACellClass: TCellClass); {reintroduce;} overload; virtual;
    destructor Destroy; override;  
    procedure Clear; stdcall;
    function ColCount : integer; stdcall;
    function RowCount : integer; stdcall;
    function Header(ColumnIndex: byte): double; stdcall;
    {Ôóíêöèÿ âåðíåò çíà÷åíèå çàãîëîâêà ïî åãî èíäåêñó
    Èíäåêñ äîëæåí áûòü <  ColCount}
    function Tag(RowIndex: byte): SmallInt; stdcall;
    {Ôóíêöèÿ âåðíåò çíà÷åíèå ñòðîêè ïî åãî èíäåêñó
    Èíäåêñ äîëæåí áûòü <  RowCount}
    function FindCol(AHeader : double; var ACol : byte):Boolean;stdcall;
    function AddCol(AHeader : double) : integer; stdcall;
    function AddRow(ATag : SmallInt) : integer; stdcall;
    {Ôóíêöèè AddCol è AddRow äîáàâëÿþò êîëîíêó è ñòðîêó ñ ïàðàìåòðàìè ñîîòâåòñòâåííî}
    function FindRow(ATag: SmallInt; var ARow : byte): boolean; stdcall;
    {Ôóíêöèÿ ïîèñêà ñòðîêè ïî ïàðàìåòðó Tag. Âåðíåò true ïðè óñïåøíîì ïîèñêå
     âûõîäíîé ïåðåìåííîé ARow áóäåò çíà÷åíèå èíäåêñà ñòðîêè}
    function ByIndex(ACol, ARow : byte; const IID: TGUID; out Obj): boolean; stdcall;
    {Ôóíêöèÿ ïîèñêà ïî èíäåêñàì ACol, ARow è GUID-ó ÿ÷åéêè.
    Âîçâðàòèò true ïðè íàéäåííîé ÿ÷åéêå.  âûõîäíîé ïåðåìåííîé Obj áóäåò ññûëêà íà èíòåðôåéñ ÿ÷åéêè}
    function ByParams(ACol : byte; ATag : SmallInt; const IID: TGUID; out Obj): boolean; stdcall;
    {Ôóíêöèÿ ïîèñêà ïî èíäåêñó ACol, ïàðàìåòðó ARow è GUID-ó ÿ÷åéêè.
    Âîçâðàòèò true ïðè íàéäåííîé ÿ÷åéêå.  âûõîäíîé ïåðåìåííîé Obj áóäåò ññûëêà íà èíòåðôåéñ ÿ÷åéêè}
  end;

  TMultiDimMatrixClass = class of TMultiDimMatrix;

implementation

uses System.SysUtils, System.Math;

{ TColumnList } 

function TColumnList.NewItem(AHeader: double): pColumnItem;
begin
  New(result);
  result.Index := byte(self.Count);
  result.Header := AHeader;
  inherited Add(result);
end;

procedure TColumnList.Clear;
begin
  while count > 0 do
    delete(count -1);
  inherited;
end;

function TColumnList.First: pColumnItem;
begin
  result := Get(0);
end;

function TColumnList.Get(Index: Integer): pColumnItem;
begin
  Result := pColumnItem(inherited Get(Index));
end;

function TColumnList.Last: pColumnItem;
begin
  result := Get(Count - 1);
end;

procedure TColumnList.Notify(Ptr: Pointer; Action: TListNotification);
begin
  if Action = lnDeleted then
      Dispose(Ptr);
  inherited Notify(Ptr, Action);
end;

{ TRowList } 

function TRowList.NewItem(ATag: SmallInt): pRowItem;
begin
  New(result);
  result.Index := byte(self.Count);
  result.M_Tag := ATag;
  inherited Add(result);
end;

procedure TRowList.Clear;
begin
  while count > 0 do
    delete(count -1);
  inherited;
end;

function TRowList.First: pRowItem;
begin
  result := Get(0);
end;

function TRowList.Get(Index: Integer): pRowItem;
begin
  Result := pRowItem(inherited Get(Index));
end;

function TRowList.Last: pRowItem;
begin
  result := Get(Count - 1);
end;

procedure TRowList.Notify(Ptr: Pointer; Action: TListNotification);
begin
  if Action = lnDeleted then
      Dispose(Ptr);
  inherited Notify(Ptr, Action);
end;

{ T2DimCellList }

function TCellList.NewItem(ACol : pColumnItem; ARow : pRowItem): ICell;
var
vTmp : TCell;
begin
  vTmp := fCellClass.Create(ACol, ARow);
  fList.Add(vTmp);
  result := vTmp as ICell;
end;

function TCellList.QueryItem(AIndex: integer; const IID: TGUID;
  out Obj): boolean;
begin
  result:= (AIndex > -1)
  and (AIndex < fList.Count)
  and assigned(fList.Items[AIndex])
  and Supports(fList.Items[AIndex], IID, Obj);
end;

procedure TCellList.Clear;
begin
  fList.Clear;
end;

function TCellList.Count: integer;
begin
  result := fList.Count;
end;

constructor TCellList.Create(ACellClass: TCellClass);
begin
  fList := TObjectList.Create;
  fCellClass := ACellClass;
end;

procedure TCellList.Delete(Index: integer);
begin
  fList.Delete(Index);
end;

destructor TCellList.Destroy;
begin
  fList.Clear;
  FreeAndNil(fList);
  inherited Destroy;
end;

{ TMultiDimMatrix }

constructor TMultiDimMatrix.Create;
begin
  Create(DefaultCellClass);
end;

constructor TMultiDimMatrix.Create(ACellClass: TCellClass);
begin
  fCols := TColumnList.Create;
  fRows := TRowList.Create;
  fCells := TCellList.Create(ACellClass);
end;

destructor TMultiDimMatrix.Destroy;
begin
  Clear;
  FreeAndNil(fCells);
  FreeAndNil(fCols);
  FreeAndNil(fRows);
  inherited Destroy;
end;

procedure TMultiDimMatrix.Clear;
begin
  fCells.Clear;
  fRows.Clear;
  fCols.Clear;
end;  

function TMultiDimMatrix.FindCol(AHeader: double; var ACol : byte): Boolean;
begin
  ACol := 0;
  while ACol < fCols.Count do
  begin
    if SameValue(fCols[ACol].Header, AHeader, 0.5) then
      Break;
    inc(ACol);
  end;
  Result := ACol < fCols.Count;
end;

function TMultiDimMatrix.AddCol(AHeader: double): integer;
var
i : integer;
vRes : byte;
v : ICell;
begin
  if FindCol(AHeader, vRes) then
  begin
    result := vRes;
    exit;
  end; 
  fCols.NewItem(AHeader);
  i := 0;
  while i < fRows.Count do
  begin
    v := fCells.NewItem(fCols.Last, fRows[i]);
    v := nil;
    inc(i);
  end;
  result := fCols.Count - 1;
end;

function TMultiDimMatrix.AddRow(ATag: SmallInt): integer;
var
i : integer;
vRes : byte;
v : ICell;
begin
  if FindRow(ATag, vRes) then
  begin
    result := vRes;
    exit;
  end;
  fRows.NewItem(ATag);
  i := 0;
  while i < fCols.Count do
  begin
    v := fCells.NewItem(fCols[i], fRows.Last);
    v := nil;
    inc(i);
  end;
  result := fRows.Count - 1;
end;

function TMultiDimMatrix.ColCount: integer;
begin
  result := fCols.Count;
end;

function TMultiDimMatrix.RowCount: integer;
begin
  result := fRows.Count;
end;  

function TMultiDimMatrix.Header(ColumnIndex: byte): double;
begin
  result := fCols[ColumnIndex]^.Header;
end;

function TMultiDimMatrix.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := S_OK
  else
    Result := E_NOINTERFACE;
end;

function TMultiDimMatrix.Tag(RowIndex: byte): SmallInt;
begin
  result := fRows[RowIndex]^.M_Tag;
end;

function TMultiDimMatrix._AddRef: Integer;
begin
  Result := -1;
end;

function TMultiDimMatrix._Release: Integer;
begin
  Result := -1;
end;

function TMultiDimMatrix.DefaultCellClass: TCellClass;
begin
  result := TCell;
end;

function TMultiDimMatrix.FindRow(ATag: SmallInt; var ARow : byte): boolean;
begin
  ARow := 0;
  while ARow < fRows.Count do
  begin
    if (fRows.Items[ARow]^.M_Tag = ATag) then
      break;
    inc(ARow);
  end;
  result := ARow < fRows.Count;
end;

function TMultiDimMatrix.ByIndex(ACol, ARow: byte; const IID: TGUID;
  out Obj): boolean;
var
i : integer;
v : ICell;
begin
  i := 0;
  while (i < fCells.Count) do
  begin
    v := nil;
    if (fCells.QueryItem(i, ICell, v))
    and (v.Row^.Index = ARow)
    and (v.Col^.Index = ACol) then
      break;
    inc(i);
  end;
  result := (i < fCells.Count) and Assigned(v) and (v.QueryInterface(IID, Obj) = S_OK);
  v := nil;
end;

function TMultiDimMatrix.ByParams(ACol : byte; ATag: SmallInt; const IID: TGUID;
  out Obj): boolean;
var
i : integer;
v : ICell;
begin
  i := 0;
  while (i < fCells.Count) do
  begin
    v := nil;
    if (fCells.QueryItem(i, ICell, v))
    and (v.Row^.M_Tag = ATag)
    and (v.Col^.Index = ACol) then
      break;
    inc(i);
  end;
  result := (i < fCells.Count) and Assigned(v) and (v.QueryInterface(IID, Obj) = S_OK);
  v := nil;
end;

{ TCell }

function TCell.Col: pColumnItem;
begin
  result := fCol;
end;

constructor TCell.Create(ACol : pColumnItem; ARow : pRowItem);
begin
  fCol := ACol;
  fRow := ARow;
end;

function TCell.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := S_OK
  else
    Result := E_NOINTERFACE;
end;

function TCell.Row: pRowItem;
begin
  result := fRow;
end;

function TCell._AddRef: Integer;
begin
  Result := -1;
end;

function TCell._Release: Integer;
begin
  Result := -1;
end;

end.