LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
   The object manager is used for registering classes together with a category,
6
   description + icon, so that they can be displayed visually.  This can then
7
   be used by run-time or design-time scene editors for choosing which
8
   scene objects to place into a scene.
9

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

13
  History :  
14
       11/11/09 - DaStr - Improved FPC compatibility
15
                             (thanks Predator) (BugtrackerID = 2893580)
16
       25/07/09 - DaStr - Added $I GLScene.inc
17
       26/03/09 - DanB - Added PopulateMenuWithRegisteredSceneObjects procedure.
18
       14/03/09 - DanB - Created by moving TGLObjectManager in from GLSceneRegister.pas,
19
                            made some slight adjustments to allow resources being loaded
20
                            from separate packages.
21
  
22
}
23

24
unit GLObjectManager;
25

26
interface
27

28
{$I GLScene.inc}
29

30
uses
31
  Classes,
32
  SysUtils,
33
  Graphics,
34
  Controls,
35
  Menus,
36
   
37
  GLCrossPlatform,
38
  GLScene,LResources;
39

40
type
41

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

53
  // TGLObjectManager
54
  //
55
  TGLObjectManager = class(TComponent)
56
  private
57
     
58
    FSceneObjectList: TList;
59
    FObjectIcons: TImageList; // a list of icons for scene objects
60
{$IFDEF MSWINDOWS}
61
    FOverlayIndex, // indices into the object icon list
62
{$ENDIF}
63
    FSceneRootIndex,
64
      FCameraRootIndex,
65
      FLightsourceRootIndex,
66
      FObjectRootIndex: Integer;
67
  protected
68
     
69
    procedure DestroySceneObjectList;
70
    function FindSceneObjectClass(AObjectClass: TGLSceneObjectClass;
71
      const ASceneObject: string = ''): PSceneObjectEntry;
72

73
  public
74
     
75
    constructor Create(AOwner: TComponent); override;
76
    destructor Destroy; override;
77

78

79
    procedure CreateDefaultObjectIcons;
80

81
    function GetClassFromIndex(Index: Integer): TGLSceneObjectClass;
82
    function GetImageIndex(ASceneObject: TGLSceneObjectClass): Integer;
83
    function GetCategory(ASceneObject: TGLSceneObjectClass): string;
84
    procedure GetRegisteredSceneObjects(ObjectList: TStringList);
85
    procedure PopulateMenuWithRegisteredSceneObjects(AMenuItem: TMenuItem; aClickEvent: TNotifyEvent);
86
    // Registers a stock object and adds it to the stock object list
87
    procedure RegisterSceneObject(ASceneObject: TGLSceneObjectClass; const aName, aCategory: string; ResourceModule: Cardinal; ResourceName: string = ''); overload;
88

89
    // Unregisters a stock object and removes it from the stock object list
90
    procedure UnRegisterSceneObject(ASceneObject: TGLSceneObjectClass);
91

92
    property ObjectIcons: TImageList read FObjectIcons;
93
    property SceneRootIndex: Integer read FSceneRootIndex;
94
    property LightsourceRootIndex: Integer read FLightsourceRootIndex;
95
    property CameraRootIndex: Integer read FCameraRootIndex;
96
    property ObjectRootIndex: Integer read FObjectRootIndex;
97
  end;
98
// ------------------------------------------------------------------
99
// ------------------------------------------------------------------
100
// ------------------------------------------------------------------
101
implementation
102
// ------------------------------------------------------------------
103
// ------------------------------------------------------------------
104
// ------------------------------------------------------------------
105

106
//----------------- TGLObjectManager ---------------------------------------------
107

108
// Create
109
//
110
constructor TGLObjectManager.Create(AOwner: TComponent);
111
begin
112
  inherited;
113
  FSceneObjectList := TList.Create;
114
  // FObjectIcons Width + Height are set when you add the first bitmap
115
  FObjectIcons := TImageList.CreateSize(16, 16);
116

117
  CreateDefaultObjectIcons;
118

119
end;
120

121
// Destroy
122
//
123
destructor TGLObjectManager.Destroy;
124
begin
125
  DestroySceneObjectList;
126
  FObjectIcons.Free;
127
  inherited Destroy;
128
end;
129

