Luxophia

LUX.FMX.Blocks.pas
326 строк · 10.3 Кб
Перенос по словам
1
unit LUX.FMX.Blocks;
2

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

5
uses System.Classes, System.Math.Vectors,
6
     FMX.Types3D, FMX.Controls3D, FMX.MaterialSources,
7
     LUX, LUX.D3;
8

9
type //$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【型】
10

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

13
     //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% TVert
14

15
     TVert = record
16
       Pos :TPoint3D;
17
       Nor :TPoint3D;
18
     end;
19

20
     //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% TQuad
21

22
     TQuad = record
23
       N  :TShortint3D;
24
       P1 :TByte3D;
25
       P2 :TByte3D;
26
       P3 :TByte3D;
27
       P4 :TByte3D;
28
     end;
29

30
     //$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【クラス】
31

32
     //%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% TBlocks
33

34
     TBlocks = class( TControl3D )
35
     private
36
       procedure MakeBrics;
37
     protected
38
       _Geometry :TMeshData;
39
       _Material :TMaterialSource;
40
       _Brics    :TArray3<Boolean>;
41
       _BricsX   :Integer;
42
       _BricsY   :Integer;
43
       _BricsZ   :Integer;
44
       ///// アクセス
45
       function GetBrics( const X_,Y_,Z_:Integer ) :Boolean;
46
       procedure SetBrics( const X_,Y_,Z_:Integer; const Bric_:Boolean );
47
       function GetBricsX :Integer;
48
       procedure SetBricsX( const BricsX_:Integer );
49
       function GetBricsY :Integer;
50
       procedure SetBricsY( const BricsY_:Integer );
51
       function GetBricsZ :Integer;
52
       procedure SetBricsZ( const BricsZ_:Integer );
53
       ///// メソッド
54
       procedure Render; override;
55
     public
56
       constructor Create( AOwner_:TComponent ); override;
57
       destructor Destroy; override;
58
       ///// プロパティ
59
       property Material                        :TMaterialSource read   _Material write   _Material;
60
       property Brics[ const X_,Y_,Z_:Integer ] :Boolean         read GetBrics    write SetBrics   ;
61
       property BricsX                          :Integer         read GetBricsX   write SetBricsX  ;
62
       property BricsY                          :Integer         read GetBricsY   write SetBricsY  ;
63
       property BricsZ                          :Integer         read GetBricsZ   write SetBricsZ  ;
64
       ///// メソッド
65
       procedure EndUpdate; override;
66
       procedure MakeModel;
67
     end;
68

69
//const //$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【定数】
70

71
//var //$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【変数】
72

73
//$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【ルーチン】
74

75
implementation //############################################################### ■
76

77
uses System.SysUtils, System.RTLConsts;
78

79
//$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【レコード】
80

81
//$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【クラス】
82

83
//%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% TBlocks
84

85
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& private
86

87
procedure TBlocks.MakeBrics;
88
begin
89
     SetLength( _Brics, _BricsZ, _BricsY, _BricsX );
90
end;
91

92
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& protected
93

94
/////////////////////////////////////////////////////////////////////// アクセス
95

96
function TBlocks.GetBrics( const X_,Y_,Z_:Integer ) :Boolean;
97
begin
98
     if ( 0 <= Z_ ) and ( Z_ < _BricsZ ) and
99
        ( 0 <= Y_ ) and ( Y_ < _BricsY ) and
100
        ( 0 <= X_ ) and ( X_ < _BricsX ) then Result := _Brics[ Z_, Y_, X_ ]
101
                                         else Result := False;
102
end;
103

104
procedure TBlocks.SetBrics( const X_,Y_,Z_:Integer; const Bric_:Boolean );
105
begin
106
     _Brics[ Z_, Y_, X_ ] := Bric_;
107

108
     if FUpdating = 0 then MakeModel;
109
end;
110

111
//------------------------------------------------------------------------------
112

113
function TBlocks.GetBricsX :Integer;
114
begin
115
     Result := _BricsX;
116
end;
117

