; 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)