130
// FindSceneObjectClass
131
//
132
function TGLObjectManager.FindSceneObjectClass(AObjectClass: TGLSceneObjectClass;
133
  const aSceneObject: string = ''): PSceneObjectEntry;
134
var
135
  I: Integer;
136
  Found: Boolean;
137
begin
138
  Result := nil;
139
  Found := False;
140
  with FSceneObjectList do
141
  begin
142
    for I := 0 to Count - 1 do
143
      with TGLSceneObjectEntry(Items[I]^) do
144
        if (ObjectClass = AObjectClass) and (Length(ASceneObject) = 0)
145
          or (CompareText(Name, ASceneObject) = 0) then
146
        begin
147
          Found := True;
148
          Break;
149
        end;
150
    if Found then
151
      Result := Items[I];
152
  end;
153
end;
154

155
// GetClassFromIndex
156
//
157
function TGLObjectManager.GetClassFromIndex(Index: Integer): TGLSceneObjectClass;
158
begin
159
  if Index < 0 then
160
    Index := 0;
161
  if Index > FSceneObjectList.Count - 1 then
162
    Index := FSceneObjectList.Count - 1;
163
  Result := TGLSceneObjectEntry(FSceneObjectList.Items[Index + 1]^).ObjectClass;
164
end;
165

166
// GetImageIndex
167
//
168
function TGLObjectManager.GetImageIndex(ASceneObject: TGLSceneObjectClass): Integer;
169
var
170
  classEntry: PSceneObjectEntry;
171
begin
172
  classEntry := FindSceneObjectClass(ASceneObject);
173
  if Assigned(classEntry) then
174
    Result := classEntry^.ImageIndex
175
  else
176
    Result := 0;
177
end;
178

179
// GetCategory
180
//
181

182
function TGLObjectManager.GetCategory(ASceneObject: TGLSceneObjectClass): string;
183
var
184
  classEntry: PSceneObjectEntry;
185
begin
186
  classEntry := FindSceneObjectClass(ASceneObject);
187
  if Assigned(classEntry) then
188
    Result := classEntry^.Category
189
  else
190
    Result := '';
191
end;
192

193
// GetRegisteredSceneObjects
194
//
195
procedure TGLObjectManager.GetRegisteredSceneObjects(objectList: TStringList);
196
var
197
  i: Integer;
198
begin
199
  if Assigned(objectList) then
200
    with objectList do
201
    begin
202
      Clear;
203
      for i := 0 to FSceneObjectList.Count - 1 do
204
        with TGLSceneObjectEntry(FSceneObjectList.Items[I]^) do
205
          AddObject(Name, Pointer(ObjectClass));
206
    end;
207
end;
208

209
procedure TGLObjectManager.PopulateMenuWithRegisteredSceneObjects(AMenuItem: TMenuItem;
210
  aClickEvent: TNotifyEvent);
211
var
212
  objectList: TStringList;
213
  i, j: Integer;
214
  item, currentParent: TMenuItem;
215
  currentCategory: string;
216
  soc: TGLSceneObjectClass;
217
begin
218
  objectList := TStringList.Create;
219
  try
220
    GetRegisteredSceneObjects(objectList);
221
    for i := 0 to objectList.Count - 1 do
222
      if objectList[i] <> '' then
223
      begin
224
        currentCategory := GetCategory(TGLSceneObjectClass(objectList.Objects[i]));
225
        if currentCategory = '' then
226
          currentParent := AMenuItem
227
        else
228
        begin
229
          currentParent := NewItem(currentCategory, 0, False, True, nil, 0, '');
230
          AMenuItem.Add(currentParent);
231
        end;
232
        for j := i to objectList.Count - 1 do
233
          if objectList[j] <> '' then
234
          begin
235
            soc := TGLSceneObjectClass(objectList.Objects[j]);
236
            if currentCategory = GetCategory(soc) then
237
            begin
238
              item := NewItem(objectList[j], 0, False, True, aClickEvent, 0, '');
239
              item.ImageIndex := GetImageIndex(soc);
240
              currentParent.Add(item);
241
              objectList[j] := '';
242
              if currentCategory = '' then
243
                Break;
244
            end;
245
          end;
246
      end;
247
  finally
248
    objectList.Free;
249
  end;
250
end;
251

