1# -*- perl -*-
2
3#
4# $Id: Ampelschaltung.pm,v 1.10 2005/12/10 23:23:23 eserte Exp $
5# Author: Slaven Rezic
6#
7# Copyright (C) 1998 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
15use strict;
16
17package AmpelschaltungCommon;
18
19sub time2s {
20    my($t1,%args) = @_;
21    return if $t1 eq '';
22
23    my($h1,$m1,$s1);
24    if ($t1 =~ /^\+(\d+):(\d+)\??$/) {
25	my($rel_m,$rel_s) = ($1, $2);
26	if (!$args{-relstart}) {
27	    die "Relative time found, but no -relstart given!";
28	}
29	($h1,$m1,$s1) = @{ $args{-relstart} };
30	$s1+=$rel_s;
31	if ($rel_s >= 60) {
32	    $rel_s -= 60;
33	    $m1++;
34	}
35	$m1+=$rel_m;
36	if ($rel_m >= 60) {
37	    $rel_m -= 60;
38	    $h1++;
39	}
40	if ($h1 >= 24) {
41	    $h1 -= 24;
42	}
43    } else {
44	($h1,$m1,$s1) = split(/:/, $t1);
45    }
46    $s1 =~ s/\D//g; # Fragezeichen etc. am Ende streichen
47    $h1*60*60+$m1*60+$s1;
48}
49
50sub s2time {
51    my($s) = @_;
52    my $h = int($s / (60*60));
53    $s -= $h*(60*60);
54    my $m = int($s / 60);
55    $s -= $m*60;
56    ($h, $m, $s);
57}
58
59package Ampelschaltung::Point;
60
61sub new {
62    my($class, $root, %args) = @_;
63    my $self = \%args;
64    $self->{Root} = $root;
65    bless $self, $class;
66}
67
68# Constructor. Erzeugt aus einer Zeile aus der Datenbanl ein Point-Objekt mit
69# den darunterliegenden Entries. Root ist *nicht* gesetzt, wenn
70# $args{Root} leer ist.
71sub create {
72    my($class, $string, %args) = @_;
73    my($p1, $kreuzung, @schaltung) = split(/\t/);
74    my $root = $args{Root};
75    if (!defined $kreuzung || $kreuzung eq '') {
76	if ($root and
77	    scalar keys %{ $root->{Crossing} } and
78	    exists $root->{Crossing}{$p1}) {
79	    $kreuzung = join("/", @{ $root->{Crossing}{$p1} });
80	} else {
81	    $kreuzung = '???';
82	}
83    }
84    my $ap = Ampelschaltung::Point->new($root,
85					Point    => $p1,
86					Crossing => $kreuzung);
87    foreach (@schaltung) {
88	my(@l) = split /,/;
89	$ap->add_entry
90	  (Ampelschaltung::Entry->new
91	   ($ap,
92	    Day     => $l[0], # Wochentag
93	    Time    => $l[1], # Uhrzeit
94	    DirFrom => $l[2],
95	    DirTo   => $l[3],
96	    Green   => $l[4],
97	    Red     => $l[5],
98	    Cycle   => $l[6],
99	    Comment => $l[7],
100	    Date    => $l[8],
101	   ));
102    }
103    $ap;
104}
105
106sub as_string {
107    my $self = shift;
108    join("\t", @{$self}{qw(Point Crossing)},
109	 map { $_->as_string } $self->entries);
110}
111
112sub add_entry {
113    my($self, $entry) = @_;
114    push @{ $self->{Entries} }, $entry;
115}
116
117sub del_entry {
118    my($self, $entry_index) = @_;
119    splice @{ $self->{Entries} }, $entry_index, 1;
120    undef $self->root->{SavedUntil};
121}
122
123sub root { $_[0]->{Root} }
124
125sub entries { ref $_[0]->{Entries} eq 'ARRAY' ?  @{ $_[0]->{Entries} } : () }
126
127sub entries_by_dir {
128    my($self, $from, $to) = @_;
129    # Ampelschaltung verwendet deutsche Himmelsrichtungen
130    $from =~ s/e/o/g;
131    $to   =~ s/e/o/g;
132    my @res;
133    foreach my $e ($self->entries) {
134	if ($e->{DirFrom} eq $from &&
135	    $e->{DirTo}   eq $to) {
136	    push @res, $e;
137	}
138    }
139    @res;
140}
141
142package Ampelschaltung::Entry;
143
144sub new {
145    my($class, $root, %args) = @_;
146    my $self = \%args;
147    $self->{Root} = $root;
148    bless $self, $class;
149}
150
151sub as_string {
152    my $self = shift;
153    local $^W = undef;
154    join(",", @{$self}{qw(Day Time DirFrom DirTo Green Red Cycle Comment Date)});
155}
156
157sub get_cycle {
158    my $self = shift;
159    if (defined $self->{Cycle} and $self->{Cycle} ne '') {
160	$self->{Cycle};
161    } elsif (defined $self->{Green} and $self->{Green} =~ /^\d/ and
162	     defined $self->{Red}   and $self->{Red} =~ /^\d/) {
163	(my $g = $self->{Green}) =~ s/\D//g;
164	(my $r = $self->{Red})   =~ s/\D//g;
165	$g + $r;
166    }
167}
168
169sub update_cycle {
170    my $self = shift;
171    my $cycle = $self->get_cycle;
172    $self->{Cycle} = $cycle;
173}
174
175sub lost {
176    my($self, %args) = @_;
177    Ampelschaltung::lost(-gruen => $self->{Green},
178			 -rot   => $self->{Red},
179			 %args);
180}
181
182sub root { $_[0]->{Root} }
183
184sub add_epoch_times {
185    my $self = shift;
186    require Time::Local;
187    if (my($d,$m,$y) = $self->{Date} =~ m{(\d{1,2})\.(\d{1,2})\.(\d{4})}) {
188	for my $key (qw(Time GreenTime RedTime)) {
189	    if (my($H,$M,$S) = ($self->{$key}||'') =~ m{(\d{1,2}):(\d{2}):(\d{2})}) {
190		my $epoch = Time::Local::timelocal($S,$M,$H,$d,$m-1,$y);
191		$self->{$key.'Epoch'} = $epoch;
192	    }
193	}
194    } else {
195	die "Cannot parse date out of " . $self->as_string;
196    }
197}
198
199######################################################################
200
201package Ampelschaltung;
202use Strassen;
203use BBBikeUtil qw(sqr);
204use vars qw($warn);
205$warn = 1;
206
207use vars qw(@ISA);
208@ISA = qw(AmpelschaltungCommon);
209
210sub new {
211    my($class, %args) = @_;
212    my $self = \%args;
213    bless $self, $class;
214}
215
216sub open {
217    my $self = shift;
218    my $basefile = shift || "ampelschaltung-orig";
219    my(%args) = @_;
220    require MyFile;
221    my $file = MyFile::openlist(*RW, map { "$_/$basefile" }
222				@Strassen::datadirs, @INC);
223    my $r = 0;
224    if ($file) {
225	$self->{File}             = $file;
226	@{ $self->{Data} }        = (); # Ampelschaltung::Point-Objekte
227	%{ $self->{Point2Index} } = (); # "x,y"-Koordinaten => Index auf Data
228	while(<RW>) {
229	    chomp;
230	    $self->add_point($_);
231	}
232	close RW;
233	if (!-w $file and $self->{Top}) {
234	    require Tk::Dialog;
235	    $self->{Top}->Dialog
236	      (-title => 'Warnung',
237	       -text => "Achtung: auf die Datei $file kann nicht geschrieben werden.",
238	       -buttons => ['OK'])->Show;
239	}
240	$r = 1;
241    }
242
243    if ($args{UpdateCycle}) {
244	# update cycle times...
245	foreach (@{ $self->{Data} }) {
246	    foreach my $e ($_->entries) {
247		$e->update_cycle;
248	    }
249	}
250    }
251
252    $r;
253}
254
255sub save {
256    my $self = shift;
257    if ($self->{File}) {
258	CORE::open(RW, ">$self->{File}") or die "Can't save $self->{File}: $!";
259	print RW join("\n", map { $_->as_string } @{ $self->{Data} }), "\n";
260	close RW;
261    }
262}
263
264sub dump {
265    my $self = shift;
266    require Data::Dumper;
267    Data::Dumper::Dumper($self->{Data});
268}
269
270# XXX
271# sub save_new {
272#     my $self = shift;
273#     if (!defined $self->{SavedUntil}) {
274# 	$self->save;
275#     } elsif ($self->{File}) {
276# 	open(RW, ">>$self->{File}") or die "Can't append to $self->{File}: $!";
277# 	print RW join("\n", map { $_->as_string } @{ $self->{Data} }), "\n";
278# 	close RW;
279#     }
280#     $self->{SavedUntil} = $#{ $self->{Data} };
281# }
282
283sub add_point {
284    my($self, $line) = @_;
285    my $ap = create Ampelschaltung::Point $line, Root => $self;
286    my $p1 = $ap->{Point};
287    push @{ $self->{Data} }, $ap;
288    if (exists $self->{Point2Index}{$p1}) {
289	warn "Die Ampelschaltung f�r $p1 existiert bereits!";
290    }
291    $self->{Point2Index}{$p1} = $#{ $self->{Data} };
292    return $#{ $self->{Data} };
293}
294
295sub find_point {
296    my($self, $point) = @_;
297    if (exists $self->{Point2Index}{$point}) {
298	$self->{Data}[$self->{Point2Index}{$point}];
299    } else {
300	undef;
301    }
302}
303
304# verlorene Zeit und Strecke
305sub lost {
306    my(%args) = @_;
307
308    my $gruen = $args{-gruen}; # in Sekunden
309    my $rot   = $args{-rot};
310    return if !defined $gruen or !defined $rot;
311
312    $gruen =~ s/^(\d+).*/$1/;
313    $rot   =~ s/^(\d+).*/$1/;
314    return if $gruen eq '' or $rot eq '';
315
316    my $kmh   = (exists $args{-geschwindigkeit}
317		 ? $args{-geschwindigkeit} : 20); # in km/h
318    # Beschleunigung in m/s�
319    my $a     = exists $args{-beschleunigung} ? $args{-beschleunigung} : 1;
320
321    my($rot_ver, $ms);
322
323    if (defined $kmh and $a) {
324	$ms = $kmh/3.6;
325	# Zeit, die f�r die Beschleunigung auf $ms ben�tigt wird:
326	my $t = $ms/$a;
327	# bei einer linearen Bewegung k�nnte man so weit kommen:
328	my $s_lin = $t*$ms;
329	# beschleunigt schafft man aber nur so viel:
330	my $s_bes = $ms*$ms/(2*$a);
331	# verlorene Zeit:
332	my $t_ver = ($s_lin-$s_bes)/$ms;
333	# auf die Rotphasenzeit aufschlagen:
334	$rot_ver = $rot + $t_ver;
335    } else {
336	$rot_ver = $rot; # ignorieren
337    }
338
339    my %res;
340    if ($gruen+$rot > 0) {
341	$res{-zeit} = (($rot_ver*($rot_ver+1))/2)/($gruen+$rot);
342	if (defined $kmh) {
343	    $res{-strecke} = $ms*$res{-zeit};
344	}
345    }
346    %res;
347
348}
349
350use vars qw($lost);
351$lost->{10}{0.5} = [17.10, 47.51];
352$lost->{15}{0.5} = [18.10, 75.43];
353$lost->{20}{0.5} = [19.13, 106.28];
354$lost->{25}{0.5} = [20.19, 140.21];
355$lost->{30}{0.5} = [21.28, 177.32];
356$lost->{10}{1} = [16.14, 44.82];
357$lost->{15}{1} = [16.62, 69.23];
358$lost->{20}{1} = [17.10, 95.02];
359$lost->{25}{1} = [17.60, 122.22];
360$lost->{30}{1} = [18.10, 150.85];
361$lost->{10}{1.5} = [15.82, 43.94];
362$lost->{15}{1.5} = [16.14, 67.23];
363$lost->{20}{1.5} = [16.45, 91.42];
364$lost->{25}{1.5} = [16.78, 116.51];
365$lost->{30}{1.5} = [17.10, 142.53];
366$lost->{10}{2} = [15.66, 43.51];
367$lost->{15}{2} = [15.90, 66.24];
368$lost->{20}{2} = [16.14, 89.64];
369$lost->{25}{2} = [16.37, 113.71];
370$lost->{30}{2} = [16.62, 138.47];
371
372sub get_lost {
373    my($speed, $a) = @_;
374    my %res;
375
376    # force numeric
377    $speed = $speed + 0;
378    $a = $a + 0;
379
380    # XXX bessere N�herung
381    if ($a < 0.7)    { $a = 0.5 }
382    elsif ($a < 1.2) { $a = 1 }
383    elsif ($a < 1.7) { $a = 1.5 }
384    else             { $a = 2 }
385    if ($speed < 10) { $speed = 10 }
386    elsif ($speed > 30) { $speed = 30 }
387
388    if (int($speed) != $speed or $speed % 5 != 0) {
389	my $lower = int($speed/5)*5;
390	my $upper = $lower+5;
391	my $arr1 = $lost->{$lower}{$a};
392	my $arr2 = $lost->{$upper}{$a};
393	die "Problem with $speed and $a " if (ref $arr1 ne 'ARRAY' or
394					      ref $arr2 ne 'ARRAY');
395	$res{-zeit} = ($arr2->[0]-$arr1->[0])*($speed-$lower)/5 + $arr1->[0];
396	$res{-strecke} = ($arr2->[1]-$arr1->[1])*($speed-$lower)/5 + $arr1->[1];
397
398    } else {
399	my $arr = $lost->{$speed}{$a};
400	die "Problem with speed=$speed and a=$a " if (ref $arr ne 'ARRAY');
401	$res{-zeit} = $arr->[0];
402	$res{-strecke} = $arr->[1];
403    }
404    %res;
405}
406
407# verlorene Zeiten, Strecken bei beschleunigten Vorg�ngen
408# %args:
409#   abbremsung:     Abbremsung in m/s^2 (ben�tigt)
410#   beschleunigung: Beschleunigung in m/s^2 /ben�tigt)
411#   beschleunigung_P: Beschleunigungs-Leistung in W, kann anstelle von
412#                     beschleunigung angegeben werden
413#   speed_reise:    Reisegeschwindigkeit in km/h
414#   speed_reduced:  Geschwindigkeit nach Abbremsung in km/h
415#   wartezeit:      zus�tzliche Wartezeit in s (nur bei speed_reduced=0
416#                   sinnvoll)
417#   length_reduced: L�nge der Strecke, die mit der reduzierten Geschwindigkeit
418#                   befahren wird (in m)
419#   gesamtmasse:    Gesamtmasse von Rad und Fahrer, nur f�r Energie- und
420#                   Leistungsberechnung notwendig (in kg)
421# R�ckgabe:
422#   linear:         zur�ckgelegte Strecke ohne Verluste und Wartezeit
423#   beschl:         zur�ckgelegte Strecke mit Verlusten und Wartezeit
424#   s:              verlorene Strecke in m
425#   t:              verlorene Zeit in s
426#   t_beschl:       Zeit f�r die Beschleunigung in s
427#   W:              aufgewendete Energie f�r Beschleunigung in J
428#   P:              aufgewendete Leistung f�r Beschleunigung in W
429sub acc_lost {
430    my(%args) = @_;
431    return if ($args{'abbremsung'} == 0 ||
432	       ($args{'beschleunigung'} == 0 and
433		$args{'beschleunigung_P'} == 0));
434
435    my $speed_reise_ms   = $args{'speed_reise'} / 3.6;
436    my $speed_reduced_ms = $args{'speed_reduced'} / 3.6;
437    my $wartezeit        = $args{'wartezeit'} || 0;
438    my $gesamtmasse      = $args{'gesamtmasse'} || 0;
439
440    # kinetische Energie f�r speed_reduced und speed_reise
441    my $W_reduced = 0.5*$gesamtmasse*sqr($speed_reduced_ms);
442    my $W_reise   = 0.5*$gesamtmasse*sqr($speed_reise_ms);
443    my $W         = $W_reise - $W_reduced;
444
445    # Zeit, die f�r das Abbremsen auf reduced ben�tigt wird
446    my $t_abbrems = ($speed_reduced_ms-$speed_reise_ms)
447                    /-$args{'abbremsung'};
448
449    # Zeit, die f�r die Beschleunigung auf reise ben�tigt wird
450    my $t_beschl;
451    if ($args{'beschleunigung_P'}) {
452	$t_beschl  = $W/$args{'beschleunigung_P'};
453    } else {
454	$t_beschl  = ($speed_reise_ms-$speed_reduced_ms)
455                     /$args{'beschleunigung'};
456    }
457
458    # bei einer linearen Bewegung k�nnte man so weit kommen
459    my $s_lin = ($t_abbrems+$t_beschl+$wartezeit)*$speed_reise_ms;
460
461    # beschleunigt schafft man aber nur so viel
462    my $s_bes_a = sqr($speed_reise_ms-$speed_reduced_ms)
463                  /(2*$args{'abbremsung'});
464    my $s_bes_b = sqr($speed_reise_ms-$speed_reduced_ms)
465                  /(2*$args{'beschleunigung'});
466    my $s_bes   = $s_bes_a + $s_bes_b;
467
468    # verlorene Zeit
469    #my $t_ver_a = ($s_lin-$s_bes_a)/$speed_reise_ms;
470    #my $t_ver_b = ($s_lin-$s_bes_b)/$speed_reise_ms;
471    my $t_ver   = ($s_lin-$s_bes)/$speed_reise_ms;
472
473    # Die Langsamfahrstrecke fordert auch ihren Tribut:
474    if ($speed_reise_ms != $speed_reduced_ms and
475	$speed_reise_ms and $speed_reduced_ms) {
476	my $t_ver_red = $args{'length_reduced'}/$speed_reduced_ms
477	              - $args{'length_reduced'}/$speed_reise_ms;
478	$t_ver += $t_ver_red;
479	# XXX t_ver_a/b ung�ltig?
480    }
481
482    # Soviel mu� daf�r geleistet werden:
483    my $P = ($t_beschl ? $W/$t_beschl : 0);
484
485    my %res =
486      (
487       'linear'	   => $s_lin,
488       'beschl'	   => $s_bes,
489       's'	   => $s_lin - $s_bes,
490       't'	   => $t_ver,
491       't_beschl'  => $t_beschl,
492       #'t_brems'   => $t_ver_a,
493       'W'	   => $W,
494       'P'	   => $P,
495      );
496    %res;
497}
498
499# Verkehrszeiten
500# Argumente:
501#   wochentag: "mo", "di" ...
502#   zeit: "hh:mm"
503# Ausgabe: "berufsverkehr", "tagesverkehr", "nachtverkehr", undef
504#
505# Ich definiere die Verkehrszeiten wie folgt:
506# Berufsverkehr: Mo-Fr, 7-9 Uhr und 16-19 Uhr
507# Nachtverkehr: von 22-7h
508# Tagesverkehr: sonstige Zeiten
509#
510# Nach dem Skript "Verkehrsplanungstheorie" S.23 von Prof. Kutter
511# existieren Verkehrsleistungsspitzen (�ber 100000 Kfz/h) in Berlin
512# in den Morgenstunden um 8 Uhr und nachmittags von 16 bis einschlie�lich
513# 19 Uhr.
514#
515sub verkehrszeit {
516    my($wochentag, $zeit) = @_;
517    return if !defined $wochentag or !defined $zeit;
518    my($h,$m) = split(/:/, $zeit);
519    return if !defined $h;
520    if ($h < 7 || $h >= 22) {
521	return "nachtverkehr";
522    }
523    if ($wochentag eq 'sa' || $wochentag eq 'so') {
524	return "tagesverkehr";
525    } else {
526	if ($h < 9 || ($h >= 16 && $h < 19)) {
527	    return "berufsverkehr";
528	} else {
529	    return "tagesverkehr";
530	}
531    }
532}
533
534# Restrict Entries by Direction, Time (Verkehrszeit) etc.
535sub restrict_entries {
536    my($e_ref, %args) = @_;
537    my(@res);
538    if ($args{DirFrom}) {
539	$args{DirFrom} =~ s/e/o/g;
540    }
541    if ($args{DirTo}) {
542	$args{DirTo} =~ s/e/o/g;
543    }
544    foreach my $e (@$e_ref) {
545      TRY: {
546	    while(my($k, $v) = each %args) {
547		if ($k eq 'Verkehrszeit') {
548		    my $vz = Ampelschaltung::verkehrszeit($e->{Day},
549							  $e->{Time});
550		    last TRY if $vz ne $v;
551		} else {
552		    last TRY if ($e->{$k} ne $v);
553		}
554	    }
555	    push @res, $e;
556	}
557    }
558    @res;
559}
560
561# XXX create_points also for Ampelschaltung!
562
563package Ampelschaltung2::Point;
564use vars qw(@ISA);
565@ISA = qw(Ampelschaltung::Point);
566
567sub new {
568    my($class, $root, $point) = @_;
569    my $self = {Point => $point,
570		Crossing => "",
571	       };
572    $self->{Root} = $root;
573    bless $self, $class;
574    my(@e) = $self->entries;
575    if (@e) {
576	$self->{Crossing} = $e[0]->{Crossing};
577    }
578    $self;
579}
580
581sub entries {
582    my $self = shift;
583    $self->{Root}->find_by_point($self->{'Point'});
584}
585
586package Ampelschaltung2::Entry;
587use vars qw(@ISA);
588@ISA = qw(Ampelschaltung::Entry);
589
590sub new {
591    my($class, $root, %args) = @_;
592    my $self = \%args;
593    $self->{Root} = $root;
594    bless $self, $class;
595}
596
597# Pseudo-Methode, um Kompatibili�t zu Ampelschaltung::Point::entries
598# zu erreichen.
599# XXX hier richtig????
600sub entries { $_[0] }
601
602sub lost { Ampelschaltung::Entry::lost(@_) }
603
604# XXX duplicate code
605sub as_string {
606    my $self = shift;
607    local $^W = undef;
608    join(",", @{$self}{qw(Day Time DirFrom DirTo Green Red Cycle Comment Date)});
609}
610
611package Ampelschaltung2;
612
613# Alternatives Ampelschaltungs-Format (misc/ampelschaltung.txt) Diese
614# ist genauer, weil die exakte Zeit (H:M:S) der Signalumschaltung
615# erfasst wird.
616
617use vars qw(@ISA);
618@ISA = qw(AmpelschaltungCommon);
619
620sub new {
621    my($class, %args) = @_;
622    my $self = \%args;
623    bless $self, $class;
624}
625
626# hacky, but works
627sub from_string {
628    my($self, $str) = @_;
629    local(@Strassen::datadirs) = "/tmp";
630    my $tmpfile = "/tmp/ampsch.$$.txt";
631    CORE::open(W, ">$tmpfile") or die "$tmpfile: $!";
632    print W $str;
633    close W;
634    require File::Basename;
635    my $r = $self->open(File::Basename::basename($tmpfile));
636    unlink $tmpfile;
637    $r;
638}
639
640sub open {
641    my $self = shift;
642    my $basefile = shift || "ampelschaltung-orig.txt";
643    require MyFile;
644    use FindBin; # XXX
645    my $file;
646    if (-e $basefile) {
647	$file = $basefile;
648	CORE::open(RW, $file) or return 0;
649    } else {
650	$file = MyFile::openlist(*RW, map { "$_/$basefile" }
651				 @Strassen::datadirs, "$FindBin::RealBin/misc",
652				 @INC);
653    }
654    if ($file) {
655	$self->{File}             = $file;
656	@{ $self->{Data} }        = (); # Ampelschaltung2::Entry-Objekte
657	%{ $self->{Point2Index} } = (); # "x,y" => Index auf Data
658	my $curr_date;
659	my $curr_day;
660	# Eine Gruppe besteht aus Beobachtungen eines Tages. Nur dort
661	# kann ich mir sicher sein, da� die Uhrzeiten *relativ*
662	# stimmen.
663	my $group_index = -1; # Index der Gruppe
664	my $index_in_group;   # Index innerhalb der Gruppe
665	my @rel_start;
666	while(<RW>) {
667	    next if (/^\s*\#/ || /^\s*$/); # Kommentare und Leerzeilen
668	    chomp;
669	    if (/^(\w{2}),\s+(\d+)\.(\d+)\.(\d+)(?:\s+\(00:00:00\s*=\s*(\d+):(\d+):(\d+)\))?/) {
670		$curr_day  = lc($1);
671		$curr_date = sprintf("%s, %02d.%02d.%04d", $1, $2, $3, $4);
672		$group_index++;
673		$index_in_group = 0;
674		@rel_start = ();
675		if (defined $5) {
676		    @rel_start = ($5, $6, $7);
677		}
678	    } elsif (/^([-+]?\d+,[-+]?\d+)/) {
679		my $point = $1;
680		$self->add_point(-date       => $curr_date,
681				 -day        => $curr_day,
682				 -point      => $point,
683				 -group      => $group_index,
684				 -groupindex => $index_in_group,
685				 -line       => $_,
686				 -relstart   => \@rel_start,
687				);
688		push @{$self->{Point2Index}{$point}}, $#{ $self->{Data} };
689		$index_in_group++;
690	    } elsif (/^\s+/) { # XXX spezielle Zeilen
691	    } else {
692		warn "Can't parse line: $_";
693	    }
694	}
695	close RW;
696	1;
697    } else {
698	0;
699    }
700}
701
702sub dump {
703    my $self = shift;
704    require Data::Dumper;
705    Data::Dumper::Dumper($self->{Data});
706}
707
708sub add_point {
709    my($self, %args) = @_;
710    my $date        = $args{-date}; # komplettes Datum: "wk, dd.mm.yyyy"
711    my $day         = $args{-day}; # Wochentag
712    my $point       = $args{-point};
713    my $line        = $args{-line};
714    my $group       = $args{-group};
715    my $group_index = $args{-groupindex};
716    my $rel_start   = $args{-relstart};
717    if (!defined $date) {
718	warn "Datum f�r <$line> nicht definiert";
719	return;
720    }
721    require Text::Tabs;
722    $line = Text::Tabs::expand($line);
723
724    my $last_e = ($#{$self->{Data}} >= 0
725		  ? $self->{Data}[$#{$self->{Data}}]
726		  : undef);
727
728    my $kreuzung = _strip_blank_substr($line, 14, 49-14);
729    my $dir = _strip_blank_substr($line, 49, 6);
730    my($dir_from, $dir_to);
731    if ($dir !~ m{^\s*$}) {
732	if ($dir !~ /([A-Z]+)->([A-Z]+)/) {
733	    warn "Die Richtung <$dir> in <$line> kann nicht geparst werden.";
734	    return;
735	}
736	($dir_from, $dir_to) = (lc($1), lc($2));
737    }
738
739    my $zyklus     = _strip_blank_substr($line, 56, 3);
740    (my $zyklus_n = $zyklus) =~ s/^(\d+).*/$1/;
741    my $green_time = _strip_blank_substr($line, 60, 69-60);
742    my $red_time   = _strip_blank_substr($line, 70, 10);
743
744    my($green, $red);
745    my $green_is_length;
746    my $red_is_length;
747
748    if ($green_time =~ /^\d+$/ || $red_time =~ /^\d+$/) {
749	if ($green_time =~ /^\d+$/) {
750	    $green = $green_time;
751	    $green_is_length = 1;
752	}
753	if ($red_time =~ /^\d+$/) {
754	    $red = $red_time;
755	    $red_is_length = 1;
756	}
757    }
758
759    if ($green_time ne '' and $red_time ne '' && !$green_is_length && !$red_is_length) {
760	my $gs = AmpelschaltungCommon::time2s($green_time, -relstart => $rel_start);
761	my $rs = AmpelschaltungCommon::time2s($red_time,   -relstart => $rel_start);
762	if ($gs < $rs) {
763	    $green = _adjust_green_red($rs-$gs, $zyklus_n);
764	} elsif ($zyklus_n ne '' and $zyklus_n > 0) {
765	    $green = _adjust_green_red($zyklus_n - ($gs-$rs), $zyklus_n);
766	}
767	if ($gs > $rs) {
768	    $red = _adjust_green_red($gs-$rs, $zyklus_n);
769	} elsif ($zyklus_n ne '' and $zyklus_n > 0) {
770	    $red = _adjust_green_red($zyklus_n - ($rs-$gs), $zyklus_n);
771	}
772    }
773    # length of red time in form +5s
774    if ($red_time =~ /^\+(\d+)/ and $green_time eq '' and $last_e and !@$rel_start) {
775	my $add = $1;
776	$green = $last_e->{Green}-$add
777	  if defined $last_e->{Green} && $last_e->{Green} ne '';
778	$red   = $last_e->{Red}+$add
779	  if defined $last_e->{Red} && $last_e->{Red} ne '';
780    }
781
782    my $time;
783    {
784	my @time;
785	if (@$rel_start) {
786	    foreach my $t_def ([$red_time, $red_is_length],
787			       [$green_time, $green_is_length]) {
788		my($t, $is_length) = @$t_def;
789		if (defined $t && $t ne "" && !$is_length) {
790		    my $s = AmpelschaltungCommon::time2s($t, -relstart => $rel_start);
791		    push @time, sprintf "%02d:%02d:%02d", AmpelschaltungCommon::s2time($s);
792		}
793	    }
794	} else {
795	    foreach my $t_def ([$red_time, $red_is_length],
796			       [$green_time, $green_is_length]) {
797		my($t, $is_length) = @$t_def;
798		push @time, $t if defined $t && $t ne "" && !$is_length && $t !~ /^\+/;
799	    }
800	}
801	if (@time) {
802	    $time = join(":", (split(/:/, (@time == 1
803					   ? $time[0]
804					   : _min_time(@time))))[0 .. 2]);
805	}
806    }
807
808    if (defined $green and ($green < 5 or $green > 50)) {
809	warn "Suspicious green time for $kreuzung at $date: $green\n"
810	  if $Ampelschaltung::warn;
811    }
812    if (defined $red   and ($red < 18 or $red > 80)) {
813	warn "Suspicious red time for $kreuzung at $date: $red\n"
814	  if $Ampelschaltung::warn;
815    }
816    if ($zyklus_n ne '' and $zyklus_n ne 'AUS'
817	and ($zyklus_n < 40 or $zyklus_n > 90)) {
818	warn "Suspicious cycle time for $kreuzung at $date: $zyklus_n\n"
819	  if $Ampelschaltung::warn;
820    }
821
822    my $comment;
823    if ($kreuzung =~ /\((auto.*|rad.*)\)/i) {
824	$comment = $1;
825    }
826    my $e = Ampelschaltung2::Entry->new
827      ($self,
828       Date       => $date,
829       Day        => $day, # Wochentag
830       Point      => $point,
831       Crossing   => $kreuzung,
832       DirFrom    => $dir_from,
833       DirTo      => $dir_to,
834       GreenTime  => $green_time,
835       Green      => $green,
836       RedTime    => $red_time,
837       Red        => $red,
838       Time       => $time, # Uhrzeit
839       Cycle      => $zyklus,
840       Comment    => $comment,
841       Group      => $group,
842       GroupIndex => $group_index,
843      );
844    push @{ $self->{Data} }, $e;
845}
846
847sub get_entries {
848    my $self = shift;
849    @{ $self->{Data} };
850}
851
852# Create a hash of Points, each one contains a list of Entries.
853sub create_points {
854    my($self) = @_;
855    my %point;
856    foreach my $e (@{ $self->{Data} }) {
857	push @{ $point{$e->{Point}} }, $e;
858    }
859    %point;
860}
861
862# Return pseudo-object Ampelschaltung2::Point
863sub find_point {
864    my($self, $point) = @_;
865    if (exists $self->{Point2Index}{$point}) {
866	Ampelschaltung2::Point->new($self, $point);
867    } else {
868	undef;
869    }
870}
871
872# Return list of Ampelschaltung2::Entries for the specified point.
873sub find_by_point {
874    my($self, $point) = @_;
875    my @res;
876    if (exists $self->{Point2Index}{$point}) {
877	foreach (@{ $self->{Point2Index}{$point} }) {
878	    push @res, $self->{Data}[$_];
879	}
880    }
881    @res;
882}
883
884# Gibt die beste Gruppe f�r die angegebenen Entries zur�ck.
885# Die beste Gruppe ist diejenige mit den meisten Eintr�gen.
886sub find_best_group {
887    my($e_ref) = @_;
888    my %group_points;
889    foreach my $e (@$e_ref) {
890	if ($e->{RedTime} ne "") {
891	    $group_points{$e->{Group}}++;
892	}
893	if ($e->{GreenTime} ne "") {
894	    $group_points{$e->{Group}}++;
895	}
896    }
897    (sort { $group_points{$b} <=> $group_points{$a} } keys %group_points)[0];
898}
899
900# Argument ist eine Referenz auf die Entries einer Gruppe (ggfs.
901# mit Ampelschaltung::restrict erstellen).
902# Ausgabe ist ein Array mit den Abst�nden zwischen den Rot- und
903# Gr�n-Zeiten in Sekungen:
904# ([r1, g1], # Rot- und Gr�n-Abstand zwischen dem Gruppenmitglied 1 und 2
905#  [r2, g2],
906#  ...)
907# XXX siehe Hinweis 3 Zeilen tiefer
908sub build_delta_table {
909    my($e_ref, %args) = @_;
910    my $zyklus = $args{Zyklus} || die; # XXX sollte nicht notwendig sein!
911    my @res;
912    for(my $i=0; $i<$#$e_ref; $i++) {
913	my @def;
914	if ($e_ref->[$i]{RedTime} ne '' and
915	    $e_ref->[$i+1]{RedTime} ne '') {
916	    my($rs1, $rs2) =
917	      (AmpelschaltungCommon::time2s($e_ref->[$i]{RedTime}),
918	       AmpelschaltungCommon::time2s($e_ref->[$i+1]{RedTime}));
919	    $def[0] = ($rs2-$rs1)%$zyklus;
920	}
921	if ($e_ref->[$i]{GreenTime} ne '' and
922	    $e_ref->[$i+1]{GreenTime} ne '') {
923	    my($rs1, $rs2) =
924	      (AmpelschaltungCommon::time2s($e_ref->[$i]{GreenTime}),
925	       AmpelschaltungCommon::time2s($e_ref->[$i+1]{GreenTime}));
926	    $def[1] = ($rs2-$rs1)%$zyklus;
927	}
928	push @res, [@def];
929    }
930    @res;
931}
932
933sub _strip_blank_substr {
934    my($s, @substr_args) = @_;
935    local $^W = 0; # "substr outside of string" verhindern
936    $s = substr($s, $substr_args[0], $substr_args[1]);
937    $s =~ s/\s+$//;
938    $s || '';
939}
940
941sub _min_time {
942    my($t1, $t2) = @_;
943    return if $t1 eq '' and $t2 eq '';
944    return $t1 if $t2 eq '';
945    return $t2 if $t1 eq '';
946    my $ss1 = AmpelschaltungCommon::time2s($t1);
947    my $ss2 = AmpelschaltungCommon::time2s($t2);
948    if ($ss1 > $ss2) { # XXX �ber Mitternacht hinaus XXX
949	$t2;
950    } else {
951	$t1;
952    }
953}
954
955sub _adjust_green_red {
956    my($green_red, $zyklus) = @_;
957    $green_red =~ s/^(\d+).*/$1/;
958    $zyklus =~ s/^(\d+).*/$1/;
959    if ($zyklus ne '' and $zyklus > 0) {
960	while ($green_red > $zyklus) {
961	    $green_red -= $zyklus;
962	}
963	while ($green_red < 0) {
964	    $green_red += $zyklus;
965	}
966    }
967    $green_red;
968}
969
9701;
971
972