#!/usr/bin/env perl
# -*- perl -*-

#
# Author: Slaven Rezic
#

# Strassen-Dateien filtern
# Similar to Strassen::CoreHeavy::grepstreets

use strict;
use warnings;

use FindBin;
use lib ("$FindBin::RealBin/..",
	 "$FindBin::RealBin/../data",
	 "$FindBin::RealBin/../lib",
	 $FindBin::RealBin,
	);

use Getopt::Long;
use Storable qw(dclone);
use Tie::IxHash;

use Strassen::Core;
use Strassen::Stat;

my $iso_date_qr = qr{(\d{4})\D*(\d{2})\D*(\d{2})};

my($v, $i, $cat, $catrx, $name, $namerx, $section, $sectionrx, $code, @directive_def, @directive, @directiverx, @directivecode, $valid_def);
my($minarea, $minlength);
my $preserveglobaldirectives;
my $ignoreglobaldirectives;
my $ignorelocaldirectives;
my $withsourcedirectives;
my $removenoncoords;
tie my %special, 'Tie::IxHash';
tie my %special_init, 'Tie::IxHash';
tie my %special_end, 'Tie::IxHash';
my %special_data;
my %type_s;
my @inner;
my @outer;
my $innerbbox;
my $onlyenclosed;
GetOptions("v" => \$v,
	   "i" => \$i,
	   "cat=s" => \$cat,
	   "catrx=s" => \$catrx,
	   "name=s" => \$name,
	   "namerx=s" => \$namerx,
	   "section=s" => \$section,
	   "sectionrx=s" => \$sectionrx,
	   "code=s" => \$code,
	   "directive=s" => \@directive_def,
	   "valid=s" => \$valid_def,
	   "special=s" => sub {
	       my $type = $_[1];
	       $special_init{$type} = 1;
	   },
	   'adddirectives=s@' => sub {
	       my $type = $_[1];
	       init_directive_handler($type);
	   },
	   "preserveglobaldirectives!" => \$preserveglobaldirectives,
	   "ignoreglobaldirectives!" => \$ignoreglobaldirectives,
	   "ignorelocaldirectives!" => \$ignorelocaldirectives,
	   "removenoncoords!" => \$removenoncoords,
	   "minarea=f" => \$minarea,
	   "minlength=f" => \$minlength,
	   'inner=s@' => \@inner,
	   'outer=s@' => \@outer,
	   'innerbbox=s' => \$innerbbox,
	   "onlyenclosed!" => \$onlyenclosed,
	   'withsourcedirectives' => \$withsourcedirectives,
	  ) or die <<EOF;
usage: $0 [-v] [-i] [-cat category | -catrx regexp]
       [-name name | -namerx regexp]
       [-section section | -sectionrx regexp]
       [-code perlcode ]
       [-directive key=val|key~val [-directive ...]]
       [-valid today|YYYYMMDD]
       [-special name] [-minarea ...km] [-minlength ...km]
       [-preserveglobaldirectives] [-ignoreglobaldirectives]
       [-withsourcedirectives]
       [-ignorelocaldirectives] [-removenoncoords]
       [-inner file [-inner ...] [-innerbbox lon1,lat1,lon2,lat2] [-onlyenclosed]] [-outer file [-outer ...]] bbd ...

section is a region marked with the "section" directive in a bbd file.

EOF

if ($withsourcedirectives && $ignorelocaldirectives) {
    die "ERROR: using both -withsourcedirectives and -ignorelocaldirectives is not possible.\n";
}

if ($catrx) {
    $catrx = $i ? qr{$catrx}i : qr{$catrx};
} elsif ($cat && $i) {
    $catrx = qr{^\Q$cat\E$}i;
    undef $cat;
}
if ($namerx) {
    $namerx = $i ? qr{$namerx}i : qr{$namerx};
} elsif ($name && $i) {
    $namerx = qr{^\Q$name\E$}i;
    undef $name;
}
if ($sectionrx) {
    $sectionrx = $i ? qr{$sectionrx}i : qr{$sectionrx};
} elsif ($section && $i) {
    $sectionrx = qr{^\Q$section\E$}i;
    undef $section;
}
$minarea = $minarea*(1000*1000) if defined $minarea;
$minlength = $minlength*1000 if defined $minlength;

