Luxophia

1
unit LUX.Graph.Tree;
2

3
interface
4

5
uses
6
  LUX,
7
  LUX.Graph;
8

9
type
10

11
  TTreeItem = class;
12
  TTreeNode = class;
13
  TTreeNode<_TParen_, _TChild_: class> = class;
14
  TTreeNode<_TNode_: class> = class;
15
  TTreeRoot<_TChild_: class> = class;
16
  TTreeLeaf<_TParen_: class> = class;
17

18
  TTreeItem = class(TNode)
19
  private
20
  protected
21
    _Prev: TTreeNode;
22
    _Next: TTreeNode;
23
  public
24
    constructor Create;
25
  end;
26

27
  TTreeNode = class(TTreeItem)
28
  private
29
    function GetZero: TTreeNode;
30
    procedure SetZero(const Zero_: TTreeNode);
31
    function GetIsOrdered: Boolean;
32
    class procedure Bind(const C0_, C1_: TTreeNode); overload; inline;
33
    class procedure Bind(const C0_, C1_, C2_: TTreeNode); overload; inline;
34
    class procedure Bind(const C0_, C1_, C2_, C3_: TTreeNode); overload; inline;
35
  protected
36
    _Paren: TTreeNode;
37
    _Order: Integer;
38
    _Childs: TMarginArray<TTreeNode>;
39
    _ChildsN: Integer;
40
    _MaxOrder: Integer;
41
    function GetParen: TTreeNode;
42
    procedure SetParen(const Paren_: TTreeNode);
43
    function GetOrder: Integer;
44
    procedure SetOrder(const Order_: Integer);
45
    function GetHead: TTreeNode;
46
    function GetTail: TTreeNode;
47
    function GetChilds(const I_: Integer): TTreeNode;
48
    procedure SetChilds(const I_: Integer; const Child_: TTreeNode);
49
    property Zero: TTreeNode read GetZero write SetZero;
50
    property IsOrdered: Boolean read GetIsOrdered;
51
    procedure FindTo(const Child_: TTreeNode); overload;
52
    procedure FindTo(const Order_: Integer); overload;
53
    procedure _Insert(const C0_, C1_, C2_: TTreeNode);
54
    procedure _Remove;
55
    procedure _InsertHead(const Child_: TTreeNode);
56
    procedure _InsertTail(const Child_: TTreeNode);
57
    procedure _InsertPrev(const Sibli_: TTreeNode);
58
    procedure _InsertNext(const Sibli_: TTreeNode);
59
  public
60
    constructor Create; overload; virtual;
61
    constructor Create(const Paren_: TTreeNode); overload; virtual;
62
    procedure BeforeDestruction; override;
63
    destructor Destroy; override;
64
    property Paren: TTreeNode read GetParen write SetParen;
65
    property Order: Integer read GetOrder write SetOrder;
66
    property Head: TTreeNode read GetHead;
67
    property Tail: TTreeNode read GetTail;
68
    property Childs[const I_: Integer]: TTreeNode read GetChilds
69
      write SetChilds; default;
70
    property ChildsN: Integer read _ChildsN;
71
    procedure Remove;
72
    class procedure RemoveChild(const Child_: TTreeNode);
73
    procedure DeleteChilds; virtual;
74
    procedure InsertHead(const Child_: TTreeNode);
75
    procedure InsertTail(const Child_: TTreeNode);
76
    procedure InsertPrev(const Sibli_: TTreeNode);
77
    procedure InsertNext(const Sibli_: TTreeNode);
78
    class procedure Swap(const C1_, C2_: TTreeNode); overload;
79
    procedure Swap(const I1_, I2_: Integer); overload;
80
  end;
81

82
  TTreeNode<_TParen_, _TChild_: class> = class(TTreeNode)
83
  private
84
  protected
85
    function GetParen: _TParen_; reintroduce;
86
    procedure SetParen(const Paren_: _TParen_); reintroduce;
87
    function GetHead: _TChild_; reintroduce;
88
    function GetTail: _TChild_; reintroduce;
89
    function GetChilds(const I_: Integer): _TChild_; reintroduce;
