Caesar's cipher

Question

How can Caesar cipher be implemented? I want to use StringReplace but I don't know how to write the replacement rule to replace the characters with, say, the character two positions down in the alphabet.

Answer 1

rule[n_] := With[{a = CharacterRange["a", "z"]}, Thread[a -> RotateLeft[a,n]]]

res = StringJoin[StringSplit["hello", ""] /. rule[2]]

"jgnnq"

StringJoin[StringSplit[res, ""] /. Reverse /@ rule[2]]

"hello"

Or to follow the example in the Wikipedia page:

StringJoin[StringSplit[CharacterRange["a", "z"], ""] /. rule[-3]]

"xyzabcdefghijklmnopqrstuvw"

Answer 2

This answer is just a complement to Öskå's, showing off the new operator forms introduced in v10. For compatibility with earlier versions, see his answer.

az = CharacterRange["a", "z"];

Notice the use of ReplaceAll with a single argument to construct a replacing operator:

encode = ReplaceAll@Dispatch@Thread[az -> RotateLeft[az, 13]];

StringJoin@encode@Characters["secret message"]
(* "frperg zrffntr" *)

StringJoin@encode@Characters[%]
(* "secret message" *)

Answer 3

The simplest way to express the transformation rules for StringReplace would be to write them explicitly (here using the traditional Caesar Cipher three-character shift):

StringReplace["THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG"
, { "A"->"X","B"->"Y","C"->"Z","D"->"A","E"->"B"
  , "F"->"C","G"->"D","H"->"E","I"->"F","J"->"G"
  , "K"->"H","L"->"I","M"->"J","N"->"K","O"->"L"
  , "P"->"M","Q"->"N","R"->"O","S"->"P","T"->"Q"
  , "U"->"R","V"->"S","W"->"T","X"->"U","Y"->"V"
  , "Z"->"W"
  }
]

(* QEB NRFZH YOLTK CLU GRJMP LSBO QEB IXWV ALD *)

To avoid the tedium of writing such rules, we could create them programatically from paired substitutions:

$encipher =
  Rule ~MapThread~ Characters @ {"ABCDEFGHIJKLMNOPQRSTUVWXYZ", "XYZABCDEFGHIJKLMNOPQRSTUVW"}

(* 
{A->X,B->Y,C->Z,D->A,E->B,F->C,G->D,H->E,I->F,J->G,K->H,L->I,M->J,
 N->K,O->L,P->M,Q->N,R->O,S->P,T->Q,U->R,V->S,W->T,X->U,Y->V,Z->W}
*)

StringReplace["THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG", $encipher]

(* QEB NRFZH YOLTK CLU GRJMP LSBO QEB IXWV ALD *)

The reverse transformation is then easily computed:

$decipher = Reverse /@ $encipher;

StringReplace["QEB NRFZH YOLTK CLU GRJMP LSBO QEB IXWV ALD", $decipher]

(* THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG *)

This scheme is simple, and supports arbitrary substitutions beyond simple shifts. But since a Caesar Cipher is a simple shift, we could define the transformation algorithmically instead:

StringReplace["THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG"
, c_ /; OrderedQ[{"A", c, "Z"}] :>
    FromCharacterCode[Mod[ToCharacterCode@c - 65 - 3, 26] + 65]
]

(* QEB NRFZH YOLTK CLU GRJMP LSBO QEB IXWV ALD *)

This subtracts three from the character code of each letter, wrapping around A back to Z. The condition /; OrderedQ[...] ensures that only the letters are affected. Spaces are unchanged, as are all other characters that are not Latin letters (we can quibble about whether Caesar knew about J or U on another StackExchange site :).

We could express the shift in a helper function, adding support for both encryption and decryption along the way:

$a = ToCharacterCode @ "A";

shift[n_, c_] /; OrderedQ[{"A", c, "Z"}] :=
  FromCharacterCode[Mod[ToCharacterCode@c - $a + n, 26] + $a]

shift[_, c_] := c

Again, only the letters from A to Z are changed and other characters are left untouched:

shift[-3, "A"]
(* X *)

shift[3, "X"]
(* A *)

shift[3, "!"]
(* ! *)

The StringReplace expression becomes very simple when using shift:

StringReplace["HI GLENN STOP GOT GOOD STUFF FOR YOU STOP SIGNED ED", c_ :> shift[-3, c]]

(* EF DIBKK PQLM DLQ DLLA PQRCC CLO VLR PQLM PFDKBA BA *)

The function supports deciphering by specifying an opposite shift:

StringReplace["EF DIBKK PQLM DLQ DLLA PQRCC CLO VLR PQLM PFDKBA BA", c_ :> shift[3, c]]

(* HI GLENN STOP GOT GOOD STUFF FOR YOU STOP SIGNED ED *)

Answer 4

Insert the passage you want shifting as a string:

str = HELLO WORLD

Then, define this function:

f[x_] := If[64 < x < 91, (Mod[x - 65 + s, 26] + 65), x]

Where s is your shift (positive or negative).

Then, simply map the function over the character codes of your string:

FromCharacterCode[Map[f, ToCharacterCode[str]]]

This will result in a Caeser Shift of s from Upper case letters to Upper case letters, without altering the punctuation.

(To change Upper case letters to lower case, or the other way round, simply replace the correspodning 65 with 97.

Answer 5

Using Lookup:

Clear["Global`*"];
CaeserCipher[s_String, lshift_Integer] := 
 Module[{lc = Alphabet[], uc = ToUpperCase@Alphabet[]},
  encoder = 
   Thread[lc -> RotateLeft[lc, lshift]]~Join~
    Thread[uc -> RotateLeft[uc, lshift]];
  (*Echo[encoder];*)
  Lookup[encoder, #, #] & /@ Characters@s // StringJoin
  ]

str = "The quick brown fox jumped OVER the LAZY dog";
secret = CaeserCipher[str, 23]

"Qeb nrfzh yoltk clu grjmba LSBO qeb IXWV ald"

This can be deciphered if one knows the key (-23 or 3):

CaeserCipher[secret, -23]

"The quick brown fox jumped OVER the LAZY dog"

---

But what if the key is not known? The following function checks all shifts and selects the one for which the majority of the deciphered words satisfy the DictionaryWordQ predicate. Examples are borrowed from other answers on the page with thanks.

CaeserDecipher[secret_String] := CaeserCipher[secret
  , Scan[If[
         Majority @@ (DictionaryWordQ /@ 
            StringSplit@CaeserCipher[secret, #]), Sow@#, Nothing] &
       , Range@Length@Alphabet[]] // Reap // Last // First // First
  ]

s1 = "EF DIBKK PQLM DLQ DLLA PQRCC CLO VLR PQLM PFDKBA BA";
s2 = "Qeb nrfzh yoltk clu grjmba LSBO qeb IXWV ald";
s3 = "uqog tcpfqo vgzv";
s4 = "Vjcqnvjcrlj rb odw";

CaeserDecipher /@ {s1, s2, s3, s4} // Column