1 // SPDX-License-Identifier: LGPL-3.0-linking-exception
2 unit BGRAScene3D;
3 
4 {$mode objfpc}{$H+}
5 
6 interface
7 
8 uses
9   BGRAClasses, SysUtils, BGRABitmapTypes, BGRAColorInt,
10   BGRASSE, BGRAMatrix3D,
11   BGRASceneTypes, BGRARenderer3D;
12 
13 type
14   TProjection3D = BGRAMatrix3D.TProjection3D;
15   TLightingNormal3D = BGRASceneTypes.TLightingNormal3D;
16   TLightingInterpolation3D = BGRASceneTypes.TLightingInterpolation3D;
17   TAntialiasingMode3D = BGRASceneTypes.TAntialiasingMode3D;
18   TPerspectiveMode3D = BGRASceneTypes.TPerspectiveMode3D;
19   TRenderingOptions = BGRASceneTypes.TRenderingOptions;
20 
21   IBGRAVertex3D = BGRASceneTypes.IBGRAVertex3D;
22   IBGRANormal3D = BGRASceneTypes.IBGRANormal3D;
23   IBGRALight3D = BGRASceneTypes.IBGRALight3D;
24   IBGRADirectionalLight3D = BGRASceneTypes.IBGRADirectionalLight3D;
25   IBGRAPointLight3D = BGRASceneTypes.IBGRAPointLight3D;
26   IBGRAMaterial3D = BGRASceneTypes.IBGRAMaterial3D;
27   IBGRAFace3D = BGRASceneTypes.IBGRAFace3D;
28   IBGRAPart3D = BGRASceneTypes.IBGRAPart3D;
29   IBGRAObject3D = BGRASceneTypes.IBGRAObject3D;
30 
31   arrayOfIBGRAVertex3D = BGRASceneTypes.arrayOfIBGRAVertex3D;
32 
33 const
34   lnNone = BGRASceneTypes.lnNone;
35   lnFace = BGRASceneTypes.lnFace;
36   lnVertex = BGRASceneTypes.lnVertex;
37   lnFaceVertexMix = BGRASceneTypes.lnFaceVertexMix;
38 
39   liLowQuality = BGRASceneTypes.liLowQuality;
40   liSpecularHighQuality = BGRASceneTypes.liSpecularHighQuality;
41   liAlwaysHighQuality = BGRASceneTypes.liAlwaysHighQuality;
42 
43   am3dNone = BGRASceneTypes.am3dNone;
44   am3dMultishape = BGRASceneTypes.am3dMultishape;
45   am3dResample = BGRASceneTypes.am3dResample;
46 
47   pmLinearMapping = BGRASceneTypes.pmLinearMapping;
48   pmPerspectiveMapping = BGRASceneTypes.pmPerspectiveMapping;
49   pmZBuffer = BGRASceneTypes.pmZBuffer;
50 
51 type
52 
53   { TCamera3D }
54 
55   TCamera3D = class
56   private
57     procedure ComputeMatrix;
GetLookWherenull58     function GetLookWhere: TPoint3D;
GetMatrixnull59     function GetMatrix: TMatrix3D;
GetViewPointnull60     function GetViewPoint: TPoint3D;
61     procedure SetMatrix(AValue: TMatrix3D);
62     procedure SetViewPoint(AValue: TPoint3D);
63   protected
64     FMatrix: TMatrix3D;
65     FMatrixComputed: boolean;
66     FViewPoint: TPoint3D_128;
67     FLookWhere, FTopDir: TPoint3D_128;
68   public
69     procedure LookAt(AWhere: TPoint3D; ATopDir: TPoint3D);
70     procedure LookDown(angleDeg: single);
71     procedure LookLeft(angleDeg: single);
72     procedure LookRight(angleDeg: single);
73     procedure LookUp(angleDeg: single);
74     property ViewPoint: TPoint3D read GetViewPoint write SetViewPoint;
75     property LookWhere: TPoint3D read GetLookWhere;
76     property Matrix: TMatrix3D read GetMatrix write SetMatrix;
77   end;
78 
79   { TBGRAScene3D }
80 
81   TBGRAScene3D = class
82   private
83     FSurface: TBGRACustomBitmap; //destination of software renderer
84     FViewCenter: TPointF;        //where origin is drawn
85     FAutoViewCenter: boolean;    //use middle of the screen
86     FZoom: TPointF;              //how much the drawing is zoomed
87     FAutoZoom: Boolean;          //display 1 as 80% of surface size
88     FProjection: TProjection3D;  //current projection
89     FRenderedFaceCount: integer; //current counter of rendered faces
90 
91     FCamera: TCamera3D;
92 
93     FObjects: array of IBGRAObject3D;
94     FObjectCount: integer;
95     FMaterials: array of IBGRAMaterial3D;
96     FMaterialCount: integer;
97     FDefaultMaterial : IBGRAMaterial3D;
98 
99     FAmbiantLightColorF: TColorF;        //lightness without light sources
100     FLights: TList;                      //individual light sources
101 
GetAmbiantLightColorFnull102     function GetAmbiantLightColorF: TColorF;
GetAmbiantLightnessnull103     function GetAmbiantLightness: single;
GetAmbiantLightColornull104     function GetAmbiantLightColor: TBGRAPixel;
GetFaceCountnull105     function GetFaceCount: integer;
GetLightnull106     function GetLight(AIndex: integer): IBGRALight3D;
GetLightCountnull107     function GetLightCount: integer;
GetMaterialnull108     function GetMaterial(AIndex: integer): IBGRAMaterial3D;
GetNormalCountnull109     function GetNormalCount: integer;
GetObjectnull110     function GetObject(AIndex: integer): IBGRAObject3D;
GetVertexCountnull111     function GetVertexCount: integer;
GetViewCenternull112     function GetViewCenter: TPointF;
GetViewPointnull113     function GetViewPoint: TPoint3D;
GetZoomnull114     function GetZoom: TPointF;
115     procedure SetAmbiantLightColorF(const AValue: TColorF);
116     procedure SetAmbiantLightness(const AValue: single);
117     procedure SetAmbiantLightColor(const AValue: TBGRAPixel);
118     procedure SetAutoViewCenter(const AValue: boolean);
119     procedure SetAutoZoom(const AValue: boolean);
120     procedure SetViewCenter(const AValue: TPointF);
121     procedure SetViewPoint(const AValue: TPoint3D);
122     procedure ComputeView(ScaleX,ScaleY: single);
ComputeCoordinatenull123     function ComputeCoordinate(AViewCoord: TPoint3D_128): TPointF;
124     procedure AddObject(AObj: IBGRAObject3D);
125     procedure AddLight(ALight: TObject);
126     procedure AddMaterial(AMaterial: IBGRAMaterial3D);
127     procedure Init;
128 
129   protected
130     FRenderer: TCustomRenderer3D;
131     FMaterialLibrariesFetched: array of string;
132     FTexturesFetched: array of record
133         Name: string;
134         Bitmap: TBGRACustomBitmap;
135       end;
136     procedure UseMaterial(AMaterialName: string; AFace: IBGRAFace3D); virtual;
LoadBitmapFromFileUTF8null137     function LoadBitmapFromFileUTF8(AFilenameUTF8: string): TBGRACustomBitmap; virtual;
FetchTexturenull138     function FetchTexture(AName: string; out texSize: TPointF): IBGRAScanner; virtual;
139     procedure HandleFetchException(AException: Exception); virtual;
140     procedure DoRender; virtual;
141     procedure DoClear; virtual;
GetRenderWidthnull142     function GetRenderWidth: integer;
GetRenderHeightnull143     function GetRenderHeight: integer;
144     procedure OnMaterialTextureChanged({%H-}ASender: TObject); virtual;
145     procedure SetDefaultMaterial(AValue: IBGRAMaterial3D);
146     procedure InvalidateMaterial;
147 
148   public
149     DefaultLightingNormal: TLightingNormal3D;
150     RenderingOptions: TRenderingOptions;
151     UnknownColor: TBGRAPixel;
152     FetchDirectory: string;
153     FetchThrowsException: boolean;
154 
155     constructor Create; overload;
156     constructor Create(ASurface: TBGRACustomBitmap); overload;
157     destructor Destroy; override;
158     procedure Clear; virtual;
FetchObjectnull159     function FetchObject(AName: string; SwapFacesOrientation: boolean = true): IBGRAObject3D;
160     procedure FetchMaterials(ALibraryName: string); virtual;
LoadObjectFromFilenull161     function LoadObjectFromFile(AFilename: string; SwapFacesOrientation: boolean = true): IBGRAObject3D;
LoadObjectFromFileUTF8null162     function LoadObjectFromFileUTF8(AFilename: string; SwapFacesOrientation: boolean = true): IBGRAObject3D;
LoadObjectFromStreamnull163     function LoadObjectFromStream(AStream: TStream; SwapFacesOrientation: boolean = true): IBGRAObject3D;
164     procedure LoadMaterialsFromFile(AFilename: string);
165     procedure LoadMaterialsFromFileUTF8(AFilename: string);
166     procedure LoadMaterialsFromStream(AStream: TStream);
167     procedure LookAt(AWhere: TPoint3D; ATopDir: TPoint3D);
168     procedure LookLeft(angleDeg: single);
169     procedure LookRight(angleDeg: single);
170     procedure LookUp(angleDeg: single);
171     procedure LookDown(angleDeg: single);
172     procedure Render;  overload; virtual;
173     procedure Render(ARenderer: TCustomRenderer3D); overload;
CreateObjectnull174     function CreateObject: IBGRAObject3D; overload;
CreateObjectnull175     function CreateObject(ATexture: IBGRAScanner): IBGRAObject3D; overload;
CreateObjectnull176     function CreateObject(AColor: TBGRAPixel): IBGRAObject3D; overload;
CreateSpherenull177     function CreateSphere(ARadius: Single; AHorizPrecision: integer = 8; AVerticalPrecision : integer = 6): IBGRAObject3D; overload;
CreateSpherenull178     function CreateSphere(ARadius: Single; AColor: TBGRAPixel; AHorizPrecision: integer = 8; AVerticalPrecision : integer = 6): IBGRAObject3D; overload;
CreateHalfSpherenull179     function CreateHalfSphere(ARadius: Single; AHorizPrecision: integer = 6; AVerticalPrecision : integer = 6): IBGRAObject3D; overload;
CreateHalfSpherenull180     function CreateHalfSphere(ARadius: Single; AColor: TBGRAPixel; AHorizPrecision: integer = 6; AVerticalPrecision : integer = 6): IBGRAObject3D; overload;
181     procedure RemoveObject(AObject: IBGRAObject3D);
AddDirectionalLightnull182     function AddDirectionalLight(ADirection: TPoint3D; ALightness: single = 1; AMinIntensity : single = 0): IBGRADirectionalLight3D; overload;
AddDirectionalLightnull183     function AddDirectionalLight(ADirection: TPoint3D; AColor: TBGRAPixel; AMinIntensity: single = 0): IBGRADirectionalLight3D; overload;
AddPointLightnull184     function AddPointLight(AVertex: IBGRAVertex3D; AOptimalDistance: single; ALightness: single = 1; AMinIntensity : single = 0): IBGRAPointLight3D; overload;
AddPointLightnull185     function AddPointLight(AVertex: IBGRAVertex3D; AOptimalDistance: single; AColor: TBGRAPixel; AMinIntensity: single = 0): IBGRAPointLight3D; overload;
186     procedure RemoveLight(ALight: IBGRALight3D);
187     procedure SetZoom(value: Single); overload;
188     procedure SetZoom(value: TPointF); overload;
CreateMaterialnull189     function CreateMaterial: IBGRAMaterial3D; overload;
CreateMaterialnull190     function CreateMaterial(ASpecularIndex: integer): IBGRAMaterial3D; overload;
GetMaterialByNamenull191     function GetMaterialByName(AName: string): IBGRAMaterial3D;
192     procedure UpdateMaterials; virtual;
193     procedure UpdateMaterial(AMaterialName: string); virtual;
194     procedure ForEachVertex(ACallback: TVertex3DCallback);
195     procedure ForEachFace(ACallback: TFace3DCallback);
MakeLightListnull196     function MakeLightList: TList;
197 
198     property ViewCenter: TPointF read GetViewCenter write SetViewCenter;
199     property AutoViewCenter: boolean read FAutoViewCenter write SetAutoViewCenter;
200     property AutoZoom: boolean read FAutoZoom write SetAutoZoom;
201     property Surface: TBGRACustomBitmap read FSurface write FSurface;
202     property Object3D[AIndex: integer]: IBGRAObject3D read GetObject;
203     property Object3DCount: integer read FObjectCount;
204     property VertexCount: integer read GetVertexCount;
205     property NormalCount: integer read GetNormalCount;
206     property FaceCount: integer read GetFaceCount;
207     property Zoom: TPointF read GetZoom write SetZoom;
208     property AmbiantLightness: single read GetAmbiantLightness write SetAmbiantLightness;
209     property AmbiantLightColor: TBGRAPixel read GetAmbiantLightColor write SetAmbiantLightColor;
210     property AmbiantLightColorF: TColorF read GetAmbiantLightColorF write SetAmbiantLightColorF;
211     property LightCount: integer read GetLightCount;
212     property Light[AIndex: integer]: IBGRALight3D read GetLight;
213     property ViewPoint: TPoint3D read GetViewPoint write SetViewPoint;
214     property RenderedFaceCount : integer read FRenderedFaceCount;
215     property Material[AIndex: integer] : IBGRAMaterial3D read GetMaterial;
216     property MaterialCount: integer read FMaterialCount;
217     property Camera: TCamera3D read FCamera;
218     property DefaultMaterial: IBGRAMaterial3D read FDefaultMaterial write SetDefaultMaterial;
219   end;
220 
221 implementation
222 
223 uses BGRACoordPool3D, BGRAUTF8;
224 
225 {$i lightingclasses3d.inc}
226 {$i vertex3d.inc}
227 {$i face3d.inc}
228 {$i part3d.inc}
229 {$i object3d.inc}
230 {$i shapes3d.inc}
231 
232 { TCamera3D }
233 
GetLookWherenull234 function TCamera3D.GetLookWhere: TPoint3D;
235 begin
236   result := Point3D(FLookWhere);
237 end;
238 
GetMatrixnull239 function TCamera3D.GetMatrix: TMatrix3D;
240 begin
241   if not FMatrixComputed then
242   begin
243     ComputeMatrix;
244     FMatrixComputed := true;
245   end;
246   result := FMatrix;
247 end;
248 
TCamera3D.GetViewPointnull249 function TCamera3D.GetViewPoint: TPoint3D;
250 begin
251   result := Point3D(FViewPoint);
252 end;
253 
254 procedure TCamera3D.SetMatrix(AValue: TMatrix3D);
255 begin
256   FMatrix := AValue;
257   FMatrixComputed:= true;
258   FViewPoint := Point3D_128(FMatrix[1,4],FMatrix[2,4],FMatrix[3,4]);
259 end;
260 
261 procedure TCamera3D.SetViewPoint(AValue: TPoint3D);
262 begin
263   FViewPoint := Point3D_128(AValue);
264   FMatrix[1,4] := FViewPoint.x;
265   FMatrix[2,4] := FViewPoint.y;
266   FMatrix[3,4] := FViewPoint.z;
267   FMatrixComputed := false;
268 end;
269 
270 procedure TCamera3D.ComputeMatrix;
271 var ZDir, XDir, YDir: TPoint3D_128;
272 begin
273   if IsPoint3D_128_Zero(FTopDir) then exit;
274   YDir := -FTopDir;
275   Normalize3D_128(YDir);
276 
277   ZDir := FLookWhere-FViewPoint;
278   if IsPoint3D_128_Zero(ZDir) then exit;
279   Normalize3D_128(ZDir);
280 
281   VectProduct3D_128(YDir,ZDir,XDir);
282   VectProduct3D_128(ZDir,XDir,YDir); //correct Y dir
283   Normalize3D_128(XDir);
284   Normalize3D_128(YDir);
285 
286   FMatrix := Matrix3D(XDir,YDir,ZDir,FViewPoint);
287   FMatrix := MatrixInverse3D(FMatrix);
288 end;
289 
290 procedure TCamera3D.LookAt(AWhere: TPoint3D; ATopDir: TPoint3D);
291 begin
292   FLookWhere := Point3D_128(AWhere);
293   FTopDir := Point3D_128(ATopDir);
294   FMatrixComputed := false;
295 end;
296 
297 procedure TCamera3D.LookLeft(angleDeg: single);
298 var m,inv: TMatrix3D;
299 begin
300   inv := MatrixInverse3D(Matrix);
301   m := MatrixRotateY(angleDeg*Pi/180);
302   FLookWhere := inv*m*Matrix*FLookWhere;
303   FMatrixComputed := false;
304 end;
305 
306 procedure TCamera3D.LookRight(angleDeg: single);
307 begin
308   LookLeft(-angleDeg);
309 end;
310 
311 procedure TCamera3D.LookUp(angleDeg: single);
312 var m,inv: TMatrix3D;
313 begin
314   inv := MatrixInverse3D(Matrix);
315   m := MatrixRotateX(-angleDeg*Pi/180);
316   FLookWhere := inv*m*Matrix*FLookWhere;
317   FMatrixComputed := false;
318 end;
319 
320 procedure TCamera3D.LookDown(angleDeg: single);
321 begin
322   LookUp(-angleDeg);
323 end;
324 
325 
326 { TBGRAScene3D }
327 
TBGRAScene3D.GetViewCenternull328 function TBGRAScene3D.GetViewCenter: TPointF;
329 begin
330   if FAutoViewCenter then
331   begin
332     result := PointF((GetRenderWidth-1)/2,(GetRenderHeight-1)/2)
333   end
334   else
335     result := FViewCenter;
336 end;
337 
TBGRAScene3D.GetViewPointnull338 function TBGRAScene3D.GetViewPoint: TPoint3D;
339 begin
340   result := Camera.ViewPoint;
341 end;
342 
GetZoomnull343 function TBGRAScene3D.GetZoom: TPointF;
344 var size: single;
345 begin
346   if FAutoZoom then
347   begin
348     Size := sqrt(GetRenderWidth*GetRenderHeight)*0.8;
349     if Size = 0 then
350       result := PointF(1,1)
351     else
352       result := PointF(size,size);
353   end else
354     result := FZoom;
355 end;
356 
357 procedure TBGRAScene3D.SetAmbiantLightColorF(const AValue: TColorF);
358 begin
359   FAmbiantLightColorF := AValue;
360 end;
361 
362 procedure TBGRAScene3D.SetAmbiantLightness(const AValue: single);
363 begin
364   FAmbiantLightColorF := ColorF(AValue, AValue, AValue, 1);
365 end;
366 
367 procedure TBGRAScene3D.SetAmbiantLightColor(const AValue: TBGRAPixel);
368 begin
369   FAmbiantLightColorF := ColorInt65536ToColorF(BGRAToColorInt(AValue,True));
370 end;
371 
TBGRAScene3D.GetObjectnull372 function TBGRAScene3D.GetObject(AIndex: integer): IBGRAObject3D;
373 begin
374   if (AIndex < 0) or (AIndex >= FObjectCount) then
375     raise exception.Create('Index out of bounds');
376   result := FObjects[AIndex];
377 end;
378 
GetVertexCountnull379 function TBGRAScene3D.GetVertexCount: integer;
380 var i: integer;
381 begin
382   result := 0;
383   for i := 0 to Object3DCount-1 do
384     inc(result, Object3D[i].TotalVertexCount);
385 end;
386 
GetAmbiantLightColornull387 function TBGRAScene3D.GetAmbiantLightColor: TBGRAPixel;
388 begin
389   result := ColorIntToBGRA(ColorFToColorInt65536(FAmbiantLightColorF),True);
390 end;
391 
TBGRAScene3D.GetFaceCountnull392 function TBGRAScene3D.GetFaceCount: integer;
393 var i: integer;
394 begin
395   result := 0;
396   for i := 0 to Object3DCount-1 do
397     inc(result, Object3D[i].FaceCount);
398 end;
399 
TBGRAScene3D.GetLightnull400 function TBGRAScene3D.GetLight(AIndex: integer): IBGRALight3D;
401 begin
402   if (AIndex < 0) or (AIndex >= FLights.Count) then
403     result := nil
404   else
405     result := TBGRALight3D(FLights[AIndex]);
406 end;
407 
GetLightCountnull408 function TBGRAScene3D.GetLightCount: integer;
409 begin
410   result := FLights.Count;
411 end;
412 
TBGRAScene3D.GetMaterialnull413 function TBGRAScene3D.GetMaterial(AIndex: integer): IBGRAMaterial3D;
414 begin
415   if (AIndex < 0) or (AIndex >= FMaterialCount) then
416     raise exception.Create('Index out of bounds');
417   result := FMaterials[AIndex];
418 end;
419 
TBGRAScene3D.GetNormalCountnull420 function TBGRAScene3D.GetNormalCount: integer;
421 var i: integer;
422 begin
423   result := 0;
424   for i := 0 to Object3DCount-1 do
425     inc(result, Object3D[i].TotalNormalCount);
426 end;
427 
GetAmbiantLightnessnull428 function TBGRAScene3D.GetAmbiantLightness: single;
429 begin
430   result := (FAmbiantLightColorF[1]+FAmbiantLightColorF[2]+FAmbiantLightColorF[3])/3;
431 end;
432 
TBGRAScene3D.GetAmbiantLightColorFnull433 function TBGRAScene3D.GetAmbiantLightColorF: TColorF;
434 begin
435   result := FAmbiantLightColorF;
436 end;
437 
438 procedure TBGRAScene3D.SetAutoViewCenter(const AValue: boolean);
439 begin
440   if FAutoViewCenter=AValue then exit;
441   if not AValue then
442     FViewCenter := ViewCenter;
443   FAutoViewCenter:=AValue;
444 end;
445 
446 procedure TBGRAScene3D.SetAutoZoom(const AValue: boolean);
447 begin
448   if FAutoZoom=AValue then exit;
449   if not AValue then
450     FZoom := Zoom;
451   FAutoZoom:=AValue;
452 end;
453 
454 procedure TBGRAScene3D.SetDefaultMaterial(AValue: IBGRAMaterial3D);
455 begin
456   if FDefaultMaterial=AValue then Exit;
457   FDefaultMaterial:=AValue;
458   InvalidateMaterial;
459 end;
460 
461 procedure TBGRAScene3D.SetViewCenter(const AValue: TPointF);
462 begin
463   FViewCenter := AValue;
464   FAutoViewCenter:= False;
465 end;
466 
467 procedure TBGRAScene3D.SetViewPoint(const AValue: TPoint3D);
468 begin
469   Camera.ViewPoint := AValue;
470 end;
471 
472 procedure TBGRAScene3D.AddObject(AObj: IBGRAObject3D);
473 begin
474   if FObjectCount = length(FObjects) then
475     setlength(FObjects, FObjectCount*2+1);
476   FObjects[FObjectCount] := AObj;
477   inc(FObjectCount);
478 end;
479 
480 procedure TBGRAScene3D.AddLight(ALight: TObject);
481 begin
482   FLights.Add(ALight);
483   IBGRALight3D(TBGRALight3D(ALight))._AddRef;
484 end;
485 
486 procedure TBGRAScene3D.AddMaterial(AMaterial: IBGRAMaterial3D);
487 begin
488   if FMaterialCount = length(FMaterials) then
489     setlength(FMaterials, FMaterialCount*2+1);
490   FMaterials[FMaterialCount] := AMaterial;
491   inc(FMaterialCount);
492 end;
493 
494 procedure TBGRAScene3D.Init;
495 begin
496   UnknownColor := BGRA(0,128,255);
497   FAutoZoom := True;
498   FAutoViewCenter := True;
499 
500   FCamera := TCamera3D.Create;
501   Camera.ViewPoint := Point3D(0,0,-100);
502   Camera.LookAt(Point3D(0,0,0), Point3D(0,-1,0));
503   with RenderingOptions do
504   begin
505     TextureInterpolation := False;
506     PerspectiveMode := pmPerspectiveMapping;
507     LightingInterpolation := liSpecularHighQuality;
508     AntialiasingMode := am3dNone;
509     AntialiasingResampleLevel := 2;
510   end;
511   AmbiantLightness := 1;
512   AmbiantLightColor := BGRAWhite;
513   DefaultLightingNormal := lnFaceVertexMix;
514   FLights := TList.Create;
515   FRenderedFaceCount:= 0;
516   FMaterialCount := 0;
517   FObjectCount := 0;
518   DefaultMaterial := CreateMaterial;
519   RenderingOptions.MinZ := 1;
520 end;
521 
522 constructor TBGRAScene3D.Create;
523 begin
524   Init;
525 end;
526 
527 constructor TBGRAScene3D.Create(ASurface: TBGRACustomBitmap);
528 begin
529   FSurface := ASurface;
530   Init;
531 end;
532 
533 destructor TBGRAScene3D.Destroy;
534 var
535   i: Integer;
536 begin
537   DoClear;
538   FreeAndNil(FLights);
539   FreeAndNil(FCamera);
540   for i := 0 to high(FTexturesFetched) do
541     FTexturesFetched[i].Bitmap.Free;
542   inherited Destroy;
543 end;
544 
545 procedure TBGRAScene3D.Clear;
546 begin
547   DoClear;
548   DefaultMaterial := CreateMaterial;
549 end;
550 
TBGRAScene3D.FetchObjectnull551 function TBGRAScene3D.FetchObject(AName: string; SwapFacesOrientation: boolean
552   ): IBGRAObject3D;
553 begin
554   if FetchDirectory = '' then raise exception.Create('Please define first the FetchDirectory');
555   try
556     result := LoadObjectFromFileUTF8(ConcatPaths([FetchDirectory,AName]), SwapFacesOrientation);
557   except
558     on ex:Exception do
559       HandleFetchException(ex);
560   end;
561 end;
562 
563 procedure TBGRAScene3D.UseMaterial(AMaterialName: string; AFace: IBGRAFace3D);
564 
ParseColornull565   function ParseColor(text: string): TBGRAPixel;
566   var
567     color,tempColor: TBGRAPixel;
568   begin
569     color := UnknownColor;
570 
571     if copy(text,1,2) = 'dk' then
572     begin
573       tempcolor := ParseColor(copy(text,3,length(text)-2));
574       tempcolor := MergeBGRA(tempcolor,3,BGRABlack,1);
575       color := StrToBGRA('dark'+copy(text,3,length(text)-2),tempcolor);
576     end;
577     if copy(text,1,2) = 'lt' then
578     begin
579       tempcolor := ParseColor(copy(text,3,length(text)-2));
580       tempcolor := MergeBGRA(tempcolor,3,BGRAWhite,1);
581       color := StrToBGRA('light'+copy(text,3,length(text)-2),tempcolor);
582     end;
583     Color := StrToBGRA(StringReplace(text,'deep','dark',[]),Color);
584     Color := StrToBGRA(StringReplace(text,'dark','deep',[]),Color);
585     Color := StrToBGRA(text,Color);
586     result := color;
587   end;
588 
589 var
590   mat: IBGRAMaterial3D;
591   c: TBGRAPixel;
592 begin
593   mat := GetMaterialByName(AMaterialName);
594   if mat = nil then
595   begin
596     mat := CreateMaterial;
597     mat.Name := AMaterialName;
598     c := ParseColor(AMaterialName);
599     mat.AmbiantColor := c;
600     mat.DiffuseColor := c;
601   end;
602   AFace.Material := mat;
603 end;
604 
LoadBitmapFromFileUTF8null605 function TBGRAScene3D.LoadBitmapFromFileUTF8(AFilenameUTF8: string): TBGRACustomBitmap;
606 begin
607   result := BGRABitmapFactory.Create(AfileNameUTF8,True);
608 end;
609 
TBGRAScene3D.FetchTexturenull610 function TBGRAScene3D.FetchTexture(AName: string; out texSize: TPointF): IBGRAScanner;
611 var
612   i: Integer;
613   bmp: TBGRACustomBitmap;
614 begin
615   bmp := nil;
616   for i := 0 to high(FTexturesFetched) do
617     if FTexturesFetched[i].Name = AName then
618     begin
619       bmp := FTexturesFetched[i].Bitmap;
620       result := bmp;
621       texSize := PointF(bmp.Width,bmp.Height);
622       exit;
623     end;
624   if FetchDirectory <> '' then
625   begin
626     try
627       bmp := LoadBitmapFromFileUTF8(ConcatPaths([FetchDirectory,AName]));
628     except
629       on ex:Exception do
630         HandleFetchException(ex);
631     end;
632   end;
633   if bmp = nil then
634   begin
635     result := nil;
636     texSize := PointF(1,1);
637   end else
638   begin
639     setlength(FTexturesFetched, length(FTexturesFetched)+1);
640     FTexturesFetched[high(FTexturesFetched)].Name := AName;
641     FTexturesFetched[high(FTexturesFetched)].Bitmap := bmp;
642     result := bmp;
643     texSize := PointF(bmp.Width,bmp.Height);
644   end;
645 end;
646 
647 procedure TBGRAScene3D.FetchMaterials(ALibraryName: string);
648 var
649   i: Integer;
650 begin
651   if FetchDirectory <> '' then
652   begin
653     for i := 0 to high(FMaterialLibrariesFetched) do
654       if FMaterialLibrariesFetched[i]=ALibraryName then exit;
655     setlength(FMaterialLibrariesFetched,length(FMaterialLibrariesFetched)+1);
656     FMaterialLibrariesFetched[high(FMaterialLibrariesFetched)] := ALibraryName;
657     try
658       LoadMaterialsFromFile(ConcatPaths([FetchDirectory,ALibraryName]));
659     except
660       on ex:Exception do
661         HandleFetchException(ex);
662     end;
663   end;
664 end;
665 
666 procedure TBGRAScene3D.HandleFetchException(AException: Exception);
667 begin
668   if FetchThrowsException then
669     raise AException;
670 end;
671 
672 procedure TBGRAScene3D.DoClear;
673 var i: integer;
674 begin
675   for i := 0 to FLights.Count-1 do
676     TBGRALight3D(FLights[i]).ReleaseInterface;
677   FLights.Clear;
678 
679   for i := 0 to FObjectCount-1 do
680   begin
681     FObjects[i].Clear;
682     FObjects[i] := nil;
683   end;
684   FObjects := nil;
685   FObjectCount := 0;
686 
687   FMaterials := nil;
688   FMaterialCount := 0;
689   DefaultMaterial := nil;
690 end;
691 
TBGRAScene3D.GetRenderWidthnull692 function TBGRAScene3D.GetRenderWidth: integer;
693 begin
694   if Assigned(FRenderer) then
695     result := FRenderer.SurfaceWidth
696   else
697   if Assigned(FSurface) then
698     result := FSurface.Width
699   else
700     result := 0;
701 end;
702 
GetRenderHeightnull703 function TBGRAScene3D.GetRenderHeight: integer;
704 begin
705   if Assigned(FRenderer) then
706     result := FRenderer.SurfaceHeight
707   else
708   if Assigned(FSurface) then
709     result := FSurface.Height
710   else
711     result := 0;
712 end;
713 
714 procedure TBGRAScene3D.OnMaterialTextureChanged(ASender: TObject);
715 begin
716   InvalidateMaterial;
717 end;
718 
719 procedure TBGRAScene3D.InvalidateMaterial;
720 var
721   i: Integer;
722 begin
723   for i := 0 to FObjectCount-1 do
724     FObjects[i].InvalidateMaterial;
725 end;
726 
LoadObjectFromFilenull727 function TBGRAScene3D.LoadObjectFromFile(AFilename: string; SwapFacesOrientation: boolean): IBGRAObject3D;
728 begin
729   result := LoadObjectFromFileUTF8(SysToUTF8(AFilename), SwapFacesOrientation);
730 end;
731 
LoadObjectFromFileUTF8null732 function TBGRAScene3D.LoadObjectFromFileUTF8(AFilename: string;
733   SwapFacesOrientation: boolean): IBGRAObject3D;
734 var source: TFileStreamUTF8;
735 begin
736   source := TFileStreamUTF8.Create(AFilename,fmOpenRead,fmShareDenyWrite);
737   try
738     result := LoadObjectFromStream(source,SwapFacesOrientation);
739   finally
740     source.free;
741   end;
742 end;
743 
LoadObjectFromStreamnull744 function TBGRAScene3D.LoadObjectFromStream(AStream: TStream;
745   SwapFacesOrientation: boolean): IBGRAObject3D;
746 var s: string;
747   secondValue,thirdValue: string;
748 
GetNextTokennull749   function GetNextToken: string;
750   var idxStart,idxEnd,idxSlash: integer;
751   begin
752     idxStart := 1;
753     while (idxStart <= length(s)) and (s[idxStart]in[' ',#9]) do inc(idxStart);
754     if idxStart > length(s) then
755     begin
756       result := '';
757       exit;
758     end;
759     idxEnd := idxStart;
760     while (idxEnd < length(s)) and not (s[idxEnd+1]in[' ',#9]) do inc(idxEnd);
761     result := copy(s,idxStart, idxEnd-idxStart+1);
762     delete(s,1,idxEnd);
763     idxSlash := pos('/',result);
764     if idxSlash <> 0 then
765     begin
766       secondValue:= copy(result,idxSlash+1,length(result)-idxSlash);
767       result := copy(result,1,idxSlash-1);
768       idxSlash:= pos('/',secondValue);
769       if idxSlash <> 0 then
770       begin
771         thirdValue:= copy(secondValue,idxSlash+1,length(secondValue)-idxSlash);
772         secondValue:= copy(secondValue,1,idxSlash-1);
773       end else
774         thirdValue:= '';
775     end else
776     begin
777       secondValue:= '';
778       thirdValue:= '';
779     end;
780   end;
781 
782 type
783   TFaceVertexExtra = record
784     normal: IBGRANormal3D;
785     texCoord: TPointF;
786   end;
787 
788 var lineType : string;
789     x,y,z : single;
790     code : integer;
791     faceVertices: array of IBGRAVertex3D;
792     faceExtra: array of TFaceVertexExtra;
793     NbFaceVertices,v,v2,v3,i: integer;
794     tempV: IBGRAVertex3D;
795     tempN: TFaceVertexExtra;
796     materialname: string;
797     face: IBGRAFace3D;
798     lines: TStringList;
799     lineIndex: integer;
800     texCoords: array of TPointF;
801     nbTexCoords: integer;
802 
803 begin
804   lines := TStringList.Create;
805   lines.LoadFromStream(AStream);
806   result := CreateObject;
807   faceVertices := nil;
808   faceExtra := nil;
809   NbFaceVertices:= 0;
810   materialname := 'default';
811   lineIndex := 0;
812   texCoords := nil;
813   nbTexCoords:= 0;
814   while lineIndex < lines.Count do
815   begin
816     s := lines[lineIndex];
817     if pos('#',s) <> 0 then
818       s := copy(s,1,pos('#',s)-1);
819     inc(lineIndex);
820     lineType := GetNextToken;
821     if lineType = 'v' then
822     begin
823       val(GetNextToken,x,code);
824       val(GetNextToken,y,code);
825       val(GetNextToken,z,code);
826       result.MainPart.Add(x,y,z);
827     end else
828     if lineType = 'vt' then
829     begin
830       val(GetNextToken,x,code);
831       val(GetNextToken,y,code);
832       if nbTexCoords >= length(texCoords) then
833         setlength(texCoords, length(texCoords)*2+1);
834       texCoords[nbTexCoords] := PointF(x,y);
835       inc(nbTexCoords);
836     end else
837     if lineType = 'vn' then
838     begin
839       val(GetNextToken,x,code);
840       val(GetNextToken,y,code);
841       val(GetNextToken,z,code);
842       result.MainPart.AddNormal(x,y,z);
843       result.LightingNormal := lnVertex;
844     end else
845     if lineType = 'mtllib' then
846       FetchMaterials(trim(s))
847     else
848     if lineType = 'usemtl' then
849       materialname := trim(s)
850     else
851     if lineType = 'f' then
852     begin
853       NbFaceVertices:= 0;
854       repeat
855         val(GetNextToken,v,code);
856         if (code = 0) and (v < 0) then v := result.MainPart.VertexCount+1+v;
857         if (code = 0) and (v >= 1) and (v <= result.MainPart.VertexCount) then
858         begin
859           if length(faceVertices) = NbFaceVertices then
860           begin
861             setlength(faceVertices, length(faceVertices)*2+1);
862             setlength(faceExtra, length(faceExtra)*2+1);
863           end;
864           faceVertices[NbFaceVertices] := result.MainPart.Vertex[v-1];
865           val(secondValue,v2,code);
866           if (code = 0) and (v2 < 0) then v2 := nbTexCoords+1+v2;
867           if (code = 0) and (v2 >= 1) and (v2-1 < nbTexCoords) then
868             faceExtra[NbFaceVertices].texCoord := texCoords[v2-1]
869           else if nbTexCoords > v-1 then
870             faceExtra[NbFaceVertices].texCoord := texCoords[v-1]
871           else
872             faceExtra[NbFaceVertices].texCoord := PointF(0,0);
873           val(thirdValue,v3,code);
874           if (code = 0) and (v3 < 0) then v3 := result.MainPart.NormalCount+1+v3;
875           if code = 0 then
876             faceExtra[NbFaceVertices].normal := result.MainPart.Normal[v3-1]
877           else if result.MainPart.NormalCount > v-1 then
878             faceExtra[NbFaceVertices].normal := result.MainPart.Normal[v-1]
879           else
880             faceExtra[NbFaceVertices].normal := nil;
881           inc(NbFaceVertices);
882         end else break;
883       until false;
884       if NbFaceVertices > 2 then
885       begin
886         if SwapFacesOrientation then
887           for i := 0 to NbFaceVertices div 2-1 do
888           begin
889             tempV := faceVertices[i];
890             faceVertices[i] := faceVertices[NbFaceVertices-1-i];
891             faceVertices[NbFaceVertices-1-i] := tempV;
892             tempN := faceExtra[i];
893             faceExtra[i] := faceExtra[NbFaceVertices-1-i];
894             faceExtra[NbFaceVertices-1-i] := tempN;
895           end;
896         face := result.AddFace(slice(faceVertices,NbFaceVertices));
897         for i := 0 to NbFaceVertices-1 do
898         begin
899           face.SetNormal(i, faceExtra[i].normal);
900           face.SetTexCoord(i, faceExtra[i].texCoord);
901         end;
902         face.MaterialName := materialname;
903       end;
904     end;
905   end;
906   lines.Free;
907 end;
908 
909 procedure TBGRAScene3D.LoadMaterialsFromFile(AFilename: string);
910 var source: TFileStreamUTF8;
911 begin
912   source := TFileStreamUTF8.Create(SysToUTF8(AFilename),fmOpenRead,fmShareDenyWrite);
913   try
914     LoadMaterialsFromStream(source);
915   finally
916     source.free;
917   end;
918 end;
919 
920 procedure TBGRAScene3D.LoadMaterialsFromFileUTF8(AFilename: string);
921 var source: TFileStreamUTF8;
922 begin
923   source := TFileStreamUTF8.Create(AFilename,fmOpenRead,fmShareDenyWrite);
924   try
925     LoadMaterialsFromStream(source);
926   finally
927     source.free;
928   end;
929 end;
930 
931 procedure TBGRAScene3D.LoadMaterialsFromStream(AStream: TStream);
932 var
933   s: String;
934 
GetNextTokennull935   function GetNextToken: string;
936   var idxStart,idxEnd: integer;
937   begin
938     idxStart := 1;
939     while (idxStart <= length(s)) and (s[idxStart]in[#9,' ']) do inc(idxStart);
940     if idxStart > length(s) then
941     begin
942       result := '';
943       exit;
944     end;
945     idxEnd := idxStart;
946     while (idxEnd < length(s)) and not (s[idxEnd+1]in[#9,' ']) do inc(idxEnd);
947     result := copy(s,idxStart, idxEnd-idxStart+1);
948     delete(s,1,idxEnd);
949   end;
950 
GetSinglenull951   function GetSingle: single;
952   var {%H-}code: integer;
953   begin
954     val(GetNextToken,result,{%H-}code);
955   end;
956 
GetColorFnull957   function GetColorF: TColorF;
958   var r,g,b: single;
959     {%H-}code: integer;
960   begin
961     val(GetNextToken,r,{%H-}code);
962     val(GetNextToken,g,{%H-}code);
963     val(GetNextToken,b,{%H-}code);
964     result := ColorF(r,g,b,1);
965   end;
966 
967 var
968   lines: TStringList;
969   lineIndex: integer;
970   lineType: String;
971   currentMaterial: IBGRAMaterial3D;
972   materialName: string;
973   texZoom: TPointF;
974   v: single;
975 
976 begin
977   lines := TStringList.Create;
978   lines.LoadFromStream(AStream);
979   lineIndex := 0;
980   while lineIndex < lines.Count do
981   begin
982     s := lines[lineIndex];
983     if pos('#',s) <> 0 then
984       s := copy(s,1,pos('#',s)-1);
985     inc(lineIndex);
986     lineType := GetNextToken;
987     if lineType = 'newmtl' then
988     begin
989       materialName := trim(s);
990       currentMaterial := GetMaterialByName(materialName);
991       if currentMaterial = nil then
992       begin
993         currentMaterial := CreateMaterial;
994         currentMaterial.Name := materialName;
995       end;
996     end else
997     if currentMaterial <> nil then
998     begin
999       if lineType = 'Ka' then currentMaterial.AmbiantColorF := GetColorF else
1000       if lineType = 'Kd' then currentMaterial.DiffuseColorF := GetColorF else
1001       if lineType = 'Ks' then currentMaterial.SpecularColorF := GetColorF else
1002       if (lineType = 'map_Ka') or (lineType = 'map_Kd') then
1003       begin
1004         currentMaterial.Texture := FetchTexture(trim(s),texZoom);
1005         texZoom.y := -texZoom.y;
1006         currentMaterial.TextureZoom := texZoom;
1007       end else
1008       if lineType = 'Ns' then currentMaterial.SpecularIndex := round(GetSingle) else
1009       if lineType = 'd' then
1010       begin
1011         v := GetSingle;
1012         if v > 1 then
1013           currentMaterial.SimpleAlpha := 255
1014         else if v < 0 then
1015           currentMaterial.SimpleAlpha := 0
1016         else
1017           currentMaterial.SimpleAlpha := round(v*255);
1018       end;
1019     end;
1020   end;
1021   lines.Free;
1022 end;
1023 
1024 procedure TBGRAScene3D.LookAt(AWhere: TPoint3D; ATopDir: TPoint3D);
1025 begin
1026   Camera.LookAt(AWhere,ATopDir);
1027 end;
1028 
1029 procedure TBGRAScene3D.LookLeft(angleDeg: single);
1030 begin
1031   Camera.LookLeft(angleDeg);
1032 end;
1033 
1034 procedure TBGRAScene3D.LookRight(angleDeg: single);
1035 begin
1036   Camera.LookRight(angleDeg);
1037 end;
1038 
1039 procedure TBGRAScene3D.LookUp(angleDeg: single);
1040 begin
1041   Camera.LookUp(angleDeg);
1042 end;
1043 
1044 procedure TBGRAScene3D.LookDown(angleDeg: single);
1045 begin
1046   Camera.LookDown(angleDeg);
1047 end;
1048 
1049 procedure TBGRAScene3D.Render;
1050 begin
1051   FRenderer := TBGRARenderer3D.Create(FSurface, RenderingOptions,
1052     FAmbiantLightColorF,
1053     FLights);
1054   DoRender;
1055   FreeAndNil(FRenderer);
1056 end;
1057 
1058 procedure TBGRAScene3D.Render(ARenderer: TCustomRenderer3D);
1059 begin
1060   FRenderer := ARenderer;
1061   DoRender;
1062   FRenderer := nil;
1063 end;
1064 
1065 procedure TBGRAScene3D.ComputeView(ScaleX,ScaleY: single);
1066 var
1067   i: Integer;
1068 begin
1069   FProjection.Zoom := Zoom;
1070   FProjection.Zoom.X := FProjection.Zoom.X * ScaleX;
1071   FProjection.Zoom.Y := FProjection.Zoom.Y * ScaleY;
1072   FProjection.Center := ViewCenter;
1073   FProjection.Center.X := FProjection.Center.X * ScaleX;
1074   FProjection.Center.Y := FProjection.Center.Y * ScaleY;
1075   for i := 0 to FObjectCount-1 do
1076     FObjects[i].ComputeWithMatrix(Camera.Matrix, FProjection);
1077 end;
1078 
TBGRAScene3D.ComputeCoordinatenull1079 function TBGRAScene3D.ComputeCoordinate(AViewCoord: TPoint3D_128): TPointF;
1080 var InvZ: single;
1081 begin
1082   if AViewCoord.z > 0 then
1083   begin
1084     InvZ := 1/AViewCoord.z;
1085     result := PointF(AViewCoord.x*InvZ*FProjection.Zoom.x + FProjection.Center.x,
1086                      AViewCoord.y*InvZ*FProjection.Zoom.Y + FProjection.Center.y);
1087   end else
1088     result := PointF(0,0);
1089 end;
1090 
1091 type
1092   arrayOfTBGRAFace3D = array of TBGRAFace3D;
1093 
1094 procedure InsertionSortFaces(var a: arrayOfTBGRAFace3D);
1095 var i,j: integer;
1096     temp: TBGRAFace3D;
1097 begin
1098   for i := 1 to high(a) do
1099   begin
1100     Temp := a[i];
1101     j := i;
1102     while (j>0) and (a[j-1].ViewCenterZ > Temp.ViewCenterZ) do
1103     begin
1104       a[j] := a[j-1];
1105       dec(j);
1106     end;
1107     a[j] := Temp;
1108   end;
1109 end;
1110 
PartitionFacesnull1111 function PartitionFaces(var a: arrayOfTBGRAFace3D; left,right: integer): integer;
1112 
1113   procedure Swap(idx1,idx2: integer); inline;
1114   var temp: TBGRAFace3D;
1115   begin
1116     temp := a[idx1];
1117     a[idx1] := a[idx2];
1118     a[idx2] := temp;
1119   end;
1120 
1121 var pivotIndex: integer;
1122     pivotValue: TBGRAFace3D;
1123     storeIndex: integer;
1124     i: integer;
1125 
1126 begin
1127   pivotIndex := left + random(right-left+1);
1128   pivotValue := a[pivotIndex];
1129   swap(pivotIndex,right);
1130   storeIndex := left;
1131   for i := left to right-1 do
1132     if a[i].ViewCenterZ <= pivotValue.ViewCenterZ then
1133     begin
1134       swap(i,storeIndex);
1135       inc(storeIndex);
1136     end;
1137   swap(storeIndex,right);
1138   result := storeIndex;
1139 end;
1140 
1141 procedure QuickSortFaces(var a: arrayOfTBGRAFace3D; left,right: integer);
1142 var pivotNewIndex: integer;
1143 begin
1144   if right > left+9 then
1145   begin
1146     pivotNewIndex := PartitionFaces(a,left,right);
1147     QuickSortFaces(a,left,pivotNewIndex-1);
1148     QuickSortFaces(a,pivotNewIndex+1,right);
1149   end;
1150 end;
1151 
1152 procedure SortFaces(var a: arrayOfTBGRAFace3D);
1153 begin
1154   if length(a) < 10 then InsertionSortFaces(a) else
1155   begin
1156     QuickSortFaces(a,0,high(a));
1157     InsertionSortFaces(a);
1158   end;
1159 end;
1160 
IsPolyVisiblenull1161 function IsPolyVisible(const p : array of TPointF; ori: integer = 1) : boolean;
1162 var i: integer;
1163 begin
1164   i := 0;
1165   while i<=high(p)-2 do
1166   begin
1167     if ori*
1168     ( (p[i+1].x-p[i].x)*(p[i+2].y-p[i].y) -
1169       (p[i+1].y-p[i].y)*(p[i+2].x-p[i].x)) > 0 then
1170     begin
1171         result := true;
1172         exit;
1173     end;
1174     inc(i);
1175   end;
1176   result := false;
1177 end;
1178 
1179 procedure TBGRAScene3D.DoRender;
1180 var
1181   LFaces: array of TBGRAFace3D;
1182   LFaceOpaque: array of boolean;
1183   LFaceCount: integer;
1184 
1185   procedure PrepareFaces;
1186   var i,j, LFaceIndex: integer;
1187       obj: IBGRAObject3D;
1188   begin
1189     LFaces := nil;
1190     LFaceCount := 0;
1191     for i := 0 to FObjectCount-1 do
1192     begin
1193       obj := FObjects[i];
1194       inc(LFaceCount, obj.GetFaceCount);
1195       obj.Update;
1196     end;
1197     setlength(LFaces, LFaceCount);
1198     LFaceIndex := 0;
1199     for i := 0 to FObjectCount-1 do
1200       with FObjects[i] do
1201       begin
1202         for j := 0 to GetFaceCount-1 do
1203         begin
1204           LFaces[LFaceIndex] := TBGRAFace3D(GetFace(j).GetAsObject);
1205           inc(LFaceIndex);
1206         end;
1207       end;
1208   end;
1209 
1210 var
1211   faceDesc: TFaceRenderingDescription;
1212   LVertices: array of TBGRAVertex3D;
1213 
1214   procedure DrawFace(numFace: integer);
1215   var
1216     j,k: Integer;
1217     VCount,NewVCount: integer;
1218     NegNormals: boolean;
1219     LastVisibleVertex: integer;
1220 
1221     procedure AddZIntermediate(n1,n2: integer);
1222     var t: single;
1223         v1,v2: TBGRAVertex3D;
1224     begin
1225        v1 := LVertices[n1];
1226        v2 := LVertices[n2];
1227        t := (RenderingOptions.MinZ - v1.ViewCoord.z)/(v2.ViewCoord.z - v1.ViewCoord.z);
1228        LVertices[NewVCount] := nil; //computed
1229 
1230        faceDesc.Colors[NewVCount] := MergeBGRA(faceDesc.Colors[n1],round((1-t)*65536),faceDesc.Colors[n2],round(t*65536));
1231        faceDesc.TexCoords[NewVCount] := faceDesc.TexCoords[n1]*(1-t) + faceDesc.TexCoords[n2]*t;
1232        faceDesc.Positions3D[NewVCount] := faceDesc.Positions3D[n1]*(1-t) + faceDesc.Positions3D[n2]*t;
1233        faceDesc.Normals3D[NewVCount] := faceDesc.Normals3D[n1]*(1-t) + faceDesc.Normals3D[n2]*t;
1234        faceDesc.Projections[NewVCount] := ComputeCoordinate(faceDesc.Positions3D[NewVCount]);
1235        inc(NewVCount);
1236     end;
1237 
1238     procedure LoadVertex(idxL: integer; idxV: integer);
1239     var vertexDesc: PBGRAFaceVertexDescription;
1240         tempV: TBGRAVertex3D;
1241     begin
1242       with LFaces[numFace] do
1243       begin
1244         vertexDesc := VertexDescription[idxV];
1245         with vertexDesc^ do
1246         begin
1247           tempV := TBGRAVertex3D(vertex.GetAsObject);
1248           LVertices[idxL] := tempV;
1249 
1250           faceDesc.Colors[idxL] := ActualColor;
1251           faceDesc.TexCoords[idxL] := ActualTexCoord;
1252 
1253           with tempV.CoordData^ do
1254           begin
1255             faceDesc.Positions3D[idxL] := viewCoord;
1256             facedesc.Normals3D[idxL] := viewNormal;
1257             faceDesc.Projections[idxL] := projectedCoord;
1258           end;
1259           if Normal <> nil then
1260             facedesc.Normals3D[idxL] := Normal.ViewNormal_128;
1261           Normalize3D_128(facedesc.Normals3D[idxL]);
1262         end;
1263       end;
1264     end;
1265 
1266   begin
1267      with LFaces[numFace] do
1268      begin
1269        VCount := VertexCount;
1270        if VCount < 3 then exit;
1271 
1272        faceDesc.NormalsMode := Object3D.LightingNormal;
1273 
1274        faceDesc.Material := ActualMaterial;
1275        if faceDesc.Material = nil then exit;
1276        faceDesc.Texture := ActualTexture;
1277 
1278        if length(LVertices) < VCount+3 then  //keep margin for z-clip
1279        begin
1280          setlength(LVertices, (VCount+3)*2);
1281          setlength(faceDesc.Colors, length(LVertices));
1282          setlength(faceDesc.TexCoords, length(LVertices));
1283          setlength(faceDesc.Projections, length(LVertices));
1284          setlength(faceDesc.Positions3D, length(LVertices));
1285          setlength(faceDesc.Normals3D, length(LVertices));
1286        end;
1287 
1288        if FRenderer.HandlesNearClipping then
1289        begin
1290          for j := 0 to VCount-1 do
1291            LoadVertex(j,j);
1292        end else
1293        begin
1294          NewVCount := 0;
1295          LastVisibleVertex := -1;
1296          for k := VCount-1 downto 0 do
1297            if Vertex[k].ViewCoordZ >= RenderingOptions.MinZ then
1298            begin
1299              LastVisibleVertex := k;
1300              break;
1301            end;
1302          if LastVisibleVertex = -1 then exit;
1303 
1304          k := VCount-1;
1305          for j := 0 to VCount-1 do
1306          begin
1307            if Vertex[j].ViewCoordZ >= RenderingOptions.MinZ then
1308            begin
1309              if k <> LastVisibleVertex then   //one or more vertices is out
1310              begin
1311                LoadVertex(NewVCount+1, LastVisibleVertex);
1312                LoadVertex(NewVCount+2, (LastVisibleVertex+1) mod VertexCount);
1313                AddZIntermediate(NewVCount+1,NewVCount+2);
1314 
1315                LoadVertex(NewVCount+1, j);
1316                LoadVertex(NewVCount+2, k);
1317 
1318                AddZIntermediate(NewVCount+1,NewVCount+2);
1319                inc(NewVCount);
1320              end else
1321              begin
1322                LoadVertex(NewVCount, j);
1323                inc(NewVCount);
1324              end;
1325              LastVisibleVertex := j;
1326            end;
1327            k := j;
1328          end;
1329          VCount := NewVCount;
1330          if VCount < 3 then exit; //after z-clipping
1331        end;
1332 
1333        if not FRenderer.HandlesFaceCulling then
1334        begin
1335          if not IsPolyVisible(slice(faceDesc.Projections,VCount)) then
1336          begin
1337            if not Biface then exit;
1338            NegNormals := True;
1339          end else
1340          begin
1341            NegNormals := False;
1342          end;
1343        end else
1344          NegNormals := false;
1345 
1346        //compute normals
1347        case faceDesc.NormalsMode of
1348          lnFace: for j := 0 to VCount-1 do
1349                    faceDesc.Normals3D[j] := ViewNormal_128;
1350          lnFaceVertexMix:
1351              for j := 0 to VCount-1 do
1352              begin
1353                faceDesc.Normals3D[j].Offset(ViewNormal_128);
1354                Normalize3D_128(faceDesc.Normals3D[j]);
1355              end;
1356        end;
1357        if NegNormals then
1358          for j := 0 to VCount-1 do
1359            faceDesc.Normals3D[j] := -faceDesc.Normals3D[j];
1360 
1361        if LightThroughFactorOverride then
1362          faceDesc.LightThroughFactor := LightThroughFactor
1363        else
1364          faceDesc.LightThroughFactor := faceDesc.Material.GetLightThroughFactor;
1365 
1366        faceDesc.NbVertices:= VCount;
1367        faceDesc.Biface := Biface;
1368 
1369        if FRenderer.RenderFace(faceDesc, @ComputeCoordinate) then
1370          inc(FRenderedFaceCount);
1371      end;
1372   end;
1373 
1374 var i,j: integer;
1375 
1376 begin
1377   FRenderedFaceCount:= 0;
1378 
1379   PrepareFaces;
1380   ComputeView(FRenderer.GlobalScale,FRenderer.GlobalScale);
1381   FRenderer.Projection := FProjection;
1382 
1383   SortFaces(LFaces);
1384   LVertices := nil;
1385 
1386   //if there is a Z-Buffer, it is possible to avoid drawing things that
1387   //are hidden by opaque faces by drawing first all opaque faces
1388   if FRenderer.HasZBuffer then
1389   begin
1390     setlength(LFaceOpaque, length(LFaces));
1391     for i := 0 to High(LFaces) do
1392     begin
1393       if (LFaces[i].Texture = nil) then
1394       begin
1395         LFaceOpaque[i] := true;
1396         with LFaces[i] do
1397           for j := 0 to VertexCount-1 do
1398             if VertexColor[j].alpha <> 255 then
1399             begin
1400               LFaceOpaque[i] := false;
1401               break;
1402             end;
1403       end else
1404         LFaceOpaque[i] := true;
1405     end;
1406 
1407     //draw near opaque faces first
1408     for i := 0 to High(LFaces) do
1409       if LFaceOpaque[i] then DrawFace(i);
1410 
1411     //draw other faces
1412     for i := High(LFaces) downto 0 do
1413       if not LFaceOpaque[i] then DrawFace(i);
1414   end else
1415   begin
1416     for i := High(LFaces) downto 0 do
1417       DrawFace(i);
1418   end;
1419 end;
1420 
TBGRAScene3D.CreateObjectnull1421 function TBGRAScene3D.CreateObject: IBGRAObject3D;
1422 begin
1423   result := TBGRAObject3D.Create(self);
1424   AddObject(result);
1425 end;
1426 
TBGRAScene3D.CreateObjectnull1427 function TBGRAScene3D.CreateObject(ATexture: IBGRAScanner): IBGRAObject3D;
1428 begin
1429   result := TBGRAObject3D.Create(self);
1430   result.Texture := ATexture;
1431   AddObject(result);
1432 end;
1433 
TBGRAScene3D.CreateObjectnull1434 function TBGRAScene3D.CreateObject(AColor: TBGRAPixel): IBGRAObject3D;
1435 begin
1436   result := TBGRAObject3D.Create(self);
1437   result.Color := AColor;
1438   AddObject(result);
1439 end;
1440 
CreateSpherenull1441 function TBGRAScene3D.CreateSphere(ARadius: Single; AHorizPrecision: integer; AVerticalPrecision : integer): IBGRAObject3D;
1442 begin
1443   result := TBGRASphere3D.Create(self, ARadius, AHorizPrecision, AVerticalPrecision);
1444   AddObject(result);
1445 end;
1446 
CreateSpherenull1447 function TBGRAScene3D.CreateSphere(ARadius: Single; AColor: TBGRAPixel; AHorizPrecision: integer; AVerticalPrecision : integer): IBGRAObject3D;
1448 begin
1449   result := TBGRASphere3D.Create(self, ARadius, AHorizPrecision, AVerticalPrecision);
1450   result.Color := AColor;
1451   AddObject(result);
1452 end;
1453 
CreateHalfSpherenull1454 function TBGRAScene3D.CreateHalfSphere(ARadius: Single;
1455   AHorizPrecision: integer; AVerticalPrecision: integer): IBGRAObject3D;
1456 begin
1457   result := TBGRASphere3D.Create(self, ARadius, AHorizPrecision, AVerticalPrecision, True);
1458   AddObject(result);
1459 end;
1460 
CreateHalfSpherenull1461 function TBGRAScene3D.CreateHalfSphere(ARadius: Single; AColor: TBGRAPixel;
1462   AHorizPrecision: integer; AVerticalPrecision: integer): IBGRAObject3D;
1463 begin
1464   result := TBGRASphere3D.Create(self, ARadius, AHorizPrecision, AVerticalPrecision, True);
1465   result.Color := AColor;
1466   AddObject(result);
1467 end;
1468 
1469 procedure TBGRAScene3D.RemoveObject(AObject: IBGRAObject3D);
1470 var
1471   i,j: Integer;
1472 begin
1473   for i := FObjectCount-1 downto 0 do
1474     if FObjects[i] = AObject then
1475     begin
1476       dec(FObjectCount);
1477       FObjects[i] := nil;
1478       for j := i to FObjectCount-1 do
1479         FObjects[j] := FObjects[j+1];
1480     end;
1481 end;
1482 
TBGRAScene3D.AddDirectionalLightnull1483 function TBGRAScene3D.AddDirectionalLight(ADirection: TPoint3D;
1484   ALightness: single; AMinIntensity: single): IBGRADirectionalLight3D;
1485 var lightObj: TBGRADirectionalLight3D;
1486 begin
1487   lightObj := TBGRADirectionalLight3D.Create(ADirection);
1488   result := lightObj;
1489   result.ColorF := ColorF(ALightness,ALightness,ALightness,1);
1490   result.MinIntensity := AMinIntensity;
1491   AddLight(lightObj);
1492 end;
1493 
TBGRAScene3D.AddPointLightnull1494 function TBGRAScene3D.AddPointLight(AVertex: IBGRAVertex3D;
1495   AOptimalDistance: single; ALightness: single; AMinIntensity: single
1496   ): IBGRAPointLight3D;
1497 var lightObj: TBGRAPointLight3D;
1498 begin
1499   lightObj := TBGRAPointLight3D.Create(AVertex, ALightness*sqr(AOptimalDistance));
1500   result := lightObj;
1501   result.MinIntensity := AMinIntensity;
1502   AddLight(lightObj);
1503 end;
1504 
TBGRAScene3D.AddDirectionalLightnull1505 function TBGRAScene3D.AddDirectionalLight(ADirection: TPoint3D;
1506   AColor: TBGRAPixel; AMinIntensity: single): IBGRADirectionalLight3D;
1507 var lightObj: TBGRADirectionalLight3D;
1508 begin
1509   lightObj := TBGRADirectionalLight3D.Create(ADirection);
1510   result := lightObj;
1511   result.MinIntensity := AMinIntensity;
1512   result.Color := AColor;
1513   AddLight(lightObj);
1514 end;
1515 
TBGRAScene3D.AddPointLightnull1516 function TBGRAScene3D.AddPointLight(AVertex: IBGRAVertex3D;
1517   AOptimalDistance: single; AColor: TBGRAPixel; AMinIntensity: single
1518   ): IBGRAPointLight3D;
1519 var lightObj: TBGRAPointLight3D;
1520 begin
1521   lightObj := TBGRAPointLight3D.Create(AVertex,sqr(AOptimalDistance));
1522   result := lightObj;
1523   result.Color := AColor;
1524   result.MinIntensity := AMinIntensity;
1525   AddLight(lightObj);
1526 end;
1527 
1528 procedure TBGRAScene3D.RemoveLight(ALight: IBGRALight3D);
1529 var idx: integer;
1530 begin
1531   idx := FLights.IndexOf(ALight.GetAsObject);
1532   if idx <> -1 then
1533   begin
1534     ALight._Release;
1535     FLights.Delete(Idx);
1536   end;
1537 end;
1538 
1539 procedure TBGRAScene3D.SetZoom(value: Single);
1540 begin
1541   SetZoom(PointF(value,value));
1542 end;
1543 
1544 procedure TBGRAScene3D.SetZoom(value: TPointF);
1545 begin
1546   FZoom := value;
1547   FAutoZoom := false;
1548 end;
1549 
CreateMaterialnull1550 function TBGRAScene3D.CreateMaterial: IBGRAMaterial3D;
1551 var m: TBGRAMaterial3D;
1552 begin
1553   m := TBGRAMaterial3D.Create;
1554   m.OnTextureChanged := @OnMaterialTextureChanged;
1555   result := m;
1556   AddMaterial(result);
1557 end;
1558 
CreateMaterialnull1559 function TBGRAScene3D.CreateMaterial(ASpecularIndex: integer): IBGRAMaterial3D;
1560 var m: TBGRAMaterial3D;
1561 begin
1562   m := TBGRAMaterial3D.Create;
1563   m.SetSpecularIndex(ASpecularIndex);
1564   m.SetSpecularColor(BGRAWhite);
1565   m.OnTextureChanged := @OnMaterialTextureChanged;
1566   result := m;
1567   AddMaterial(result);
1568 end;
1569 
TBGRAScene3D.GetMaterialByNamenull1570 function TBGRAScene3D.GetMaterialByName(AName: string): IBGRAMaterial3D;
1571 var i: integer;
1572 begin
1573   for i := 0 to MaterialCount-1 do
1574     if AName = Material[i].Name then
1575     begin
1576       result := Material[i];
1577       exit;
1578     end;
1579   result := nil;
1580 end;
1581 
1582 procedure TBGRAScene3D.UpdateMaterials;
1583 var i,j: integer;
1584   obj: IBGRAObject3D;
1585   face: IBGRAFace3D;
1586 begin
1587   for i := 0 to Object3DCount-1 do
1588   begin
1589     obj := Object3D[i];
1590     for j := 0 to obj.FaceCount-1 do
1591     begin
1592       face := obj.Face[j];
1593       if face.MaterialName <> '' then
1594         UseMaterial(face.MaterialName,face);
1595     end;
1596   end;
1597 end;
1598 
1599 procedure TBGRAScene3D.UpdateMaterial(AMaterialName: string);
1600 var i,j: integer;
1601   obj: IBGRAObject3D;
1602   face: IBGRAFace3D;
1603 begin
1604   for i := 0 to Object3DCount-1 do
1605   begin
1606     obj := Object3D[i];
1607     for j := 0 to obj.FaceCount-1 do
1608     begin
1609       face := obj.Face[j];
1610       if face.MaterialName = AMaterialName then
1611         UseMaterial(face.MaterialName,face);
1612     end;
1613   end;
1614 end;
1615 
1616 procedure TBGRAScene3D.ForEachVertex(ACallback: TVertex3DCallback);
1617 var i: integer;
1618 begin
1619   for i := 0 to Object3DCount-1 do
1620     Object3D[i].ForEachVertex(ACallback);
1621 end;
1622 
1623 procedure TBGRAScene3D.ForEachFace(ACallback: TFace3DCallback);
1624 var i: integer;
1625 begin
1626   for i := 0 to Object3DCount-1 do
1627     Object3D[i].ForEachFace(ACallback);
1628 end;
1629 
MakeLightListnull1630 function TBGRAScene3D.MakeLightList: TList;
1631 var i: integer;
1632 begin
1633   result := TList.Create;
1634   for i := 0 to FLights.Count-1 do
1635     result.Add(FLights[i]);
1636 end;
1637 
1638 initialization
1639 
1640   Randomize;
1641 
1642 end.
1643 
1644