Luxophia

1
unit LUX.Data.Tree.core;
2

3
interface
4

5
type
6

7
  TTreeAtom = class;
8
  TTreeItem = class;
9

10
  TNodeProc<_TNode_: class> = reference to procedure(const Node_: _TNode_);
11

12
  TTreeAtom = class
13
  private
14
  protected
15
    function Get_Parent: TTreeItem; virtual;
16
    procedure Set_Parent(const Parent_: TTreeItem); virtual;
17
    function Get_Order: Integer; virtual;
18
    procedure Set_Order(const Order_: Integer); virtual;
19
    function Get_Prev: TTreeItem; virtual;
20
    procedure Set_Prev(const Prev_: TTreeItem); virtual;
21
    function Get_Next: TTreeItem; virtual;
22
    procedure Set_Next(const Next_: TTreeItem); virtual;
23
    function Get_Links(const I_: Integer): TTreeItem; virtual;
24
    procedure Set_Links(const I_: Integer; const Link_: TTreeItem); virtual;
25
    function Get_LinksN: Integer; virtual;
26
    procedure Set_LinksN(const LinksN_: Integer); virtual;
27
    function Get_ChildsN: Integer; virtual;
28
    procedure Set_ChildsN(const ChildsN_: Integer); virtual;
29
    function Get_MaxOrder: Integer; virtual;
30
    procedure Set_MaxOrder(const MaxOrder_: Integer); virtual;
31
    property _Parent: TTreeItem read Get_Parent write Set_Parent;
32
    property _Order: Integer read Get_Order write Set_Order;
33
    property _Prev: TTreeItem read Get_Prev write Set_Prev;
34
    property _Next: TTreeItem read Get_Next write Set_Next;
35
    property _Links[const I_: Integer]: TTreeItem read Get_Links
36
      write Set_Links;
37
    property _LinksN: Integer read Get_LinksN write Set_LinksN;
38
    property _ChildsN: Integer read Get_ChildsN write Set_ChildsN;
39
    property _MaxOrder: Integer read Get_MaxOrder write Set_MaxOrder;
40
  public
41
  end;
42

43
  TTreeItem = class(TTreeAtom)
44
  private
45
    function Get_Zero: TTreeItem;
46
    procedure Set_Zero(const Zero_: TTreeItem);
47
    function GetIsOrdered: Boolean;
48
    class procedure Bind(const C0_, C1_: TTreeItem); overload; inline;
49
    class procedure Bind(const C0_, C1_, C2_: TTreeItem); overload; inline;
50
    class procedure Bind(const C0_, C1_, C2_, C3_: TTreeItem); overload; inline;
51
  protected
52
    function GetParent: TTreeItem;
53
    procedure SetParent(const Parent_: TTreeItem);
54
    function GetOrder: Integer;
55
    procedure SetOrder(const Order_: Integer);
56
    function GetHead: TTreeItem;
57
    function GetTail: TTreeItem;
58
    function GetChilds(const I_: Integer): TTreeItem;
59
    procedure SetChilds(const I_: Integer; const Child_: TTreeItem);
60
    function GetChildsN: Integer;
61
    function GetRootNode: TTreeItem;
62
    property _Zero: TTreeItem read Get_Zero write Set_Zero;
63
    property IsOrdered: Boolean read GetIsOrdered;
64
    procedure FindTo(const Child_: TTreeItem); overload;
65
    procedure FindTo(const Order_: Integer); overload;
66
    procedure _Insert(const C0_, C1_, C2_: TTreeItem);
67
    procedure _Remove;
68
    procedure OnInsertChild(const Child_: TTreeItem); virtual;
69
    procedure OnRemoveChild(const Child_: TTreeItem); virtual;
70
  public
71
    property Parent: TTreeItem read GetParent write SetParent;
72
    property Order: Integer read GetOrder write SetOrder;
73
    property Head: TTreeItem read GetHead;
74
    property Tail: TTreeItem read GetTail;
75
    property Childs[const I_: Integer]: TTreeItem read GetChilds
76
      write SetChilds; default;
77
    property ChildsN: Integer read GetChildsN;
78
    property RootNode: TTreeItem read GetRootNode;
79
    procedure Remove;
80
    procedure RemoveChild(const Child_: TTreeItem);
81
    procedure DeleteChilds; virtual;
