codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
(define (take n xs) (let loop ((n n) (xs xs) (ys '())) (if (or (zero? n) (null? xs)) (reverse ys) (loop (- n 1) (cdr xs) (cons (car xs) ys))))) (define (drop n xs) (let loop ((n n) (xs xs)) (if (or (zero? n) (null? xs)) xs (loop (- n 1) (cdr xs))))) (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 (filter pred? xs) (let loop ((xs xs) (ys '())) (cond ((null? xs) (reverse ys)) ((pred? (car xs)) (loop (cdr xs) (cons (car xs) ys))) (else (loop (cdr xs) ys))))) (define-syntax assert (syntax-rules () ((assert expr result) (if (not (equal? expr result)) (for-each display `( #\newline "failed assertion:" #\newline expr #\newline "expected: " ,result #\newline "returned: " ,expr #\newline)))))) (define (transpose m) (if (null? (car m)) '() (cons (map car m) (transpose (map cdr m))))) (define (make-list n x) (let loop ((n n) (xs '())) (if (zero? n) xs (loop (- n 1) (cons x xs))))) (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 X '_) ; a unique tag for padding the data structure (define (waves str h) (define (down str) (if (>= h (length str)) (list (fill h str)) (cons (take h str) (up (drop h str))))) (define (up str) (if (>= (- h 2) (length str)) (list (pad (fill (- h 2) str))) (cons (pad (take (- h 2) str)) (down (drop (- h 2) str))))) (define (pad str) (append (list X) (reverse str) (list X))) (define (fill h str) (append str (make-list (- h (length str)) X))) (down str)) (define (fence lox h) (define a (apply append (transpose (waves lox h)))) (filter (lambda (e) (not (eq? X e))) a)) (define (encipher str h) (list->string (fence (string->list str) h))) (define (decipher str h) (define e (fence (range (string-length str)) h)) (define x (map list e (string->list str))) (define y (sort (lambda (i j) (<= (car i) (car j))) x)) (define z (map cadr y)) (list->string z)) (do ((i 2 (+ i 1))) ((< 18 i)) (assert (decipher (encipher "PROGRAMMING PRAXIS" i) i) "PROGRAMMING PRAXIS")) (display (encipher "PROGRAMMING PRAXIS" 4)) (newline) (display (decipher "PMPRAM RSORIGAIGNX" 4))
Private
[
?
]
Run code
Submit