raw
esthlos-v_keccak        1 (in-package "CL-KECCAK")
esthlos-v_keccak        2 
esthlos-v_keccak        3 
esthlos-v_keccak        4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
esthlos-v_keccak        5 ;; magic numbers
esthlos-v_keccak        6 
esthlos-v_keccak        7 (defconstant +row-size+ 5)
esthlos-v_keccak        8 (defconstant +column-size+ 5)
esthlos-v_keccak        9 (defconstant +lane-size+ (expt 2 +keccak_L+))
esthlos-v_keccak       10 (defconstant +keccak-width+ (* +row-size+ +column-size+ +lane-size+))
esthlos-v_keccak       11 (defconstant +round-quantity+ (+ 12 (* 2 +keccak_L+)))
esthlos-v_keccak       12 
esthlos-v_keccak       13 
esthlos-v_keccak       14 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
esthlos-v_keccak       15 ;; lanes
esthlos-v_keccak       16 
esthlos-v_keccak       17 ;; definition of a lane
esthlos-v_keccak       18 (deftype lane () `(simple-bit-vector ,+lane-size+))
esthlos-v_keccak       19 
esthlos-v_keccak       20 ;; instantiation of lanes
esthlos-v_keccak       21 (defun make-lane ()
esthlos-v_keccak       22   (make-sequence 'lane +lane-size+ :initial-element 0))
esthlos-v_keccak       23 
esthlos-v_keccak       24 ;; copy a lane into a new memory location
esthlos-v_keccak       25 (defun copy-lane (lane)
esthlos-v_keccak       26   (make-array `(,+lane-size+) :element-type 'bit
esthlos-v_keccak       27               :initial-contents lane))
esthlos-v_keccak       28 
esthlos-v_keccak       29 ;; basic operations on lanes
esthlos-v_keccak       30 (defun lane-and (a b)
esthlos-v_keccak       31   (declare (type lane a b))
esthlos-v_keccak       32   (bit-and a b))
esthlos-v_keccak       33 
esthlos-v_keccak       34 (defun lane-xor (a b)
esthlos-v_keccak       35   (declare (type lane a b))
esthlos-v_keccak       36   (bit-xor a b))
esthlos-v_keccak       37 
esthlos-v_keccak       38 (defun lane-not (a)
esthlos-v_keccak       39   (declare (type lane a))
esthlos-v_keccak       40   (bit-not a))
esthlos-v_keccak       41 
esthlos-v_keccak       42 (defun lane-rot (a n)
esthlos-v_keccak       43   (let* ((rtn (make-lane)))
esthlos-v_keccak       44     (dotimes (z +lane-size+)
esthlos-v_keccak       45       (setf (aref rtn (mod (+ z n) +lane-size+))
esthlos-v_keccak       46             (aref a z)))
esthlos-v_keccak       47     rtn))
esthlos-v_keccak       48 
esthlos-v_keccak       49 
esthlos-v_keccak       50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
esthlos-v_keccak       51 ;; magic lanes
esthlos-v_keccak       52 
esthlos-v_keccak       53 (defconstant +round-constants+
esthlos-v_keccak       54   (let ((magic
esthlos-v_keccak       55          '(#*1000000000000000000000000000000000000000000000000000000000000000
esthlos-v_keccak       56            #*0100000100000001000000000000000000000000000000000000000000000000
esthlos-v_keccak       57            #*0101000100000001000000000000000000000000000000000000000000000001
esthlos-v_keccak       58            #*0000000000000001000000000000000100000000000000000000000000000001
esthlos-v_keccak       59            #*1101000100000001000000000000000000000000000000000000000000000000
esthlos-v_keccak       60            #*1000000000000000000000000000000100000000000000000000000000000000
esthlos-v_keccak       61            #*1000000100000001000000000000000100000000000000000000000000000001
esthlos-v_keccak       62            #*1001000000000001000000000000000000000000000000000000000000000001
esthlos-v_keccak       63            #*0101000100000000000000000000000000000000000000000000000000000000
esthlos-v_keccak       64            #*0001000100000000000000000000000000000000000000000000000000000000
esthlos-v_keccak       65            #*1001000000000001000000000000000100000000000000000000000000000000
esthlos-v_keccak       66            #*0101000000000000000000000000000100000000000000000000000000000000
esthlos-v_keccak       67            #*1101000100000001000000000000000100000000000000000000000000000000
esthlos-v_keccak       68            #*1101000100000000000000000000000000000000000000000000000000000001
esthlos-v_keccak       69            #*1001000100000001000000000000000000000000000000000000000000000001
esthlos-v_keccak       70            #*1100000000000001000000000000000000000000000000000000000000000001
esthlos-v_keccak       71            #*0100000000000001000000000000000000000000000000000000000000000001
esthlos-v_keccak       72            #*0000000100000000000000000000000000000000000000000000000000000001
esthlos-v_keccak       73            #*0101000000000001000000000000000000000000000000000000000000000000
esthlos-v_keccak       74            #*0101000000000000000000000000000100000000000000000000000000000001
esthlos-v_keccak       75            #*1000000100000001000000000000000100000000000000000000000000000001
esthlos-v_keccak       76            #*0000000100000001000000000000000000000000000000000000000000000001
esthlos-v_keccak       77            #*1000000000000000000000000000000100000000000000000000000000000000
esthlos-v_keccak       78            #*0001000000000001000000000000000100000000000000000000000000000001)))
esthlos-v_keccak       79     (make-array '(24)
esthlos-v_keccak       80                 :element-type 'lane
esthlos-v_keccak       81                 :initial-contents
esthlos-v_keccak       82                 (mapcar #'(lambda (x) (subseq x 0 +lane-size+))
esthlos-v_keccak       83                         magic))))
esthlos-v_keccak       84 
esthlos-v_keccak       85 
esthlos-v_keccak       86 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
esthlos-v_keccak       87 ;; states
esthlos-v_keccak       88 
esthlos-v_keccak       89 ;; definition of a keccak state
esthlos-v_keccak       90 (deftype state () `(array lane (,+row-size+ ,+column-size+)))
esthlos-v_keccak       91 
esthlos-v_keccak       92 ;; instantiation of states
esthlos-v_keccak       93 (defun make-state ()
esthlos-v_keccak       94   (make-array `(,+row-size+ ,+column-size+)
esthlos-v_keccak       95               :element-type 'lane
esthlos-v_keccak       96               :initial-element (make-lane)))
esthlos-v_keccak       97 
esthlos-v_keccak       98 ;; accessing the lanes of a state
esthlos-v_keccak       99 (defun lane (a x y)
esthlos-v_keccak      100   (declare (type state a)
esthlos-v_keccak      101            (type fixnum x y))
esthlos-v_keccak      102   (aref a (mod x +row-size+) (mod y +column-size+)))
esthlos-v_keccak      103 
esthlos-v_keccak      104 ;; mutating the lanes of a state
esthlos-v_keccak      105 (defmethod set-lane (a x y L)
esthlos-v_keccak      106   (setf (aref a (mod x +row-size+) (mod y +column-size+))
esthlos-v_keccak      107         L))
esthlos-v_keccak      108 
esthlos-v_keccak      109 (defsetf lane set-lane)
esthlos-v_keccak      110 
esthlos-v_keccak      111 ;; a macro for modifying and returning a state
esthlos-v_keccak      112 (defmacro with-return-state (s &rest body)
esthlos-v_keccak      113   `(let ((,(first s) (if (= ,(length s) 2)
esthlos-v_keccak      114                          (copy-state ,(second s))
esthlos-v_keccak      115                          (make-state))))
esthlos-v_keccak      116      (progn ,@body)
esthlos-v_keccak      117      ,(first s)))
esthlos-v_keccak      118 
esthlos-v_keccak      119 ;; a macro for traversing the lanes of a state in the
esthlos-v_keccak      120 ;; standard order (x,y) = (0,0), (1,0), (2,0), ...
esthlos-v_keccak      121 (defmacro while-traversing-state (vars &body body)
esthlos-v_keccak      122   `(dotimes (,(second vars) +column-size+)
esthlos-v_keccak      123      (dotimes (,(first vars) +row-size+)
esthlos-v_keccak      124        ,@body)))
esthlos-v_keccak      125 
esthlos-v_keccak      126 ;; copy a state into a new memory location
esthlos-v_keccak      127 (defun copy-state (state)
esthlos-v_keccak      128   (let ((s (make-array `(,+row-size+ ,+column-size+)
esthlos-v_keccak      129                        :initial-element (make-lane)
esthlos-v_keccak      130                        :element-type 'lane)))
esthlos-v_keccak      131     (dotimes (x +row-size+)
esthlos-v_keccak      132       (dotimes (y +column-size+)
esthlos-v_keccak      133         (setf (lane s x y)
esthlos-v_keccak      134               (copy-lane (lane state x y)))))
esthlos-v_keccak      135     s))
esthlos-v_keccak      136 
esthlos-v_keccak      137 ;; transform a state into a single bit vector, concatenating
esthlos-v_keccak      138 ;; the lanes in the standard order
esthlos-v_keccak      139 (defun state-linearize (state)
esthlos-v_keccak      140   (let ((r '()))
esthlos-v_keccak      141     (with-return-state (s state)
esthlos-v_keccak      142       (while-traversing-state (x y)
esthlos-v_keccak      143         (push (lane s x y) r)))
esthlos-v_keccak      144     (bit-vector-concatenate (nreverse r))))
esthlos-v_keccak      145 
esthlos-v_keccak      146 ;; transform a bit vector into a state, filling the
esthlos-v_keccak      147 ;; lanes in the standard order
esthlos-v_keccak      148 (defun state-unlinearize (linearized-state)
esthlos-v_keccak      149   (let ((chunked-state (bit-chunk linearized-state
esthlos-v_keccak      150                                   +lane-size+)))
esthlos-v_keccak      151     (with-return-state (s)
esthlos-v_keccak      152       (while-traversing-state (x y)
esthlos-v_keccak      153         (setf (lane s x y) (pop chunked-state))))))
esthlos-v_keccak      154 
esthlos-v_keccak      155 (defun state-xor (state bit-vector)
esthlos-v_keccak      156   (state-unlinearize (bit-xor (state-linearize state)
esthlos-v_keccak      157                               (bit-pad-right bit-vector
esthlos-v_keccak      158                                              +keccak-width+))))
esthlos-v_keccak      159 
esthlos-v_keccak      160 
esthlos-v_keccak      161 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
esthlos-v_keccak      162 ;; keccak round operations
esthlos-v_keccak      163 
esthlos-v_keccak      164 (defun theta (a)
esthlos-v_keccak      165   (with-return-state (b)
esthlos-v_keccak      166     (let* ((c (make-sequence '(vector lane) +row-size+
esthlos-v_keccak      167                              :initial-element (make-lane)))
esthlos-v_keccak      168            (d (make-sequence '(vector lane) +row-size+
esthlos-v_keccak      169                              :initial-element (make-lane))))
esthlos-v_keccak      170       (dotimes (x +row-size+)
esthlos-v_keccak      171         (setf (aref c x)
esthlos-v_keccak      172               (lane a x 0))
esthlos-v_keccak      173         (loop for y from 1 below +column-size+
esthlos-v_keccak      174            do (setf (aref c x)
esthlos-v_keccak      175                     (lane-xor (aref c x)
esthlos-v_keccak      176                               (lane a x y)))))
esthlos-v_keccak      177       (dotimes (x +row-size+)
esthlos-v_keccak      178         (setf (aref d x)
esthlos-v_keccak      179               (lane-xor (aref c (mod (- x 1) +row-size+))
esthlos-v_keccak      180                         (lane-rot (aref c (mod (+ x 1) +row-size+))
esthlos-v_keccak      181                                   1)))
esthlos-v_keccak      182         (dotimes (y +column-size+)
esthlos-v_keccak      183           (setf (lane b x y)
esthlos-v_keccak      184                 (lane-xor (lane a x y)
esthlos-v_keccak      185                           (aref d x))))))))
esthlos-v_keccak      186 
esthlos-v_keccak      187 (defun rho (a)
esthlos-v_keccak      188   (with-return-state (b)
esthlos-v_keccak      189     (setf (lane b 0 0) (lane a 0 0))
esthlos-v_keccak      190     (let ((x 1) (y 0))
esthlos-v_keccak      191       (dotimes (q 24)
esthlos-v_keccak      192         (setf (lane b x y)
esthlos-v_keccak      193               (lane-rot (lane a x y)
esthlos-v_keccak      194                         (/ (* (+ q 1)
esthlos-v_keccak      195                               (+ q 2))
esthlos-v_keccak      196                            2)))
esthlos-v_keccak      197         (psetq x y
esthlos-v_keccak      198                y (+ (* 2 x)
esthlos-v_keccak      199                     (* 3 y)))))))
esthlos-v_keccak      200 
esthlos-v_keccak      201 (defun k-pi (a)
esthlos-v_keccak      202   (with-return-state (b)
esthlos-v_keccak      203     (dotimes (x +row-size+)
esthlos-v_keccak      204       (dotimes (y +column-size+)
esthlos-v_keccak      205         (setf (lane b y (+ (* 2 x)
esthlos-v_keccak      206                            (* 3 y)))
esthlos-v_keccak      207               (lane a x y))))))
esthlos-v_keccak      208 
esthlos-v_keccak      209 (defun chi (a)
esthlos-v_keccak      210   (with-return-state (b)
esthlos-v_keccak      211     (dotimes (x +row-size+)
esthlos-v_keccak      212       (dotimes (y +column-size+)
esthlos-v_keccak      213         (setf (lane b x y)
esthlos-v_keccak      214               (lane-xor (lane a x y)
esthlos-v_keccak      215                         (lane-and (lane-not (lane a (+ x 1) y))
esthlos-v_keccak      216                                   (lane a (+ x 2) y))))))))
esthlos-v_keccak      217 
esthlos-v_keccak      218 (defun iota (r a)
esthlos-v_keccak      219   (with-return-state (b a)
esthlos-v_keccak      220     (setf (lane b 0 0)
esthlos-v_keccak      221           (lane-xor (lane b 0 0)
esthlos-v_keccak      222                     (aref +round-constants+ r)))))
esthlos-v_keccak      223 
esthlos-v_keccak      224 (defun keccak-permute (a)
esthlos-v_keccak      225   (with-return-state (b a)
esthlos-v_keccak      226     (dotimes (r +round-quantity+)
esthlos-v_keccak      227       (setq b (iota r (chi (k-pi (rho (theta b)))))))))
esthlos-v_keccak      228 
esthlos-v_keccak      229 
esthlos-v_keccak      230 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
esthlos-v_keccak      231 ;; sponge
esthlos-v_keccak      232 
esthlos-v_keccak      233 (defun keccak-pad (bit-vector bitrate)
esthlos-v_keccak      234   (labels ((remaining-space (bit-vector bitrate)
esthlos-v_keccak      235              (abs (nth-value 1 (ceiling (+ 2 (length bit-vector))
esthlos-v_keccak      236                                         bitrate)))))
esthlos-v_keccak      237     (bit-vector-concatenate (list
esthlos-v_keccak      238                              bit-vector
esthlos-v_keccak      239                              #*1
esthlos-v_keccak      240                              (make-sequence 'simple-bit-vector
esthlos-v_keccak      241                                             (remaining-space bit-vector
esthlos-v_keccak      242                                                              bitrate))
esthlos-v_keccak      243                              #*1))))
esthlos-v_keccak      244 
esthlos-v_keccak      245 (defun keccak-absorb (bit-vector bitrate)
esthlos-v_keccak      246   (assert (< bitrate +keccak-width+))
esthlos-v_keccak      247   (with-return-state (s)
esthlos-v_keccak      248     (dolist (c (bit-chunk (keccak-pad bit-vector bitrate) bitrate))
esthlos-v_keccak      249       (setq s (state-xor s c))
esthlos-v_keccak      250       (setq s (keccak-permute s)))))
esthlos-v_keccak      251 
esthlos-v_keccak      252 (defun keccak-squeeze (state  bitrate output-bits)
esthlos-v_keccak      253   (assert (< bitrate +keccak-width+))
esthlos-v_keccak      254   (let ((rtn '()))
esthlos-v_keccak      255     (do ((remaining-bits output-bits (- remaining-bits
esthlos-v_keccak      256                                         bitrate)))
esthlos-v_keccak      257         ((> bitrate remaining-bits)
esthlos-v_keccak      258          (push (subseq (state-linearize state) 0 remaining-bits)
esthlos-v_keccak      259                rtn))
esthlos-v_keccak      260       (push (subseq (state-linearize state) 0 bitrate)
esthlos-v_keccak      261             rtn)
esthlos-v_keccak      262       (setq state (keccak-permute state)))
esthlos-v_keccak      263     (bit-vector-concatenate (nreverse rtn))))
esthlos-v_keccak      264 
esthlos-v_keccak      265 (defun keccak-sponge (input-bit-vector bitrate output-bits)
esthlos-v_keccak      266   (keccak-squeeze (keccak-absorb input-bit-vector
esthlos-v_keccak      267                                  bitrate)
esthlos-v_keccak      268                   bitrate
esthlos-v_keccak      269                   output-bits))
esthlos-v_keccak      270 
esthlos-v_keccak      271 (defun keccak-hash-file (filepath bitrate output-bits)
esthlos-v_keccak      272   (bit-vector-to-hex (keccak-sponge (file-to-bit-vector filepath)
esthlos-v_keccak      273                                     bitrate
esthlos-v_keccak      274                                     output-bits)))
esthlos-v_keccak      275 
esthlos-v_keccak      276 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
esthlos-v_keccak      277 ;; for use as an executable
esthlos-v_keccak      278 
esthlos-v_keccak      279 (defun main ()
esthlos-v_keccak      280   (let ((args #+sbcl (cdr sb-ext:*posix-argv*)
esthlos-v_keccak      281               #+ccl (cdr ccl:*command-line-argument-list*)))
esthlos-v_keccak      282     (princ (string-downcase (keccak-hash-file (first args)
esthlos-v_keccak      283                                               +bitrate+
esthlos-v_keccak      284                                               +output-bits+)))))