diff options
| -rwxr-xr-x | bin/db-wagenreihung | 16 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/DBWagenreihung.pm | 102 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/DBWagenreihung/Wagon.pm | 5 |
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; } |