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

#
# Author: Slaven Rezic
#
# Copyright (C) 2002,2003,2009,2016,2017,2025 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.
#
# WWW:  https://github.com/eserte/bbbike
#

# quick hack

use strict;
use warnings;
use FindBin;
use lib ("$FindBin::RealBin/..",
	 "$FindBin::RealBin/../lib",
	 "$FindBin::RealBin/../data",
	);
use Geography;
use Strassen::Core;
use Strassen::MultiStrassen;
use Strassen::Strasse;
use ESRI::Shapefile::Main;
use XBase;
use List::Util qw(max);
use Getopt::Long;
use BBBikeUtil qw(rad2deg);

use vars '$VERSION';
$VERSION = '0.52';

my $outprefix;
my $shapetype = "polyline";
my $filter_shapetype = 0;
my $type = "";
my $imagetype;
my $onewayhack;
my $qualityshack;
my $handle_igndisp;
my $dbf_encoding;
my $polar;

my $city;
my $country;

use constant Strassen_SHORTCAT => Strassen::LAST + 1;

if (!GetOptions("o=s" => \$outprefix,
		"shptype|shapetype=s" => \$shapetype,
		"filter!" => \$filter_shapetype,
		"type=s" => \$type,
		"imagetype=s" => \$imagetype,
		"onewayhack!" => \$onewayhack,
		"qualityshack!" => \$qualityshack,
		"city=s" => \$city,
		"country=s" => \$country,
		"dbfencoding=s" => \$dbf_encoding,
		"polar!" => \$polar,
		"igndisp!" => \$handle_igndisp,
		'v|version' => sub {
		    print "$0 $VERSION\n";
		    exit 0;
		},
	       )) {
    die "usage $0: [-o outprefix] [-shptype shapetype] [-[no]filter] [-type type]
	[-imagetype imagetype] [-onewayhack] [-qualityshack] [-igndisp]
	[-city city] [-country country]
	[-dbfencoding encoding] [-polar]
	bbdfile ...

shapetype may be auto, polyline, polygon, or point
encoding may be any valid perl encoding, and html
";
}
if (!defined $outprefix) {
    die "-o is missing";
}

my $city_obj = Geography->new($city, $country);

my @files = @ARGV;
if (!@files) {
    die "No files specified";
}

if ($polar) {
    require Karte::Standard;
    require Karte::Polar;
    $Karte::Polar::obj = $Karte::Polar::obj if 0; # cease -w
}

if ($shapetype eq 'auto') {
    create_shape_file(-shapetype => "polyline",
		      -filter => 1,
		      -type => $type,
		      -emptyexpected => 1,
		     );
    create_shape_file(-shapetype => "polygon",
		      -filter => 1,
		      -suffix => "_polygon",
		      -type => $type,
		      -emptyexpected => 1,
		     );
    create_shape_file(-shapetype => "point",
		      -filter => 1,
		      -suffix => "_point",
		      -type => $type,
		      -emptyexpected => 1,
		     );
} else {
    create_shape_file(-shapetype => $shapetype,
		      -type => $type,
		      -filter => $filter_shapetype,
		     );
}

my($glob_rec_no, $glob_min_x, $glob_min_y, $glob_max_x, $glob_max_y);

