#lang scheme
(provide run-garden-fence-benchmark
(rename-out [encrypt-ra encrypt]
[decrypt-ra decrypt]))
(define (permute str perm)
(permuter str perm
(lambda (i j) (list i j))))
(define (unpermute str perm)
(permuter str perm
(lambda (i j) (list j i))))
(define (permuter str perm f)
(let ([ans (string-copy str)])
(let loop ([i 0] [p perm])
(cond [(= i (string-length str)) ans]
[else (string-set! ans
(first (f i (first p)))
(string-ref str
(second (f i (first p)))))
(loop (add1 i)
(rest p))]))))
(define (vector-cons! v i x)
(vector-set! v i (cons x (vector-ref v i))))
(define (fence-vec height len)
(let ([bot 0]
[top (sub1 height)]
[vec (make-vector height empty)])
(let loop ([n 0] [level 0] [move add1])
(cond [(= n len) (void)]
[(< level bot) (loop n (add1 bot) add1)]
[(> level top) (loop n (sub1 top) sub1)]
[else
(vector-cons! vec level n)
(loop (add1 n) (move level) move)]))
(apply append (map reverse (vector->list vec)))))
(define (encrypt-vec text height)
(permute text (fence-vec height (string-length text))))
(define (decrypt-vec text height)
(unpermute text (fence-vec height (string-length text))))
(require (planet cce/scheme:4:1/planet)
(prefix-in ra: (this-package-in main)))
(define (fence-ra height len)
(let ([bot 0]
[top (sub1 height)])
(let loop ([n 0] [level 0] [move add1] [rls (ra:make-list height empty)])
(cond [(= n len)
(apply append (ra:foldr (lambda (ls r) (cons (reverse ls) r))
empty
rls))]
[(< level bot) (loop n (add1 bot) add1 rls)]
[(> level top) (loop n (sub1 top) sub1 rls)]
[else
(loop (add1 n)
(move level)
move
(ra:list-update rls level (lambda (ls) (cons n ls))))]))))
(define (encrypt-ra text height)
(permute text (fence-ra height (string-length text))))
(define (decrypt-ra text height)
(unpermute text (fence-ra height (string-length text))))
(define (encrypt-co ls n)
(list->string (wave ls n)))
(define (decrypt-co s n)
(list->string
(sort2 (wave (for/list ((i (in-naturals)) (c s)) i) n) (string->list s))))
(define (wave ls n)
(sort2 (in-list (shared ((x (append (range 1 n) (range (- n 1) 2) x))) x)) ls))
(define (sort2 ks ls)
(map second (sort (for/list ((k ks) (l ls)) (list k l)) < #:key first)))
(define (range lo hi)
(if (>= hi lo)
(build-list (+ (- hi lo) 1) (lambda (i) (+ lo i)))
(build-list (+ (- lo hi) 1) (lambda (i) (- lo i)))))
(define (do size)
(define str (build-string size (lambda (i) #\x)))
(write `(define str (build-string ,size (lambda (i) #\x))))
(newline)
(newline)
(display '(encrypt str 20))
(newline)
(display "ra : ")
(collect-garbage)
(time (void (encrypt-ra str 20)))
(display "vec: ")
(collect-garbage)
(time (void (encrypt-vec str 20)))
(newline)
(display '(decrypt str 20))
(newline)
(display "ra : ")
(collect-garbage)
(time (void (decrypt-ra str 20)))
(display "vec: ")
(collect-garbage)
(time (void (decrypt-vec str 20)))
(newline))
(define (run-garden-fence-benchmark)
(printf "Garden fence encryption benchmark~n")
(printf "=================================~n")
(printf "http://list.cs.brown.edu/pipermail/plt-scheme/2009-March/031313.html~n")
(do 10000)
(do 100000)
(do 1000000))