Solitaire Cipher

(require :cl-ppcre)

;;;; Utility functions

;; Combine a sequence into single string, optionally putting a space between each element of the sequence
(defun combine-string-parts (string-parts &optional (with-space t))
  (string-right-trim " " (format nil
                 (if with-space "~{~A ~}" "~{~A~}" )
                 string-parts)))

;; Divide a string into a sequence of substrings, each of length 5
(defun divide-into-parts (plaintext)
  "divide given plaintext into groups of five characters"
  (combine-string-parts
   (loop for n from 0 to (length plaintext)
      when (and (> n 0) (= 0 (mod n 5)))
      collect (subseq plaintext (- n 5) n))))

;; Prepare input according to Solitaire Cipher rules - remove all punctuation and spaces,
;; convert all letters to uppercase, and split into groups of 5 characters each
(defun prepare-input (input)
  ;; remove spaces and punctuation, convert to uppercase
  (multiple-value-bind (processed-input regex-match-p)
      (cl-ppcre:regex-replace-all "[^A-Z]" (string-upcase input) "")
    (declare (ignore regex-match-p))

  ;; if string length is not a multiple of 5,
  ;; concatenate X's until it is
  (when (not (zerop (mod (length processed-input) 5)))
    (dotimes (x (- 5 (mod (length processed-input) 5)))
      (setf processed-input
        (concatenate 'string processed-input "X"))))

  (divide-into-parts processed-input)))

;;;; deck handling functions
(defun initialize-deck ()
  (append (loop for x from 1 to 52 collect x)
      '(#\A #\B)))

(defun key-deck (deck &optional (shuffle nil))
  ;; should be shuffling randomly, but we keep the deck as is for unit testing
  (when (eq shuffle t)
    ;; shuffle the deck
    deck)
  deck)

;; move given joker given number of spaces down, treating deck as a circular queue
(defun move-joker-n-down (n which-joker deck)
  (let (joker-index new-index)
    (setf joker-index (position which-joker deck)
      deck (remove-if (lambda (x) (eq x which-joker)) deck)
      new-index (+ n joker-index))
    (when (> new-index 53)
      (setf new-index (- new-index 53)))

    (append (subseq deck 0 new-index) `(,which-joker)
        (subseq deck new-index  (length deck)))))

;; perform a triple cut - swap cards above top joker and below bottom joker
(defun triple-cut (deck)
  (let (top-card bottom-card joker-a-position joker-b-position)
    (setf joker-a-position (position #\A deck)
      joker-b-position (position #\B deck)
      top-card (min joker-a-position joker-b-position)
      bottom-card (max joker-a-position joker-b-position))

    (append (subseq deck (+ 1 bottom-card) (length deck))
        (subseq deck top-card (+ 1 bottom-card))
        (subseq deck 0 top-card))))

;; convert a card into its corresponding value
(defun get-card-value (card)
  (case card
      (#\A 53)
      (#\B 53)
      (t card)))

;; perform a count cut - take the value of bottom card, then move that many cards
;; from top of deck to just above bottom deck
(defun count-cut (deck)
  (let (( bottom-card (elt deck (- (length deck) 1)))
    count)
    (setf count (get-card-value bottom-card))

    (append (subseq deck count 53)
        (subseq deck 0 count)
        `(,bottom-card))))

;; convert a card into a character
(defun card->character (card)
  (case card
    (#\A nil) (#\B nil)
    (t (if (> card 26)
       (code-char (+ 64 (- card 26)))
       (code-char (+ 64 card))))))

;; get output character
(defun get-output-character (deck)
  (card->character (elt deck (get-card-value (first deck)))))

;; perform a single round of the SOlitaire cipher
(defun single-round (deck)

  ;; move jokers (steps 2 and 3)
  (setf deck (move-joker-n-down 2 #\B (move-joker-n-down 1 #\A deck)))

  ;; triple cut (step 4)
  (setf deck (triple-cut deck))

  ;; count cut (step 5)
  (setf deck (count-cut deck))

  ;; return deck
  deck)

(defun not-nil (x)
  (not (eq nil x)))

;; get keystream - not sure how to do a loop until condition is met, so
;; generating twice as many characters as needed, then taking first few
(defun get-keystream (deck key-length)

  ;; generate large number of characters
  ;; then extract required number of characters
  (combine-string-parts
   (subseq (remove-if-not 'not-nil
              (loop for n from 1 to (* 2 key-length)
                 do (setf deck (single-round deck))
                 collect (get-output-character deck)))
       0 key-length) nil))

;; encrypt given text using Solitaire cipher
(defun encrypt (plaintext)
  (let (keystream (ciphertext '()))
    (setf keystream (prepare-input (get-keystream (initialize-deck) (length plaintext)))
      plaintext (prepare-input plaintext))
    (dotimes (n (length plaintext) (prepare-input (reverse (combine-string-parts ciphertext nil))))
      (if (not (char-equal (char plaintext n) #\Space))
      (let* ((plaintext-char-value (- (char-code (char plaintext n)) 64))
         (keystream-char-value (- (char-code (char keystream n)) 64)))
        (setf plaintext-char-value (+ plaintext-char-value keystream-char-value))
        (when (> plaintext-char-value 26)
          (setf plaintext-char-value (- plaintext-char-value 26)))
        (push (code-char (+ 64 plaintext-char-value)) ciphertext))
      (push #\Space ciphertext)))))

;; decrypt given text using Solitaire cipher
(defun decrypt (ciphertext)
  (let (keystream (plaintext '()))
    (setf keystream (prepare-input (get-keystream (initialize-deck) (length ciphertext)))
      ciphertext (prepare-input ciphertext))    ;; may not be necessary
    (dotimes (n (length ciphertext) (prepare-input (reverse (combine-string-parts plaintext nil))))
      (if (not (char-equal (char ciphertext n) #\Space))
      (let* ((ciphertext-char-value (- (char-code (char ciphertext n)) 64))
         (keystream-char-value (- (char-code (char keystream n)) 64)))
        (when (<= ciphertext-char-value keystream-char-value)
          (setf ciphertext-char-value (+ 26 ciphertext-char-value)))
        (setf ciphertext-char-value (- ciphertext-char-value keystream-char-value))
        (push (code-char (+ 64 ciphertext-char-value)) plaintext))
      (push #\Space plaintext)))))