From 6a0022d67d4baea240897c7e3b24d2b864f06c60 Mon Sep 17 00:00:00 2001 From: dakkar Date: Mon, 29 Aug 2011 18:15:22 +0100 Subject: more stepping tests --- lib/Enigmatic/CryptTrain.pm | 101 ++++++++++++++++++++++++++++++++++++++----- lib/Enigmatic/Role/Rotate.pm | 9 ++++ lib/Enigmatic/Rotor.pm | 39 ++++++++++++++--- lib/Enigmatic/Types.pm | 67 +++++++++++++++++++++++----- t/stepping.t | 100 ++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 286 insertions(+), 30 deletions(-) create mode 100644 lib/Enigmatic/Role/Rotate.pm diff --git a/lib/Enigmatic/CryptTrain.pm b/lib/Enigmatic/CryptTrain.pm index 06a11d2..4d4b6c6 100644 --- a/lib/Enigmatic/CryptTrain.pm +++ b/lib/Enigmatic/CryptTrain.pm @@ -4,6 +4,8 @@ use Enigmatic::Types qw(Letter RotorPos); use MooseX::Types::Moose qw(ArrayRef); use Moose::Util::TypeConstraints; +with 'Enigmatic::Role::Rotate'; + has rotors => ( isa => ArrayRef[class_type('Enigmatic::Rotor')], traits => ['Array'], @@ -36,8 +38,42 @@ has positions => ( position_at => 'get', positions => 'elements', }, + lazy_build => 1, ); +sub _build_positions { + my ($self) = @_; + + my @ret = (0) x $self->rotor_count; + return \@ret; +} + +around BUILDARGS => sub { + my $orig = shift; + my $class = shift; + + my $args = $class->$orig(@_); + + if ($args->{positions}) { + + warn "pos: @{$args->{positions}}\n"; + + for my $pos (@{$args->{positions}}) { + $pos = to_RotorPos($pos); + } + + warn "pos: @{$args->{positions}}\n"; + } + + return $args; +}; + +around set_position => sub { + my ($orig,$self,$idx,$pos) = @_; + + return $self->$orig($idx,to_RotorPos($pos)); +}; + sub map { my $self = shift; my ($letter) = pos_validated_list( @@ -45,15 +81,34 @@ sub map { { isa => Letter }, ); - for my $element ( - $self->rotors, - $self->reflector, - (reverse $self->rotors), - ) { - $letter = $element->map($letter); - } + my $max_idx = $self->rotor_count -1; + + my $log=''; + $self->step_positions(); + for my $idx (0..$max_idx) { + my $rotor = $self->rotor_at($idx);$log.="($idx:"; + my $position = $self->position_at($idx);$log.="$position)"; + + $letter = _rotate_by($letter,$position);$log.=$letter; + $letter = $rotor->map($letter);$log.=$letter; + $letter = _rotate_by($letter,-$position);$log.=$letter; + } + + $letter = $self->reflector->map($letter);$log.="r${letter}r"; + + for my $idx (reverse 0..$max_idx) { + my $rotor = $self->rotor_at($idx);$log.="($idx:"; + my $position = $self->position_at($idx);$log.="$position)"; + + $letter = _rotate_by($letter,$position);$log.=$letter; + $letter = $rotor->inverse_map($letter);$log.=$letter; + $letter = _rotate_by($letter,-$position);$log.=$letter; + } + + warn "$log\n"; + return $letter; } @@ -72,14 +127,36 @@ sub rotor_window_at { return ['A'..'Z']->[$self->position_at($idx)] } +sub rotor_windows { + my ($self) = @_; + + my @ret = map { $self->rotor_window_at($_) } 0 .. $self->rotor_count -1; + return @ret; +} + sub step_positions { my ($self) = @_; - for my $pos (0 .. $self->rotor_count -1) { - $self->_inc_position($pos); - my $rot = $self->rotor_at($pos); - last - unless $rot->has_notch_at($self->rotor_window_at($pos)); + # from http://users.telenet.be/d.rijmenants/en/enigmatech.htm#steppingmechanism + # the mechanism is: + # - the first rotor always steps + # - if there is a notch at the current position, both the rotor + # with the notch, and the next one, will step + + my $max_idx = $self->rotor_count -1; + my @will_step = (0) x $max_idx; + $will_step[0]=1; # the first rotor always steps + + for my $idx (0 .. $max_idx) { + my $rot = $self->rotor_at($idx); + my $notch = $rot->has_notch_at($self->rotor_window_at($idx)); + $will_step[$idx] = $will_step[$idx+1] = 1 if $notch; + } + + $will_step[3] = 0; # the fourth rotor never steps + + for my $idx (0 .. $max_idx) { + $self->_inc_position($idx) if $will_step[$idx]; } return; diff --git a/lib/Enigmatic/Role/Rotate.pm b/lib/Enigmatic/Role/Rotate.pm new file mode 100644 index 0000000..89fb761 --- /dev/null +++ b/lib/Enigmatic/Role/Rotate.pm @@ -0,0 +1,9 @@ +package Enigmatic::Role::Rotate; +use DAKKAR::p 'role'; + +sub _rotate_by { + my ($letter,$position) = @_; + + return chr(ord('A')+ + (ord($letter)-ord('A')+26+$position)%26); +} diff --git a/lib/Enigmatic/Rotor.pm b/lib/Enigmatic/Rotor.pm index e0a3b97..9a88718 100644 --- a/lib/Enigmatic/Rotor.pm +++ b/lib/Enigmatic/Rotor.pm @@ -3,16 +3,33 @@ use DAKKAR::p 'class'; use Enigmatic::Types qw(WiringMap Letter RotorPos); use MooseX::Types::Set::Object; +with 'Enigmatic::Role::Rotate'; + has wiring => ( is => 'ro', isa => WiringMap, coerce => 1, ); +has inverse_wiring => ( + is => 'ro', + isa => WiringMap, + init_arg => undef, + lazy_build => 1, +); + +sub _build_inverse_wiring { + my ($self) = @_; + my $w = $self->wiring; + my $ret = { reverse %$w }; + return $ret; +} + has ring_setting => ( is => 'rw', isa => RotorPos, default => 0, + coerce => 1, ); has notches => ( @@ -33,18 +50,28 @@ sub map { { isa => Letter }, ); - return $self->wiring->at($self->_apply_ring_setting($letter)); + return $self->_real_map($letter,'wiring'); } -sub _apply_ring_setting { +sub inverse_map { my $self = shift; my ($letter) = pos_validated_list( \@_, { isa => Letter }, ); - return chr( - (ord($letter) - ord('A') + $self->ring_setting) - % 26 - +ord('A') ); + return $self->_real_map($letter,'inverse_wiring'); +} + +sub _real_map { + my ($self,$letter,$wiring) = @_; + + my $setting = $self->ring_setting; + + my $log = "{$letter"; + $letter = _rotate_by($letter,$setting);$log.=$letter; + $letter = $self->$wiring->at($letter);$log.=$letter; +# $letter = _rotate_by($letter,-$setting);$log.=$letter; + $log .= "}\n";warn $log; + return $letter; } diff --git a/lib/Enigmatic/Types.pm b/lib/Enigmatic/Types.pm index ed0be32..be5bc87 100644 --- a/lib/Enigmatic/Types.pm +++ b/lib/Enigmatic/Types.pm @@ -1,12 +1,21 @@ package Enigmatic::Types; use DAKKAR::p; -use MooseX::Types -declare => [qw(Letter WiringMap ReflWiringMap RotorPos)]; +use MooseX::Types -declare => + [qw( + Letter RotorPos + WiringMap ReflWiringMap PlugWiringMap + PlugboardT + RotorT + ReflectorT + )]; use MooseX::Types::Moose qw(Str Int); use MooseX::Types::Structured qw(Map); +use Moose::Util::TypeConstraints; -subtype Letter, - as Str, - where { /[A-Z]/ }; +subtype Letter, as Str, where { /[A-Z]/ }; + +subtype RotorPos, as Int, where { $_ >=0 and $_ <= 25 }; +coerce RotorPos, from Letter, via { ord($_) - ord('A') }; subtype WiringMap, as Map[Letter,Letter], @@ -32,14 +41,48 @@ sub _coerce_wiring { \%ret; } -coerce WiringMap, - from Str, - via \&_coerce_wiring; +coerce WiringMap, from Str, via \&_coerce_wiring; + +coerce ReflWiringMap, from Str, via \&_coerce_wiring; -coerce ReflWiringMap, +subtype PlugWiringMap, as ReflWiringMap; + +coerce PlugWiringMap, from Str, - via \&_coerce_wiring; + via { + my %map = map { $_, $_ } 'A'..'Z'; + + my $in = $_; $in =~ s{\s+}{}g; + my @pairs = $in->split(qr{(..)})->grep(sub{length})->flatten; + for my $pair (@pairs) { + my ($from,$to) = ($pair =~ m{(.)(.)}); + + croak "useless plug $pair" + if $from eq $to; + croak "excessive plug in $from" + if $map{$from} ne $from; + croak "excessive plug in $to" + if $map{$to} ne $to; + $map{$from} = $to; + $map{$to} = $from; + } + return \%map; + }; + +subtype RotorT, as class_type('Enigmatic::Rotor'); +coerce RotorT, from Str, via { + require Enigmatic::RotorBox; + Enigmatic::RotorBox->new->get($_) + }; + +subtype ReflectorT, as class_type('Enigmatic::Reflector'); +coerce ReflectorT, from Str, via { + require Enigmatic::ReflectorBox; + Enigmatic::ReflectorBox->new->get($_) + }; -subtype RotorPos, - as Int, - where { $_ >=0 and $_ <= 26 }; +subtype PlugboardT, as class_type('Enigmatic::Plugboard'); +coerce PlugboardT, from Str, via { + require Enigmatic::Plugboard; + Enigmatic::Plugboard->new($_); + }; diff --git a/t/stepping.t b/t/stepping.t index f50bce9..0d7a453 100644 --- a/t/stepping.t +++ b/t/stepping.t @@ -3,6 +3,8 @@ use DAKKAR::p 'test'; use Enigmatic::Rotor; use Enigmatic::Reflector; +use Enigmatic::RotorBox; +use Enigmatic::ReflectorBox; use Enigmatic::CryptTrain; subtest 'first position' => sub { @@ -28,4 +30,102 @@ subtest 'first position' => sub { } }; +subtest 'some stepping' => sub { + my @in = 'A'..'Z'; + + my @rots = map { Enigmatic::Rotor->new({ + wiring => @in->join, + notches => ['Z'], + }) } 1..3; + my $refl = Enigmatic::Reflector->new(@in->join); + my $train = Enigmatic::CryptTrain->new({ + rotors => \@rots, + reflector => $refl, + positions => [0,0,0], + }); + + my $pos=0; + for my $c ('A' .. 'Y') { + $train->step_positions(); + ++$pos; + is_deeply([$train->positions], + [$pos,0,0], + 'single notch'); + } + $train->step_positions(); + is_deeply([$train->positions], + [0,1,0], + 'single notch'); +}; + +sub _test_double_stepping { + my ($train,$init,$steps) = @_; + + for my $rot (0..2) { + $train->set_position($rot,$init->[$rot]); + } + + for my $step_idx (0..$#$steps) { + $train->step_positions(); + + my $now_windows = $steps->[$step_idx]; + is_deeply([$train->rotor_windows], + $now_windows, + 'correct step'); + } +} + +subtest 'double-stepping' => sub { + my $rotbox = Enigmatic::RotorBox->new(); + my $reflbox = Enigmatic::ReflectorBox->new(); + + my $train = sub { Enigmatic::CryptTrain->new({ + rotors => [ + $rotbox->get('I'), + $rotbox->get('II'), + $rotbox->get('III'), + ], + reflector => $reflbox->get('B'), + }) }; + + _test_double_stepping($train->(), + [qw(O D K)], + [ + [qw(P D K)], + [qw(Q D K)], + [qw(R E K)], + [qw(S F L)], + [qw(T F L)], + ]); + + $train = sub { Enigmatic::CryptTrain->new({ + rotors => [ + $rotbox->get('III'), + $rotbox->get('II'), + $rotbox->get('I'), + ], + reflector => $reflbox->get('B'), + }) }; + + _test_double_stepping($train->(), + [qw(T A A)], + [ + [qw(U A A)], + [qw(V A A)], + [qw(W B A)], + [qw(X B A)], + [qw(Y B A)], + ]); + + _test_double_stepping($train->(), + [qw(T D A)], + [ + [qw(U D A)], + [qw(V D A)], + [qw(W E A)], + [qw(X F B)], + [qw(Y F B)], + ]); +}; + done_testing(); -- cgit v1.2.3