90
    procedure SetChilds(const I_: Integer; const Child_: _TChild_); reintroduce;
91
  public
92
    property Paren: _TParen_ read GetParen write SetParen;
93
    property Head: _TChild_ read GetHead;
94
    property Tail: _TChild_ read GetTail;
95
    property Childs[const I_: Integer]: _TChild_ read GetChilds
96
      write SetChilds; default;
97
  end;
98

99
  TTreeNode<_TNode_: class> = class(TTreeNode<_TNode_, _TNode_>)
100
  private
101
  protected
102
  public
103
  end;
104

105
  TTreeRoot<_TChild_: class> = class(TTreeNode<_TChild_>)
106
  private
107
  protected
108
    property Paren;
109
  public
110
    property Head;
111
    property Tail;
112
    property Childs;
113
  end;
114

115
  TTreeLeaf<_TParen_: class> = class(TTreeNode<_TParen_>)
116
  private
117
  protected
118
    property Head;
119
    property Tail;
120
    property Childs;
121
  public
122
    property Paren;
123
  end;
124

125
implementation // --------------------------------------------------------------
126

127
constructor TTreeItem.Create;
128
begin
129
  inherited;
130

131
  _Prev := TTreeNode(Self);
132
  _Next := TTreeNode(Self);
133
end;
134

135
function TTreeNode.GetZero: TTreeNode;
136
begin
137
  Result := _Childs[-1];
138
end;
139

140
procedure TTreeNode.SetZero(const Zero_: TTreeNode);
141
begin
142
  _Childs[-1] := Zero_;
143
end;
144

145
// ------------------------------------------------------------------------------
146

147
function TTreeNode.GetIsOrdered: Boolean;
148
begin
149
  Result := (_Order <= _Paren._MaxOrder) and (_Paren._Childs[_Order] = Self);
150
end;
151

152
class procedure TTreeNode.Bind(const C0_, C1_: TTreeNode);
153
begin
154
  C0_._Next := C1_;
155
  C1_._Prev := C0_;
156
end;
157

158
class procedure TTreeNode.Bind(const C0_, C1_, C2_: TTreeNode);
159
begin
160
  Bind(C0_, C1_);
161
  Bind(C1_, C2_);
162
end;
163

164
class procedure TTreeNode.Bind(const C0_, C1_, C2_, C3_: TTreeNode);
165
begin
166
  Bind(C0_, C1_);
167
  Bind(C1_, C2_);
168
  Bind(C2_, C3_);
169
end;
170

171
function TTreeNode.GetParen: TTreeNode;
172
begin
173
  Result := _Paren;
174
end;
175

176
procedure TTreeNode.SetParen(const Paren_: TTreeNode);
177
begin
178
  Remove;
179

180
  if Assigned(Paren_) then
181
    Paren_._InsertTail(Self);
182
end;
183

184
// ------------------------------------------------------------------------------
185

186
function TTreeNode.GetOrder: Integer;
187
begin
188
  if not IsOrdered then
189
    _Paren.FindTo(Self);
190

191
  Result := _Order;
192
end;
193

194
procedure TTreeNode.SetOrder(const Order_: Integer);
195
begin
196
  Swap(Self, _Paren.Childs[Order_]);
197
end;
198

199
// ------------------------------------------------------------------------------
200

201
function TTreeNode.GetHead: TTreeNode;
202
begin
203
  Result := Zero._Next;
204
end;
205

206
function TTreeNode.GetTail: TTreeNode;
207
begin
208
  Result := Zero._Prev;
209
end;
210

211
// ------------------------------------------------------------------------------
212

213
function TTreeNode.GetChilds(const I_: Integer): TTreeNode;
214
begin
215
  if I_ > _MaxOrder then
216
    FindTo(I_);
217

218
  Result := _Childs[I_];
219
end;
220

221
procedure TTreeNode.SetChilds(const I_: Integer; const Child_: TTreeNode);
222
var
223
  S: TTreeNode;
224
begin
225
  with Childs[I_] do
226
  begin
227
    S := Childs[I_]._Prev;
228

229
    Remove;
230
  end;
231

