Dear Chelsea,
that is a very nice post. There's some code for the enigma on the community by @Michael Hale:
lettersToNumbers = Thread[CharacterRange["A", "Z"] -> Range@26];
numbersToLetters = Reverse /@ lettersToNumbers;
rotors = Characters /@ {"EKMFLGDQVZNTOWYHXUSPAIBRCJ",
"AJDKSIRUXBLHWTMCQGZNPYFVOE", "BDFHJLCPRTXVZNYEIWGAKMUSQO",
"ESOVPZJAYQUIRHXLNFTGKDCMWB", "VZBRGITYUPSDNHLXAWMJQOFECK"} /. lettersToNumbers;
notches = {"Q", "E", "V", "J", "Z"} /. lettersToNumbers;
reflector =
Characters@"YRUHQSLDPXNGOKMIEBFZCWVJAT" /. lettersToNumbers;
{active, turns} = {{3, 2, 1}, {"A", "A", "A"} /. lettersToNumbers};
step[] :=
turns = Mod[
turns + ({1, If[#, 1, 0], If[# && #2, 1, 0]} &[
turns[[1]] == notches[[active[[1]]]],
turns[[2]] == notches[[active[[2]]]]]), 26, 1]
encode[letter_] := (step[];
Fold[Mod[
PermutationReplace[Mod[# + #2[[2]], 26, 1], #2[[1]]] - #2[[2]],
26, 1] &, letter /. lettersToNumbers,
Join[#, {{reflector, 0}}, {InversePermutation@#, #2} & @@@
Reverse@#] &@Thread@{rotors[[active]], turns - 1}] /.
numbersToLetters)
The code functions like this. If this is our secret message:
message = "WHENSHALLWETHREEMEETAGAIN";
this will encode it:
turns = {"A", "B", "C"} /. lettersToNumbers;
StringJoin[encode /@ Characters@message]
It gives:
YFRGMRNSERQYTNKZCVWBVURAI
This decodes the message:
turns = {"A", "B", "C"} /. lettersToNumbers;
StringJoin[encode /@ Characters@"YFRGMRNSERQYTNKZCVWBVURAI"]
and gives:
WHENSHALLWETHREEMEETAGAIN
Now here is a little graphical visualisation of the enigma.
tocode = Characters@"WHENSHALLWETHREEMEETAGAIN";
{active, turns} = {{3, 2, 1}, {"A", "B", "C"} /. lettersToNumbers};
plotEnigma[letter_, activer_] := (step[];
r1 = activer[[1]];
r2 = activer[[2]];
r3 = activer[[3]]; letters = letter /. lettersToNumbers;
a1 = Mod[rotors[[r1, Mod[letters + turns[[1]] - 2, 26] + 1]] - turns[[1]],26] + 1;
a2 = Mod[rotors[[r2, Mod[a1 + turns[[2]] - 2, 26] + 1]] - turns[[2]], 26] + 1;
a3 = Mod[rotors[[r3, Mod[a2 + turns[[3]] - 2, 26] + 1]] - turns[[3]], 26] + 1;
a4 = reflector[[a3]];
a5 = Mod[Flatten[Position[ rotors[[r3]], Mod[a4 + turns[[3]] - 2, 26] + 1]][[1]] - turns[[3]], 26] + 1;
a6 = Mod[Flatten[Position[ rotors[[r2]], Mod[a5 + turns[[2]] - 2, 26] + 1]][[1]] - turns[[2]], 26] + 1;
a7 = Mod[Flatten[Position[ rotors[[r1]], Mod[a6 + turns[[1]] - 2, 26] + 1]][[1]] - turns[[1]], 26] + 1;
Show[Graphics[Text[Style[#[[1]], FontFamily -> "Courier", 15], {-1.5, #[[2]]}] & /@
Transpose[{CharacterRange["A", "Z"], Range[26]}]],
Graphics[{Green, Rectangle[{0.5, 0.5}, {3.5, 26.5}]}],
Graphics[{ Yellow, Rectangle[{5.5, 0.5}, {8.5, 26.5}]}],
Graphics[{Red, Rectangle[{10.5, 0.5}, {13.5, 26.5}]}],
Graphics[{Blue, Rectangle[{15.5, 0.5}, {16.5, 26.5}]}],
Graphics[
Circle[{16, #[[1]]}, {#[[2]]/4., #[[2]]}, {-Pi/2, Pi/2}] & /@
Transpose[{Abs[Range[26] + reflector]/2 // N,
Abs[Range[26] - reflector]/2 // N}]],
Graphics[Table[Disk[{m, k}, 0.1], {k, 1, 26}, {m, 1, 4, 2}]],
Graphics[Table[Disk[{m, k}, 0.1], {k, 1, 26}, {m, 6, 9, 2}]],
Graphics[Table[Disk[{m, k}, 0.1], {k, 1, 26}, {m, 11, 14, 2}]],
Graphics[Table[Disk[{m, k}, 0.1], {k, 1, 26}, {m, 16, 17, 2}]],
Graphics[
Table[Line[{{1, k}, {3,
Mod[rotors[[r1, Mod[k + turns[[1]] - 2, 26] + 1]] -
turns[[1]], 26] + 1}}], {k, 1, 26}]],
Graphics[
Table[Line[{{6, k}, {8,
Mod[rotors[[r2, Mod[k + turns[[2]] - 2, 26] + 1]] -
turns[[2]], 26] + 1}}], {k, 1, 26}]],
Graphics[
Table[Line[{{11, k}, {13,
Mod[
rotors[[r3, Mod[k + turns[[3]] - 2, 26] + 1]] - turns[[3]],
26] + 1}}], {k, 1, 26}]],
Graphics[{Thickness[0.01], Line[{{-1, letters}, {1, letters}}]}],
Graphics[{Thickness[0.01], Line[{{1, letters}, {3, a1}}]}],
Graphics[{Thickness[0.01], Line[{{3, a1}, {6, a1}}]}],
Graphics[{Thickness[0.01], Line[{{6, a1}, {8, a2}}]}],
Graphics[{Thickness[0.01], Line[{{8, a2}, {11, a2}}]}],
Graphics[{Thickness[0.01], Line[{{11, a2}, {13, a3}}]}],
Graphics[{Thickness[0.01], Line[{{13, a3}, {16, a3}}]}],
Graphics[{Thickness[0.01], Line[{{13, a4}, {16, a4}}]}],
Graphics[{Thickness[0.01], Line[{{11, a5}, {13, a4}}]}],
Graphics[{Thickness[0.01], Line[{{8, a5}, {11, a5}}]}],
Graphics[{Thickness[0.01], Line[{{6, a6}, {8, a5}}]}],
Graphics[{Thickness[0.01], Line[{{3, a6}, {6, a6}}]}],
Graphics[{Thickness[0.01], Line[{{1, a7}, {3, a6}}]}],
Graphics[{Thickness[0.01], Line[{{-1, a7}, {1, a7}}]}],
Graphics[{Thickness[0.01],
Circle[{16,
Abs[a3 + reflector[[a3]]]/2}, {Abs[a3 - reflector[[a3]]]/2/4.,
Abs[a3 - reflector[[a3]]]/2}, {-Pi/2, Pi/2}]}],
AspectRatio -> 1, ImageSize -> Large])
Manipulate[
plotEnigma[tocode[[let]], active], {let, 1, Length[tocode], 1}]
You can clearly see the mechanical structure. The three rotors (green, yellow and red) have a complicated wiring. Then there is a reflector (blue) that sends the trail back to the letters on the left. After ever letter the green rotor changes the position, so that the same letter is encoded by a different letter next time. After some time the yellow (and later the red) rotor will change the position.
The important bit is that the thing is a bijection, i.e. invertible. So If I go backwards I can decode the message.
Please do also have a look at this demonstration.
Cheers,
Marco
