# Enigma-like machine in Wolfram Language?

GROUPS:
 Luis Ledesma 5 Votes Hi all, one of my friends shared the following link, which I found interesting to share with you and by the way, ask the community if it is to do something like the machine enigma that is on that page, I hope someone has any idea how to do it.http://enigmaco.de/enigma/enigma.swf
4 years ago
19 Replies
 Sam Carrettie 3 Votes A rather nice implementation. Are there any instructions on how it works? Such websites often go away with time - so here is an animated .GIF of how it works so it stays here on Community.
4 years ago
 In this wikipedia link this enigma how the machine works, I hope is enough information. https://en.wikipedia.org/wiki/Enigma_machine
4 years ago
 Michael Hale 6 Votes I've considered doing a Wolfram implementation of this before. Here is the logic that does the encoding:It's much simpler to convert letters to numbers before the encoding and convert back after.lettersToNumbers = Thread[CharacterRange["A", "Z"] -> Range@26];numbersToLetters = Reverse /@ lettersToNumbers;The linked applet uses rotors I-V from the Enigma I and M3 Army models and reflector B. Copy the permutations and notch settings for those and others from here.rotors = Characters /@ {"EKMFLGDQVZNTOWYHXUSPAIBRCJ",     "AJDKSIRUXBLHWTMCQGZNPYFVOE", "BDFHJLCPRTXVZNYEIWGAKMUSQO",     "ESOVPZJAYQUIRHXLNFTGKDCMWB", "VZBRGITYUPSDNHLXAWMJQOFECK"} /.   lettersToNumbers;notches = ({"Q", "E", "V", "J", "Z"} /. lettersToNumbers) - 1;reflector =  Characters@"YRUHQSLDPXNGOKMIEBFZCWVJAT" /. lettersToNumbers;The state of the machine consists of an ordered set of 3 rotors and their current rotation. The first rotor rotates every letter. The others two periodically rotate based on the notches for each rotor. The configuration below is the one used in the animation above. configuration = {{3, 2, 1}, ({"X", "D", "H"} /. lettersToNumbers) -      1};  step[] :=   configuration[[2]] =    Mod[configuration[[2]] +      Switch[{configuration[[2, 1]] == notches[[configuration[[1, 1]]]],        configuration[[2, 2]] ==         notches[[configuration[[1, 2]]]]}, {True, True}, {1, 1,       1}, {True, False}, {1, 1, 0}, _, {1, 0, 0}], 26]Encoding consists of a sequence of permutations where the input prior to each step is offset by that rotor's rotation and the output is then reverse-offset before sending to the next rotor. The reflector rotor does not rotate and has the added constraint that its permutation is its own inverse. After reflecting the input is passed back through the rotors in reverse order.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[[configuration[[1]]]], configuration[[2]]}]] /.    numbersToLetters)Here's the result with the same input from the animation:encode /@ Characters@"WOLFRAMMATHEMATICA"{"I", "X", "Z", "K", "H", "E", "U", "W", "T", "J", "Q", "C", "J", \"P", "Z", "E", "T", "C"}
4 years ago
 Very nice Michael. It'd be cool if someone could hook it up to those interactive rotating wheels ;-)
4 years ago
 Luis Ledesma 1 Vote Excellent work Michael, You left me amazed, I will keep trying, your solution is very interesting, I hope I can help with anything,
4 years ago
 Michael Hale 2 Votes I'm glad you like it! I had skimmed the Wikipedia article before, but programming something gives you a very concrete understanding of it. I've done some projects in ActionScript, and I can assure you the code for both the logic and UI would be cleaner in Wolfram. It wouldn't even be that much harder in Wolfram to expand the visualization to 3D. I did a cleaning pass over the logic code to be more readable and shave off a few characters. 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)turns = {"A", "B", "C"} /. lettersToNumbers;StringJoin[encode /@ Characters@"BEWAREXTHEXIDESXOFXMARCH"]FODCBDZMNFUWUPWMLWFQVAOGturns = {"A", "B", "C"} /. lettersToNumbers;StringJoin[encode /@ Characters@"FODCBDZMNFUWUPWMLWFQVAOG"]BEWAREXTHEXIDESXOFXMARCH
4 years ago
 Sam Carrettie 2 Votes Interesting, turns out we have a Demonstration for this. I am curious how different is the code from Michael's.Encryption with the Enigma Machine
