File: dbf\deque_types.adb
1 --::::::::::
2 --dequtype.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 package body deque_types is
12
13 package body deques is
14
15 dqsgn: array(edge_type) of integer := (-1, 1);
16
17 function valid (i, w : in integer) return positive is
18 begin
19 return ((i + w - 1) mod w) + 1;
20 end valid;
21
22 pragma inline(valid);
23
24 procedure set_target (deque : in out object;
25 target : in edge_type) is
26 begin
27 deque.current.target := target;
28 end set_target;
29
30 procedure set_source (deque : in out object;
31 source : in edge_type) is
32 begin
33 deque.current.source := source;
34 end set_source;
35
36 procedure set_rule (deque : in out object;
37 rule : in edges_rule) is
38 begin
39 deque.current := rule;
40 end set_rule;
41
42 function source (deque : in object) return edge_type is
43 begin
44 return deque.current.source;
45 end source;
46
47 function target (deque : in object) return edge_type is
48 begin
49 return deque.current.target;
50 end target;
51
52 function current (deque : in object) return edges_rule is
53 begin
54 return deque.current;
55 end current;
56
57 procedure reset_rule (deque : in out object) is
58 begin
59 set_rule(deque, (source => default_state.source,
60 target => default_state.target));
61 end reset_rule;
62
63 procedure flip_edges (deque : in out object) is
64 begin
65 set_rule(deque, (source => opposite (source(deque)),
66 target => opposite (target(deque))));
67 end flip_edges;
68
69 procedure discard (deque : in out object;
70 item : out element) is
71 begin
72 discard(deque, item, deque.current.source);
73 end discard;
74
75 procedure append (deque : in out object;
76 item : in element) is
77 begin
78 append(deque, item, deque.current.target);
79 end append;
80
81 procedure discard (deque : in out object;
82 item : out element;
83 source : in edge_type) is
84
85 dqei : integer renames deque.index(source);
86
87 begin
88 if deque.count < 1 then
89 raise deque_underflow;
90 end if;
91 item := deque.data (dqei);
92 dqei := valid(dqei - dqsgn(source), deque.width);
93 deque.count := deque.count - 1;
94 end discard;
95
96 procedure append (deque : in out object;
97 item : in element;
98 target : in edge_type) is
99 dqei : integer renames deque.index(target);
100 begin
101 if deque.count >= deque.width then
102 raise deque_overflow;
103 end if;
104 dqei := valid(dqei + dqsgn(target), deque.width);
105 deque.data (dqei) := item;
106 deque.count := deque.count + 1;
107 end append;
108
109 procedure clear (deque : in out object) is
110 begin
111 deque.count := 0;
112 deque.index := (1, deque.width);
113 end clear;
114
115 function value (deque : in object;
116 source : in edge_type) return element is
117 begin
118 return deque.data (deque.index(source));
119 end value;
120
121 function value (deque : in object) return element is
122 begin
123 return deque.data (deque.index(deque.current.source));
124 end value;
125
126 function length (deque : in object) return natural is
127 begin
128 return deque.count;
129 end length;
130
131 procedure update (deque : in out object;
132 item : in element;
133 target : in edge_type) is
134 begin
135 deque.data (deque.index(target)) := item;
136 end update;
137
138 procedure update (deque : in out object;
139 item : in element) is
140 begin
141 deque.data (deque.index(deque.current.target)) := item;
142 end update;
143
144 package body array_support is
145
146 -- function value (deque: in object) return sequence is
147 -- procedure get (deque : in out object; seq: out sequence);
148 -- function "&" (left: object; right: object) return sequence;
149 -- function "&" (left: sequence ; right: object) return sequence;
150 -- function "&" (left: object; right: sequence ) return sequence;
151 -- procedure set (deque : in out object; seq: in sequence) is
152
153 end array_support;
154
155 end deques;
156
157 end deque_types;
158