; playfair

(define (string-upcase str)
  (list->string
    (map char-upcase
      (string->list str))))

(define (string-index c str)
  (let loop ((ss (string->list str)) (k 0))
    (cond ((null? ss) #f)
          ((char=? (car ss) c) k)
          (else (loop (cdr ss) (+ k 1))))))

(define (left-section proc . args)
  (lambda xs (apply proc (append args xs))))

(define (split plain-text)
  (let loop ((ps (string->list (string-upcase plain-text))) (x #\_) (xs '()))
    (cond ((null? ps) (if (char=? x #\_) (reverse xs)
                        (reverse (cons (string x #\X) xs))))
          ((not (char-alphabetic? (car ps))) (loop (cdr ps) x xs))
          ((char=? (car ps) #\J) (loop (cons #\I (cdr ps)) x xs))
          ((char=? x #\_) (loop (cdr ps) (car ps) xs))
          ((char=? (car ps) x) (loop ps #\_ (cons (string x #\X) xs)))
          (else (loop (cdr ps) #\_ (cons (string x (car ps)) xs))))))

(define (make-key pass-phrase)
  (let loop ((pass (string->list (string-append
              (string-upcase pass-phrase) "ABCDEFGHIKLMNOPQRSTUVWXYZ")))
             (key '()))
    (cond ((null? pass) (list->string (reverse key)))
          ((not (char-alphabetic? (car pass))) (loop (cdr pass) key))
          ((char=? (car pass) #\J) (loop (cons #\I (cdr pass)) key))
          ((member (car pass) key) (loop (cdr pass) key))
          (else (loop (cdr pass) (cons (car pass) key))))))

(define (p->c key str)
  (let ((a (string-index (string-ref str 0) key))
        (b (string-index (string-ref str 1) key)))
    (cond ((= (quotient a 5) (quotient b 5)) ; same row
            (string (string-ref key (+ (* (quotient a 5) 5) (modulo (+ a 1) 5)))
                    (string-ref key (+ (* (quotient b 5) 5) (modulo (+ b 1) 5)))))
          ((= (modulo a 5) (modulo b 5)) ; same column
            (string (string-ref key (+ (* (modulo (+ (quotient a 5) 1) 5) 5) (modulo a 5)))
                    (string-ref key (+ (* (modulo (+ (quotient b 5) 1) 5) 5) (modulo b 5)))))
          (else (string (string-ref key (+ (* (quotient a 5) 5) (modulo b 5)))
                        (string-ref key (+ (* (quotient b 5) 5) (modulo a 5))))))))

(define (encipher key plain-text)
  (apply string-append (map (left-section p->c key) (split plain-text))))

(define (c->p key str)
  (let ((a (string-index (string-ref str 0) key))
        (b (string-index (string-ref str 1) key)))
    (cond ((= (quotient a 5) (quotient b 5)) ; same row
            (string (string-ref key (+ (* (quotient a 5) 5) (modulo (- a 1) 5)))
                    (string-ref key (+ (* (quotient b 5) 5) (modulo (- b 1) 5)))))
          ((= (modulo a 5) (modulo b 5)) ; same column
            (string (string-ref key (+ (* (modulo (- (quotient a 5) 1) 5) 5) (modulo a 5)))
                    (string-ref key (+ (* (modulo (- (quotient b 5) 1) 5) 5) (modulo b 5)))))
          (else (string (string-ref key (+ (* (quotient a 5) 5) (modulo b 5)))
                        (string-ref key (+ (* (quotient b 5) 5) (modulo a 5))))))))

(define (decipher key cipher-text)
  (apply string-append (map (left-section c->p key) (split cipher-text))))

(display (encipher (make-key "PLAYFAIR") "PROGRAMMING PRAXIS"))
(newline)
(display (decipher (make-key "PLAYFAIR") "LIVOBLKZEDOELIYWCN"))

LIVOBLKZEDOELIYWCN
PROGRAMXMINGPRAXIS