252
// RegisterSceneObject
253
//
254
{$IFNDEF FPC}
255
// RegisterSceneObject
256
//
257

258
procedure TGLObjectManager.RegisterSceneObject(ASceneObject: TGLSceneObjectClass;
259
  const aName, aCategory: string);
260
var
261
  resBitmapName: string;
262
  bmp: TBitmap;
263
begin
264
  // Since no resource name was provided, assume it's the same as class name
265
  resBitmapName := ASceneObject.ClassName;
266
  bmp := TBitmap.Create;
267
  try
268
    // Try loading bitmap from module that class is in
269
    GLLoadBitmapFromInstance(FindClassHInstance(ASceneObject), bmp, resBitmapName);
270
    if bmp.Width = 0 then
271
      GLLoadBitmapFromInstance(HInstance, bmp, resBitmapName);
272
    // If resource was found, register scene object with bitmap
273
    if bmp.Width <> 0 then
274
    begin
275
      RegisterSceneObject(ASceneObject, aName, aCategory, bmp);
276
    end
277
    else
278
      // Resource not found, so register without bitmap
279
      RegisterSceneObject(ASceneObject, aName, aCategory, nil);
280
  finally
281
    bmp.Free;
282
  end;
283
end;
284

285
// RegisterSceneObject
286
//
287

288
procedure TGLObjectManager.RegisterSceneObject(ASceneObject: TGLSceneObjectClass; const aName, aCategory: string; aBitmap: TBitmap);
289
var
290
  newEntry: PSceneObjectEntry;
291
  bmp: TBitmap;
292
begin
293
  if Assigned(RegisterNoIconProc) then
294
    RegisterNoIcon([aSceneObject]);
295
  with FSceneObjectList do
296
  begin
297
    // make sure no class is registered twice
298
    if Assigned(FindSceneObjectClass(ASceneObject, AName)) then
299
      Exit;
300
    New(NewEntry);
301
    try
302
      with NewEntry^ do
303
      begin
304
        // object stock stuff
305
        // registered objects list stuff
306
        ObjectClass := ASceneObject;
307
        NewEntry^.Name := aName;
308
        NewEntry^.Category := aCategory;
309
        Index := FSceneObjectList.Count;
310
        if Assigned(aBitmap) then
311
        begin
312
          bmp := TBitmap.Create;
313
          try
314
            // If we just add the bitmap, and it has different dimensions, then
315
            // all icons will be cleared, so ensure this doesn't happen
316
            bmp.PixelFormat := glpf24bit;
317
            bmp.Width := FObjectIcons.Width;
318
            bmp.Height := FObjectIcons.Height;
319
            bmp.Canvas.Draw(0, 0, aBitmap);
320
            FObjectIcons.AddMasked(bmp, bmp.Canvas.Pixels[0, 0]);
321
            ImageIndex := FObjectIcons.Count - 1;
322
          finally
323
            bmp.free;
324
          end;
325
        end
326
        else
327
          ImageIndex := 0;
328
      end;
329
      Add(NewEntry);
330
    finally
331
      //
332
    end;
333
  end;
334
end;
335

336
// RegisterSceneObject
337
//
338

339
procedure TGLObjectManager.RegisterSceneObject(ASceneObject: TGLSceneObjectClass; const aName, aCategory: string; ResourceModule: Cardinal; ResourceName: string = '');
340
var
341
  bmp: TBitmap;
342
  resBitmapName: string;
343
begin
344
  if ResourceName = '' then
345
    resBitmapName := ASceneObject.ClassName
346
  else
347
    resBitmapName := ResourceName;
348
  bmp := TBitmap.Create;
349
  try
350
    // Load resource
351
    if (ResourceModule <> 0) then
352
      GLLoadBitmapFromInstance(ResourceModule, bmp, resBitmapName);
353
    // If the resource was found, then register scene object using the bitmap
354
    if bmp.Width > 0 then
355
      RegisterSceneObject(ASceneObject, aName, aCategory, bmp)
356
    else
357
      // Register the scene object with no icon
358
      RegisterSceneObject(ASceneObject, aName, aCategory, nil);
359
  finally
360
    bmp.Free;
361
  end;
362
end;
363
{$ELSE}
364

