lazarus-ccr/applications/cactusjukebox/source/MGList.pas

//******************************************************************************
//***                     COMMON DELPHI FUNCTIONS                            ***
//***                                                                        ***
//***    (c) Beppe Grimaldi, Massimo Magnano 11-11-2004.                     ***
//***                                                                        ***
//***                                                                        ***
//******************************************************************************
//  File        : MGList.pas      REV. 1.6   (13-09-2006)
//
//  Description : Implementation of an Optimazed and Polimorphic List.
//
//******************************************************************************

unit MGList;
{$mode delphi}{$H+}

interface

Type
  PDataExt = ^TDataExt;
  TDataExt = record
     Data         :Pointer;
     Prev         :PDataExt;
     Next         :PDataExt;
  end;

  //I Tag sono necessari xche' Non posso leggere le variabili che stanno nello Stack
  //quindi devo passare le variabile necessarie alle funzioni locali di compare così
  //EN the Tags are needed because i cannot read variables from the Stack
  //so i must pass the variables that i need in the local compare function int this way
  TLocalCompareFunction = function (Tag :Pointer; ptData1, ptData2 :Pointer) :Boolean;
  TLocalWalkFunction = procedure (Tag :Integer; ptData :Pointer);
  TObjCompareFunction = function (Tag :Pointer; ptData1, ptData2 :Pointer) :Boolean of object;
  PObjCompareFunction = ^TObjCompareFunction;
  TObjWalkFunction = procedure (Tag :Integer; ptData :Pointer) of object;


  { TMGList }

  TMGList = class
    protected
        rListInit,
        rListEnd,
        rCurrent     :PDataExt;
        rCount       :Integer;

        function Get(Index: Integer): Pointer;
        function InternalDelete(Item :PDataExt) :PDataExt; overload;
        function InternalFind(pData :Pointer; ATag :Pointer; CompareFunction : TLocalCompareFunction=nil) :PDataExt; virtual;
        function PutInRightPosition(newElem :PDataExt; ATag :Pointer; CompareFunction : TLocalCompareFunction=nil) :Integer; overload; virtual;
        function PutInRightPosition(newElem :PDataExt; ATag :Pointer; CompareFunction : TObjCompareFunction) :Integer; overload; virtual;
        function allocData :Pointer; virtual;
        procedure deallocData(pData :Pointer); virtual;
        function RefreshOK(pData :Pointer) : Boolean; virtual;
    public
        constructor Create; virtual;
        destructor Destroy; override;

        function Find(pData :Pointer; ATag :Pointer; CompareFunction : TLocalCompareFunction=nil): Integer; overload;
        function Find(pData :Pointer; ATag :Pointer; CompareFunction : TObjCompareFunction): Integer; overload;
        function Find(const Args: array of Variant): Pointer; overload; virtual;
        function ExtFind(pData :Pointer; ATag :Pointer; CompareFunction : TLocalCompareFunction=nil): Pointer; overload;
        function ExtFind(pData :Pointer; ATag :Pointer; CompareFunction : TObjCompareFunction): Pointer; overload;
        procedure Walk(ATag :Integer; WalkFunction : TLocalWalkFunction); overload;
        procedure Walk(ATag :Integer; WalkFunction : TObjWalkFunction); overload;
        procedure WalkAndRefresh(ATag :Integer; WalkFunction : TLocalWalkFunction); overload;
        procedure WalkAndRefresh(ATag :Integer; WalkFunction : TObjWalkFunction); overload;

        function Add :Pointer; overload;
        function Insert(pData :Pointer; ATag :Pointer; CompareFunction : TLocalCompareFunction=nil) :Integer; overload;
        function Insert(pData :Pointer; ATag :Pointer; CompareFunction : TObjCompareFunction) :Integer; overload;
        function DeleteFirst :Boolean;
        function DeleteLast :Boolean;
        function Delete(Index :Integer) :Boolean; overload;
        function Delete(pData :Pointer; ATag :Pointer; CompareFunction : TLocalCompareFunction=Nil) :Boolean; overload;
        function Delete(pData :Pointer; ATag :Pointer; CompareFunction : TObjCompareFunction) :Boolean; overload;
        procedure Exchange(pData1, pData2 :Pointer); overload; virtual;

        procedure Clear;
        procedure Refresh;

        function FindFirst: Pointer; virtual;
        function FindNext : Pointer; virtual;
        function GetFirst : Pointer;
        function GetLast : Pointer;
        function GetCurrent : Pointer; virtual;
        function GetData(DataPointer :Pointer; DataName :String) :Variant; virtual;
        function DeleteCurrent :Boolean;
        procedure FindClose; virtual;

        property Count :Integer read rCount;
        property Items [Index :Integer] :Pointer read Get;
  end;

  TMGListClass = class of TMGList;


  TMGObjectWithCreate = class(TObject)
  public
     constructor Create(dummy :Boolean); virtual;
  end;

  TObjectWCClass = class of TMGObjectWithCreate;

  TMGObject_List = class(TMGList)
  protected
       function allocData :Pointer; override;
       procedure deallocData(pData :Pointer); override;
       function GetObjectClass :TObjectWCClass; virtual; abstract;
  end;

  TMGList_List = class(TMGList)
  protected
       function allocData :Pointer; override;
       procedure deallocData(pData :Pointer); override;
       function GetObjectClass :TMGListClass; virtual; abstract;
  end;