if (defined $code) {
    $code = eval 'sub ($$) { my($r,$dir) = @_; ' . $code . ' }';
    if (!$code || $@) {
	die "Cannot eval -code value: $@";
    }
}

for my $directive_def (@directive_def) {
    if ($directive_def =~ m{^([^=~]+)([=~])(.*)}) {
	my($key, $type, $val) = ($1, $2, $3);
	if ($type eq '=') {
	    if ($i) {
		push @directiverx, [$key, qr{^\Q$val\E$}i];
	    } else {
		push @directive, [$key, $val];
	    }
	} else {
	    push @directiverx, [$key, $i ? qr{$val}i : qr{$val}];
	}
    } else {
	die "Cannot parse <$directive_def>, should be key=val or key~val";
    }
}

if ($valid_def) {
    my $date;
    if ($valid_def eq 'today') {
	require POSIX;
	$date = POSIX::strftime("%Y%m%d", localtime);
    } else {
	if (my($y,$m,$d) = $valid_def =~ m{^$iso_date_qr$}) {
	    $date = sprintf "%04d%02d%02d", $y,$m,$d;
	} else {
	    die "Cannot parse date '$valid_def', should be in the form 'YYYY-MM-DD' or 'YYYYMMDD'";
	}
    }
    my $code = sub {
	my($all_dirs) = @_;
	if (!$all_dirs->{'valid'}) { # no 'valid' directive -> assume it's valid
	    return 1;
	}
	my $dirs = $all_dirs->{'valid'};
	if (@$dirs != 1) {
	    die "No support for multiple 'valid' directives (@$dirs)";
	}
	my $dir = $dirs->[0];
	delete $all_dirs->{'valid'}; # note, side effect: 'valid' directive is removed for output
	my $is_inverted = ($dir =~ s{^!}{});
	if (my($y1,$m1,$d1, $y2,$m2,$d2) = $dir =~ m{^(?:$iso_date_qr)?-(?:$iso_date_qr)?$}) {
	    my $from = defined $y1 ? sprintf("%04d%02d%02d", $y1, $m1, $d1): undef;
	    my $to   = defined $y2 ? sprintf("%04d%02d%02d", $y2, $m2, $d2): undef;
	    if (!$from && !$to) {
		die "Please specify either from or to date, or both";
	    }
	    if (defined $from) {
		return $is_inverted ? 1 : 0 if $date lt $from;
	    }
	    if (defined $to) {
		return $is_inverted ? 1 : 0 if $date gt $to;
	    }
	    return $is_inverted ? 0 : 1;
	} else {
	    die "Invalid 'valid' directive '$dir', should be either YYYYMMDD-YYYYMMDD or -YYYYMMDD or YYYYMMDD-";
	}
    };
    push @directivecode, $code;
}

my @datafiles = @ARGV;
if (!@datafiles) {
    @datafiles = '-';
}
my $s;
if (@datafiles == 1) {
    if ($withsourcedirectives && $datafiles[0] eq '-') {
	die "ERROR: -withsourcedirectives option does not support reading from stdin.\n";
    }
    $s = Strassen->new($datafiles[0], UseLocalDirectives => 1, PreserveLineInfo => 1);
} else {
    if ($withsourcedirectives) {
	die "ERROR: -withsourcedirectives option does not support multiple source files yet.\n"; # XXX NYI
    }
    require Strassen::MultiStrassen;
    $s = MultiStrassen->new(map {
	my $s = eval {
	    Strassen->new($_, UseLocalDirectives => 1, PreserveLineInfo => 1);
	};
	warn $@ if $@;
	defined $s ? $s : ();
    } @datafiles);
}

my $coordsys = $s->get_global_directive('map') || 'standard';

my $new_s = Strassen->new;
local $Strassen::STRICT = 1;

