; double transposition cipher

(define (sort lt? xs)
  (define (merge x1 x2)
    (cond ((null? x1) x2)
          ((null? x2) x1)
          ((lt? (car x2) (car x1))
            (cons (car x2) (merge x1 (cdr x2))))
          (else (cons (car x1) (merge (cdr x1) x2)))))
  (define (merge-pairs xs k)
    (if (or (null? (cdr xs)) (odd? k)) xs
        (merge-pairs
          (cons (merge (car xs) (cadr xs)) (cddr xs))
          (quotient k 2))))
  (define (next-run run xs)
    (if (or (null? xs) (lt? (car xs) (car run)))
        (values (reverse run) xs)
        (next-run (cons (car xs) run) (cdr xs))))
  (define (sorting xs ys k)
    (if (null? xs)
        (car (merge-pairs ys 0))
        (call-with-values
          (lambda () (next-run (list (car xs)) (cdr xs)))
          (lambda (run tail)
            (sorting tail (merge-pairs (cons run ys) (+ k 1)) (+ k 1))))))
  (if (null? xs) xs (sorting xs '() 0)))

(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 (make-next key text)
  (let* ((klen (string-length key))
         (tlen (string-length text))
         (ks (make-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-key word)
;  (map cadr
;    (sort (lambda (a b) (char<? (car a) (car b)))
;      (zip (string->list word)
;           (range 0 (string-length word))))))

(define (make-key word)
  (define (lt? a b)
    (cond ((char<? (car a) (car b)) #t)
          ((char<? (car b) (car a)) #f)
          (else (< (cadr a) (cadr b)))))
  (map cadr (sort lt?
    (zip (string->list word)
         (range 0 (string-length word))))))

(define (encrypt 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 (decrypt 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)))))

(display (encrypt "STRIPE" (encrypt "COACH" "PROGRAMMINGPRAXIS")))
(newline)
(display (decrypt "COACH" (decrypt "STRIPE" "GNPAPARSRIMOIXMGR")))

GNPAPARSRIMOIXMGR
PROGRAMMINGPRAXIS