1# -*- perl -*-
2
3#
4# $Id: StrassenNetz.pm,v 1.60 2008/12/31 12:26:33 eserte Exp $
5#
6# Copyright (c) 1995-2003 Slaven Rezic. All rights reserved.
7# This is free software; you can redistribute it and/or modify it under the
8# terms of the GNU General Public License, see the file COPYING.
9#
10# Mail: slaven@rezic.de
11# WWW:  http://bbbike.sourceforge.net
12#
13
14package Strassen::StrassenNetz;
15
16=head1 NAME
17
18Strassen::StrassenNetz - net creation and route searching routines
19
20=head1 SYNOPSIS
21
22    $net = StrassenNetz->new($strassen);
23    $net->make_net;
24    $net->search(...)
25
26=head1 DESCRIPTION
27
28=head2 METHODS
29
30=cut
31
32$VERSION = sprintf("%d.%02d", q$Revision: 1.60 $ =~ /(\d+)\.(\d+)/);
33
34package StrassenNetz;
35use strict;
36# XXX StrassenNetzLite?
37#use AutoLoader 'AUTOLOAD';
38use BBBikeUtil qw(schnittwinkel m2km min max);
39use BBBikeCalc;
40use Strassen::Util;
41BEGIN {@StrassenNetz::EXPORT_OK = qw($VERBOSE $data_format
42				     $FMT_HASH $FMT_ARRAY $FMT_CDB $FMT_MMAP)}
43use vars @StrassenNetz::EXPORT_OK;
44
45$FMT_HASH  = 1;
46$FMT_ARRAY = 2;
47$FMT_CDB   = 3;
48$FMT_MMAP  = 4;
49
50$VERBOSE     = 0         if !defined $VERBOSE;
51$data_format = $FMT_HASH if !defined $data_format;
52
53require Strassen::Cat;
54require Strassen::Generated;
55
56use vars qw($AUTOLOAD);
57sub AUTOLOAD {
58    warn "Loading Strassen::StrassenNetzHeavy for $AUTOLOAD ...\n"
59	if $VERBOSE;
60    require Strassen::StrassenNetzHeavy;
61    if (defined &$AUTOLOAD) {
62	goto &$AUTOLOAD;
63    } else {
64	die "Cannot find $AUTOLOAD in ". __PACKAGE__;
65    }
66}
67
68=head2 new($strassen)
69
70Construct a new C<Strassen::StrassenNetz> object. The supplied
71argument should be a C<Strassen> object.
72
73=cut
74
75sub new {
76    my($class, $strassen) = @_;
77    die "argument 1 is not of type Strassen"
78	if !$strassen->isa('Strassen') && !$strassen->isa('Strassen::Storable');
79    my $self = {};
80    $self->{Strassen} = $strassen;
81    bless $self, $class;
82}
83
84# verwendet entweder new_from_server (wenn nicht NoNewFromServer spezifiziert
85# wurde) oder new
86# XXX einheitliches Mapping strassen/multistrassen => shareable object
87# XXX $class vs. __PACKAGE__?
88### AutoLoad Sub
89sub new_from_best {
90    my($class, %args) = @_;
91    my $net;
92    $net = __PACKAGE__->new_from_server
93	unless $args{NoNewFromServer};
94    if (!$net) {
95	die "Missing Strassen parameter" if !$args{Strassen};
96	$net = __PACKAGE__->new($args{Strassen});
97	if ($args{OnCreate}) {
98	    my $meth = $args{OnCreate};
99	    $meth->($net);
100	}
101    }
102    $net;
103}
104
105sub get_cachefile {
106    my $self = shift;
107#XXX del:
108#     require File::Basename;
109#     my(@src) = $self->dependent_files;
110#     my $cachefile = join("_", map { File::Basename::basename($_) } @src);
111#     $cachefile;
112    $self->id;
113}
114
115# Markiert die angegebenen Objekte als Quell-Objekte f�r dieses StrassenNetz
116# Im Gegensatz dazu m�ssen dependent_files nicht unbedingt die direkten
117# Quellen sein.
118# Returns nothing meaningful
119### AutoLoad Sub
120sub set_source {
121    my($self, @source) = @_;
122    $self->{Source} = \@source;
123}
124
125sub get_source {
126    my($self) = @_;
127    @{ $self->{Source} || [] };
128}
129
130# Markiert die angegebenen Stra�en-Abk�rzungen als Quell-Objekte f�r
131# dieses StrassenNetz
132# Returns nothing meaningful
133### AutoLoad Sub
134sub set_source_abk {
135    my($self, @source_abk) = @_;
136    $self->{SourceAbk} = \@source_abk;
137}
138
139sub get_source_abk {
140    my($self) = @_;
141    @{ $self->{SourceAbk} || [] };
142}
143
144### AutoLoad Sub
145sub is_source {
146    my($self, $source) = @_;
147    foreach (@{$self->{Source}}) {
148	return 1 if $_ eq $source;
149    }
150    0;
151}
152
153# gibt die zugeh�rigen Quellobjekte aus
154### AutoLoad Sub
155sub sourceobjects {
156    my $self = shift;
157    if (exists $self->{Source} && @{$self->{Source}}) {
158	@{$self->{Source}};
159    } else {
160	$self->{Strassen};
161    }
162}
163
164# gibt die zugeh�rigen Quelldateien aus
165### AutoLoad Sub
166sub sourcefiles {
167    my $self = shift;
168    my %src;
169    for my $obj ($self->sourceobjects) {
170	for my $file ($obj->file) {
171	    $src{$file}++;
172	}
173    }
174    sort keys %src;
175}
176
177sub dependent_files {
178    my $self = shift;
179    $self->{Strassen}->dependent_files;
180}
181
182sub id {
183    my $self = shift;
184    $self->{Strassen}->id;
185}
186
187if (!defined &make_net) {
188    *make_net = \&make_net_slow_1;
189    *net_read_cache = \&net_read_cache_1;
190    *net_write_cache = \&net_write_cache_1;
191}
192*make_net_classic = \&make_net_slow_1;
193
194use enum qw(:WIDE_ NEIGHBOR1 DISTANCE1 NEIGHBOR2 DISTANCE2);
195
196use constant BLOCKED_ONEWAY   => 1;
197use constant BLOCKED_ONEWAY_STRICT => "1s";
198use constant BLOCKED_COMPLETE => 2;
199use constant BLOCKED_CARRY    => 0;
200use constant BLOCKED_ROUTE    => 3;
201use constant BLOCKED_NARROWPASSAGE => "BNP";
202
203# $sperre_file may also be a Strassen object
204### AutoLoad Sub
205sub make_sperre_1 {
206    my($self, $sperre_file, %args) = @_;
207
208    my $del_token = $args{DelToken};
209    my $special_vehicle = $args{SpecialVehicle} || '';
210
211    my %sperre_type;
212    if (exists $args{Type}) {
213	$args{Type} = [$args{Type}] unless ref $args{Type} eq 'ARRAY';
214	foreach (@{$args{Type}}) {
215	    if ($_ eq 'einbahn') {
216		$sperre_type{&BLOCKED_ONEWAY} = 1;
217	    } elsif ($_ eq 'einbahn-strict') {
218		$sperre_type{&BLOCKED_ONEWAY_STRICT} = 1;
219	    } elsif ($_ eq 'sperre') {
220		$sperre_type{&BLOCKED_COMPLETE} = 1;
221	    } elsif ($_ eq 'tragen') {
222		$sperre_type{&BLOCKED_CARRY} = 1;
223	    } elsif ($_ eq 'wegfuehrung') {
224		$sperre_type{&BLOCKED_ROUTE} = 1;
225	    } elsif ($_ eq 'narrowpassage') {
226		$sperre_type{&BLOCKED_NARROWPASSAGE} = 1;
227	    } elsif ($_ eq 'all') {
228		for (BLOCKED_ONEWAY, BLOCKED_ONEWAY_STRICT,
229		     BLOCKED_COMPLETE, BLOCKED_CARRY, BLOCKED_ROUTE,
230		     BLOCKED_NARROWPASSAGE) {
231		    $sperre_type{$_} = 1;
232		}
233	    } else {
234		$sperre_type{$_} = 1;
235	    }
236	}
237    } else {
238	%sperre_type = (&BLOCKED_COMPLETE => 1,
239			&BLOCKED_ONEWAY   => 1); # Standard: einbahn und sperre
240    }
241
242    my $sperre_obj;
243    if (UNIVERSAL::isa($sperre_file, "Strassen")) {
244	$sperre_obj = $sperre_file;
245    } else {
246	require Strassen::Core;
247	$sperre_obj = new Strassen $sperre_file;
248    }
249    $sperre_obj->init;
250    while(1) {
251	my $ret = $sperre_obj->next;
252	last if !@{$ret->[Strassen::COORDS()]};
253	my($category,$penalty,@addinfo) = split /:/, $ret->[Strassen::CAT()];
254
255	# Fix penalty or propagate to other category for special
256	# vehicles, currently only for BNP and CARRY:
257	if ($special_vehicle ne '') {
258	    if ($category eq BLOCKED_NARROWPASSAGE) {
259		Strassen::Cat::change_bnp_penalty_for_special_vehicle(\@addinfo, $special_vehicle, \$category, \$penalty);
260	    } elsif ($category eq BLOCKED_CARRY) {
261		$penalty = Strassen::Cat::carry_penalty_for_special_vehicle($penalty, $special_vehicle);
262	    }
263	}
264
265	if (exists $sperre_type{$category}) {
266	    if ($category eq BLOCKED_ROUTE) {
267		# Aufzeichnen der nicht erlaubten Wegf�hrung
268		push @{ $self->{Wegfuehrung}{$ret->[Strassen::COORDS()][-1]} },
269		     $ret->[Strassen::COORDS()];
270		if (defined $del_token) {
271		    # XXX Maybe the $del_token part has to be between
272		    # princicap coord and joined coords string ---
273		    # otherwise deletion in remove_all_from_deleted is
274		    # not 100% secure, especially for doubled values
275		    $self->{"_Added_Wegfuehrung"}{$del_token}{$ret->[Strassen::COORDS()][-1]}{join(" ", @{ $ret->[Strassen::COORDS()] })} = 1;
276		}
277	    } else { # ONEWAY...
278		my @kreuzungen = @{$ret->[Strassen::COORDS()]};
279		if (@kreuzungen == 1) {
280		    $self->del_net($kreuzungen[0], undef, undef, $del_token);
281		} else {
282		    my $i;
283		    for($i = 0; $i < $#kreuzungen; $i++) {
284			$self->del_net($kreuzungen[$i], $kreuzungen[$i+1],
285				       substr($category, 0, 1), $del_token);
286		    }
287		}
288	    }
289	} else {
290	    if (defined $penalty) {
291		# XXX z.Zt. nur f�r Typ BLOCKED_CARRY u. BLOCKED_NARROWPASSAGE
292		$self->{Penalty}{$ret->[Strassen::COORDS()][0]} = $penalty;
293	    }
294	}
295    }
296}
297
298*make_sperre = \&make_sperre_1;
299
300sub make_sperre_tragen {
301    my($sperre_file, $special_vehicle, $sperre_tragen_ref, $sperre_narrowpassage_ref, %args) = @_;
302    %$sperre_tragen_ref        = ();
303    %$sperre_narrowpassage_ref = ();
304    my $extended = $args{'-extended'} || 0;
305    my $s = Strassen->new($sperre_file);
306    $s->init;
307    while(1) {
308	my $r = $s->next;
309	last if !@{ $r->[Strassen::COORDS()] };
310	my($cat,@addinfo) = split /:/, $r->[Strassen::CAT()];
311	if ($cat eq StrassenNetz::BLOCKED_CARRY &&
312	    defined $addinfo[0] && $addinfo[0] ne '') {
313	    my $penalty = Strassen::Cat::carry_penalty_for_special_vehicle($addinfo[0], $special_vehicle);
314	    $sperre_tragen_ref->{$r->[Strassen::COORDS()][0]} = $extended ? [$r->[Strassen::NAME()], $penalty] : $penalty;
315	} elsif ($cat eq StrassenNetz::BLOCKED_NARROWPASSAGE &&
316		 defined $addinfo[0] && $addinfo[0] ne '') {
317	    my $penalty = $addinfo[0];
318	    my $dummy;
319	    Strassen::Cat::change_bnp_penalty_for_special_vehicle(\@addinfo, $special_vehicle, \$dummy, \$penalty);
320	    $sperre_narrowpassage_ref->{$r->[Strassen::COORDS()][0]} = $extended ? [$r->[Strassen::NAME()], $penalty] : $penalty;
321	}
322    }
323}
324
325# erstellt ein Netz mit der Steigung als Value
326# Argumente:
327#   sourcenet: bereits existierendes StrassenNetz-Objekt, das
328#              als Vorlage dient
329#   hoehe: Hash-Referenz mit den Hoehenangaben
330#   -min => minimale_Steigung in %
331#   -maxsearchdist => maximale Suche nach H�henpunkten
332#   -v (verbose, but not activated)
333# XXX Problems if the net contains a null-distance edge!
334#
335# XXX Problem mit der rekursiven Suche: unterschiedliche
336# Wege/Ausgangspunkte k�nnen unterschiedliche Ergebnisse verursachen.
337# Denkfehler! Ich benutze nicht zwangsweise den *kuerzesten* Weg!
338# find_neighbors sollte eine Breitensuche mit korrekter Sortierung nach
339# Wegstrecke verwenden.
340# Problemfaelle: Bersarinplatz, Heilbronner Str.; Imchenweg, bevor ich den
341# korrigierenden H�henpunkt eingef�gt habe.
342#
343### AutoLoad Sub
344sub make_net_steigung {
345    my($self, $sourcenet, $hoehe, %args) = @_;
346    die "sourcenet must be StrassenNetz object"
347	if !$sourcenet->isa('StrassenNetz');
348    my $calc_strecke = $args{'-strecke'} || \&Strassen::Util::strecke_s;
349    my $min_mount = 0.001; # 0.1% als minimale Steigung
350    my $max_search_dist = 1000; # bricht die Suche nach H�henpunkten nach 1000m ab
351    my $v = $args{-v} || 0;
352
353    if (exists $args{'-min'}) {
354	$min_mount = $args{'-min'}/100;
355    }
356    if (exists $args{'-maxsearchdist'}) {
357	$max_search_dist = $args{'-maxsearchdist'};
358    }
359    $self->{Net} = {};
360    my $net = $self->{Net};
361
362    # Search recursively until $max_search_dist is exceeded
363    my $find_neighborsXXX;
364    $find_neighborsXXX = sub {
365	my($from, $seen, $dist_so_far, $initial_elevation) = @_;
366
367	my $nodes = keys %{ $sourcenet->{Net} };
368
369	my %CLOSED;
370	my %OPEN;
371	my %PRED;
372
373	my $act_coord = $from;
374	my $act_dist = $dist_so_far || 0;
375	$OPEN{$act_coord} = $act_dist;
376	$PRED{$act_coord} = undef;
377
378	while (1) {
379	    $CLOSED{$act_coord} = $act_dist;
380	    delete $OPEN{$act_coord};
381
382	    while (my($neighbor, $dist) = each %{ $sourcenet->{Net}{$act_coord} }) {
383#require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([\%OPEN, \%CLOSED],[])->Indent(1)->Useqq(1)->Dump; # XXX
384
385#warn "($neighbor, $dist)";
386		next if exists $CLOSED{$neighbor} && $CLOSED{$neighbor} <= $act_dist + $dist;
387		next if exists $OPEN{$neighbor} && $OPEN{$neighbor} <= $act_dist + $dist;
388		$OPEN{$neighbor} = $act_dist + $dist;
389		delete $CLOSED{$neighbor};
390		$PRED{$neighbor} = $act_coord;
391	    }
392
393	    # XXX Better use a heap!
394	    my $new_act_coord;
395	    my $new_act_dist = Strassen::Util::infinity();
396	    while (my($c, $dist) = each %OPEN) {
397		if ($dist < $new_act_dist) {
398		    $new_act_coord = $c;
399		    $new_act_dist = $dist;
400		}
401	    }
402	    if (!defined $new_act_coord) {
403		last;
404	    }
405	    if ($new_act_dist > $max_search_dist) {
406		last;
407	    }
408
409	    if (exists $hoehe->{$new_act_coord}) {
410		my $hoehendiff = $hoehe->{$new_act_coord} - $initial_elevation;
411		if (!exists $net->{$from}{$new_act_coord} && $new_act_dist > 0) {
412		    my $mount = int(($hoehendiff/$new_act_dist)*1000)/1000;
413		    if ($mount >= $min_mount) {
414			for my $i (0 .. $#$seen - 1) {
415			    # XXX m��te ich hier nicht max(abs(...)) aussuchen?
416			    $net->{$seen->[$i]}{$seen->[$i+1]} = $mount
417				unless exists $net->{$seen->[$i]}{$seen->[$i+1]};
418			}
419			$net->{$seen->[-1]}{$from} = $mount
420			    unless exists $net->{$seen->[-1]}{$from};
421			$net->{$from}{$new_act_coord} = $mount
422			    unless exists $net->{$from}{$new_act_coord};
423		    }
424		}
425	    }
426
427	    $act_coord = $new_act_coord;
428	    $act_dist = $new_act_dist;
429	    # warn $act_dist;
430	}
431    };
432
433    my $find_neighbors;
434    $find_neighbors = sub {
435	my($from, $seen, $dist_so_far, $initial_elevation) = @_;
436	$seen ||= [];
437	$dist_so_far ||= 0;
438	my %seen = map { ($_=>1) } @$seen;
439
440	for my $neighbor (keys %{$sourcenet->{Net}{$from}}) {
441	    next if exists $seen{$neighbor};
442	    my $strecke1 = $dist_so_far;
443	    my $strecke2 = $calc_strecke->($from, $neighbor);
444	    my $strecke = $strecke1 + $strecke2;
445	    if (exists $hoehe->{$neighbor}) {
446		my $hoehendiff = $hoehe->{$neighbor} - $initial_elevation;
447		if (!exists $net->{$from}{$neighbor} && $strecke > 0) {
448		    my $mount = int(($hoehendiff/$strecke)*1000)/1000;
449		    if ($mount >= $min_mount) {
450			for my $i (0 .. $#$seen - 1) {
451			    $net->{$seen->[$i]}{$seen->[$i+1]} = $mount
452				unless exists $net->{$seen->[$i]}{$seen->[$i+1]};
453			}
454#XXX$mount = "$mount @$seen";
455			$net->{$seen->[-1]}{$from} = $mount
456			    unless exists $net->{$seen->[-1]}{$from};
457			$net->{$from}{$neighbor} = $mount
458			    unless exists $net->{$from}{$neighbor};
459		    }
460		}
461	    } else {
462		return if $strecke > $max_search_dist;
463		$find_neighbors->($neighbor, [@$seen, $from], $strecke, $initial_elevation);
464	    }
465	}
466    };
467
468    my $keys = scalar keys %{$sourcenet->{Net}};
469    my $i = 0;
470    my @keys = keys %{$sourcenet->{Net}};
471    foreach my $p1 (@keys) {
472	my $val = $sourcenet->{Net}{$p1};
473	if ($v) {
474	    if ($i%100 == 0) {
475		printf STDERR "$i/$keys (%d%%) ($p1)...\r", $i/$keys*100;
476	    }
477	    $i++;
478	}
479	my @keys = keys %$val; # no iterator reset!
480	foreach my $p2 (@keys) {
481	    if (exists $hoehe->{$p1}) {
482		if (exists $hoehe->{$p2}) {
483		    my $strecke = $calc_strecke->($p1, $p2);
484		    my $hoehendiff = $hoehe->{$p2}-$hoehe->{$p1};
485		    if ($strecke > 0) {
486			my $mount = int(($hoehendiff/$strecke)*1000)/1000;
487			$net->{$p1}{$p2} = $mount
488			    if $mount >= $min_mount;
489		    }
490		} else {
491		    $find_neighbors->($p2, [$p1], $calc_strecke->($p1, $p2), $hoehe->{$p1});
492		}
493	    }
494	}
495    }
496    printf STDERR "\n" if $v;
497}
498
499### AutoLoad Sub
500sub reset {
501    my $self = shift;
502    $self->del_add_net;
503}
504
505use vars qw($MLDBM_SERIALIZER);
506$MLDBM_SERIALIZER = 'Storable' unless defined $MLDBM_SERIALIZER;
507
508# Gibt die Stra�en-Positionsnummer f�r das angegebene Koordinaten-Paar aus.
509# Der zweite R�ckgabewert (rueckwaerts) gibt an, ob die Reihenfolge from-to
510# in der Datenbank umgedreht ist.
511# Wenn $to nicht definiert ist, werden alle Stra�en-Positionsnummern, die
512# von $from aus gehen, ausgegeben. In diesem Fall gibt es keinen
513# "rueckwaerts"-R�ckgabewert.
514### AutoLoad Sub
515sub net2name {
516    my($net, $from, $to) = @_;
517    if (!defined $to) {
518	my(@to) = keys %{$net->{Net}{$from}};
519	my @ret;
520	foreach my $to (@to) {
521	    push @ret, $net->net2name($from, $to);
522	}
523	@ret;
524    } else {
525	if (exists $net->{Net2Name}{$from} &&
526	    exists $net->{Net2Name}{$from}{$to}) {
527	    ($net->{Net2Name}{$from}{$to}, 0);
528	} elsif (exists $net->{Net2Name}{$to} &&
529		 exists $net->{Net2Name}{$to}{$from}) {
530	    ($net->{Net2Name}{$to}{$from}, 1);
531	} else {
532	    warn "Can't find street from $from to $to"
533	      if $VERBOSE;
534	    undef;
535	}
536    }
537}
538
539sub get_street_record {
540    my($net, $from, $to, %args) = @_;
541    my $obeydir = delete $args{-obeydir};
542    my($pos, $reversed) = $net->net2name($from, $to);
543    if (defined $pos) {
544	return undef if ($obeydir && $reversed);
545	if (ref $pos eq 'ARRAY') {
546	    map { $net->{Strassen}->get($_) } @$pos;
547	} else {
548	    $net->{Strassen}->get($pos);
549	}
550    } else {
551	undef;
552    }
553}
554
555{
556    package StrassenNetz::SearchContext;
557    use myclassstruct qw(
558			 Algorithm
559			 HasPenalty
560			 HasAmpeln
561			 AmpelPenalty
562			 HasQualitaet
563			 HasHandicap
564			 HasStrcat
565			 HasRadwege
566			 HasRadwegeStrcat
567			 HasGreen
568			 HasUnlitStreets
569			 HasSteigung
570			 HasTragen
571			 HasTram
572			 Velocity
573			 HasAbbiegen
574			 Statistics
575			 UserDefPenaltySub
576			 HasBlocked
577		       );
578}
579
580sub build_penalty_code {
581    my $sc = shift || die "No build context given";
582
583    my $penalty_code = "";
584
585    if ($sc->Algorithm ne 'srt' &&
586	$sc->Algorithm !~ /^C-/) {
587	$penalty_code .= '
588                    my $next_node = $successor;
589                    my $last_node = $min_node;
590';
591    }
592    if ($sc->HasBlocked) {
593	$penalty_code .= '
594                    if (defined $last_node) {
595                        if (exists $blocked_net->{$last_node}{$next_node}) {
596			    my $cat = $blocked_net->{$last_node}{$next_node};
597			    if ($cat =~ /^(?:' . BLOCKED_COMPLETE . '|' . BLOCKED_ONEWAY . ')$/) {
598			        return Strassen::Util::infinity();
599			    } # XXX strict oneway?
600			} elsif (exists $blocked_net->{$next_node}{$last_node} &&
601				 $blocked_net->{$next_node}{$last_node} =~ /^' . BLOCKED_COMPLETE . '/) {
602			    return Strassen::Util::infinity();
603			}
604		    }
605';
606    }
607    if ($sc->HasAmpeln && $sc->Algorithm ne 'srt') {
608	# XXX not yet for srt_algo
609	# XXX Penalty anpassen, falls nach links/rechts abgebogen wird.
610	# Keine Penalty bei Besonderheiten (nur eine Richtung ist relevant,
611	# Fu�g�ngerampel...) XXX
612	# XXX next_node oder last_node verwenden?
613	$penalty_code .= '
614		    if (exists $ampel_net->{$next_node}) {
615			$pen += ' . $sc->AmpelPenalty . ';
616		    }
617';
618    }
619    if ($sc->HasQualitaet) {
620	# A not existing penalty may happen if searching with fragezeichen streets
621	# is turned on.
622	$penalty_code .= '
623		    if (defined $last_node and
624                        exists $qualitaet_net->{$last_node}{$next_node}) {
625			my $cat = $qualitaet_net->{$last_node}{$next_node};
626			if (exists $qualitaet_penalty->{$cat}) {
627  	                    $pen *= $qualitaet_penalty->{$cat}; # Qualit�tszuschlag
628			}
629		    }
630';
631    }
632    if ($sc->HasHandicap) {
633	# See above
634	$penalty_code .= '
635		    if (defined $last_node and
636                        exists $handicap_net->{$last_node}{$next_node}) {
637			my $cat = $handicap_net->{$last_node}{$next_node};
638			if (exists $handicap_penalty->{$cat}) {
639                            $pen *= $handicap_penalty->{$cat}; # Handicapzuschlag
640			}
641		    }
642';
643    }
644    if ($sc->HasStrcat) {
645	# See above
646	$penalty_code .= '
647		    if (defined $last_node and
648                        exists $strcat_net->{$last_node}{$next_node}) {
649			my $cat = $strcat_net->{$last_node}{$next_node};
650			if (exists $strcat_penalty->{$cat}) {
651                            $pen *= $strcat_penalty->{$cat}; # Kategorieaufschlag
652			}
653		    }
654';
655    }
656    if ($sc->HasRadwege) {
657	# A penalty for the empty category should be defined.
658	$penalty_code .= '
659		    if (defined $last_node and
660                        exists $radwege_net->{$last_node}{$next_node}) {
661                        # Radwegeaufschlag
662                        $pen *= $radwege_penalty->{$radwege_net->{$last_node}{$next_node}};
663		    } else {
664                        $pen *= $radwege_penalty->{""};
665                    }
666';
667    }
668    if ($sc->HasRadwegeStrcat) {
669	# Assumes that every possible category has a penalty.
670	$penalty_code .= '
671		    if (defined $last_node and
672                        exists $radwege_strcat_net->{$last_node}{$next_node}) {
673                        $pen *= $radwege_strcat_penalty->{$radwege_strcat_net->{$last_node}{$next_node}}; # combined cycle path/street category penalty
674		    }
675';
676    }
677    if ($sc->HasGreen) {
678	# Assumes that the penalty for green0 (not a green street) is
679	# defined.
680	$penalty_code .= '
681		    if (defined $last_node) {
682                        if (exists $green_net->{$last_node}{$next_node}) {
683                            $pen *= $green_penalty->{$green_net->{$last_node}{$next_node}};
684                        } else {
685                            $pen *= $green_penalty->{"green0"};
686                        }
687
688		    }
689';
690    }
691    if ($sc->HasUnlitStreets) {
692	# Lit streets have no penalty.
693	$penalty_code .= '
694		    if (defined $last_node and
695                        exists $unlit_streets_net->{$last_node}{$next_node}) {
696			my $cat = $unlit_streets_net->{$last_node}{$next_node};
697			if (exists $unlit_streets_penalty->{$cat}) {
698                            $pen *= $unlit_streets_penalty->{$cat};
699                        }
700		    }
701';
702    }
703    if ($sc->HasSteigung) {
704	$penalty_code .= '
705		    if (defined $last_node and
706                        exists $steigung_net->{$last_node}{$next_node}) {
707                        my $norm_steigung = int(1000*$steigung_net->{$last_node}{$next_node});
708                        if (!exists $steigung_penalty->{$norm_steigung}) {
709                            $steigung_penalty->{$norm_steigung} = $steigung_penalty_sub->($norm_steigung);
710                        }
711                        $pen *= $steigung_penalty->{$norm_steigung}; # Steigungsaufschlag
712		    }
713';
714    }
715    if ($sc->HasTram) {
716	$penalty_code .= '
717		    if (defined $last_node and
718                        exists $tram_net->{$last_node}{$next_node}) {
719			my $cat = $tram_net->{$last_node}{$next_node};
720			if (exists $tram_penalty->{$cat}) {
721                            $pen *= $tram_penalty->{$cat};
722                        }
723		    }
724';
725    }
726    if ($sc->UserDefPenaltySub) {
727	$penalty_code .= '
728                    $pen = $user_def_penalty_sub->($pen, $next_node, $last_node);
729';
730    }
731    # should be last, because of addition
732    if ($sc->HasTragen) { # XXX h�h?
733	if ($sc->HasGreen) {
734	    # Adjust penalty according to penalty for "normal" (non-green)
735	    # streets:
736	    $penalty_code .= '
737		    if ($penalty and exists $penalty->{$next_node}) {
738                        $pen += ' . $sc->Velocity . '*$penalty->{$next_node}*$green_penalty->{"green0"};
739		    }
740';
741	} else {
742	    $penalty_code .= '
743		    if ($penalty and exists $penalty->{$next_node}) {
744                        $pen += ' . $sc->Velocity . '*$penalty->{$next_node};
745		    }
746';
747	}
748    }
749
750    if ($penalty_code ne "" &&
751	$] >= 5.006 # has warnings.pm
752       ) {
753	$penalty_code = "    no warnings; # ignore because of \"inwork\" and such
754
755$penalty_code";
756    }
757
758    $penalty_code;
759}
760
761# Return value
762use enum qw(:RES_ PATH LEN XXX PENALTY TRAFFICLIGHTS NEAREST_NODE);
763
764# local constants for A*
765use enum qw(PREDECESSOR DIST HEURISTIC_DIST);
766
767# XXX m�gliche R�ckgabewerte:
768# - die beste Pfadbeschreibung (+ L�nge etc.)
769# - die besten Pfadbeschreibungen (+ L�nge etc.)
770# - die beste Pfadbeschreibung (ohne L�nge etc.)
771# - die besten Pfadbeschreibungen (ohne L�nge etc.)
772# - die beste Route (als Objekt)
773# - die besten Routen (als Objekt)
774### AutoLoad Sub
775sub build_search_code {
776    my($self, %args) = @_;
777
778    my $sc = $args{SearchContext} || die "No SearchContext given";
779
780    # Optionen zum �ndern des Suchalgorithmus'
781    #XXX => $sc->AlgorithmOpt
782    my $cut_path_nr   = 10;
783    my $pure_depth    = 0;
784    my $backtracking  = 0;
785    if (exists $args{Tune}) {
786	if (exists $args{Tune}->{CutPath}) {
787	    $cut_path_nr = $args{Tune}->{CutPath};
788	}
789	if ($args{Tune}->{PureDepth}) {
790	    $pure_depth = $args{Tune}->{PureDepth};
791	}
792	if ($args{Tune}->{Backtracking}) {
793	    $backtracking = $args{Tune}->{Backtracking};
794	}
795    }
796
797    # soll eine "visuelle" Suche vorgenommen werden
798    my $do_visual     = exists $args{VisualSearch} ? 1 : 0;
799    my $do_singlestep = exists $args{SingleStep} ? 1 : 0;
800
801    # Optimierung mit einem seen-Hash, damit bereits besuchte Knoten im
802    # gleichen Pfad nicht nochmals �berpr�ft werden.
803    my $seen_optimierung = 1;
804
805    my $use_2 = 0;
806    if (defined $args{Use2}) {
807	$use_2 = $args{Use2};
808    } elsif ($data_format == $FMT_ARRAY) {
809	$use_2 = 1;
810    }
811
812    # XXX use_3 nicht implementiert?
813    my $use_3 = $data_format == $FMT_CDB;
814
815    # XXX use_2 ist f�r A* noch nicht implementiert XXXXXXXXXXXXXXXXXX
816    if ($use_2) {
817	$sc->Algorithm("srt");
818    }
819
820    my $len_pen    = ($sc->HasPenalty ? 'pen' : 'len');
821
822    # Aufschlag, damit Alternativ-Routen gefunden werden k�nnen
823    my $aufschlag_code = '';
824    if ($args{Aufschlag}) {
825	$aufschlag_code = '*' . $args{Aufschlag};
826    }
827    # XXX Die $skip_path_code*-Variablen sind nur fuer SRT-Algo.
828    #
829    # Code f�r die Abfrage, ob der aktuelle Path das Ziel nicht mehr in einer
830    # k�rzeren L�nge erreichen kann.
831    my $skip_path_code = '
832		    if (defined $visited{$next_node} and
833			$next_node_'.$len_pen.' > $visited{$next_node}'
834			  . $aufschlag_code . ') {
835			next;
836		    }
837';
838    my $skip_path_code2 = '
839		    if (defined $visited{$to} and
840                        $virt_'.$len_pen.' > $visited{$to}'
841			  . $aufschlag_code . ') {
842			next;
843		    }
844';
845    # Code f�r die Abfrage, ob die Wegf�hrung des aktuellen Pfades nicht
846    # erlaubt ist
847    # XXX ich habe die Datenstruktur von $wegfuehrung umgestellt, hier
848    # aber noch nicht...
849    my $skip_path_code3 = '
850		    if ($wegfuehrung and
851                        exists $wegfuehrung->{$next_node}) {
852                      CHECK_WEGFUEHRUNG: {
853                          my($wegfuehrung) = $wegfuehrung->{$next_node};
854                          for(my $i=0; $i<$#$wegfuehrung; $i++) {
855                             last CHECK_WEGFUEHRUNG if ($path[$#path-$i] ne $wegfuehrung->[$#$wegfuehrung-1-$i];
856                          }
857			  next;
858                        }
859		    }
860';
861
862    # Commoninit
863    my $code = 'sub {
864    my($self, $from, $to) = @_;
865    my $str = $self->{Strassen};
866    my $net = $self->{Net};
867    my $wegfuehrung = $self->{Wegfuehrung};
868    my $penalty = $self->{Penalty};
869    local *strecke_s = $self->{strecke_s_sub} || \&Strassen::Util::strecke_s;
870';
871
872    # Use_2_Init
873    if ($use_2) {
874	$code .= '
875    $from = unpack("l", $self->{Coord2Index}{pack("l2", split(/,/, $from))});
876    $to   = unpack("l", $self->{Coord2Index}{pack("l2", split(/,/, $to))});
877';
878    }
879
880    # Visualinit
881    if ($do_visual) {
882	$code .= '
883    my $red_val = 100;
884';
885    }
886
887    # Statinit/VisualInit
888    if ($sc->Statistics || $do_visual) {
889	$code .= '
890    my $last_time = (defined &Tk::timeofday ? Tk::timeofday() : time);
891';
892    }
893
894    # Debugging (single step)
895    if ($do_singlestep) {
896	$code .= '
897    my $do_singlestep = 1;
898';
899    }
900
901    # Penaltycode ...
902    my($penalty_code) = "";
903    if ($sc->HasPenalty) {
904	$penalty_code = build_penalty_code($sc);
905    }
906
907    if ($sc->Algorithm eq 'srt') {
908	require Strassen::Obsolete;
909	return $self->build_search_code_srt($code, $sc, $seen_optimierung, $use_2, $do_visual, $penalty_code, $len_pen, $skip_path_code, $skip_path_code2, $pure_depth, $backtracking, $cut_path_nr, \%args, $aufschlag_code);
910    }
911
912    ######################################################################
913    # A*
914
915    # NODES: Hash von Nodes auf
916    #     [$node: Vorg�nger-Node ("x,y") (PREDECESSOR),
917    #      $g:    Streckenl�nge (oder Penalty) bis Node (DIST),
918    #      $f:    abgesch�tzte L�nge bis Ziel �ber Node (HEURISTIC_DIST),
919    #      weitere Array-Elemente sind optional ...]
920    use vars qw($use_heap);
921    $use_heap = 0 if !defined $use_heap; # XXX the heap version seems to be faster, but first do some tests and enable it after 3.13 RELEASE.
922    if ($use_heap && !eval q{ require Array::Heap; Array::Heap->VERSION(2); import Array::Heap; 1 }) {
923	$use_heap = 0;
924    }
925    $code .= '
926
927'; if ($use_heap) { $code .= '
928    my @OPEN = ([0, $from]); make_heap @OPEN;
929'; } else { $code .= '
930    my %OPEN = ($from => 1);
931'; } $code .= '
932    my %NODES = ($from => [undef, 0, strecke_s($from, $to), undef]);
933    my %CLOSED;
934    my $nearest_node;
935    my $nearest_node_dist = Strassen::Util::infinity();
936    while (1) {
937#require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([\@OPEN],[])->Indent(1)->Useqq(1)->Dump; # XXX
938
939'; if ($do_visual) { $code .= '
940        if (Tk::timeofday() > $last_time + $visual_delay) {
941            $canvas->idletasks;
942            $last_time = Tk::timeofday();
943        }
944        $red_val+=5 if $red_val < 255;
945        my $red_col = sprintf("#%02x0000", $red_val);
946'; } if ($use_heap) { $code .= '
947        if (!@OPEN) {
948'; } else { $code .= '
949        if (keys %OPEN == 0) {
950'; } $code .= '
951            my @res;
952            $res[RES_NEAREST_NODE] = $nearest_node;
953            return @res;
954        }
955
956'; if ($use_heap) { $code .= '
957	my($min_node_f, $min_node) = @{ pop_heap @OPEN };
958'; } else { $code .= '
959        my $min_node;
960        my $min_node_f = Strassen::Util::infinity();
961        foreach (keys %OPEN) {
962            if ($NODES{$_}->[HEURISTIC_DIST] < $min_node_f) {
963                $min_node = $_;
964                $min_node_f = $NODES{$_}->[HEURISTIC_DIST];
965            }
966        }
967        # min_node wird aus OPEN nach CLOSED bewegt
968        delete $OPEN{$min_node};
969'; } $code .= '
970        $CLOSED{$min_node} = 1;
971        if ($min_node eq $to) {
972	    #$self->dump_search_nodes(\%NODES); # DEBUG_DUMP_NODES
973            my @path;
974            my $len = 0;
975            while (1) {
976                push @path, $min_node;
977                my $prev_node = $NODES{$min_node}->[PREDECESSOR];
978                if (defined $prev_node) {
979                    $len += strecke_s($min_node, $prev_node);
980                    $min_node = $prev_node;
981                } else {
982                    last;
983                }
984            }
985            @path = map { [ split(/,/, $_) ] } reverse @path;
986'; if ($sc->Statistics) {
987    if ($use_heap) { $code .= '
988            $visited_nodes = scalar(@OPEN) + scalar(keys %CLOSED);
989';  } else { $code .= '
990            $visited_nodes = scalar(keys %OPEN) + scalar(keys %CLOSED);
991'; }} $code .= '
992            my @ret;
993            $ret[RES_PATH]          = \@path;
994            $ret[RES_LEN]           = $len;
995            $ret[2]                 = 0; # ???
996            $ret[RES_PENALTY]       = $min_node_f;
997            $ret[RES_TRAFFICLIGHTS] = undef;
998            return @ret;
999        }
1000
1001        #printf STDERR "- dump minnode ----------------------------\nx,y=%s dist=%d hdist=%d\n", $min_node, $NODES{$min_node}->[DIST], $NODES{$min_node}->[HEURISTIC_DIST]; # DEBUG_MINNODE
1002	#printf STDERR "----------\n"; # DEBUG_SUCC
1003        my @successors = keys %{ $net->{$min_node} };
1004     CHECK_SUCCESSOR:
1005        foreach my $successor (@successors) {
1006#         while(my($successor, $dist) = each %{ $net->{$min_node} }) {
1007
1008            my $NODES_min_node = $NODES{$min_node};
1009            # do not check against the predecessor of this node
1010            next if (defined $NODES_min_node->[PREDECESSOR] &&
1011                     $NODES_min_node->[PREDECESSOR] eq $successor);
1012
1013            # erlaubte Wegf�hrungen beachten
1014            # die Performance-Einbu�e liegt anscheinend unter 1% (Messung
1015            # mit der alten, nicht-Array-Implementation)
1016            if ($wegfuehrung and
1017                exists $wegfuehrung->{$successor}) {
1018                my($wegfuehrungen) = $wegfuehrung->{$successor};
1019                for my $wegfuehrung (@$wegfuehrungen) {
1020                    my $this_node = $min_node;
1021                    my $same = 1;
1022                    for(my $i=$#$wegfuehrung-1; $i>=0; $i--) {
1023                        if ($wegfuehrung->[$i] ne $this_node) {
1024                            $same = 0;
1025                            last;
1026                        }
1027			if ($i > 0) {
1028                            $this_node = $NODES{$this_node}->[PREDECESSOR];
1029                            if (!defined $this_node) {
1030                                $same = 0;
1031                                last;
1032			    }
1033                        }
1034                    }
1035                    next CHECK_SUCCESSOR if $same;
1036                }
1037            }
1038'; if ($do_visual) { $code .= '
1039            if ($canvas) {
1040                # Ausgabe f�r Visual Search
1041                my($lx, $ly) = $transpose_sub->(split(/,/, $min_node));
1042                my($nx, $ny) = $transpose_sub->(split(/,/, $successor));
1043                $canvas->createLine($lx,$ly,$nx,$ny,
1044                                    -tag=>"visual",
1045                                    -fill=>"red",-width=>3);
1046            }
1047'; } if ($sc->Statistics) { $code .= '
1048            $node_touches++; # das geh�rt in die Stat-Abteilung
1049'; } $code .= "
1050
1051            my \$" . $len_pen .' = $net->{$min_node}{$successor};#$dist;
1052';
1053	if ($sc->HasPenalty) {
1054	    $code .= $penalty_code;
1055	} $code .= '
1056            my $g = $NODES_min_node->[DIST] + ' . "\$" . $len_pen . ';
1057            my $remaining_dist = strecke_s($successor, $to);
1058            my $f = $g + $remaining_dist;
1059	    #printf STDERR "x,y=%s\nthis=%d f=%d g=%d\n", $successor, $' . $len_pen . ', $f, $g; # DEBUG_SUCC
1060            # !exists in OPEN and !exists in CLOSED:
1061            if (!exists $NODES{$successor}) {
1062                $NODES{$successor} = [$min_node, $g, $f];
1063'; if ($use_heap) { $code .= '
1064		push_heap @OPEN, [$f, $successor];
1065'; } else { $code .= '
1066                $OPEN{$successor} = 1;
1067'; } $code .= '
1068                if ($remaining_dist < $nearest_node_dist) {
1069                    $nearest_node_dist = $remaining_dist;
1070                    $nearest_node = $min_node;
1071                }
1072            } else {
1073                if ($f < $NODES{$successor}->[HEURISTIC_DIST]) {
1074                    $NODES{$successor} = [$min_node, $g, $f];
1075                    if (exists $CLOSED{$successor}) {
1076'; if ($use_heap) { $code .= '
1077			push_heap @OPEN, [$f, $successor];
1078'; } else { $code .= '
1079                        $OPEN{$successor} = 1;
1080'; } $code .= '
1081                        delete $CLOSED{$successor};
1082                    }
1083'; if ($use_heap) { $code .= '
1084		    else { # exists in OPEN
1085			for my $i (0 .. $#OPEN) {
1086			    if ($OPEN[$i][1] eq $successor) {
1087				$OPEN[$i][0] = $f;
1088				last;
1089			    }
1090			}
1091			make_heap @OPEN;
1092		    }
1093'; } $code .= '
1094                }
1095            }
1096        }
1097';
1098	if ($do_singlestep) {
1099	    $code .= '
1100	    if ($do_singlestep) {
1101                my $mw = defined &Tk::MainWindow::Existing && (Tk::MainWindow::Existing())[0];
1102		$mw->update if $mw && Tk::Exists($mw);
1103	    INPUT: {
1104	            print STDERR "min node=$min_node, <RETURN> for next step, <c> for continue: ";
1105	            my($ans) = scalar(<STDIN>);
1106	            if ($ans =~ /^c/) {
1107		        $do_singlestep = 0;
1108		    } elsif ($ans =~ /^x\s+(.*)/) {
1109			require Data::Dumper; print STDERR "\n", Data::Dumper->new([eval $1],[])->Deparse(1)->Useqq(1)->Dump, "\n";
1110		        redo INPUT;
1111		    }
1112		}
1113	    }
1114';
1115	} $code .= '
1116    }
1117 } # Achtung, Einr�ckung f�r make_autoload!
1118';
1119    return $code;
1120}
1121
1122# Sucht eine Route im Netz von $from bis $to.
1123#
1124# R�ckgabewert:
1125# wenn AsObj gesetzt ist, dann eine Liste von Route-Objekten
1126# ansonsten eine Liste von Array-Referenzen mit folgendem Format:
1127#    [\@Path, $Len, $_, $Penalty, $Ampeln]
1128# \@Path ist eine Liste aus Punkten "$x,$y"
1129# $Len ist die Gesamtl�nge in Metern
1130# $_: ?
1131# $Penalty ist die Penalty (in Metern ???)
1132# $Ampeln ist die Anzahl der Ampeln an der Route
1133#
1134### AutoLoad Sub
1135sub search {
1136    my($self, $from, $to, %args) = @_;
1137
1138    my $sc = StrassenNetz::SearchContext->new;
1139
1140    # Initialisierung ...
1141    # $sc->HasPenalty gibt an, ob die Suche nur �ber die Entfernung geht oder
1142    # ob eine Penalty verwendet wird, die sich aus der Entfernung modifiziert
1143    # mit weiteren Parametern ergibt
1144    $sc->HasPenalty(exists $args{Ampeln}    ||
1145		    exists $args{Qualitaet} ||
1146		    exists $args{Handicap}  ||
1147		    exists $args{Strcat}    ||
1148		    exists $args{Radwege}   ||
1149		    exists $args{RadwegeStrcat} ||
1150		    exists $args{Green} ||
1151		    exists $args{UnlitStreets} ||
1152		    exists $args{Steigung}  ||
1153		    exists $args{Abbiegen}  ||
1154		    exists $args{Tragen}    ||
1155		    exists $args{Tram}      ||
1156		    exists $self->{BlockingNet}
1157		   );
1158    $sc->HasBlocked(exists $self->{BlockingNet});
1159    $sc->HasAmpeln(exists $args{Ampeln});
1160    if ($sc->HasAmpeln) {
1161	$sc->AmpelPenalty((exists $args{Ampeln}->{Penalty}
1162			   ? $args{Ampeln}->{Penalty}
1163			   : 100));
1164    }
1165    $sc->HasQualitaet     (exists $args{Qualitaet});
1166    $sc->HasHandicap      (exists $args{Handicap});
1167    $sc->HasStrcat        (exists $args{Strcat});
1168    $sc->HasRadwege       (exists $args{Radwege});
1169    $sc->HasRadwegeStrcat (exists $args{RadwegeStrcat});
1170    $sc->HasGreen         (exists $args{Green});
1171    $sc->HasUnlitStreets  (exists $args{UnlitStreets});
1172    $sc->HasSteigung      (exists $args{Steigung});
1173    $sc->HasAbbiegen      (exists $args{Abbiegen} and exists $args{Ampeln});
1174    $sc->HasTragen        (exists $args{Tragen} and exists $args{Velocity});
1175    $sc->HasTram          (exists $args{Tram});
1176    $sc->UserDefPenaltySub(exists $args{UserDefPenaltySub});
1177
1178    # Ausgabe einer Statistik
1179    $sc->Statistics($args{Stat} || 0);
1180
1181    $sc->Velocity($args{Velocity});
1182
1183    $sc->Algorithm($args{'Algorithm'} || "A*");
1184
1185    my $ampel_net;
1186    if (exists $args{Ampeln}) {
1187	$ampel_net = $args{Ampeln}->{Net};
1188    }
1189
1190    my($qualitaet_net, $qualitaet_penalty);
1191    if (exists $args{Qualitaet}) {
1192	$qualitaet_net = $args{Qualitaet}->{Net}->{Net};
1193	$qualitaet_penalty = $args{Qualitaet}->{Penalty} || die "No penalty";
1194    }
1195
1196    my($handicap_net, $handicap_penalty);
1197    if (exists $args{Handicap}) {
1198	$handicap_net = $args{Handicap}->{Net}->{Net};
1199	$handicap_penalty = $args{Handicap}->{Penalty} || die "No penalty";
1200    }
1201
1202    my($strcat_net, $strcat_penalty);
1203    if (exists $args{Strcat}) {
1204	$strcat_net = $args{Strcat}->{Net}->{Net};
1205	$strcat_penalty = $args{Strcat}->{Penalty} || die "No penalty";
1206    }
1207    my($radwege_net, $radwege_penalty);
1208    if (exists $args{Radwege}) {
1209	$radwege_net = $args{Radwege}->{Net}->{Net};
1210	$radwege_penalty = $args{Radwege}->{Penalty} || die "No penalty";
1211    }
1212    my($radwege_strcat_net, $radwege_strcat_penalty);
1213    if (exists $args{RadwegeStrcat}) {
1214	$radwege_strcat_net = $args{RadwegeStrcat}->{Net}->{Net};
1215	$radwege_strcat_penalty = $args{RadwegeStrcat}->{Penalty} || die "No penalty";
1216    }
1217    my($green_net, $green_penalty);
1218    if (exists $args{Green}) {
1219	$green_net = $args{Green}->{Net}->{Net};
1220	$green_penalty = $args{Green}->{Penalty} || die "No penalty";
1221    }
1222    my($unlit_streets_net, $unlit_streets_penalty);
1223    if (exists $args{UnlitStreets}) {
1224	$unlit_streets_net = $args{UnlitStreets}->{Net}->{Net};
1225	$unlit_streets_penalty = $args{UnlitStreets}->{Penalty} || die "No penalty";
1226    }
1227    my($steigung_net, $steigung_penalty, $steigung_penalty_sub);
1228    if (exists $args{Steigung}) {
1229	$steigung_net = $args{Steigung}->{Net}->{Net};
1230	$steigung_penalty = $args{Steigung}->{Penalty} || die "No penalty";
1231	$steigung_penalty_sub = $args{Steigung}->{PenaltySub} ||
1232	  die "No penalty subroutine";
1233    }
1234    my($abbiegen_penalty, $category_order);
1235    if (exists $args{Abbiegen}) {
1236	$category_order = $args{Abbiegen}->{Order} || die "No order";
1237	$abbiegen_penalty = $args{Abbiegen}->{Penalty} || die "No penalty";
1238    }
1239    my($blocked_net);
1240    if (exists $self->{BlockingNet}) {
1241	$blocked_net = $self->{BlockingNet}->{Net};
1242    }
1243    my($tram_net, $tram_penalty);
1244    if (exists $args{Tram}) {
1245	$tram_net = $args{Tram}->{Net}->{Net};
1246	$tram_penalty = $args{Tram}->{Penalty} || die "No penalty";
1247    }
1248    my $user_def_penalty_sub = $args{UserDefPenaltySub};
1249
1250    # f�r die Statistik:
1251    my($max_new_paths, $max_suspended_paths, $visited_nodes, $node_touches)
1252	= (0, 0, 0, 0);
1253    my(@loop_count);
1254    # f�r Visual Search:
1255    my($canvas, $transpose_sub, $visual_delay);
1256    if ($args{'VisualSearch'}) {
1257	$canvas        = $args{'VisualSearch'}->{Canvas};
1258	$transpose_sub = $args{'VisualSearch'}->{Transpose};
1259	$visual_delay  = $args{'VisualSearch'}->{Delay};
1260	$canvas->delete("visual");
1261    }
1262
1263    if ($sc->Algorithm) {
1264	if ($sc->Algorithm =~ /^(dip-|DBI-)A\*$/) {
1265	    push @INC, "$FindBin::RealBin/diplom/code";
1266	    require BBBikeDiplom;
1267	    if ($sc->Algorithm eq 'dip-A*') {
1268		return $self->search_A_star($from, $to, %args);
1269	    } elsif ($sc->Algorithm eq 'DBI-A*') {
1270		$args{'DBI'} = 1;
1271		return $self->search_A_star($from, $to, %args);
1272	    }
1273	} elsif ($sc->Algorithm !~ /^(srt$|A\*$|C-A\*)/) {
1274	    die "Unknown algorithm " . $sc->Algorithm;
1275	}
1276    } else {
1277	$sc->Algorithm("A*");
1278    }
1279
1280    my $search_sub;
1281    if ($sc->Algorithm !~ /^C-/) {
1282	my $code = $self->build_search_code(SearchContext => $sc, %args);
1283	if ($VERBOSE) {
1284	    # dump code with line numbers
1285	    my $i = 0;
1286	    foreach (split(/\n/, $code)) {
1287		$i++;
1288		printf STDERR "%3d %s\n", $i, $_;
1289	    }
1290	}
1291	$search_sub = eval $code;
1292	warn $@ if $@;
1293    } else {
1294	my $inner_search_sub;
1295	if ($sc->Algorithm eq 'C-A*-2') {
1296	    require Strassen::Inline2Dist;
1297	    $inner_search_sub = \&Strassen::Inline2::search_c;
1298	} else {
1299	    require Strassen::InlineDist;
1300	    $inner_search_sub = \&Strassen::Inline::search_c;
1301	}
1302	my $penalty_code = build_penalty_code($sc);
1303	my $penalty_sub;
1304	if ($penalty_code ne "") {
1305	    $penalty_code = <<'EOF' .
1306sub {
1307    my($next_node, $last_node, $pen) = @_;
1308    my $penalty = $self->{Penalty}; # XXX should not be here...
1309EOF
1310		$penalty_code . <<'EOF'
1311    $pen;
1312}
1313EOF
1314	    ;
1315	    warn $penalty_code if $VERBOSE;
1316	    $penalty_sub = eval $penalty_code;
1317	    die "While eval'ing penalty sub: $@" if $@;
1318	}
1319	$search_sub = sub {
1320	    $inner_search_sub->(@_,
1321				($penalty_sub ? (-penaltysub => $penalty_sub) : ()),
1322			       );
1323	};
1324    }
1325
1326    my $start_time;
1327    if ($sc->Statistics) {
1328	$start_time = (defined &Tk::timeofday ? Tk::timeofday() : time);
1329    }
1330
1331    if ($args{WideSearch}) {
1332	my $inner_search_sub = $search_sub;
1333	$search_sub = sub { $self->wide_search($inner_search_sub, @_) };
1334    }
1335
1336    my @res;
1337    if (exists $args{Via} and @{$args{Via}}) {
1338	my(@route) = ($from, @{$args{Via}}, $to);
1339	my @path;
1340	my $ges_len = 0;
1341	for(my $i = 0; $i < $#route; $i++) {
1342	    my($search_res, $len)
1343		= &$search_sub($self, $route[$i], $route[$i+1]);
1344	    if (ref $search_res eq 'ARRAY') {
1345		my(@found_path) = @$search_res;
1346		if ($i > 0) {
1347		    shift @found_path;
1348		}
1349		push @path, @found_path;
1350		$ges_len += $len;
1351	    }
1352	}
1353	@res = (\@path, $ges_len);
1354    } else {
1355	@res = &$search_sub($self, $from, $to);
1356    }
1357
1358    if ($args{WideSearch}) {
1359	$res[0] = $self->expand_wide_path($res[0]);
1360    }
1361
1362    if ($sc->Statistics) {
1363
1364	my $search_time = (defined &Tk::timeofday ? Tk::timeofday() : time) - $start_time;
1365	warn "\n";
1366	warn "Algorithm:            " . $sc->Algorithm . "\n";
1367	warn sprintf "Search time:          %.4f s\n", $search_time;
1368	if ($sc->Algorithm eq 'srt') {
1369	    warn "Max. new paths:       $max_new_paths\n";
1370	    warn "Max. suspended paths: $max_suspended_paths\n";
1371	}
1372	my $path_length = 0;
1373	if ($search_time) {
1374	    if (ref $res[0] eq 'ARRAY') {
1375		$path_length = scalar @{$res[0]};
1376		warn sprintf "Path length (nodes):  %-5d %d/s\n", $path_length, $path_length/$search_time;
1377	    }
1378	    warn sprintf "Visited nodes:        %-5d %d/s\n", $visited_nodes, $visited_nodes/$search_time;
1379	    warn sprintf "Node touches:         %-5d %d/s\n", $node_touches, $node_touches/$search_time;
1380	}
1381	if ($visited_nodes) {
1382	    warn "Penetrance P:         "
1383		. sprintf("%.4f", scalar(@{$res[0]})/$visited_nodes) . "\n";
1384	    # XXX effective branching factor
1385	}
1386	warn "Length:               " . $res[RES_LEN] . "\n";
1387	warn "Penalty:              " . $res[RES_PENALTY] . "\n";
1388	warn "Length/Penalty ratio: " . ($res[RES_LEN] ? $res[RES_PENALTY]/$res[RES_LEN] : "Inf") . "\n";
1389	if ($sc->Statistics > 1) {
1390	    for(my $i=1; $i<=3; $i++) {
1391		if (defined $loop_count[$i-1]) {
1392		    warn "Loop count level $i:   " . $loop_count[$i-1] . "\n";
1393		}
1394	    }
1395	}
1396
1397	if ($args{StatDB} && open(STAT, ">>$FindBin::RealBin/tmp/searchstat.txt")) {
1398	    print STAT join('|', $visited_nodes, $node_touches, $path_length);
1399	    close STAT;
1400	}
1401    }
1402
1403    # XXX ???? verwenden f�r GPS-Ausgabe
1404    if ($args{AsObj}) {
1405	require Route;
1406	my $new_res = new Route(Path    => $res[RES_PATH],
1407				Len     => $res[RES_LEN],
1408				From    => $from,
1409				Via	=> $args{Via},
1410				To      => $to,
1411				Penalty => $res[RES_PENALTY],
1412				Ampeln  => $res[RES_TRAFFICLIGHTS],
1413				NearestNode => $res[RES_NEAREST_NODE],
1414				);
1415	$new_res;
1416    } else {
1417	@res;
1418    }
1419}
1420
1421# Backward compat:
1422sub new_search {
1423    warn "new_search() is deprecated, please use search()";
1424    shift->search(@_);
1425}
1426
1427
1428# Findet f�r die Strecke c1-c2 die Position in Strassen.
1429# Von c1 und c2 mu� mindestens ein Punkt in Net2Name existieren.
1430# Als zweiter R�ckgabewert wird zur�ckgegeben, ob die Strecke r�ckw�rts
1431# zur Strecke in der Datenbasis verl�uft.
1432### AutoLoad Sub
1433sub nearest_street {
1434    my($self, $c1, $c2) = @_;
1435    my $rueckwaerts = 0;
1436    my @neighbors = keys %{ $self->{Net}{$c1} };
1437    if (!@neighbors) {
1438	($c1, $c2) = ($c2, $c1);
1439	$rueckwaerts = 1;
1440	@neighbors = keys %{ $self->{Net}{$c1} };
1441	if (!@neighbors) {
1442	    warn "Kann weder $c1 noch $c2 in Net2Name finden"
1443		if $VERBOSE;
1444	    return (undef, undef);
1445	}
1446    }
1447
1448    my($x1,$y1) = split /,/, $c1;
1449    my($x2,$y2) = split /,/, $c2;
1450
1451    my $best_winkel;
1452    my $best_neighbor_i;
1453    for my $neighbor_i (0 .. $#neighbors) {
1454	my($xn,$yn) = split /,/, $neighbors[$neighbor_i];
1455	my(undef,$w) = Strassen::Util::abbiegen([$x1,$y1], [$x2,$y2], [$xn,$yn]);
1456	$w = 0 if !defined $w;
1457	if (!defined $best_winkel || $best_winkel > $w) {
1458	    $best_winkel = $w;
1459	    $best_neighbor_i = $neighbor_i;
1460	    last if $w == 0; # no improvements possible, shortcut
1461	}
1462    }
1463
1464    my($pos,$rueckwaerts2) = $self->net2name($c1, $neighbors[$best_neighbor_i]);
1465    ($pos, $rueckwaerts ^ $rueckwaerts2);
1466}
1467
1468use enum qw(:ROUTE_ NAME DIST ANGLE DIR	ARRAYINX EXTRA);
1469
1470*route_to_name = \&route_to_name_1;
1471
1472sub street_is_backwards {
1473    my($self, $xy1, $xy2) = @_;
1474    # XXX probably does not work for $type == $FMT_ARRAY
1475    my($str_i, $backwards) = $self->net2name($xy1, $xy2);
1476    return $backwards if (defined $str_i);
1477    ($str_i, $backwards) = $self->nearest_street($xy1, $xy2);
1478    return $backwards if (defined $str_i);
1479    warn "Can't get street for coordinates $xy1 - $xy2\n";
1480    0;
1481}
1482
1483# Take the output of route_to_name and simplify the list so that only
1484# direction changes with an angle > $args{-minangle} (no default, 30� is a
1485# possible value) are recorded.
1486# If $args{-samestreet} is set to a true then also changes in street names
1487# will be recorded.
1488# The returned value is of the same format like in route_to_name, only change:
1489# the street names are collected into an array of streets.
1490# The ROUTE_EXTRA information is not used.
1491sub simplify_route_to_name {
1492    my($route_to_name_ref, %args) = @_;
1493    my @new_route_to_name;
1494    for(my $i=0; $i<=$#$route_to_name_ref; $i++) {
1495	my $e0; $e0 = $route_to_name_ref->[$i-1] if $i > 0;
1496	my $e = $route_to_name_ref->[$i];
1497	my $combine = 0;
1498    CHECK_COMBINE: {
1499	    last if $i == $#$route_to_name_ref;
1500	    last if (!@new_route_to_name);
1501	    last if ($args{-samestreet} && $new_route_to_name[-1][0][-1] ne $e->[ROUTE_NAME]);
1502	    last if (defined $args{-minangle} &&
1503		     defined $e0->[ROUTE_ANGLE] &&
1504		     $e0->[ROUTE_ANGLE] >= $args{-minangle});
1505	    $combine = 1;
1506	}
1507	if ($combine) {
1508	    my $last = $new_route_to_name[-1];
1509	    push @{$last->[ROUTE_NAME]}, $e->[ROUTE_NAME];
1510	    $last->[ROUTE_DIST] += $e->[ROUTE_DIST];
1511	    $last->[ROUTE_ANGLE]       = $e->[ROUTE_ANGLE];
1512	    $last->[ROUTE_DIR]         = $e->[ROUTE_DIR];
1513	    $last->[ROUTE_ARRAYINX][1] = $e->[ROUTE_ARRAYINX][1];
1514	} else {
1515	    push @new_route_to_name,
1516		[[$e->[ROUTE_NAME]],
1517		 $e->[ROUTE_DIST], $e->[ROUTE_ANGLE], $e->[ROUTE_DIR],
1518		 [@{ $e->[ROUTE_ARRAYINX] }]
1519		];
1520	}
1521    }
1522
1523    @new_route_to_name;
1524}
1525
1526=head2 route_info(%args)
1527
1528The input arguments:
1529
1530=over
1531
1532=item Route
1533
1534Required. The list of the path, as returned by search().
1535
1536=item Coords
1537
1538List of coordinates (? XXX)
1539
1540=item Km
1541
1542Return distances in km instead of m.
1543
1544=item AngleAccuracy
1545
1546Set the accuracy for angles in degrees. Default is 10E<deg>.
1547
1548=item PathIndexStart
1549
1550Set the start index for the reference to the Path/Route array. By
1551default 0.
1552
1553=item StartMeters
1554
1555Set the start distance. Used for continued routes. By default 0.
1556
1557=back
1558
1559The output is an array of hash elements with the following keys:
1560
1561=over
1562
1563=item Hop
1564
1565The distance of the current hop as a string (number with unit, usually km).
1566
1567=item HopMeters
1568
1569Same as B<Hop> as a number in meters.
1570
1571=item Whole
1572
1573The distance from the start to the end point of the current hop. Same
1574format as Hop.
1575
1576=item WholeMeters
1577
1578Same as B<Whole> as a number in meters.
1579
1580=item Way
1581
1582The direction to be used at the beginning of the current hop. Possible
1583values are "R" (right), "L" (left) and may be prefixed with "H"
1584(half). Undefined or empty means: straight ahead.
1585
1586=item Angle
1587
1588The precise angle of the direction change. The angle is in degrees,
1589always positive and rounded to the AngleAccuracy input argument.
1590
1591=item Direction
1592
1593The direction at the beginning of the current hop ("N" for north, "S"
1594for south etc.).
1595
1596=item Street
1597
1598The street name of the current hop.
1599
1600=item Coords
1601
1602The coordinates as "X,Y" at the beginning of the current hop.
1603
1604=back
1605
1606=cut
1607
1608sub route_info {
1609   my($self, %args) = @_;
1610
1611   my $routeref       = $args{Route} || die "Missing argument: Route";
1612   my $coords         = $args{Coords};
1613   my $s_in_km        = $args{Km};
1614   my $angle_accuracy = $args{AngleAccuracy} || 10;
1615   my $path_index_start = $args{PathIndexStart} || 0;
1616   my $whole          = $args{StartMeters} || 0;
1617
1618   my $s_sub = ($s_in_km ? sub { m2km($_[0]) } : sub { $_[0] });
1619
1620   my @search_route = $self->route_to_name($routeref);
1621   my @route_info;
1622   my @route_strnames;
1623   my($next_angle, $next_direction)
1624	= ("", undef, "");
1625   my $last_str;
1626   for(my $i = 0; $i <= $#search_route; $i++) {
1627	my $route_info_item = {};
1628	my($str, $index_arr);
1629	my $compassdirection;
1630	my $hop;
1631	my($angle, $direction)
1632	    = ($next_angle, $next_direction);
1633
1634	my $val = $search_route[$i];
1635	$str	        = $val->[ROUTE_NAME];
1636	$hop	        = $val->[ROUTE_DIST];
1637	$next_angle     = $val->[ROUTE_ANGLE];
1638	$next_direction = $val->[ROUTE_DIR];
1639	$index_arr      = $val->[ROUTE_ARRAYINX];
1640
1641	my $route_strnames_index;
1642	if ($str ne '...' &&
1643	    (!defined $last_str || $last_str ne $str)) {
1644	    $last_str = $str;
1645	    $str = Strassen::strip_bezirk($str);
1646	    if (ref $index_arr eq 'ARRAY' &&
1647		ref $coords eq 'ARRAY' &&
1648		defined $index_arr->[0] &&
1649		defined $coords->[$index_arr->[0]] &&
1650		defined $coords->[$index_arr->[0]+1]) {
1651		my($x, $y) = ($coords->[$index_arr->[0]]->[0],
1652			      $coords->[$index_arr->[0]]->[1]);
1653		push @route_strnames, [$str, $x, $y, $index_arr->[0]];
1654		$route_strnames_index = $#route_strnames;
1655	    }
1656	}
1657
1658	if ($i < $#search_route and  ref $index_arr eq 'ARRAY') {
1659	    $compassdirection =
1660		    uc(BBBikeCalc::line_to_canvas_direction
1661		       (@{ $routeref->[$index_arr->[0]] },
1662			@{ $routeref->[$index_arr->[0]+1] }));
1663	}
1664
1665	if ($i > 0) {
1666	    if (!$angle) { $angle = 0 }
1667	    $angle = int($angle/$angle_accuracy)*$angle_accuracy;
1668	    if ($angle < 30) {
1669		$direction = "";
1670	    } else {
1671		$direction = ($angle <= 45 ? 'H' : '') . uc($direction);
1672	    }
1673	    # XXX is this correct (that is, in the $i>0 condition)?
1674	    if (defined $route_strnames_index) {
1675		$route_strnames[$route_strnames_index]->[ROUTE_ARRAYINX]
1676		    = $s_sub->($whole);
1677	    }
1678	}
1679	$whole += $hop;
1680
1681	for ($route_info_item) {
1682	    $_->{Hop}         = $s_sub->($hop);
1683	    $_->{HopMeters}   = $hop;
1684	    $_->{Whole}       = $s_sub->($whole);
1685	    $_->{WholeMeters} = $whole;
1686	    $_->{Way}         = $direction;
1687	    $_->{Angle}       = $angle;
1688	    $_->{Direction}   = $compassdirection;
1689	    $_->{Street}      = $str;
1690	    $_->{Coords}      =
1691		join(",", @{$routeref->[$index_arr->[0]]});
1692	    $_->{PathIndex}   = $index_arr->[0] + $path_index_start;
1693	}
1694
1695	push @route_info, $route_info_item;
1696   }
1697
1698   @route_info;
1699}
1700
1701# Only valid for "comments" net objects.
1702# $routeref: array reference to path
1703# $routeinx: current route index
1704# $seen: optional hash reference of seen comments XXX Rundfahrten?
1705# XXX flaky.
1706# XXX support for ":" in categories missing (except for PI)
1707# $args{AsObj} = 1: return a full Strasse object instead of the name
1708# $args{AsIndex} = 1: return the index of the Strasse object
1709sub get_point_comment {
1710    my($self, $routeref, $routeinx, $seen, %args) = @_;
1711    my $as_obj = $args{AsObj};
1712    my $as_index = $args{AsIndex};
1713    return if $routeinx == $#$routeref;
1714    my $xy1 = join ",", @{ $routeref->[$routeinx] };
1715    my $xy2 = join ",", @{ $routeref->[$routeinx+1] };
1716    my @pos;
1717    my $pos;
1718    my $strassen = $self->{Strassen};
1719    my $net2name = $self->{Net2Name};
1720 FIND_POS: {
1721	my $h1;
1722	$h1 = $net2name->{$xy1};
1723	if ($h1) {
1724	    $pos = $h1->{$xy2};
1725	    push @pos, $pos if defined $pos;
1726	    $pos = $h1->{"*"};
1727	    push @pos, $pos if defined $pos;
1728	}
1729	$h1 = $net2name->{$xy2};
1730	if ($h1) {
1731	    $pos = $h1->{$xy1};
1732	    push @pos, $pos if defined $pos;
1733	    $pos = $h1->{"*"};
1734	    push @pos, $pos if defined $pos;
1735	}
1736        $h1 = $net2name->{"*"};
1737	if ($h1) {
1738	    $pos = $h1->{$xy1};
1739	    push @pos, $pos if defined $pos;
1740	    $pos = $h1->{$xy2};
1741	    push @pos, $pos if defined $pos;
1742	}
1743	if (!@pos) {
1744	    return;
1745	}
1746    }
1747
1748    # array-ify and uniq-ify
1749    my %pos = map {($_,1)} map {
1750	if (UNIVERSAL::isa($_, "ARRAY")) {
1751	    @$_;
1752	} else {
1753	    $_;
1754	}
1755    } @pos;
1756    @pos = keys %pos;
1757
1758    my @res;
1759    my @res_inx;
1760 POS:
1761    for my $pos1 (@pos) {
1762	next if $seen && $seen->{$pos1};
1763	my $r = $strassen->get($pos1);
1764	if ($r->[Strassen::CAT()] =~ /^(P1|CP;)$/) {
1765	    if ($routeinx > 0) {
1766		my $xy0 = join ",", @{ $routeref->[$routeinx-1] };
1767		if (($r->[Strassen::COORDS()][0] eq $xy0 || $r->[Strassen::COORDS()][0] eq '*') &&
1768		    ($r->[Strassen::COORDS()][1] eq $xy1 || $r->[Strassen::COORDS()][1] eq '*') &&
1769		    ($r->[Strassen::COORDS()][2] eq $xy2 || $r->[Strassen::COORDS()][2] eq '*')) {
1770		    push @res, $r;
1771		    push @res_inx, $pos1;
1772		    next POS;
1773		}
1774	    }
1775	} elsif ($r->[Strassen::CAT()] =~ /^(P2|CP)$/) {
1776	    if ($routeinx > 0) {
1777		my $xy0 = join ",", @{ $routeref->[$routeinx-1] };
1778		if ((($r->[Strassen::COORDS()][0] eq $xy0 || $r->[Strassen::COORDS()][0] eq '*') &&
1779		     ($r->[Strassen::COORDS()][1] eq $xy1 || $r->[Strassen::COORDS()][1] eq '*') &&
1780		     ($r->[Strassen::COORDS()][2] eq $xy2 || $r->[Strassen::COORDS()][2] eq '*')) ||
1781		    (($r->[Strassen::COORDS()][0] eq $xy2 || $r->[Strassen::COORDS()][2] eq '*') &&
1782		     ($r->[Strassen::COORDS()][1] eq $xy1 || $r->[Strassen::COORDS()][1] eq '*') &&
1783		     ($r->[Strassen::COORDS()][2] eq $xy0 || $r->[Strassen::COORDS()][0] eq '*'))) {
1784		    push @res, $r;
1785		    push @res_inx, $pos1;
1786		    next POS;
1787		}
1788	    }
1789	} elsif ($r->[Strassen::CAT()] =~ /^CP2;$/) {
1790	    if ($r->[Strassen::COORDS()][0] eq $xy1 &&
1791		$r->[Strassen::COORDS()][1] eq $xy2) {
1792		push @res, $r;
1793		push @res_inx, $pos1;
1794		next POS;
1795	    }
1796	} elsif ($r->[Strassen::CAT()] =~ /^CP2$/) {
1797	    if (($r->[Strassen::COORDS()][0] eq $xy1 &&
1798		 $r->[Strassen::COORDS()][1] eq $xy2) ||
1799		($r->[Strassen::COORDS()][0] eq $xy2 &&
1800		 $r->[Strassen::COORDS()][1] eq $xy1)) {
1801		push @res, $r;
1802		push @res_inx, $pos1;
1803		next POS;
1804	    }
1805	} elsif ($r->[Strassen::CAT()] =~ /^(S1|CS;)$/) {
1806	    for my $i (0 .. $#{$r->[Strassen::COORDS()]}-1) {
1807		if ($r->[Strassen::COORDS()][$i] eq $xy1 &&
1808		    $r->[Strassen::COORDS()][$i+1] eq $xy2) {
1809		    $seen->{$pos1}++ if $seen;
1810		    push @res, $r;
1811		    push @res_inx, $pos1;
1812		    next POS;
1813		}
1814	    }
1815	} elsif ($r->[Strassen::CAT()] =~ /^(S2|CS)$/) {
1816	    for my $i (0 .. $#{$r->[Strassen::COORDS()]}-1) {
1817		if (($r->[Strassen::COORDS()][$i] eq $xy1 &&
1818		     $r->[Strassen::COORDS()][$i+1] eq $xy2) ||
1819		    ($r->[Strassen::COORDS()][$i+1] eq $xy1 &&
1820		     $r->[Strassen::COORDS()][$i] eq $xy2)) {
1821		    $seen->{$pos1}++ if $seen;
1822		    push @res, $r;
1823		    push @res_inx, $pos1;
1824		    next POS;
1825		}
1826	    }
1827	} elsif ($r->[Strassen::CAT()] =~ /^PI;?(:|$)/) {
1828	CHECK_PI: {
1829		for my $i (0 .. $#{$r->[Strassen::COORDS()]}) {
1830		    last CHECK_PI if !defined $routeref->[$routeinx+$i];
1831		    my $xy = join ",", @{ $routeref->[$routeinx+$i] };
1832		    last CHECK_PI if ($r->[Strassen::COORDS()][$i] ne $xy);
1833		}
1834		$seen->{$pos1}++ if $seen;
1835		push @res, $r;
1836		push @res_inx, $pos1;
1837		next POS;
1838	    }
1839	} elsif ($r->[Strassen::CAT()] =~ /^P0;?$/) {
1840	    # not yet
1841	    next POS;
1842	} else { # arbitrary categories
1843	    # XXX what about obey_dir???
1844	    my $cat_hin = $r->[Strassen::CAT()];
1845	    my $cat_rueck;
1846	    if ($cat_hin =~ /(.*);(.*)/) {
1847		($cat_hin, $cat_rueck) = ($1, $2);
1848	    } else {
1849		$cat_rueck = $cat_hin;
1850	    }
1851	    for my $i (0 .. $#{$r->[Strassen::COORDS()]}-1) {
1852		my $yes = 0;
1853		if ($r->[Strassen::COORDS()][$i] eq $xy1 &&
1854		    $r->[Strassen::COORDS()][$i+1] eq $xy2 &&
1855		    $cat_hin ne "") {
1856		    $yes = 1;
1857		} elsif ($r->[Strassen::COORDS()][$i+1] eq $xy1 &&
1858			 $r->[Strassen::COORDS()][$i] eq $xy2 &&
1859			 $cat_rueck ne "") {
1860		    $yes = 1;
1861		}
1862		if ($yes) {
1863		    $seen->{$pos1}++ if $seen;
1864		    push @res, $r;
1865		    push @res_inx, $pos1;
1866		    next POS;
1867		}
1868	    }
1869	}
1870    }
1871
1872    if ($as_index) {
1873	@res_inx;
1874    } elsif ($as_obj) {
1875	@res;
1876    } else {
1877	map { $_->[Strassen::NAME()] } @res;
1878    }
1879}
1880
1881# L�scht den Punkt aus dem Stra�ennetz-Graphen
1882# Wenn nur ein Punkt angegeben ist, dann werden alle Nachbarn entfernt.
1883# Wenn zwei Punkte angegeben sind, dann wird nur diese Strecke entfernt,
1884# und zwar nur in dieser Richtung, wenn dir == 1, oder beide Richtungen,
1885# wenn dir == 2
1886# If $del_token is defined, then record the deletion in {_Deleted}->{$del_token}
1887sub del_net {
1888    my($self, $point1, $point2, $dir, $del_token) = @_;
1889    my $deleted_net = ($self->{_Deleted}{$del_token||''} ||= {});
1890    if (!defined $point2) {
1891	if (exists $self->{Net}{$point1}) {
1892	    foreach (keys %{$self->{Net}{$point1}}) {
1893		if (defined $del_token) {
1894		    if (exists $self->{Net}{$point1}{$_}) {
1895			$deleted_net->{$point1}{$_} = $self->{Net}{$point1}{$_};
1896		    }
1897		    if (exists $self->{Net}{$_}{$point1}) {
1898			$deleted_net->{$_}{$point1} = $self->{Net}{$_}{$point1};
1899		    }
1900		}
1901		delete $self->{Net}{$point1}{$_};
1902		delete $self->{Net}{$_}{$point1};
1903	    }
1904	}
1905    } else {
1906	if (exists $self->{Net}{$point1}) {
1907	    if (defined $del_token && # XXX why?
1908		exists $self->{Net}{$point1}{$point2}) {
1909		$deleted_net->{$point1}{$point2} = $self->{Net}{$point1}{$point2};
1910	    }
1911	    delete $self->{Net}{$point1}{$point2};
1912	}
1913	if ($dir ne BLOCKED_ONEWAY) { # "2"
1914	    if (exists $self->{Net}{$point2}) {
1915		if (defined $del_token && # XXX why?
1916		    exists $self->{Net}{$point2}{$point1}) {
1917		    $deleted_net->{$point2}{$point1} = $self->{Net}{$point2}{$point1};
1918		}
1919		delete $self->{Net}{$point2}{$point1};
1920	    }
1921	}
1922    }
1923}
1924
1925# add_net: inject additional points into the net, typically a point
1926# between two points in a street segment.
1927#
1928# Parameters are:
1929# - $pos:         position (index) of the the street segment
1930# - $points[0]:   the inserted point as [$x,$y]
1931# - $points[1,2]: the neighbors of the inserted point, also as [$x,$y]
1932#
1933# Internally the data structures AdditionalNet, AdditionalDelNet and
1934# AdditionalDelNet2Name exist which have all operations done here
1935# recorded, and which are used in reset() to undo the additional points.
1936#
1937# Limited support for WideNet exists.
1938### AutoLoad Sub
1939sub add_net {
1940    my($self, $pos, @points) = @_;
1941    return unless defined $pos;
1942    die 'Es m�ssen genau 3 Punkte in @points sein!' if @points != 3;
1943    my $Net = $self->{Net};
1944    my $Net2Name = $self->{Net2Name};
1945    # additional check: for (@points) { die "add_net: all points should be array refs" if !UNIVERSAL::isa($_,"ARRAY") }
1946    my($startx, $starty) = @{$points[0]};
1947    require Route;
1948    my $starts = Route::_coord_as_string([$startx,$starty]);
1949    my @ex_point;
1950    my @entf;
1951    for (1..2) {
1952	$ex_point[$_] = Route::_coord_as_string($points[$_]);
1953    }
1954    my $rueckwaerts = 0;
1955    if ($Net2Name && exists $Net2Name->{$ex_point[2]}{$ex_point[1]}) {
1956        $rueckwaerts = 1;
1957    }
1958
1959    my $i;
1960    for($i=1; $i<=2; $i++) {
1961        my $s = $ex_point[$i];
1962	my $entf = $entf[$i] = Strassen::Util::strecke($points[0], $points[$i]);
1963	if (!exists $Net->{$starts}{$s}) {
1964	    $self->store_to_hash($Net, $starts, $s, $entf);
1965	    push @{$self->{AdditionalNet}}, [$starts, $s];
1966	}
1967	if (!exists $Net->{$s}{$starts}) {
1968	    $self->store_to_hash($Net, $s, $starts, $entf);
1969	    push @{$self->{AdditionalNet}}, [$s, $starts];
1970	}
1971	# XXX $pos ist hier immer definiert...
1972	if ($Net2Name && !exists $Net2Name->{$starts}{$s} &&
1973	    defined $pos) {
1974  	    if (($i == 1 && $rueckwaerts) || $i == 2) {
1975		$self->store_to_hash($Net2Name, $starts, $s, $pos);
1976	    } else {
1977		$self->store_to_hash($Net2Name, $s, $starts, $pos);
1978            }
1979	}
1980    }
1981
1982    if (exists $Net->{$ex_point[1]}{$ex_point[2]}) {
1983	push @{$self->{AdditionalDelNet}}, [$ex_point[1], $ex_point[2], delete $Net->{$ex_point[1]}{$ex_point[2]}];
1984	if ($Net2Name && exists $Net2Name->{$ex_point[1]}{$ex_point[2]}) {
1985	    push @{$self->{AdditionalDelNet2Name}}, [$ex_point[1], $ex_point[2], delete $Net2Name->{$ex_point[1]}{$ex_point[2]}];
1986	}
1987    }
1988    if (exists $Net->{$ex_point[2]}{$ex_point[1]}) {
1989	push @{$self->{AdditionalDelNet}}, [$ex_point[2], $ex_point[1], delete $Net->{$ex_point[2]}{$ex_point[1]}];
1990	if ($Net2Name && exists $Net2Name->{$ex_point[2]}{$ex_point[1]}) {
1991	    push @{$self->{AdditionalDelNet2Name}}, [$ex_point[2], $ex_point[1], delete $Net2Name->{$ex_point[2]}{$ex_point[1]}];
1992	}
1993    }
1994
1995    if ($self->{WideNet}) {
1996	# XXX AdditionalDelNet and AdditionalDelNet2Name support is missing
1997	my $wide_neighbors = $self->{WideNet}{WideNeighbors};
1998	my $intermediates_hash = $self->{WideNet}{Intermediates};
1999
2000	my($n1, $n2);
2001	if (!defined $wide_neighbors->{$ex_point[1]} &&
2002	    !defined $wide_neighbors->{$ex_point[2]}) {
2003	    # Beide Endpunkte sind bereits Kreuzungspunkte
2004	    ($n1, $n2) = ($ex_point[1], $ex_point[2]);
2005	    $wide_neighbors->{$starts} =
2006		[$n1, $entf[1],
2007		 $n2, $entf[2],
2008		];
2009	} else {
2010	    my($ex1_n1_dist, $ex1_n2_dist);
2011	    if (defined $wide_neighbors->{$ex_point[1]}) {
2012		($n1, $ex1_n1_dist, $n2, $ex1_n2_dist) =
2013		    @{ $wide_neighbors->{$ex_point[1]} };
2014	    } else {
2015		($n1, $ex1_n1_dist, $n2, $ex1_n2_dist) =
2016		    @{ $wide_neighbors->{$ex_point[2]} };
2017	    }
2018
2019	    my $total_len = $ex1_n1_dist + $ex1_n2_dist;
2020	    $wide_neighbors->{$starts} =
2021		[$n1,
2022		 $total_len - $ex1_n2_dist - $entf[2],
2023		 $n2,
2024		 $total_len - $ex1_n1_dist - $entf[1],
2025		];
2026	}
2027return; # XXX?????????????????
2028	for my $def ([$n1, $n2],
2029		     [$n2, $n1]) {
2030	    my $intermediates = $intermediates_hash->{$def->[0]}{$def->[1]};
2031	    if ($intermediates) {
2032		my @test_interm = @$intermediates;
2033	    TRY: {
2034		    for(my $i=0; $i<$#test_interm; $i++) {
2035			if ($test_interm[$i]   eq $ex_point[1] &&
2036			    $test_interm[$i+1] eq $ex_point[2]) {
2037			    $intermediates_hash->{$def->[0]}{$starts}
2038				= [@{$intermediates}[0 .. $i]];
2039			    $intermediates_hash->{$starts}{$def->[1]}
2040				= [@{$intermediates}[$i+1 .. $#$intermediates]];
2041			    last TRY;
2042			} elsif ($test_interm[$i]   eq $ex_point[2] &&
2043				 $test_interm[$i+1] eq $ex_point[1]) {
2044warn "#XXXny";
2045#  			    $intermediates_hash->{$def->[1]}{$starts}
2046#  				= [@{$intermediates}[0 .. $i]];
2047#  			    $intermediates_hash->{$starts}{$def->[0]}
2048#  				= [@{$intermediates}[$i+1 .. $#$intermediates]];
2049			}
2050		    }
2051		    warn "$ex_point[1]/$ex_point[2] not found in @test_interm";
2052		}
2053	    } else {
2054		warn "No intermediates for $def->[0] to $def->[1]";
2055	    }
2056	}
2057    }
2058}
2059
2060# del_add_net() undos all operations done in preceding add_net() calls.
2061### AutoLoad Sub
2062sub del_add_net {
2063    my $self = shift;
2064
2065    foreach my $b (@{$self->{AdditionalNet}}) {
2066	delete $self->{Net}{$b->[0]}{$b->[1]};
2067	if (exists $self->{Net2Name}{$b->[0]}{$b->[1]}) {
2068	    delete $self->{Net2Name}{$b->[0]}{$b->[1]};
2069	}
2070    }
2071    @{$self->{AdditionalNet}} = ();
2072
2073    foreach my $def (reverse @{$self->{AdditionalDelNet} || []}) {
2074	my($p1,$p2,$val) = @$def;
2075	$self->{Net}{$p1}{$p2} = $val;
2076    }
2077    @{$self->{AdditionalDelNet}} = ();
2078
2079    foreach my $def (reverse @{$self->{AdditionalDelNet2Name} || []}) {
2080	my($p1,$p2,$val) = @$def;
2081	$self->{Net2Name}{$p1}{$p2} = $val;
2082    }
2083    @{$self->{AdditionalDelNet2Name}} = ();
2084}
2085
2086*reachable = \&reachable_1;
2087
2088# Falls die Koordinate nicht exakt im Netz existiert, wird der n�chstgelegene
2089# Punkt gesucht und zur�ckgegeben, ansonsten der exakte Punkt.
2090# Die Koordinate ist im "x,y"-Format angegeben.
2091# XXX Funktioniert die Methode auch mit Data_Format 2?
2092### AutoLoad Sub
2093sub fix_coords {
2094    my($self, $coord) = @_;
2095    if (!$self->reachable($coord)) {
2096	$self->make_crossings();
2097	my(@nearest) = $self->{Crossings}->nearest_coord($coord);
2098	if (@nearest) {
2099	    $nearest[0];
2100	} else {
2101	    warn "Can't find another point near to $coord.\n";
2102	    undef;
2103	}
2104    } else {
2105	$coord;
2106    }
2107}
2108
2109### AutoLoad Sub
2110sub make_crossings {
2111    my $self = shift;
2112    if (!defined $self->{Crossings}) {
2113	require Strassen::Kreuzungen;
2114	warn "In StrassenNetz::make_crossings...\n" if $VERBOSE;
2115	$self->{CrossingsHash} = $self->{Strassen}->all_crossings
2116	    (RetType => 'hash', UseCache => 1);
2117	$self->{Crossings} = Kreuzungen->new(Hash => $self->{CrossingsHash});
2118	$self->{Crossings}->make_grid;
2119	warn "...done\n" if $VERBOSE;
2120    }
2121}
2122
2123sub null { }
2124
2125# XXX sollte ge�ndert werden, so dass echtes Subclassing verwendet
2126# wird (etwa wie f�r CNetFile)
2127### AutoLoad Sub
2128sub use_data_format {
2129    my $self;
2130    if (@_) {
2131	if (ref $_[0] && $_[0]->isa("StrassenNetz")) {
2132	    $self = shift;
2133	}
2134    }
2135    if (@_) {
2136	$data_format = shift;
2137    }
2138    if ($self) {
2139	if ($data_format == $FMT_MMAP) {
2140	    require StrassenNetz::CNetFileDist;
2141	    bless $self, "StrassenNetz::CNetFile";
2142	} else {
2143	    bless $self, "StrassenNetz";
2144	}
2145    }
2146
2147    my $a = shift;
2148    if (defined $a) {
2149	$data_format = $a;
2150    }
2151
2152    local($^W) = 0;
2153
2154    if ($data_format == $FMT_MMAP) {
2155	# nothing to do
2156    } elsif ($data_format == $FMT_CDB) {
2157	require Strassen::CDB;
2158	use_data_format_cdb();
2159    } else {
2160	*make_net        = ($data_format == $FMT_HASH ? \&make_net_slow_1 : \&make_net_slow_2);
2161	*net_read_cache  = ($data_format == $FMT_HASH ? \&net_read_cache_1 : \&net_read_cache_2);
2162	*net_write_cache = ($data_format == $FMT_HASH ? \&net_write_cache_1 : \&net_write_cache_2);
2163	*make_sperre     = ($data_format == $FMT_HASH ? \&make_sperre_1 : \&null);
2164	*route_to_name   = ($data_format == $FMT_HASH ? \&route_to_name_1 : \&route_to_name_2);
2165	*reachable       = ($data_format == $FMT_HASH ? \&reachable_1 : \&reachable_2);
2166	# XXX restliche ...
2167    }
2168}
2169
2170sub DESTROY { }
2171
2172*make_net_classic = *make_net_classic if 0; # peacify -w
2173
21741;
2175