232
  S.InsertNext(Child_);
233
end;
234

235
procedure TTreeNode.FindTo(const Child_: TTreeNode);
236
var
237
  P: TTreeNode;
238
begin
239
  if _ChildsN > _Childs.Count then
240
    _Childs.Count := _ChildsN;
241

242
  P := _Childs[_MaxOrder];
243

244
  repeat
245
    P := P._Next;
246

247
    Inc(_MaxOrder);
248

249
    _Childs[_MaxOrder] := P;
250
    P._Order := _MaxOrder;
251

252
  until P = Child_;
253
end;
254

255
procedure TTreeNode.FindTo(const Order_: Integer);
256
var
257
  P: TTreeNode;
258
  I: Integer;
259
begin
260
  if _ChildsN > _Childs.Count then
261
    _Childs.Count := _ChildsN;
262

263
  P := _Childs[_MaxOrder];
264

265
  for I := _MaxOrder + 1 to Order_ do
266
  begin
267
    P := P._Next;
268

269
    _Childs[I] := P;
270
    P._Order := I;
271
  end;
272

273
  _MaxOrder := Order_;
274
end;
275

276
// ------------------------------------------------------------------------------
277

278
procedure TTreeNode._Insert(const C0_, C1_, C2_: TTreeNode);
279
begin
280
  C1_._Paren := Self;
281

282
  Bind(C0_, C1_, C2_);
283

284
  Inc(_ChildsN);
285
end;
286

287
procedure TTreeNode._Remove;
288
begin
289
  Bind(_Prev, _Next);
290

291
  if IsOrdered then
292
    _Paren._MaxOrder := _Order - 1;
293

294
  with _Paren do
295
  begin
296
    Dec(_ChildsN);
297

298
    if _ChildsN * 2 < _Childs.Count then
299
      _Childs.Count := _ChildsN;
300
  end;
301

302
  _Paren := nil;
303
  _Order := -1;
304
end;
305

306
// ------------------------------------------------------------------------------
307

308
procedure TTreeNode._InsertHead(const Child_: TTreeNode);
309
begin
310
  _Insert(Zero, Child_, Head);
311

312
  _MaxOrder := -1; { if Head.IsOrdered then _MaxOrder := Head._Order - 1; }
313
end;
314

315
procedure TTreeNode._InsertTail(const Child_: TTreeNode);
316
begin
317
  _Insert(Tail, Child_, Zero);
318

319
  { if Tail.IsOrdered then _MaxOrder := Tail._Order; }
320
end;
321

322
procedure TTreeNode._InsertPrev(const Sibli_: TTreeNode);
323
begin
324
  _Paren._Insert(_Prev, Sibli_, Self);
325

326
  if IsOrdered then
327
    _Paren._MaxOrder := _Order - 1;
328
end;
329

330
procedure TTreeNode._InsertNext(const Sibli_: TTreeNode);
331
begin
332
  _Paren._Insert(Self, Sibli_, _Next);
333

334
  if IsOrdered then
335
    _Paren._MaxOrder := _Order;
336
end;
337

338
constructor TTreeNode.Create;
339
begin
340
  inherited;
341

342
  _Paren := nil;
343
  _Order := -1;
344

345
  _ChildsN := 0;
346

347
  _Childs := TMarginArray<TTreeNode>.Create(1, _ChildsN, 0);
348

349
  Zero := TTreeNode(TTreeItem.Create);
350

351
  _MaxOrder := -1;
352
end;
353

354
constructor TTreeNode.Create(const Paren_: TTreeNode);
355
begin
356
  Create;
357

358
  Paren_._InsertTail(Self);
359
end;
360

361
procedure TTreeNode.BeforeDestruction;
362
begin
363
  Remove;
364

365
  DeleteChilds;
366
end;
367

368
destructor TTreeNode.Destroy;
369
begin
370
  Zero.Free;
371

372
  inherited;
373
end;
374

375
procedure TTreeNode.Remove;
376
begin
377
  if Assigned(_Paren) then
378
    _Remove;
379
end;
380

381
class procedure TTreeNode.RemoveChild(const Child_: TTreeNode);
382
begin
383
  Child_.Remove;
