; solitaire cipher

(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 (drop-while pred? xs)
  (let loop ((xs xs))
    (if (or (null? xs) (not (pred? (car xs)))) xs
      (loop (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 (make-list n x)
  (let loop ((n n) (xs '()))
    (if (zero? n) xs
      (loop (- n 1) (cons x xs)))))

(define rand #f)
(define randint #f)
(let ((two31 #x80000000) (a (make-vector 56 -1)) (fptr #f))
  (define (mod-diff x y) (modulo (- x y) two31)) ; generic version
  ; (define (mod-diff x y) (logand (- x y) #x7FFFFFFF)) ; fast version
  (define (flip-cycle)
    (do ((ii 1 (+ ii 1)) (jj 32 (+ jj 1))) ((< 55 jj))
      (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
    (do ((ii 25 (+ ii 1)) (jj 1 (+ jj 1))) ((< 55 ii))
      (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
    (set! fptr 54) (vector-ref a 55))
  (define (init-rand seed)
    (let* ((seed (mod-diff seed 0)) (prev seed) (next 1))
      (vector-set! a 55 prev)
      (do ((i 21 (modulo (+ i 21) 55))) ((zero? i))
        (vector-set! a i next) (set! next (mod-diff prev next))
        (set! seed (+ (quotient seed 2) (if (odd? seed) #x40000000 0)))
        (set! next (mod-diff next seed)) (set! prev (vector-ref a i)))
      (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle)))
  (define (next-rand)
    (if (negative? (vector-ref a fptr)) (flip-cycle)
      (let ((next (vector-ref a fptr))) (set! fptr (- fptr 1)) next)))
  (define (unif-rand m)
    (let ((t (- two31 (modulo two31 m))))
      (let loop ((r (next-rand)))
        (if (<= t r) (loop (next-rand)) (modulo r m)))))
  (init-rand 19380110) ; happy birthday donald e knuth
  (set! rand (lambda seed
    (cond ((null? seed) (/ (next-rand) two31))
          ((eq? (car seed) 'get) (cons fptr (vector->list a)))
          ((eq? (car seed) 'set) (set! fptr (caadr seed))
                                 (set! a (list->vector (cdadr seed))))
          (else (/ (init-rand (modulo (numerator
                  (inexact->exact (car seed))) two31)) two31)))))
  (set! randint (lambda args
    (cond ((null? (cdr args))
            (if (< (car args) two31) (unif-rand (car args))
              (floor (* (next-rand) (car args)))))
          ((< (car args) (cadr args))
            (let ((span (- (cadr args) (car args))))
              (+ (car args)
                 (if (< span two31) (unif-rand span)
                   (floor (* (next-rand) span))))))
          (else (let ((span (- (car args) (cadr args))))
                  (- (car args)
                     (if (< span two31) (unif-rand span)
                       (floor (* (next-rand) span))))))))))

(define-syntax assert ; modified to use sol-equal?
  (syntax-rules ()
    ((assert expr result)
      (if (not (sol-equal? expr result))
          (for-each display `(
            #\newline "failed assertion:" #\newline
            expr #\newline "expected: " ,result
            #\newline "returned: " ,expr #\newline))))))

(define (name idx)
  (define (pips idx)
    (case (modulo (- idx 1) 13)
      ((0) "ace") ((1) "deuce") ((2) "trey")
      ((3) "four") ((4) "five") ((5) "six")
      ((6) "seven") ((7) "eight") ((8) "nine")
      ((9) "ten") ((10) "jack") ((11) "queen")
      ((12) "king")))
  (define (suit idx)
    (case (quotient (- idx 1) 13)
      ((0) "clubs") ((1) "diamonds")
      ((2) "hearts") ((3) "spades")))
  (if (= idx 53) "little joker"
    (if (= idx 54) "big joker"
      (string-append (pips idx) " of " (suit idx)))))

(define (init-deck) (range 1 55))

(define value list-ref) ; 1 <= value <= 54

(define (index deck val) ; 0 <= index <= 53
  (let loop ((deck deck) (idx 0))
    (if (= (car deck) val) idx
      (loop (cdr deck) (+ idx 1)))))

(define (down-one deck idx)
  (if (= idx 53)
      (append (take 1 deck)
              (list (value deck 53))
              (take 52 (drop 1 deck)))
      (append (take idx deck)
              (list (value deck (+ idx 1)))
              (list (value deck idx))
              (drop (+ idx 2) deck))))

(define (down-two deck idx)
  (cond ((= idx 53)
          (append (take 2 deck)
                  (list (value deck 53))
                  (take 51 (drop 2 deck))))
        ((= idx 52)
          (append (take 1 deck)
                  (list (value deck 52))
                  (take 51 (drop 1 deck))
                  (list (value deck 53))))
        (else (append (take idx deck)
                      (take 2 (drop (+ idx 1) deck))
                      (list (value deck idx))
                      (drop (+ idx 3) deck)))))

(define (triple-cut deck)
  (let* ((j1 (index deck 53))
         (j2 (index deck 54))
         (lo (min j1 j2))
         (hi (max j1 j2)))
    (append (drop (+ hi 1) deck)
            (drop lo (take (+ hi 1) deck))
            (take lo deck))))

(define (count-cut deck idx)
  (append (take (- 53 idx)
            (drop idx deck))
          (take idx deck)
          (list (value deck 53))))

(define (next-deck deck)
  (let* ((d1 (down-one deck (index deck 53)))
         (d2 (down-two d1 (index d1 54)))
         (d3 (triple-cut d2)))
    (count-cut d3 (min (value d3 53) 53))))

(define (prep str)
  (map char-upcase
    (filter char-alphabetic?
      (string->list str))))

(define (key-deck key)
  (let loop ((ks (prep key)) (deck (next-deck (init-deck))))
    (if (null? ks) deck
      (loop (cdr ks) (next-deck (count-cut deck (numb (car ks))))))))

(define (numb letr) (- (char->integer letr) 64))
(define (letr numb) (integer->char (+ numb 64)))

(define (card deck)
  (let ((c (value deck (min (value deck 0) 53))))
    (if (< 26 c 53) (- c 26) c)))

(define (fives text)
  (if (< (length text) 6) text
    (append (take 5 text) (list #\space) (fives (drop 5 text)))))

(define (encrypt key plain-text)
  (let* ((p (prep plain-text)) (len (modulo (length p) 5))
         (ps (append p (make-list (if (zero? len) 0 (- 5 len)) #\X))))
    (let loop ((ps ps) (deck (key-deck key)) (cs '()))
      (if (null? ps) (list->string (fives (reverse cs)))
        (if (< 52 (card deck)) (loop ps (next-deck deck) cs)
          (let* ((k (+ (numb (car ps)) (card deck)))
                 (c (letr (if (< 26 k) (- k 26) k))))
            (loop (cdr ps) (next-deck deck) (cons c cs))))))))

(define (decrypt key cipher-text)
  (let loop ((cs (prep cipher-text)) (deck (key-deck key)) (ps '()))
    (if (null? cs) (list->string (reverse ps))
      (if (< 52 (card deck)) (loop cs (next-deck deck) ps)
        (let* ((k (- (numb (car cs)) (card deck)))
               (p (letr (if (< k 1) (+ k 26) k))))
          (loop (cdr cs) (next-deck deck) (cons p ps)))))))

(define (sol-equal? s1 s2)
  (define (del-x s)
    (list->string (reverse
      (drop-while (lambda (c) (char=? c #\X))
        (reverse s)))))
  (let ((p1 (del-x (prep s1))) (p2 (del-x (prep s2))))
    (string=? p1 p2)))

(define (rand-string n)
  (let loop ((n n) (cs '()))
    (if (zero? n) (list->string cs)
      (let* ((r (randint 27))
             (c (if (zero? r) #\space (letr r))))
        (loop (- n 1) (cons c cs))))))

(define (sol-test)
  (assert (encrypt "" "AAAAAAAAAA") "EXKYI ZSGEH")
  (assert (decrypt "" "EXKYI ZSGEH") "AAAAAAAAAA")
  (assert (encrypt "FOO" "AAAAAAAAAAAAAAA") "ITHZU JIWGR FARMW")
  (assert (decrypt "FOO" "ITHZU JIWGR FARMW") "AAAAAAAAAAAAAAA")
  (assert (encrypt "CRYPTONOMICON" "SOLITAIRE") "KIRAK SFJAN")
  (assert (decrypt "CRYPTONOMICON" "KIRAK SFJAN") "SOLITAIRE")
  (do ((i 0 (+ i 1))) ((= i 20))
    (let ((key (rand-string 80)) (plain-text (rand-string 1000)))
      (assert (decrypt key (encrypt key plain-text)) plain-text))))

(display (encrypt "" "AAAAAAAAAA")) (newline)
(display (encrypt "FOO" "AAAAAAAAAAAAAAA")) (newline)
(display (encrypt "CRYPTONOMICON" "SOLITAIRE")) (newline)

(sol-test)

EXKYI ZSGEH
ITHZU JIWGR FARMW
KIRAK SFJAN