Luxophia

1
unit LUX.FMX;
2

3
interface //#################################################################### ■
4

5
uses System.Types, System.UITypes, System.Math.Vectors, System.Generics.Collections, System.Classes,
6
     FMX.Types, FMX.Graphics,
7
     FMX.Types3D, FMX.Controls3D, FMX.Objects3D, FMX.Viewport3D, FMX.MaterialSources,
8
     LUX;
9

10
type //$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【型】
11

12
     //$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【レコード】
13

14
     //$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【クラス】
15

16
     //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% HBitmapData
17

18
     HBitmapData = record helper for TBitmapData
19
     private
20
       ///// アクセス
21
       function GetPixels( const X_,Y_:Integer ) :TAlphaColor;
22
       procedure SetPixels( const X_,Y_:Integer; const Pixels_:TAlphaColor );
23
     public
24
       ///// プロパティ
25
       property Pixels[ const X_,Y_:Integer ] :TAlphaColor read GetPixels write SetPixels;
26
     end;
27

28
     //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% HCanvas
29

30
     HCanvas = class helper for TCanvas
31
     private
32
     protected
33
       ///// アクセス
34
       function GetMatrix :TMatrix;
35
       procedure SetMatrix( const Matrix_:TMatrix );
36
     public
37
       property Matrix :TMatrix read GetMatrix write SetMatrix;
38
       ///// メソッド
39
       procedure DrawCircle( const Center_ :TPointF;
40
                             const Radius_ :Single;
41
                             const Opacity_:Single = 1 );
42
       procedure FillCircle( const Center_ :TPointF;
43
                             const Radius_ :Single;
44
                             const Opacity_:Single = 1 );
45
       procedure DrawText( const Text_   :String;
46
                           const Pos_    :TPointF;
47
                           const AlignX_ :TTextAlign;
48
                           const AlignY_ :TTextAlign;
49
                           const Opacity_:Single = 1 );
50
     end;
51

52
     //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% HMeshData
53

54
     HMeshData = class helper for TMeshData
55
     private
56
     protected
57
     public
58
       ///// メソッド
59
       procedure SaveToFileBinSTL( const FileName_:String; const Text_:AnsiString = '' );
60
     end;
61

62
     //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% HControl3D
63

64
     HControl3D = class helper for TControl3D
65
     private
66
     protected
67
       ///// アクセス
68
       function GetAbsolMatrix :TMatrix3D;
69
       procedure SetAbsoluteMatrix( const AbsoluteMatrix_:TMatrix3D ); virtual;
70
       function GetLocalMatrix :TMatrix3D; virtual;
71
       procedure SetLocalMatrix( const LocalMatrix_:TMatrix3D ); virtual;
72
       ///// メソッド
73
       procedure RecalcFamilyAbsolute;
74
       procedure RecalcChildrenAbsolute;
75
     public
76
       ///// プロパティ
77
       property AbsoluteMatrix :TMatrix3D read GetAbsolMatrix write SetAbsoluteMatrix;
78
       property LocalMatrix    :TMatrix3D read GetLocalMatrix write SetLocalMatrix   ;
79
       ///// メソッド
80
       procedure RenderInternalTo( const Context_:TContext3D );
81
     end;
82

83
     //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% HCustomMesh
84

85
     HCustomMesh = class helper for TCustomMesh
86
     private
87
     protected
88
       ///// アクセス
89
       function GetMeshData :TMeshData;
90
     public
91
       ///// プロパティ
92
       property MeshData :TMeshData read GetMeshData;
93
     end;
94

95
     //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% TTrueViewport3D
96

97
     TTrueViewport3D = class( TViewport3D )
98
     private
99
       _Bitmap        :TBitmap;
100
       _DrawOK        :Boolean;
101
       _RenderingList :TList<TControl3D>;
102
     protected
103
       ///// メソッド
104
       procedure Paint; override;
105
       procedure Resize; override;
106
     public
107
       constructor Create( Owner_:TComponent ); override;
108
       destructor Destroy; override;
109
       ///// メソッド
110
       procedure RebuildRenderingList;
111
     end;
112

113
     //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% TTensorShape
114

115
     TTensorShape = class( TControl3D )
116
     private
117
     protected
118
       _GeometryX :TMeshData;