118
procedure TBlocks.SetBricsX( const BricsX_:Integer );
119
begin
120
     _BricsX := BricsX_;  MakeBrics;
121
end;
122

123
function TBlocks.GetBricsY :Integer;
124
begin
125
     Result := _BricsY;
126
end;
127

128
procedure TBlocks.SetBricsY( const BricsY_:Integer );
129
begin
130
     _BricsY := BricsY_;  MakeBrics;
131
end;
132

133
function TBlocks.GetBricsZ :Integer;
134
begin
135
     Result := _BricsZ;
136
end;
137

138
procedure TBlocks.SetBricsZ( const BricsZ_:Integer );
139
begin
140
     _BricsZ := BricsZ_;  MakeBrics;
141
end;
142

143
/////////////////////////////////////////////////////////////////////// メソッド
144

145
procedure TBlocks.Render;
146
begin
147
     Context.SetMatrix( TMatrix3D.CreateTranslation( TPoint3D.Create( -_BricsX / 2,
148
                                                                      -_BricsY / 2,
149
                                                                      -_BricsZ / 2 ) )
150
                      * TMatrix3D.CreateScaling( TPoint3D.Create( Width  / _BricsX,
151
                                                                  Height / _BricsY,
152
                                                                  Depth  / _BricsZ ) )
153
                      * AbsoluteMatrix );
154

155
     Context.DrawTriangles( _Geometry.VertexBuffer,
156
                            _Geometry.IndexBuffer,
157
                            TMaterialSource.ValidMaterial( _Material ),
158
                            AbsoluteOpacity );
159
end;
160

161
//------------------------------------------------------------------------------
162

163
procedure TBlocks.MakeModel;
164
const
165
     Quads :array [ 1..6 ] of TQuad = (
166
          ( N:( X:-1; Y: 0; Z: 0 ); P1:( X:0; Y:0; Z:0 ); P2:( X:0; Y:1; Z:0 ); P3:( X:0; Y:1; Z:1 ); P4:( X:0; Y:0; Z:1 ) ),
167
          ( N:( X: 0; Y:-1; Z: 0 ); P1:( X:0; Y:0; Z:0 ); P2:( X:0; Y:0; Z:1 ); P3:( X:1; Y:0; Z:1 ); P4:( X:1; Y:0; Z:0 ) ),
168
          ( N:( X: 0; Y: 0; Z:-1 ); P1:( X:0; Y:0; Z:0 ); P2:( X:1; Y:0; Z:0 ); P3:( X:1; Y:1; Z:0 ); P4:( X:0; Y:1; Z:0 ) ),
169
          ( N:( X:+1; Y: 0; Z: 0 ); P1:( X:1; Y:1; Z:1 ); P2:( X:1; Y:1; Z:0 ); P3:( X:1; Y:0; Z:0 ); P4:( X:1; Y:0; Z:1 ) ),
170
          ( N:( X: 0; Y:+1; Z: 0 ); P1:( X:1; Y:1; Z:1 ); P2:( X:0; Y:1; Z:1 ); P3:( X:0; Y:1; Z:0 ); P4:( X:1; Y:1; Z:0 ) ),
171
          ( N:( X: 0; Y: 0; Z:+1 ); P1:( X:1; Y:1; Z:1 ); P2:( X:1; Y:0; Z:1 ); P3:( X:0; Y:0; Z:1 ); P4:( X:0; Y:1; Z:1 ) ) );
172
          //      |/       |/
173
          //     011------111--
174
          //     /|       /|
175
          //   |/ |     |/ |
176
          //  010------110--
177
          //   |  |/    |  |/
178
          //   | 001----|-101--
179
          //   | /      | /
180
          //   |/       |/
181
          //  000------100--
182
var
183
   Vs :TArray<TVert>;
184
   X, Y, Z :Integer;
185
//······································
186
     procedure AddVert( const P_:TByte3D; const N_:TShortint3D );
187
     var
188
        V :TVert;
189
     begin