my(@inner_s, @outer_s);
for my $inner (@inner) {
    my $s = Strassen->new($inner);
    die "Record count of $inner is not 1" if $s->count != 1;
    $s->init;
    push @inner_s, [ map { [split /,/] } @{ $s->next->[Strassen::COORDS()] } ];
}
if ($innerbbox) {
    require Karte;
    Karte::preload(':all');
    my($lon1,$lat1,$lon2,$lat2,$rest) = split /,/, $innerbbox;
    if (defined $rest)  { die "-innerbox should consist of four comma-separated values, but got more.\n" }
    if (!defined $lat2) { die "-innerbox should consist of four comma-separated values, but got less.\n" }
    push @inner_s, [ map { [ $Karte::map{polar}->map2map($Karte::map{$coordsys}, @$_) ] } ([$lon1,$lat1], [$lon1,$lat2], [$lon2,$lat2], [$lon2,$lat1], [$lon1,$lat1]) ];
}

for my $outer (@outer) {
    my $s = Strassen->new($outer);
    die "Record count of $outer is not 1" if $s->count != 1;
    $s->init;
    push @outer_s, [ map { [split /,/] } @{ $s->next->[Strassen::COORDS()] } ];
}
if (@inner_s || @outer_s) {
    require VectorUtil;
}
if ($onlyenclosed && !@inner_s) {
    die "-onlyenclosed is only valid with -inner or -innerbbox\n";
}

for my $type (keys %special_init) {
    no strict 'refs';
    &{"init_" . $type}($type);
}

$s->init;
my @errors;
my $source_file_directive_emitted;
LOOP_STREETS: while(1) {
    my $r = $s->next;
    if (!$r->[1]) {
	if (@datafiles == 0) {
	    push @errors, "Empty coords array found in file " . $datafiles[0] . ", line " . $s->line . " (please check format of line!)";
	} else {
	    # XXX which datafile exactly?
	    push @errors, "Empty coords array found in any of the input files, line " . $s->line . " (please check format of line!)";
	}
	next;
    }
    last if !@{ $r->[1] };
    # Match NAME
    if (defined $name) { if ($r->[0] eq $name) { next if $v } else { next unless $v } }
    if (defined $namerx) { if ($r->[0] =~ $namerx) { next if $v } else { next unless $v } }
    # Match CATEGORY
    if (defined $cat) { if ($r->[2] eq $cat) { next if $v } else { next unless $v } }
    if (defined $catrx) { if ($r->[2] =~ $catrx) { next if $v } else { next unless $v } }
    my $dir = $s->get_writable_directives;
    # Match CODE
    if ($code) { if ($code->($r, $dir)) { next if $v } else { next unless $v } }
    # Match SECTION
    if (defined $section) { if (defined $dir->{section} && grep { $_ eq $section } @{ $dir->{section} }) { next if $v } else { next unless $v } }
    if (defined $sectionrx) { if (defined $dir->{section} && grep { /$sectionrx/ } @{ $dir->{section} }) { next if $v } else { next unless $v } }
    # Match DIRECTIVES
    if (@directive) {
	for my $directive (@directive) {
	    my($key, $val) = @$directive;
	    if (defined $dir->{$key} && grep { $_ eq $val } @{ $dir->{$key} }) { next LOOP_STREETS if $v } else { next LOOP_STREETS unless $v }
	}
    }
    if (@directiverx) {
	for my $directiverx (@directiverx) {
	    my($key, $val) = @$directiverx;
	    if (defined $dir->{$key} && grep { /$val/ } @{ $dir->{$key} }) { next LOOP_STREETS if $v } else { next LOOP_STREETS unless $v }
	}
    }
    if (@directivecode) {
	for my $directivecode (@directivecode) {
	    if ($directivecode->($dir)) { next LOOP_STREETS if $v } else { next LOOP_STREETS unless $v }
	}
    }
    # Match length/area
    if (defined $minarea && $r->[2] =~ /^F:/) { if (Strassen::area($r) >= $minarea) { next if $v } else { next unless $v } }
    if (defined $minlength && $r->[2] !~ /^F:/ && @{$r->[1]} > 1) { if (Strassen::total_len($r) >= $minlength) { next if $v } else { next unless $v } }	
    # Match inner/outer
    # XXX using point_in_polygon is somewhat rough, probably should use something like line_in_polygon
    # XXX no -v support here!
    my @c;
    if (@inner_s || @outer_s) {
	@c = map { [ split /,/ ] } @{ $r->[Strassen::COORDS] };
    }
 INNER: {
	if (@inner_s) {
	    if ($onlyenclosed) {
		my @r = get_enclosed_linesegments($r, \@c, \@inner_s);
		# we have to push here, because multiple $r objects may be returned
		for my $r (@r) {
		    if ($ignorelocaldirectives) {
			$new_s->push_ext($r);
		    } else {
			$new_s->push_ext($r, $dir);
		    }
		}
		next LOOP_STREETS;
	    }
	    for my $inner (@inner_s) {
		for my $c (@c) {
		    if (VectorUtil::point_in_polygon($c,$inner)) {
			last INNER;
		    }
		}
	    }
	    next LOOP_STREETS;
	}
    }
    if (@outer_s) {
	for my $outer (@outer_s) {
	    for my $c (@c) {
		if (VectorUtil::point_in_polygon($c,$outer)) {
		    next LOOP_STREETS;
		}
	    }
	}
    }
    # Special matches
    keys %special; # reset iterator
    while(my($k,$v) = each %special) {
	next LOOP_STREETS if !$v->($r, $dir);
    }
    if ($removenoncoords) { # primary use: remove the "*" pseudo coords. XXX maybe a better solution: expand before, like it's done for the non-orig files anyway
	my @new_c;
	my $do_copy;
	for my $c (@{ $r->[Strassen::COORDS] }) {
	    if ($c =~ m{^[-+]?\d+,[-+]?\d+$}) {
		push @new_c, $c;
	    } else {
		$do_copy = 1;
	    }
	}
	if ($do_copy) {
	    $r->[Strassen::COORDS] = \@new_c;
	}
    }
    if ($withsourcedirectives) {
	if (!$source_file_directive_emitted) {
	    push @{ $dir->{source_file} }, ($s->file)[0];
	    $source_file_directive_emitted = 1;
	}
	push @{ $dir->{source_line} }, $s->line;
    }
    if ($ignorelocaldirectives) {
	$new_s->push_ext($r);
    } else {
	$new_s->push_ext($r, $dir);
    }
}