implementation

Type
    TLocalToObjData_Compare = record
        Tag  :Pointer;
        Func :TObjCompareFunction;
    end;
    PLocalToObjData_Compare = ^TLocalToObjData_Compare;

    TLocalToObjData_Walk = record
        Tag  :Integer;
        Func :TObjWalkFunction;
    end;
    PLocalToObjData_Walk = ^TLocalToObjData_Walk;


function _localToObj_Compare(xTag :Pointer; ptData1, ptData2 :Pointer) :Boolean;
begin
//   try
     Result := PLocalToObjData_Compare(xTag).Func(
                                     PLocalToObjData_Compare(xTag).Tag,
                                     ptData1, ptData2);
(*   except
     Result :=False;
   end;*)
end;

procedure _localToObj_Walk(xTag :Integer; ptData :Pointer);
begin
     PLocalToObjData_Walk(xTag).Func(PLocalToObjData_Walk(xTag).Tag, ptData);
end;

function AllocData_Compare(Tag :Pointer; Func :TObjCompareFunction) :PLocalToObjData_Compare;
begin
     GetMem(Result, sizeOf(TLocalToObjData_Compare));
     Result^.Tag :=Tag;
     Result^.Func :=Func;
end;

function AllocData_Walk(Tag :Integer; Func :TObjWalkFunction) :PLocalToObjData_Walk;
begin
     GetMem(Result, sizeOf(TLocalToObjData_Walk));
     Result^.Tag :=Tag;
     Result^.Func :=Func;
end;

function CompByData(xTag :Pointer; ptData1, ptData2 :Pointer) :Boolean;
begin
     Result := (ptData1 = ptData2);
end;



// =============================================================================

constructor TMGList.Create;
begin
   rCount := 0;
   rListInit := Nil;
   rListEnd := Nil;
   rCurrent := Nil;
end;

destructor TMGList.Destroy;
begin
   Clear;
end;

function TMGList.allocData :Pointer;
begin
     Result :=Nil;
end;

procedure TMGList.deallocData(pData :Pointer);
begin
end;

function TMGList.RefreshOK(pData :Pointer) : Boolean;
begin
     Result :=True;
end;

procedure TMGList.Clear;
var
   pIndex :PDataExt;
begin
   while (rListInit <> Nil) do
     begin
        pIndex := rListInit;
        rListInit := rListInit^.Next;
        deallocData(pIndex^.Data);
        Dispose(pIndex);
     end;
   rListInit := Nil;
   rListEnd := Nil;
   rCount := 0;
end;

procedure TMGList.Refresh;
var
   pIndex :PDataExt;
begin
   pIndex := rListInit;
   while (pIndex <> Nil) do
     begin
        if RefreshOK(pIndex^.Data)
          then pIndex := pIndex^.Next
          else begin
                  if (pIndex^.Next = Nil)  // se è l'ultimo elemento..
                    then rListEnd := pIndex^.Prev;
                  pIndex := InternalDelete(pIndex);
               end;
     end;
end;

function TMGList.FindFirst: Pointer;
begin
     if (rCurrent=Nil)
      then begin
                rCurrent :=rListInit;
                Result :=GetCurrent;
           end
      else Result :=Nil;
