1# -*- perl -*-
2
3#
4# Copyright (c) 1995-2001,2010 Slaven Rezic. All rights reserved.
5# This is free software; you can redistribute it and/or modify it under the
6# terms of the GNU General Public License, see the file COPYING.
7#
8# Mail: slaven@rezic.de
9# WWW:  http://bbbike.sourceforge.net
10#
11
12package Strassen::CoreHeavy;
13
14package Strassen;
15use strict;
16
17# Gibt die Positionsnummern aller Stra�en aus $str_ref als Liste aus.
18# $str_ref ist eine Liste von [Stra�enname, Bezirk]-Elementen
19# Falls eine Stra�e durch mehrere Bezirke f�hrt, wird nur _eine_ Position
20# zur�ckgegeben.
21### AutoLoad Sub
22sub union {
23    my($self, $str_ref, %args) = @_;
24
25    my $uniq = !$args{Nouniq};
26
27    my %str;
28    foreach (@$str_ref) {
29	$str{$_->[0]}->{$_->[1]}++;
30    }
31
32    my %res;
33    $self->init;
34    my $last;
35    while(1) {
36	my $ret = $self->next;
37	last if !@{$ret->[COORDS]};
38	my $name = $ret->[NAME];
39	if ($uniq) {
40	    if (defined $last && $last eq $name) {
41		next;
42	    } else {
43		$last = $name;
44	    }
45	}
46	my @bez;
47	if ($name =~ /^(.*)\s+\((.*)\)$/) {
48	    $name = $1;
49	    @bez = split(/,\s*/, $2);
50	}
51	if (exists $str{$name}) {
52	    if (@bez) {
53		foreach my $bez (@bez) {
54		    if (exists $str{$name}->{$bez}) {
55			$res{$self->pos}++;
56			last;
57		    }
58		}
59	    } else {
60		$res{$self->pos}++;
61	    }
62	}
63    }
64    keys %res;
65}
66
67# Create a new Strassen object from $self and remove points specified
68# in Strassen object $to_remove.
69sub new_with_removed_points {
70    my($self, $to_remove, %args) = @_;
71    my $new_s = Strassen->new;
72    $new_s->_clone_some_globals($self);
73    require Strassen::Kreuzungen;
74    my $kr = Kreuzungen->new_from_strassen(Strassen => $to_remove);
75    my $h = $kr->{Hash};
76    $self->init;
77    while(1) {
78	my $r = $self->next;
79	last if !@{ $r->[COORDS] };
80	my @newcoords = ([]);
81	for my $p (@{ $r->[COORDS] }) {
82	    if (!exists $h->{$p}) {
83		CORE::push @{$newcoords[-1]}, $p;
84	    } else {
85		CORE::push @newcoords, [] if @{$newcoords[-1]} != 0;
86	    }
87	}
88	pop @newcoords if @{$newcoords[-1]} == 0;
89	for my $new_c (@newcoords) {
90	    $new_s->push([$r->[NAME], $new_c, $r->[CAT]]);
91	    my $dir = $self->get_directives;
92	    $new_s->set_directives_for_current($dir) if $dir;
93	}
94    }
95    #$new_s->{Id} = $self->id . "_removed_" . $to_remove->id;
96    $new_s->{DependentFiles} = [$self->dependent_files,
97				$to_remove->dependent_files];
98    $new_s;
99}
100
101# XXX make gzip-aware
102# XXX does not work for MultiStrassen
103# %arg:
104# NoDot: keine Ausgabe von "...", wenn zu viele Matches existieren
105# NoStringApprox: do not use String::Approx, even if available
106# ErrorDef: Angabe der Reihenfolge (match begin, match errors)
107# Agrep: maximale Anzahl von erlaubten Fehlern
108# Return value: Array with matched street names
109### AutoLoad Sub
110sub agrep {
111    my($self, $pattern, %arg) = @_;
112
113    my @paths;
114    my @files;
115    my $file = $self->{File};
116    if (ref $file eq 'ARRAY') {
117	@files = @$file;
118    } else {
119	CORE::push(@files, $file);
120    }
121
122    my $file_encoding = $self->get_global_directive("encoding");
123
124    foreach my $file (@files) {
125	my $path;
126	if (-r $file) {
127	    $path = $file;
128	} else {
129	    foreach (@datadirs) {
130		if (-r "$_/$file") {
131		    $path = "$_/$file";
132		    last;
133		}
134	    }
135	}
136	if (!defined $path) {
137	    warn "File $file not found in @datadirs.\n";
138	    return undef;
139	}
140	CORE::push(@paths, $path);
141    }
142
143    my $grep_type;
144    my @data;
145    if (!$OLD_AGREP && is_in_path('agrep')) {
146	$grep_type = 'agrep';
147	# agrep does not cope with utf-8, so convert to octets
148	if (defined $file_encoding) {
149	    eval {
150		require Encode;
151		$pattern = Encode::encode($file_encoding, $pattern);
152	    };
153	    warn $@ if $@;
154	}
155	$pattern =~ s/(.)/\\$1/g;
156    } else {
157	foreach my $path (@paths) {
158	    open(F, $path) or die "Can't open $path: $!";
159	    if (defined $file_encoding) {
160		switch_encoding(\*F, $file_encoding);
161	    }
162	    my @file_data;
163	    chomp(@file_data = <F>);
164	    CORE::push(@data, @file_data);
165	    close F;
166	}
167	return () if !@data;
168	eval { local $SIG{'__DIE__'};
169	       die if $arg{NoStringApprox};
170	       require String::Approx;
171	       String::Approx->VERSION(2.7);
172	   };
173	if (!$@) {
174	    $grep_type = 'approx';
175	} else {
176	    $grep_type = 'perl';
177	}
178    }
179    my @def;
180    if ($arg{ErrorDef}) {
181	@def = @{$arg{ErrorDef}};
182    } else {
183	@def = ([1, 0],
184		[1, 1],
185		[1, 2],
186		[0, 0],
187		[0, 1],
188		[0, 2],
189		[0, 3],
190	       );
191    }
192    for my $def (@def) {
193	my($begin, $err, @extra) = @$def;
194	next if (exists $arg{Agrep} && $err > $arg{Agrep});
195	my @this_res;
196	my $grep_pattern = $pattern;
197	if (grep($_ eq 'strasse', @extra)) {
198            next if ($grep_pattern !~ s/(s)tra�e$/$1tr./i);
199	}
200	if ($grep_type eq 'agrep') {
201	    my @args = '-i';
202	    $grep_pattern = ($begin ? "^$grep_pattern" : $grep_pattern);
203	    if ($err > 0) { CORE::push(@args, "-$err") }
204	    open(AGREP, "-|") or
205	      exec 'agrep', @args, $grep_pattern, @paths or
206		die "Can't exec program: $!";
207	    if (defined $file_encoding) {
208		switch_encoding(\*AGREP, $file_encoding);
209	    }
210	    chomp(@this_res = <AGREP>);
211	    close AGREP;
212	} elsif ($grep_type eq 'approx' && $err) {
213	    next if $begin || $err > 2; # Bug bei $err == 3
214	    $grep_pattern =~ s/[()]/./g; # String::Approx-Bug?
215	    @this_res = String::Approx::amatch
216	      ($grep_pattern, ['i', $err], @data);
217	} else { # weder agrep noch String::Approx
218	    $grep_pattern = ($begin ? "^$grep_pattern" : $grep_pattern);
219	    if ($err == 0) {
220		@this_res = grep(/\Q$grep_pattern\E/i, @data);
221	    } elsif ($err == 1) { # metacharacter erlauben
222		@this_res = grep(/$grep_pattern/i, @data);
223	    } else {
224		next;
225	    }
226	}
227	@this_res = grep { !/^#/ } @this_res;
228	if (@this_res == 1) {
229	    return parse($this_res[0])->[NAME];
230	} elsif (@this_res) {
231	    my(@res1, @res2, @res3);
232	    my $i = 0;
233	    my $last_name;
234	    foreach (@this_res) {
235		$i++;
236		my $name = parse($_)->[NAME];
237		if (defined $last_name && $last_name eq $name) {
238		    next;
239		} else {
240		    $last_name = $name;
241		}
242		if ($name eq $pattern) {
243		    return $name;
244		} elsif ($name =~ /^\Q$pattern\E/i) {
245		    CORE::push(@res1, $name);
246		} elsif ($i < 20) {
247		    CORE::push(@res2, $name);
248		} elsif ($i == 20) {
249		    CORE::push(@res3, "...") unless $arg{NoDot};
250		}
251	    }
252	    @res1 = sort @res1;
253	    @res2 = sort @res2;
254	    return @res1, @res2, @res3;
255	}
256    }
257    ();
258}
259
260# Sucht Stra�e anhand des Bezirkes.
261# $bezirk may be in the form "citypart1, citypart2, ..."
262# Return value is context-sensitive:
263#   in list context, return list of positions
264#   in scalar context, return position of first match or undef
265### AutoLoad Sub
266sub choose_street {
267    my($str, $strasse, $bezirk, %args) = @_;
268    my @bezirk = defined $bezirk ? (split /\s*,\s*/, $bezirk) : ();
269    my @pos;
270    $str->init;
271    while(1) {
272	my $ret = $str->next;
273	last if !@{$ret->[COORDS]};
274	my $check_strasse = $ret->[NAME];
275	if (substr($check_strasse, 0, length($strasse)) eq $strasse) {
276#	if ($check_strasse =~ /^$strasse/) {
277	    my %bez;
278	    if ($check_strasse =~ /(.*)\s+\((.*)\)/) {
279		$check_strasse = $1;
280		foreach (split(/\s*,\s*/, $2)) {
281		    $bez{$_}++;
282		}
283		for my $bezirk (@bezirk) {
284		    if (exists $bez{$bezirk}) {
285			if (wantarray) {
286			    CORE::push(@pos, $str->pos);
287			} else {
288			    return $str->pos;
289			}
290			last;
291		    }
292		}
293	    } elsif ($check_strasse eq $strasse) {
294		if (wantarray) {
295		    CORE::push(@pos, $str->pos);
296		} else {
297		    return $str->pos;
298		}
299	    }
300	}
301    }
302    if (wantarray) {
303	@pos;
304    } else {
305	undef;
306    }
307}
308
309sub copy_orig {
310    my $self = shift;
311    require Strassen::Util;
312    if (! -d $Strassen::Util::tmpdir) {
313	warn "$Strassen::Util::tmpdir does not exist" if $VERBOSE;
314	return;
315    }
316    my $origdir = $self->get_diff_orig_dir;
317    return if !$origdir;
318
319    my @file = $self->file;
320    if (!@file) {
321	warn "File not defined" if $VERBOSE;
322	return;
323    }
324    foreach (@file) {
325	if (!-f $_) {
326	    warn "<$_> does not exist" if $VERBOSE;
327	    return;
328	}
329    }
330    my $dest = $self->get_diff_file_name;
331    if ($self->write($dest, IgnoreDirectives => 1)) {
332	$self->{OrigFile} = $dest;
333	1;
334    } else {
335	delete $self->{OrigFile};
336	0;
337    }
338}
339
340sub get_diff_orig_dir {
341    # ignore $self
342    my $origdir = "$Strassen::Util::tmpdir/bbbike-orig-$<";
343    if (! -d $origdir) {
344	mkdir $origdir, 0700;
345	if (! -d $origdir) {
346	    warn "Can't create $origdir: $!" if $VERBOSE;
347	    return;
348	}
349    }
350    $origdir;
351}
352
353sub get_diff_file_name {
354    my($self) = @_;
355    my @file = $self->file;
356    my $origdir = get_diff_orig_dir;
357    require File::Basename;
358    my $dest = "$origdir/" . join("_", map { defined $_ ? File::Basename::basename($_) : "???" } @file);
359    $dest;
360}
361
362# Erzeugt die Differenz aus dem aktuellen Strassen-Objekt und der
363# letzten Version, die (evtl.) in $origdir abgelegt ist.
364# R�ckgabe: (Strassen-Objekt mit neuen Stra�en, zu l�schenden Indices)
365# Argumente: -clonefile => 1: das File-Argument wird in das neue Objekt
366#            kopiert
367### AutoLoad Sub
368sub diff_orig {
369    my($self, %args) = @_;
370    require File::Basename;
371    require Strassen::Util;
372    my $origdir = $self->get_diff_orig_dir;
373    my $first_file = $self->get_diff_file_name;
374    if (!defined $self->{OrigFile}) {
375	$self->{OrigFile} =
376	  "$origdir/" . File::Basename::basename($first_file);
377    }
378    if (! -f $self->{OrigFile}) {
379	warn "<$self->{OrigFile}> does not exist" if $VERBOSE;
380	delete $self->{OrigFile};
381	return;
382    }
383
384    my $use_diff_tool;
385    # XXX check order not yet clear
386    if (eval { require Text::Diff; 1 }) {
387	$use_diff_tool = "Text::Diff";
388    } elsif (is_in_path("diff")) {
389	$use_diff_tool = "diff";
390    }
391
392    if (!$use_diff_tool) {
393	warn "diff not found in path or Text::Diff not available" if $VERBOSE;
394	return;
395    }
396
397    my $dest = "$origdir/" . File::Basename::basename($first_file) . ".new";
398    return unless $self->write($dest, IgnoreDirectives => 1);
399
400    my $old_line = 1;
401    my $new_line = 1;
402    my(@del, @add, %index_mapping);
403
404    if ($use_diff_tool eq 'diff') {
405	my $diff_cmd = "diff -u $self->{OrigFile} $dest |";
406	#warn $diff_cmd;
407	open(DIFF, $diff_cmd) or die $!;
408    } else {
409	my $diff = Text::Diff::diff($self->{OrigFile}, $dest, {STYLE => "Unified"});
410	eval 'open(DIFF, "<", \$diff) or die $!;';
411	if ($@) {
412	    warn "Need fallback ($@)";
413	    my $diff_fallback_file = "/tmp/bbbike_diff_fallback_" . $< . ".diff";
414	    open(DIFFOUT, "> $diff_fallback_file")
415		or die $!;
416	    binmode DIFFOUT;
417	    print DIFFOUT $diff;
418	    close DIFFOUT
419		or die $!;
420
421	    open(DIFF, $diff_fallback_file);
422	}
423    }
424    scalar <DIFF>; scalar <DIFF>; # overread header
425    while(<DIFF>) {
426	chomp;
427	if (/^\@\@\s*-(\d+).*\+(\d+)/) {
428	    $old_line = $1;
429	    $new_line = $2;
430	} elsif (/^\+(.*)/) {
431	    CORE::push(@add, "$1\n");
432	    $index_mapping{$#add} = $new_line-1;
433	    $new_line++;
434	} elsif (/^-/) {
435	    CORE::push(@del, $old_line-1); # warum -1?
436	    $old_line++;
437	} elsif (!/^[ \\]/) {
438	    warn "Unknown diff line: $_";
439	} else {
440	    $old_line++;
441	    $new_line++;
442	}
443    }
444    close DIFF;
445
446    unlink $dest;
447    my $new_s = new_from_data Strassen @add;
448    if ($args{-clonefile}) {
449	$new_s->{File} = $self->{File};
450    }
451    ($new_s, \@del, \%index_mapping);
452}
453
454# Create array reference from Data property:
455# [[$name, $category, ["$x1,$y1", "$x2,$y2" ...]],
456#  [$name2, ...]
457# ]
458# Warning: this method resets any init/next loop!
459### AutoLoad Sub
460sub as_array {
461    my $self = shift;
462    my $ret = [];
463    $self->init;
464    while(1) {
465	my $r = $self->next;
466	last if !@{$r->[COORDS]};
467	my $new_item = [$r->[NAME], $r->[CAT], $r->[COORDS]];
468	CORE::push(@$ret, $new_item);
469    }
470    $ret;
471}
472
473# Create a reverse hash pointing from a point to a list of streets
474# containing this point:
475# { "$x1,$y1" => [$streetname1, $streetname2 ...], ... }
476# Warning: this method resets any init/next loop!
477### AutoLoad Sub
478sub as_reverse_hash {
479    my $self = shift;
480    my $rev_hash = {};
481    $self->init;
482    while(1) {
483	my $r = $self->next;
484	last if !@{$r->[COORDS]};
485	foreach my $c (@{$r->[COORDS]}) {
486	    if (exists $rev_hash->{$c}) {
487		CORE::push(@{ $rev_hash->{$c} }, $r->[NAME]);
488	    } else {
489		$rev_hash->{$c} = [$r->[NAME]];
490	    }
491	}
492    }
493    $rev_hash;
494}
495
496# Given a Strassen file and a position, return the linenumber (starting
497# at 1). This function will skip all comment lines.
498### AutoLoad Sub
499sub get_linenumber {
500    my($strfile, $pos) = @_;
501    my $orig_pos = $pos;
502    my $linenumber = 0;
503    open(STR, $strfile) or die "Can't open $strfile: $!";
504    while(<STR>) {
505	$linenumber++;
506	next if /^( \# | \s*$ )/x;
507	if ($pos == 0) {
508            close STR;
509	    return $linenumber;
510	}
511	$pos--;
512    }
513    close STR;
514    warn "Can't find position $orig_pos in file $strfile";
515    undef;
516}
517
518# Resets iterator
519# XXX does not preserve global directives (yet)
520### AutoLoad Sub
521sub filter_region {
522    my($s, $type, $x1,$y1, $x2,$y2) = @_;
523    my $new_s = Strassen->new;
524    $new_s->_clone_some_globals($s);
525    $s->init;
526    while(1) {
527	my $r = $s->next;
528	last if !@{ $r->[COORDS] };
529	my $ret;
530	if ($type eq 'enclosed') {
531	    # XXX works only for one point
532	    my($x,$y) = split /,/, $r->[COORDS][0];
533	    $ret = ($x1 <= $x && $x2 >= $x &&
534		    $y1 <= $y && $y2 >= $y);
535	} else {
536	    die "XXX type $type NYI";
537	}
538	if ($ret) {
539	    $new_s->push($r);
540	}
541    }
542    $new_s;
543}
544
545# Resets iterator
546# XXX does not preserve global directives (yet)
547# Arguments: -date (optional, default is today)
548#            -negpos (optional, default is 0=negative, matches are deleted)
549### AutoLoad Sub
550sub filter_date {
551    my($s, %args) = @_;
552
553    my $date = $args{-date};
554    if (!defined $date) {
555	my @l = localtime;
556	$date = sprintf "%04d-%02d-%02d", $l[5]+1900, $l[4]+1, $l[3];
557    }
558
559    my $neg_pos = $args{-negpos} || 0;
560
561    my $new_s = Strassen->new;
562    $new_s->_clone_some_globals($s);
563    $s->init;
564    while(1) {
565	my $r = $s->next;
566	last if !@{ $r->[COORDS] };
567	my $hit;
568	if ($r->[NAME] =~ /(\d{4}-\d{2}-\d{2})\s*(?:-|bis)\s*(\d{4}-\d{2}-\d{2})/
569	    && ($date lt $1 || $date gt $2)) {
570	    if ($neg_pos == 0) {
571		next;
572	    } else {
573		$hit = 1;
574	    }
575	} elsif ($r->[NAME] =~ /(?:-|bis)\s*(\d{4}-\d{2}-\d{2})/
576		 && $date le $1) {
577	    if ($neg_pos == 0) {
578		next;
579	    } else {
580		$hit = 1;
581	    }
582	} elsif ($r->[NAME] =~ /(\d{4}-\d{2}-\d{2})\s*(?:-|bis)/
583		 && $date ge $1) {
584	    if ($neg_pos == 0) {
585		next;
586	    } else {
587		$hit = 1;
588	    }
589	}
590	if ($neg_pos == 0 || $hit) {
591	    $new_s->push($r);
592	}
593    }
594    $new_s;
595}
596
597# XXX german/multilingual labels?
598# use as: $mw->getOpenFile(-filetypes => [Strassen->filetypes])
599sub filetypes {
600    (['bbd Files' => '.bbd'],
601     ['Compressed bbd Files' => '.bbd.gz'],
602     ['All Files' => '*']);
603}
604
605# Create a hash reference "x1,y1_x2,y2" => [position,...] in data array.
606# Optional $restrict should hold a callback returning 0 if the record
607# should be ignored, 1 for normal processing and 2 for using both
608# directions.
609# Warning: this method resets any init/next loop!
610sub make_coord_to_pos {
611    my($s, $restrict) = @_;
612    my $hash = {};
613    $s->init;
614    while(1) {
615	my $r = $s->next;
616	last if !@{$r->[COORDS]};
617	my $restrict = $restrict->($r);
618	next if !$restrict;
619	for my $i (1 .. $#{$r->[COORDS]}) {
620	    CORE::push @{$hash->{$r->[COORDS]->[$i-1]."_".$r->[COORDS]->[$i]}}, $s->{Pos};
621	    if ($restrict == 2) {
622		CORE::push @{$hash->{$r->[COORDS]->[$i]."_".$r->[COORDS]->[$i-1]}}, $s->{Pos};
623	    }
624	}
625    }
626    $hash;
627}
628
629# Read/write bounding box file
630# Ack: resets the iterator if writing!
631### AutoLoad Sub
632sub bboxes {
633    my($self) = @_;
634
635    return $self->{BBoxes} if $self->{BBoxes};
636
637    my @bboxes;
638    $self->init;
639    while(1) {
640	my $r = $self->next;
641	last if !@{ $r->[Strassen::COORDS] };
642
643	my @p;
644	foreach (@{ $r->[Strassen::COORDS] }) {
645	    CORE::push(@p, split /,/, $_);
646	}
647
648	my(@bbox) = ($p[0], $p[1], $p[0], $p[1]);
649	for(my $i=2; $i<$#p-1; $i+=2) {
650	    $bbox[0] = $p[$i] if ($p[$i] < $bbox[0]);
651	    $bbox[2] = $p[$i] if ($p[$i] > $bbox[2]);
652	    $bbox[1] = $p[$i+1] if ($p[$i+1] < $bbox[1]);
653	    $bbox[3] = $p[$i+1] if ($p[$i+1] > $bbox[3]);
654	}
655
656	CORE::push @bboxes, \@bbox;
657    }
658
659    $self->{BBoxes} = \@bboxes;
660    \@bboxes;
661}
662
663# Return the bounding box of the file
664# Ack: resets the iterator
665sub bbox {
666    my($self) = @_;
667    $self->init;
668    my($x1,$y1,$x2,$y2);
669    while(1) {
670	my $r = $self->next;
671	last if !@{ $r->[Strassen::COORDS] };
672	for (@{ $r->[Strassen::COORDS] }) {
673	    my($x,$y) = split /,/;
674	    $x1 = $x if !defined $x1 || $x1 > $x;
675	    $x2 = $x if !defined $x2 || $x2 < $x;
676	    $y1 = $y if !defined $y1 || $y1 > $y;
677	    $y2 = $y if !defined $y2 || $y2 < $y;
678	}
679    }
680    ($x1,$y1,$x2,$y2);
681}
682
683# $catref is either a hash reference of category => level mapping or a
684# an array reference of categories. Lower categories should be first.
685sub sort_by_cat {
686    my($self, $catref, %args) = @_;
687    $catref = $self->default_cat_stack_mapping if !$catref;
688    my %catval;
689    if (ref $catref eq 'HASH') {
690	%catval = %$catref;
691    } else {
692	my $i = 0;
693	$catval{$_} = $i++ foreach (@$catref);
694    }
695    my %ignore;
696    %ignore = map { ($_,1) } @{ $args{-ignore} } if $args{-ignore};
697
698    my $data = $self->{Data};
699    my $directives = $self->{Directives} || [];
700    my @data_and_directives;
701    for my $i (0 .. $#$data) {
702	CORE::push @data_and_directives, [$data->[$i], $directives->[$i]];
703    }
704
705    @data_and_directives =
706	map  { $_->[1] }
707	sort {
708	    if (exists $ignore{$a->[2][CAT]} || exists $ignore{$b->[2][CAT]}) {
709		0;
710	    } else {
711		$a->[0] <=> $b->[0];
712	    }
713	}
714	map  { my $l = parse($_->[0]);
715	       [exists $catval{$l->[CAT]} ? $catval{$l->[CAT]} : 9999,
716		$_,
717		$l
718	       ]
719	} @data_and_directives;
720
721    $self->{Data} = [];
722    $self->{Directives} = [];
723    for my $i (0 .. $#data_and_directives) {
724	CORE::push @{ $self->{Data} }, $data_and_directives[$i]->[0];
725	CORE::push @{ $self->{Directives} }, $data_and_directives[$i]->[1];
726    }
727}
728
729# Generic sorting function. There are two approaches: with or without
730# map function for a Schwartzian Transform.
731#
732# First approach:
733# $sort_func: a subroutine reference which defines the sort function.
734# The subroutine must be prototyped with ($$). The incoming records are
735# hashrefs with two elements, the data element containing a
736# bbd line as a string, and the directives element containing the
737# directives hash.
738# $map_func is not used here and should be omitted.
739#
740# Second approach:
741# $sort_func: a subroutine references, also prototyped with ($$).
742# Here the incoming records are two-element arrayrefs, with the
743# original record at index zero (typically not be used) and the
744# sort value at index one.
745# $map_func: a function for a map() call which is calculating the
746# sort value. The incoming record is in $_, and contains both {data}
747# and {directives}
748#
749# See t/strassen-sort.t for usage examples.
750sub sort_by_anything {
751    my($self, $sort_func, $map_func) = @_;
752
753    my $data = $self->{Data};
754    my $directives = $self->{Directives} || [];
755    my @data_and_directives;
756    for my $i (0 .. $#$data) {
757	CORE::push @data_and_directives, {data => $data->[$i], directives => $directives->[$i]};
758    }
759
760    if ($map_func) {
761	@data_and_directives =
762	    map { $_->[0] }
763		sort $sort_func
764		    map { [ $_, $map_func->() ] }
765			@data_and_directives;
766    } else {
767	@data_and_directives =
768	    sort $sort_func
769		@data_and_directives;
770    }
771
772    $self->{Data} = [];
773    $self->{Directives} = [];
774    for my $i (0 .. $#data_and_directives) {
775	CORE::push @{ $self->{Data} }, $data_and_directives[$i]->{data};
776	CORE::push @{ $self->{Directives} }, $data_and_directives[$i]->{directives};
777    }
778
779}
780
781sub sort_records_by_cat {
782    my($class_or_self, $records, $catref, %args) = @_;
783    $catref = $class_or_self->default_cat_stack_mapping if !$catref;
784    return map  { $_->[1] }
785	   sort { $a->[0] <=> $b->[0] }
786	   map  { [(exists $catref->{$_->[CAT]} ? $catref->{$_->[CAT]} : 9999),
787		   $_
788		  ]
789	      } @$records;
790}
791
792sub default_cat_stack_mapping {
793    return {'F:W'          => 3, # Gew�sser
794	    'F:W1'         => 3, # Gew�sser
795	    'W'            => 3,
796	    'W1'           => 3,
797	    'W2'           => 3,
798	    'F:I'          => 6, # Insel
799	    'F:P'          => 15, # Parks
800
801	    # XXX This should be changed to real categories
802	    'F:#c08080'    => 10, # bebaute Fl�chen
803	    'F:violet'     => 20, # Industrie (alt)
804	    'F:Industrial' => 20, # Industrie
805	    'F:DarkViolet' => 21, # Hafen oder Industrie
806	    'F:#46b47b'    => 13, # Wald (alt)
807	    'F:Woods'      => 13, # Wald
808	    'F:Orchard'    => 13,
809	    'F:Sport'      => 13,
810	    'F:Green'      => 13,
811	    'F:Mine'	   => 13,
812
813	    'BAB'	   => 21,
814	    'B'            => 20,
815	    'HH'           => 15,
816	    'H'            => 10,
817	    'NH'	   => 7,
818	    'N'            => 5,
819	    'NN'           => 1,
820	    'Pl'	    => 0,
821
822	    # Orte
823	    6		   => 6,
824	    5		   => 5,
825	    4		   => 4,
826	    3		   => 3,
827	    2		   => 2,
828	    1		   => 1,
829	    0 		   => 0,
830	   };
831}
832
833
834sub is_current {
835    my($self) = @_;
836    my @dependent_files;
837    if ($self->dependent_files) {
838	@dependent_files = $self->dependent_files;
839    } elsif (defined $self->file) {
840	@dependent_files = $self->file;
841    }
842    return 1 if !@dependent_files;
843    # XXX Hmmm, what's right, what's wrong? Returning 1 helps in
844    # temp_blockings objects, where one subobj is a file-based
845    # Strassen object.
846    return 1 if !defined $self->{Modtime};
847    for my $f (@dependent_files) {
848	my $now_modtime = (stat($f))[STAT_MODTIME];
849	return 0 if $self->{Modtime} < $now_modtime;
850    }
851    return 1;
852}
853
854sub reload {
855    my($self) = @_;
856    return if $self->is_current;
857    if ($self->{RebuildCode}) {
858	$self->{RebuildCode}->();
859    } else {
860	warn "Reload " . $self->file . "...\n"
861	    if $VERBOSE;
862	$self->read_data;
863    }
864    if ($self->{Grid}) {
865	warn "Rebuild grid ...\n"
866	    if $VERBOSE;
867	$self->make_grid(-rebuild => 1);
868    }
869}
870
871# See also get_conversion
872sub get_anti_conversion {
873    my($self, %args) = @_;
874    my $convsub;
875    my $tomap = $self->{GlobalDirectives}{map} || $args{Map};
876    if ($tomap) {
877	require Karte;
878	Karte::preload(":all"); # Can't preload specific maps, because $map is a token, not a map module name
879	my $frommap = $args{-frommap} || "standard";
880	return if $tomap eq $frommap; # no conversion needed
881	if ($frommap ne "standard") {
882	    $convsub = sub {
883		join ",", $Karte::map{$frommap}->map2map($Karte::map{$tomap},
884							 split /,/, $_[0]);
885	    };
886	} else {
887	    $convsub = sub {
888		join ",", $Karte::map{$tomap}->standard2map(split /,/, $_[0]);
889	    };
890	}
891    }
892    $convsub;
893}
894
895# Filter by a subroutine.
896# Return a new Strassen object.
897# This method uses the "grepstreets" iterator (use this for
898# get_directive_for_iterator)
899# Arguments:
900#  -idadd => $string      add this string to the id of the created object
901#  -preservedir => $bool  preserve local directives
902# Note that global directives are always preserved.
903sub grepstreets {
904    my($s, $sub, %args) = @_;
905    my $new_s = Strassen->new;
906    $new_s->_clone_some_globals($s);
907    if ($args{-idadd}) {
908	my $id = $new_s->id;
909	$new_s->{Id} = $id . "_" . $args{-idadd};
910    }
911    my $preserve_dir = $args{-preservedir} || 0;
912    $s->init_for_iterator("grepstreets");
913    while(1) {
914	my $r = $s->next_for_iterator("grepstreets");
915	last if !@{$r->[Strassen::COORDS]};
916	local $_ = $r;
917	next if !&$sub;
918	if ($preserve_dir) {
919	    $new_s->push_ext($r, $s->get_directive_for_iterator("grepstreets"));
920	} else {
921	    $new_s->push($r);
922	}
923    }
924    $new_s;
925}
926
927# Simplify the object using the Douglas-Peucker algorithm.
928# Adapted from http://mapserver.gis.umn.edu/community/scripts/thin.pl
929# Note: this changes the self object
930sub simplify {
931    my($s, $tolerance) = @_;
932
933    $s->init;
934    while() {
935	my $r = $s->next;
936	my @c = @{ $r->[Strassen::COORDS] };
937	last if !@c;
938	next if $r->[Strassen::NAME] =~ m{^\#}; # skip comments (really needed???)
939	next if @c == 1;
940
941	my @new_c;
942	douglas_peucker(\@c, \@new_c, $tolerance);
943
944	$r->[Strassen::COORDS] = \@new_c;
945	$s->set_current2($r);
946    }
947}
948
949sub _distance_point_to_segment {
950    # from: mapsearch.c, msDistancePointToSegment
951    my($p, $a, $b) = @_;
952
953    require BBBikeUtil;
954    require Strassen::Util;
955
956    $p = [ Strassen::Util::string_to_coord($p) ];
957    $a = [ Strassen::Util::string_to_coord($a) ];
958    $b = [ Strassen::Util::string_to_coord($b) ];
959
960    my $l = Strassen::Util::strecke($a, $b);
961    if ($l == 0.0) { # a = b
962	return Strassen::Util::strecke($a, $p);
963    }
964
965    my $r = (($a->[1] - $p->[1])*($a->[1] - $b->[1]) -
966	     ($a->[0] - $p->[0])*($b->[0] - $a->[0]))/($l*$l);
967    if ($r > 1) { # perpendicular projection of P is on the forward extention of AB
968	return BBBikeUtil::min(Strassen::Util::strecke($p, $b),
969			       Strassen::Util::strecke($p, $a));
970    }
971    if ($r < 0) { # perpendicular projection of P is on the backward extention of AB
972	return BBBikeUtil::min(Strassen::Util::strecke($p, $b),
973			       Strassen::Util::strecke($p, $a));
974    }
975
976    my $s = (($a->[1] - $p->[1])*($b->[0] - $a->[0]) - ($a->[0] - $p->[0])*($b->[1] - $a->[1]))/($l*$l);
977
978    return abs($s*$l);
979}
980
981sub douglas_peucker {
982    my($c, $new_c, $tolerance) = @_;
983
984    my @stack = ();
985    my $anchor = $c->[0]; # save first point
986    CORE::push @$new_c, $anchor;
987    my $aIndex = 0;
988    my $fIndex = $#$c;
989    CORE::push @stack, $fIndex;
990
991    # Douglas - Peucker algorithm
992    while (@stack) {
993	$fIndex = $stack[$#stack];
994	my $fPoint = $c->[$fIndex];
995	my $max = $tolerance; # comparison values
996	my $maxIndex = 0;
997
998	# process middle points
999	for (($aIndex+1) .. ($fIndex-1)) {
1000
1001	    my $point = $c->[$_];
1002	    # XXX wrong! should be distanceToSegment!!!
1003	    my $dist = _distance_point_to_segment($point, $anchor, $fPoint);
1004
1005	    if ($dist >= $max) {
1006		$max = $dist;
1007		$maxIndex = $_;
1008	    }
1009	}
1010
1011	if ($maxIndex > 0) {
1012	    CORE::push @stack, $maxIndex;
1013	} else {
1014	    CORE::push @$new_c, $fPoint;
1015	    $anchor = $c->[pop @stack];
1016	    $aIndex = $fIndex;
1017	}
1018    }
1019}
1020
1021sub _clone_some_globals {
1022    my($new_s, $s) = @_;
1023    $new_s->{DependentFiles} = [ $s->dependent_files ];
1024    require Storable;
1025    $new_s->set_global_directives(Storable::dclone($s->get_global_directives));
1026}
1027
1028# Just a quick check if all dependent files are the same, and the
1029# objects have the same modtime recorded. Return 1 if the structures
1030# are considered the same.
1031sub shallow_compare {
1032    my($self, $other_self) = @_;
1033
1034    my $modtime       = $self->{Modtime};
1035    my $other_modtime = $other_self->{Modtime};
1036    return 0 if  defined $modtime && !defined $other_modtime;
1037    return 0 if !defined $modtime &&  defined $other_modtime;
1038    return 0 if (defined $modtime && defined $other_modtime && $modtime != $other_modtime);
1039
1040    my @dependent_files       = $self->dependent_files;
1041    my @other_dependent_files = $other_self->dependent_files;
1042    return 0 if scalar(@dependent_files) != scalar(@other_dependent_files);
1043    for my $i (0 .. $#dependent_files) {
1044	return 0 if $dependent_files[$i] ne $other_dependent_files[$i];
1045    }
1046
1047    return 1;
1048}
1049
10501;
1051
1052__END__
1053