if (@errors) {
    die "*** Following errors were found:\n" . join("\n", @errors) . "\n";
}

keys %special_end; # reset iterator
while(my($k,$v) = each %special_end) {
    $v->();
}

binmode STDOUT; # for Windows

if ($preserveglobaldirectives || !$ignoreglobaldirectives) {
    my $global_directives = $s->get_global_directives;
    my $encoding_directive = $s->get_global_directive('encoding');
    if ($preserveglobaldirectives) {
	$new_s->set_global_directives(dclone $global_directives);
    } elsif (!$ignoreglobaldirectives) {
	# Only preserve some importing global directives:
	my $need_global_directive_separator;
	my $comment_directives = $global_directives->{'#'};
	if ($comment_directives) {
	    print join("", map { "#: #: $_\n" } @$comment_directives);
	    $need_global_directive_separator++;
	}
	if ($encoding_directive) {
	    (my $emacs_coding_system = $encoding_directive) =~ s{iso8859}{iso-8859};
	    print "#: encoding: $emacs_coding_system\n";
	    $need_global_directive_separator++;
	}
	if ($need_global_directive_separator) {
	    print "#:\n";
	}
    }
    if ($encoding_directive) {
	binmode STDOUT, ":encoding($encoding_directive)";
    }
}

print $new_s->as_string;

######################################################################

sub init_directive_handler {
    my $type = shift;
    $special{$type} = sub { special_directive_handler($type, @_) };
    require Storable;
    $type_s{$type} = Strassen->new;
    $special_end{$type} = sub { end_directive_handler($type, @_) };
}

