Message Boards Message Boards

Enigma-like machine in Wolfram Language?

Posted 11 years ago
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
POSTED BY: Luis Ledesma
19 Replies
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.

POSTED BY: Sam Carrettie
Posted 11 years ago
In this wikipedia link this enigma how the machine works, I hope is enough information.
https://en.wikipedia.org/wiki/Enigma_machine
POSTED BY: Luis Ledesma
Posted 11 years ago
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"}
POSTED BY: Michael Hale
Very nice Michael. It'd be cool if someone could hook it up to those interactive rotating wheels ;-)
POSTED BY: Sam Carrettie
Posted 11 years ago
Excellent work Michael, You left me amazed, I will keep trying, your solution is very interesting, I hope I can help with anything,
POSTED BY: Luis Ledesma
Posted 11 years ago
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"]
FODCBDZMNFUWUPWMLWFQVAOG
turns = {"A", "B", "C"} /. lettersToNumbers;
StringJoin[encode /@ Characters@"FODCBDZMNFUWUPWMLWFQVAOG"]
BEWAREXTHEXIDESXOFXMARCH
POSTED BY: Michael Hale
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

POSTED BY: Sam Carrettie
Posted 11 years ago
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.
POSTED BY: Michael Hale
Posted 11 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 mathematica
In[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:
POSTED BY: Luis Ledesma
Posted 11 years ago
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 this
PermutationReplace[1, {2, 3, 1}]
gives 2 on v9 and 3 on v8. The fix is to simply not use PermutationReplace and just use
Mod[#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:
POSTED BY: Michael Hale
Posted 11 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
POSTED BY: Luis Ledesma
Posted 11 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
POSTED BY: Luis Ledesma
Posted 11 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.
POSTED BY: Michael Hale
Posted 11 years ago
michael,would like to ask you,
POSTED BY: Luis Ledesma

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. Enigma 1 - Type M1

Type 4

POSTED BY: Charles Stevens

Charles, they look beautiful. Can you post code or attache notebooks to the post?

POSTED BY: Sam Carrettie
Posted 10 years ago

Excellent work, I think that this demo left me breathless for a good while, we would like to comment that all the demonstrations of the enigma machine are excellent. Finally would be of much that the author share their notebooks to continue learning more about this program

POSTED BY: Luis Ledesma

For those interested in my Enigma manipulates, here is a link to a cdf paper I did along with making the simulations. The majority of it explains the basic mechanics, a little of the math, and the three manipulates at the end. It's not polished, but should work as a starting point for understanding a little about the ENIGMA. I may do a talk at a local math conference the area, but I'm not sure how many math folk would be interested. One thing to note is that the "copy to clipboard" feature doesn't work in the cdf (Wolfram disabled that as far as I can tell.) It's use is for copying the settings and coded message to the clipboard for saving and printing. If you find any errors, please let me know. As far as I've tested, the simulation runs 100% accurate, even with the double-step oddity. Each manipulate is about 1200 lines of code; rather large, but hopefully though, the manipulate is not too cumbersome to use. Here is the link, with the manipulates at the end.

Enigma Article and Manipulates

Sincerely, Charles

P.S. CDF file is also attached to this post.

Attachments:
POSTED BY: Charles Stevens

Charles, the CDF you attached is beautiful. Great interfaces and educational work. Could you also share a notebook with actual code? We could learn a trick or two from you.

POSTED BY: Sam Carrettie
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract