GLScene/Source/GLObjectManager.pas

//
// This unit is part of the GLScene Engine, http://glscene.org
//

unit GLObjectManager;

(*
   The object manager is used for registering classes together with a category,
   description + icon, so that they can be displayed visually.  This can then
   be used by run-time or design-time scene editors for choosing which
   scene objects to place into a scene.

   TODO: add some notification code, so that when a scene object is registered/
   unregistered, any editor that is using the object manager can be notified.
*)

interface

{$I GLScene.inc}

uses
  System.Classes,
  System.SysUtils,
  VCL.Graphics,
  VCL.Controls,
  VCL.Menus,
  
  GLCrossPlatform,
  GLScene;

type
  PSceneObjectEntry = ^TGLSceneObjectEntry;
  // holds a relation between an scene object class, its global identification,
  // its location in the object stock and its icon reference
  TGLSceneObjectEntry = record
    ObjectClass: TGLSceneObjectClass;
    Name: string; // type name of the object
    Category: string; // category of object
    Index, // index into "FSceneObjectList"
    ImageIndex: Integer; // index into "FObjectIcons"
  end;

  TGLObjectManager = class(TComponent)
  private
    FSceneObjectList: TList;
    FObjectIcons: TImageList; // a list of icons for scene objects
    FOverlayIndex, // indices into the object icon list
    FSceneRootIndex,
      FCameraRootIndex,
      FLightsourceRootIndex,
      FObjectRootIndex: Integer;
  protected
    procedure DestroySceneObjectList;
    function FindSceneObjectClass(AObjectClass: TGLSceneObjectClass;
      const ASceneObject: string = ''): PSceneObjectEntry;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CreateDefaultObjectIcons(ResourceModule: Cardinal);
    function GetClassFromIndex(Index: Integer): TGLSceneObjectClass;
    function GetImageIndex(ASceneObject: TGLSceneObjectClass): Integer;
    function GetCategory(ASceneObject: TGLSceneObjectClass): string;
    procedure GetRegisteredSceneObjects(ObjectList: TStringList);
    procedure PopulateMenuWithRegisteredSceneObjects(AMenuItem: TMenuItem; aClickEvent: TNotifyEvent);
    // Registers a stock object and adds it to the stock object list
    procedure RegisterSceneObject(ASceneObject: TGLSceneObjectClass; 
	  const aName, aCategory: string); overload;
    procedure RegisterSceneObject(ASceneObject: TGLSceneObjectClass; 
	  const aName, aCategory: string; aBitmap: TBitmap); overload;
    procedure RegisterSceneObject(ASceneObject: TGLSceneObjectClass; 
	  const aName, aCategory: string; ResourceModule: Cardinal; ResourceName: string = ''); overload;
    // Unregisters a stock object and removes it from the stock object list
    procedure UnRegisterSceneObject(ASceneObject: TGLSceneObjectClass);

    property ObjectIcons: TImageList read FObjectIcons;
    property SceneRootIndex: Integer read FSceneRootIndex;
    property LightsourceRootIndex: Integer read FLightsourceRootIndex;
    property CameraRootIndex: Integer read FCameraRootIndex;
    property ObjectRootIndex: Integer read FObjectRootIndex;
  end;

// ------------------------------------------------------------------
implementation
// ------------------------------------------------------------------

constructor TGLObjectManager.Create(AOwner: TComponent);
begin
  inherited;
  FSceneObjectList := TList.Create;
  // FObjectIcons Width + Height are set when you add the first bitmap
  FObjectIcons := TImageList.CreateSize(16, 16);
end;

destructor TGLObjectManager.Destroy;
begin
  DestroySceneObjectList;
  FObjectIcons.Free;
  inherited Destroy;
end;

function TGLObjectManager.FindSceneObjectClass(AObjectClass: TGLSceneObjectClass;
  const aSceneObject: string = ''): PSceneObjectEntry;
var
  I: Integer;
  Found: Boolean;
begin
  Result := nil;
  Found := False;
  with FSceneObjectList do
  begin
    for I := 0 to Count - 1 do
      with TGLSceneObjectEntry(Items[I]^) do
        if (ObjectClass = AObjectClass) and (Length(ASceneObject) = 0)
          or (CompareText(Name, ASceneObject) = 0) then
        begin
          Found := True;
          Break;
        end;
    if Found then
      Result := Items[I];
  end;