119
       _GeometryY :TMeshData;
120
       _GeometryZ :TMeshData;
121
       _MaterialX :TColorMaterialSource;
122
       _MaterialY :TColorMaterialSource;
123
       _MaterialZ :TColorMaterialSource;
124
       _MeshData  :TMeshData;
125
       _AxisLeng  :Single;
126
       ///// アクセス
127
       procedure SetMeshData( const MeshData_:TMeshData );
128
       procedure SetAxisLeng( const AxisLeng_:Single );
129
       function GetColorX :TAlphaColor;
130
       procedure SetColorX( const ColorX_:TAlphaColor );
131
       function GetColorY :TAlphaColor;
132
       procedure SetColorY( const ColorY_:TAlphaColor );
133
       function GetColorZ :TAlphaColor;
134
       procedure SetColorZ( const ColorZ_:TAlphaColor );
135
       ///// メソッド
136
       procedure Render; override;
137
     public
138
       constructor Create( Owner_:TComponent ); override;
139
       destructor Destroy; override;
140
       ///// プロパティ
141
       property MeshData :TMeshData   read   _MeshData write SetMeshData;
142
       property AxisLeng :Single      read   _AxisLeng write SetAxisLeng;
143
       property ColorX   :TAlphaColor read GetColorX   write SetColorX  ;
144
       property ColorY   :TAlphaColor read GetColorY   write SetColorY  ;
145
       property ColorZ   :TAlphaColor read GetColorZ   write SetColorZ  ;
146
       ///// メソッド
147
       procedure MakeShape;
148
     end;
149

150
//const //$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【定数】
151

152
//var //$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【変数】
153

154
//$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【ルーチン】
155

156
function GapFit( const P0_,P1_:TPoint3D ) :TMatrix3D;
157

158
implementation //############################################################### ■
159

160
uses System.SysUtils, System.RTLConsts, System.AnsiStrings,
161
     FMX.Controls,
162
     LUX.D3;
163

164
//$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【レコード】
165

166
//$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【クラス】
167

168
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% HBitmapData
169

170
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& private
171

172
/////////////////////////////////////////////////////////////////////// アクセス
173

174
function HBitmapData.GetPixels( const X_,Y_:Integer ) :TAlphaColor;
175
begin
176
     Result := GetPixel( X_, Y_ );
177
end;
178

179
procedure HBitmapData.SetPixels( const X_,Y_:Integer; const Pixels_:TAlphaColor );
180
begin
181
     SetPixel( X_, Y_, Pixels_ );
182
end;
183

184
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& public
185

186
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% HCanvas
187

188
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& private
189

190
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& protected
191

192
/////////////////////////////////////////////////////////////////////// アクセス
193

194
function HCanvas.GetMatrix :TMatrix;
195
begin
196
     with Self do
197
     begin
198
          Result := FMatrix;
199
     end;
200
end;
201

202
procedure HCanvas.SetMatrix( const Matrix_:TMatrix );
203
begin
204
     inherited SetMatrix( Matrix_ );
205
end;
206

207
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& public
208

209
procedure HCanvas.DrawCircle( const Center_ :TPointF;
210
                              const Radius_ :Single;
211
                              const Opacity_:Single = 1 );
212
begin
213
     DrawEllipse( TRectF.Create( Center_.X-Radius_, Center_.Y-Radius_,
214
                                 Center_.X+Radius_, Center_.Y+Radius_ ), Opacity_ );
215
end;
216

217
procedure HCanvas.FillCircle( const Center_ :TPointF;
218
                              const Radius_ :Single;
219
                              const Opacity_:Single = 1 );
220
begin
221
     FillEllipse( TRectF.Create( Center_.X-Radius_, Center_.Y-Radius_,
222
                                 Center_.X+Radius_, Center_.Y+Radius_ ), Opacity_ );
223
end;
224

225
procedure HCanvas.DrawText( const Text_   :String;
226
                            const Pos_    :TPointF;
227
                            const AlignX_ :TTextAlign;
228
                            const AlignY_ :TTextAlign;
229
                            const Opacity_:Single = 1 );
230
var
231
   W, H, W2, H2 :Single;
232
   R :TRectF;