82
    procedure _InsertHead(const Child_: TTreeItem);
83
    procedure _InsertTail(const Child_: TTreeItem);
84
    procedure _InsertPrev(const Sibli_: TTreeItem);
85
    procedure _InsertNext(const Sibli_: TTreeItem);
86
    procedure InsertHead(const Child_: TTreeItem);
87
    procedure InsertTail(const Child_: TTreeItem);
88
    procedure InsertPrev(const Sibli_: TTreeItem);
89
    procedure InsertNext(const Sibli_: TTreeItem);
90
    class procedure Swap(const C1_, C2_: TTreeItem); overload;
91
    procedure Swap(const I1_, I2_: Integer); overload;
92
    procedure RunFamily(const Proc_: TNodeProc<TTreeItem>);
93
  end;
94

95
//=====================================================================
96
implementation
97

98
function TTreeAtom.Get_Parent: TTreeItem;
99
begin
100
  Result := nil;
101
end;
102

103
procedure TTreeAtom.Set_Parent(const Parent_: TTreeItem);
104
begin
105

106
end;
107

108
function TTreeAtom.Get_Order: Integer;
109
begin
110
  Result := -1;
111
end;
112

113
procedure TTreeAtom.Set_Order(const Order_: Integer);
114
begin
115

116
end;
117

118
function TTreeAtom.Get_Prev: TTreeItem;
119
begin
120
  Result := nil;
121
end;
122

123
procedure TTreeAtom.Set_Prev(const Prev_: TTreeItem);
124
begin
125

126
end;
127

128
function TTreeAtom.Get_Next: TTreeItem;
129
begin
130
  Result := nil;
131
end;
132

133
procedure TTreeAtom.Set_Next(const Next_: TTreeItem);
134
begin
135

136
end;
137

138
function TTreeAtom.Get_Links(const I_: Integer): TTreeItem;
139
begin
140
  Result := nil;
141
end;
142

143
procedure TTreeAtom.Set_Links(const I_: Integer; const Link_: TTreeItem);
144
begin
145

146
end;
147

148
function TTreeAtom.Get_LinksN: Integer;
149
begin
150
  Result := 0;
151
end;
152

153
procedure TTreeAtom.Set_LinksN(const LinksN_: Integer);
154
begin
155

156
end;
157

158
function TTreeAtom.Get_ChildsN: Integer;
159
begin
160
  Result := 0;
161
end;
162

163
procedure TTreeAtom.Set_ChildsN(const ChildsN_: Integer);
164
begin
165

166
end;
167

168
function TTreeAtom.Get_MaxOrder: Integer;
169
begin
170
  Result := -1;
171
end;
172

173
procedure TTreeAtom.Set_MaxOrder(const MaxOrder_: Integer);
174
begin
175

176
end;
177

178
function TTreeItem.Get_Zero: TTreeItem;
179
begin
180
  Result := _Links[-1];
181
end;
182

183
procedure TTreeItem.Set_Zero(const Zero_: TTreeItem);
184
begin
185
  _Links[-1] := Zero_;
186
end;
187

188
// ------------------------------------------------------------------------------
189

190
function TTreeItem.GetIsOrdered: Boolean;
191
begin
192
  Result := (_Order <= _Parent._MaxOrder) and (_Parent._Links[_Order] = Self);
193
end;
194

195
class procedure TTreeItem.Bind(const C0_, C1_: TTreeItem);
196
begin
197
  C0_._Next := C1_;
198
  C1_._Prev := C0_;
199
end;
200

201
class procedure TTreeItem.Bind(const C0_, C1_, C2_: TTreeItem);
202
begin
203
  Bind(C0_, C1_);
204
  Bind(C1_, C2_);
205
end;
206

207
class procedure TTreeItem.Bind(const C0_, C1_, C2_, C3_: TTreeItem);
208
begin
209
  Bind(C0_, C1_);
210
  Bind(C1_, C2_);
211
  Bind(C2_, C3_);
212
end;
213

214
function TTreeItem.GetParent: TTreeItem;
215
begin
216
  Result := _Parent;
217
end;
218

219
procedure TTreeItem.SetParent(const Parent_: TTreeItem);
220
begin
221
  Remove;
222

223
  if Assigned(Parent_) then
224
    Parent_._InsertTail(Self);
225
end;
226