end;

function TGLObjectManager.GetClassFromIndex(Index: Integer): TGLSceneObjectClass;
begin
  if Index < 0 then
    Index := 0;
  if Index > FSceneObjectList.Count - 1 then
    Index := FSceneObjectList.Count - 1;
  Result := TGLSceneObjectEntry(FSceneObjectList.Items[Index + 1]^).ObjectClass;
end;

function TGLObjectManager.GetImageIndex(ASceneObject: TGLSceneObjectClass): Integer;
var
  classEntry: PSceneObjectEntry;
begin
  classEntry := FindSceneObjectClass(ASceneObject);
  if Assigned(classEntry) then
    Result := classEntry^.ImageIndex
  else
    Result := 0;
end;

function TGLObjectManager.GetCategory(ASceneObject: TGLSceneObjectClass): string;
var
  classEntry: PSceneObjectEntry;
begin
  classEntry := FindSceneObjectClass(ASceneObject);
  if Assigned(classEntry) then
    Result := classEntry^.Category
  else
    Result := '';
end;

procedure TGLObjectManager.GetRegisteredSceneObjects(objectList: TStringList);
var
  i: Integer;
begin
  if Assigned(objectList) then
    with objectList do
    begin
      Clear;
      for i := 0 to FSceneObjectList.Count - 1 do
        with TGLSceneObjectEntry(FSceneObjectList.Items[I]^) do
          AddObject(Name, Pointer(ObjectClass));
    end;
end;

procedure TGLObjectManager.PopulateMenuWithRegisteredSceneObjects(AMenuItem: TMenuItem;
  AClickEvent: TNotifyEvent);
var
  ObjectList: TStringList;
  i, j: Integer;
  Item, CurrentParent: TMenuItem;
  CurrentCategory: string;
  Soc: TGLSceneObjectClass;
begin
  ObjectList := TStringList.Create;
  try
    GetRegisteredSceneObjects(ObjectList);
    for i := 0 to ObjectList.Count - 1 do
      if ObjectList[i] <> '' then
      begin
        CurrentCategory := GetCategory(TGLSceneObjectClass(ObjectList.Objects[i]));
        if CurrentCategory = '' then
          CurrentParent := AMenuItem
        else
        begin
          CurrentParent := NewItem(CurrentCategory, 0, False, True, nil, 0, '');
          AMenuItem.Add(CurrentParent);
        end;
        for j := i to ObjectList.Count - 1 do
          if ObjectList[j] <> '' then
          begin
            Soc := TGLSceneObjectClass(ObjectList.Objects[j]);
            if CurrentCategory = GetCategory(Soc) then
            begin
              Item := NewItem(objectList[j], 0, False, True, AClickEvent, 0, '');
              Item.ImageIndex := GetImageIndex(Soc);
              CurrentParent.Add(Item);
              ObjectList[j] := '';
              if CurrentCategory = '' then
                Break;
            end;
          end;
      end;
  finally
    ObjectList.Free;
  end;
end;

procedure TGLObjectManager.RegisterSceneObject(ASceneObject: TGLSceneObjectClass;
  const aName, aCategory: string);
var
  resBitmapName: string;
  bmp: TBitmap;
begin
  // Since no resource name was provided, assume it's the same as class name
  resBitmapName := ASceneObject.ClassName;
  bmp := TBitmap.Create;
  try
    // Try loading bitmap from module that class is in
    GLLoadBitmapFromInstance(FindClassHInstance(ASceneObject), bmp, resBitmapName);
    if bmp.Width = 0 then
      GLLoadBitmapFromInstance(HInstance, bmp, resBitmapName);
    // If resource was found, register scene object with bitmap
    if bmp.Width <> 0 then
    begin
      RegisterSceneObject(ASceneObject, aName, aCategory, bmp);
    end
    else
      // Resource not found, so register without bitmap
      RegisterSceneObject(ASceneObject, aName, aCategory, nil);
  finally
    bmp.Free;
  end;
end;

procedure TGLObjectManager.RegisterSceneObject(ASceneObject: TGLSceneObjectClass; const aName, aCategory: string; aBitmap: TBitmap);
var
  newEntry: PSceneObjectEntry;
  bmp: TBitmap;
