WebSVN – oidplus – Diff – /trunk_dos/STRLIST.PAS


unit STRLIST;
 
(************************************************)
(* STRLIST.PAS                                  *)
(* Author:   Daniel Marschall                   *)
(* Revision: 2022-02-14                         *)
(* License:  Apache 2.0                         *)
(* This file contains:                          *)
(* - StringList implementation for Turbo Pascal *)
(************************************************)
 
interface
 
type
  PStringList = ^TStringList;
  TStringList = record
    init: boolean;
    element: string;
    next: PStringList;
  end;
 
procedure CreateList(var list: PStringList);
procedure FreeList(list: PStringList);
function ListContains(list: PStringList; val: string): boolean;
procedure ListClear(list: PStringList);
function ListAppend(list: PStringList; str: string): integer;
function ListCount(list: PStringList): integer;
function ListDeleteElementByIndex(list: PStringlist; idx: integer): boolean;
function ListDeleteElementByValue(list: PStringlist; val: string): boolean;
function ListGetElement(list: PStringList; idx: integer): string;
procedure ListSetElement(list: PStringList; idx: integer; value: string);
procedure ListInsert(list: PStringlist; str: string; idx: integer);
procedure ListSwapElement(list: PStringList; i, j: integer);
procedure SplitStrToList(str: string; list: PStringList; separator: string);
procedure OIDtoArcList(oid: string; list: PStringList);
procedure ListBubbleSortNumericString(list: PStringList);
 
implementation
 
uses
  VtsFuncs;
 
procedure CreateList(var list: PStringList);
begin
  GetMem(list, SizeOf(TStringList));
  list^.init := false;
  list^.element := '';
  list^.next := nil;
end;
 
procedure FreeList(list: PStringList);
begin
  if list^.next <> nil then
    FreeList(list^.Next);
  FreeMem(list, SizeOf(TStringList));
end;
 
function ListContains(list: PStringList; val: string): boolean;
var
  i: integer;
begin
  ListContains := false;
  for i := 0 to ListCount(list)-1 do
  begin
    if ListGetElement(list, i) = val then
    begin
      ListContains := true;
      break;
    end;
  end;
end;
 
procedure ListClear(list: PStringList);
begin
  while ListCount(list) > 0 do
  begin
    ListDeleteElementByIndex(list, 0);
  end;
end;
 
function ListAppend(list: PStringList; str: string): integer;
var
  new: PStringList;
  tmp: PStringList;
  cnt: integer;
begin
  cnt := 0;
  if not list^.init then
  begin
   list^.element := str;
   list^.init := true;
  end
  else
  begin
    Inc(cnt);
    GetMem(new, sizeof(TStringList));
    new^.element := str;
    new^.next := nil;
    new^.init := true;
 
    tmp := list;
    while tmp^.next <> nil do
    begin
      tmp := tmp^.next;
      Inc(cnt);
    end;
 
    tmp^.next := new;
  end;
 
  ListAppend := cnt; (* Return the index where the new element was put *)
end;
 
function ListCount(list: PStringList): integer;
var
  cnt: integer;
  tmp: PStringList;
begin
  tmp := list;
  cnt := 0;
 
  if tmp^.init then
  begin
    repeat
      Inc(cnt);
      tmp := tmp^.next;
    until tmp = nil;
  end;
 
  ListCount := cnt;
end;
 
function ListDeleteElementByIndex(list: PStringlist; idx: integer): boolean;
var
  tmp, tmp2, prev: PStringList;
  i: integer;
begin
  ListDeleteElementByIndex := false;
  if idx < 0 then exit;
  if idx > ListCount(list)-1 then exit;
 
  tmp := list;
  prev := nil;
  i := 0;
  while i < idx do
  begin
    prev := tmp;
    tmp := tmp^.next;
    inc(i);
  end;
  if prev = nil then
  begin
    if tmp^.next = nil then
    begin
      tmp^.init := false;
    end
    else
    begin
      tmp^.init := true;
      tmp^.element := tmp^.next^.element;
      tmp2 := tmp^.next;
      tmp^.next := tmp^.next^.next;
      FreeMem(tmp2, SizeOf(TStringList));
    end;
  end
  else
  begin
    prev^.next := tmp^.next;
    FreeMem(tmp, SizeOf(TStringList));
  end;
 
  ListDeleteElementByIndex := true;