233
begin
234
     R := TRectF.Create( 0, 0, Single.MaxValue, Single.MaxValue );
235
     MeasureText( R, Text_, False, [], TTextAlign.Leading, TTextAlign.Leading );
236

237
     W := R.Right ;
238
     H := R.Bottom;
239

240
     with R do
241
     begin
242
          case AlignX_ of
243
            TTextAlign.Leading:
244
               begin
245
                    Left   := Pos_.X     ;
246
                    Right  := Pos_.X + W ;
247
               end;
248
            TTextAlign.Center:
249
               begin
250
                    W2 := W / 2;
251

252
                    Left   := Pos_.X - W2;
253
                    Right  := Pos_.X + W2;
254
               end;
255
            TTextAlign.Trailing:
256
               begin
257
                    Left   := Pos_.X - W ;
258
                    Right  := Pos_.X     ;
259
               end;
260
          end;
261

262
          case AlignY_ of
263
            TTextAlign.Leading:
264
               begin
265
                    Top    := Pos_.Y     ;
266
                    Bottom := Pos_.Y + H ;
267
               end;
268
            TTextAlign.Center:
269
               begin
270
                    H2 := H / 2;
271

272
                    Top    := Pos_.Y - H2;
273
                    Bottom := Pos_.Y + H2;
274
               end;
275
            TTextAlign.Trailing:
276
               begin
277
                    Top    := Pos_.Y - H ;
278
                    Bottom := Pos_.Y     ;
279
               end;
280
          end;
281
     end;
282

283
     FillText( R, Text_, False, Opacity_, [], AlignX_, AlignY_ );
284
end;
285

286
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% HMeshData
287

288
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& private
289

290
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& protected
291

292
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& public
293

294
/////////////////////////////////////////////////////////////////////// メソッド
295

296
procedure HMeshData.SaveToFileBinSTL( const FileName_:String; const Text_:AnsiString = '' );
297
var
298
   Cs :array [ 0..80-1 ] of AnsiChar;
299
   N, I :Cardinal;
300
   Face :packed record
301
           Nor  :TSingle3D;
302
           Pos1 :TSingle3D;
303
           Pos2 :TSingle3D;
304
           Pos3 :TSingle3D;
305
           temp :Word;
306
         end;
307
begin
308
     with TFileStream.Create( FileName_, fmCreate ) do
309
     begin
310
          try
311
             System.AnsiStrings.StrLCopy( Cs, PAnsiChar( Text_ ), Length( Cs )-1 );
312

313
             Write( Cs, 80 );
314

315
             N := IndexBuffer.Length div 3;
316

317
             Write( N, SizeOf( N ) );
318

319
             for I := 0 to N-1 do
320
             begin
321
                  with Face do
322
                  begin
323
                       Nor  := TSingle3D.Create( 0, 0, 0 );
324
                       Pos1 := VertexBuffer.Vertices[ IndexBuffer.Indices[ 3*I+0 ] ];
325
                       Pos2 := VertexBuffer.Vertices[ IndexBuffer.Indices[ 3*I+1 ] ];
326
                       Pos3 := VertexBuffer.Vertices[ IndexBuffer.Indices[ 3*I+2 ] ];
327
                       temp := 0;
328
                  end;
329

330
                  Write( Face, SizeOf( Face ) );
331
             end;
332

333
          finally
334
                 Free;
335
          end;
336
     end;
337
end;
338

339
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% HControl3D
340

341
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& private
342

343
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& protected
344

345
/////////////////////////////////////////////////////////////////////// アクセス
346

347
function HControl3D.GetAbsolMatrix :TMatrix3D;
348
begin
349
     if FRecalcAbsolute then
350
     begin
351
          if FParent is TControl3D then FAbsoluteMatrix := FLocalMatrix * TControl3D(FParent).AbsoluteMatrix
352
                                   else FAbsoluteMatrix := FLocalMatrix;
353

354
          Result := FAbsoluteMatrix;
355

356
          FInvAbsoluteMatrix := FAbsoluteMatrix.Inverse;
357

358
          FRecalcAbsolute := False;
359
     end
360
     else Result := FAbsoluteMatrix;
361
end;
362

363
procedure HControl3D.SetAbsoluteMatrix( const AbsoluteMatrix_:TMatrix3D );
364
begin
365
        FAbsoluteMatrix := AbsoluteMatrix_;
366
     FInvAbsoluteMatrix := AbsoluteMatrix_.Inverse;
367

368
     if Assigned( FParent ) and ( FParent is TControl3D )
369
     then FLocalMatrix := FAbsoluteMatrix * TControl3D( FParent ).AbsoluteMatrix.Inverse
370
     else FLocalMatrix := FAbsoluteMatrix;
371

372
     RecalcChildrenAbsolute;
373

374
     Repaint;
375
end;
376

377
function HControl3D.GetLocalMatrix :TMatrix3D;
378
begin
379
     Result := FLocalMatrix;
380
end;
381

382
procedure HControl3D.SetLocalMatrix( const LocalMatrix_:TMatrix3D );
383
begin
384
     FLocalMatrix := LocalMatrix_;
385

386
     RecalcFamilyAbsolute;
387

388
     Repaint;
389
end;
390

391
/////////////////////////////////////////////////////////////////////// メソッド
392

393
procedure HControl3D.RecalcFamilyAbsolute;
394
begin
395
     RecalcAbsolute;
396
end;
397

398
procedure HControl3D.RecalcChildrenAbsolute;
399
var
400
   F :TFmxObject;
401
begin
402
     FRecalcAbsolute := False;
403

404
     if Assigned( Children ) then
405
     begin
406
          for F in Children do
407
          begin
408
               if F is TControl3D then TControl3D( F ).RecalcFamilyAbsolute;
409
          end;
410
     end;
411
end;
412

413
procedure HControl3D.RenderInternalTo( const Context_:TContext3D );
414
begin
415
     TempContext := Context_;
416

417
     RenderInternal;
418

419
     TempContext := nil;
420
end;
421

422
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& public
423

424
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% HCustomMesh
425

426
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& private
427

428
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& protected
429

430
/////////////////////////////////////////////////////////////////////// アクセス
431

432
function HCustomMesh.GetMeshData :TMeshData;
433
begin
434
     Result := Data;
435
end;
436

437
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& public
438

439
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% TTrueViewport3D
440

441
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& private
442

443
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& protected
444

445
/////////////////////////////////////////////////////////////////////// メソッド
446

447
procedure TTrueViewport3D.Paint;
448
var
449
   R :TRectF;
450
   I :Integer;
451
   C :TControl3D;
452
begin
453
     if ( csDesigning in ComponentState ) then
454
     begin
455
          R := LocalRect;
456

457
          InflateRect( R, -0.5, -0.5 );
458

459
          Canvas.DrawDashRect( R, 0, 0, AllCorners, AbsoluteOpacity, $A0909090 );
460
     end;
461

462
     if _DrawOK then
463
     begin
464
          _DrawOK := False;
465

466
          try
467
             if Assigned( Context ) then
468
             begin
469
                  Canvas.Flush;
470

471
                  with Context do
472
                  begin
473
                       if BeginScene then
474
                       try
475
                          SetContextState( TContextState.csScissorOff );
476
                          Clear( [ TClearTarget.Color, TClearTarget.Depth ], Color, 1.0, 0 );
477
                          SetCameraMatrix( Camera.CameraMatrix );
478
                          SetCameraAngleOfView( Camera.AngleOfView );
479

480
                          Lights.Clear;
481
                          for I := 0 to Camera.Viewport.LightCount-1
482
                          do Lights.Add( Camera.Viewport.Lights[ I ].LightDescription );
483

484
                          for C in _RenderingList do
485
                          begin
486
                               with C do
487
                               begin
488
                                    if Visible or ( not Visible and ( csDesigning in ComponentState ) and not Locked )
489
                                    then RenderInternalTo( Self.Context );
490
                               end;
491
                          end;
492

493
                       finally
494
                              EndScene;
495
                       end;
496

497
                       CopyToBitmap( _Bitmap, _Bitmap.Bounds );
498
                  end;
499
             end;
500
          finally
501
                 _DrawOK := True;
502
          end;
503

504
          inherited Canvas.DrawBitmap( _Bitmap, _Bitmap.BoundsF, LocalRect, AbsoluteOpacity, True );
505
     end;
506
end;
507

508
procedure TTrueViewport3D.Resize;
509
begin
510
     inherited;
