summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xbin/db-wagenreihung16
-rw-r--r--lib/Travel/Status/DE/DBWagenreihung.pm102
-rw-r--r--lib/Travel/Status/DE/DBWagenreihung/Wagon.pm5
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;
}