; adfgx

(define (make-next key text)
  (let* ((klen (string-length key))
         (tlen (string-length text))
         (ks (make-transpose-key key))
         (i tlen))
    (lambda ()
      (cond ((< (+ i klen) tlen)
              (set! i (+ i klen)))
            ((pair? ks)
              (set! i (car ks))
              (set! ks (cdr ks)))
            (else (set! i -1)))
      i)))

(define (make-transpose-key word)
  (map cadr
    (sort (lambda (a b) (char<? (car a) (car b)))
      (zip (string->list word)
           (range 0 (string-length word))))))

(define (to-transpose key text)
  (let ((next (make-next key text)))
    (let loop ((i (next)) (cipher '()))
      (if (negative? i)
          (list->string (reverse cipher))
          (loop (next) (cons (string-ref text i) cipher))))))

(define (from-transpose key cipher)
  (let ((next (make-next key cipher))
        (text (make-string (string-length cipher))))
    (do ((i (next) (next))
         (cipher (string->list cipher) (cdr cipher)))
        ((negative? i) text)
      (string-set! text i (car cipher)))))

(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 (string-upcase str)
  (list->string
    (map char-upcase
      (string->list str))))

(define (range . args)
  (case (length args)
    ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
    ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
    ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
           (let loop ((x(car args)) (xs '()))
             (if (le? (cadr args) x)
                 (reverse xs)
                 (loop (+ x (caddr args)) (cons x xs))))))
    (else (error 'range "unrecognized arguments"))))

(define (zip . xss) (apply map list xss))

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))

(define (to-adfgx key plain-text)
  (define (p->c p)
    (let ((x (string-index p key)))
      (string
        (string-ref "ADFGX" (quotient x 5))
        (string-ref "ADFGX" (modulo x 5)))))
  (apply string-append
    (map p->c (map char-upcase
      (string->list plain-text)))))

(define (from-adfgx key cipher-text)
  (define (map2 f xs)
    (if (or (null? xs) (null? (cdr xs))) '()
      (cons (f (car xs) (cadr xs)) (map2 f (cddr xs)))))
  (define (c->p c1 c2)
    (string-ref key
      (+ (* (string-index c1 "ADFGX") 5)
            (string-index c2 "ADFGX"))))
  (list->string
    (map2 c->p (map char-upcase
      (string->list cipher-text)))))

(define (encipher adfgx-key transpose-key plain-text)
  (to-transpose transpose-key (to-adfgx adfgx-key plain-text)))

(define (decipher adfgx-key transpose-key cipher-text)
  (from-adfgx adfgx-key (from-transpose transpose-key cipher-text)))

(display (encipher "BTALPDHOZKQFVSNGICUXMREWY" "TULIP" "PROGRAMMINGPRAXIS"))
(newline)
(display (decipher "BTALPDHOZKQFVSNGICUXMREWY" "TULIP" "DXAFXGGXAXDAFFDDXXXXAFAAGDGXGFGAAD"))

DXAFXGGXAXDAFFDDXXXXAFAAGDGXGFGAAD
PROGRAMMINGPRAXIS