190
          V.Pos := TPoint3D.Create( X+P_.X, Y+P_.Y, Z+P_.Z );
191
          V.Nor := TPoint3D.Create(   N_.X,   N_.Y,   N_.Z );
192

193
          Vs := Vs + [ V ];
194
     end;
195
//······································
196
var
197
   VsN, QsN, N, I, J, I00, I01, I10, I11 :Integer;
198
begin
199
     Vs := [];
200

201
     //         +----+
202
     //        /| +-/|-+
203
     //       +----+ |/|
204
     //    +--|-+--|-+----+
205
     //   /|  |/|  |/| + /|
206
     //  +----+----+----+ |
207
     //  | +-/|-+-/|-+--|-+
208
     //  |/ +----+ |/|  |/
209
     //  +--|-+--|-+----+
210
     //     |/| +|/|-+
211
     //     +----+ |/
212
     //       +----+
213

214
     for Z := 0 to _BricsZ-1 do
215
     for Y := 0 to _BricsY-1 do
216
     for X := 0 to _BricsX-1 do
217
     begin
218
          if Brics[ X, Y ,Z ] then
219
          begin
220
               for N := 1 to 6 do
221
               begin
222
                    with Quads[ N ] do
223
                    begin
224
                         if not Brics[ X+N.X, Y+N.Y, Z+N.Z ] then
225
                         begin
226
                              AddVert( P1, N );
227
                              AddVert( P2, N );
228
                              AddVert( P3, N );
229
                              AddVert( P4, N );
230
                         end;
231
                    end;
232
               end;
233
          end;
234
     end;
235

236
     VsN := Length( Vs );
237
     QsN := VsN{Vert} div 4{Vert/Quad};
238

239
     with _Geometry do
240
     begin
241
          with VertexBuffer do
242
          begin
243
               Length := VsN{Vert};
244

245
               for I := 0 to VsN-1 do
246
               begin
247
                    with Vs[ I ] do
248
                    begin
249
                         Vertices[ I ] := Pos;
250
                         Normals [ I ] := Nor;
251
                    end;
252
               end;
253
          end;
254

255
          with IndexBuffer do
256
          begin
257
               Length := QsN{Quad} * 2{Tria/Quad} * 3{Poin/Tria};
258

259
               I := 0;  J := 0;
260
               for N := 1 to QsN do
261
               begin
262
                    //  10--11
263
                    //   | /|
264
                    //   |/ |
265
                    //  00--01
266

267
                    I00 := I;  Inc( I );
268
                    I01 := I;  Inc( I );
269
                    I11 := I;  Inc( I );
270
                    I10 := I;  Inc( I );
271

272
                    Indices[ J ] := I00;  Inc( J );
273
                    Indices[ J ] := I01;  Inc( J );
274
                    Indices[ J ] := I11;  Inc( J );
275

276
                    Indices[ J ] := I11;  Inc( J );
277
                    Indices[ J ] := I10;  Inc( J );
278
                    Indices[ J ] := I00;  Inc( J );
279
               end;
280
          end;
281
     end;
282

283
     Repaint;
284
end;
285

286
//&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& public
287

288
constructor TBlocks.Create( AOwner_:TComponent );
289
begin
290
     inherited;
291

292
     _Geometry := TMeshData.Create;
293
     _Material := nil;
294

295
     _BricsX := 10;
296
     _BricsY := 10;
297
     _BricsZ := 10;
298

299
     MakeBrics;
300
end;
301

302
destructor TBlocks.Destroy;
303
begin
304
     _Geometry.DisposeOf;
305

306
     inherited;
307
end;
308

309
/////////////////////////////////////////////////////////////////////// メソッド
310

311
procedure TBlocks.EndUpdate;
312
begin
313
     inherited;
314

315
     if FUpdating = 0 then MakeModel;
316
end;
317

318
//$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$【ルーチン】
319

320
//############################################################################## □
321

322
initialization //$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 初期化
323

324
finalization //$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 最終化
325

326
end. //######################################################################### ■
327
Luxophia

Использование cookies
