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

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

Subversion Repositories oidplus

oidplus/trunk_dos/STRLIST.PAS @ 992 – Rev 740