sub special_directive_handler {
    my($type, $r, $dir) = @_;
    my $new_r = Storable::dclone($r);
    my $new_dir = Storable::dclone($dir);
    if (exists $dir->{$type}) {
	my $name = $r->[Strassen::NAME] . " (";
	my @add_names = grep { !/^\s*$/ } @{ $dir->{$type} };
	if (!@add_names) {
	    @add_names = $type eq 'fragezeichen' ? "unsicher" : $type;
	}
	$name .= join("; ", map { s/\t/ /g; $_ } @add_names); # join & sanitize
	$name .= ")";
	$new_r->[Strassen::NAME] = $name;
	$new_r->[Strassen::CAT] = "?";
	$type_s{$type}->push($new_r);
	delete $new_dir->{$type};
	$type_s{$type}->set_directives_for_current($new_dir);
    }
    1;
}

sub end_directive_handler {
    my($type) = @_;
    require File::Basename;
    # XXX support for MultiStrassen missing --- is it needed at all?
    $type_s{$type}->write("/tmp/" . $type . "_" . File::Basename::basename($datafiles[0]) . ".bbd");
}

######################################################################

sub init_nextcheck {
    my $type = shift;
    no strict 'refs';
    $special{$type} = \&{"special_" . $type};
    my $check_frequency_days = 30;
    my $glob_dir = $s->get_global_directives;
    if ($glob_dir && $glob_dir->{check_frequency}) {
	($check_frequency_days) = $glob_dir->{check_frequency}[0] =~ m{(\d+)};
    }
    $special_data{$type}{check_frequency_days} = $check_frequency_days;
    require POSIX;
    $special_data{$type}{today} = POSIX::strftime("%Y-%m-%d", localtime);
    $type_s{$type} = Strassen->new;
    $special_end{$type} = sub { end_nextcheck(@_) };
    require Storable;
    require StrassenNextCheck;
}

sub special_nextcheck {
    my($r, $dir) = @_;
    StrassenNextCheck::process_nextcheck_record($s, $r, $dir, check_frequency_days => $special_data{nextcheck}{check_frequency_days});
    if ($dir->{_nextcheck_date} && $dir->{_nextcheck_date}[0] lt $special_data{nextcheck}{today}) {
	my $new_r = Storable::dclone($r);
	$new_r->[Strassen::NAME] .= " (" . $dir->{_nextcheck_label}[0] . ")";
	$new_r->[Strassen::CAT] = "?";
	$type_s{nextcheck}->push($new_r);
	my $new_dir = Storable::dclone($dir);
	for (keys %$new_dir) {
	    delete $new_dir->{$_} if $_ =~ m{^_nextcheck_};
	}
	$type_s{nextcheck}->set_directive_for_current($new_dir);
    }
}

sub end_nextcheck {
    require File::Basename;
    $type_s{nextcheck}->write("/tmp/nextcheck.bbd");
}

######################################################################
# Filter everything out what is not yet expired by
# next_check/last_checked. This is used for the standard
# fragezeichen-orig -> fragezeichen conversion
#
# Bug: this filter does not honor -v. This may change, so probably best
# to not use this currently with -v.

sub init_filternextcheck {
    my $type = shift;

    # Pseudo-inheritance/reusage
    # XXX bug: by reusing the initialization, also end_nextcheck() is executed, which would write an empty and unnecessary /tmp/nextcheck.bbd
    init_nextcheck('nextcheck');

    no strict 'refs';
    $special{$type} = \&{"special_" . $type};
    delete $special{'nextcheck'};
    $special_end{$type} = sub { end_nextcheck(@_) };
}

sub special_filternextcheck {
    my($r, $dir) = @_;
    StrassenNextCheck::process_nextcheck_record($s, $r, $dir, check_frequency_days => $special_data{nextcheck}{check_frequency_days}, passthru_without_nextcheck => 1);
    if ($dir->{_nextcheck_date} && $dir->{_nextcheck_date}[0]) {
	if ($dir->{_nextcheck_date}[0] gt $special_data{nextcheck}{today}) {
	    return 0;
	}
    }
    for (keys %$dir) {
	delete $dir->{$_} if $_ =~ m{^_nextcheck_};
    }
    return 1;
}

