plugboard

2 files changed, 81 insertions, 0 deletions

diff --git a/lib/Enigmatic/Plugboard.pm b/lib/Enigmatic/Plugboard.pm
new file mode 100644
index 0000000..b505195
--- /dev/null
+++ b/lib/Enigmatic/Plugboard.pm
@@ -0,0 +1,27 @@
+package Enigmatic::Plugboard;
+use DAKKAR::p 'class';
+use Enigmatic::Types qw(PlugWiringMap Letter);
+
+has wiring => (
+    is => 'ro',
+    isa => PlugWiringMap,
+    coerce => 1,
+    builder => '_build_wiring',
+);
+
+sub _build_wiring {
+    my %map = map { $_, $_ } 'A'..'Z';
+    return \%map;
+}
+
+with 'Enigmatic::Role::WithWiring';
+
+sub map {
+    my $self = shift;
+    my ($letter) = pos_validated_list(
+        \@_,
+        { isa => Letter },
+    );
+
+    return $self->wiring->at($letter);
+}
diff --git a/t/plugboard.t b/t/plugboard.t
new file mode 100644
index 0000000..3e1b5dc
--- /dev/null
+++ b/t/plugboard.t
@@ -0,0 +1,54 @@
+#!perl
+use DAKKAR::p 'test';
+use Test::Enigmatic;
+
+use Enigmatic::Plugboard;
+
+# yes, a plugboard is just like a reflector, but it uses a different input
+
+subtest 'identity plugboard' => sub {
+    my @in = 'A'..'Z';
+    my $p = Enigmatic::Plugboard->new();
+    Test::Enigmatic::test_static_map($p,\@in,'identity');
+};
+
+subtest 'scramble plugboard' => sub {
+    my %map;my @letters='A'..'Z';my %fullmap;
+    my %unused;@unused{@letters}=();
+    for my $letter (@letters) {
+        next if not exists $unused{$letter};
+        delete $unused{$letter};
+        my @usable = keys %unused;
+        my $image = @usable[rand @usable];
+        $map{$letter} = $image;
+        $fullmap{$letter} = $image;
+        $fullmap{$image} = $letter;
+        delete $unused{$image};
+    }
+
+    my $wiring = '';
+    %map->each(sub {
+                   $wiring .= @_->join(''). ' ';
+               });
+    note "scramble plugboard: $wiring";
+
+    my $p = Enigmatic::Plugboard->new($wiring);
+    Test::Enigmatic::test_static_map($p,[@fullmap{@letters}],'shuffle');
+};
+
+subtest 'constraints' => sub {
+    my @bad_params = (
+        'AB CD EF GH IJ KL MN OP QR ST UV WX YZ AB CD',
+        'AA',
+        '12',
+        'AB BC',
+    );
+
+    for my $bad_param (@bad_params) {
+        dies_ok {
+            Enigmatic::Plugboard->new($bad_param);
+        } "bad parameter $bad_param";
+    }
+};
+
+done_testing();