[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/ryMtgPbD    [ raw code | fork ]

programmingpraxis - Scheme, pasted on Jun 9:
; steganography

(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 (mappend f . xss) (apply append (apply map f xss)))

(define (all? pred? xs)
  (cond ((null? xs) #t)
        ((pred? (car xs))
          (all? pred? (cdr xs)))
        (else #f)))

(define (make-list n x)
  (let loop ((n n) (xs '()))
    (if (zero? n) xs
      (loop (- n 1) (cons x xs)))))

(define (fold-input reader proc base . pof)
  (let* ((f? (and (pair? pof) (string? (car pof))))
         (p (cond (f? (open-input-file (car pof)))
                  ((pair? pof) (car pof))
                  (else (current-input-port)))))
    (let loop ((item (reader p)) (base base))
      (if (eof-object? item)
          (begin (if f? (close-input-port p)) base)
          (loop (reader p) (proc base item))))))

(define (read-line . port)
  (define (eat p c)
    (if (and (not (eof-object? (peek-char p)))
             (char=? (peek-char p) c))
        (read-char p)))
  (let ((p (if (null? port) (current-input-port) (car port))))
    (let loop ((c (read-char p)) (line '()))
      (cond ((eof-object? c) (if (null? line) c (list->string (reverse line))))
            ((char=? #\newline c) (eat p #\return) (list->string (reverse line)))
            ((char=? #\return c) (eat p #\newline) (list->string (reverse line)))
            (else (loop (read-char p) (cons c line)))))))

(define (filter-input reader pred?)
  (lambda args
    (let loop ((item (apply reader args)))
      (if (or (eof-object? item) (pred? item)) item
        (loop (apply reader args))))))

(define (string-index c str)
  (let loop ((ss (string->list str)) (k 0))
    (cond ((null? ss) #f)
          ((char=? (car ss) c) k)
          (else (loop (cdr ss) (+ k 1))))))

(define (string-split sep str)
  (define (f cs xs) (cons (list->string (reverse cs)) xs))
  (let loop ((ss (string->list str)) (cs '()) (xs '()))
    (cond ((null? ss) (reverse (if (null? cs) xs (f cs xs))))
          ((char=? (car ss) sep) (loop (cdr ss) '() (f cs xs)))
          (else (loop (cdr ss) (cons (car ss) cs) xs)))))

(define (string-join sep ss)
  (define (f s ss)
    (string-append s (string sep) ss))
  (define (join ss)
    (if (null? (cdr ss)) (car ss)
      (f (car ss) (join (cdr ss)))))
  (if (null? ss) "" (join ss)))

(define (swap f) (lambda (x y) (f y x)))

(define (digits n . args)
  (let ((b (if (null? args) 10 (car args))))
    (let loop ((n n) (d '()))
      (if (zero? n) d
          (loop (quotient n b)
                (cons (modulo n b) d))))))

(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 (make-key pass-phrase)
  (let ((digits '((#\a . #\1) (#\b . #\2) (#\c . #\3)
         (#\d . #\4) (#\e . #\5) (#\f . #\6) (#\g .
         #\7) (#\h . #\8) (#\i . #\9) (#\j . #\0))))
    (let loop ((pass (string->list (string-append
                 pass-phrase "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
                 "abcdefghijklmnopqrstuvwxyz" ". ")))
               (key '()))
      (cond ((null? pass) (list->string (reverse key)))
            ((member (car pass) key) (loop (cdr pass) key))
            ((member (car pass) '(#\. #\space))
              (loop (cdr pass) (cons (car pass) key)))
            ((char-alphabetic? (car pass))
             (if (char<=? #\a (car pass) #\j)
                 (loop (cdr pass)
                       (cons (cdr (assoc (car pass) digits))
                             (cons (car pass) key)))
                 (loop (cdr pass) (cons (car pass) key))))
            (else (loop (cdr pass) key))))))

(define (split str)
  (define (clean str)
    (filter (lambda (c)
              (member c (string->list (string-append
                "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
                "abcdefghijklmnopqrstuvwxyz"
                "0123456789. "))))
            (string->list str)))
  (let loop ((cs (clean str)) (zs '()))
    (cond ((null? cs) (reverse zs))
          ((null? (cdr cs))
            (reverse (cons (string (car cs) #\X) zs)))
          ((char=? (car cs) (cadr cs))
            (loop (cdr cs) (cons (string (car cs) #\X) zs)))
          (else (loop (cddr cs)
                      (cons (string (car cs) (cadr cs)) zs))))))

(define (encipher key plain-text)
  (define (p->c str)
    (let ((a (string-index (string-ref str 0) key))
          (b (string-index (string-ref str 1) key)))
      (cond ((= (quotient a 8) (quotient b 8)) ; same row
              (string (string-ref key (+ (* (quotient a 8) 8) (modulo (+ a 1) 8)))
                      (string-ref key (+ (* (quotient b 8) 8) (modulo (+ b 1) 8)))))
            ((= (modulo a 8) (modulo b 8)) ; same column
              (string (string-ref key (+ (* (modulo (+ (quotient a 8) 1) 8) 8) (modulo a 8)))
                      (string-ref key (+ (* (modulo (+ (quotient b 8) 1) 8) 8) (modulo b 8)))))
            (else (string (string-ref key (+ (* (quotient a 8) 8) (modulo b 8)))
                          (string-ref key (+ (* (quotient b 8) 8) (modulo a 8))))))))
  (apply string-append (map p->c (split plain-text))))

(define (decipher key cipher-text)
  (define (c->p str)
    (let ((a (string-index (string-ref str 0) key))
          (b (string-index (string-ref str 1) key)))
      (cond ((= (quotient a 8) (quotient b 8)) ; same row
              (string (string-ref key (+ (* (quotient a 8) 8) (modulo (- a 1) 8)))
                      (string-ref key (+ (* (quotient b 8) 8) (modulo (- b 1) 8)))))
            ((= (modulo a 8) (modulo b 8)) ; same column
              (string (string-ref key (+ (* (modulo (- (quotient a 8) 1) 8) 8) (modulo a 8)))
                      (string-ref key (+ (* (modulo (- (quotient b 8) 1) 8) 8) (modulo b 8)))))
            (else (string (string-ref key (+ (* (quotient a 8) 8) (modulo b 8)))
                          (string-ref key (+ (* (quotient b 8) 8) (modulo a 8))))))))
  (apply string-append (map c->p (split cipher-text))))

(define (valid? word)
  (and (all? char-alphabetic? (string->list word))
       (< (string-length word) 9)))

(define (read-dict file-name)
  (list->vector (fold-input (filter-input read-line valid?) (swap cons) '() file-name)))

(define dict (read-dict "moby.common"))

(define dict-len (vector-length dict))

(define alpha
  (map (lambda (c n)
         (let ((ds (digits n 2)))
           (cons c (append (make-list (- 6 (length ds)) 0) ds))))
       (string->list (string-append "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
         "abcdefghijklmnopqrstuvwxyz" "0123456789" ". "))
       (range 64)))

(define inverse-alpha
  (map (lambda (xs) (cons (cdr xs) (car xs))) alpha))

(define (get-word b)
  (case b
    ((0) (let ((w (vector-ref dict (randint dict-len))))
           (if (even? (string-length w)) w (get-word b))))
    ((1) (let ((w (vector-ref dict (randint dict-len))))
           (if (odd? (string-length w)) w (get-word b))))
    (else (error 'get-word "can't happen"))))

(define (hide str)
  (string-join #\space (map get-word
    (mappend (lambda (c) (cdr (assoc c alpha))) (string->list str)))))

(define (unhide str)
  (define (convert d) (if (even? d) 0 1))
  (let loop ((ds (map convert (map string-length (string-split #\space str)))) (cs '()))
    (if (null? ds) (apply string (reverse cs))
      (let ((c (cdr (assoc (take 6 ds) inverse-alpha))))
        (loop (drop 6 ds) (cons c cs))))))

(define key-20110606 (make-key (string-append "President Obama's"
  " visit to a Chrysler plant in Toledo, Ohio, on Friday was the"
  " culmination of a campaign to portray the auto bailouts as a"
  " brilliant success with no unpleasant side effects.")))
(display key-20110606) (newline

(define spam (hide (encipher key-20110606 "Programming Praxis")))
(display spam) (newline)

(display (decipher key-20110606 (unhide spam))) (newline)


Create a new paste based on this one


Comments: