codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
; 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)
Private
[
?
]
Run code
Submit