384
end;
385

386
// ------------------------------------------------------------------------------
387

388
procedure TTreeNode.DeleteChilds;
389
var
390
  N: Integer;
391
begin
392
  for N := 1 to _ChildsN do
393
    Tail.Free;
394
end;
395

396
// ------------------------------------------------------------------------------
397

398
procedure TTreeNode.InsertHead(const Child_: TTreeNode);
399
begin
400
  Child_.Remove;
401
  _InsertHead(Child_);
402
end;
403

404
procedure TTreeNode.InsertTail(const Child_: TTreeNode);
405
begin
406
  Child_.Remove;
407
  _InsertTail(Child_);
408
end;
409

410
procedure TTreeNode.InsertPrev(const Sibli_: TTreeNode);
411
begin
412
  Sibli_.Remove;
413
  _InsertPrev(Sibli_);
414
end;
415

416
procedure TTreeNode.InsertNext(const Sibli_: TTreeNode);
417
begin
418
  Sibli_.Remove;
419
  _InsertNext(Sibli_);
420
end;
421

422
// ------------------------------------------------------------------------------
423

424
class procedure TTreeNode.Swap(const C1_, C2_: TTreeNode);
425
var
426
  P1, P2, C1n, C1u, C2n, C2u: TTreeNode;
427
  B1, B2: Boolean;
428
  I1, I2: Integer;
429
begin
430
  with C1_ do
431
  begin
432
    P1 := _Paren;
433
    B1 := IsOrdered;
434
    I1 := _Order;
435

436
    C1n := _Prev;
437
    C1u := _Next;
438
  end;
439

440
  with C2_ do
441
  begin
442
    P2 := _Paren;
443
    B2 := IsOrdered;
444
    I2 := _Order;
445

446
    C2n := _Prev;
447
    C2u := _Next;
448
  end;
449

450
  C1_._Paren := P2;
451
  C2_._Paren := P1;
452

453
  if C1_ = C2n then
454
    Bind(C1n, C2_, C1_, C2u)
455
  else if C1_ = C2u then
456
    Bind(C2n, C1_, C2_, C1u)
457
  else
458
  begin
459
    Bind(C1n, C2_, C1u);
460
    Bind(C2n, C1_, C2u);
461
  end;
462

463
  if B1 then
464
  begin
465
    P1._Childs[I1] := C2_;
466
    C2_._Order := I1;
467
  end;
468

469
  if B2 then
470
  begin
471
    P2._Childs[I2] := C1_;
472
    C1_._Order := I2;
473
  end;
474
end;
475

476
procedure TTreeNode.Swap(const I1_, I2_: Integer);
477
begin
478
  Swap(Childs[I1_], Childs[I2_]);
479
end;
480

481
function TTreeNode<_TParen_, _TChild_>.GetParen: _TParen_;
482
begin
483
  Result := _TParen_(inherited GetParen);
484
end;
485

486
procedure TTreeNode<_TParen_, _TChild_>.SetParen(const Paren_: _TParen_);
487
begin
488
  inherited SetParen(TTreeNode(Paren_));
489
end;
490

491
// ------------------------------------------------------------------------------
492

493
function TTreeNode<_TParen_, _TChild_>.GetHead: _TChild_;
494
begin
495
  Result := _TChild_(inherited GetHead);
496
end;
497

498
function TTreeNode<_TParen_, _TChild_>.GetTail: _TChild_;
499
begin
500
  Result := _TChild_(inherited GetTail);
501
end;
502

503
// ------------------------------------------------------------------------------
504

505
function TTreeNode<_TParen_, _TChild_>.GetChilds(const I_: Integer): _TChild_;
506
begin
507
  Result := _TChild_(inherited GetChilds(I_));
508
end;
509

510
procedure TTreeNode<_TParen_, _TChild_>.SetChilds(const I_: Integer;
511
  const Child_: _TChild_);
512
begin
513
  inherited SetChilds(I_, TTreeNode(Child_));
514
end;
515

516
initialization // --------------------------------------------------------------
517

518
finalization
519

520
end.
521