227
// ------------------------------------------------------------------------------
228

229
function TTreeItem.GetOrder: Integer;
230
begin
231
  if not IsOrdered then
232
    _Parent.FindTo(Self);
233

234
  Result := _Order;
235
end;
236

237
procedure TTreeItem.SetOrder(const Order_: Integer);
238
begin
239
  Swap(Self, _Parent.Childs[Order_]);
240
end;
241

242
// ------------------------------------------------------------------------------
243

244
function TTreeItem.GetHead: TTreeItem;
245
begin
246
  Result := _Zero._Next;
247
end;
248

249
function TTreeItem.GetTail: TTreeItem;
250
begin
251
  Result := _Zero._Prev;
252
end;
253

254
// ------------------------------------------------------------------------------
255

256
function TTreeItem.GetChilds(const I_: Integer): TTreeItem;
257
begin
258
  if I_ > _MaxOrder then
259
    FindTo(I_);
260

261
  Result := _Links[I_];
262
end;
263

264
procedure TTreeItem.SetChilds(const I_: Integer; const Child_: TTreeItem);
265
var
266
  S: TTreeItem;
267
begin
268
  with Childs[I_] do
269
  begin
270
    S := Childs[I_]._Prev;
271

272
    Remove;
273
  end;
274

275
  S.InsertNext(Child_);
276
end;
277

278
function TTreeItem.GetChildsN: Integer;
279
begin
280
  Result := _ChildsN;
281
end;
282

283
function TTreeItem.GetRootNode: TTreeItem;
284
begin
285
  Result := Self;
286

287
  while Assigned(Result.Parent) do
288
    Result := Result.Parent;
289
end;
290

291
procedure TTreeItem.FindTo(const Child_: TTreeItem);
292
var
293
  P: TTreeItem;
294
begin
295
  if _ChildsN > _LinksN then
296
    _LinksN := _ChildsN;
297

298
  P := _Links[_MaxOrder];
299

300
  repeat
301
    P := P._Next;
302

303
    _MaxOrder := _MaxOrder + 1;
304

305
    _Links[_MaxOrder] := P;
306
    P._Order := _MaxOrder;
307

308
  until P = Child_;
309
end;
310

311
procedure TTreeItem.FindTo(const Order_: Integer);
312
var
313
  P: TTreeItem;
314
  I: Integer;
315
begin
316
  if _ChildsN > _LinksN then
317
    _LinksN := _ChildsN;
318

319
  P := _Links[_MaxOrder];
320

321
  for I := _MaxOrder + 1 to Order_ do
322
  begin
323
    P := P._Next;
324

325
    _Links[I] := P;
326
    P._Order := I;
327
  end;
328

329
  _MaxOrder := Order_;
330
end;
331

332
// ------------------------------------------------------------------------------
333

334
procedure TTreeItem._Insert(const C0_, C1_, C2_: TTreeItem);
335
begin
336
  C1_._Parent := Self;
337

338
  Bind(C0_, C1_, C2_);
339

340
  _ChildsN := _ChildsN + 1;
341

342
  OnInsertChild(C1_);
343
end;
344

345
procedure TTreeItem._Remove;
346
begin
347
  Bind(_Prev, _Next);
348

349
  if IsOrdered then
350
    _Parent._MaxOrder := _Order - 1;
351

352
  with _Parent do
353
  begin
354
    _ChildsN := _ChildsN - 1;
355

356
    if _ChildsN * 2 < _LinksN then
357
      _LinksN := _ChildsN;
358

359
    OnRemoveChild(Self);
360
  end;
361

362
  _Parent := nil;
363
  _Order := -1;
364
end;
365

366
// ------------------------------------------------------------------------------
367

368
procedure TTreeItem.OnInsertChild(const Child_: TTreeItem);
369
begin
370
  if Assigned(_Parent) then
371
    _Parent.OnInsertChild(Child_);
372
end;
373

374
procedure TTreeItem.OnRemoveChild(const Child_: TTreeItem);
375
begin
376
  if Assigned(_Parent) then
377
    _Parent.OnRemoveChild(Child_);
378
end;
379

380
procedure TTreeItem.Remove;
381
begin
382
  if Assigned(_Parent) then
383
    _Remove;
384
end;
385

386
procedure TTreeItem.RemoveChild(const Child_: TTreeItem);
387
begin
388
  if Self = Child_.Parent then
389
    Child_.Remove;
390
end;
391

392
// ------------------------------------------------------------------------------
393

394
procedure TTreeItem.DeleteChilds;
395
var
396
  N: Integer;
397
begin
398
  for N := 1 to _ChildsN do
399
    _Zero._Prev.Free;
400
end;
401

402
// ------------------------------------------------------------------------------
403

404
procedure TTreeItem._InsertHead(const Child_: TTreeItem);
405
begin
406
  _Insert(_Zero, Child_, Head);
407

408
  _MaxOrder := -1; { if Head.IsOrdered then _MaxOrder := Head._Order - 1; }
409
end;
410

411
procedure TTreeItem._InsertTail(const Child_: TTreeItem);
412
begin
413
  _Insert(Tail, Child_, _Zero);
414

415
  { if Tail.IsOrdered then _MaxOrder := Tail._Order; }
416
end;
417

418
procedure TTreeItem._InsertPrev(const Sibli_: TTreeItem);
419
begin
420
  _Parent._Insert(_Prev, Sibli_, Self);
421

422
  if IsOrdered then
423
    _Parent._MaxOrder := _Order - 1;
424
end;
425

426
procedure TTreeItem._InsertNext(const Sibli_: TTreeItem);
427
begin
428
  _Parent._Insert(Self, Sibli_, _Next);
429

430
  if IsOrdered then
431
    _Parent._MaxOrder := _Order;
432
end;
433

434
// ------------------------------------------------------------------------------
435

436
procedure TTreeItem.InsertHead(const Child_: TTreeItem);
437
begin
438
  Child_.Remove;
439
  _InsertHead(Child_);
440
end;
441

442
procedure TTreeItem.InsertTail(const Child_: TTreeItem);
443
begin
444
  Child_.Remove;
445
  _InsertTail(Child_);
446
end;
447

448
procedure TTreeItem.InsertPrev(const Sibli_: TTreeItem);
449
begin
450
  Sibli_.Remove;
451
  _InsertPrev(Sibli_);
452
end;
453

454
procedure TTreeItem.InsertNext(const Sibli_: TTreeItem);
455
begin
456
  Sibli_.Remove;
457
  _InsertNext(Sibli_);
458
end;
459

460
// ------------------------------------------------------------------------------
461

462
class procedure TTreeItem.Swap(const C1_, C2_: TTreeItem);
463
var
464
  P1, P2, C1n, C1u, C2n, C2u: TTreeItem;
465
  B1, B2: Boolean;
466
  I1, I2: Integer;
467
begin
468
  with C1_ do
469
  begin
470
    P1 := _Parent;
471
    B1 := IsOrdered;
472
    I1 := _Order;
473

474
    C1n := _Prev;
475
    C1u := _Next;
476
  end;
477

478
  with C2_ do
479
  begin
480
    P2 := _Parent;
481
    B2 := IsOrdered;
482
    I2 := _Order;
483

484
    C2n := _Prev;
485
    C2u := _Next;
486
  end;
487

488
  C1_._Parent := P2;
489
  C2_._Parent := P1;
490

491
  if C1_ = C2n then
492
    Bind(C1n, C2_, C1_, C2u)
493
  else if C1_ = C2u then
494
    Bind(C2n, C1_, C2_, C1u)
495
  else
496
  begin
497
    Bind(C1n, C2_, C1u);
498
    Bind(C2n, C1_, C2u);
499
  end;
500

501
  if B1 then
502
  begin
503
    P1._Links[I1] := C2_;
504
    C2_._Order := I1;
505
  end;
506

507
  if B2 then
508
  begin
509
    P2._Links[I2] := C1_;
510
    C1_._Order := I2;
511
  end;
512
end;
513

514
procedure TTreeItem.Swap(const I1_, I2_: Integer);
515
begin
516
  Swap(Childs[I1_], Childs[I2_]);
517
end;
518

519
// ------------------------------------------------------------------------------
520

521
procedure TTreeItem.RunFamily(const Proc_: TNodeProc<TTreeItem>);
522
var
523
  I: Integer;
524
begin
525
  Proc_(Self);
526

527
  for I := 0 to ChildsN - 1 do
528
    Childs[I].RunFamily(Proc_);
529
end;
530

531
end.
532