add train_descriptions accessor

3 files changed, 92 insertions, 31 deletions

diff --git a/bin/db-wagenreihung b/bin/db-wagenreihung
index e0dd4c9..756785c 100755
--- a/bin/db-wagenreihung
+++ b/bin/db-wagenreihung
@@ -71,7 +71,7 @@ my $wr = Travel::Status::DE::DBWagenreihung->new(
 );
 
 printf(
-	"%s: %s → %s  (%s)\n%s Gleis %s\n\n",
+	"%s: %s → %s\n",
 	join( ' / ', map { $wr->train_type . ' ' . $_ } $wr->train_numbers ),
 	join( ' / ', $wr->origins ),
 	join(
@@ -80,11 +80,10 @@ printf(
 			sprintf( '%s (%s)', $_->{name}, join( q{}, @{ $_->{sections} } ) )
 		} $wr->destinations
 	),
-	$wr->train_desc,
-	$wr->station_name,
-	$wr->platform
 );
 
+printf( "%s Gleis %s\n\n", $wr->station_name, $wr->platform );
+
 for my $section ( $wr->sections ) {
 	my $section_length = $section->length_percent;
 	my $spacing_left   = int( ( $section_length - 2 ) / 2 ) - 1;
@@ -139,6 +138,15 @@ for my $wagon ( $wr->wagons ) {
 print $wr->direction == 100 ? '>' : '<';
 print "\n\n";
 
+for my $desc ( $wr->train_descriptions ) {
+	if ( $desc->{text} ) {
+		printf( "%s (%s)\n",
+			$desc->{text}, join( q{}, @{ $desc->{sections} } ) );
+	}
+}
+
+say "";
+
 for my $wagon ( $wr->wagons ) {
 	printf(
 		"%3s: %3s %10s  %s\n",
diff --git a/lib/Travel/Status/DE/DBWagenreihung.pm b/lib/Travel/Status/DE/DBWagenreihung.pm
index dcf1e8b..dd263a4 100644
--- a/lib/Travel/Status/DE/DBWagenreihung.pm
+++ b/lib/Travel/Status/DE/DBWagenreihung.pm
@@ -226,7 +226,6 @@ sub destinations {
 	for my $group ( @{ $self->{data}{istformation}{allFahrzeuggruppe} } ) {
 		my $destination = $group->{zielbetriebsstellename};
 		my @sections = map { $_->{fahrzeugsektor} } @{ $group->{allFahrzeug} };
-		@sections = uniq @sections;
 		push( @{ $section{$destination} }, @sections );
 		push( @destinations,               $destination );
 	}
@@ -234,7 +233,8 @@ sub destinations {
 	@destinations = uniq @destinations;
 
 	@destinations
-	  = map { { name => $_, sections => $section{$_} } } @destinations;
+	  = map { { name => $_, sections => [ uniq @{ $section{$_} } ] } }
+	  @destinations;
 
 	$self->{destinations} = \@destinations;
 
@@ -324,15 +324,15 @@ sub train_no {
 	return $self->{data}{istformation}{zugnummer};
 }
 
+# TODO rename to wagongrop_powertype
 sub train_powertype {
-	my ($self) = @_;
+	my ( $self, @wagons ) = @_;
 
-	if ( exists $self->{train_powertype} ) {
-		return $self->{train_powertype};
+	if ( not @wagons ) {
+		@wagons = $self->wagons;
 	}
 
-	my @wagons = $self->wagons;
-	my %ml     = map { $_ => 0 } ( 90 .. 99 );
+	my %ml = map { $_ => 0 } ( 90 .. 99 );
 
 	for my $wagon (@wagons) {
 
@@ -351,12 +351,51 @@ sub train_powertype {
 	my @likelihood = reverse sort { $ml{$a} <=> $ml{$b} } keys %ml;
 
 	if ( $ml{ $likelihood[0] } == 0 ) {
-		return $self->{train_powertype} = undef;
+		return undef;
 	}
 
-	return $self->{train_powertype} = $likelihood[0];
+	return $likelihood[0];
 }
 
+sub train_descriptions {
+	my ($self) = @_;
+
+	my @ret;
+
+	for my $wagons ( @{ $self->{wagongroups} } ) {
+		my $powertype = $self->train_powertype( @{$wagons} );
+		my @model     = $self->train_model( @{$wagons} );
+		my $desc      = q{};
+
+		my @sections = uniq map { $_->section } @{$wagons};
+
+		if (@model) {
+			$desc .= $model[0];
+		}
+
+		if ( $powertype and $power_desc{$powertype} ) {
+			if ( not $desc and $power_desc{$powertype} =~ m{^mit} ) {
+				$desc = "Zug";
+			}
+			$desc .= " $power_desc{$powertype}";
+		}
+
+		if ( @model > 1 ) {
+			$desc .= " ($model[1])";
+		}
+		push(
+			@ret,
+			{
+				sections => [@sections],
+				text     => $desc,
+			}
+		);
+	}
+
+	return @ret;
+}
+
+# TODO rename to wagongroup_desc
 sub train_desc {
 	my ($self) = @_;
 
@@ -383,10 +422,11 @@ sub train_desc {
 	return $ret;
 }
 
+# TODO rename to wagongroup_model
 sub train_model {
-	my ($self) = @_;
+	my ( $self, @wagons ) = @_;
 
-	my $subtype = $self->train_subtype;
+	my $subtype = $self->train_subtype(@wagons);
 
 	if ( $subtype and $model_name{$subtype} ) {
 		return @{ $model_name{$subtype} };
@@ -397,15 +437,14 @@ sub train_model {
 	return;
 }
 
+# TODO rename to wagongroup_subtype
 sub train_subtype {
-	my ($self) = @_;
+	my ( $self, @wagons ) = @_;
 
-	if ( exists $self->{train_subtype} ) {
-		return $self->{train_subtype};
+	if ( not @wagons ) {
+		@wagons = $self->wagons;
 	}
 
-	my @wagons = $self->wagons;
-
 	my %ml = (
 		'401'      => 0,
 		'402'      => 0,
@@ -487,9 +526,7 @@ sub train_subtype {
 		return undef;
 	}
 
-	$self->{train_subtype} = $likelihood[0];
-
-	return $self->{train_subtype};
+	return $likelihood[0];
 }
 
 sub wagons {
@@ -499,16 +536,21 @@ sub wagons {
 		return @{ $self->{wagons} };
 	}
 
+	my @wagon_groups;
+
 	for my $group ( @{ $self->{data}{istformation}{allFahrzeuggruppe} } ) {
+		my @group;
 		for my $wagon ( @{ $group->{allFahrzeug} } ) {
 			my $wagon_object
 			  = Travel::Status::DE::DBWagenreihung::Wagon->new( %{$wagon},
 				train_no => $group->{verkehrlichezugnummer} );
 			push( @{ $self->{wagons} }, $wagon_object );
+			push( @group,               $wagon_object );
 			if ( not $wagon_object->{position}{valid} ) {
 				$self->{has_bad_wagons} = 1;
 			}
 		}
+		push( @wagon_groups, [@group] );
 	}
 	if ( @{ $self->{wagons} // [] } > 1 and not $self->has_bad_wagons ) {
 		if ( $self->{wagons}[0]->{position}{start_percent}
@@ -526,16 +568,17 @@ sub wagons {
 		} @{ $self->{wagons} };
 	}
 
-	# ->train_subtype calls ->wagons, so this call must not be made before
-	# $self->{wagons} has beet set.
-	my $tt = $self->train_subtype;
-
-	if ($tt) {
-		for my $wagon ( @{ $self->{wagons} } ) {
-			$wagon->set_traintype($tt);
+	for my $group (@wagon_groups) {
+		my $tt = $self->train_subtype( @{$group} );
+		if ($tt) {
+			for my $wagon ( @{$group} ) {
+				$wagon->set_traintype($tt);
+			}
 		}
 	}
 
+	$self->{wagongroups} = [@wagon_groups];
+
 	return @{ $self->{wagons} // [] };
 }
 
@@ -700,6 +743,13 @@ Returns the name of the requested station.
 
 Returns the international id (UIC ID / IBNR) of the requested station.
 
+=item $wr->train_descriptions
+
+Returns a list of hashes describing the rolling stock used for this train based
+on model and locomotive (if present). Each hash contains the keys B<text>
+(textual representation, see C<< $wr->train_desc >>) and B<sections>
+(arrayref of corresponding sections).
+
 =item $wr->train_desc
 
 Returns a string describing the rolling stock used for this train based on
diff --git a/lib/Travel/Status/DE/DBWagenreihung/Wagon.pm b/lib/Travel/Status/DE/DBWagenreihung/Wagon.pm
index 319c919..060f303 100644
--- a/lib/Travel/Status/DE/DBWagenreihung/Wagon.pm
+++ b/lib/Travel/Status/DE/DBWagenreihung/Wagon.pm
@@ -13,7 +13,8 @@ Travel::Status::DE::DBWagenreihung::Wagon->mk_ro_accessors(
 	qw(attributes class_type has_ac has_accessibility has_bahn_comfort
 	  has_bike_storage has_bistro has_compartments has_family_area
 	  has_phone_area has_quiet_area is_dosto is_interregio is_locomotive
-	  is_powercar number model multipurpose section train_no type uic_id)
+	  is_powercar number model multipurpose section train_no train_subtype type
+	  uic_id)
 );
 
 our %type_attributes = (
@@ -197,6 +198,8 @@ sub parse_type {
 sub set_traintype {
 	my ( $self, $tt ) = @_;
 
+	$self->{train_subtype} = $tt;
+
 	if ( not $self->{number} or not exists( $type_attributes{$tt} ) ) {
 		return;
 	}