summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/Enigmatic/CryptTrain.pm101
-rw-r--r--lib/Enigmatic/Role/Rotate.pm9
-rw-r--r--lib/Enigmatic/Rotor.pm39
-rw-r--r--lib/Enigmatic/Types.pm67
-rw-r--r--t/stepping.t100
5 files changed, 286 insertions, 30 deletions
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();