sub create_shape_file {
    my(%args) = @_;
    my $shapetype = $args{-shapetype};
    my $suffix    = $args{-suffix};
    my $filter    = $args{-filter};
    my $type      = $args{-type};

    my $header = init_shp_header();
    my $shx_header = $header;
    my @rec;
    my @rec_offset;
    my @rec_length;
    my $rec_offset = length($header);
    my @dbf;

    # semi-globals
    $glob_rec_no = 1;
    ($glob_min_x, $glob_min_y, $glob_max_x, $glob_max_y)
	= (undef, undef, undef, undef);

    my $create_record_sub = ($shapetype =~ /^polyline$/
			     ? \&create_polyline_record
			     : $shapetype =~ /^polygon$/
			     ? \&create_polygon_record
			     : $shapetype =~ /^point$/
			     ? \&create_point_record
			     : die "Unhandled shape type $shapetype");

    for my $file (@files) {
	my $qualityshack = $qualityshack && $file =~ /qualitaet_s/;
	my $type = $type;
	my $s = Strassen->new($file);
	if      ($file =~ /strassen_bab/) {
	    $type .= '-bab';
	} elsif ($file =~ /landstrassen/) {
	    $type .= "-l";
	} elsif ($file =~ /\bstrassen/) {
	    $type .= "-s";
	}

	if ($polar) {
	    $s->init;
	    while(1) {
		my $r = $s->next;
		last if !@{ $r->[Strassen::COORDS] };
		for my $c (@{ $r->[Strassen::COORDS] }) {
		    $c = join(",", $Karte::Polar::obj->trim_accuracy($Karte::Polar::obj->standard2map(split /,/, $c)));
		}
		$s->set_current2($r);
	    }
	}

	my $create_esri_and_dbf_record = sub {
	    my $d = shift;
	    my $rec = $create_record_sub->($d);
	    push @rec_offset, $rec_offset;
	    push @rec_length, length($rec) - 8; # dbx expects the record length *without* the header (which is 8 bytes)
	    push @rec, $rec;
	    $rec_offset += length($rec);
	    push @dbf, create_dbf_record($d, -type => $type, -file => $file);
	};

	$s->init;
	while(1) {
	    local $_ = $s->next;
	    last if !@{ $_->[Strassen::COORDS] };

	    next if $handle_igndisp && $_->[Strassen::CAT] =~ /::igndisp/;

	    ($_->[Strassen_SHORTCAT] = $_->[Strassen::CAT]) =~ s/::.*//;

	    if ($filter && $shapetype eq 'polygon') {
		if ($_->[Strassen_SHORTCAT] !~ /^F:/) {
		    next;
		} else {
		    $_->[Strassen_SHORTCAT] =~ s/^F://;
		}
	    }
	    next if ($filter && $shapetype ne 'polygon' && $_->[Strassen_SHORTCAT] =~ /^F:/);

	    if ($filter && $shapetype eq 'point') {
		if (@{$_->[Strassen::COORDS]} > 1) {
		    next;
		}
	    }
	    next if ($filter && $shapetype ne 'point' && @{$_->[Strassen::COORDS]} == 1);

	    if (defined $imagetype) {
		# change extension
		$_->[Strassen_SHORTCAT] =~ s/(IMG:[^|]*\.)[^|]+/$1$imagetype/;
	    }
	    # XXX should really find a better solution here:
	    if ($_->[Strassen_SHORTCAT] =~ /(.*);(.*)/) {
		$_->[Strassen_SHORTCAT] = ($1 eq '' ? $2 : $1);
	    }
	    # XXX Remove the extra info part in gesperrt files
	    # (the category should really be better named using the ::
	    # syntax)!	    
	    if ($file =~ /gesperrt/ && $_->[Strassen_SHORTCAT] =~ /^(.*?):/) {
		$_->[Strassen_SHORTCAT] = $1;
	    }
	    if ($onewayhack && $_->[Strassen_SHORTCAT] eq '1') {
		for my $res (oneway_hack($_)) {
		    $create_esri_and_dbf_record->($res);
		}
	    } elsif ($qualityshack) {
		if ($_->[Strassen_SHORTCAT] ne "Q0") {
		    $create_esri_and_dbf_record->($_);
		}
	    } else {
		$create_esri_and_dbf_record->($_);
	    }
	}
    }

    if (!@rec && !$args{-emptyexpected}) {
	warn "bbd2esri: No data found in the following files: <@files>\n";
	return;
    }

    my $outprefix = $outprefix;
    if (defined $suffix) {
	$outprefix .= $suffix;
    }

    # Avoid warnings (no records -> no bounding box)
    if (!@rec) {
	for ($glob_min_x, $glob_min_y, $glob_max_x, $glob_max_y) {
	    $_ = 0 if !defined $_;
	}
    }

    $header = set_shp_header($header,
			     -length => $rec_offset,
			     -shapetype => $shapetype,
			     -bbox => [$glob_min_x, $glob_min_y,
				       $glob_max_x, $glob_max_y,
				       0, 0, 0, 0],
			    );
    open(SHP, "> $outprefix.shp")
	or die "Cannot write to $outprefix.shp: $!";
    print SHP $header;
    print SHP $_ for @rec;
    close SHP
	or die "While writing to $outprefix.shp: $!";

    $shx_header = set_shp_header($header,
				 -length => length($shx_header) + (scalar(@rec_offset)+scalar(@rec_length))*4,
				);
    open(SHX, "> $outprefix.shx")
	or die "Cannot write to $outprefix.shx: $!";
    print SHX $shx_header;
    for my $i (0 .. $#rec_offset) {
	print SHX pack("N2", $rec_offset[$i]/2, $rec_length[$i]/2);
    }
    close SHX
	or die "While writing to $outprefix.shx: $!";

    my @max_length;
    my $fields = 7;
    {
	no warnings;
	for my $i (0 .. $fields-1) {
	    $max_length[$i] = max map { length($_->[$i]) } @dbf;
	    $max_length[$i] = 0 if !defined $max_length[$i]; # since perl 5.12.0 length(undef) -> undef
	}
    }

    unlink "$outprefix.dbf";
    my $newtable = XBase->create
	("name" => "$outprefix.dbf",
	 "field_names" => [ "NAME", "CAT", "FULLNAME", "STRNR", "CAT_IMG", "CAT_ANCHOR", "ANGLE" ],
	 "field_types" => [ ("C") x $fields ],
	 "field_lengths" => [ @max_length ],
	 "field_decimals" => [ (undef) x $fields ]);
    my $rec_no = 0;
    for my $row (@dbf) {
	if ($dbf_encoding) {
	    require Encode;
	    $row = [ map { do_encode($_, $dbf_encoding) } @$row ];
	}
	$newtable->set_record($rec_no, @$row);
	$rec_no++;
    }
}