end;

function TMGList.FindNext : Pointer;
begin
     if (rCurrent<>Nil)
      then begin
                rCurrent :=rCurrent^.Next;
                Result :=GetCurrent;
           end
      else Result :=Nil;
end;

function TMGList.GetFirst: Pointer;
begin
     Result :=rListInit^.Data;
end;

function TMGList.GetLast: Pointer;
begin
     Result :=rListEnd^.Data;
end;

function TMGList.GetCurrent : Pointer;
begin
     if (rCurrent=Nil)
     then Result :=Nil
     else Result :=rCurrent^.Data;
end;

function TMGList.GetData(DataPointer :Pointer; DataName :String) :Variant;
begin
     Result :=Variant(Integer(DataPointer));
end;

function TMGList.DeleteCurrent :Boolean;
begin
   Result := False;
   if (rCurrent <> Nil) then
     begin
        rCurrent := InternalDelete(rCurrent);
        Result := True;
     end;
end;

procedure TMGList.FindClose;
begin
     rCurrent :=Nil;
end;

function TMGList.Get(Index: Integer): Pointer;
var
   I :Integer;
   pIndex :PDataExt;

begin
   Result := Nil;
   if ((Index >= 0) and (Index < rCount)) then
     begin
        pIndex := rListInit;
        for i:=0 to Index-1 do
          pIndex := pIndex^.Next;
        Result := pIndex^.Data;
     end;
end;

function TMGList.Find(pData :Pointer; ATag :Pointer; CompareFunction : TLocalCompareFunction=nil): Integer;
var
   i :Integer;
   Found :Boolean;
   pIndex :PDataExt;

begin
   if not(Assigned(CompareFunction))
   then CompareFunction :=CompByData;

   Result := -1;
   i := 0;
   Found := False;
   pIndex := rListInit;
   while ((i < rCount) and not Found) do
     if CompareFunction(ATag, pData, pIndex^.Data)
       then begin
               Result := i;
               Found := True;
            end
       else begin
               Inc(i);
               pIndex := pIndex^.Next;
            end;
end;

function TMGList.Find(pData :Pointer; ATag :Pointer; CompareFunction : TObjCompareFunction): Integer;
Var
  auxPointer :PLocalToObjData_Compare;

begin
     auxPointer :=AllocData_Compare(ATag, CompareFunction);
     Result := Find(pData, auxPointer, _LocalToObj_Compare);
     FreeMem(auxPointer);
end;

function TMGList.Find(const Args: array of Variant): Pointer;
begin
     Result :=Nil;
end;

function TMGList.ExtFind(pData :Pointer; ATag :Pointer; CompareFunction : TLocalCompareFunction=nil): Pointer;
var
   Found  :Boolean;
   pIndex :PDataExt;

begin
   if not(Assigned(CompareFunction))
   then CompareFunction :=CompByData;

   Result := Nil;
   Found := False;
   pIndex := rListInit;
   while ((pIndex <> Nil) and not Found) do
     if CompareFunction(ATag, pData, pIndex^.Data)
       then begin
               Result := pIndex^.Data;
               Found := True;
            end
       else pIndex := pIndex^.Next;
end;


function TMGList.ExtFind(pData :Pointer; ATag :Pointer; CompareFunction : TObjCompareFunction): Pointer;
Var
  auxPointer :PLocalToObjData_Compare;

begin
     auxPointer :=AllocData_Compare(ATag, CompareFunction);
     Result := ExtFind(pData, auxPointer, _LocalToObj_Compare);
     FreeMem(auxPointer);
end;

procedure TMGList.Walk(ATag :Integer; WalkFunction : TLocalWalkFunction);
var
   pIndex :PDataExt;

begin
     pIndex := rListInit;
     while (pIndex <> Nil) do
     begin
          WalkFunction(ATag, pIndex^.Data);
          pIndex := pIndex^.Next;
     end;
end;

procedure TMGList.Walk(ATag :Integer; WalkFunction : TObjWalkFunction);
Var
  auxPointer :PLocalToObjData_Walk;

begin
     auxPointer :=AllocData_Walk(ATag, WalkFunction);
     Walk(Integer(auxPointer), _LocalToObj_Walk);
     FreeMem(auxPointer);
end;

procedure TMGList.WalkAndRefresh(ATag :Integer; WalkFunction : TLocalWalkFunction);
var
   pIndex :PDataExt;

begin
     pIndex := rListInit;
     while (pIndex <> Nil) do
     begin
          if RefreshOk(pIndex^.Data)
          then begin
                    WalkFunction(ATag, pIndex^.Data);
                    pIndex := pIndex^.Next;
               end
          else begin
                  if (pIndex^.Next = Nil)  // se è l'ultimo elemento..
                    then rListEnd := pIndex^.Prev;
                  pIndex := InternalDelete(pIndex);
               end;
     end;
end;

procedure TMGList.WalkAndRefresh(ATag :Integer; WalkFunction : TObjWalkFunction);
Var
  auxPointer :PLocalToObjData_Walk;

begin
     auxPointer :=AllocData_Walk(ATag, WalkFunction);
     WalkAndRefresh(Integer(auxPointer), _LocalToObj_Walk);
     FreeMem(auxPointer);
end;


function TMGList.Add :Pointer;
var
   newElem :PDataExt;

begin
   new(newElem);
   fillchar(newElem^, sizeof(TDataExt), 0);
   newElem^.Data := allocData;

   if (rListEnd = Nil)
     then begin
             rListInit := newElem;
             rListEnd := newElem;
          end
     else begin
             rListEnd^.Next := newElem;
             newElem^.Prev := rListEnd;
             rListEnd := newElem;
          end;
   Inc(rCount);
   Result := newElem^.Data;
end;

function TMGList.PutInRightPosition(newElem :PDataExt; ATag :Pointer; CompareFunction : TLocalCompareFunction) :Integer;
var
   Found   :Boolean;
   pIndex  :PDataExt;

begin
   if not(Assigned(CompareFunction))
   then CompareFunction :=CompByData;

   Result := 0;
   if (rListInit = Nil)
     then begin
             rListInit := newElem;
             rListEnd := newElem;
          end
     else begin
             Found := False;
             pIndex := rListInit;
             repeat
               if CompareFunction(ATag, newElem^.Data, pIndex^.Data)
                 then begin
                         // uso 'newElem^.Prev' per conservare il puntatore al record precedente..
                         newElem^.Prev := pIndex;
                         pIndex := pIndex^.Next;
                      end
                 else Found := True;
               Inc(Result);
             until ((pIndex = Nil) or Found);

             if (newElem^.Prev = Nil)  // inserisco in prima posizione..
               then rListInit := newElem
               else newElem^.Prev^.Next := newElem;
             newElem^.Next := pIndex;
             if (pIndex <> Nil)
               then pIndex^.Prev := newElem
               else rListEnd := newElem;  // inserisco in ultima posizione..
          end;
end;

function TMGList.PutInRightPosition(newElem :PDataExt; ATag :Pointer; CompareFunction : TObjCompareFunction) :Integer;
Var
  auxPointer :PLocalToObjData_Compare;

begin
     auxPointer :=AllocData_Compare(ATag, CompareFunction);
     Result := PutInRightPosition(newElem, auxPointer, _LocalToObj_Compare);
     FreeMem(auxPointer);
end;

function TMGList.Insert(pData :Pointer; ATag :Pointer; CompareFunction : TLocalCompareFunction=Nil) :Integer;
var
   newElem :PDataExt;
   
begin
   if not(Assigned(CompareFunction))
   then CompareFunction :=CompByData;

   new(newElem);
   fillchar(newElem^, sizeof(TDataExt), 0);
   newElem^.Data :=pData;

   Result := PutInRightPosition(pData, ATag, CompareFunction);
   Inc(rCount);
end;

function TMGList.Insert(pData :Pointer; ATag :Pointer; CompareFunction : TObjCompareFunction) :Integer;
Var
  auxPointer :PLocalToObjData_Compare;

begin
     auxPointer :=AllocData_Compare(ATag, CompareFunction);
     Result := Insert(pData, auxPointer, _LocalToObj_Compare);
     FreeMem(auxPointer);
end;

function TMGList.DeleteFirst: Boolean;
begin
     try
        InternalDelete(rListInit);
        Result :=True;
     except
       Result :=False;
     end;
end;

