From 1294a5b0aa33e3d9e04e3f8e5c47ab927e97d42b Mon Sep 17 00:00:00 2001
From: Daniel Friesel <derf@finalrewind.org>
Date: Sun, 20 Dec 2020 09:23:04 +0100
Subject: add cycle plan ("Umlaufplan") and empty LPF trains ("Leerfahrt")

---
 bin/db-wagenreihung-to-json | 105 +++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 99 insertions(+), 6 deletions(-)

(limited to 'bin')

diff --git a/bin/db-wagenreihung-to-json b/bin/db-wagenreihung-to-json
index 7c279c0..8956477 100755
--- a/bin/db-wagenreihung-to-json
+++ b/bin/db-wagenreihung-to-json
@@ -11,6 +11,7 @@ use utf8;
 use File::Slurp qw(write_file);
 use IPC::Run3;
 use JSON;
+use List::Util qw(uniq);
 
 sub show_usage {
 	my ($exit_code) = @_;
@@ -214,6 +215,10 @@ for my $line (@lines) {
 		}
 	}
 
+	if ( $line eq 'F. Anhang V: Beschilderungsplan' ) {
+		last;
+	}
+
 	if ( $line
 		=~ m{ ^ (?<type> [EINR][CJN][ A-Z-]{6}) (?<number> [ 0-9]{2,12}) }x )
 	{
@@ -263,7 +268,9 @@ for my $line (@lines) {
 			$map{$number}{type} = $type;
 		}
 	}
-	elsif ( $line =~ m{^LPF} ) {
+	elsif (
+		$line =~ m{ ^ (?<type> LPF T? (-[A-Z])? ) (?<number> [ 0-9]{2,12}) }x )
+	{
 
 		# Not in passenger service ("Leehrfahrt"). Ignore it for now.
 		# FWIW, LPF(T) can be further distinguished:
@@ -271,8 +278,25 @@ for my $line (@lines) {
 		# LPFT-B: ICE BR 412
 		# LPFT-T: ICE BR 411 / 415 / 605
 		# LPFT-W: ICE BR 403 / 406
-		$number = undef;
-		$state  = "";
+		#$number = undef;
+		#$state  = "";
+
+		$type = $+{type};
+		$type =~ tr{ }{}d;
+		$number = $+{number};
+		$number =~ tr{ }{}d;
+
+		if ( $number !~ m{ ^ \d+ $ }x ) {
+			next;
+		}
+
+		$state = "train_no";
+
+		$map{$number} = {
+			raw   => $type,
+			type  => $type,
+			empty => \1,
+		};
 	}
 
 	elsif ( $state eq "train_no" and $line =~ m{ ^ \s{2,6} \S }x ) {
@@ -345,13 +369,21 @@ for my $line (@lines) {
 
 	if (    $number
 		and $line
-		=~ m{ ^ \d* \s{1,10} (?<type> ( D? (WL)? (A|AB|B|W) R? D? [aceimpvw] \S* ) | 40[1-9]([.][0-9])? ) \s* (?<number> \d+ )? (?: $ | \s{3} ) }x
+		=~ m{ ^ \d* \s{1,10} (?<type> ( D? (WL)? (A|AB|B|W) R? D? [aceimpvw] \S* ) | 40[1-9]([.][0-9])? ) \s* (?<number> \d+ )? (?: $ | \s{3} (?<rest> .* ) $ ) }x
 	  )
 	{
 		$state = "wagonorder";
-		push( @{ $wagon_map{$number} }, [ $+{type}, $+{number} ] );
+		my $wagon_type   = $+{type};
+		my $wagon_number = $+{number};
+		my $rest         = $+{rest};
+
+		push( @{ $wagon_map{$number} }, [ $wagon_type, $wagon_number ] );
 
-		$map{$number}{has_wagon}{$1} = \1;
+		if ( $rest and $rest =~ m{\S} ) {
+			push( @{ $map{$number}{wagonorder_notes} }, $line );
+		}
+
+		$map{$number}{has_wagon}{$wagon_type} = \1;
 	}
 
 	if ( $state eq "conditions" and length($line) and $line =~ m{ \S }x ) {
@@ -366,6 +398,67 @@ for my $line (@lines) {
 	}
 }
 
+#for my $train ( values %map ) {
+#	if ($train->{route} and $train->{route} =~ m{ - }) {
+#		my @route_parts = split(qr{ - }, $train->{route});
+#	}
+#}
+
+for my $train ( values %map ) {
+	if ( @{ $train->{wagonorder_notes} // [] } == 0 ) {
+		next;
+	}
+	my $first_line  = $train->{wagonorder_notes}[0];
+	my $from_offset = 0;
+	my $to_offset   = 0;
+	if ( $first_line
+		=~ m{ ^ (?<lead> .*? [^0-9] ) (?<from> \d+ ) (?<middle> [A-Z ]+ ) (?<to> \d+ ) $ }x
+	  )
+	{
+		$from_offset = length( $+{lead} );
+		$to_offset   = $from_offset + length( $+{from} ) + length( $+{middle} );
+	}
+	if ( not $from_offset ) {
+		next;
+	}
+	for my $line ( @{ $train->{wagonorder_notes} } ) {
+		if ( length($line) <= $from_offset ) {
+			next;
+		}
+		my $umlauf = substr( $line, $from_offset );
+		if ( $umlauf =~ m{ ^ (\d+) }x ) {
+			push( @{ $train->{cycle}{from} }, $1 );
+		}
+		if ( length($line) > $to_offset and $line =~ m{ (\d+) $ }x ) {
+			push( @{ $train->{cycle}{to} }, $1 );
+		}
+	}
+	if ( exists $train->{cycle}{from} ) {
+		@{ $train->{cycle}{from} } = uniq @{ $train->{cycle}{from} };
+		@{ $train->{cycle}{to} }   = uniq @{ $train->{cycle}{to} };
+	}
+}
+
+#for my $train_number ( keys %map ) {
+#	my $tr = $map{$train_number}{route} // q{};
+#	$tr =~ s{ - .* - }{ - };
+#	my $this = sprintf("\"%d %s\"", $train_number, $tr);
+#	for my $from ( @{ $map{$train_number}{umlauf}{from} // [] } ) {
+#		$tr = $map{$from}{route} // q{};
+#		$tr =~ s{ - .* - }{ - };
+#		$from = sprintf("\"%d %s\"", $from, $tr);
+#		say "$from -> $this;";
+#	}
+#	for my $to ( @{ $map{$train_number}{umlauf}{to} // [] } ) {
+#		$tr = $map{$to}{route} // q{};
+#		$tr =~ s{ -.*- }{ - };
+#		$to = sprintf("\"%d %s\"", $to, $tr);
+#		say "$this -> $to;";
+#	}
+#}
+
+#exit 0;
+
 for my $train_number ( keys %map ) {
 	my $wagon_numbers_ok = 1;
 	my $wagon_types_ok   = 1;
-- 
cgit v1.2.3