end;
 
function ListDeleteElementByValue(list: PStringlist; val: string): boolean;
var
  i: integer;
begin
  ListDeleteElementByValue := false;
  for i := 0 to ListCount(list)-1 do
  begin
    if ListGetElement(list, i) = val then
    begin
      ListDeleteElementByValue := ListDeleteElementByIndex(list, i);
      exit;
    end;
  end;
end;
 
function ListGetElement(list: PStringList; idx: integer): string;
var
  tmp: PStringList;
  i: integer;
begin
  if idx < 0 then exit;
  if idx > ListCount(list)-1 then exit;
 
  tmp := list;
  i := 0;
  while i < idx do
  begin
    tmp := tmp^.next;
    inc(i);
  end;
 
  ListGetElement := tmp^.element;
end;
 
procedure ListSetElement(list: PStringList; idx: integer; value: string);
var
  tmp: PStringList;
  i: integer;
begin
  if idx < 0 then exit;
  if idx > ListCount(list)-1 then exit;
 
  tmp := list;
  i := 0;
  while i < idx do
  begin
    tmp := tmp^.next;
    inc(i);
  end;
 
  tmp^.element := value;
end;
 
procedure ListInsert(list: PStringlist; str: string; idx: integer);
var
  tmp, new: PStringList;
  i: integer;
begin
  if idx < 0 then exit;
  if idx > ListCount(list)-1 then exit;
 
  tmp := list;
  i := 0;
  while i < idx do
  begin
    tmp := tmp^.next;
    inc(i);
  end;
 
  GetMem(new, sizeof(TStringList));
  new^.init := true;
  new^.next := tmp^.next;
  new^.element := tmp^.element;
 
  tmp^.element := str;
  tmp^.next := new;
  tmp^.init := true;
end;
 
procedure ListSwapElement(list: PStringList; i, j: integer);
var
  a, b: string;
begin
  a := ListGetElement(list, i);
  b := ListGetElement(list, j);
  ListSetElement(list, i, b);
  ListSetElement(list, j, a);
end;
 
procedure SplitStrToList(str: string; list: PStringList; separator: string);
var
  p: integer;
begin
  str := str + separator;
  repeat
    p := Pos(separator, str);
    ListAppend(list, Copy(str, 1, p-1));
    str := copy(str, p+Length(separator), Length(str)-p);
  until str = '';
end;
 
procedure OIDtoArcList(oid: string; list: PStringList);
begin
  SplitStrToList(oid, list, '.');
end;
 
procedure ListBubbleSortNumericString(list: PStringList);
var
  n, i: integer;
  a, b: string;
  swapped: boolean;
begin
  n := ListCount(list);
  while n>1 do
  begin
    i := 0;
    swapped := false;
    while i<n-1 do
    begin
      a := ListGetElement(list, i);
      b := ListGetElement(list, i+1);
      if CompareNumericString(a, b) > 0 then
      begin
        ListSwapElement(list, i, i+1);
        swapped := true;
      end;
      Inc(i);
    end;
    if not swapped then break;
    Dec(n);
  end;
end;
 
end.
 

