1# -*- perl -*-
2
3#
4# $Id: MasterPunkte.pm,v 1.2 1999/04/13 13:38:34 eserte Exp $
5# Author: Slaven Rezic
6#
7# Copyright (C) 1999 Slaven Rezic. All rights reserved.
8# This package is free software; you can redistribute it and/or
9# modify it under the same terms as Perl itself.
10#
11# Mail: eserte@cs.tu-berlin.de
12# WWW:  http://user.cs.tu-berlin.de/~eserte/
13#
14
15# neues Punkt-Format
16# Kommentare/Namen/etc.:
17# * Stra�en
18#   tragen
19#   Vorfahrt
20#   Ampelkategorie (ohne Richtung (?))
21#   Sperrung
22#   Penalty
23#   H�he (ohne Richtung)
24# * locker mit Stra�en verbunden
25#   Label-Name, Label-Orientierung, Label-Anchor
26#   Platz
27#   Obst-Art
28# * Sonstiges
29#   Ort-Name, Ort-Kategorie
30#   S-Bahnhof, VBB-Zone
31#   U-Bahnhof, VBB-Zone
32#   R-Bahnhof, VBB-Zone
33
34# Datenformat:
35#
36# x,y TAB Attribute TAB x1,y1 x2,y2 TAB Attribute<->;Attribute->;Attribute<- TAB ...
37#
38# Format der Attribute:
39#
40# Attributzeichen [ = Kommentar ], Attributzeichen...
41#
42
43use strict;
44
45{
46    package MasterPunkt;
47
48    use constant Hoehe               => 'h';
49    use constant Vorfahrt            => 'v';
50
51    use constant Sperrung            => 'x';
52    use constant Tragen              => 't';
53    use constant Penalty             => 'p';
54
55    use constant Ampel               => 'X';
56    use constant Fussgaengerampel    => 'F';
57    use constant Bahnuebergang       => 'B';
58
59    use constant Fragezeichen        => '?';
60
61    sub new {
62	my($class, $coord) = @_;
63	my $self = {};
64	$self->{Coord} = $coord;
65	bless $self, $class;
66    }
67
68    sub parse {
69	my($class, $str) = @_;
70	my($p, $glob, $rest) = split(/\t/, $str, 3);
71	my $o = $class->new($p);
72	my(%r) = _parse_attributes($glob);
73	if (keys %r) {
74	    $o->{Global} = \%r;
75	}
76
77	while(1) {
78	    if (defined $rest and $rest =~ /^(\S+)\s(\S+)\t([^\t]*)(.*)$/) {
79		my($c1, $c2, $attr) = ($1, $2, $3);
80		$rest = $4; $rest =~ s/^\t//;
81		my($both, $forth, $back) = split(/;/, $attr);
82		if ($both ne '') {
83		    my(%r) = _parse_attributes($both);
84		    $o->{Line}{$c1}{$c2} = \%r;
85		}
86		if ($forth ne '') {
87		    my(%r) = _parse_attributes($forth);
88		    $o->{Vector}{$c1}{$c2} = \%r;
89		}
90		if ($back ne '') {
91		    my(%r) = _parse_attributes($back);
92		    $o->{Vector}{$c2}{$c1} = \%r;
93		}
94	    } else {
95		last;
96	    }
97	}
98
99	$o;
100    }
101
102    sub _parse_attribute {
103	my $str = shift;
104	my($k,$v) = split(/=/, $str, 2);
105	if (!defined $v) { $v = "1" }
106	($k,$v);
107    }
108
109    sub _parse_attributes {
110	my $str = shift;
111	my(@a) = split(/,/, $str);
112	my %r;
113	foreach (@a) {
114	    my($k,$v) = _parse_attribute($_);
115	    $r{$k} = $v;
116	}
117	%r;
118    }
119
120
121
122    sub set_global {
123	my($self, %args) = @_;
124	while(my($k, $v) = each %args) {
125	    $self->{Global}{$k} = $v;
126	}
127    }
128
129    sub set_line {
130	my($self, $coord1, $coord2, %args) = @_;
131	if (exists $self->{Line}{$coord2}{$coord1}) {
132	    ($coord1, $coord2) = ($coord2, $coord1);
133	}
134	while(my($k, $v) = each %args) {
135	    $self->{Line}{$coord1}{$coord2}{$k} = $v;
136	}
137    }
138
139    sub set_vector {
140	my($self, $coord1, $coord2, %args) = @_;
141	while(my($k, $v) = each %args) {
142	    $self->{Vector}{$coord1}{$coord2}{$k} = $v;
143	}
144    }
145
146    # Alle benachbarten Punkte feststellen
147    sub get_neighbours {
148	my $self = shift;
149	my @add_coords;
150	my %add_coords;
151	foreach my $type (qw(Line Vector)) {
152	    foreach my $c1 (keys %{ $self->{$type} }) {
153		foreach my $c2 (keys %{ $self->{$type}{$c1} }) {
154		    if (!exists $add_coords{"$c1,$c2"} &&
155			!exists $add_coords{"$c2,$c1"}) {
156			push @add_coords, [$c1, $c2];
157			$add_coords{"$c1,$c2"}++;
158		    }
159		}
160	    }
161	}
162	@add_coords;
163    }
164
165    # Gibt die String-Repr�sentation f�r das Abspeichern in der
166    # Datenbank zur�ck. Wenn keine Attribute gesetzt sind,
167    # wird ein leerer String zur�ckgegeben.
168    sub as_string {
169	my $self = shift;
170	my $ret = $self->{Coord} . "\t";
171	my @attr;
172	my $has_global = 0;
173	while(my($k, $v) = each %{ $self->{Global} }) {
174	    push @attr, _attribute($k, $v);
175	    $has_global++;
176	}
177	$ret .= join(",", @attr);
178
179	my(@add_coords) = $self->get_neighbours;
180	my(@add_coords_attr);
181	foreach my $def (@add_coords) {
182	    my($c1, $c2) = @$def;
183	    my(@both, @forth, @back);
184
185	    # hin und zur�ck
186	    my %h = (exists $self->{Line}{$c1}{$c2}
187		     ? %{ $self->{Line}{$c1}{$c2} }
188		     : (exists $self->{Line}{$c1}{$c2}
189			? %{ $self->{Line}{$c2}{$c1} }
190			: ()));
191	    while(my($k, $v) = each %h) {
192		push @both, _attribute($k, $v);
193	    }
194
195	    # hin
196	    if (exists $self->{Vector}{$c1}{$c2}) {
197		while(my($k, $v) = each %{ $self->{Vector}{$c1}{$c2} }) {
198		    push @forth, _attribute($k, $v);
199		}
200	    }
201
202	    # zur�ck
203	    if (exists $self->{Vector}{$c2}{$c1}) {
204		while(my($k, $v) = each %{ $self->{Vector}{$c2}{$c1} }) {
205		    push @back, _attribute($k, $v);
206		}
207	    }
208
209	    if (@both || @forth || @back) {
210		push @add_coords_attr, "$c1 $c2\t" . join(";",
211							  join(",", @both),
212							  join(",", @forth),
213							  join(",", @back));
214	    }
215	}
216	if (@add_coords_attr) {
217	    $ret .= "\t" . join("\t", @add_coords_attr);
218	}
219	if (!@add_coords_attr && !$has_global) {
220	    "";
221	} else {
222	    $ret;
223	}
224    }
225
226    sub _remove_special {
227	my $str = shift;
228	$str =~ s/=;,\t//g;
229	$str;
230    }
231
232    sub _attribute {
233	my($k, $v) = @_;
234	if ($v eq "1") {
235	    $k;
236	} else {
237	    $k . "=" . _remove_special($v);
238	}
239    }
240
241=head2 selfcheck
242
243�berpr�ft den Konstantenteil auf Konflikte. Aufruf:
244
245   perl5.00502 -MMasterPunkte -e 'MasterPunkt::selfcheck()'
246
247=cut
248
249    sub selfcheck {
250	open(M, "MasterPunkte.pm") or die;
251	my $found_pkg;
252	my %used;
253	while(<M>) {
254	    if ($found_pkg && /use\s+constant\s+(\S+).*'(.)'/) {
255		if (exists $used{$2}) {
256		    warn "$2 wird bereits von $1 verwendet!";
257		} else {
258		    $used{$2} = $1;
259		}
260	    } elsif ($found_pkg && /package\s+/) {
261		last;
262	    } elsif (/package\s+MasterPunkt/) {
263		$found_pkg = 1;
264	    }
265	}
266	close M;
267	warn "Done.\n";
268    }
269}
270
271package MasterPunkte;
272
273use DB_File;
274use vars qw(@datadirs $VERBOSE); # XXX $OLD_AGREP
275
276@datadirs = ("$FindBin::RealBin/data", './data');
277foreach (@INC) {
278    push @datadirs, "$_/data";
279}
280
281sub new {
282    my($class, $filename, %arg) = @_;
283    my @filenames;
284    if (defined $filename) {
285	push @filenames, $filename, map { "$_/$filename" } @datadirs;
286    }
287    my $self = {};
288    bless $self, $class;
289
290    if (@filenames) {
291      TRY: {
292	    foreach my $file (@filenames) {
293		if (-f $file and -r _) {
294		    my @a;
295		    my $db =
296		      tie @a, 'DB_File', $file, O_RDWR, 0644, $DB_RECNO;
297		    if ($db) {
298			$self->{DB} = $db;
299			last TRY;
300		    }
301		}
302	    }
303	    die "Can't open ", join(", ", @filenames);
304	}
305    }
306
307    $self->{Pos} = 0;
308
309    $self;
310}
311
312# initialisiert f�r next() und gibt *keinen* Wert zur�ck
313sub init {
314    my $self = shift;
315    $self->{Pos} = 0;
316}
317
318sub getpoint {
319    my($self, $pos) = @_;
320    while ($pos < $self->{DB}->length) {
321	my $line;
322	$self->{DB}->get($pos, $line);
323	if ($line !~ /^\s*($|\#)/) {
324	    my $o = parse MasterPunkt $line;
325	    return ($o, ++$pos);
326	} else {
327	    $pos++;
328	}
329    }
330    undef;
331}
332
333sub nextpoint {
334    my $self = shift;
335    my($o, $pos) = $self->getpoint($self->{Pos});
336    if (defined $pos) {
337	$self->{Pos} = $pos;
338    }
339    $o;
340}
341
342sub read {
343    my $self = shift;
344    undef $self->{Data};
345    $self->init;
346    my $pos = 0;
347    while(1) {
348	my $o = $self->nextpoint;
349	last if !$o;
350	$self->{Data}{$o->{Coord}} = $o;
351	$o->{Pos} = $pos;
352	$pos++;
353    }
354}
355
356# read() mu� vorher aufgerufen worden sein.
357sub get_point {
358    my($self, $coord) = @_;
359    $self->{Data}{$coord};
360}
361
362# read() mu� vorher aufgerufen worden sein.
363# $o: das abzuspeichernde MasterPunkt-Objekt
364# $pos: Die Position in der Datenbank. Wenn nicht angegeben, wird die
365#       alte Position $o->{Pos} verwendet. Wenn diese auch nicht existiert,
366#       wird das Objekt ans Ende geschrieben.
367# $nosync: Verhindert ein flush, damit gro�e Datenmengen schnell geschrieben
368#          werden k�nnen. Siehe flush-Methode.
369sub set_point {
370    my($self, $o, $pos, $nosync) = @_;
371    $pos = $o->{Pos} unless defined $pos;
372    $pos = $self->{DB}->length unless defined $pos;
373    $self->{DB}->put($pos, $o->as_string);
374    $o->{Pos} = $pos;
375    $self->{Data}{$o->{Coord}} = $o;
376    $self->{DB}->sync unless $nosync;
377}
378
379sub flush {
380    shift->{DB}->sync;
381}
382
383return 1 if caller();
384
385{
386    package main;
387    no strict;
388    $p = new MasterPunkte "/tmp/test";
389    $p->read;
390use Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->Dumpxs([$p],[]); # XXX
391
392}
393