[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Sep 1:
; data encryption standard

(define (vector-map proc . vecs)
  (define (elt i)
    (lambda (vec)
      (vector-ref vec i)))
  (let* ((len (vector-length (car vecs)))
         (result (make-vector len)))
    (do ((i 0 (+ i 1))) ((= i len) result)
      (vector-set! result i
        (apply proc (map (elt i) vecs))))))

(define (vector-permute rule vec)
  (let* ((len (vector-length rule))
         (result (make-vector len)))
    (do ((i 0 (+ i 1))) ((= i len) result)
      (vector-set! result i
        (vector-ref vec (vector-ref rule i))))))

(define (vector-cycle shift vec)
  ; positive => left, negative => right
  (let* ((len (vector-length vec))
         (result (make-vector len)))
    (do ((i 0 (+ i 1))) ((= i len) result)
      (let ((j (modulo (+ i shift) len)))
        (vector-set! result i
          (vector-ref vec j))))))

(define (vector-slice vec start len)
  (let ((result (make-vector len)))
    (do ((i 0 (+ i 1))) ((= i len) result)
      (vector-set! result i
        (vector-ref vec (+ i start))))))

(define (vector-slice-by n vec)
  (let* ((len (vector-length vec)))
    (let loop ((k 0) (result '()))
      (if (= k len) (reverse result)
        (loop (+ k n) (cons (vector-slice vec k n) result))))))

(define (vector-append . vecs)
  (let* ((len (apply + (map vector-length vecs)))
         (result (make-vector len)))
    (let loop ((i 0) (j 0) (vecs vecs))
      (cond ((null? vecs) result)
            ((= (vector-length (car vecs)) j)
              (loop i 0 (cdr vecs)))
            (else (vector-set! result i
                    (vector-ref (car vecs) j))
                  (loop (+ i 1) (+ j 1) vecs))))))

(define (vector-xor vec1 vec2)
  (define (xor a b) (if (= a b) 0 1))
  (vector-map xor vec1 vec2))

(define (undigits ds . args)
  (let ((b (if (null? args) 10 (car args))))
    (let loop ((ds ds) (n 0))
      (if (null? ds) n
          (loop (cdr ds) (+ (* n b) (car ds)))))))

(define (n->bits n)
  (let ((bv (list->vector '((0 0 0 0) (0 0 0 1) (0 0 1 0) (0 0 1 1)
        (0 1 0 0) (0 1 0 1) (0 1 1 0) (0 1 1 1) (1 0 0 0) (1 0 0 1)
        (1 0 1 0) (1 0 1 1) (1 1 0 0) (1 1 0 1) (1 1 1 0) (1 1 1 1)))))
    (vector-ref bv n)))

(define (char->bits c)
  (n->bits (- (char->integer (char-upcase c)) (if (char-numeric? c) 48 55))))

(define (bits->char bits)
  (let ((n (undigits (vector->list bits) 2)))
    (integer->char (+ n (if (< n 10) 48 55)))))

(define (hex->bits hex)
    (list->vector (apply append (map char->bits (string->list hex)))))

(define (bits->hex vec)
  (list->string (map bits->char (vector-slice-by 4 vec))))

(define (ascii->bits txt)
  (list->vector
    (apply append
      (map (lambda (c)
             (let ((x (char->integer c)))
               (append (n->bits (quotient x 16))
                       (n->bits (modulo x 16)))))
           (string->list txt)))))

(define (bits->ascii bits)
  (list->string (map integer->char
    (map (lambda (v) (undigits (vector->list v) 2))
         (vector-slice-by 8 bits)))))

(define (check-parity? key)
  (let loop ((ks (vector-slice-by 8 key)))
    (cond ((null? ks) #t)
          ((even? (apply + (vector->list (car ks)))) #f)
          (else (loop (cdr ks))))))

(define (pc1 key)
  (let ((rule #(
           57 49 41 33 25 17  9  1 58 50 42 34 26 18
           10  2 59 51 43 35 27 19 11  3 60 52 44 36
           63 55 47 39 31 23 15  7 62 54 46 38 30 22
           14  6 61 53 45 37 29 21 13  5 28 20 12  4)))
    (vector-permute (vector-map sub1 rule) key)))

(define (ls i key)
  (let ((rule #(1 1 2 2 2 2 2 2 1 2 2 2 2 2 2 1)))
    (vector-cycle (vector-ref rule i) key)))

(define (pc2 key)
  (let ((rule #(
           14 17 11 24  1  5  3 28 15  6 21 10
           23 19 12  4 26  8 16  7 27 20 13  2
           41 52 31 37 47 55 30 40 51 45 33 48
           44 49 39 56 34 53 46 42 50 36 29 32)))
    (vector-permute (vector-map sub1 rule) key)))

(define (key-schedule key)
  (let ((c (make-vector 17 #f))
        (d (make-vector 17 #f))
        (k (make-vector 17 #f))
        (c0d0 (pc1 key)))
    (vector-set! c 0 (vector-slice c0d0 0 28))
    (vector-set! d 0 (vector-slice c0d0 28 28))
    (do ((i 1 (+ i 1))) ((< 16 i) k)
      (vector-set! c i (ls (- i 1) (vector-ref c (- i 1))))
      (vector-set! d i (ls (- i 1) (vector-ref d (- i 1))))
      (vector-set! k i (pc2 (vector-append
                            (vector-ref c i)
                            (vector-ref d i)))))))

(define (ip data)
  (let ((rule #(
           58 50 42 34 26 18 10  2 60 52 44 36 28 20 12  4
           62 54 46 38 30 22 14  6 64 56 48 40 32 24 16  8
           57 49 41 33 25 17  9  1 59 51 43 35 27 19 11  3
           61 53 45 37 29 21 13  5 63 55 47 39 31 23 15  7)))
    (vector-permute (vector-map sub1 rule) data)))

(define (e data)
  (let ((rule #(
           32  1  2  3  4  5  4  5  6  7  8  9
            8  9 10 11 12 13 12 13 14 15 16 17
           16 17 18 19 20 21 20 21 22 23 24 25
           24 25 26 27 28 29 28 29 30 31 32  1)))
    (vector-permute (vector-map sub1 rule) data)))

(define (s vec)
  (define (b->s j)
    (let* ((sbox #(
              #(14  4 13  1  2 15 11  8  3 10  6 12  5  9  0  7 ; 1
                 0 15  7  4 14  2 13  1 10  6 12 11  9  5  3  8
                 4  1 14  8 13  6  2 11 15 12  9  7  3 10  5  0
                15 12  8  2  4  9  1  7  5 11  3 14 10  0  6 13)
              #(15  1  8 14  6 11  3  4  9  7  2 13 12  0  5 10 ; 2
                 3 13  4  7 15  2  8 14 12  0  1 10  6  9 11  5
                 0 14  7 11 10  4 13  1  5  8 12  6  9  3  2 15
                13  8 10  1  3 15  4  2 11  6  7 12  0  5 14  9)
              #(10  0  9 14  6  3 15  5  1 13 12  7 11  4  2  8 ; 3
                13  7  0  9  3  4  6 10  2  8  5 14 12 11 15  1
                13  6  4  9  8 15  3  0 11  1  2 12  5 10 14  7
                 1 10 13  0  6  9  8  7  4 15 14  3 11  5  2 12)
              #( 7 13 14  3  0  6  9 10  1  2  8  5 11 12  4 15 ; 4
                13  8 11  5  6 15  0  3  4  7  2 12  1 10 14  9
                10  6  9  0 12 11  7 13 15  1  3 14  5  2  8  4
                 3 15  0  6 10  1 13  8  9  4  5 11 12  7  2 14)
              #( 2 12  4  1  7 10 11  6  8  5  3 15 13  0 14  9 ; 5
                14 11  2 12  4  7 13  1  5  0 15 10  3  9  8  6
                 4  2  1 11 10 13  7  8 15  9 12  5  6  3  0 14
                11  8 12  7  1 14  2 13  6 15  0  9 10  4  5  3)
              #(12  1 10 15  9  2  6  8  0 13  3  4 14  7  5 11 ; 6
                10 15  4  2  7 12  9  5  6  1 13 14  0 11  3  8
                 9 14 15  5  2  8 12  3  7  0  4 10  1 13 11  6
                 4  3  2 12  9  5 15 10 11 14  1  7  6  0  8 13)
              #( 4 11  2 14 15  0  8 13  3 12  9  7  5 10  6  1 ; 7
                13  0 11  7  4  9  1 10 14  3  5 12  2 15  8  6
                 1  4 11 13 12  3  7 14 10 15  6  8  0  5  9  2
                 6 11 13  8  1  4 10  7  9  5  0 15 14  2  3 12)
              #(13  2  8  4  6 15 11  1 10  9  3 14  5  0 12  7 ; 8
                 1 15 13  8 10  3  7  4 12  5  6 11  0 14  9  2
                 7 11  4  1  9 12 14  2  0  6 10 13 15  3  5  8
                 2  1 14  7  4 10  8 13 15 12  9  0  3  5  6 11)))
           (m1 (vector-ref vec (* j 6)))
           (m2 (vector-ref vec (+ (* j 6) 5)))
           (m (undigits (list m1 m2) 2))
           (n (undigits (vector->list (vector-slice vec (+ (* j 6) 1) 4)) 2)))
      (vector-ref (vector-ref sbox j) (+ (* m 16) n))))
  (let loop ((j 0) (result '()))
    (if (= j 8)
        (list->vector (apply append (map n->bits (reverse result))))
        (loop (+ j 1) (cons (b->s j) result)))))

(define (p data)
  (let ((rule  #(
           16  7 20 21 29 12 28 17  1 15 23 26  5 18 31 10
            2  8 24 14 32 27  3  9 19 13 30  6 22 11  4 25)))
    (vector-permute (vector-map sub1 rule) data)))

