fork(1) download
  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
stdin
Standard input is empty
stdout
TMFXAUYSSONMQTYCVR
PROGRAMMINGPRAXISZ