-
+ 1BA7F252F6402D72569874D25F59F15992D844E16B678C5CEDD6F0A837065E8BD5238A9FD7F2977B927E8093CD0E915BF2FE395C211C8B11565FE49C43F46A3D
esthlos-v/src/keccak/src/cl-keccak.lisp
(0 . 0)(1 . 284)
132 (in-package "CL-KECCAK")
133
134
135 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
136 ;; magic numbers
137
138 (defconstant +row-size+ 5)
139 (defconstant +column-size+ 5)
140 (defconstant +lane-size+ (expt 2 +keccak_L+))
141 (defconstant +keccak-width+ (* +row-size+ +column-size+ +lane-size+))
142 (defconstant +round-quantity+ (+ 12 (* 2 +keccak_L+)))
143
144
145 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
146 ;; lanes
147
148 ;; definition of a lane
149 (deftype lane () `(simple-bit-vector ,+lane-size+))
150
151 ;; instantiation of lanes
152 (defun make-lane ()
153 (make-sequence 'lane +lane-size+ :initial-element 0))
154
155 ;; copy a lane into a new memory location
156 (defun copy-lane (lane)
157 (make-array `(,+lane-size+) :element-type 'bit
158 :initial-contents lane))
159
160 ;; basic operations on lanes
161 (defun lane-and (a b)
162 (declare (type lane a b))
163 (bit-and a b))
164
165 (defun lane-xor (a b)
166 (declare (type lane a b))
167 (bit-xor a b))
168
169 (defun lane-not (a)
170 (declare (type lane a))
171 (bit-not a))
172
173 (defun lane-rot (a n)
174 (let* ((rtn (make-lane)))
175 (dotimes (z +lane-size+)
176 (setf (aref rtn (mod (+ z n) +lane-size+))
177 (aref a z)))
178 rtn))
179
180
181 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
182 ;; magic lanes
183
184 (defconstant +round-constants+
185 (let ((magic
186 '(#*1000000000000000000000000000000000000000000000000000000000000000
187 #*0100000100000001000000000000000000000000000000000000000000000000
188 #*0101000100000001000000000000000000000000000000000000000000000001
189 #*0000000000000001000000000000000100000000000000000000000000000001
190 #*1101000100000001000000000000000000000000000000000000000000000000
191 #*1000000000000000000000000000000100000000000000000000000000000000
192 #*1000000100000001000000000000000100000000000000000000000000000001
193 #*1001000000000001000000000000000000000000000000000000000000000001
194 #*0101000100000000000000000000000000000000000000000000000000000000
195 #*0001000100000000000000000000000000000000000000000000000000000000
196 #*1001000000000001000000000000000100000000000000000000000000000000
197 #*0101000000000000000000000000000100000000000000000000000000000000
198 #*1101000100000001000000000000000100000000000000000000000000000000
199 #*1101000100000000000000000000000000000000000000000000000000000001
200 #*1001000100000001000000000000000000000000000000000000000000000001
201 #*1100000000000001000000000000000000000000000000000000000000000001
202 #*0100000000000001000000000000000000000000000000000000000000000001
203 #*0000000100000000000000000000000000000000000000000000000000000001
204 #*0101000000000001000000000000000000000000000000000000000000000000
205 #*0101000000000000000000000000000100000000000000000000000000000001
206 #*1000000100000001000000000000000100000000000000000000000000000001
207 #*0000000100000001000000000000000000000000000000000000000000000001
208 #*1000000000000000000000000000000100000000000000000000000000000000
209 #*0001000000000001000000000000000100000000000000000000000000000001)))
210 (make-array '(24)
211 :element-type 'lane
212 :initial-contents
213 (mapcar #'(lambda (x) (subseq x 0 +lane-size+))
214 magic))))
215
216
217 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
218 ;; states
219
220 ;; definition of a keccak state
221 (deftype state () `(array lane (,+row-size+ ,+column-size+)))
222
223 ;; instantiation of states
224 (defun make-state ()
225 (make-array `(,+row-size+ ,+column-size+)
226 :element-type 'lane
227 :initial-element (make-lane)))
228
229 ;; accessing the lanes of a state
230 (defun lane (a x y)
231 (declare (type state a)
232 (type fixnum x y))
233 (aref a (mod x +row-size+) (mod y +column-size+)))
234
235 ;; mutating the lanes of a state
236 (defmethod set-lane (a x y L)
237 (setf (aref a (mod x +row-size+) (mod y +column-size+))
238 L))
239
240 (defsetf lane set-lane)
241
242 ;; a macro for modifying and returning a state
243 (defmacro with-return-state (s &rest body)
244 `(let ((,(first s) (if (= ,(length s) 2)
245 (copy-state ,(second s))
246 (make-state))))
247 (progn ,@body)
248 ,(first s)))
249
250 ;; a macro for traversing the lanes of a state in the
251 ;; standard order (x,y) = (0,0), (1,0), (2,0), ...
252 (defmacro while-traversing-state (vars &body body)
253 `(dotimes (,(second vars) +column-size+)
254 (dotimes (,(first vars) +row-size+)
255 ,@body)))
256
257 ;; copy a state into a new memory location
258 (defun copy-state (state)
259 (let ((s (make-array `(,+row-size+ ,+column-size+)
260 :initial-element (make-lane)
261 :element-type 'lane)))
262 (dotimes (x +row-size+)
263 (dotimes (y +column-size+)
264 (setf (lane s x y)
265 (copy-lane (lane state x y)))))
266 s))
267
268 ;; transform a state into a single bit vector, concatenating
269 ;; the lanes in the standard order
270 (defun state-linearize (state)
271 (let ((r '()))
272 (with-return-state (s state)
273 (while-traversing-state (x y)
274 (push (lane s x y) r)))
275 (bit-vector-concatenate (nreverse r))))
276
277 ;; transform a bit vector into a state, filling the
278 ;; lanes in the standard order
279 (defun state-unlinearize (linearized-state)
280 (let ((chunked-state (bit-chunk linearized-state
281 +lane-size+)))
282 (with-return-state (s)
283 (while-traversing-state (x y)
284 (setf (lane s x y) (pop chunked-state))))))
285
286 (defun state-xor (state bit-vector)
287 (state-unlinearize (bit-xor (state-linearize state)
288 (bit-pad-right bit-vector
289 +keccak-width+))))
290
291
292 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
293 ;; keccak round operations
294
295 (defun theta (a)
296 (with-return-state (b)
297 (let* ((c (make-sequence '(vector lane) +row-size+
298 :initial-element (make-lane)))
299 (d (make-sequence '(vector lane) +row-size+
300 :initial-element (make-lane))))
301 (dotimes (x +row-size+)
302 (setf (aref c x)
303 (lane a x 0))
304 (loop for y from 1 below +column-size+
305 do (setf (aref c x)
306 (lane-xor (aref c x)
307 (lane a x y)))))
308 (dotimes (x +row-size+)
309 (setf (aref d x)
310 (lane-xor (aref c (mod (- x 1) +row-size+))
311 (lane-rot (aref c (mod (+ x 1) +row-size+))
312 1)))
313 (dotimes (y +column-size+)
314 (setf (lane b x y)
315 (lane-xor (lane a x y)
316 (aref d x))))))))
317
318 (defun rho (a)
319 (with-return-state (b)
320 (setf (lane b 0 0) (lane a 0 0))
321 (let ((x 1) (y 0))
322 (dotimes (q 24)
323 (setf (lane b x y)
324 (lane-rot (lane a x y)
325 (/ (* (+ q 1)
326 (+ q 2))
327 2)))
328 (psetq x y
329 y (+ (* 2 x)
330 (* 3 y)))))))
331
332 (defun k-pi (a)
333 (with-return-state (b)
334 (dotimes (x +row-size+)
335 (dotimes (y +column-size+)
336 (setf (lane b y (+ (* 2 x)
337 (* 3 y)))
338 (lane a x y))))))
339
340 (defun chi (a)
341 (with-return-state (b)
342 (dotimes (x +row-size+)
343 (dotimes (y +column-size+)
344 (setf (lane b x y)
345 (lane-xor (lane a x y)
346 (lane-and (lane-not (lane a (+ x 1) y))
347 (lane a (+ x 2) y))))))))
348
349 (defun iota (r a)
350 (with-return-state (b a)
351 (setf (lane b 0 0)
352 (lane-xor (lane b 0 0)
353 (aref +round-constants+ r)))))
354
355 (defun keccak-permute (a)
356 (with-return-state (b a)
357 (dotimes (r +round-quantity+)
358 (setq b (iota r (chi (k-pi (rho (theta b)))))))))
359
360
361 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
362 ;; sponge
363
364 (defun keccak-pad (bit-vector bitrate)
365 (labels ((remaining-space (bit-vector bitrate)
366 (abs (nth-value 1 (ceiling (+ 2 (length bit-vector))
367 bitrate)))))
368 (bit-vector-concatenate (list
369 bit-vector
370 #*1
371 (make-sequence 'simple-bit-vector
372 (remaining-space bit-vector
373 bitrate))
374 #*1))))
375
376 (defun keccak-absorb (bit-vector bitrate)
377 (assert (< bitrate +keccak-width+))
378 (with-return-state (s)
379 (dolist (c (bit-chunk (keccak-pad bit-vector bitrate) bitrate))
380 (setq s (state-xor s c))
381 (setq s (keccak-permute s)))))
382
383 (defun keccak-squeeze (state bitrate output-bits)
384 (assert (< bitrate +keccak-width+))
385 (let ((rtn '()))
386 (do ((remaining-bits output-bits (- remaining-bits
387 bitrate)))
388 ((> bitrate remaining-bits)
389 (push (subseq (state-linearize state) 0 remaining-bits)
390 rtn))
391 (push (subseq (state-linearize state) 0 bitrate)
392 rtn)
393 (setq state (keccak-permute state)))
394 (bit-vector-concatenate (nreverse rtn))))
395
396 (defun keccak-sponge (input-bit-vector bitrate output-bits)
397 (keccak-squeeze (keccak-absorb input-bit-vector
398 bitrate)
399 bitrate
400 output-bits))
401
402 (defun keccak-hash-file (filepath bitrate output-bits)
403 (bit-vector-to-hex (keccak-sponge (file-to-bit-vector filepath)
404 bitrate
405 output-bits)))
406
407 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
408 ;; for use as an executable
409
410 (defun main ()
411 (let ((args #+sbcl (cdr sb-ext:*posix-argv*)
412 #+ccl (cdr ccl:*command-line-argument-list*)))
413 (princ (string-downcase (keccak-hash-file (first args)
414 +bitrate+
415 +output-bits+)))))