sub end_filternextcheck { }

######################################################################
# Bug: this filter does not honor -v. This may change, so probably best
# to not use this currently with -v.

sub init_nonextcheck {
    my $type = shift;
    no strict 'refs';
    $special{$type} = \&{"special_" . $type};
}

sub special_nonextcheck {
    my($r, $dir) = @_;
    return 0 if (exists $dir->{next_check} || exists $dir->{last_checked});
    return 0 if exists $dir->{XXX_prog}; # the fragezeichen-nextcheck file is supposed for research tasks, not for programming tasks
    return 1;
}

sub end_nonextcheck { }

######################################################################
# XXX obsolete: could be replaced by -adddirectives add_fragezeichen
# BUT! this would create files /tmp/add_fragezeichen... instead of
# /tmp/fragezeichen...
# XXX Cannot handle encoding directive
sub init_fragezeichen {
    my $val = shift;
    no strict 'refs';
    $special{$val} = \&{"special_" . $val};
    require Storable;
    use vars qw($fragezeichen_s);
    $fragezeichen_s = Strassen->new;
    $special_end{$val} = \&{"end_" . $val};
}

sub special_fragezeichen {
    my($r, $dir) = @_;
    my $fragezeichen_r = Storable::dclone($r);
    if (exists $dir->{add_fragezeichen}) {
	my $name = $r->[Strassen::NAME];
	$name .= ' ' if $r->[Strassen::NAME] ne '';
	$name .= '(';
	my @add_names = grep { !/^\s*$/ } @{ $dir->{add_fragezeichen} };
	if (!@add_names) {
	    @add_names = 'unsicher';
	} else {
	    s/:$// for @add_names;
	}
	$name .= join("; ", @add_names);
	$name .= ")";
	$fragezeichen_r->[Strassen::NAME] = $name;
	$fragezeichen_r->[Strassen::CAT] = "?";
	$fragezeichen_s->push($fragezeichen_r);
    }
    1;
}

sub end_fragezeichen {
    require File::Basename;
    # XXX support for MultiStrassen missing --- is it needed at all?
    $fragezeichen_s->write("/tmp/fragezeichen_" . File::Basename::basename($datafiles[0]) . ".bbd");
}

######################################################################
sub get_enclosed_linesegments {
    my($r, $c_ref, $inner_s_ref) = @_;
    my @ret = ([]);
    for my $inner (@$inner_s_ref) {
	for my $c (@$c_ref) {
	    if (VectorUtil::point_in_polygon($c, $inner)) {
		push @{ $ret[-1] }, $c;
	    } else {
		if (@{ $ret[-1] }) {
		    push @ret, []; # create a new segment
		}
	    }
	}
    }
    if (!@{ $ret[-1] }) {
	pop @ret;
    }
    @ret = grep { @$_ >= 2 } @ret; # one-point records are no line segments ---> remove
    if (@ret) {
	@ret = map { [$r->[Strassen::NAME], [map { join(",", @$_) } @$_], $r->[Strassen::CAT]] } @ret;
    }
    @ret;
}

__END__

=head1 NAME

grepstrassen - filter bbd files

=head1 SYNOPSIS

    grepstrassen [options] bbdfile > filtered_bbdfile

For usage:

    grepstrassen "-?"

=head1 EXAMPLES

Voraussetzung:

    cd .../bbbike/data

Alle S-Bahnhfe finden, die nicht barrierefrei sind:

    ../miscsrc/grepstrassen -v -directive attributes~b sbahnhof-orig 

=head1 NOTES

Important global directives (e.g. "encoding") are preserved by
default. To preserve all global directives, use the option
C<-preserveglobaldirectives>. To ignore all global directives, use the
option C<-ignoreglobaldirectives>.

=head1 BUGS

There's no way to specify absolute no global directives. This is
probably desirable if appending to an existing bbd file. But in this
case encoding mismatches may happen.

=head1 SEE ALSO

L<Strassen::CoreHeavy/grepstreets>

=cut