4 years ago
 Michael Hale 2 Votes Ah, normally I have good habits for searching for existing code prior to starting. This does remind me of wanting a pallette button that will copy a notebook after sending its symbol names and comments through Google Translate. As always though, triple-click is your friend when looking at someone else's code. I think the heart of the encryption is here: p0 = Mod[crkaLoc - #[[1, 3, 1]], m, 1]; tabelaPozicijGor =    FoldList[Mod[      Position[#2[[1]], Mod[#1 + #2[[2]], m, 1]][[1, 1]] - #2[[2]], m,       1] &, p0, Transpose[{#[[1, 1]], #[[1, 3]]}]];  p0 = Position[#[[1, 2]], tabelaPozicijGor[[-1]]][[1]];    p0 = #[[1, 2, p0[[1]], Mod[p0[[2]], 2] + 1]]; tabelaPozicijDol =    FoldList[Mod[#2[[1, Mod[#1 + #2[[2]], m, 1]]] - #2[[2]], m, 1] &,    p0, Transpose[{Reverse[#[[1, 1]]], Reverse[#[[1, 3]]]}]];He splits path before and after the reflector into two separate folds. He also uses Position on lists instead of built-in permutation functions. The slot parameters to the Transpose calls (the substitution rules for the rotors and reflector and the turn and notch positions) are referring to arguments for a very large pure function, so you have to scroll down over a page to see what they are. I compress that into one Fold.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}]My main critique would be that he tries to illustrate the process as a continuous animation that re-evaluates all of his code on every frame. I think the approach in the Flash applet of just updating the image once for every letter is easier to follow, and then you wouldn't notice the choppiness from such a large expression having no nested Dynamics.
4 years ago
 Hi Michael, I have the following problem with your code, copy it as I was in your post, but I get a different result, here I leave my input and the result returned me mathematicaIn[15]:= encode /@ Characters@"WOLFRAMMATHEMATICA"Out[15]= {"Z", "L", "R", "U", "I", "B", "T", "D", "D", "E", "I", "H", \"V", "L", "J", "B", "X", "F"}Additionally you annex my mathematica file, so that may be what you check please, as I have tried to copy their best, greetings Attachments:
4 years ago
 Michael Hale 1 Vote I happen to be in Florida right now with just v8 on my laptop, and the code no longer works for me either! I wrote it on my desktop at home with v9. It appears that the behavior of PermutationReplace changed from v8 to v9, and this breaking change is not mentioned in the documentation. In v9 (the behavior I expect), if a permutation is given in list form instead of as Cycles, the behavior is simply:permutation[[element]]But on v8 it appears to be:Position[permutation,element][[1,1]]So thisPermutationReplace[1, {2, 3, 1}]gives 2 on v9 and 3 on v8. The fix is to simply not use PermutationReplace and just useMod[#2[[1, Mod[# + #2[[2]], 26, 1]]] - #2[[2]], 26, 1] &as the function in Fold. I've attached a notebook with this fix that should work in v8 and v9. Attachments:
4 years ago
 Thanks for your correction, simply amazing, I tested the code and run perfectly.  I've tried with several words and several positions of the rotors and it works fine
4 years ago
 Hi Michael Hale, to conclude this section, I want to ask if you have any idea how to make it more visual, for my part I have been very satisfied and very surprised, but I would like someone else help us carry out the graphic part, to whom can we go?, I hope someone has the same idea, greetings
4 years ago
 It depends on what you are trying to accomplish. There are many variations on how you can visualize practically anything. If you are trying to teach people the basic workings of the Enigma machine as quickly as possible, it might be hard to beat the simple diagram and caption on Wikipedia. The larger amount of information presented in the linked Flash applet and Demonstration can take longer to absorb for someone who doesn't already have some understanding about what they are watching. On the other hand, the Flash applet and Demonstration are better at drawing people in so they actually want to learn about something (or learn to program) compared to just a simple diagram. If you have a specific idea I can certainly help you implement it. The symbolic graphics capabilities are a lot of fun to use.
4 years ago
4 years ago
 Charles Stevens 3 Votes I made 3 manipulates to emulate the Enigma 1, 3, and 4 a few years ago. They can be used to decode actual Enigma enciphered messages. I haven't posted a cdf of them yet, but may in the future.
3 years ago
 Charles, they look beautiful. Can you post code or attache notebooks to the post?