summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/Enigmatic/Reflector.pm21
-rw-r--r--lib/Enigmatic/ReflectorBox.pm28
-rw-r--r--lib/Enigmatic/Role/WithWiring.pm17
-rw-r--r--lib/Enigmatic/Rotor.pm12
-rw-r--r--lib/Enigmatic/Types.pm31
-rw-r--r--t/lib/Test/Enigmatic.pm15
-rw-r--r--t/reflectors.t71
-rw-r--r--t/rotors.t26
8 files changed, 182 insertions, 39 deletions
diff --git a/lib/Enigmatic/Reflector.pm b/lib/Enigmatic/Reflector.pm
new file mode 100644
index 0000000..b9371dd
--- /dev/null
+++ b/lib/Enigmatic/Reflector.pm
@@ -0,0 +1,21 @@
+package Enigmatic::Reflector;
+use DAKKAR::p 'class';
+use Enigmatic::Types qw(ReflWiringMap Letter);
+
+has wiring => (
+ is => 'ro',
+ isa => ReflWiringMap,
+ coerce => 1,
+);
+
+with 'Enigmatic::Role::WithWiring';
+
+sub map {
+ my $self = shift;
+ my ($letter) = pos_validated_list(
+ \@_,
+ { isa => Letter },
+ );
+
+ return $self->wiring->at($letter);
+}
diff --git a/lib/Enigmatic/ReflectorBox.pm b/lib/Enigmatic/ReflectorBox.pm
new file mode 100644
index 0000000..eafa667
--- /dev/null
+++ b/lib/Enigmatic/ReflectorBox.pm
@@ -0,0 +1,28 @@
+package Enigmatic::ReflectorBox;
+use DAKKAR::p 'class';
+use Enigmatic::Reflector;
+use MooseX::Types::Structured qw(Map);
+use MooseX::Types::Moose qw(Str);
+use Moose::Util::TypeConstraints;
+
+has reflectorset => (
+ is => 'ro',
+ isa => Map[Str,class_type('Enigmatic::Reflector')],
+ lazy_build => 1,
+ traits => ['Hash'],
+ handles => {
+ get => 'get',
+ },
+);
+
+sub _build_reflectorset {
+ my %reflectors = (
+ B => 'YRUHQSLDPXNGOKMIEBFZCWVJAT',
+ C => 'FVPJIAOYEDRZXWGCTKUQSBNMHL',
+ 'B_thin' => 'ENKQAUYWJICOPBLMDXZVFTHRGS',
+ 'C_thin' => 'RDOBJNTKVEHMLFCWZAXGYIPSUQ',
+ );
+
+ $_ = Enigmatic::Reflector->new($_) for values %reflectors;
+ return \%reflectors;
+}
diff --git a/lib/Enigmatic/Role/WithWiring.pm b/lib/Enigmatic/Role/WithWiring.pm
new file mode 100644
index 0000000..df6dc48
--- /dev/null
+++ b/lib/Enigmatic/Role/WithWiring.pm
@@ -0,0 +1,17 @@
+package Enigmatic::Role::WithWiring;
+use DAKKAR::p 'role';
+
+requires 'BUILDARGS';
+requires 'wiring';
+
+around BUILDARGS => sub {
+ my $orig = shift;
+ my $class = shift;
+
+ if ( @_ == 1 && !ref $_[0] ) {
+ return $class->$orig( wiring => $_[0] );
+ }
+ else {
+ return $class->$orig(@_);
+ }
+};
diff --git a/lib/Enigmatic/Rotor.pm b/lib/Enigmatic/Rotor.pm
index a600b43..792c7b5 100644
--- a/lib/Enigmatic/Rotor.pm
+++ b/lib/Enigmatic/Rotor.pm
@@ -14,17 +14,7 @@ has ring_setting => (
default => 0,
);
-around BUILDARGS => sub {
- my $orig = shift;
- my $class = shift;
-
- if ( @_ == 1 && !ref $_[0] ) {
- return $class->$orig( wiring => $_[0] );
- }
- else {
- return $class->$orig(@_);
- }
-};
+with 'Enigmatic::Role::WithWiring';
sub map {
my $self = shift;
diff --git a/lib/Enigmatic/Types.pm b/lib/Enigmatic/Types.pm
index 12cb414..ed0be32 100644
--- a/lib/Enigmatic/Types.pm
+++ b/lib/Enigmatic/Types.pm
@@ -1,6 +1,6 @@
package Enigmatic::Types;
use DAKKAR::p;
-use MooseX::Types -declare => [qw(Letter WiringMap RotorPos)];
+use MooseX::Types -declare => [qw(Letter WiringMap ReflWiringMap RotorPos)];
use MooseX::Types::Moose qw(Str Int);
use MooseX::Types::Structured qw(Map);
@@ -16,16 +16,29 @@ subtype WiringMap,
$in eq $out and $in eq ['A'..'Z']->join;
};
+subtype ReflWiringMap,
+ as WiringMap,
+ where {
+ my %reverse; @reverse{values %$_} = keys %$_;
+ (join '',@reverse{keys %$_}) eq $_->values->join;
+ };
+
+sub _coerce_wiring {
+ my @out = $_[0]->uc->split(qr//)->flatten;
+ croak "invalid wiring string <$_>"
+ unless @out == 26;
+ my %ret;
+ @ret{'A'..'Z'}=@out;
+ \%ret;
+}
+
coerce WiringMap,
from Str,
- via {
- my @out = $_->uc->split(qr//)->flatten;
- croak "invalid wiring string <$_>"
- unless @out == 26;
- my %ret;
- @ret{'A'..'Z'}=@out;
- \%ret;
- };
+ via \&_coerce_wiring;
+
+coerce ReflWiringMap,
+ from Str,
+ via \&_coerce_wiring;
subtype RotorPos,
as Int,
diff --git a/t/lib/Test/Enigmatic.pm b/t/lib/Test/Enigmatic.pm
new file mode 100644
index 0000000..923ede1
--- /dev/null
+++ b/t/lib/Test/Enigmatic.pm
@@ -0,0 +1,15 @@
+package Test::Enigmatic;
+use DAKKAR::p 'test';
+
+sub test_static_map {
+ my ($mapper,$out,$name) = @_;
+
+ my @in = 'A'..'Z';
+ my %map;@map{@in}=@$out;
+
+ for my $c ('A' .. 'Z') {
+ is($mapper->map($c),
+ $map{$c},
+ "$name on $c");
+ }
+}
diff --git a/t/reflectors.t b/t/reflectors.t
new file mode 100644
index 0000000..107ff9f
--- /dev/null
+++ b/t/reflectors.t
@@ -0,0 +1,71 @@
+#!perl
+use DAKKAR::p 'test';
+use List::Util 'shuffle';
+use Test::Enigmatic;
+
+use Enigmatic::Reflector;
+use Enigmatic::ReflectorBox;
+
+subtest 'identity reflector' => sub {
+ my @in = 'A'..'Z';
+ my $r = Enigmatic::Reflector->new(@in->join);
+ Test::Enigmatic::test_static_map($r,\@in,'identity');
+};
+
+subtest 'scramble reflector' => sub {
+ my %map;my @letters='A'..'Z';
+ my %unused;@unused{@letters}=();
+ for my $letter (@letters) {
+ next if not exists $unused{$letter};
+ my @usable = keys %unused;
+ my $image = @usable[rand @usable];
+ $map{$letter} = $image;
+ $map{$image} = $letter;
+ delete $unused{$letter};
+ delete $unused{$image};
+ }
+
+ my $wiring = join '',@map{@letters};
+ note "scramble reflector: $wiring";
+
+ my $r = Enigmatic::Reflector->new($wiring);
+ Test::Enigmatic::test_static_map($r,[@map{@letters}],'shuffle');
+};
+
+subtest 'constraints' => sub {
+ my @bad_params = (
+ 'ABCD',
+ 'ABCDEFGHIJKLMNOPQRSTUVWXYZABCD',
+ 'AACDEFGHIJKLMNOPQRSTUVWXYZ',
+ '12CDEFGHIJKLMNOPQRSTUVWXYZABCD',
+ 'EKMFLGDQVZNTOWYHXUSPAIBRCJ',
+ );
+
+ for my $bad_param (@bad_params) {
+ dies_ok {
+ Enigmatic::Reflector->new($bad_param);
+ } "bad parameter $bad_param";
+ }
+};
+
+subtest 'reflector box' => sub {
+ my %reflectors = (
+ B => 'YRUHQSLDPXNGOKMIEBFZCWVJAT',
+ C => 'FVPJIAOYEDRZXWGCTKUQSBNMHL',
+ 'B_thin' => 'ENKQAUYWJICOPBLMDXZVFTHRGS',
+ 'C_thin' => 'RDOBJNTKVEHMLFCWZAXGYIPSUQ',
+ );
+
+ my $box = Enigmatic::ReflectorBox->new();
+
+ %reflectors->each(sub {
+ my ($reflector,$wiring) = @_;
+ my $r = $box->get($reflector);
+ my $out = $wiring->split(qr//);
+ Test::Enigmatic::test_static_map(
+ $r,$out,
+ "reflector $reflector from box");
+ });
+};
+
+done_testing();
diff --git a/t/rotors.t b/t/rotors.t
index fb53fe4..90ce6ce 100644
--- a/t/rotors.t
+++ b/t/rotors.t
@@ -1,35 +1,22 @@
#!perl
use DAKKAR::p 'test';
use List::Util 'shuffle';
+use Test::Enigmatic;
use Enigmatic::Rotor;
use Enigmatic::RotorBox;
-sub test_the_rotor {
- my ($r,$out,$name) = @_;
-
- my @in = 'A'..'Z';
- my %map;@map{@in}=@$out;
-
- for my $c ('A' .. 'Z') {
- is($r->map($c),
- $map{$c},
- "$name on $c");
- }
-}
-
subtest 'identity rotor' => sub {
my @in = 'A'..'Z';
my $r = Enigmatic::Rotor->new(@in->join);
- test_the_rotor($r,\@in,'identity');
+ Test::Enigmatic::test_static_map($r,\@in,'identity');
};
-
subtest 'scramble rotor' => sub {
my @out = shuffle 'A'..'Z';
my $r = Enigmatic::Rotor->new(@out->join);
- test_the_rotor($r,\@out,'shuffle');
+ Test::Enigmatic::test_static_map($r,\@out,'shuffle');
};
subtest 'identity rotor, non-default ring setting' => sub {
@@ -39,7 +26,7 @@ subtest 'identity rotor, non-default ring setting' => sub {
wiring => ['A'..'Z']->join,
ring_setting => 1,
);
- test_the_rotor($r,\@out,'ring=1');
+ Test::Enigmatic::test_static_map($r,\@out,'ring=1');
};
subtest 'constraints' => sub {
@@ -77,8 +64,9 @@ subtest 'rotor box' => sub {
my ($rotor,$wiring) = @_;
my $r = $box->get($rotor);
my $out = $wiring->split(qr//);
- test_the_rotor($r,$out,
- "rotor $rotor from box");
+ Test::Enigmatic::test_static_map(
+ $r,$out,
+ "rotor $rotor from box");
});
};