File: dbf\b_tree_file.adb
1 --::::::::::
2 --btrefile.adb
3 --::::::::::
4 -- Developed by (C) Wasiliy W. Molostoff 1994, 1995.
5 -- Moscow, Russia,
6 -- Voice: 7 (095) 398-23-38
7 -- e-mail: edv@edv.msk.ru
8 -- This is free software; you can freely redistribute it and/or
9 -- modify it without any restrictions. Please report any errors.
10 -- All corrections will be made as soon as possible.
11
12 with unchecked_deallocation,
13 direct_io;
14
15 package body b_tree_file is
16
17 seek_softly: constant boolean := true;
18 comp_softly: constant boolean := true;
19
20 tree_degree: constant positive := degree;
21 node_length: constant positive := 2 * tree_degree;
22
23 --------------------------------------------------------------------------
24
25 subtype node_position is long_integer range 0..long_integer'last;
26
27 --------------------------------------------------------------------------
28
29 type element is
30 record
31 node : node_position := 0;
32 item : item_type;
33 data : data_type;
34 end record;
35
36 type elem_count is new integer range 0..node_length;
37 subtype elem_index is elem_count range 1..elem_count'last;
38
39 --------------------------------------------------------------------------
40
41 type elements is array (elem_index range <>) of element;
42 type elem_sequence is
43 record
44 len: elem_count := 0;
45 seq: elements (1..elem_count'last);
46 end record;
47
48 --------------------------------------------------------------------------
49
50 type elem_location is
51 record
52 node: node_position := 0;
53 slot: elem_index := 1;
54 less: boolean := false;
55 end record;
56
57 --------------------------------------------------------------------------
58
59 type step_array is array (1..node_position'size) of elem_location;
60 type step_sequence is
61 record
62 len: natural := 0;
63 seq: step_array;
64 end record;
65
66 --------------------------------------------------------------------------
67
68 type node_record is
69 record
70 left: node_position := 0;
71 data: elem_sequence;
72 end record;
73
74 --------------------------------------------------------------------------
75
76 type node_access is access node_record;
77 procedure release is new unchecked_deallocation (node_record, node_access);
78
79 --------------------------------------------------------------------------
80
81 package node_io is new direct_io (node_record); use node_io;
82 subtype io_pos is node_io.positive_count;
83
84 --------------------------------------------------------------------------
85
86 type tree_object is
87 record
88 file: node_io.file_type;
89 path: step_sequence;
90 curr: elem_location;
91 node: node_access := null;
92 mode: tree_mode;
93 end record;
94
95 --------------------------------------------------------------------------
96
97 io_mode: constant array (tree_mode) of node_io.file_mode :=
98 (in_tree => node_io.in_file ,
99 inout_tree => node_io.inout_file ,
100 out_tree => node_io.inout_file );
101
102 --------------------------------------------------------------------------
103
104 function length (item: step_sequence) return natural is
105 begin
106 return item.len;
107 end;
108
109 --------------------------------------------------------------------------
110
111 procedure clear (what: in out step_sequence) is
112 begin
113 what.len := 0;
114 end;
115
116 --------------------------------------------------------------------------
117
118 procedure append (tail: in elem_location; to: in out step_sequence) is
119 begin
120 to.len := to.len + 1;
121 to.seq (to.len) := tail;
122 end;
123
124 --------------------------------------------------------------------------
125
126 procedure discard (from: in out step_sequence;
127 tail: out elem_location) is
128 begin
129 tail := from.seq (from.len);
130 from.len := from.len - 1;
131 end;
132
133 --------------------------------------------------------------------------
134
135 function min (a, b: in elem_count) return elem_count is
136 begin
137 if a < b then return a;
138 else return b;
139 end if;
140 end;
141
142 --------------------------------------------------------------------------
143
144 procedure set_length (item: in out elem_sequence; len: in elem_count) is
145 begin
146 item.len := min (len, item.seq'last);
147 end;
148
149 --------------------------------------------------------------------------
150
151 function find_ge (items: in elem_sequence;
152 item: in item_type) return elem_index is
153 left, right, mid: elem_index;
154 begin
155 left := 1;
156 right := items.len;
157 loop
158 exit when left >= right;
159 mid := elem_index'val((elem_index'pos(left) + elem_index'pos(right)) / 2);
160 if not (item < items.seq (mid).item)
161 then
162 left := elem_index'succ (mid);
163 else
164 right := mid;
165 end if;
166 end loop;
167 return left;
168 end;
169
170 --------------------------------------------------------------------------
171
172 function find_le (items: in elem_sequence;
173 item: in item_type) return elem_index is
174 left, right, mid: elem_index;
175 begin
176 left := 1;
177 right := items.len;
178 loop
179 exit when left >= right;
180 mid := elem_index'val((elem_index'pos(left) + elem_index'pos(right)) / 2);
181 if items.seq (mid).item < item
182 then
183 left := elem_index'succ(mid);
184 else
185 right := mid;
186 end if;
187 end loop;
188 return left;
189 end;
190
191 --------------------------------------------------------------------------
192
193 function length (item: elem_sequence) return elem_count is
194 begin
195 return item.len;
196 end;
197
198 --------------------------------------------------------------------------
199
200 procedure append (tail: in elements; to: in out elem_sequence) is
201 len: elem_count;
202 begin
203 if tail'length > 0
204 then
205 len := min(tail'length, to.seq'last - to.len);
206 to.seq (to.len + 1 .. to.len + len) :=
207 tail(tail'first .. tail'first + len - 1);
208 to.len := to.len + len;
209 end if;
210 end;
211
212 --------------------------------------------------------------------------
213
214 procedure append (tail: in element; to: in out elem_sequence) is
215 begin
216 if to.seq'last > to.len then
217 to.len := to.len + 1;
218 to.seq(to.len) := tail;
219 end if;
220 end;
221
222 --------------------------------------------------------------------------
223
224 procedure extend (item: in out elem_sequence;
225 frag: in elem_count;
226 from: in elem_index) is
227
228 begin
229 for n in reverse from..item.len
230 loop
231 item.seq (n + frag) := item.seq (n);
232 end loop;
233 item.len := item.len + frag;
234 end;
235
236 --------------------------------------------------------------------------
237
238 procedure amend (item: in out elem_sequence;
239 frag: in elements;
240 from: in elem_index) is
241 begin
242 item.seq (from..from + frag'length - 1) := frag;
243 end;
244
245 --------------------------------------------------------------------------
246
247 procedure insert (item: in out elem_sequence;
248 frag: in elements;
249 from: in elem_index) is
250
251 begin
252 if frag'length > 0
253 then
254 extend (item, frag'length, from);
255 amend (item, frag, from);
256 end if;
257 end;
258
259 --------------------------------------------------------------------------
260
261 procedure insert (item: in out elem_sequence;
262 frag: in element;
263 from: in elem_index) is
264
265 begin
266 extend (item, 1, from);
267 item.seq (from) := frag;
268 end;
269
270 --------------------------------------------------------------------------
271
272 procedure delete (item: in out elem_sequence;
273 from: in elem_index;
274 num: in elem_index := 1) is
275
276
277 begin
278 for n in from + num..item.len
279 loop
280 item.seq (n - num) := item.seq (n);
281 end loop;
282 item.len := item.len - num;
283 end;
284
285 --------------------------------------------------------------------------
286
287 procedure set (item: in out elem_sequence; value: in elements) is
288 begin
289 item.len := value'length;
290 if item.len > 0
291 then
292 item.seq (1..item.len) := value;
293 end if;
294 end;
295
296 --------------------------------------------------------------------------
297
298 procedure set (item: in out elem_sequence; value: in element) is
299 begin
300 item.seq (1) := value;
301 item.len := 1;
302 end;
303
304 --------------------------------------------------------------------------
305
306 procedure clear (item: in out elem_sequence; from: in elem_index := 1) is
307 begin
308 set_length (item, from - 1);
309 end;
310
311 --------------------------------------------------------------------------
312
313 procedure ensure_status (file: in tree_type) is
314 begin
315 if not is_open (file)
316 then
317 raise status_error;
318 end if;
319 end;
320
321 --------------------------------------------------------------------------
322
323 procedure except_mode (file: in tree_type; mode: tree_mode) is
324 begin
325 if file.mode = mode
326 then
327 raise mode_error;
328 end if;
329 end;
330
331 --------------------------------------------------------------------------
332
333 procedure put_node (file: in tree_type;
334 tonp: in node_position;
335 node: in node_access) is
336 begin
337
338 -- WARNING !!!
339 -- When size(file) = index(file) = tonp
340 -- meridian v4.11 writes data record to tonp + 1,
341 -- reset (file) temporary avoids this strange reaction.
342
343 reset (file.file);
344 write (file.file, node.all, io_pos (tonp));
345 end;
346
347 procedure get_node (file: in tree_type;
348 tonp: in node_position;
349 node: in node_access) is
350 begin
351 read (file.file, node.all, io_pos (tonp));
352 end;
353
354 procedure put_node (file: in tree_type;
355 tonp: in node_position) is
356 begin
357 put_node (file, tonp, file.node);
358 end;
359
360 procedure get_node (file: in tree_type;
361 tonp: in node_position) is
362 begin
363 get_node (file, tonp, file.node);
364 end;
365
366 --------------------------------------------------------------------------
367
368 function is_equal (file: in tree_type; item: item_type) return boolean is
369 curr: elem_location renames file.curr;
370 data: elem_sequence renames file.node.data;
371 begin
372 if comp_softly
373 then
374 return not (data.seq (curr.slot).item < item xor curr.less);
375 else
376 return item = data.seq (curr.slot).item;
377 end if;
378 end;
379
380 --------------------------------------------------------------------------
381
382 procedure seek_root (file: in tree_type) is
383 begin
384 if file.curr.node /= 1
385 then
386 get_node (file, 1);
387 file.curr.node := 1;
388 clear (file.path);
389 end if;
390 end;
391
392 --------------------------------------------------------------------------
393
394 procedure seek_right (file: in tree_type) is
395 next: node_position;
396 curr: elem_location renames file.curr;
397 data: elem_sequence renames file.node.data;
398 begin
399
400 curr.less := false;
401 loop
402
403 curr.slot := data.len;
404 next := data.seq (curr.slot).node;
405
406 exit when next = 0;
407
408 append (curr, file.path);
409 get_node (file, next);
410
411 curr.node := next;
412
413 end loop;
414 end;
415
416 --------------------------------------------------------------------------
417
418 procedure seek_left (file: in tree_type) is
419 next: node_position;
420 curr: elem_location renames file.curr;
421 data: elem_sequence renames file.node.data;
422 begin
423
424 curr.less := true;
425 loop
426
427 curr.slot := 1;
428 next := file.node.left;
429
430 exit when next = 0;
431
432 append (curr, file.path);
433 get_node (file, next);
434
435 curr.node := next;
436
437 end loop;
438 end;
439
440 --------------------------------------------------------------------------
441
442 procedure seek_leaf (file: in tree_type; item: in item_type) is
443 item_inside: boolean;
444 next: node_position;
445 curr: elem_location renames file.curr;
446 begin
447
448 if seek_softly
449 then
450
451 seek_up: loop
452
453 curr.slot := find_le (file.node.data, item);
454 curr.less := item < file.node.data.seq (curr.slot).item;
455
456 if curr.slot = length (file.node.data)
457 then
458 item_inside := curr.less;
459 elsif curr.slot = 1
460 then
461 item_inside := not curr.less;
462 else
463 item_inside := true;
464 end if;
465
466 exit when item_inside;
467 exit when length (file.path) = 0;
468
469 discard (file.path, curr);
470
471 get_node (file, curr.node);
472
473 end loop seek_up;
474
475 else
476 seek_root (file);
477
478 curr.slot := find_le (file.node.data, item);
479 curr.less := item < file.node.data.seq (curr.slot).item;
480
481 end if;
482
483 seek_down: loop
484 if curr.less
485 then
486 if curr.slot = 1
487 then
488 next := file.node.left;
489 else
490 next := file.node.data.seq (curr.slot - 1).node;
491 end if;
492 else
493 next := file.node.data.seq (curr.slot).node;
494 end if;
495
496 exit when next = 0;
497
498 append (curr, file.path);
499
500 get_node (file, next);
501
502 curr.node := next;
503 curr.slot := find_le (file.node.data, item);
504 curr.less := item < file.node.data.seq (curr.slot).item;
505 end loop seek_down;
506
507 end seek_leaf;
508
509 --------------------------------------------------------------------------
510
511 procedure seek_pred (file: in tree_type; okay: in out boolean) is
512
513 curr: elem_location renames file.curr;
514 data: elem_sequence renames file.node.data;
515 next: node_position;
516 last: node_position;
517
518 function next_node (elem: in elem_index) return node_position is
519 begin
520 if elem = 1
521 then
522 return file.node.left;
523 else
524 return data.seq (elem - 1).node;
525 end if;
526 end;
527
528 begin
529 okay := false;
530 if data.len > 0
531 then
532
533 next := next_node (curr.slot);
534
535 if next /= 0
536 then
537
538 curr.less := true;
539
540 append (curr, file.path);
541 get_node (file, next);
542 seek_right (file);
543 okay := true;
544
545 else
546 last := curr.node;
547 loop
548
549 if curr.slot > 1
550 then
551 curr.slot := curr.slot - 1;
552 okay := true;
553 exit;
554 end if;
555
556 exit when length (file.path) = 0;
557
558 discard (file.path, curr);
559
560 if not curr.less
561 then
562 okay := true;
563 exit;
564 end if;
565 end loop;
566
567 if last /= curr.node
568 then
569 get_node (file, curr.node);
570 end if;
571 end if;
572 end if;
573 end seek_pred;
574
575 --------------------------------------------------------------------------
576
577 procedure seek_succ (file: in tree_type; okay: out boolean) is
578
579 curr: elem_location renames file.curr;
580 data: elem_sequence renames file.node.data;
581 next: node_position;
582
583 function next_node (elem: in elem_index) return node_position is
584 begin
585 return data.seq (elem).node;
586 end;
587
588 begin
589 okay := false;
590 if data.len > 0
591 then
592 next := next_node (curr.slot);
593
594 if next /= 0
595 then
596
597 curr.less := false;
598
599 append (curr, file.path);
600 get_node (file, next);
601 seek_left (file);
602 okay := true;
603
604 else
605
606 loop
607
608 if curr.slot < length (data)
609 then
610 curr.slot := curr.slot + 1;
611 okay := true;
612 exit;
613 end if;
614
615 exit when length (file.path) = 0;
616
617 discard (file.path, curr);
618 get_node (file, curr.node);
619
620 if curr.less
621 then
622 okay := true;
623 exit;
624 end if;
625 end loop;
626
627 end if;
628 end if;
629 end seek_succ;
630
631 --------------------------------------------------------------------------
632
633 procedure seek_item (file: in tree_type;
634 item: in item_type;
635 okay: in out boolean) is
636
637 curr: elem_location renames file.curr;
638 data: elem_sequence renames file.node.data;
639
640 begin
641
642 seek_leaf (file, item);
643
644 okay := false;
645
646 if data.len > 0
647 then
648 if is_equal (file, item)
649 then
650 okay := true;
651 else
652 seek_pred (file, okay);
653
654 if okay
655 then
656 curr.less := item < data.seq (curr.slot).item;
657 okay := is_equal (file, item);
658 end if;
659 end if;
660 end if;
661 end seek_item;
662
663 --------------------------------------------------------------------------
664
665 procedure destroy (file: in out tree_type) is
666 procedure release is new unchecked_deallocation (tree_object, tree_type);
667 begin
668 if file /= null
669 then
670 if is_open (file.file)
671 then
672 close (file.file);
673 end if;
674 if file.node /= null
675 then
676 release (file.node);
677 end if;
678 release (file);
679 end if;
680 end;
681
682 --------------------------------------------------------------------------
683
684 procedure create(file : in out tree_type;
685 mode : in tree_mode := inout_tree;
686 name : in string := "";
687 form : in string := "") is
688 begin
689 file := new tree_object;
690 file.node := new node_record;
691
692 file.mode := mode;
693 create (file.file, io_mode (mode), name, form);
694
695 file.node.left := 0;
696
697 clear (file.node.data);
698 clear (file.path);
699
700 file.curr.less := false;
701 file.curr.node := 1;
702 file.curr.slot := 1;
703
704 put_node (file, file.curr.node);
705
706 exception
707 when others => destroy (file);
708 raise;
709 end;
710
711 --------------------------------------------------------------------------
712
713 procedure open(file : in out tree_type;
714 mode : in tree_mode;
715 name : in string := "";
716 form : in string := "") is
717 begin
718 file := new tree_object;
719 file.node := new node_record;
720 file.mode := mode;
721
722 open (file.file, io_mode (mode), name, form);
723 file.curr.node := 0;
724 seek_root(file);
725 exception
726 when others => destroy (file); raise;
727 end;
728
729 --------------------------------------------------------------------------
730
731 procedure close (file : in out tree_type) is
732 begin
733 ensure_status (file);
734 close (file.file);
735 destroy (file);
736 end;
737
738 --------------------------------------------------------------------------
739
740 procedure delete (file : in out tree_type) is
741 begin
742 ensure_status (file);
743 delete (file.file);
744 destroy (file);
745 end;
746
747 --------------------------------------------------------------------------
748
749 function is_open (file : in tree_type) return boolean is
750 begin
751 if file /= null
752 then
753 return is_open (file.file);
754 end if;
755 return false;
756 end;
757
758 --------------------------------------------------------------------------
759
760 function name (file : in tree_type) return string is
761 begin
762 ensure_status (file);
763 return name (file.file);
764 end;
765
766 --------------------------------------------------------------------------
767
768 function form (file : in tree_type) return string is
769 begin
770 ensure_status (file);
771 return form (file.file);
772 end;
773
774 --------------------------------------------------------------------------
775
776 function mode (file : in tree_type) return tree_mode is
777 begin
778 ensure_status (file);
779 return file.mode;
780 end;
781
782 --------------------------------------------------------------------------
783
784 procedure reset (file : in out tree_type) is
785 begin
786 ensure_status (file);
787 reset (file.file);
788 seek_root (file);
789 end;
790
791 --------------------------------------------------------------------------
792
793 procedure reset (file : in out tree_type;
794 mode : in tree_mode) is
795 begin
796 ensure_status (file);
797 reset (file.file, io_mode (mode));
798 seek_root (file);
799 end;
800
801 --------------------------------------------------------------------------
802
803 procedure condalloc (node: in out node_access) is
804 begin
805 if node = null
806 then
807 node := new node_record;
808 end if;
809 end;
810
811 --------------------------------------------------------------------------
812
813 procedure insert (file : in out tree_type;
814 item : in item_type;
815 data : in data_type) is
816
817 upd : boolean := false;
818 temp: node_access := null;
819 npos: node_position;
820 elem: element;
821 left: node_position; -- left node of element
822
823 procedure split_node is
824 begin
825
826 condalloc (temp);
827
828 if file.curr.slot <= elem_count (tree_degree + 1)
829 then
830
831 set (temp.data, file.node.data.seq (elem_count (tree_degree) + 1..
832 elem_count (tree_degree) * 2));
833
834 set_length (file.node.data, elem_count (tree_degree));
835
836 if file.curr.slot <= elem_count (tree_degree)
837 then
838 insert (file.node.data, elem, file.curr.slot);
839 elem := file.node.data.seq (elem_count (tree_degree) + 1);
840 end if;
841 else
842 if file.curr.slot = elem_count (tree_degree) + 2
843 then
844 set (temp.data, elem);
845 append (file.node.data.seq (elem_count (tree_degree) + 2..
846 elem_count (node_length)), temp.data);
847 else
848
849 set (temp.data, file.node.data.seq (elem_count (tree_degree) + 2..
850 elem_count (node_length)));
851
852 if file.curr.slot = elem_count (node_length) and then
853 file.curr.less = false
854 then
855 append (elem, temp.data);
856 else
857 insert (temp.data, elem, file.curr.slot);
858 end if;
859
860 end if;
861 elem := file.node.data.seq (elem_count (tree_degree) + 1);
862 end if;
863 set_length (file.node.data, elem_count (tree_degree));
864
865 temp.left := elem.node;
866
867 npos := node_position (size (file.file) + 1);
868
869 temp.left := elem.node;
870 elem.node := npos;
871
872 put_node (file, npos, temp); -- temp is always right
873
874 end split_node;
875
876 begin
877
878 ensure_status (file);
879 except_mode (file, in_tree);
880
881 elem.item := item;
882 elem.data := data;
883 elem.node := 0;
884
885 if length (file.node.data) < 1
886 then
887 append (elem, file.node.data);
888 else
889
890 seek_leaf (file, item);
891
892 inserting: loop
893
894 if length (file.node.data) < elem_count (node_length)
895 then
896 if file.curr.slot < length (file.node.data)
897 then
898 insert (file.node.data, elem, file.curr.slot);
899 else
900 if file.curr.less
901 then
902 insert (file.node.data, elem, file.curr.slot);
903 else
904 append (elem, file.node.data);
905 end if;
906 end if;
907
908 exit inserting;
909
910 else
911
912 split_node;
913
914 if length (file.path) = 0 -- root node here
915 then
916 -- append old root to file
917 npos := node_position (size (file.file) + 1);
918
919 put_node (file, npos);
920
921 set (file.node.data, elem);
922
923 file.node.left := npos;
924 file.curr.less := false;
925 file.curr.slot := 1;
926
927 exit inserting;
928
929 else
930 put_node (file, file.curr.node);
931 end if;
932
933 discard (file.path, file.curr);
934
935 get_node (file, file.curr.node);
936
937 end if;
938
939 end loop inserting;
940 end if;
941
942 -- update changes of curr node
943 put_node (file, file.curr.node);
944
945 if temp /= null
946 then
947 release (temp);
948 end if;
949
950 exception
951 when others => release (temp);
952 raise;
953 end insert;
954
955 --------------------------------------------------------------------------
956
957 procedure modify (file : in out tree_type;
958 item : in item_type;
959 data : in data_type;
960 ok : out boolean) is
961
962 begin
963
964 ok := false;
965
966 ensure_status (file);
967 except_mode (file, in_tree);
968
969 declare
970 elms: elem_sequence renames file.node.data;
971 curr: elem_location renames file.curr;
972 okay: boolean;
973 begin
974 seek_item (file, item, okay);
975
976 if okay
977 then
978
979 elms.seq (curr.slot).data := data;
980 put_node (file, curr.node);
981
982 ok := true;
983 end if;
984 end;
985 end modify;
986
987 --------------------------------------------------------------------------
988
989 procedure junk (elem: in element;
990 left: in node_access;
991 right: in node_access) is
992 begin
993
994 append (elem, left.data);
995 left.data.seq (left.data.len).node := right.left;
996 append (right.data.seq (1..right.data.len), left.data);
997
998 end;
999
1000 --------------------------------------------------------------------------
1001
1002 procedure balance (elem: in out element;
1003 left: in node_access;
1004 right: in node_access) is
1005
1006 num: elem_count := elem_count (abs (integer(length (left.data)) -
1007 integer(length (right.data))) / 2);
1008
1009 begin
1010
1011 if num >= 1
1012 then
1013 if length (left.data) < length (right.data)
1014 then
1015
1016 append (elem, left.data);
1017 left.data.seq (left.data.len).node := right.left;
1018
1019 append (right.data.seq (1..num - 1), left.data);
1020
1021 declare
1022 last: element renames right.data.seq (num);
1023 begin
1024 right.left := last.node;
1025 elem.data := last.data;
1026 elem.item := last.item;
1027 end;
1028
1029 delete (right.data, 1, num);
1030
1031 else
1032
1033 extend (right.data, num, 1);
1034
1035 right.data.seq (num).data := elem.data;
1036 right.data.seq (num).item := elem.item;
1037 right.data.seq (num).node := right.left;
1038
1039 declare
1040 spos: elem_index := (left.data.len - num + 1);
1041 last: element renames left.data.seq (spos);
1042 begin
1043
1044 amend (right.data, left.data.seq (spos + 1..left.data.len), 1);
1045
1046 right.left := last.node;
1047 elem.data := last.data;
1048 elem.item := last.item;
1049
1050 delete (left.data, spos, num);
1051
1052 end;
1053
1054 end if;
1055 end if;
1056 end;
1057
1058 --------------------------------------------------------------------------
1059
1060 procedure delete (file : in out tree_type;
1061 item : in item_type;
1062 data : out data_type;
1063 ok : out boolean) is
1064
1065 tmpr: node_access := null;
1066 tmpl: node_access := null;
1067
1068 next: node_position;
1069 fore: elem_location;
1070 elem: element;
1071 okay: boolean;
1072
1073 function left (elem: in elem_index) return node_position is
1074 begin
1075 if elem = 1
1076 then
1077 return file.node.left;
1078 else
1079 return file.node.data.seq (elem - 1).node;
1080 end if;
1081 end;
1082
1083 procedure swap (a, b: in out node_access) is
1084 t: node_access;
1085 begin
1086 t := a; a := b; b := t;
1087 end;
1088
1089 begin
1090
1091 ok := false;
1092
1093 ensure_status (file);
1094 except_mode (file, in_tree);
1095 except_mode (file, out_tree);
1096
1097 declare
1098 curr: elem_location renames file.curr;
1099 fino: node_access renames file.node;
1100 begin
1101
1102 seek_item (file, item, okay);
1103
1104 if okay
1105 then
1106
1107 data := fino.data.seq (curr.slot).data;
1108 next := left (curr.slot);
1109
1110 if next /= 0
1111 then
1112
1113 tmpl := fino;
1114 fino := new node_record;
1115
1116 fore := curr;
1117 curr.less := true;
1118
1119 append (curr, file.path);
1120 get_node (file, next, fino);
1121
1122 curr.node := next;
1123
1124 seek_right (file);
1125
1126 tmpl.data.seq (fore.slot).data := fino.data.seq (curr.slot).data;
1127 tmpl.data.seq (fore.slot).item := fino.data.seq (curr.slot).item;
1128
1129 put_node (file, fore.node, tmpl);
1130
1131 end if;
1132
1133 delete (fino.data, curr.slot);
1134
1135 loop
1136
1137 exit when length (file.path) = 0;
1138 exit when length (fino.data) >= elem_count (tree_degree);
1139
1140 condalloc (tmpl);
1141 condalloc (tmpr);
1142
1143 discard (file.path, curr); -- prepare to reading root
1144
1145 -- save old root
1146
1147 if curr.less
1148 then
1149 swap (tmpl, fino);
1150 get_node (file, curr.node, fino);
1151 get_node (file, fino.data.seq (curr.slot).node, tmpr);
1152
1153 else
1154 swap (tmpr, fino);
1155 get_node (file, curr.node , fino);
1156 get_node (file, left (curr.slot), tmpl);
1157
1158 end if;
1159
1160 if integer (length (tmpl.data)) +
1161 integer (length (tmpr.data)) < node_length
1162 then
1163 junk (fino.data.seq (curr.slot), tmpl, tmpr);
1164
1165 next := left (curr.slot);
1166 delete (fino.data, curr.slot);
1167
1168 if length (fino.data) = 0
1169 then
1170 swap (tmpl, fino);
1171 else
1172 put_node (file, next, tmpl);
1173 end if;
1174
1175 else
1176 balance (fino.data.seq (curr.slot), tmpl, tmpr);
1177 put_node (file, fino.data.seq (curr.slot).node, tmpr);
1178 put_node (file, left (curr.slot), tmpl);
1179
1180 end if;
1181
1182 end loop;
1183
1184 put_node (file, curr.node, fino);
1185
1186 ok := true;
1187
1188 release (tmpl);
1189 release (tmpr);
1190
1191 end if;
1192
1193 end;
1194
1195 exception
1196 when others => release (tmpl);
1197 release (tmpr);
1198 raise;
1199 end delete;
1200
1201 --------------------------------------------------------------------------
1202
1203 procedure get_first(file : in tree_type;
1204 item : out item_type;
1205 data : out data_type;
1206 ok : out boolean) is
1207
1208
1209 begin
1210 ok := false;
1211
1212 ensure_status (file);
1213 except_mode (file, out_tree);
1214
1215 declare
1216 elms: elem_sequence renames file.node.data;
1217 curr: elem_location renames file.curr;
1218 begin
1219 if elms.len > 0
1220 then
1221 seek_root (file);
1222 seek_left (file);
1223
1224 item := elms.seq (curr.slot).item;
1225 data := elms.seq (curr.slot).data;
1226
1227 ok := true;
1228 end if;
1229 end;
1230 end get_first;
1231
1232 --------------------------------------------------------------------------
1233
1234 procedure get_last(file : in tree_type;
1235 item : out item_type;
1236 data : out data_type;
1237 ok : out boolean) is
1238
1239 begin
1240 ok := false;
1241
1242 ensure_status (file);
1243 except_mode (file, out_tree);
1244
1245 declare
1246 elms: elem_sequence renames file.node.data;
1247 curr: elem_location renames file.curr;
1248 begin
1249 if elms.len > 0
1250 then
1251 seek_root (file);
1252 seek_right (file);
1253
1254 item := elms.seq (curr.slot).item;
1255 data := elms.seq (curr.slot).data;
1256
1257 ok := true;
1258 end if;
1259 end;
1260 end get_last;
1261
1262 --------------------------------------------------------------------------
1263
1264 procedure get_ge(file : in tree_type;
1265 item : in out item_type;
1266 data : out data_type;
1267 ok : out boolean) is
1268
1269 begin
1270
1271 ok := false;
1272
1273 ensure_status (file);
1274 except_mode (file, out_tree);
1275
1276 declare
1277 elms: elem_sequence renames file.node.data;
1278 curr: elem_location renames file.curr;
1279 elem: element;
1280 okay: boolean := false;
1281 begin
1282
1283 if elms.len > 0
1284 then
1285
1286 seek_leaf (file, item);
1287
1288 if is_equal (file, item)
1289 then
1290 okay := true;
1291 else
1292 if curr.less
1293 then
1294
1295 elem.item := elms.seq (curr.slot).item;
1296 elem.data := elms.seq (curr.slot).data;
1297
1298 seek_pred (file, okay);
1299
1300 if okay
1301 then
1302 curr.less := item < elms.seq (curr.slot).item;
1303 okay := is_equal (file, item);
1304 end if;
1305
1306 if not okay
1307 then
1308 item := elem.item;
1309 data := elem.data;
1310 ok := true;
1311 end if;
1312 else
1313 seek_succ (file, okay);
1314 end if;
1315 end if;
1316
1317 if okay
1318 then
1319 item := elms.seq (curr.slot).item;
1320 data := elms.seq (curr.slot).data;
1321 ok := okay;
1322 end if;
1323
1324 end if;
1325 end;
1326 end get_ge;
1327
1328 --------------------------------------------------------------------------
1329
1330 procedure get_le(file : in tree_type;
1331 item : in out item_type;
1332 data : out data_type;
1333 ok : out boolean) is
1334
1335 begin
1336
1337 ok := false;
1338
1339 ensure_status (file);
1340 except_mode (file, out_tree);
1341
1342 declare
1343 elms: elem_sequence renames file.node.data;
1344 curr: elem_location renames file.curr;
1345 elem: element;
1346 okay: boolean := false;
1347 begin
1348
1349 if elms.len > 0
1350 then
1351 seek_leaf (file, item);
1352
1353 if is_equal (file, item)
1354 then
1355 okay := true;
1356 else
1357 if not curr.less
1358 then
1359
1360 elem.item := elms.seq (curr.slot).item;
1361 elem.data := elms.seq (curr.slot).data;
1362
1363 seek_succ (file, okay);
1364
1365 if okay
1366 then
1367 curr.less := item < elms.seq (curr.slot).item;
1368 okay := is_equal (file, item);
1369 end if;
1370
1371 if not okay
1372 then
1373 item := elem.item;
1374 data := elem.data;
1375 ok := true;
1376 end if;
1377 else
1378 seek_pred (file, okay);
1379 end if;
1380
1381 end if;
1382
1383 if okay
1384 then
1385 item := elms.seq (curr.slot).item;
1386 data := elms.seq (curr.slot).data;
1387 ok := okay;
1388 end if;
1389
1390 end if;
1391 end;
1392
1393 end get_le;
1394
1395 --------------------------------------------------------------------------
1396
1397 procedure get_lt(file : in tree_type;
1398 item : in out item_type;
1399 data : out data_type;
1400 ok : out boolean) is
1401
1402 begin
1403
1404 ok := false;
1405
1406 ensure_status (file);
1407 except_mode (file, out_tree);
1408
1409 declare
1410 elms: elem_sequence renames file.node.data;
1411 curr: elem_location renames file.curr;
1412 elem: element;
1413 okay: boolean := false;
1414 begin
1415
1416 if elms.len > 0
1417 then
1418
1419 seek_leaf (file, item);
1420
1421 if curr.less
1422 then
1423 seek_pred (file, okay);
1424 if okay
1425 then
1426 curr.less := item < elms.seq (curr.slot).item;
1427 end if;
1428 else
1429 okay := true;
1430 end if;
1431
1432 if okay
1433 then
1434 if is_equal (file, item)
1435 then
1436 seek_pred (file, okay);
1437 end if;
1438 end if;
1439
1440 if okay
1441 then
1442 item := elms.seq (curr.slot).item;
1443 data := elms.seq (curr.slot).data;
1444 ok := okay;
1445 end if;
1446
1447 end if;
1448 end;
1449
1450 end get_lt;
1451
1452 --------------------------------------------------------------------------
1453
1454 procedure get_gt(file : in tree_type;
1455 item : in out item_type;
1456 data : out data_type;
1457 ok : out boolean) is
1458
1459 begin
1460
1461 ok := false;
1462
1463 ensure_status (file);
1464 except_mode (file, out_tree);
1465
1466 declare
1467 elms: elem_sequence renames file.node.data;
1468 curr: elem_location renames file.curr;
1469 elem: element;
1470 okay: boolean := false;
1471 begin
1472
1473 if elms.len > 0
1474 then
1475
1476 seek_leaf (file, item);
1477
1478 if not curr.less
1479 then
1480 seek_succ (file, okay);
1481 if okay
1482 then
1483 curr.less := item < elms.seq (curr.slot).item;
1484 end if;
1485 else
1486 okay := true;
1487 end if;
1488
1489 if okay
1490 then
1491 if is_equal (file, item)
1492 then
1493 seek_succ (file, okay);
1494 end if;
1495 end if;
1496
1497 if okay
1498 then
1499 item := elms.seq (curr.slot).item;
1500 data := elms.seq (curr.slot).data;
1501 ok := okay;
1502 end if;
1503
1504 end if;
1505 end;
1506
1507 end get_gt;
1508
1509 begin
1510 if tree_degree < 2
1511 then
1512 raise program_error;
1513 end if;
1514 end b_tree_file;
1515