#lang scheme
(provide run-garden-fence-benchmark
         (rename-out [encrypt-ra encrypt]
                     [decrypt-ra decrypt]))
         

;; Garden fence encryption benchmark
;; http://list.cs.brown.edu/pipermail/plt-scheme/2009-March/031313.html

;; ----------------------------------------------------
;; Shared

;; String [Listof Nat] -> String
;; Permute the string according to the given permutation.
(define (permute str perm)
   (permuter str perm
             (lambda (i j) (list i j))))

;; String [Listof Nat] -> String
;; Unpermute the string according to the given permutation.
(define (unpermute str perm)
   (permuter str perm
             (lambda (i j) (list j i))))

;; String [Listof Nat] [Nat Nat -> [List Nat Nat]] -> String
;; Abstraction of permute/unpermute.
(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))]))))

;; ----------------------------------------------------
;; Imperative vector solution
;; http://list.cs.brown.edu/pipermail/plt-scheme/2009-March/031313.html

;; [Vectorof [Listof X]] Nat X -> Void
;; Set v[i] to (cons x v[i]).
(define (vector-cons! v i x)
   (vector-set! v i (cons x (vector-ref v i))))

;; Nat Nat -> [Listof Nat]
;; Generate a fence permutation of the given
;; height (> 1) for strings of length len.
(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)))))

;; String Nat -> String
(define (encrypt-vec text height)
   (permute text (fence-vec height (string-length text))))

;; String Nat -> String
(define (decrypt-vec text height)
   (unpermute text (fence-vec height (string-length text))))

;; ----------------------------------------------------
;; Functional random access list solution

(require (planet cce/scheme:4:1/planet)
         (prefix-in ra: (this-package-in main)))

;; Nat Nat -> [Listof Nat]
;; Generate a fence permutation of the given
;; height (> 1) for strings of length len.
(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))))]))))

;; String Nat -> String
(define (encrypt-ra text height)
   (permute text (fence-ra height (string-length text))))

;; String Nat -> String
(define (decrypt-ra text height)
   (unpermute text (fence-ra height (string-length text))))


;; ----------------------------------------------------
;; Felleisen, combinator solution
;; http://list.cs.brown.edu/pipermail/plt-dev/2009-April/000532.html

;; String Nat -> String
;; encrypt according to fence shape
(define (encrypt-co ls n)
   (list->string (wave ls n)))

;; String Nat -> String
;; decrypt according to fence shape
(define (decrypt-co s n)
   (list->string
    (sort2 (wave (for/list ((i (in-naturals)) (c s)) i) n) (string->list s))))

;; [Listof X] Nat -> [Listof X]
;; create a wave from the list, depth n
;; [needed because in Scheme, string != (Listof Char)]
(define (wave ls n)
   (sort2 (in-list (shared ((x (append (range 1 n) (range (- n 1) 2)  x))) x)) ls))

;; [Listof Nat] [Sequence Y] -> [Listof Y]
;; sort lst according to indicies in list inds
(define (sort2 ks ls)
   (map second (sort (for/list ((k ks) (l ls)) (list k l)) < #:key  first)))

;; Nat Nat -> [Listof Nat]
(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)))))


;; ----------------------------------------------------

;; Benchmark setup
(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))