511

512
     FreeAndNil( _Bitmap );
513

514
     with Context do _Bitmap := TBitmap.Create( Width, Height );
515
end;
516

517
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& public
518

519
constructor TTrueViewport3D.Create( Owner_:TComponent );
520
begin
521
     inherited;
522

523
     _DrawOK        := True;
524
     _RenderingList := TList<TControl3D>.Create;
525

526
     UsingDesignCamera := False;
527
end;
528

529
destructor TTrueViewport3D.Destroy;
530
begin
531
     FreeAndNil( _Bitmap        );
532
     FreeAndNil( _RenderingList );
533

534
     inherited;
535
end;
536

537
/////////////////////////////////////////////////////////////////////// メソッド
538

539
procedure TTrueViewport3D.RebuildRenderingList;
540
var
541
   F :TFmxObject;
542
 //CompareFunc :TRenderingCompare;
543
begin
544
     with TViewport3D( Camera.Viewport ) do
545
     begin
546
          if Assigned( Children ) and ( Children.Count > 0 ) and ( FUpdating = 0 ) then
547
          begin
548
               _RenderingList.Clear;
549

550
               for F in Children do
551
               begin
552
                    if ( F is TControl3D ) then _RenderingList.Add( F as TControl3D );
553
               end;
554

555
               {
556
               CompareFunc := TRenderingCompare.Create;
557

558
               try
559
                  _RenderingList.Sort( CompareFunc );
560

561
               finally
562
                      CompareFunc.Free;
563
               end;
564
               }
565
          end;
566
     end;
567
end;
568

569
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% TTensorShape
570

571
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& private
572

573
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& protected
574

575
/////////////////////////////////////////////////////////////////////// アクセス
576

577
procedure TTensorShape.SetMeshData( const MeshData_:TMeshData );
578
begin
579
     _MeshData := MeshData_;  MakeShape;
580
end;
581

582
procedure TTensorShape.SetAxisLeng( const AxisLeng_:Single );
583
begin
584
     _AxisLeng := AxisLeng_;  MakeShape;
585
end;
586

587
//------------------------------------------------------------------------------
588

589
function TTensorShape.GetColorX :TAlphaColor;
590
begin
591
     Result := _MaterialX.Color;
592
end;
593

594
procedure TTensorShape.SetColorX( const ColorX_:TAlphaColor );
595
begin
596
     _MaterialX.Color := ColorX_;  Repaint;
597
end;
598

599
function TTensorShape.GetColorY :TAlphaColor;
600
begin
601
     Result := _MaterialY.Color;
602
end;
603

604
procedure TTensorShape.SetColorY( const ColorY_:TAlphaColor );
605
begin
606
     _MaterialY.Color := ColorY_;  Repaint;
607
end;
608

609
function TTensorShape.GetColorZ :TAlphaColor;
610
begin
611
     Result := _MaterialZ.Color;
612
end;
613

614
procedure TTensorShape.SetColorZ( const ColorZ_:TAlphaColor );
615
begin
616
     _MaterialZ.Color := ColorZ_;  Repaint;
617
end;
618

619
/////////////////////////////////////////////////////////////////////// メソッド
620

621
procedure TTensorShape.Render;
622
begin
623
     with Context do
624
     begin
625
          SetMatrix( AbsoluteMatrix );
626

627
          DrawLines( _GeometryX.VertexBuffer, _GeometryX.IndexBuffer, _MaterialX.Material, AbsoluteOpacity );
628
          DrawLines( _GeometryY.VertexBuffer, _GeometryY.IndexBuffer, _MaterialY.Material, AbsoluteOpacity );
629
          DrawLines( _GeometryZ.VertexBuffer, _GeometryZ.IndexBuffer, _MaterialZ.Material, AbsoluteOpacity );
630
     end;
631
end;
632

633
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& public
634

635
constructor TTensorShape.Create( Owner_:TComponent );
636
begin
637
     inherited;
638

639
     HitTest := False;
640

641
     _GeometryX := TMeshData.Create;
642
     _GeometryY := TMeshData.Create;
643
     _GeometryZ := TMeshData.Create;
644

645
     _MaterialX := TColorMaterialSource.Create( Self );
