Commit c1f88f41 authored by Birte Kristina Friesel's avatar Birte Kristina Friesel
Browse files

add train_descriptions accessor

parent 4806dd51

bin/db-wagenreihung

+12 −4
Original line number Diff line number Diff line
@@ -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",

lib/Travel/Status/DE/DBWagenreihung.pm

+76 −26
Original line number Diff line number Diff line
@@ -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,14 +324,14 @@ 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 );



	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 $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 $self->{train_powertype} = $likelihood[0];

	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,15 +568,16 @@ 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;



	for my $group (@wagon_groups) {

		my $tt = $self->train_subtype( @{$group} );

		if ($tt) {

		for my $wagon ( @{ $self->{wagons} } ) {

			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

lib/Travel/Status/DE/DBWagenreihung/Wagon.pm

+4 −1
Original line number Diff line number Diff line
@@ -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;

	}