File: testobjectslist.pas

package info (click to toggle)
castle-game-engine 5.0.0-3
  • links: PTS, VCS
  • area: main
  • in suites: jessie, jessie-kfreebsd
  • size: 164,776 kB
  • ctags: 30,841
  • sloc: pascal: 168,882; cpp: 1,340; objc: 730; makefile: 492; sh: 477; xml: 434; php: 1
file content (142 lines) | stat: -rw-r--r-- 3,258 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
{
  Copyright 2004-2014 Michalis Kamburelis.

  This file is part of "Castle Game Engine".

  "Castle Game Engine" is free software; see the file COPYING.txt,
  included in this distribution, for details about the copyright.

  "Castle Game Engine" is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

  ----------------------------------------------------------------------------
}

unit TestObjectsList;

interface

uses
  Classes, SysUtils, fpcunit, testutils, testregistry, FGL;

type
  TTestObjectsList = class(TTestCase)
    procedure TestObjectsList;
  end;

implementation

uses CastleUtils, CastleClassUtils;

type
  TItem = class
    Str: string;
  end;

  TItemList = class(specialize TFPGObjectList<TItem>)
    { For each item of the list, delete all it's duplicates. }
    procedure DeleteDuplicates;
    procedure AddList(Source: TItemList);
  end;

procedure TItemList.DeleteDuplicates;

  function IndexOf(Item: TItem; StartIndex: Integer): Integer;
  begin
    for result := StartIndex to Count - 1 do
      if Item = Items[result] then exit;
    result := -1;
  end;

var
  I, Index: integer;
begin
  I := 0;
  while I < Count do
  begin
    Index := I + 1;
    repeat
      Index := IndexOf(Items[I], Index);
      if Index = -1 then Break;
      FPGObjectList_NilItem(Self, Index);
      Delete(Index);
    until false;

    Inc(I);
  end;
end;

procedure TItemList.AddList(Source: TItemList);
var
  OldCount: Integer;
begin
  OldCount := Count;
  Count := Count + Source.Count;
  if Source.Count <> 0 then
    System.Move(Source.List^[0], List^[OldCount], SizeOf(Pointer) * Source.Count);
end;

procedure TTestObjectsList.TestObjectsList;
var ol, ol2: TItemList;
begin
 ol := TItemList.Create(false);
 try ol.Add(TItem.Create); ol[0].Str := 'foo'; ol[0].Free;
 finally ol.Free end;

 ol := TItemList.Create(false);
 try ol.Add(TItem($454545)); ol.Delete(0);
 finally ol.Free end;

 ol := TItemList.Create(true);
 try ol.Add(TItem.Create); ol.Clear;
 finally ol.Free end;

 ol := TItemList.Create(true);
 try ol.Add(nil); ol.Clear;
 finally ol.Free end;

 ol := TItemList.Create(true);
 try
  ol.Add(TItem.Create); ol.Last.Str := 'first item';

  ol2 := TItemList.Create(false);
  try
   ol2.Add(TItem.Create); ol2.Last.Str := 'one';
   ol2.Add(TItem.Create); ol2.Last.Str := 'two';
   ol.AddList(ol2);
  finally ol2.Free end;
  ol.Clear;
 finally ol.Free end;

 ol := TItemList.Create(true);
 try
  ol.Add(TItem.Create); ol.Last.Str := 'first item';

  ol2 := TItemList.Create(false);
  try
   ol2.Add(TItem.Create); ol2.Last.Str := 'one';
   ol2.Add(TItem.Create); ol2.Last.Str := 'two';
   ol.AddList(ol2);
   ol.AddList(ol2);
  finally ol2.Free end;

  Assert(ol.Count = 5);
  Assert(ol[0].Str = 'first item');
  Assert(ol[1].Str = 'one');
  Assert(ol[2].Str = 'two');
  Assert(ol[3].Str = 'one');
  Assert(ol[4].Str = 'two');

  Assert(ol[1] = ol[3]); { (1 i 3) i (2 i 4) to te same obiekty. }
  Assert(ol[2] = ol[4]);

  { delete dups, preventing Clear from Freeing two times the same reference }
  ol.DeleteDuplicates;
  ol.Clear;
 finally ol.Free end;
end;

initialization
 RegisterTest(TTestObjectsList);
end.