(define (fp data)
  (let ((rule  #(
           40  8 48 16 56 24 64 32 39  7 47 15 55 23 63 31
           38  6 46 14 54 22 62 30 37  5 45 13 53 21 61 29
           36  4 44 12 52 20 60 28 35  3 43 11 51 19 59 27
           34  2 42 10 50 18 58 26 33  1 41  9 49 17 57 25)))
    (vector-permute (vector-map sub1 rule) data)))

(define (f x k) (p (s (vector-xor (e x) k))))

(define (encipher ks block)
  (let ((l (make-vector 17 #f)) (r (make-vector 17 #f)) (l0r0 (ip block)))
    (vector-set! l 0 (vector-slice l0r0 0 32))
    (vector-set! r 0 (vector-slice l0r0 32 32))
    (do ((i 1 (+ i 1)))
        ((< 16 i) (fp (vector-append (vector-ref r 16) (vector-ref l 16))))
      (vector-set! l i (vector-ref r (- i 1)))
      (vector-set! r i
        (vector-xor (vector-ref l (- i 1))
          (f (vector-ref r (- i 1)) (vector-ref ks i)))))))

(define (decipher ks block)
  (let ((l (make-vector 17 #f)) (r (make-vector 17 #f)) (r16l16 (ip block)))
    (vector-set! r 16 (vector-slice r16l16 0 32))
    (vector-set! l 16 (vector-slice r16l16 32 32))
    (do ((i 16 (- i 1)))
        ((= i 0) (fp (vector-append (vector-ref l 0) (vector-ref r 0))))
      (vector-set! r (- i 1) (vector-ref l i))
      (vector-set! l (- i 1)
        (vector-xor (vector-ref r i)
          (f (vector-ref l i) (vector-ref ks i)))))))

; > (bits->hex
;     (encipher
;       (key-schedule (hex->bits "0123456789ABCDEF"))
;       (ascii->bits "ProgPrax")))
; "CC99EA46B16E2890"
; > (bits->ascii
;     (decipher
;       (key-schedule (hex->bits "0123456789ABCDEF"))
;       (hex->bits "CC99EA46B16E2890")))
; "ProgPrax"

(define (pad txt)
  (let ((c0 (integer->char 0)) (s128 (string (integer->char 128))))
    (string-append txt s128 (make-string (- 7 (modulo (string-length txt) 8)) c0))))

(define (unpad txt)
  (do ((i (- (string-length txt) 1) (- i 1)))
      ((= (char->integer (string-ref txt i)) 128) (substring txt 0 i))))

(define (read8 port)
  (let loop ((n 7) (c (read-char port)) (cs '()))
    (cond ((eof-object? c) (if (null? cs) c (list->string (reverse cs))))
          ((zero? n) (list->string (reverse (cons c cs))))
          (else (loop (- n 1) (read-char port) (cons c cs))))))

(define (ecb-encipher encipher ks port)
  (define (encode txt) (encipher ks (ascii->bits txt)))
  (let loop ((txt (read8 port)))
    (cond ((eof-object? txt) (display (bits->ascii (encode (pad "")))))
          ((< (string-length txt) 8) (display (bits->ascii (encode (pad txt)))))
          (else (display (bits->ascii (encode txt))) (loop (read8 port))))))

(define (ecb-decipher decipher ks port)
  (define (decode txt) (decipher ks (ascii->bits txt)))
  (let ((txt (read8 port)))
    (if (eof-object? txt) (error 'ecb-decipher "no data")
      (let loop ((txt txt) (next (read8 port)))
        (if (eof-object? next)
            (display (unpad (bits->ascii (decode txt))))
            (begin (display (bits->ascii (decode txt)))
                   (loop next (read8 port))))))))

; > (with-input-from-string "Programming Praxis"
;     (lambda ()
;       (ecb-encipher
;         encipher
;         (key-schedule (hex->bits "0123456789ABCDEF"))
;         (current-input-port))))
; asdfasdfasdfasdfasdfasdf
; > (with-input-from-string "asdfasdfasdfasdfasdfasdf"
;     (lambda ()
;       (ecb-decipher
;         decipher
;         (key-schedule (hex->bits "0123456789ABCDEF"))
;         (current-input-port))))
; Programming Praxis

(define (cbc-encipher encipher iv ks port)
  (define (encode prev txt) (encipher ks (vector-xor (ascii->bits txt) prev)))
  (let loop ((prev iv) (txt (read8 port)))
    (cond ((eof-object? txt) (display (bits->ascii (encode prev (pad "")))))
          ((< (string-length txt) 8) (display (bits->ascii (encode prev (pad txt)))))
          (else (let ((next (encode prev txt)))
                  (display (bits->ascii next))
                  (loop next (read8 port)))))))

(define (cbc-decipher decipher iv ks port)
  (define (decode prev txt) (vector-xor (decipher ks (ascii->bits txt)) prev))
  (let loop ((prev iv) (txt (read8 port)))
    (if (eof-object? (peek-char port))
        (display (unpad (bits->ascii (decode prev txt))))
        (let ((next (decode prev txt)))
          (display (bits->ascii next))
          (loop (ascii->bits txt) (read8 port))))))

; > (with-input-from-string "Programming Praxis"
;     (lambda ()
;       (cbc-encipher
;         encipher
;         (ascii->bits "ProgPrax")
;         (key-schedule (hex->bits "0123456789ABCDEF"))
;         (current-input-port))))
; asdfasdfasdfasdfasdfasdf
; > (with-input-from-string "asdfasdfasdfasdfasdfasdf"
;     (lambda ()
;       (cbc-decipher
;         decipher
;         (ascii->bits "ProgPrax")
;         (key-schedule (hex->bits "0123456789ABCDEF"))
;         (current-input-port))))
; Programming Praxis

(define (cfb-encipher encipher iv ks port)
  (define (encode prev txt) (vector-xor (encipher ks prev) (ascii->bits txt)))
  (let loop ((prev iv) (txt (read8 port)))
    (when (not (eof-object? txt))
      (let ((len (string-length txt)))
        (if (= len 8)
            (let ((next (encode prev txt)))
              (display (bits->ascii next))
              (loop next (read8 port)))
            (display (bits->ascii
              (vector-slice (encode prev (pad txt)) 0 (* 8 len)))))))))
     
(define (cfb-decipher encipher iv ks port)
  (define (encode prev txt) (vector-xor (encipher ks prev) (ascii->bits txt)))
  (let loop ((prev iv) (txt (read8 port)))
    (when (not (eof-object? txt))
      (let ((len (string-length txt)))
        (if (= len 8)
            (let ((next (encode prev txt)))
              (display (bits->ascii next))
              (loop (ascii->bits txt) (read8 port)))
            (display (bits->ascii
              (vector-slice (encode prev (pad txt)) 0 (* 8 len)))))))))

; > (with-input-from-string "Programming Praxis"
;     (lambda ()
;       (cfb-encipher
;         encipher
;         (ascii->bits "ProgPrax")
;         (key-schedule (hex->bits "0123456789ABCDEF"))
;         (current-input-port))))
; asdfasdfasdfasdfas
; > (with-input-from-string "asdfasdfasdfasdfas"
;     (lambda ()
;       (cfb-decipher
;         encipher
;         (ascii->bits "ProgPrax")
;         (key-schedule (hex->bits "0123456789ABCDEF"))
;         (current-input-port))))
; Programming Praxis

(define (ofb-encipher encipher iv ks port)
  (do ((txt (read8 port) (read8 port))
       (o (encipher ks iv) (encipher ks o)))
      ((eof-object? txt))
    (display (bits->ascii
      (if (= (string-length txt) 8)
          (vector-xor (ascii->bits txt) o)
          (let* ((bits (ascii->bits txt)) (len (vector-length bits)))
            (vector-xor bits (vector-slice o 0 len))))))))

(define ofb-decipher ofb-encipher)

; > (with-input-from-string "Programming Praxis"
;     (lambda ()
;       (ofb-encipher
;         encipher
;         (ascii->bits "ProgPrax")
;         (key-schedule (hex->bits "0123456789ABCDEF"))
;         (current-input-port))))
; asdfasdfasdfasdfas
; > (with-input-from-string "asdfasdfasdfasdfas"
;     (lambda ()
;       (ofb-decipher
;         encipher
;         (ascii->bits "ProgPrax")
;         (key-schedule (hex->bits "0123456789ABCDEF"))
;         (current-input-port))))
; Programming Praxis


Output:
No errors or program output.


Create a new paste based on this one


Comments: