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