/pliant/language/type/set/old_index.pli
1	# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
2	#
3	# This program is free software; you can redistribute it and/or
4	# modify it under the terms of the GNU General Public License version 2
5	# as published by the Free Software Foundation.
6	#
7	# This program is distributed in the hope that it will be useful,
8	# but WITHOUT ANY WARRANTY; without even the implied warranty of
9	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
10	# GNU General Public License for more details.
11	#
12	# You should have received a copy of the GNU General Public License
13	# version 2 along with this program; if not, write to the Free Software
14	# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
15
16	scope "/pliant/language/" "/pliant/install/"
17	module "/pliant/install/ring3.pli"
18
19
20	module "/pliant/language/declare/internals.pli"
21	module "/pliant/language/basic/shunt.pli"
22	module "/pliant/language/debug/error1.pli"
23	module "/pliant/language/basic/shortcut.pli"
24	module "/pliant/language/basic/compare.pli"
25	module "/pliant/language/type/number/int.pli"
26	module "/pliant/language/type/text/str.pli"
27
28
29
30	#   data types
31
32
33	type IndexNode
34	field Arrow data
35	field Str key
36	field Pointer:IndexNode right left
37	field Pointer:IndexNode father
38	field Int nb <- 0
39
40
41	type Index
42	field Pointer:IndexNode root
43
44
45
46	#   IndexNode small computations
47
48
49	gvar IndexNode null_node
50	null_node left :> null_node
51	null_node right :> null_node
52	null_node father :> null_node
53
54	function build  index
55	arg_w Index index
56	index root :> null_node
57
58	function free node
59	arg_rw IndexNode node
60	if addressof:node=addressof:null_node
61	return
62	free node:left
63	free node:right
64	IndexNode destroy_instance addressof:node
65	memory_free addressof:node
66
67	function destroy index
68	arg_w Index index
69	free index:root
70
71
72	method n biggest_son -> s
73	arg IndexNode n ; arg_C IndexNode s
74	s :> shunt n:left:nb>=n:right:nb n:left n:right
75
76
77	method n adjust_count
78	arg_rw IndexNode n
79	n nb := n:left:nb+n:right:nb+1
80
81
82
83	#   checking
84
85
86	method index check node
87	arg Index index ; arg IndexNode node
88	if addressof:node=addressof:null_node
89	return
90	if node:nb<>node:left:nb+node:right:nb+1
91	error error_id_corrupted "Incorrect index (counter) for "+node:key
92	if (addressof node:left)<>addressof:null_node
93	if node:left:key>node:key
94	error error_id_corrupted "Incorrect index (left order)"
95	if (addressof node:left:father)<>addressof:node
96	error error_id_corrupted "Incorrect index (left son)"
97	if (addressof node:right)<>addressof:null_node
98	if node:right:key<node:key
99	error error_id_corrupted "Incorrect index (right order)"
100	if (addressof node:right:father)<>addressof:node
101	error error_id_corrupted "Incorrect index (right son)"
102	index check node:left
103	index check node:right
104
105	method index check
106	arg Index index
107	if (addressof index:root)=addressof:null_node
108	return
109	if (addressof index:root:father)<>addressof:null_node
110	error error_id_corrupted "Incorrect index (root)"
111	index check index:root
112
113
114	method index display node indent
115	arg Index index ; arg Pointer:IndexNode node ; arg Int indent
116	if addressof:node=addressof:null_node
117	return
118	console (repeat indent " ")+node:key+" "+(string node:nb)+" "+(shunt (addressof node:left)<>addressof:null_node "/" " ")+(shunt (addressof node:right)<>addressof:null_node "\" " ")+"[lf]"
119	index display node:left indent+2
120	index display node:right indent+2
121
122	method index display_tree
123	arg Index index
124	index display index:root 0
125
126
127
128	#   walking
129
130
131	method index first -> cursor
132	arg Index index ; arg Pointer:Arrow cursor
133	var Pointer:IndexNode node :> index root
134	while (addressof node:left)<>addressof:null_node
135	node :> node left
136	cursor :> node data
137
138
139	method index last -> cursor
140	arg Index index ; arg Pointer:Arrow cursor
141	var Pointer:IndexNode node :> index root
142	while (addressof node:right)<>addressof:null_node
143	node :> node right
144	cursor :> node data
145
146
147	method index next cursor -> cursor2
148	arg Index index ; arg Pointer:Arrow cursor cursor2
149	check addressof:cursor<>addressof:null_node
150	var Pointer:IndexNode node :> addressof:cursor map IndexNode
151	var Pointer:IndexNode node2
152	if (addressof node:right)<>addressof:null_node
153	node2 :> node right
154	while (addressof node2:left)<>addressof:null_node
155	node2 :> node2 left
156	else
157	var Pointer:IndexNode cur :> node ; node2 :> node father
158	while addressof:node2<>addressof:null_node and (addressof node2:right)=addressof:cur
159	cur :> node2 ; node2 :> node2 father
160	cursor2 :> node2 data
161
162
163	method index previous cursor -> cursor2
164	arg Index index ; arg Pointer:Arrow cursor cursor2
165	check addressof:cursor<>addressof:null_node
166	var Pointer:IndexNode node :> addressof:cursor map IndexNode
167	var Pointer:IndexNode node2
168	if (addressof node:left)<>addressof:null_node
169	node2 :> node left
170	while (addressof node2:right)<>addressof:null_node
171	node2 :> node2 right
172	else
173	var Pointer:IndexNode cur :> node ; node2 :> node father
174	while addressof:node2<>addressof:null_node and (addressof node2:left)=addressof:cur
175	cur :> node2 ; node2 :> node2 father
176	cursor2 :> node2 data
177
178
179
180	#   searching
181
182
183	method index first sample -> cursor
184	arg Index index ; arg Str sample ; arg Pointer:Arrow cursor
185	var Pointer:IndexNode cur :> index root
186	while addressof:cur<>addressof:null_node
187	var Int c := compare sample cur:key
188	if c=compare_superior
189	cur :> cur right
190	eif c=compare_inferior
191	cur :> cur left
192	else
193	var Pointer:IndexNode son :> cur left
194	while addressof:son<>addressof:null_node
195	if sample=son:key
196	cur :> son ; son :> son left
197	else
198	son :> son right
199	cursor :> cur data
200	return
201	cursor :> cur data
202
203
204	method index next sample cursor -> cursor2
205	arg Index index ; arg Str sample ; arg Pointer:Arrow cursor cursor2
206	check (addressof:cursor map IndexNode):key=sample
207	cursor2 :> index next cursor
208	if (addressof:cursor2 map IndexNode):key<>sample
209	cursor2 :> null_node data
210
211	# search for the first greater or equal
212	method index from sample -> cursor
213	arg Index index ; arg Str sample ; arg Pointer:Arrow cursor
214	var Pointer:IndexNode cur :> index root
215	while addressof:cur<>addressof:null_node
216	var Int c := compare cur:key sample
217	if c=compare_inferior
218	cur :> cur right
219	else
220	var Pointer:IndexNode son :> cur left
221	while addressof:son<>addressof:null_node
222	if ((compare son:key sample) .and. compare_superior+compare_equal)<>0
223	cur :> son ; son :> son left
224	else
225	son :> son right
226	cursor :> cur data
227	return
228	cursor :> null_node data
229
230
231	# search for the first greater
232	method index to sample -> cursor
233	arg Index index ; arg Str sample ; arg Pointer:Arrow cursor
234	var Pointer:IndexNode cur :> index root
235	while addressof:cur<>addressof:null_node
236	var Int c := compare cur:key sample
237	if c=compare_superior
238	cur :> cur left
239	else
240	var Pointer:IndexNode son :> cur right
241	while addressof:son<>addressof:null_node
242	if ((compare son:key sample) .and. compare_inferior+compare_equal)<>0
243	cur :> son ; son :> son right
244	else
245	son :> son left
246	cursor :> cur data
247	cursor :> index next cursor
248	return
249	cursor :> index first
250
251
252
253	#   inserting, moving, removing
254
255
256	method index twist fat cur son -> node
257	arg_rw Index index ; arg_rw IndexNode fat cur son ; arg_C IndexNode node
258	var Pointer:IndexNode grand :> fat father
259	if addressof:cur=(addressof fat:right)
260	if addressof:son=(addressof cur:right)
261	cur father :> grand
262	fat father :> cur
263	if (addressof cur:left)<>addressof:null_node
264	cur:left father :> fat
265	fat right :> cur left
266	cur left :> fat
267	if addressof:grand=addressof:null_node
268	index root :> cur
269	eif (addressof grand:left)=addressof:fat
270	grand left :> cur
271	else
272	grand right :> cur
273	fat adjust_count
274	cur adjust_count
275	node :> cur
276	else
277	son father :> grand
278	cur father :> son
279	fat father :> son
280	if (addressof son:left)<>addressof:null_node
281	son:left father :> fat
282	if (addressof son:right)<>addressof:null_node
283	son:right father :> cur
284	fat right :> son left
285	cur left :> son right
286	son left :> fat
287	son right :> cur
288	if addressof:grand=addressof:null_node
289	index root :> son
290	eif (addressof grand:left)=addressof:fat
291	grand left :> son
292	else
293	grand right :> son
294	fat adjust_count
295	cur adjust_count
296	son adjust_count
297	node :> son
298	else
299	if addressof:son=(addressof cur:left)
300	cur father :> grand
301	fat father :> cur
302	if (addressof cur:right)<>addressof:null_node
303	cur:right father :> fat
304	fat left :> cur right
305	cur right :> fat
306	if addressof:grand=addressof:null_node
307	index root :> cur
308	eif (addressof grand:left)=addressof:fat
309	grand left :> cur
310	else
311	grand right :> cur
312	fat adjust_count
313	cur adjust_count
314	node :> cur
315	else
316	son father :> grand
317	cur father :> son
318	fat father :> son
319	if (addressof son:left)<>addressof:null_node
320	son:left father :> cur
321	if (addressof son:right)<>addressof:null_node
322	son:right father :> fat
323	fat left :> son right
324	cur right :> son left
325	son left :> cur
326	son right :> fat
327	if addressof:grand=addressof:null_node
328	index root :> son
329	eif (addressof grand:left)=addressof:fat
330	grand left :> son
331	else
332	grand right :> son
333	cur adjust_count
334	fat adjust_count
335	son adjust_count
336	node :> son
337
338
339	method index balanceonce -> c
340	arg_rw Index index ; arg CBool c
341	var Pointer:IndexNode fat :> index root
342	if addressof:fat=addressof:null_node
343	return false
344	var CBool balanced := false
345	while true
346	var Pointer:IndexNode cur :> fat biggest_son
347	if addressof:cur=addressof:null_node
348	return balanced
349	if 3*cur:nb>2*fat:nb
350	fat :> index twist fat cur cur:biggest_son ; balanced := true
351	else
352	fat :> cur
353
354
355	method index insert key ahead data -> cursor
356	arg_rw Index index ; arg Str key ; arg CBool ahead ; arg Address data ; arg Pointer:Arrow cursor
357	var Int c ; var Int mode := shunt ahead compare_inferior+compare_equal compare_inferior
358	var Pointer:IndexNode fat :> null_node
359	var Pointer:IndexNode cur :> index root
360	while addressof:cur<>addressof:null_node
361	if addressof:fat<>addressof:null_node and 3*cur:nb>2*fat:nb
362	fat nb -= 1
363	cur :> index twist fat cur cur:biggest_son
364	fat :> cur father
365	else
366	cur nb += 1
367	fat :> cur
368	c := compare key cur:key
369	cur :> shunt (c .and. mode)<>0 cur:left cur:right
370	var Pointer:IndexNode node :> (memory_allocate IndexNode:size addressof:index) map IndexNode
371	IndexNode build_instance addressof:node
372	node key := key ; node data := data
373	node left :> null_node
374	node right :> null_node
375	node father :> fat
376	node nb := 1
377	if addressof:fat=addressof:null_node
378	index root :> node
379	eif (c .and. mode)<>0
380	fat left :> node
381	else
382	fat right :> node
383	cursor :> node data
384	# index balanceonce
385
386	method index insert key data -> cursor
387	arg_rw Index index ; arg Str key ; arg Address data ; arg Pointer:Arrow cursor
388	cursor :> index insert key false data
389
390
391	method index move old new
392	arg_rw Index index ; arg_rw IndexNode old new
393	check addressof:new<>addressof:old
394	var Pointer:IndexNode fat :> old father
395	var Pointer:IndexNode left :> old left
396	var Pointer:IndexNode right :> old right
397	if addressof:fat=addressof:null_node
398	check (addressof index:root)=addressof:old
399	index root :> new
400	eif (addressof fat:left)=addressof:old
401	fat left :> new
402	eif (addressof fat:right)=addressof:old
403	fat right :> new
404	else
405	error "Corrupted node"
406	if addressof:left<>addressof:null_node
407	check (addressof left:father)=addressof:old
408	left father :> new
409	if addressof:right<>addressof:null_node
410	check (addressof right:father)=addressof:old
411	right father :> new
412	new left :> old left
413	new right :> old right
414	new father :> old father
415	new nb := old nb
416
417	method index remove cursor -> cursor2
418	arg_rw Index index ; arg Pointer:Arrow cursor cursor2
419	check addressof:cursor<>addressof:null_node
420	var Pointer:IndexNode node :> addressof:cursor map IndexNode
421	var Pointer:IndexNode next
422	if (addressof node:right)=addressof:null_node
423	next :> node
424	cursor2 :> index next cursor
425	else
426	next :> node right
427	while (addressof next:left)<>addressof:null_node
428	next :> next left
429	cursor2 :> next data
430	var Pointer:IndexNode cur :> next father
431	while addressof:cur<>addressof:null_node
432	cur nb -= 1
433	cur :> cur father
434	var Pointer:IndexNode son :> shunt (addressof next:left)<>addressof:null_node next:left next:right
435	var Pointer:IndexNode fat :> next father
436	if addressof:fat=addressof:null_node
437	check (addressof index:root)=addressof:next
438	index root :> son
439	eif (addressof fat:left)=addressof:next
440	fat left :> son
441	else
442	check (addressof fat:right)=addressof:next
443	fat right :> son
444	if addressof:son<>addressof:null_node
445	son father :> fat
446	if addressof:next<>addressof:node
447	index move node next
448	IndexNode destroy_instance addressof:node
449	memory_free addressof:node
450	index balanceonce
451
452	method index remove label data
453	arg_rw Index index ; arg Str label ; arg Address data
454	var Pointer:Arrow c :> index first label
455	while c<>null
456	if data=null or data=c
457	c :> index remove c
458	if (addressof:c map IndexNode):key<>label
459	return
460	else
461	c :> index next label c
462
463
464	method index balance
465	arg_rw Index index
466	while index:balanceonce
467	void
468
469
470	export Index IndexNode
471	export '. first' '. next' '. last' '. previous' '. from' '. to'
472	export '. insert' '. remove' '. move' '. balance' '. check' '. display_tree'
473
474
475	# method c key -> k
476	#   arg Pointer:Arrow c ; arg_R Str k
477	#   k :> (addressof:c map IndexNode) key
478	#
479	# export '. key'