]> gb7djk.dxcluster.net Git - spider.git/blob - perl/Chain.pm
start PC90 development
[spider.git] / perl / Chain.pm
1 package Chain;
2
3 use strict;
4 use Carp;
5
6 use vars qw($VERSION $BRANCH);
7 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
8 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
9 $main::build += $VERSION;
10 $main::branch += $BRANCH;
11
12 use constant NEXT => 0;
13 use constant PREV => 1;
14 use constant OBJ => 2;
15
16 use vars qw($docheck);
17
18 $docheck = 0;
19                         
20 sub _check
21 {
22         confess("chain broken $_[1]") unless ref $_[0] && $_[0]->isa('Chain') &&
23                 $_[0]->[PREV]->[NEXT] == $_[0] &&
24                         $_[0]->[NEXT]->[PREV] == $_[0];
25         return 1;
26 }
27
28 # set internal checking
29 sub setcheck
30 {
31         $docheck = shift;
32 }
33
34 # constructor                   
35 sub new
36 {
37         my $pkg = shift;
38         my $name = ref $pkg || $pkg;
39
40         my $self = [];
41         push @$self, $self, $self, @_;
42         return bless $self, $name;
43 }
44
45 # Insert before this point of the chain
46 sub ins
47 {
48         my ($p, $ref) = @_;
49         
50         $docheck && _check($p);
51         
52         my $q = ref $ref && $ref->isa('Chain') ? $ref : Chain->new($ref);
53         $q->[PREV] = $p->[PREV];
54         $q->[NEXT] = $p;
55         $p->[PREV]->[NEXT] = $q;
56         $p->[PREV] = $q;
57 }
58
59 # Insert after this point of the chain
60 sub add  
61 {
62         my ($p, $ref) = @_;
63         
64         $docheck && _check($p);
65         
66         $p->[NEXT]->ins($ref);
67 }
68
69 # Delete this item from the chain, returns the NEXT item in the chain
70 sub del
71 {
72         my $p = shift;
73         
74         $docheck && _check($p);
75         
76         my $q = $p->[PREV]->[NEXT] = $p->[NEXT];
77         $p->[NEXT]->[PREV] = $p->[PREV];
78         $p->[NEXT] = $p->[PREV] = undef;
79         return $q;
80 }
81
82 # Is this chain empty?
83 sub isempty
84 {
85         my $p = shift;
86         
87         $docheck && _check($p);
88         
89         return $p->[NEXT] == $p;
90 }
91
92 # return next item or undef if end of chain
93 sub next
94 {
95         my ($base, $p) = @_;
96         
97         $docheck && _check($base);
98         
99         return $base->[NEXT] == $base ? undef : $base->[NEXT] unless $p; 
100         
101         $docheck && _check($p);
102         
103         return $p->[NEXT] != $base ? $p->[NEXT] : undef; 
104 }
105
106 # return previous item or undef if end of chain
107 sub prev
108 {
109         my ($base, $p) = @_;
110         
111         $docheck && _check($base);
112         
113         return $base->[PREV] == $base ? undef : $base->[PREV] unless $p; 
114         
115         $docheck && _check($p);
116         
117         return $p->[PREV] != $base ? $p->[PREV] : undef; 
118 }
119
120 # return (and optionally replace) the object in this chain item
121 sub obj
122 {
123         my ($p, $ref) = @_;
124         $p->[OBJ] = $ref if $ref;
125         return $p->[OBJ];
126 }
127
128 # clear out the chain
129 sub flush
130 {
131         my $base = shift;
132         while (!$base->isempty) {
133                 $base->[NEXT]->del;
134         }
135 }
136
137 # move this item after the 'base' item
138 sub rechain
139 {
140         my ($base, $p) = @_;
141         
142         $docheck && _check($base, "base") && _check($p, "rechained ref");
143         
144         $p->del;
145         $base->add($p);
146 }
147
148 # count the no of items in a chain
149 sub count
150 {
151         my $base = shift;
152         my $count;
153         my $p;
154         
155         ++$count while ($p = $base->next($p));
156         return $count;
157 }
158
159 sub close
160 {
161         my $base = shift;
162         $base->flush;
163         $base->[PREV] = $base->[NEXT] = undef;
164 }
165
166 1;
167 __END__
168 # Below is the stub of documentation for your module. You better edit it!
169
170 =head1 NAME
171
172 Chain - Double linked circular chain handler
173
174 =head1 SYNOPSIS
175
176   use Chain;
177   $base = new Chain [$obj];
178   $p->ins($ref [,$obj]);
179   $p->add($ref [,$obj]);
180   $ref = $p->obj or $p->obj($ref);
181   $q = $base->next($p);
182   $q = $base->prev($p);
183   $base->isempty;                       
184   $q = $p->del;
185   $base->flush;
186   $base->rechain($p);                   
187   $base->count;
188
189   Chain::setcheck(0);
190
191 =head1 DESCRIPTION
192
193 A module to handle those nasty jobs where a perl list simply will
194 not do what is required.
195
196 This module is a transliteration from a C routine I wrote in 1987, which
197 in turn was taken directly from the doubly linked list handling in ICL
198 George 3 originally written in GIN5 circa 1970. 
199
200 The type of list this module manipulates is circularly doubly linked
201 with a base.  This means that you can traverse the list backwards or
202 forwards from any point.  
203
204 The particular quality that makes this sort of list useful is that you
205 can insert and delete items anywhere in the list without having to
206 worry about end effects. 
207
208 The list has a I<base> but it doesn't have any real end!  The I<base> is
209 really just another (invisible) list member that you choose to
210 remember the position of and is the reference point that determines
211 what is an I<end>.
212
213 There is nothing special about a I<base>. You can choose another member 
214 of the list to be a I<base> whenever you like.
215
216 The difference between this module and a normal list is that it allows
217 one to create persistant arbitrary directed graphs reasonably
218 efficiently that are easy to traverse, insert and delete objects. You
219 will never need to use I<splice>, I<grep> or I<map> again (for this
220 sort of thing).
221
222 A particular use of B<Chain> is for connection maps that come and go
223 during the course of execution of your program.
224
225 An artificial example of this is:-
226
227   use Chain;
228
229   my $base = new Chain;
230   $base->ins({call=>'GB7BAA', users => new Chain});
231   $base->ins({call=>'GB7DJK', users => new Chain});
232   $base->ins({call=>'GB7MRS', users => new Chain});
233
234   # order is now GB7BAA, GB7DJK, GB7MRS
235   
236   my $p;
237   while ($p = $base->next($p)) {
238     my $obj = $p->obj;
239     if ($obj->{call} eq 'GB7DJK') {
240       my $ubase = $obj->{users};
241       $ubase->ins( {call => 'G1TLH'} );
242       $ubase->ins( {call => 'G7BRN'} );
243     } elsif ($obj->{call} eq 'GB7MRS') {
244       my $ubase = $obj->{users};
245       $ubase->ins( {call => 'G4BAH'} );
246       $ubase->ins( {call => 'G4PIQ'} );
247     } elsif ($obj->{call} eq 'GB7BAA') {
248       my $ubase = $obj->{users};
249       $ubase->ins( {call => 'G8TIC'} );
250       $ubase->ins( {call => 'M0VHF'} );
251     }
252   }
253
254   # move the one on the end to the beginning (LRU on a stick :-).
255   $base->rechain($base->prev);
256
257   # order is now GB7MRS, GB7BAA, GB7DJK
258
259   # this is exactly equivalent to :
260   my $p = $base->prev;
261   $p->del;
262   $base->add($p);
263
264   # order is now GB7DJK, GB7MRS, GB7BAA
265
266   # disconnect (ie remove) GB7MRS
267   for ($p = 0; $p = $base->next($p); ) {
268     if ($p->obj->{call} eq 'GB7MRS') {
269       $p->del;                     # remove this 'branch' from the tree
270       $p->obj->{users}->flush;     # get rid of all its users
271       last;
272     }
273   }
274  
275   
276     
277 =head1 AUTHOR
278
279 Dirk Koopman <djk@tobit.co.uk>
280
281 =head1 SEE ALSO
282
283 ICL George 3 internals reference manual (a.k.a the source)
284
285 =cut