646
     _MaterialY := TColorMaterialSource.Create( Self );
647
     _MaterialZ := TColorMaterialSource.Create( Self );
648

649
     _MaterialX.Color := TAlphaColors.Red ;
650
     _MaterialY.Color := TAlphaColors.Lime;
651
     _MaterialZ.Color := TAlphaColors.Blue;
652

653
     _AxisLeng := 0.05;
654
end;
655

656
destructor TTensorShape.Destroy;
657
begin
658
     _GeometryX.Free;
659
     _GeometryY.Free;
660
     _GeometryZ.Free;
661

662
     inherited;
663
end;
664

665
/////////////////////////////////////////////////////////////////////// メソッド
666

667
procedure TTensorShape.MakeShape;
668
var
669
   N, I, J :Integer;
670
   AO, AX, AY, AZ :TPoint3D;
671
begin
672
     with _MeshData.VertexBuffer do
673
     begin
674
          N := Length * 2{Poin};
675

676
          _GeometryX.VertexBuffer.Length := N;
677
          _GeometryY.VertexBuffer.Length := N;
678
          _GeometryZ.VertexBuffer.Length := N;
679

680
          _GeometryX.IndexBuffer .Length := N;
681
          _GeometryY.IndexBuffer .Length := N;
682
          _GeometryZ.IndexBuffer .Length := N;
683

684
          J := 0;
685
          for I := 0 to Length-1 do
686
          begin
687
               AO := Vertices [ I ];
688
               AX := Tangents [ I ];
689
               AY := BiNormals[ I ];
690
               AZ := Normals  [ I ];
691

692
               _GeometryX.VertexBuffer.Vertices[ J ] := AO;
693
               _GeometryY.VertexBuffer.Vertices[ J ] := AO;
694
               _GeometryZ.VertexBuffer.Vertices[ J ] := AO;
695

696
               _GeometryX.IndexBuffer .Indices [ J ] := J;
697
               _GeometryY.IndexBuffer .Indices [ J ] := J;
698
               _GeometryZ.IndexBuffer .Indices [ J ] := J;
699

700
               Inc( J );
701

702
               _GeometryX.VertexBuffer.Vertices[ J ] := AO + _AxisLeng * AX;
703
               _GeometryY.VertexBuffer.Vertices[ J ] := AO + _AxisLeng * AY;
704
               _GeometryZ.VertexBuffer.Vertices[ J ] := AO + _AxisLeng * AZ;
705

706
               _GeometryX.IndexBuffer .Indices [ J ] := J;
707
               _GeometryY.IndexBuffer .Indices [ J ] := J;
708
               _GeometryZ.IndexBuffer .Indices [ J ] := J;
709

710
               Inc( J );
711
          end;
712
     end;
713

714
     Repaint;
715
end;
716

717
//$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【ルーチン】
718

719
function GapFit( const P0_,P1_:TPoint3D ) :TMatrix3D;
720
var
721
   AX, AY ,AZ, AP, E :TPoint3D;
722
begin
723
     AY := ( P1_ - P0_ ).Normalize;
724
     AP := ( P1_ + P0_ ) / 2;
725

726
     with AY do
727
     begin
728
          case MinI( Abs( X ), Abs( Y ) ,Abs( Z ) ) of
729
            1: E := TPoint3D.Create( 1, 0, 0 );
730
            2: E := TPoint3D.Create( 0, 1, 0 );
731
            3: E := TPoint3D.Create( 0, 0, 1 );
732
          end;
733

734
          AZ := CrossProduct( E ).Normalize;
735

736
          AX := CrossProduct( AZ );
737
     end;
738

739
     with Result do
740
     begin
741
          m11 := AX.X;  m12 := AX.Y;  m13 := AX.Z;  m14 := 0;
742
          m21 := AY.X;  m22 := AY.Y;  m23 := AY.Z;  m24 := 0;
743
          m31 := AZ.X;  m32 := AZ.Y;  m33 := AZ.Z;  m34 := 0;
744
          m41 := AP.X;  m42 := AP.Y;  m43 := AP.Z;  m44 := 1;
745
     end;
746
end;
747

748
//############################################################################## □
749

750
initialization //$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 初期化
751

752
finalization //$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 最終化
753

754
end. //######################################################################### ■
755