function TMGList.DeleteLast: Boolean;
begin
     try
        InternalDelete(rListEnd);
        Result :=True;
     except
       Result :=False;
     end;
end;


function TMGList.Delete(Index :Integer) :Boolean;
var
   i      :Integer;
   pIndex :PDataExt;

begin
   Result := False;
   if ((Index >= 0) and (Index < rCount)) then
     begin
        pIndex := rListInit;
        for i:=0 to Index-1 do
          pIndex := pIndex^.Next;

        if (pIndex = Nil)
          then InternalDelete(rListEnd)
          else InternalDelete(pIndex);

        Result := True;
     end;
end;

function TMGList.Delete(pData :Pointer; ATag :Pointer; CompareFunction : TLocalCompareFunction=Nil) :Boolean;
Var
   toDel :PDataExt;

begin
     if not(Assigned(CompareFunction))
     then CompareFunction :=CompByData;

     toDel := InternalFind(pData, ATag, CompareFunction);
     Result := (toDel<>Nil);
     if Result
     then InternalDelete(toDel);
end;

function TMGList.Delete(pData :Pointer; ATag :Pointer; CompareFunction : TObjCompareFunction) :Boolean;
Var
  auxPointer :PLocalToObjData_Compare;

begin
     auxPointer :=AllocData_Compare(ATag, CompareFunction);
     Result := Delete(pData, auxPointer, _LocalToObj_Compare);
     FreeMem(auxPointer);
end;

procedure TMGList.Exchange(pData1, pData2 :Pointer);
var
   pIndex,
   pIndexData1,
   pIndexData2  :PDataExt;
   xData        :Pointer;


begin
   pIndex := rListInit;
   pIndexData1 :=Nil;
   pIndexData2 :=Nil;
   while ((pIndex <> Nil) and ((pIndexData1=Nil) or (pIndexData2=Nil))) do
   begin
        if (pIndex^.Data=pData1)
        then pIndexData1 :=pIndex
        else if (pIndex^.Data=pData2)
             then pIndexData2 :=pIndex;

        pIndex := pIndex^.Next;
   end;

   if ((pIndexData1<>Nil) and (pIndexData2<>Nil)) then
   begin
        xData := pIndexData1^.Data;
        pIndexData1^.Data := pIndexData2^.Data;
        pIndexData2^.Data := xData;
   end;
end;


function TMGList.InternalDelete(Item :PDataExt) :PDataExt;
var
   P :PDataExt;
begin
   Result := Nil;
   P := PDataExt(Item);
   if (P <> Nil) then
     begin
        if (P^.Prev <> Nil)
          then P^.Prev^.Next := P^.Next
          else rListInit := P^.Next;
        if (P^.Next <> Nil)
          then P^.Next^.Prev := P^.Prev
          else rListEnd := P^.Prev;  // sto cancellando l'ultimo elemento..

        Result := P^.Prev;
        deallocData(P^.Data);
        Dispose(P);
        Dec(rCount);
     end;
end;


function TMGList.InternalFind(pData :Pointer; ATag :Pointer; CompareFunction : TLocalCompareFunction=nil) :PDataExt;
var
   Found  :Boolean;
   pIndex :PDataExt;

begin
   if not(Assigned(CompareFunction))
   then CompareFunction :=CompByData;

   Result := Nil;
   Found := False;
   pIndex := rListInit;
   while ((pIndex <> Nil) and not Found) do
     if CompareFunction(ATag, pData, pIndex^.Data)
       then begin
               Result := pIndex;
               Found := True;
            end
       else pIndex := pIndex^.Next;
end;

//==============================================================================
//  TMGObject_List = class(TMGList)

constructor TMGObjectWithCreate.Create(dummy :Boolean);
begin
     inherited Create;
end;

function TMGObject_List.allocData :Pointer;
begin
     Result :=GetObjectClass.Create(true); //Why Tobject.Create is not virtual???
end;

procedure TMGObject_List.deallocData(pData :Pointer);
begin
     TObject(pData).Free;
end;

//==============================================================================
//  TMGList_List = class(TMGList)

function TMGList_List.allocData :Pointer;
begin
     Result :=GetObjectClass.Create;
end;

procedure TMGList_List.deallocData(pData :Pointer);
begin
     TMGList(pData).Free;
end;


end.