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

;; 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-ve 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-ve text height)
   (permute text (fence-ve height (string-length text))))

;; String Nat -> String
(define (decrypt-ve text height)
   (unpermute text (fence-ve 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)))))

;; ----------------------------------------------------
;; Tobin-Hochstadt, cycle solution
;; http://list.cs.brown.edu/pipermail/plt-dev/2009-April/000533.html

(define (rail n l)
  (zip-sort (for/list ([i (in-cycle (in-range 1 (add1 n)) 
                                    (in-range (sub1 n) 1 -1))]
                       [e l])
               (cons i e))))

(define (derail n s)
  (zip-sort (map cons 
                 (rail n (for/list ([i (in-naturals)] [e s]) i))
                 s)))

(define (zip-sort ks/vs)
  (map cdr (sort #:key car ks/vs <)))

(define (encrypt-cy s n) (apply string (rail n s)))
(define (decrypt-cy s n) (apply string (derail n (string->list s))))

;; ----------------------------------------------------
;; Felleisen, output data driven design recipe solution
;; http://list.cs.brown.edu/pipermail/plt-scheme/2009-March/031344.html

(define X '_)

#;
(check-expect (encrypt "diesisteinklartext" 6) "dkinleiasertittxse")

(define (encrypt-dr str h)
   (list->string (fence (string->list str) h)))

;; [Listof X] -> [Listof X]
(define (fence lox h)
   (local ((define a (apply append (transpose (waves lox h))))
           (define r (filter (lambda (e) (not (eq? X e))) a)))
     r))

;; [Listof X] Nat -> [Listof [Listof (U X Char)]]
;; chop the list into as many pieces of length h, plus padding of the
;; last one
#;
(check-expect (waves '(d i e s i s t e i n k l a r t e x t) 6)
               '((d i e s i s) (_ n i e t _) (k l a r t e) (_ _ _ t x  _)))
#;
(check-expect (waves '(d i e s i) 3) '((d i e) (_ s _) (i _ _)))

(define (waves str h)
  (local ((define (down str)
            (cond
              [(>= h (length str)) (list (append str (fill h str)))]
              [else (cons (take str h) (up (drop str h)))]))
          (define (up str)
            (cond
              [(>= (- h 2) (length str))
               (list (append (fill (- h 1) str) (reverse (cons X  str))))]
              [else (cons (cons X (reverse (cons X (take str (- h  2)))))
                          (down (drop str (- h 2))))]))
          (define (fill h str) (build-list (- h (length str))  
                                           (lambda (i) X))))
    (down str)))

;; [Listof [Listof X]] -> [Listof [Listof X]]
;; transpose the matrix
#;
(check-expect
  (transpose '((d i e s i s) (_ n i e t _) (k l a r t e) (_ _ _ t x _)))
  '((d _ k _) (i n l _) (e i a _) (s e r t) (i t t x) (s _ e _)))

(define (transpose m)
   (cond
     [(empty? (first m)) '()]
     [else (cons (map first m) (transpose (map rest m)))]))


(define (decrypt-dr str h)
   (local ((define e (fence (build-list (string-length str)
                                        (lambda  (i) i)) h))
           (define x (map list e (string->list str)))
           (define y (sort x (lambda (i j) (<= (first i) (first j)))))
           (define z (map second y)))
     (list->string z)))

;; some demonstration code
;(define e (encrypt "diesisteinklartext" 6))
;(check-expect (decrypt e 6) "diesisteinklartext")


;; ----------------------------------------------------
;; Benchmark setup

(define-struct crypt (name en de))
(define crypts
  (list (make-crypt "ve" encrypt-ve decrypt-ve)
        (make-crypt "ra" encrypt-ra decrypt-ra)
        (make-crypt "dr" encrypt-dr decrypt-dr)
        (make-crypt "co" encrypt-co decrypt-co)
        (make-crypt "cy" encrypt-cy decrypt-cy)))

(define (do size crypts)
  (define str (build-string size (lambda (i) #\x)))
  
  (write `(define str (build-string ,size (lambda (i) #\x))))
  (newline)
  (newline)
  
  (display '(encrypt str 20))
  (newline)
  (for-each (lambda (c)
              (printf "~a: " (crypt-name c))
              (collect-garbage)
              (time (void ((crypt-en c) str 20))))
            crypts)
  
  (newline)
  
  (display '(decrypt str 20))
  (newline)
  (for-each (lambda (c)
              (printf "~a: " (crypt-name c))
              (collect-garbage)
              (time (void ((crypt-de c) str 20))))
            crypts)
  (newline))
  
(define header
#<<HEADER
Garden fence encryption benchmark
=================================
http://list.cs.brown.edu/pipermail/plt-scheme/2009-March/031310.html

Key:

ve = imperative vector
http://list.cs.brown.edu/pipermail/plt-scheme/2009-March/031313.html

ra = random access list (translation of above)

dr = Felleisen output data driven design recipe
http://list.cs.brown.edu/pipermail/plt-scheme/2009-March/031344.html
(Omitted from 1,000,000 chars case since it takes too long)

co = Felleisen combinator
http://list.cs.brown.edu/pipermail/plt-dev/2009-April/000532.html

cy = Tobin-Hochstadt in-cycle
http://list.cs.brown.edu/pipermail/plt-dev/2009-April/000533.html


HEADER
)

(define (run-garden-fence-benchmark)
  (printf header)
  (do 10000 crypts)
  (do 100000 crypts)
  (do 1000000 (filter (lambda (c) (not (equal? "dr" (crypt-name c)))) crypts)))