fork(1) download
copy 
  1. ; hill cipher
  2.  
  3. (define (make-matrix rows columns . value)
  4.   (do ((m (make-vector rows)) (i 0 (+ i 1)))
  5.       ((= i rows) m)
  6.     (if (null? value)
  7.         (vector-set! m i (make-vector columns))
  8.         (vector-set! m i (make-vector columns (car value))))))
  9.  
  10. (define (matrix-rows x) (vector-length x))
  11.  
  12. (define (matrix-cols x) (vector-length (vector-ref x 0)))
  13.  
  14. (define (matrix-ref m i j) (vector-ref (vector-ref m i) j))
  15.  
  16. (define (matrix-set! m i j x) (vector-set! (vector-ref m i) j x))
  17.  
  18. (define-syntax for
  19.   (syntax-rules ()
  20.     ((for (var first past step) body ...)
  21.       (let ((ge? (if (< first past) >= <=)))
  22.         (do ((var first (+ var step)))
  23.             ((ge? var past))
  24.           body ...)))
  25.     ((for (var first past) body ...)
  26.       (let* ((f first) (p past) (s (if (< first past) 1 -1)))
  27.         (for (var f p s) body ...)))
  28.     ((for (var past) body ...)
  29.       (let* ((p past)) (for (var 0 p) body ...)))))
  30.  
  31. (define (matrix-add a b)
  32.   (let ((ar (matrix-rows a)) (ac (matrix-cols a))
  33.         (br (matrix-rows b)) (bc (matrix-cols b)))
  34.     (if (or (not (= ar br)) (not (= ac bc)))
  35.         (error 'matrix-add "incompatible matrices")
  36.         (let ((c (make-matrix ar ac)))
  37.           (for (i ar)
  38.             (for (j ac)
  39.               (matrix-set! c i j
  40.                 (+ (matrix-ref a i j)
  41.                    (matrix-ref b i j)))))
  42.           c))))
  43.  
  44. (define (matrix-scalar-multiply n a)
  45.   (let* ((ar (matrix-rows a))
  46.          (ac (matrix-cols a))
  47.          (c (make-matrix ar ac)))
  48.     (for (i ar)
  49.       (for (j ac)
  50.         (matrix-set! c i j
  51.           (* n (matrix-ref a i j)))))
  52.     c))
  53.  
  54. (define (matrix-multiply a b)
  55.   (let ((ar (matrix-rows a)) (ac (matrix-cols a))
  56.         (br (matrix-rows b)) (bc (matrix-cols b)))
  57.     (if (not (= ac br))
  58.         (error 'matrix-multiply "incompatible matrices")
  59.         (let ((c (make-matrix ar bc 0)))
  60.           (for (i ar)
  61.             (for (j bc)
  62.               (for (k ac)
  63.                 (matrix-set! c i j
  64.                   (+ (matrix-ref c i j)
  65.                      (* (matrix-ref a i k)
  66.                         (matrix-ref b k j)))))))
  67.           c))))
  68.  
  69. (define (matrix-transpose a)
  70.   (let* ((ar (matrix-rows a))
  71.          (ac (matrix-cols a))
  72.          (c (make-matrix ac ar)))
  73.     (for (i ar)
  74.       (for (j ac)
  75.         (matrix-set! c j i
  76.           (matrix-ref a i j))))
  77.     c))
  78.  
  79. (define (sub-matrix a i j)
  80.   (let ((r (matrix-rows a)) (c (matrix-cols a)))
  81.     (let ((m (make-matrix (- r 1) (- c 1))) (new-i -1))
  82.       (for (old-i c)
  83.         (when (not (= old-i i))
  84.           (set! new-i (+ new-i 1))
  85.           (let ((new-j -1))
  86.             (for (old-j r)
  87.               (when (not (= old-j j))
  88.                 (set! new-j (+ new-j 1))
  89.                 (matrix-set! m new-i new-j
  90.                   (matrix-ref a old-i old-j)))))))
  91.       m)))
  92.  
  93. (define (matrix-determinant a) ; assume a is square
  94.   (let ((n (matrix-rows a)))
  95.     (if (= n 2)
  96.         (- (* (matrix-ref a 0 0) (matrix-ref a 1 1))
  97.            (* (matrix-ref a 1 0) (matrix-ref a 0 1)))
  98.         (let loop ((j 0) (k 1) (d 0))
  99.           (if (= j n) d
  100.             (loop (+ j 1) (* k -1)
  101.                   (+ d (* k (matrix-ref a 0 j)
  102.                           (matrix-determinant
  103.                             (sub-matrix a 0 j))))))))))
  104.  
  105. (define (matrix-cofactors a) ; assume a is square
  106.   (let* ((n (matrix-rows a)) (cof (make-matrix n n)))
  107.     (if (= n 2)
  108.         (for (i n)
  109.           (for (j n)
  110.             (matrix-set! cof i j
  111.               (* (expt -1 (+ i j))
  112.                  (matrix-ref a (- 1 i) (- 1 j))))))
  113.         (for (i n)
  114.           (for (j n)
  115.             (matrix-set! cof i j
  116.               (* (expt -1 (+ i j))
  117.                  (matrix-determinant (sub-matrix a i j)))))))
  118.     cof))
  119.  
  120. (define (matrix-adjugate a)
  121.   (matrix-transpose (matrix-cofactors a)))
  122.  
  123. (define (matrix-inverse a)
  124.   (matrix-scalar-multiply
  125.     (/ (matrix-determinant a))
  126.     (matrix-adjugate a)))
  127.  
  128. (define (inverse x m) ; inverse of x (mod m)
  129.   (let loop ((x x) (a 0) (b m) (u 1))
  130.     (if (zero? x)
  131.         (if (= b 1) (modulo a m) 0)
  132.         (let ((q (quotient b x)))
  133.           (loop (modulo b x) u x
  134.                 (modulo (- a (* q u)) m))))))
  135.  
  136. (define (matrix-map f a)
  137.   (let ((r (matrix-rows a))
  138.         (c (matrix-cols a)))
  139.     (let ((b (make-matrix r c)))
  140.       (for (i r)
  141.         (for (j c)
  142.           (matrix-set! b i j
  143.             (f (matrix-ref a i j)))))
  144.       b)))
  145.  
  146. (define (matrix-multiply-modulo a b m)
  147.   (define (modm n) (modulo n m))
  148.   (matrix-map modm (matrix-multiply a b)))
  149.  
  150. (define (matrix-inverse-modulo a m)
  151.   (define (modm n) (modulo n m))
  152.   (matrix-map modm
  153.     (matrix-scalar-multiply
  154.       (inverse (modulo (matrix-determinant a) m) m)
  155.       (matrix-transpose (matrix-cofactors a)))))
  156.  
  157. (define (c->i c) (- (char->integer (char-upcase c)) 65))
  158.  
  159. (define (i->c i) (integer->char (+ i 65)))
  160.  
  161. (define (string->matrix str blocksize)
  162.   (let* ((len (string-length str))
  163.          (rows (ceiling (/ len blocksize)))
  164.          (m (make-matrix rows blocksize #\Z)))
  165.     (for (k len)
  166.       (let ((i (quotient k blocksize))
  167.             (j (remainder k blocksize)))
  168.         (matrix-set! m i j (string-ref str k))))
  169.     m))
  170.  
  171. (define (matrix->string m)
  172.   (let ((r (matrix-rows m))
  173.         (c (matrix-cols m)))
  174.     (let ((cs (list)))
  175.       (for (i r)
  176.         (for (j c)
  177.           (set! cs (cons (matrix-ref m i j) cs))))
  178.       (list->string (reverse cs)))))
  179.  
  180. (define (encrypt str key blocksize modulus)
  181.   (matrix->string
  182.     (matrix-map i->c
  183.       (matrix-multiply-modulo
  184.         (matrix-map c->i (string->matrix str blocksize))
  185.         (matrix-map c->i (string->matrix key blocksize))
  186.         modulus))))
  187.  
  188. (define (decrypt str key blocksize modulus)
  189.   (matrix->string
  190.     (matrix-map i->c
  191.       (matrix-multiply-modulo
  192.         (matrix-map c->i (string->matrix str blocksize))
  193.         (matrix-inverse-modulo
  194.           (matrix-map c->i (string->matrix key blocksize))
  195.           modulus)
  196.         modulus))))
  197.  
  198. (display (encrypt "PROGRAMMINGPRAXIS" "GYBNQKURP" 3 26)) (newline)
  199. (display (decrypt "TMFXAUYSSONMQTYCVR" "GYBNQKURP" 3 26)) (newline)
Success #stdin #stdout 0.1s 43712KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
TMFXAUYSSONMQTYCVR
PROGRAMMINGPRAXISZ
https://ideone.com/Cf9pZq
language:
Scheme (guile 2.2.4)
created:
6 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!