begin
  if Assigned(RegisterNoIconProc) then
    RegisterNoIcon([aSceneObject]);
  with FSceneObjectList do
  begin
    // make sure no class is registered twice
    if Assigned(FindSceneObjectClass(ASceneObject, AName)) then
      Exit;
    New(NewEntry);
    try
      with NewEntry^ do
      begin
        // object stock stuff
        // registered objects list stuff
        ObjectClass := ASceneObject;
        NewEntry^.Name := aName;
        NewEntry^.Category := aCategory;
        Index := FSceneObjectList.Count;
        if Assigned(aBitmap) then
        begin
          bmp := TBitmap.Create;
          try
            // If we just add the bitmap, and it has different dimensions, then
            // all icons will be cleared, so ensure this doesn't happen
            bmp.PixelFormat := pf24bit;
            bmp.Width := FObjectIcons.Width;
            bmp.Height := FObjectIcons.Height;
            bmp.Canvas.Draw(0, 0, ABitmap);
            FObjectIcons.AddMasked(bmp, bmp.Canvas.Pixels[0, 0]);
            ImageIndex := FObjectIcons.Count - 1;
          finally
            bmp.free;
          end;
        end
        else
          ImageIndex := 0;
      end;
      Add(NewEntry);
    finally
      //
    end;
  end;
end;

procedure TGLObjectManager.RegisterSceneObject(ASceneObject: TGLSceneObjectClass; const aName, aCategory: string; ResourceModule: Cardinal; ResourceName: string = '');
var
  bmp: TBitmap;
  resBitmapName: string;
begin
  if ResourceName = '' then
    resBitmapName := ASceneObject.ClassName
  else
    resBitmapName := ResourceName;
  bmp := TBitmap.Create;
  try
    // Load resource
    if (ResourceModule <> 0) then
      GLLoadBitmapFromInstance(ResourceModule, bmp, resBitmapName);
    // If the resource was found, then register scene object using the bitmap
    if bmp.Width > 0 then
      RegisterSceneObject(ASceneObject, aName, aCategory, bmp)
    else
      // Register the scene object with no icon
      RegisterSceneObject(ASceneObject, aName, aCategory, nil);
  finally
    bmp.Free;
  end;
end;

procedure TGLObjectManager.UnRegisterSceneObject(ASceneObject: TGLSceneObjectClass);
var
  oldEntry: PSceneObjectEntry;
begin
  // find the class in the scene object list
  OldEntry := FindSceneObjectClass(ASceneObject);
  // found?
  if assigned(OldEntry) then
  begin
    // remove its entry from the list of registered objects
    FSceneObjectList.Remove(OldEntry);
    // finally free the memory for the entry
    Dispose(OldEntry);
  end;
end;

procedure TGLObjectManager.CreateDefaultObjectIcons(ResourceModule: Cardinal);
var
  bmp: TBitmap;
begin
  bmp := TBitmap.Create;
  with FObjectIcons, bmp.Canvas do
  begin
    try
      // There's a more direct way for loading images into the image list, but
      // the image quality suffers too much
{$IFDEF WIN32}
      GLLoadBitmapFromInstance(ResourceModule, bmp, 'gls_cross');
      FOverlayIndex := AddMasked(bmp, Pixels[0, 0]);
      Overlay(FOverlayIndex, 0); // used as indicator for disabled objects
{$ENDIF}
      GLLoadBitmapFromInstance(ResourceModule, bmp, 'gls_root');
      FSceneRootIndex := AddMasked(bmp, Pixels[0, 0]);
      GLLoadBitmapFromInstance(ResourceModule, bmp, 'gls_camera');
      FCameraRootIndex := AddMasked(bmp, Pixels[0, 0]);
      GLLoadBitmapFromInstance(ResourceModule, bmp, 'gls_lights');
      FLightsourceRootIndex := AddMasked(bmp, Pixels[0, 0]);
      GLLoadBitmapFromInstance(ResourceModule, bmp, 'gls_objects');
      FObjectRootIndex := AddMasked(bmp, Pixels[0, 0]);
    finally
      bmp.Free;
    end;
  end;
end;

procedure TGLObjectManager.DestroySceneObjectList;
var
  i: Integer;
begin
  with FSceneObjectList do
  begin
    for i := 0 to Count - 1 do
      Dispose(PSceneObjectEntry(Items[I]));
    Free;
  end;
end;

//-------------------------------------------
initialization
//-------------------------------------------

end.