365
procedure TGLObjectManager.RegisterSceneObject(ASceneObject: TGLSceneObjectClass; const aName, aCategory: string; ResourceModule: Cardinal; ResourceName: string = '');
366
var
367
  newEntry: PSceneObjectEntry;
368
  pic: TPicture;
369
  resBitmapName: string;
370
begin
371
  //>>Lazarus will crash at this function
372
  if Assigned(RegisterNoIconProc) then
373
    RegisterNoIcon([ASceneObject]);
374
  //Writeln('GL Registered ',ASceneObject.classname);
375
  Classes.RegisterClass(ASceneObject);
376
  with FSceneObjectList do
377
  begin
378
    // make sure no class is registered twice
379
    if Assigned(FindSceneObjectClass(ASceneObject, AName)) then
380
      Exit;
381
    New(NewEntry);
382
    pic := TPicture.Create;
383
    try
384
      with NewEntry^ do
385
      begin
386
        // object stock stuff
387
        // registered objects list stuff
388
        ObjectClass := ASceneObject;
389
        NewEntry^.Name := aName;
390
        NewEntry^.Category := aCategory;
391
        Index := FSceneObjectList.Count;
392
        resBitmapName := ASceneObject.ClassName;
393
        if LazarusResources.Find(resBitmapName) <> nil then
394
        begin
395
          try
396
            FObjectIcons.AddLazarusResource(resBitmapName);
397
          except
398
          end;
399
          ImageIndex := FObjectIcons.Count - 1;
400
        end
401
        else
402
        begin
403
          ImageIndex := 0;
404
        end;
405
      end;
406
      Add(NewEntry);
407
    finally
408
      pic.Free;
409
    end;
410
  end;
411
end;
412
{$ENDIF}
413

414
// UnRegisterSceneObject
415
//
416

417
procedure TGLObjectManager.UnRegisterSceneObject(ASceneObject: TGLSceneObjectClass);
418
var
419
  oldEntry: PSceneObjectEntry;
420
begin
421
  // find the class in the scene object list
422
  OldEntry := FindSceneObjectClass(ASceneObject);
423
  // found?
424
  if assigned(OldEntry) then
425
  begin
426
    // remove its entry from the list of registered objects
427
    FSceneObjectList.Remove(OldEntry);
428
    // finally free the memory for the entry
429
    Dispose(OldEntry);
430
  end;
431
end;
432

433
// CreateDefaultObjectIcons
434
//
435

436

437
procedure TGLObjectManager.CreateDefaultObjectIcons;
438
begin
439
  with FObjectIcons do
440
  begin
441
    if LazarusResources.Find('gls_cross') <> nil then
442
      try
443
        AddLazarusResource('gls_cross');
444
      except
445
      end;
446
    // FOverlayIndex:=Count-1;
447
    if LazarusResources.Find('gls_root') <> nil then
448
      try
449
        AddLazarusResource('gls_root');
450
      except
451
      end;
452
    FSceneRootIndex := Count - 1;
453
    if LazarusResources.Find('gls_camera') <> nil then
454
      try
455
        AddLazarusResource('gls_camera');
456
      except
457
      end;
458
    FCameraRootIndex := Count - 1;
459
    if LazarusResources.Find('gls_lights') <> nil then
460
      try
461
        AddLazarusResource('gls_lights');
462
      except
463
      end;
464
    FLightsourceRootIndex := Count - 1;
465
    if LazarusResources.Find('gls_objects') <> nil then
466
      try
467
        AddLazarusResource('gls_objects');
468
      except
469
      end;
470
    FObjectRootIndex := Count - 1;
471
    if LazarusResources.Find('gls_objects') <> nil then
472
      try
473
        AddLazarusResource('gls_objects');
474
      except
475
      end;
476
  end;
477
end;
478

479
// DestroySceneObjectList
480
//
481

482
procedure TGLObjectManager.DestroySceneObjectList;
483
var
484
  i: Integer;
485
begin
486
  with FSceneObjectList do
487
  begin
488
    for i := 0 to Count - 1 do
489
      Dispose(PSceneObjectEntry(Items[I]));
490
    Free;
491
  end;
492
end;
493

494
initialization
495

496
{$I ../../Resources/GLSceneObjects.lrs}
497

498

499
end.
500

501