diff options
Diffstat (limited to 'lib/Travel/Status/DE/DBWagenreihung')
| -rw-r--r-- | lib/Travel/Status/DE/DBWagenreihung/Carriage.pm | 189 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/DBWagenreihung/Group.pm | 379 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/DBWagenreihung/Section.pm | 34 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/DBWagenreihung/Sector.pm | 51 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/DBWagenreihung/Wagon.pm | 272 |
5 files changed, 594 insertions, 331 deletions
diff --git a/lib/Travel/Status/DE/DBWagenreihung/Carriage.pm b/lib/Travel/Status/DE/DBWagenreihung/Carriage.pm new file mode 100644 index 0000000..ca9d56a --- /dev/null +++ b/lib/Travel/Status/DE/DBWagenreihung/Carriage.pm @@ -0,0 +1,189 @@ +package Travel::Status::DE::DBWagenreihung::Carriage; + +use strict; +use warnings; +use 5.020; +use utf8; + +use parent 'Class::Accessor'; +use Carp qw(cluck); + +our $VERSION = '0.14'; +Travel::Status::DE::DBWagenreihung::Carriage->mk_ro_accessors( + qw(class_type is_closed is_dosto is_locomotive is_powercar + number model section uic_id type + start_meters end_meters length_meters start_percent end_percent length_percent + ) +); + +sub new { + my ( $obj, %opt ) = @_; + my $ref = {}; + + my %json = %{ $opt{json} }; + my $platform = $opt{platform}; + + $ref->{class_type} = 0; + $ref->{has_bistro} = 0; + $ref->{is_locomotive} = 0; + $ref->{is_powercar} = 0; + $ref->{is_closed} = 0; + $ref->{number} = $json{wagonIdentificationNumber}; + $ref->{model} = $json{vehicleID}; + $ref->{uic_id} = $json{vehicleID}; + $ref->{section} = $json{platformPosition}{sector}; + $ref->{type} = $json{type}{constructionType}; + + $ref->{model} =~ s{^.....(...)....(?:-.)?$}{$1} or $ref->{model} = undef; + + my $self = bless( $ref, $obj ); + + $self->parse_type; + + if ( $json{status} and $json{status} eq 'CLOSED' ) { + $ref->{is_closed} = 1; + } + + if ( $json{type}{category} =~ m{DININGCAR} ) { + $ref->{has_bistro} = 1; + } + elsif ( $json{type}{category} eq 'LOCOMOTIVE' ) { + $ref->{is_locomotive} = 1; + } + elsif ( $json{type}{category} eq 'POWERCAR' ) { + $ref->{is_powercar} = 1; + } + + if ( $ref->{type} =~ m{AB} ) { + $ref->{class_type} = 12; + } + elsif ( $ref->{type} =~ m{A} ) { + $ref->{class_type} = 1; + } + elsif ( $ref->{type} =~ m{B|WR} ) { + $ref->{class_type} = 2; + } + + my $pos = $json{platformPosition}; + my $platform_length = $platform->{end} - $platform->{start}; + + $ref->{start_meters} = $pos->{start}; + $ref->{end_meters} = $pos->{end}; + $ref->{start_percent} + = ( $pos->{start} - $platform->{start} ) * 100 / $platform_length, + $ref->{end_percent} + = ( $pos->{end} - $platform->{start} ) * 100 / $platform_length, + $ref->{length_meters} = $pos->{start} - $pos->{end}; + $ref->{length_percent} = $ref->{end_percent} - $ref->{start_percent}; + + if ( $pos->{start} eq '' + or $pos->{end} eq '' ) + { + $ref->{position}{valid} = 0; + } + else { + $ref->{position}{valid} = 1; + } + + return $self; +} + +sub attributes { + my ($self) = @_; + + return @{ $self->{attributes} // [] }; +} + +# See also: +# https://de.wikipedia.org/wiki/UIC-Bauart-Bezeichnungssystem_f%C3%BCr_Reisezugwagen#Kennbuchstaben +# https://www.deutsche-reisezugwagen.de/lexikon/erklarung-der-gattungszeichen/ +sub parse_type { + my ($self) = @_; + + my $type = $self->{type}; + my @desc; + + if ( $type =~ m{^D} ) { + $self->{is_dosto} = 1; + push( @desc, 'Doppelstock' ); + } + + if ( $type =~ m{b} ) { + $self->{has_accessibility} = 1; + push( @desc, 'Behindertengerechte Ausstattung' ); + } + + if ( $type =~ m{d} ) { + $self->{multipurpose} = 1; + push( @desc, 'Mehrzweck' ); + } + + if ( $type =~ m{f} ) { + push( @desc, 'Steuerabteil' ); + } + + if ( $type =~ m{i} ) { + push( @desc, 'Interregio' ); + } + + if ( $type =~ m{mm} ) { + push( @desc, 'modernisiert' ); + } + + if ( $type =~ m{p} ) { + $self->{has_ac} = 1; + push( @desc, 'Großraum' ); + } + + if ( $type =~ m{s} ) { + push( @desc, 'Sonderabteil' ); + } + + if ( $type =~ m{v} ) { + $self->{has_ac} = 1; + $self->{has_compartments} = 1; + push( @desc, 'Abteil' ); + } + + if ( $type =~ m{w} ) { + $self->{has_ac} = 1; + $self->{has_compartments} = 1; + push( @desc, 'Abteil' ); + } + + $self->{attributes} = \@desc; +} + +sub is_first_class { + my ($self) = @_; + + if ( $self->{type} =~ m{^D?A} ) { + return 1; + } + return 0; +} + +sub is_second_class { + my ($self) = @_; + + if ( $self->{type} =~ m{^D?A?B} ) { + return 1; + } + return 0; +} + +sub sections { + my ($self) = @_; + + return @{ $self->{sections} }; +} + +sub TO_JSON { + my ($self) = @_; + + my %copy = %{$self}; + + return {%copy}; +} + +1; diff --git a/lib/Travel/Status/DE/DBWagenreihung/Group.pm b/lib/Travel/Status/DE/DBWagenreihung/Group.pm index dd98550..5cd2b24 100644 --- a/lib/Travel/Status/DE/DBWagenreihung/Group.pm +++ b/lib/Travel/Status/DE/DBWagenreihung/Group.pm @@ -6,61 +6,390 @@ use 5.020; use utf8; use parent 'Class::Accessor'; +use List::Util qw(uniq); our $VERSION = '0.14'; Travel::Status::DE::DBWagenreihung::Group->mk_ro_accessors( - qw(id train_no type description desc_short origin destination has_sections) + qw(train_no train_type description desc_short destination has_sectors model series) ); +# {{{ Rolling Stock Models + +my %model_name = ( + '011' => [ 'ICE T', 'ÖBB 4011' ], + '401' => ['ICE 1'], + '402' => ['ICE 2'], + '403.S1' => [ 'ICE 3', 'BR 403, 1. Serie' ], + '403.S2' => [ 'ICE 3', 'BR 403, 2. Serie' ], + '403.R' => [ 'ICE 3', 'BR 403 Redesign' ], + '406' => [ 'ICE 3', 'BR 406' ], + '406.R' => [ 'ICE 3', 'BR 406 Redesign' ], + '407' => [ 'ICE 3 Velaro', 'BR 407' ], + '408' => [ 'ICE 3neo', 'BR 408' ], + '411.S1' => [ 'ICE T', 'BR 411, 1. Serie' ], + '411.S2' => [ 'ICE T', 'BR 411, 2. Serie' ], + '412' => ['ICE 4'], + '415' => [ 'ICE T', 'BR 415' ], + '420' => ['BR 420'], + '422' => ['BR 422'], + '423' => ['BR 423'], + '425' => ['BR 425'], + '427' => [ 'FLIRT', 'BR 427' ], + '428' => [ 'FLIRT', 'BR 428' ], + '429' => [ 'FLIRT', 'BR 429' ], + '430' => ['BR 430'], + '440' => [ 'Coradia Continental', 'BR 440' ], + '442' => [ 'Talent 2', 'BR 442' ], + '445' => [ 'Twindexx Vario', 'BR 445' ], + '446' => [ 'Twindexx Vario', 'BR 446' ], + '462' => [ 'Desiro HC', 'BR 462' ], + '463' => [ 'Mireo', 'BR 463' ], + '475' => [ 'TGV', 'BR 475' ], + '612' => [ 'RegioSwinger', 'BR 612' ], + '620' => [ 'LINT 81', 'BR 620' ], + '622' => [ 'LINT 54', 'BR 622' ], + '631' => [ 'Link I', 'BR 631' ], + '632' => [ 'Link II', 'BR 632' ], + '633' => [ 'Link III', 'BR 633' ], + '640' => [ 'LINT 27', 'BR 640' ], + '642' => [ 'Desiro Classic', 'BR 642' ], + '643' => [ 'TALENT', 'BR 643' ], + '648' => [ 'LINT 41', 'BR 648' ], + 'IC2.TWIN' => ['IC 2 Twindexx'], + 'IC2.KISS' => ['IC 2 KISS'], +); + +my %power_desc = ( + 90 => 'mit sonstigem Antrieb', + 91 => 'mit elektrischer Lokomotive', + 92 => 'mit Diesellokomotive', + 93 => 'Hochgeschwindigkeitszug', + 94 => 'Elektrischer Triebzug', + 95 => 'Diesel-Triebzug', + 96 => 'mit speziellen Beiwagen', + 97 => 'mit elektrischer Rangierlok', + 98 => 'mit Diesel-Rangierlok', + 99 => 'Sonderfahrzeug', +); + +# }}} + sub new { my ( $obj, %opt ) = @_; - my $ref = \%opt; - return bless( $ref, $obj ); -} + my %json = %{ $opt{json} }; -sub set_description { - my ( $self, $desc, $short ) = @_; + my $ref = { + carriages => $opt{carriages}, + destination => $json{transport}{destination}{name}, + train_type => $json{transport}{category}, + name => $json{transport}{name}, + line => $json{transport}{numberwline}, + train_no => $json{transport}{number}, + }; - $self->{description} = $desc; - $self->{desc_short} = $short; + $ref->{sectors} = [ + uniq grep { defined } + map { $_->{platformPosition}{sector} } @{ $json{vehicles} // [] } + ]; + if ( @{ $ref->{sectors} } ) { + $ref->{has_sectors} = 1; + } + + bless( $ref, $obj ); + + $ref->parse_description; + + return $ref; } -sub set_sections { - my ( $self, @sections ) = @_; +sub parse_powertype { + my ($self) = @_; + + my %ml = map { $_ => 0 } ( 90 .. 99 ); + + for my $carriage ( $self->carriages ) { + + if ( not $carriage->uic_id or length( $carriage->uic_id ) != 12 ) { + next; + } + + my $carriage_type = substr( $carriage->uic_id, 0, 2 ); + if ( $carriage_type < 90 ) { + next; + } + + $ml{$carriage_type}++; + } + + my @likelihood = reverse sort { $ml{$a} <=> $ml{$b} } keys %ml; - $self->{sections} = [@sections]; + if ( $ml{ $likelihood[0] } == 0 ) { + return; + } - $self->{has_sections} = 1; + $self->{powertype} = $likelihood[0]; } -sub set_traintype { - my ( $self, $i, $tt ) = @_; - $self->{type} = $tt; - for my $wagon ( $self->wagons ) { - $wagon->set_traintype( $i, $tt ); +sub parse_model { + my ($self) = @_; + + my %ml = ( + '011' => 0, + '401' => 0, + '402' => 0, + '403.S1' => 0, + '403.S2' => 0, + '403.R' => 0, + '406' => 0, + '407' => 0, + '408' => 0, + '411.S1' => 0, + '411.S2' => 0, + '412' => 0, + '415' => 0, + '420' => 0, + '422' => 0, + '423' => 0, + '425' => 0, + '427' => 0, + '428' => 0, + '429' => 0, + '430' => 0, + '440' => 0, + '442' => 0, + '445' => 0, + '446' => 0, + '462' => 0, + '463' => 0, + '475' => 0, + '612' => 0, + '620' => 0, + '622' => 0, + '631' => 0, + '632' => 0, + '633' => 0, + '640' => 0, + '642' => 0, + '643' => 0, + '648' => 0, + 'IC2.TWIN' => 0, + 'IC2.KISS' => 0, + ); + + my @carriages = $self->carriages; + + for my $carriage (@carriages) { + if ( not $carriage->model ) { + next; + } + if ( $carriage->model == 401 + or ( $carriage->model >= 801 and $carriage->model <= 804 ) ) + { + $ml{'401'}++; + } + elsif ( $carriage->model == 402 + or ( $carriage->model >= 805 and $carriage->model <= 808 ) ) + { + $ml{'402'}++; + } + elsif ( $carriage->model == 403 + and substr( $carriage->uic_id, 9, 2 ) <= 37 ) + { + $ml{'403.S1'}++; + } + elsif ( $carriage->model == 403 + and substr( $carriage->uic_id, 9, 2 ) > 37 ) + { + $ml{'403.S2'}++; + } + elsif ( $carriage->model == 406 ) { + $ml{'406'}++; + } + elsif ( $carriage->model == 407 ) { + $ml{'407'}++; + } + elsif ( $carriage->model == 408 ) { + $ml{'408'}++; + } + elsif ( $carriage->model == 412 or $carriage->model == 812 ) { + $ml{'412'}++; + } + elsif ( $carriage->model == 411 + and substr( $carriage->uic_id, 9, 2 ) <= 32 ) + { + $ml{'411.S1'}++; + } + elsif ( $carriage->model == 411 + and substr( $carriage->uic_id, 9, 2 ) > 32 ) + { + $ml{'411.S2'}++; + } + elsif ( $carriage->model == 415 ) { + $ml{'415'}++; + } + elsif ( $carriage->model == 420 or $carriage->model == 421 ) { + $ml{'420'}++; + } + elsif ( $carriage->model == 422 or $carriage->model == 432 ) { + $ml{'422'}++; + } + elsif ( $carriage->model == 423 or $carriage->model == 433 ) { + $ml{'423'}++; + } + elsif ( $carriage->model == 425 or $carriage->model == 435 ) { + $ml{'425'}++; + } + elsif ( $carriage->model == 427 or $carriage->model == 827 ) { + $ml{'427'}++; + } + elsif ( $carriage->model == 428 or $carriage->model == 828 ) { + $ml{'428'}++; + } + elsif ( $carriage->model == 429 or $carriage->model == 829 ) { + $ml{'429'}++; + } + elsif ( $carriage->model == 430 or $carriage->model == 431 ) { + $ml{'430'}++; + } + elsif ($carriage->model == 440 + or $carriage->model == 441 + or $carriage->model == 841 ) + { + $ml{'440'}++; + } + elsif ($carriage->model == 442 + or $carriage->model == 443 ) + { + $ml{'442'}++; + } + elsif ($carriage->model == 462 + or $carriage->model == 862 ) + { + $ml{'462'}++; + } + elsif ($carriage->model == 463 + or $carriage->model == 863 ) + { + $ml{'463'}++; + } + elsif ( $carriage->model == 445 ) { + $ml{'445'}++; + } + elsif ( $carriage->model == 446 ) { + $ml{'446'}++; + } + elsif ( $carriage->model == 475 ) { + $ml{'475'}++; + } + elsif ( $carriage->model == 612 ) { + $ml{'612'}++; + } + elsif ( $carriage->model == 620 or $carriage->model == 621 ) { + $ml{'620'}++; + } + elsif ( $carriage->model == 622 ) { + $ml{'622'}++; + } + elsif ( $carriage->model == 631 ) { + $ml{'631'}++; + } + elsif ( $carriage->model == 632 ) { + $ml{'632'}++; + } + elsif ( $carriage->model == 633 ) { + $ml{'633'}++; + } + elsif ( $carriage->model == 640 ) { + $ml{'640'}++; + } + elsif ( $carriage->model == 642 ) { + $ml{'642'}++; + } + elsif ( $carriage->model == 643 or $carriage->model == 943 ) { + $ml{'643'}++; + } + elsif ( $carriage->model == 648 ) { + $ml{'648'}++; + } + elsif ( $self->train_type eq 'IC' and $carriage->model == 110 ) { + $ml{'IC2.KISS'}++; + } + elsif ( $self->train_type eq 'IC' and $carriage->is_dosto ) { + $ml{'IC2.TWIN'}++; + } + elsif ( substr( $carriage->uic_id, 4, 4 ) eq '4011' ) { + $ml{'011'}++; + } + } + + my @likelihood = reverse sort { $ml{$a} <=> $ml{$b} } keys %ml; + + # Less than two carriages are generally inconclusive. + # Exception: BR 631 (Link I) only has a single carriage + if ( + $ml{ $likelihood[0] } < 2 + and not($likelihood[0] eq '631' + and @carriages == 1 + and substr( $carriages[0]->uic_id, 0, 2 ) eq '95' ) + ) + { + $self->{subtype} = undef; + } + else { + $self->{subtype} = $likelihood[0]; + } + + if ( $self->{subtype} and $model_name{ $self->{subtype} } ) { + my @model = @{ $model_name{ $self->{subtype} } }; + $self->{model} = $model[0]; + $self->{series} = $model[-1]; } } -sub sort_wagons { +sub parse_description { my ($self) = @_; - @{ $self->{wagons} } - = sort { $a->{position}{start_percent} <=> $b->{position}{start_percent} } - @{ $self->{wagons} }; + $self->parse_powertype; + $self->parse_model; + + my $short; + my $ret = q{}; + + if ( $self->{model} ) { + $short = $self->{model}; + $ret .= $self->{model}; + } + + if ( $self->{powertype} and $power_desc{ $self->{powertype} } ) { + if ( not $ret and $power_desc{ $self->{powertype} } =~ m{^mit} ) { + $ret = "Zug"; + } + $ret .= ' ' . $power_desc{ $self->{powertype} }; + $short //= $ret; + $short =~ s{elektrischer }{E-}; + $short =~ s{[Ll]\Kokomotive}{ok}; + } + + if ( $self->{series} and $self->{series} ne $self->{model} ) { + $ret .= ' (' . $self->{series} . ')'; + } + + $self->{desc_short} = $short; + $self->{description} = $ret; } -sub sections { +sub sectors { my ($self) = @_; - return @{ $self->{sections} // [] }; + return @{ $self->{sectors} // [] }; } -sub wagons { +sub carriages { my ($self) = @_; - return @{ $self->{wagons} // [] }; + return @{ $self->{carriages} // [] }; } sub TO_JSON { diff --git a/lib/Travel/Status/DE/DBWagenreihung/Section.pm b/lib/Travel/Status/DE/DBWagenreihung/Section.pm deleted file mode 100644 index 5bbf1c9..0000000 --- a/lib/Travel/Status/DE/DBWagenreihung/Section.pm +++ /dev/null @@ -1,34 +0,0 @@ -package Travel::Status::DE::DBWagenreihung::Section; - -use strict; -use warnings; -use 5.020; -use utf8; - -use parent 'Class::Accessor'; - -our $VERSION = '0.14'; - -Travel::Status::DE::DBWagenreihung::Section->mk_ro_accessors( - qw(name start_percent end_percent length_percent start_meters end_meters length_meters) -); - -sub new { - my ( $obj, %opt ) = @_; - my $ref = \%opt; - - $ref->{length_meters} = $ref->{end_meters} - $ref->{start_meters}; - $ref->{length_percent} = $ref->{end_percent} - $ref->{start_percent}; - - return bless( $ref, $obj ); -} - -sub TO_JSON { - my ($self) = @_; - - my %copy = %{$self}; - - return {%copy}; -} - -1; diff --git a/lib/Travel/Status/DE/DBWagenreihung/Sector.pm b/lib/Travel/Status/DE/DBWagenreihung/Sector.pm new file mode 100644 index 0000000..a039845 --- /dev/null +++ b/lib/Travel/Status/DE/DBWagenreihung/Sector.pm @@ -0,0 +1,51 @@ +package Travel::Status::DE::DBWagenreihung::Sector; + +use strict; +use warnings; +use 5.020; +use utf8; + +use parent 'Class::Accessor'; + +our $VERSION = '0.14'; + +Travel::Status::DE::DBWagenreihung::Sector->mk_ro_accessors( + qw(name start_percent end_percent length_percent start_meters end_meters length_meters cube_meters cube_percent) +); + +sub new { + my ( $obj, %opt ) = @_; + + my %section = %{ $opt{json} }; + my %platform = %{ $opt{platform} }; + + my $platform_length = $platform{end} - $platform{start}; + + my $ref = { + name => $section{name}, + start_meters => $section{start}, + end_meters => $section{end}, + length_meters => $section{end} - $section{start}, + cube_meters => $section{cubePosition}, + start_percent => ( $section{start} - $platform{start} ) + * 100 / $platform_length, + end_percent => ( $section{end} - $platform{start} ) + * 100 / $platform_length, + cube_percent => ( $section{cubePosition} - $platform{start} ) + * 100 / $platform_length, + }; + + $ref->{length_percent} = $ref->{end_percent} - $ref->{start_percent}; + + return bless( $ref, $obj ); +} + +sub TO_JSON { + my ($self) = @_; + + my %copy = %{$self}; + + return {%copy}; +} + +1; diff --git a/lib/Travel/Status/DE/DBWagenreihung/Wagon.pm b/lib/Travel/Status/DE/DBWagenreihung/Wagon.pm deleted file mode 100644 index 549a5ff..0000000 --- a/lib/Travel/Status/DE/DBWagenreihung/Wagon.pm +++ /dev/null @@ -1,272 +0,0 @@ -package Travel::Status::DE::DBWagenreihung::Wagon; - -use strict; -use warnings; -use 5.020; -use utf8; - -use parent 'Class::Accessor'; -use Carp qw(cluck); - -our $VERSION = '0.14'; -Travel::Status::DE::DBWagenreihung::Wagon->mk_ro_accessors( - qw(attributes class_type group_index has_ac has_accessibility - has_bahn_comfort has_bike_storage has_bistro has_compartments - has_family_area has_phone_area has_quiet_area is_closed is_dosto - is_interregio is_locomotive is_powercar number model multipurpose section - train_no train_subtype type uic_id) -); - -our %type_attributes = ( - 'ICE 1' => [ - undef, ['has_quiet_area'], undef, ['has_quiet_area'], # 1 2 3 4 - ['has_family_area'], undef, ['has_bahn_comfort'], # 5 6 7 - undef, undef, undef, ['has_bahn_comfort'], # 8 9 (10) 11 - ['has_quiet_area'], undef, undef # 12 (13) 14 - ], - 'ICE 2' => [ - undef, ['has_quiet_area'], ['has_bahn_comfort'], - ['has_family_area'], # 1 2 3 4 - undef, ['has_bahn_comfort'], - [ 'has_quiet_area', 'has_phone_area' ] # 5 6 7 - ], - 'ICE 3' => [ - ['has_quiet_area'], undef, undef, undef, # 1 2 3 (4) - ['has_family_area'], undef, ['has_bahn_comfort'], # 5 6 7 - [ 'has_quiet_area', 'has_phone_area', 'has_bahn_comfort' ], undef # 8 9 - ], - 'ICE 3 Velaro' => [ - ['has_quiet_area'], undef, undef, ['has_family_area'], # 1 2 3 4 - ['has_bahn_comfort'], ['has_bahn_comfort'], undef, undef, # 5 6 (7) 8 - [ 'has_quiet_area', 'has_phone_area' ] # 9 - ], - 'ICE 4' => [ - ['has_bike_storage'], undef, ['has_quiet_area'], undef, - undef, # 1 2 3 4 5 - undef, ['has_bahn_comfort'], undef, ['has_family_area'], # 6 7 (8) 9 - undef, ['has_bahn_comfort'], undef, undef, - ['has_quiet_area'] # 10 11 12 (13) 14 - ], - 'ICE T 411' => [ - ['has_quiet_area'], ['has_quiet_area'], undef, - ['has_family_area'], # 1 2 3 4 - undef, undef, ['has_bahn_comfort'], - [ 'has_quiet_area', 'has_bahn_comfort' ] # (5) 6 7 8 - ], - 'ICE T 415' => [ - ['has_quiet_area'], ['has_quiet_area'], ['has_bahn_comfort'], - undef, # 1 2 3 (4) - undef, undef, ['has_family_area'], - [ 'has_quiet_area', 'has_bahn_comfort' ] # (5) (6) 7 8 - ], - 'IC2 Twindexx' => [ - [ 'has_family_area', 'has_bike_storage' ], ['has_bike_storage'], # 1 2 - ['has_bike_storage'], [ 'has_bike_storage', 'has_bahn_comfort' ], # 3 4 - [ 'has_bahn_comfort', 'has_quiet_area', 'has_phone_area' ] # 5 - ], -); - -sub new { - my ( $obj, %opt ) = @_; - my $ref = {}; - - $ref->{class_type} = 0; - $ref->{has_bistro} = 0; - $ref->{is_locomotive} = 0; - $ref->{is_powercar} = 0; - $ref->{is_closed} = 0; - $ref->{train_no} = $opt{train_no}; - $ref->{number} = $opt{wagenordnungsnummer}; - $ref->{model} = $opt{fahrzeugnummer}; - $ref->{uic_id} = $opt{fahrzeugnummer}; - $ref->{section} = $opt{fahrzeugsektor}; - $ref->{type} = $opt{fahrzeugtyp}; - - $ref->{model} =~ s{^.....(...)....$}{$1} or $ref->{model} = undef; - - my $self = bless( $ref, $obj ); - - $self->parse_type; - - if ( $opt{status} and $opt{status} eq 'GESCHLOSSEN' ) { - $ref->{is_closed} = 1; - } - - if ( $opt{kategorie} =~ m{SPEISEWAGEN} ) { - $ref->{has_bistro} = 1; - } - elsif ( $opt{kategorie} eq 'LOK' ) { - $ref->{is_locomotive} = 1; - } - elsif ( $opt{kategorie} eq 'TRIEBKOPF' ) { - $ref->{is_powercar} = 1; - } - - if ( $opt{fahrzeugtyp} =~ m{AB} ) { - $ref->{class_type} = 12; - } - elsif ( $opt{fahrzeugtyp} =~ m{A} ) { - $ref->{class_type} = 1; - } - elsif ( $opt{fahrzeugtyp} =~ m{B|WR} ) { - $ref->{class_type} = 2; - } - - my $pos = $opt{positionamhalt}; - - $ref->{position}{start_percent} = $pos->{startprozent}; - $ref->{position}{end_percent} = $pos->{endeprozent}; - $ref->{position}{start_meters} = $pos->{startmeter}; - $ref->{position}{end_meters} = $pos->{endemeter}; - - if ( $pos->{startprozent} eq '' - or $pos->{endeprozent} eq '' - or $pos->{startmeter} eq '' - or $pos->{endemeter} eq '' ) - { - $ref->{position}{valid} = 0; - } - else { - $ref->{position}{valid} = 1; - } - - return $self; -} - -sub attributes { - my ($self) = @_; - - return @{ $self->{attributes} // [] }; -} - -# See also: -# https://de.wikipedia.org/wiki/UIC-Bauart-Bezeichnungssystem_f%C3%BCr_Reisezugwagen#Kennbuchstaben -# https://www.deutsche-reisezugwagen.de/lexikon/erklarung-der-gattungszeichen/ -sub parse_type { - my ($self) = @_; - - my $type = $self->{type}; - my @desc; - - if ( $type =~ m{^D} ) { - $self->{is_dosto} = 1; - push( @desc, 'Doppelstock' ); - } - - if ( $type =~ m{b} ) { - $self->{has_accessibility} = 1; - push( @desc, 'Behindertengerechte Ausstattung' ); - } - - if ( $type =~ m{d} ) { - $self->{multipurpose} = 1; - push( @desc, 'Mehrzweck' ); - } - - if ( $type =~ m{f} ) { - push( @desc, 'Steuerabteil' ); - } - - if ( $type =~ m{i} ) { - $self->{is_interregio} = 1; - push( @desc, 'Interregio' ); - } - - if ( $type =~ m{mm} ) { - push( @desc, 'modernisiert' ); - } - - if ( $type =~ m{p} ) { - $self->{has_ac} = 1; - push( @desc, 'Großraum' ); - } - - if ( $type =~ m{s} ) { - push( @desc, 'Sonderabteil' ); - } - - if ( $type =~ m{v} ) { - $self->{has_ac} = 1; - $self->{has_compartments} = 1; - push( @desc, 'Abteil' ); - } - - if ( $type =~ m{w} ) { - $self->{has_ac} = 1; - $self->{has_compartments} = 1; - push( @desc, 'Abteil' ); - } - - $self->{attributes} = \@desc; -} - -sub set_traintype { - my ( $self, $group_index, $tt ) = @_; - - $self->{group_index} = $group_index; - - if ( not $tt ) { - return; - } - - $self->{train_subtype} = $tt; - - if ( not $self->{number} or not exists( $type_attributes{$tt} ) ) { - return; - } - - if ( $self->{number} !~ m{^\d+$} ) { - return; - } - - my $index = $self->{number} - 1; - - if ( $index >= 30 ) { - $index -= 30; - } - elsif ( $index >= 20 ) { - $index -= 20; - } - - if ( not $type_attributes{$tt}[$index] ) { - return; - } - - for my $attr ( @{ $type_attributes{$tt}[$index] } ) { - $self->{$attr} = 1; - } -} - -sub is_first_class { - my ($self) = @_; - - if ( $self->{type} =~ m{^D?A} ) { - return 1; - } - return 0; -} - -sub is_second_class { - my ($self) = @_; - - if ( $self->{type} =~ m{^D?A?B} ) { - return 1; - } - return 0; -} - -sub sections { - my ($self) = @_; - - return @{ $self->{sections} }; -} - -sub TO_JSON { - my ($self) = @_; - - my %copy = %{$self}; - - return {%copy}; -} - -1; |