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

#
# Author: Slaven Rezic
#
# Copyright (C) 1998,2004,2014,2024 Slaven Rezic. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: slaven@rezic.de
# WWW:  http://bbbike.de
#

# berprft, ob alle Punkte aus der ersten Datei in min. einer der folgenden
# Dateien vorkommt (z.B. alle Ampeln mssen in Straen vorhanden sein...)

package BBBike::check_points;

use strict;
use FindBin;
use lib ("$FindBin::RealBin/..", "$FindBin::RealBin/../lib");
use Strassen::Core;
use Strassen::MultiStrassen;
use Strassen::Kreuzungen;
use Getopt::Long;

use vars qw(%str_obj %hash);

@Strassen::datadirs = ("$FindBin::RealBin/../data");

sub doit {
    local(@ARGV) = @_;

    my $ampelschaltung_source;
    my $ampelschaltung2_source;
    my $warn; # warn only instead of failing
    my $usecache = 1;
    my $usememcache = 1;
    my $q;
    my $debug;
    my $do_report = 0;
    my $assert_single_coordinate;
    my @namerx;
    my @catrx;

    GetOptions("ampelschaltung!" => \$ampelschaltung_source,
	       "ampelschaltung2!" => \$ampelschaltung2_source,
	       "warn!" => \$warn,
	       "cache!" => \$usecache,
	       "memcache!" => \$usememcache,
	       "q|quiet!" => \$q,
	       "debug" => \$debug,
	       "report!" => \$do_report,
	       "assert-single-coordinate!" => \$assert_single_coordinate,
	       "namerx=s\@" => \@namerx,
	       "catrx=s\@" => \@catrx,
	      ) or die <<EOF;
usage: $0 [-ampelschaltung] [-ampelschaltung2] [-[no]warn] [-[no]cache]
          [-[no]keepnet] [-[no]quiet | -q] [-report] [-assert-single-coordinate]
	  [-namerx regexp [-namerx ...]] [-catrx regexp [-catrx ...]]
          checkfile againstfile ...
EOF

    my $file = shift @ARGV || die "file to check missing";
    my(@check) = @ARGV;
    if (!@ARGV) {
	die "files to check against missing!";
    }

    if ($debug) {
	Strassen::set_verbose(1);
    }

    if (@namerx) {
	for (@namerx) {
	    $_ = qr{$_};
	}
    }

    if (@catrx) {
	for (@catrx) {
	    $_ = qr{$_};
	}
    }

    my $s1;
    if ($ampelschaltung_source ||
	$ampelschaltung2_source) {
	# no usememcache for this one
	$s1 = new Strassen;
	open(D, $file) or die "Can't open $file: $!";
	while(<D>) {
	    next if /^#/;
	    chomp;
	    my @l;
	    if ($ampelschaltung_source) {
		@l = split(/\t/o, $_);
	    } else {
		if (/^(\d+,\d+)\s+(\S+)/) {
		    @l = ($1, $2);
		} else {
		    next;
		}
	    }
	    push @{ $s1->{Data} }, "$l[1]\tX $l[0]";
	}
	close D;
    } else {
	if ($usememcache && $str_obj{$file}) {
	    $s1 = $str_obj{$file};
	} else {
	    $s1 = Strassen->new($file, UseLocalDirectives => 1);
	}
	if ($usememcache && !$str_obj{$file}) {
	    $str_obj{$file} = $s1;
	}
    }

    my $s2;
    my $check_token = join("_", sort @check);
    if ($usememcache && $hash{$check_token}) {
	$s2 = $hash{$check_token};
    } else {
	if ($usecache) {
	    my $check_str = MultiStrassen->new(@check);
	    my $cr = Kreuzungen->new(Strassen => $check_str,
				     UseCache => 1,
				     Kurvenpunkte => 1,
				     RetType => 'hash',
				    );
	    $s2 = $cr->{Hash};
	} else {
	    foreach my $checkfile (@check) {
		my $str2 = new Strassen $checkfile;
		$str2->init;
		while(1) {
		    my $ret = $str2->next;
		    last if !@{$ret->[1]};
		    foreach (@{$ret->[1]}) {
			$s2->{$_}++;
		    }
		}
	    }
	}
	if ($usememcache) {
	    $hash{$check_token} = $s2;
	}
    }

    my @error_points;
    my $fail = 0;
    $s1->init;
    while(1) {
	my $ret = $s1->next;
	last if !@{$ret->[Strassen::COORDS()]};
	my $name = $ret->[Strassen::NAME()];
	my $cat = $ret->[Strassen::CAT()];
	my $dir = $s1->get_directives;

	if (($dir->{ignore_check_net}[0] || '') ne 'yes') {
	    my @this_error_points;
	    foreach (@{$ret->[Strassen::COORDS()]}) {
		if (!exists $s2->{$_} && $_ ne '*') {
		    push(@this_error_points, $_);
		}
	    }
	    if (@this_error_points) {
		print STDERR "Error in $name: coordinate(s) " . join(" ", @this_error_points) . " are not in net\n" unless $q;
		$fail++ unless $warn;
		push @error_points, @this_error_points if $do_report;
	    }
	}

	if ($assert_single_coordinate) {
	    if (@{ $ret->[Strassen::COORDS()] } != 1) {
		print STDERR "Error in $name: single coordinate assertion violated, coords=@{ $ret->[Strassen::COORDS()] }\n" unless $q;
		$fail++ unless $warn;
	    }
	}

	if (@namerx) {
	    my $match = 0;
	    for my $namerx (@namerx) {
		if ($name =~ $namerx) {
		    $match++;
		    last;
		}
	    }
	    if (!$match) {
		print STDERR "Error in $name: name is not expected\n" unless $q;
		$fail++ unless $warn;
	    }
	}

	if (@catrx) {
	    my $match = 0;
	    for my $catrx (@catrx) {
		if ($cat =~ $catrx) {
		    $match++;
		    last;
		}
	    }
	    if (!$match) {
		print STDERR "Error in $name: category <$cat> is not expected\n" unless $q;
		$fail++ unless $warn;
	    }
	}
    }

    if ($do_report && @error_points) {
	my $line = 1;
	print "# Errors doing check_points\n";
	print "# Checked file: $file\n";
	print "# Check against: @check\n";
	print join("\n", map { ($line++) . "\tX $_" } @error_points), "\n";
    }

    return ($fail ? 1 : 0);
}

return 1 if caller;

exit doit(@ARGV);

