; straddling checkerboard

(define (last-pair xs)
  (cond ((null? xs) (error 'last-pair "empty input"))
        ((null? (cdr xs)) xs)
        (else (last-pair (cdr xs)))))

(define (digits n . args)
  (let ((b (if (null? args) 10 (car args))))
    (let loop ((n n) (d '()))
      (if (zero? n) d
          (loop (quotient n b)
                (cons (modulo n b) d))))))

(define (clean text)
  (let loop ((cs (string->list text)) (zs '()))
    (cond ((null? cs) (reverse zs))
          ((char=? (car cs) #\space)
            (loop (cdr cs) (cons #\* zs)))
          ((char-alphabetic? (car cs))
            (loop (cdr cs) (cons (char-upcase (car cs)) zs)))
          ((char-numeric? (car cs))
            (loop (cdr cs) (cons (car cs) zs)))
          (else (loop (cdr cs) zs)))))

(define (make-checkerboard key s1 s2 s3)
  (define alphabet (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
  (define (put c zs)
    (cond ((member c zs) '())
          ((char-numeric? c) (list c))
          ((char<=? #\A c #\I)
            (append (put (integer->char (- (char->integer c) 16)) zs) (list c)))
          ((char=? c #\J)
            (append (put #\0 zs) (list c)))
          (else (list c))))
  (define (fix xs)
    (let loop ((k 0) (xs xs) (zs '()))
      (cond ((null? xs) (reverse zs))
            ((= k s1) (loop (+ k 1) xs (cons #\space zs)))
            ((= k s2) (loop (+ k 1) xs (cons #\space zs)))
            ((= k s3) (loop (+ k 1) xs (cons #\space zs)))
            (else (loop (+ k 1) (cdr xs) (cons (car xs) zs))))))
  (let loop ((ks (append (clean key) alphabet)) (zs '()))
    (if (null? ks)
        (list->string (fix (reverse zs)))
        (loop (cdr ks) (append (put (car ks) zs) zs)))))

(define space1 #f)
(define space2 #f)
(define space3 #f)
(define e-key '())
(define d-key '())

(define (make-keys checkerboard)
  (do ((i 0 (+ i 1))) ((= i 10))
    (cond ((not (char-whitespace? (string-ref checkerboard i)))
            (set! e-key (cons (list (string-ref checkerboard i)
                  i) e-key)))
          (space2 (set! space3 i))
          (space1 (set! space2 i))
          (else (set! space1 i))))
  (do ((i 10 (+ i 1))) ((= i 20))
    (set! e-key (cons (list (string-ref checkerboard i)
          (- i 10) space1) e-key)))
  (do ((i 20 (+ i 1))) ((= i 30))
    (set! e-key (cons (list (string-ref checkerboard i)
          (- i 20) space2) e-key)))
  (do ((i 30 (+ i 1))) ((= i 40))
    (set! e-key (cons (list (string-ref checkerboard i)
          (- i 30) space3) e-key)))
  (let ((d1 '()) (d2 '()) (d3 '()) (d4 '()))
    (do ((i 0 (+ i 1))) ((= i 10))
      (if (not (char-whitespace? (string-ref checkerboard i)))
          (set! d1 (cons (list i
                (string-ref checkerboard i)) d1))))
    (do ((i 10 (+ i 1))) ((= i 20))
       (set! d2 (cons (list (- i 10)
             (string-ref checkerboard i)) d2)))
    (do ((i 20 (+ i 1))) ((= i 30))
       (set! d3 (cons (list (- i 20)
             (string-ref checkerboard i)) d3)))
    (do ((i 30 (+ i 1))) ((= i 40))
       (set! d4 (cons (list (- i 30)
             (string-ref checkerboard i)) d4)))
    (set! d-key (list d1 d2 d3 d4))))

(define (straddle plain-text)
  (let loop ((ps plain-text) (cs '()))
    (cond ((null? ps) (reverse cs))
          ((assoc (car ps) e-key) =>
            (lambda (xs) (loop (cdr ps) (append (cdr xs) cs))))
          (else (loop (cdr ps) (cons (car ps) (cons (car ps) cs)))))))

(define (unstraddle list-of-digits)
  (let loop ((cs list-of-digits) (ps '()))
    (cond ((null? cs) (map cadr (reverse ps)))
          ((= (car cs) space1)
            (loop (cddr cs) (cons (assoc (cadr cs) (cadr d-key)) ps)))
          ((= (car cs) space2)
            (loop (cddr cs) (cons (assoc (cadr cs) (caddr d-key)) ps)))
          ((= (car cs) space3)
            (loop (cddr cs) (cons (assoc (cadr cs) (cadddr d-key)) ps)))
          (else (loop (cdr cs) (cons (assoc (car cs) (car d-key)) ps))))))

(define (cycle xs) (set-cdr! (last-pair xs) xs) xs)

(define (encipher key plain-text)
  (define (plus a b) (modulo (+ a b) 10))
  (let loop ((xs (straddle (clean plain-text)))
             (ks (cycle (digits key))) (zs '()))
    (if (null? xs)
        (list->string (unstraddle (reverse zs)))
        (loop (cdr xs) (cdr ks) (cons (plus (car xs) (car ks)) zs)))))

(define (decipher key cipher-text)
  (define (minus a b) (modulo (- a b) 10))
  (let loop ((xs (straddle (string->list cipher-text)))
             (ks (cycle (digits key))) (zs '()))
    (if (null? xs)
        (list->string
          (map (lambda (c) (if (char=? c #\*) #\space c))
            (unstraddle (reverse zs))))
        (loop (cdr xs) (cdr ks) (cons (minus (car xs) (car ks)) zs)))))

(make-keys (make-checkerboard "sharpen your saw" 2 5 9))
(display (make-checkerboard "sharpen your saw" 2 5 9)) (newline)
(display (encipher 2641 "programming praxis")) (newline)
(display (decipher 2641 "S811R53S87A18RUAS8PSSH5")) (newline)

SH 8A 1RP E5N*YOUWB2C3D4F6G7I9J0KLMQTVXZ
S811R53S87A18RUAS8PSSH5
PROGRAMMING PRAXIS