I was designing a treasure hunt as a Christmas present. I wanted to create a Playfair cipher as the final clue which when decoded would reveal the location of the Christmas present.

I used R to construct a function which produces a cipher matrix and key lookup table, and an encoded message. Here is a brief description of how the playfair cipher works:

Start with a matrix of letters:

a|J|N|G|o|k S|R|h|B|Z|b x|E|w|z|u|f d|l|t|W|H|p r|K|n|I|c|M s|q|g|P|T|D

and a lookup table:

keypair|letter wD|A bM|B aq|C sB|T

and an encoded message: `sJgfSP`

Find each pair of characters in the encoded message in the matrix, here starting with `aq`

:

*a*|**J**|N|G|o|k
S|R|h|B|Z|b
x|E|w|z|u|f
d|l|t|W|H|p
r|K|n|I|c|M
**s**|*q*|g|P|T|D

and take the “opposite” corners of the box formed by the keypair. In this case the answers are `aq`

, `wD`

, and `sB`

.

Then take the output keypairs and match them in the lookup table. The answer here is `CAT`

.

My function actually uses a slightly adapted version of the Playfair cipher. The differences are:

- In my version if two key values are on the same row or column in the matrix they are simply swapped round, rather than transposed to the right or down.
- In my version the matrix is 6x6 rather than 5x5 and uses a sample of 36 uppercase and lowercase letters rather than 25 (-J) uppercase letters.

Here is the function, which takes the message to be encoded as its single argument. It returns the encoded message, the matrix and the key lookup table:

```
#' Create a playfair-style cipher
#'
#' @param x character string to encode
#'
#' @return list with three slots: (1) encoded message (2) decoder matrix
#' (3) decoder lookup table
#'
#' @details Creates a cipher based on the original playfair cipher.
#' Unlike the original playfair cipher this method produces a
#' 6x6 grid of upper and lowercase letters. Additionally, the
#' behaviour when a keypair appear on the same row or column of
#' the decoder matrix is different. In this version keypairs which
#' appear on the same row or column are merely swapped rather than
#' transposed as in the original cipher.
#' Messages to be encoded are converted to uppercase and all
#' non-alphabet characters are stripped out.
#'
#' @examples
#' x <- "This is a test"
#' playfair(x)
#'
#' @export
#'
playfair <- function(x) {
# List all letters, upper and lowercase (52 chr)
all_chr <- c(letters, LETTERS)
# Create 6x6 matrix of distinct letters
mat <- matrix(sample(all_chr, 6*6), 6, 6)
# Get all pairwise combinations of grid positions
locs_pairs <- matrix(combn(seq(length(mat)), 2), ncol = 2)
locs_clean <- unique(locs_pairs[locs_pairs[,1] != locs_pairs[,2],])
# Randomly sample pairs of grid positions
# 26 times to create windows for each letter
locs_letters <- locs_clean[sample(nrow(locs_clean), 26),]
# Order the pairs to always take the top left of each pair
locs_pairs <- apply(locs_letters, 1, function(y) {
c(min(y), max(y))
})
# Search matrix for grid positions to get letter combinations
combins <- apply(locs_pairs, 2, function(y) {
paste0(mat[y[1]], mat[y[2]])
})
# Make tidy dataframe of letter codes
code_df <- data.frame(input = combins,
output = LETTERS)
# Split x into component characters,
# remove spaces and non-letter characters
x_string <- unlist(strsplit(toupper(x),
split = ""))
x_string_clean <- x_string[x_string %in% LETTERS]
decoded <- code_df[match(x_string_clean, code_df$output), "input"]
# For each character, encode
out <- unlist(lapply(decoded, function(i) {
# Split string
i_split <- unlist(strsplit(i, split = ""))
# Find locations in matrix
letter_one <- c(which(mat == i_split[1], arr.ind = TRUE))
letter_two <- c(which(mat == i_split[2], arr.ind = TRUE))
# Get opposite locations
if (letter_one[1] == letter_two[1]) {
opp_one <- mat[letter_one[1], letter_two[2]]
opp_two <- mat[letter_two[1], letter_one[2]]
} else {
opp_one <- mat[letter_two[1], letter_one[2]]
opp_two <- mat[letter_one[1], letter_two[2]]
}
# Combine into one string
out <- paste0(opp_one, opp_two)
out
}))
return(list(code = out, matrix = mat, key = code_df))
}
```