1
2 (*
3 What's in it?
4 The zip file contains an example of a simple in-memory table of names.
5 Creation, sorting and destruction are demonstrated.
6
7
8 What version of Delphi?
9 It's written in D6, but should compile on any version of Delphi.
10 You may have to redo the form due to DFM incompatability.
11 Who cares?Anyone who wants to use an old-school method of making very fast datasets
12 in memory.
13
14 *)
15
16 unit Unit1;
17
18 interface
19 //-------------------------UNIT1.PAS--------------------------------------
20 uses
21 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
22 StdCtrls;
23
24 type
25 TMyObjectPtr = ^TMyObject;
26 TMyObject = record
27 First_Name: string[20];
28 Last_Name: string[20];
29 Next: TMyObjectPtr;
30 end;
31
32 type
33 TForm1 = class(TForm)
34 bSortByLastName: TButton;
35 bDisplay: TButton;
36 bPopulate: TButton;
37 ListBox1: TListBox;
38 bClear: TButton;
39 procedure bSortByLastNameClick(Sender: TObject);
40 procedure bPopulateClick(Sender: TObject);
41 procedure bDisplayClick(Sender: TObject);
42 procedure bClearClick(Sender: TObject);
43 private
44 { Private declarations }
45 public
46 { Public declarations }
47 end;
48
49 var
50 Form1: TForm1;
51 pStartOfList: TMyObjectPtr = nil;
52
53 procedure SortMyObjectListByLastName(var aStartOfList: TMyObjectPtr);
54 function CreateMyObject(aFirstName, aLastName: string): TMyObjectPtr;
55 procedure AppendMyObject(var aCurrentItem, aNewItem: TMyObjectPtr);
56 procedure ClearMyObjectList(var aMyObject: TMyObjectPtr);
57 procedure RemoveMyObject(var aStartOfList, aRemoveMe: TMyObjectPtr);
58 function AreInAlphaOrder(aString1, aString2: string): Boolean;
59
60
61 implementation
62
63 {$R *.DFM}
64
65
66 procedure TForm1.bClearClick(Sender: TObject);
67 begin
68 ClearMyObjectList(pStartOfList);
69 end;
70
71 procedure TForm1.bPopulateClick(Sender: TObject);
72 var
73 pNew: TMyObjectPtr;
74 begin
75 pNew := CreateMyObject('Suzy','Martinez');
76 AppendMyObject(pStartOfList, pNew);
77 pNew := CreateMyObject('John','Sanchez');
78 AppendMyObject(pStartOfList, pNew);
79 pNew := CreateMyObject('Mike','Rodriguez');
80 AppendMyObject(pStartOfList, pNew);
81 pNew := CreateMyObject('Mary','Sosa');
82 AppendMyObject(pStartOfList, pNew);
83 pNew := CreateMyObject('Betty','Hayek');
84 AppendMyObject(pStartOfList, pNew);
85 pNew := CreateMyObject('Luke','Smith');
86 AppendMyObject(pStartOfList, pNew);
87 pNew := CreateMyObject('John','Sosa');
88 AppendMyObject(pStartOfList, pNew);
89 end;
90
91 procedure TForm1.bSortByLastNameClick(Sender: TObject);
92 begin
93 SortMyObjectListByLastName(pStartOfList);
94 end;
95
96 procedure TForm1.bDisplayClick(Sender: TObject);
97 var
98 pTemp: TMyObjectPtr;
99 begin
100 ListBox1.Items.Clear;
101 pTemp := pStartOfList;
102 while pTemp <> nil do
103 begin
104 ListBox1.Items.Add(pTemp^.Last_Name + ', ' + pTemp.First_Name);
105 pTemp := pTemp^.Next;
106 end;
107 end;
108
109 procedure ClearMyObjectList(var aMyObject: TMyObjectPtr);
110 var
111 TempMyObject: TMyObjectPtr;
112 begin
113 TempMyObject := aMyObject;
114 while aMyObject <> nil do
115 begin
116 aMyObject := aMyObject^.Next;
117 Dispose(TempMyObject);
118 TempMyObject := aMyObject;
119 end;
120 end;
121
122 function CreateMyObject(aFirstName, aLastName: string): TMyObjectPtr;
123 begin
124 new(result);
125 result^.First_Name := aFirstName;
126 result^.Last_Name := aLastName;
127 result^.Next := nil;
128 end;
129
130 procedure SortMyObjectListByLastName(var aStartOfList: TMyObjectPtr);
131 var
132 aSortedListStart, aSearch, aBest: TMyObjectPtr;
133 begin
134 aSortedListStart := nil;
135 while (aStartOfList <> nil) do
136 begin
137 aSearch := aStartOfList;
138 aBest := aSearch;
139 while aSearch^.Next <> nil do
140 begin
141 if not AreInAlphaOrder(aBest^.Last_Name, aSearch^.Last_Name) then
142 aBest := aSearch;
143 aSearch := aSearch^.Next;
144 end;
145 RemoveMyObject(aStartOfList, aBest);
146 AppendMyObject(aSortedListStart, aBest);
147 end;
148 aStartOfList := aSortedListStart;
149 end;
150
151 procedure AppendMyObject(var aCurrentItem, aNewItem: TMyObjectPtr);
152 begin
153 if aCurrentItem = nil then
154 aCurrentItem := aNewItem
155 else
156 AppendMyObject(aCurrentItem^.Next, aNewItem);
157 end;
158
159 procedure RemoveMyObject(var aStartOfList, aRemoveMe: TMyObjectPtr);
160 var
161 pTemp: TMyObjectPtr;
162 begin
163 pTemp := aStartOfList;
164 if pTemp = aRemoveMe then
165 aStartOfList := aStartOfList^.Next
166 else
167 begin
168 while (pTemp^.Next <> aRemoveMe) and (pTemp^.Next <> nil) do
169 pTemp := pTemp^.Next;
170 if pTemp = nil then Exit; //Shouldn't ever happen
171 if pTemp^.Next = nil then Exit; //Shouldn't ever happen
172 pTemp^.Next := aRemoveMe^.Next;
173 end;
174 aRemoveMe^.Next := nil;
175 end;
176
177 function AreInAlphaOrder(aString1, aString2: string): Boolean;
178 var
179 i: Integer;
180 begin
181 Result := True;
182
183 while Length(aString2) < Length(aString1) do aString2 := aString2 + '!';
184 while Length(aString1) < Length(aString2) do aString1 := aString1 + '!';
185
186 for i := 1 to Length(aString1) do
187 begin
188 if aString1[i] > aString2[i] then Result := False;
189 if aString1[i] <> aString2[i] then break;
190 end;
191 end;
192
193 end.
194 //-------------------------UNIT1.DFM--------------------------------------
195 object Form1: TForm1
196 Left = 334
197 Top = 198
198 Width = 374
199 Height = 329
200 Caption = 'Linked List Example'
201 Color = clBtnFace
202 Font.Charset = DEFAULT_CHARSET
203 Font.Color = clWindowText
204 Font.Height = -11
205 Font.Name = 'MS Sans Serif'
206 Font.Style = []
207 OldCreateOrder = False
208 PixelsPerInch = 96
209 TextHeight = 13
210 object bSortByLastName: TButton
211 Left = 4
212 Top = 63
213 Width = 125
214 Height = 25
215 Caption = 'Sort List by Last Name'
216 TabOrder = 0
217 OnClick = bSortByLastNameClick
218 end
219 object bDisplay: TButton
220 Left = 28
221 Top = 89
222 Width = 75
223 Height = 25
224 Caption = 'Display List'
225 TabOrder = 1
226 OnClick = bDisplayClick
227 end
228 object bPopulate: TButton
229 Left = 4
230 Top = 37
231 Width = 125
232 Height = 25
233 Caption = 'Populate List'
234 TabOrder = 2
235 OnClick = bPopulateClick
236 end
237 object ListBox1: TListBox
238 Left = 146
239 Top = 12
240 Width = 179
241 Height = 235
242 ItemHeight = 13
243 TabOrder = 3
244 end
245 object bClear: TButton
246 Left = 4
247 Top = 11
248 Width = 125
249 Height = 25
250 Caption = 'Clear List'
251 TabOrder = 4
252 OnClick = bClearClick
253 end
254 end
|