Rev 737	Rev 740
1	unit STRLIST;	1	unit STRLIST;
2		2
3	(************************************************)	3	(************************************************)
4	(* STRLIST.PAS *)	4	(* STRLIST.PAS *)
5	(* Author: Daniel Marschall *)	5	(* Author: Daniel Marschall *)
6	(* Revision: 2022-02-14 *)	6	(* Revision: 2022-02-14 *)
7	(* License: Apache 2.0 *)	7	(* License: Apache 2.0 *)
8	(* This file contains: *)	8	(* This file contains: *)
9	(* - StringList implementation for Turbo Pascal *)	9	(* - StringList implementation for Turbo Pascal *)
10	(************************************************)	10	(************************************************)
11		11
12	interface	12	interface
13		13
14	type	14	type
15	PStringList = ^TStringList;	15	PStringList = ^TStringList;
16	TStringList = record	16	TStringList = record
17	init: boolean;	17	init: boolean;
18	element: string;	18	element: string;
19	next: PStringList;	19	next: PStringList;
20	end;	20	end;
21		21
22	procedure CreateList(var list: PStringList);	22	procedure CreateList(var list: PStringList);
23	procedure FreeList(list: PStringList);	23	procedure FreeList(list: PStringList);
24	function ListContains(list: PStringList; val: string): boolean;	24	function ListContains(list: PStringList; val: string): boolean;
25	procedure ListClear(list: PStringList);	25	procedure ListClear(list: PStringList);
26	function ListAppend(list: PStringList; str: string): integer;	26	function ListAppend(list: PStringList; str: string): integer;
27	function ListCount(list: PStringList): integer;	27	function ListCount(list: PStringList): integer;
28	function ListDeleteElementByIndex(list: PStringlist; idx: integer): boolean;	28	function ListDeleteElementByIndex(list: PStringlist; idx: integer): boolean;
29	function ListDeleteElementByValue(list: PStringlist; val: string): boolean;	29	function ListDeleteElementByValue(list: PStringlist; val: string): boolean;
30	function ListGetElement(list: PStringList; idx: integer): string;	30	function ListGetElement(list: PStringList; idx: integer): string;
31	procedure ListSetElement(list: PStringList; idx: integer; value: string);	31	procedure ListSetElement(list: PStringList; idx: integer; value: string);
32	procedure ListInsert(list: PStringlist; str: string; idx: integer);	32	procedure ListInsert(list: PStringlist; str: string; idx: integer);
33	procedure ListSwapElement(list: PStringList; i, j: integer);	33	procedure ListSwapElement(list: PStringList; i, j: integer);
34	procedure SplitStrToList(str: string; list: PStringList; separator: string);	34	procedure SplitStrToList(str: string; list: PStringList; separator: string);
35	procedure OIDtoArcList(oid: string; list: PStringList);	35	procedure OIDtoArcList(oid: string; list: PStringList);
36	procedure ListBubbleSortNumericString(list: PStringList);	36	procedure ListBubbleSortNumericString(list: PStringList);
37		37
38	implementation	38	implementation
39		39
40	uses	40	uses
41	VtsFuncs;	41	VtsFuncs;
42		42
43	procedure CreateList(var list: PStringList);	43	procedure CreateList(var list: PStringList);
44	begin	44	begin
45	GetMem(list, SizeOf(TStringList));	45	GetMem(list, SizeOf(TStringList));
46	list^.init := false;	46	list^.init := false;
47	list^.element := '';	47	list^.element := '';
48	list^.next := nil;	48	list^.next := nil;
49	end;	49	end;
50		50
51	procedure FreeList(list: PStringList);	51	procedure FreeList(list: PStringList);
52	begin	52	begin
53	if list^.next <> nil then	53	if list^.next <> nil then
54	FreeMem(list^.next, SizeOf(TStringList));	54	FreeList(list^.Next);
55	FreeMem(list, SizeOf(TStringList));	55	FreeMem(list, SizeOf(TStringList));
56	end;	56	end;
57		57
58	function ListContains(list: PStringList; val: string): boolean;	58	function ListContains(list: PStringList; val: string): boolean;
59	var	59	var
60	i: integer;	60	i: integer;
61	begin	61	begin
62	ListContains := false;	62	ListContains := false;
63	for i := 0 to ListCount(list)-1 do	63	for i := 0 to ListCount(list)-1 do
64	begin	64	begin
65	if ListGetElement(list, i) = val then	65	if ListGetElement(list, i) = val then
66	begin	66	begin
67	ListContains := true;	67	ListContains := true;
68	break;	68	break;
69	end;	69	end;
70	end;	70	end;
71	end;	71	end;
72		72
73	procedure ListClear(list: PStringList);	73	procedure ListClear(list: PStringList);
74	begin	74	begin
75	while ListCount(list) > 0 do	75	while ListCount(list) > 0 do
76	begin	76	begin
77	ListDeleteElementByIndex(list, 0);	77	ListDeleteElementByIndex(list, 0);
78	end;	78	end;
79	end;	79	end;
80		80
81	function ListAppend(list: PStringList; str: string): integer;	81	function ListAppend(list: PStringList; str: string): integer;
82	var	82	var
83	new: PStringList;	83	new: PStringList;
84	tmp: PStringList;	84	tmp: PStringList;
85	cnt: integer;	85	cnt: integer;
86	begin	86	begin
87	cnt := 0;	87	cnt := 0;
88	if not list^.init then	88	if not list^.init then
89	begin	89	begin
90	list^.element := str;	90	list^.element := str;
91	list^.init := true;	91	list^.init := true;
92	end	92	end
93	else	93	else
94	begin	94	begin
95	Inc(cnt);	95	Inc(cnt);
96	GetMem(new, sizeof(TStringList));	96	GetMem(new, sizeof(TStringList));
97	new^.element := str;	97	new^.element := str;
98	new^.next := nil;	98	new^.next := nil;
99	new^.init := true;	99	new^.init := true;
100		100
101	tmp := list;	101	tmp := list;
102	while tmp^.next <> nil do	102	while tmp^.next <> nil do
103	begin	103	begin
104	tmp := tmp^.next;	104	tmp := tmp^.next;
105	Inc(cnt);	105	Inc(cnt);
106	end;	106	end;
107		107
108	tmp^.next := new;	108	tmp^.next := new;
109	end;	109	end;
110		110
111	ListAppend := cnt; (* Return the index where the new element was put *)	111	ListAppend := cnt; (* Return the index where the new element was put *)
112	end;	112	end;
113		113
114	function ListCount(list: PStringList): integer;	114	function ListCount(list: PStringList): integer;
115	var	115	var
116	cnt: integer;	116	cnt: integer;
117	tmp: PStringList;	117	tmp: PStringList;
118	begin	118	begin
119	tmp := list;	119	tmp := list;
120	cnt := 0;	120	cnt := 0;
121		121
122	if tmp^.init then	122	if tmp^.init then
123	begin	123	begin
124	repeat	124	repeat
125	Inc(cnt);	125	Inc(cnt);
126	tmp := tmp^.next;	126	tmp := tmp^.next;
127	until tmp = nil;	127	until tmp = nil;
128	end;	128	end;
129		129
130	ListCount := cnt;	130	ListCount := cnt;
131	end;	131	end;
132		132
133	function ListDeleteElementByIndex(list: PStringlist; idx: integer): boolean;	133	function ListDeleteElementByIndex(list: PStringlist; idx: integer): boolean;
134	var	134	var
135	tmp, tmp2, prev: PStringList;	135	tmp, tmp2, prev: PStringList;
136	i: integer;	136	i: integer;
137	begin	137	begin
138	ListDeleteElementByIndex := false;	138	ListDeleteElementByIndex := false;
139	if idx < 0 then exit;	139	if idx < 0 then exit;
140	if idx > ListCount(list)-1 then exit;	140	if idx > ListCount(list)-1 then exit;
141		141
142	tmp := list;	142	tmp := list;
143	prev := nil;	143	prev := nil;
144	i := 0;	144	i := 0;
145	while i < idx do	145	while i < idx do
146	begin	146	begin
147	prev := tmp;	147	prev := tmp;
148	tmp := tmp^.next;	148	tmp := tmp^.next;
149	inc(i);	149	inc(i);
150	end;	150	end;
151	if prev = nil then	151	if prev = nil then
152	begin	152	begin
153	if tmp^.next = nil then	153	if tmp^.next = nil then
154	begin	154	begin
155	tmp^.init := false;	155	tmp^.init := false;
156	end	156	end
157	else	157	else
158	begin	158	begin
159	tmp^.init := true;	159	tmp^.init := true;
160	tmp^.element := tmp^.next^.element;	160	tmp^.element := tmp^.next^.element;
161	tmp2 := tmp^.next;	161	tmp2 := tmp^.next;
162	tmp^.next := tmp^.next^.next;	162	tmp^.next := tmp^.next^.next;
163	FreeMem(tmp2, SizeOf(TStringList));	163	FreeMem(tmp2, SizeOf(TStringList));
164	end;	164	end;
165	end	165	end
166	else	166	else
167	begin	167	begin
168	prev^.next := tmp^.next;	168	prev^.next := tmp^.next;
169	FreeMem(tmp, SizeOf(TStringList));	169	FreeMem(tmp, SizeOf(TStringList));
170	end;	170	end;
171		171
172	ListDeleteElementByIndex := true;	172	ListDeleteElementByIndex := true;
173	end;	173	end;
174		174
175	function ListDeleteElementByValue(list: PStringlist; val: string): boolean;	175	function ListDeleteElementByValue(list: PStringlist; val: string): boolean;
176	var	176	var
177	i: integer;	177	i: integer;
178	begin	178	begin
179	ListDeleteElementByValue := false;	179	ListDeleteElementByValue := false;
180	for i := 0 to ListCount(list)-1 do	180	for i := 0 to ListCount(list)-1 do
181	begin	181	begin
182	if ListGetElement(list, i) = val then	182	if ListGetElement(list, i) = val then
183	begin	183	begin
184	ListDeleteElementByValue := ListDeleteElementByIndex(list, i);	184	ListDeleteElementByValue := ListDeleteElementByIndex(list, i);
185	exit;	185	exit;
186	end;	186	end;
187	end;	187	end;
188	end;	188	end;
189		189
190	function ListGetElement(list: PStringList; idx: integer): string;	190	function ListGetElement(list: PStringList; idx: integer): string;
191	var	191	var
192	tmp: PStringList;	192	tmp: PStringList;
193	i: integer;	193	i: integer;
194	begin	194	begin
195	if idx < 0 then exit;	195	if idx < 0 then exit;
196	if idx > ListCount(list)-1 then exit;	196	if idx > ListCount(list)-1 then exit;
197		197
198	tmp := list;	198	tmp := list;
199	i := 0;	199	i := 0;
200	while i < idx do	200	while i < idx do
201	begin	201	begin
202	tmp := tmp^.next;	202	tmp := tmp^.next;
203	inc(i);	203	inc(i);
204	end;	204	end;
205		205
206	ListGetElement := tmp^.element;	206	ListGetElement := tmp^.element;
207	end;	207	end;
208		208
209	procedure ListSetElement(list: PStringList; idx: integer; value: string);	209	procedure ListSetElement(list: PStringList; idx: integer; value: string);
210	var	210	var
211	tmp: PStringList;	211	tmp: PStringList;
212	i: integer;	212	i: integer;
213	begin	213	begin
214	if idx < 0 then exit;	214	if idx < 0 then exit;
215	if idx > ListCount(list)-1 then exit;	215	if idx > ListCount(list)-1 then exit;
216		216
217	tmp := list;	217	tmp := list;
218	i := 0;	218	i := 0;
219	while i < idx do	219	while i < idx do
220	begin	220	begin
221	tmp := tmp^.next;	221	tmp := tmp^.next;
222	inc(i);	222	inc(i);
223	end;	223	end;
224		224
225	tmp^.element := value;	225	tmp^.element := value;
226	end;	226	end;
227		227
228	procedure ListInsert(list: PStringlist; str: string; idx: integer);	228	procedure ListInsert(list: PStringlist; str: string; idx: integer);
229	var	229	var
230	tmp, new: PStringList;	230	tmp, new: PStringList;
231	i: integer;	231	i: integer;
232	begin	232	begin
233	if idx < 0 then exit;	233	if idx < 0 then exit;
234	if idx > ListCount(list)-1 then exit;	234	if idx > ListCount(list)-1 then exit;
235		235
236	tmp := list;	236	tmp := list;
237	i := 0;	237	i := 0;
238	while i < idx do	238	while i < idx do
239	begin	239	begin
240	tmp := tmp^.next;	240	tmp := tmp^.next;
241	inc(i);	241	inc(i);
242	end;	242	end;
243		243
244	GetMem(new, sizeof(TStringList));	244	GetMem(new, sizeof(TStringList));
245	new^.init := true;	245	new^.init := true;
246	new^.next := tmp^.next;	246	new^.next := tmp^.next;
247	new^.element := tmp^.element;	247	new^.element := tmp^.element;
248		248
249	tmp^.element := str;	249	tmp^.element := str;
250	tmp^.next := new;	250	tmp^.next := new;
251	tmp^.init := true;	251	tmp^.init := true;
252	end;	252	end;
253		253
254	procedure ListSwapElement(list: PStringList; i, j: integer);	254	procedure ListSwapElement(list: PStringList; i, j: integer);
255	var	255	var
256	a, b: string;	256	a, b: string;
257	begin	257	begin
258	a := ListGetElement(list, i);	258	a := ListGetElement(list, i);
259	b := ListGetElement(list, j);	259	b := ListGetElement(list, j);
260	ListSetElement(list, i, b);	260	ListSetElement(list, i, b);
261	ListSetElement(list, j, a);	261	ListSetElement(list, j, a);
262	end;	262	end;
263		263
264	procedure SplitStrToList(str: string; list: PStringList; separator: string);	264	procedure SplitStrToList(str: string; list: PStringList; separator: string);
265	var	265	var
266	p: integer;	266	p: integer;
267	begin	267	begin
268	str := str + separator;	268	str := str + separator;
269	repeat	269	repeat
270	p := Pos(separator, str);	270	p := Pos(separator, str);
271	ListAppend(list, Copy(str, 1, p-1));	271	ListAppend(list, Copy(str, 1, p-1));
272	str := copy(str, p+Length(separator), Length(str)-p);	272	str := copy(str, p+Length(separator), Length(str)-p);
273	until str = '';	273	until str = '';
274	end;	274	end;
275		275
276	procedure OIDtoArcList(oid: string; list: PStringList);	276	procedure OIDtoArcList(oid: string; list: PStringList);
277	begin	277	begin
278	SplitStrToList(oid, list, '.');	278	SplitStrToList(oid, list, '.');
279	end;	279	end;
280		280
281	procedure ListBubbleSortNumericString(list: PStringList);	281	procedure ListBubbleSortNumericString(list: PStringList);
282	var	282	var
283	n, i: integer;	283	n, i: integer;
284	a, b: string;	284	a, b: string;
-		285	swapped: boolean;
285	begin	286	begin
286	n := ListCount(list);	287	n := ListCount(list);
287	while n>1 do	288	while n>1 do
288	begin	289	begin
289	i := 0;	290	i := 0;
-		291	swapped := false;
290	while i<n-1 do	292	while i<n-1 do
291	begin	293	begin
292	a := ListGetElement(list, i);	294	a := ListGetElement(list, i);
293	b := ListGetElement(list, i+1);	295	b := ListGetElement(list, i+1);
294	if CompareNumericString(a, b) > 0 then	296	if CompareNumericString(a, b) > 0 then
295	begin	297	begin
296	ListSwapElement(list, i, i+1);	298	ListSwapElement(list, i, i+1);
-		299	swapped := true;
297	end;	300	end;
298	Inc(i);	301	Inc(i);
299	end;	302	end;
-		303	if not swapped then break;
300	Dec(n);	304	Dec(n);
301	end;	305	end;
302	end;	306	end;
303		307
304	end.	308	end.
305		309

Subversion Repositories oidplus

oidplus/trunk_dos/STRLIST.PAS – Rev 737 → 740