Below is an implementation of the German Enigma Machine which the German forces used to communicate encrypted messages during WWII. The machine was an ingenious design. It used a series of rotors and an elaborate electromechanical coupling to encrypt messages in German.
About the mechanism, the first rotor moved with each click of the keyboard; the second rotor moved once the first rotor completed 26 moves or one complete turn; and the third rotor once the first moved 26*26 steps (one can easily understand where this is going).
Since the rotors could move during the encryption process the key to deciphering the text was the "key" or the initial state of the rotors. The code was finally broken by a team of cryptographers at Bletchley Park led by Alan Turing. Some believe this caused the war to shorten by a few years. A movie titled "The Imitation Game" was released in 2014 highlighting this code breaking feat.
ClearAll@rotateWheel;
SetAttributes[rotateWheel, HoldFirst];
rotateWheel[wheel_] := Block[{},
wheel = RotateLeft[wheel]];
The immediate block of code above enables me to make in-place modification i.e. to rotate and preserve the state of the rotors.
EnigmaEncryption[string_, staterot1_, staterot2_, staterot3_] :=
Module[{count = 0, RotorIn, leftRotor, middleRotor, rightRotor, reflector, reflectorOutput,
rotateMiddleCheck, rotateRightCheck, inputToNext, reverseOutput},
RotorIn = ToLowerCase@CharacterRange["A", "Z"];
{leftRotor, middleRotor, rightRotor} = MapThread[Function[{x, y}, (z \[Function]
RotateLeft[z, First@Position[z, ToLowerCase@y] - 1])@
Characters@ToLowerCase[x]], {{"BDFHJLCPRTXVZNYEIWGAKMUSQO",
"AJDKSIRUXBLHWTMCQGZNPYFVOE", "EKMFLGDQVZNTOWYHXUSPAIBRCJ"},
{staterot1, staterot2, staterot3}}];
reflector = Characters@ToLowerCase@"YRUHQSLDPXNGOKMIEBFZCWVJAT";
inputToNext[rotor_, input_] := First@Cases[Thread[{RotorIn, rotor}], {input, map_} :> map ];
reverseOutput[rotor_, input_] := First@Cases[Thread[{RotorIn, rotor}], {map_, input} :> map ];
rotateMiddleCheck := If[count~Mod~26 == 0, rotateWheel@middleRotor, middleRotor];
rotateRightCheck := If[count~Mod~676 == 0, rotateWheel@rightRotor, rightRotor];
StringJoin@Table[
If[FreeQ[input, Alternatives[" ", ",", "'", "?" ]],
count += 1;
reflectorOutput =
Fold[inputToNext[#2, #1] &, input, {rotateWheel@leftRotor, rotateMiddleCheck, rotateRightCheck, reflector}];
Fold[reverseOutput[#2, #1] &, reflectorOutput, {rightRotor, middleRotor, leftRotor}], input]
, {input, Characters@ToLowerCase@string}]
]
Now lets assume that the Germans encrypt a message with state "A", "A","A" for the three moving rotors:
Style[text = EnigmaEncryption["this is the SS, Identify yourself, are you a German or are you Alan Turing?", "A", "A", "A"], {Bold, FontSize -> 24}]
uubf jw dif oo, jctjgmbn nbtqrang, pvs vsh o orgiya lq lyw svn ssui zcxuxs?
If the cryptographers at Bletchley have the incorrect key "B","A","E" they will not be able to decipher the text (it will be gibberish).
Style[EnigmaEncryption[text, "B", "A", "E"], {Bold, FontSize -> 24}]
pgyy yd gnu nw, etlisxnw fnkniizh, tgy wde u gqkabx ma foe alc aifb cmavmt?
However, with the right key:
Style[EnigmaEncryption[text, "A", "A", "A"], {Bold, FontSize -> 24}]
this is the ss, identify yourself, are you a german or are you alan turing?
We can make a small animation of the rotor states. For visual purposes, blue represents the forward states of the system and red the backward state.
the code below can be used to generate the animation sequence:
list = (Rasterize@*Grid /@
Module[{out, states, mergedstates, rotorstates, riffle, first, last, text = text,
textout = StringReplace[text[[1]], Alternatives[" ", ",", "'", "?"] :> ""]},
out = Characters@textout;
states = Partition[text[[2, 1]], 7];
mergedstates = Table[Join[states[[i]], {out[[i]]}], {i, Length@states}];
rotorstates = text[[2, 2]];
riffle = MapAt[Reverse, (Partition[#, 4] & /@ mergedstates), {All, 2}];
riffle = Apply[Composition[Partition[#, 2] &, Riffle], riffle, {1}];
Do[{first, last} = Flatten@Position[rotorstates[[j, i]], #] & /@ riffle[[j, i]];
rotorstates[[j, i, first]] = Style[First@rotorstates[[j, i, first]], {Blue, Bold, Background -> LightBlue}];
rotorstates[[j, i, last]] = Style[First@rotorstates[[j, i, last]], {Red, Bold, Background -> LightRed}];
, {j, Length@riffle}, {i, 4}];
rotorstates
]);