sub create_point_record {
    my $s_rec = shift;
    ($glob_min_x, $glob_min_y, $glob_max_x, $glob_max_y) =
	get_bbox($s_rec->[Strassen::COORDS],
		 $glob_min_x, $glob_min_y, $glob_max_x, $glob_max_y);
    my($x,$y) = split /,/, $s_rec->[Strassen::COORDS][0];
    my $rec = pack("d2", $x, $y);
    $rec = pack("N", $glob_rec_no)
	. pack("N", length($rec)/2+4)
	    . pack("V", ESRI::Shapefile::Main::SHAPE_POINT)
		. $rec;
    $glob_rec_no++;
    $rec;
}

# XXX handle "*" coordinates as in comments-orig
sub create_polyline_record {
    my $s_rec = shift;
    my $rec = "\0" x 40;
    substr($rec, 0, 32) = pack("d4", get_bbox($s_rec->[Strassen::COORDS]));
    ($glob_min_x, $glob_min_y, $glob_max_x, $glob_max_y) =
	get_bbox($s_rec->[Strassen::COORDS],
		 $glob_min_x, $glob_min_y, $glob_max_x, $glob_max_y);
    substr($rec, 32, 4) = pack("V", 1);
    substr($rec, 36, 4) = pack("V", scalar @{$s_rec->[Strassen::COORDS]});
    $rec .= pack("V", 0);
    for (@{$s_rec->[Strassen::COORDS]}) {
	my($x,$y) = split /,/, $_;
	$rec .= pack("d2", $x, $y);
    }
    $rec = pack("N", $glob_rec_no)
	. pack("N", length($rec)/2+4)
	    . pack("V", ESRI::Shapefile::Main::SHAPE_POLYLINE)
		. $rec;
    $glob_rec_no++;
    $rec;
}

sub create_polygon_record {
    my $s_rec = shift;
    my $rec = "\0" x 40;
    # force a closed polygon
    if ($s_rec->[Strassen::COORDS][0] ne $s_rec->[Strassen::COORDS][-1]) {
	push @{ $s_rec->[Strassen::COORDS] }, $s_rec->[Strassen::COORDS][0];
    }
    substr($rec, 0, 32) = pack("d4", get_bbox($s_rec->[Strassen::COORDS]));
    ($glob_min_x, $glob_min_y, $glob_max_x, $glob_max_y) =
	get_bbox($s_rec->[Strassen::COORDS],
		 $glob_min_x, $glob_min_y, $glob_max_x, $glob_max_y);
    substr($rec, 32, 4) = pack("V", 1);
    substr($rec, 36, 4) = pack("V", scalar @{$s_rec->[Strassen::COORDS]});
    $rec .= pack("V", 0);
    for (@{$s_rec->[Strassen::COORDS]}) {
	my($x,$y) = split /,/, $_;
	$rec .= pack("d2", $x, $y);
    }
    $rec = pack("N", $glob_rec_no)
	. pack("N", length($rec)/2+4)
	    . pack("V", ESRI::Shapefile::Main::SHAPE_POLYGON)
		. $rec;
    $glob_rec_no++;
    $rec;
}

# XXX too much proprietary stuff here (-type, "Stadtstraen" etc.)
sub create_dbf_record {
    my($s_rec, %args) = @_;
    my $displayname;
    my $str_nr = "";
    my $cat_img = "";
    my $cat_anchor = "";
    my $angle = "";
    if (exists $args{-type} && $args{-type} =~ /^street/) {
	($displayname) = $s_rec->[Strassen::NAME] =~ /^([^\(]+)/;
	if (!defined $displayname) {
	    $displayname = $s_rec->[Strassen::NAME];
	}
    } else {
	($displayname) = $s_rec->[Strassen::NAME] =~ /^([^|]+)/;
    }
    if (exists $args{-type}) {
	if ($args{-type} eq 'street-l') {
	    my $stadt_strassen_rx = get_stadt_strassen_rx();
	    if ($s_rec->[Strassen::NAME] =~ $stadt_strassen_rx) {
		($displayname = $s_rec->[Strassen::NAME]) =~ s/\s*$stadt_strassen_rx//;
	    } else {
		$displayname = "";
	    }
	} elsif ($args{-type} =~ /^ferry/) {
	    $str_nr = "\xa0"; # dummy invisible string for mapserver
	    # a single space seems to be ignored by dbf or Xbase
	}
	if ($args{-type} eq 'street-l' ||
	    $args{-type} eq 'street-bab' ||
	    $args{-file} =~ /\bcomments_route/) {
	    my($type,$nr) = Strasse::parse_street_type_nr($s_rec->[Strassen::NAME]);
	    if (!defined $type && $city_obj && $city_obj->can("parse_street_type_nr")) {
		my $do_round; # XXX not yet used...
		($type, $nr, $do_round) = $city_obj->parse_street_type_nr($s_rec->[Strassen::NAME]);
		$nr = "" if !defined $nr;
	    }
	    if (defined $type) {
		if ($type eq 'BAB') {
		    $str_nr = $nr;
		    $displayname = $nr; # "100" is shorter than "BAB100"
		} else {
		    $str_nr = "$type$nr"; # XXX flacky...
		}
	    }
	}
    }
    if ($s_rec->[Strassen_SHORTCAT] =~ /\|/) {
	my(@t) = split /\|/, $s_rec->[Strassen_SHORTCAT];
	foreach (@t) {
	    if (/^IMG:(.*)/) {
		$cat_img = $1;
	    } elsif (/^ANCHOR:(.*)/) {
		$cat_anchor = $1;
	    }
	}
    }
    if ($s_rec->[Strassen::CAT] =~ m{^(?:BNP|0):[^:]*:(-?\d+)}) {
	$angle = -$1;
    }
    [$displayname, $s_rec->[Strassen_SHORTCAT], $s_rec->[Strassen::NAME],
     $str_nr, $cat_img, $cat_anchor, $angle];
}

sub get_bbox {
    my($cref, $min_x, $min_y, $max_x, $max_y) = @_;
    for (@$cref) {
	next if $_ eq '*';
	my($x, $y) = split /,/, $_;
	if (!defined $min_x || $x < $min_x) {
	    $min_x = $x;
	}
	if (!defined $max_x || $x > $max_x) {
	    $max_x = $x;
	}
	if (!defined $min_y || $y < $min_y) {
	    $min_y = $y;
	}
	if (!defined $max_y || $y > $max_y) {
	    $max_y = $y;
	}
    }
    ($min_x, $min_y, $max_x, $max_y);
}

sub init_shp_header {
    my $buf = "\0"x100;
    substr($buf, 0, 4)  = pack("N", ESRI::Shapefile::Main::FILECODE);
    substr($buf, 28, 4) = pack("V", ESRI::Shapefile::Main::VERSION);
    $buf;
}

sub set_shp_header {
    my($buf, %args) = @_;
    if (exists $args{-length}) {
	substr($buf, 24, 4) = pack("N", $args{-length}/2);
    }
    if (exists $args{-bbox}) {
	if (@{ $args{-bbox} } != 8) {
	    die "Bounding box should have 8 values";
	}
	my $pos = 36;
	for (@{ $args{-bbox} }) {
	    substr($buf, $pos, 8) = pack("d", $_);
	    $pos+=8;
	}
    }
    if (exists $args{-shapetype}) {
	my $const = eval "ESRI::Shapefile::Main::SHAPE_" . uc($args{-shapetype});
	if (!defined $const) {
	    die "Can't get shape type for $args{-shapetype}";
	}
	substr($buf, 32, 4) = pack("V", $const);
    }
    $buf;
}

# Leider zeichnet der Mapserver Linien grundstzlich von links nach rechts,
# so dass die Richtung der Einbahnstraen verloren geht. Hier ist ein
# Hack, um die Einbahnstraen nach der Himmelsrichtung (von links nach rechts
# oder rechts nach links) zu sortieren und mit den Kategorien 1_left und
# 1_right zu versehen. Der Grenzbereich der senkrechten Straen ist
# besonders problematisch und wird ignoriert.
#
sub oneway_hack {
    my $d = shift;
    my %res;
    my $c = $d->[Strassen::COORDS];
    my $last_dir;
    for my $i (1 .. $#$c) {
	my($x0,$y0) = split /,/, $c->[$i-1];
	my($x1,$y1) = split /,/, $c->[$i];

	my $get_direction = sub {
	    my $dir = ($x1 > $x0 ? 1 : -1);
	    my $deg = rad2deg(atan2($y1-$y0, $x1-$x0));
	    if (($deg > 89 && $deg < 91) || ($deg > -89 && $deg < -91)) {
		0;
	    } else {
		$dir;
	    }
	};

	if (!defined $last_dir) {
	    $last_dir = $get_direction->();
	    $res{$last_dir} = [[$c->[$i-1], $c->[$i]]];
	} else {
	    my $now_dir = $get_direction->();
	    if ($now_dir == $last_dir) {
		push @{ $res{$now_dir}[-1] }, $c->[$i];
	    } else {
		push @{ $res{$now_dir} }, [$c->[$i-1], $c->[$i]];
		$last_dir = $now_dir;
	    }
	}
    }

    my @res;
    for my $dir (-1, 0, 1) {
	next if $dir == 0; # ignore senkrechte
	my $cat = ($dir < 0 ? "1_right" : "1_left");
	for (@{ $res{$dir} }) {
	    my $r = [];
	    $r->[Strassen::NAME]    = $d->[Strassen::NAME];
	    $r->[Strassen::CAT]     = $cat;
	    $r->[Strassen::COORDS]  = $_;
	    $r->[Strassen_SHORTCAT] = $cat;
	    push @res, $r;
	}
    }
    @res;
}

sub do_encode {
    my($text, $encoding) = @_;
    if ($encoding eq 'html') {
	require HTML::Entities;
	HTML::Entities::encode_numeric($text, q{<>&"'}.qq{\200-\xffffffff});
    } else {
	unidecode_any($text, $encoding);
    }
}

{
    my $stadt_strassen_rx;
    my $warn_fallback;
    sub get_stadt_strassen_rx {
	if (!defined $stadt_strassen_rx) {
	    my @stadt_strassen;
	    eval {
		my %stadt;
		for my $basefile (qw(landstrassen-orig landstrassen2-orig)) {
		    my $file = "$FindBin::RealBin/../data/$basefile";
		    my $s = Strassen->new_stream($file);
		    $s->read_stream(sub {
					my $dir = $_[1];
					if ($dir->{append_comment}) {
					    $stadt{$dir->{append_comment}->[0]} = 1;
					}
				    });
		}
		@stadt_strassen = sort keys %stadt;
	    };
	    if (!@stadt_strassen) {
		if (!$warn_fallback++) {
		    warn "bbd2esri: stadt_strassen_rx could not be created, trying fallback. Error: $@";
		}
		# Generated with M-x occur --append in landstrassen-orig
		# and some hand-editing... XXX probably need another solution!
		@stadt_strassen = (qw(Potsdam Erkner Schnefeld
				      Dahlwitz-Hoppegarten Kleinmachnow Stahnsdorf Teltow Gosen Mahlow
				      Mahlow-Waldblick Brandenburg Frankfurt Cottbus), 'Hohen Neuendorf',
				   qw(Borgsdorf Oranienburg Rheinsberg Woltersdorf Rdersdorf Schneiche
				      Strausberg Lindenberg Falkensee Dallgow-Dberitz Werder), 'Knigs Wusterhausen',
				   qw(Eberswalde Bernau Frstenwalde Lbbenau Luckenwalde
				      Neuruppin Mittenwalde));
	    }
	    my $stadt_strassen_rx0 = "\\((?:" . join("|", map { quotemeta } @stadt_strassen) . ")\\)";
	    $stadt_strassen_rx = qr/$stadt_strassen_rx0/;
	}
	$stadt_strassen_rx;
    }
}

# REPO BEGIN
# REPO NAME unidecode_any /home/e/eserte/work/srezic-repository 
# REPO MD5 59f056efd990dc126e49f5e846eee797

=head2 unidecode_any($text, $encoding)

Similar to Text::Unidecode::unidecode, but convert to the given
$encoding. This will return an octet string in the given I<$encoding>.
If all you want is just to restrict the charset of the string to a
specific encoding charset, then it's best to C<Encode::decode> the
result again with I<$encoding>.

=cut

sub unidecode_any {
    my($text, $encoding) = @_;

    require Text::Unidecode;
    require Encode;

    # provide better conversions for german umlauts
    my %override = ("\xc4" => "Ae",
		    "\xd6" => "Oe",
		    "\xdc" => "Ue",
		    "\xe4" => "ae",
		    "\xf6" => "oe",
		    "\xfc" => "ue",
		   );
    my $override_rx = "(" . join("|", map { quotemeta } keys %override) . ")";
    $override_rx = qr{$override_rx};

    my $res = "";

    if (!eval {
	no warnings;
	Encode->VERSION(2.12); # need v2.12 to support coderef
	$res = Encode::encode($encoding, $text,
			      sub {
				  my $ch = chr $_[0];
				  if ($ch =~ $override_rx) {
				      return $override{$ch};
				  } else {
				      my $ascii = unidecode($ch);
				      Encode::_utf8_off($ascii);
				      $ascii;
				  }
			      });
	1;
    }) {
	for (split //, $text) {
	    my $conv = eval { Encode::encode($encoding, $_, Encode::FB_CROAK()) };
	    if ($@) {
		$res .= Text::Unidecode::unidecode($_);
	    } else {
		$res .= $conv;
	    }
	}
    }

    $res;
}
# REPO END

__END__
