;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: kira; Coding: utf-8 -*-
;;;; Copyright © 2020 David Mullen. All Rights Reserved. Origin: <https://cl-pdx.com/kira/>

(in-package :kira)

(eval-always
  ;; Parameters for the Speck block cipher,
  ;; with a 96-bit block and 144-bit key.
  (defconstant +speck-rounds+ 29)
  (defconstant +speck-key-words+ 3)
  (defconstant +speck-word-bits+ 48)
  (defconstant +speck-word-size+ (/ +speck-word-bits+ 8))
  (defconstant +speck-word-mask+ (1- (ash 1 +speck-word-bits+)))
  (deftype speck-word () `(unsigned-byte ,+speck-word-bits+)))

(defmacro %ror (x r)
  (let ((mask (1- (ash 1 r))))
    `(logior (ash ,x (- ,r))
             (the speck-word
               (ash (logand ,x ,mask)
                    (- +speck-word-bits+
                       ,r))))))

(defmacro %rol (x r)
  `(logior (logand (ash ,x ,r) +speck-word-mask+)
           (ash ,x (- ,r +speck-word-bits+))))

(defmacro %round-function (x y k)
  `(setq ,x (%ror ,x 8) ,x (logand (+ ,x ,y) +speck-word-mask+)
         ,x (logxor ,x ,k) ,y (%rol ,y 3) ,y (logxor ,y ,x)))

(defun make-key-schedule (key)
  (with-array-data ((key key) (start 0) end)
    (assert (eql (- end start) +speck-key-words+))
    (let ((c (require-type (svref key 0) 'speck-word))
          (b (require-type (svref key 1) 'speck-word))
          (a (require-type (svref key 2) 'speck-word)))
      (declare (type speck-word c b a))
      (loop with key-schedule = (make-array +speck-rounds+)
            initially (setf (svref key-schedule 0) c)
            for i of-type (unsigned-byte 6) from 0 below (1- +speck-rounds+)
            do (if (evenp i) (%round-function b c i) (%round-function a c i))
               (setf (svref key-schedule (1+ i)) c) finally (return key-schedule)))))

(define-symbol-macro +speck-iv+
  ;; This is the test vector given for
  ;; Speck96/144 in the original paper.
  ;; (But little-endian, not big-endian.)
  '(115586905564534 . 111520595058798))

(defstruct (speck-context (:conc-name speck-))
  (key-schedule nil) (ciphertext (cons 0 0))
  (plaintext (copy-tree +speck-iv+)))

(defun %encrypt (context)
  (let ((plaintext (speck-plaintext context))
        (ciphertext (speck-ciphertext context))
        (key-schedule (speck-key-schedule context)))
    (check-type plaintext (cons speck-word speck-word))
    (check-type ciphertext (cons speck-word speck-word))
    (check-type key-schedule simple-vector)
    (locally (declare (optimize (safety 0) (speed 3)))
      (loop with (y . x) of-type (speck-word . speck-word) = plaintext
            for i of-type (unsigned-byte 6) from 0 below +speck-rounds+
            for round-key of-type speck-word = (svref key-schedule i)
            do (%round-function x y round-key)
            finally (setf (car ciphertext) y)
                    (setf (cdr ciphertext) x)
                    (return ciphertext)))))

(defmacro %xar (block speck-word)
  "XOR the CAR of BLOCK with the SPECK-WORD."
  `(setf (car ,block) (logxor (the speck-word (car ,block))
                              (the speck-word ,speck-word))))

(defmacro %xdr (block speck-word)
  "XOR the CDR of BLOCK with the SPECK-WORD."
  `(setf (cdr ,block) (logxor (the speck-word (cdr ,block))
                              (the speck-word ,speck-word))))

(defun %get-speck-word (vector i start end buffer)
  (declare (type (simple-array octet (*)) vector))
  (declare (type (simple-array octet (*)) buffer))
  (declare (type array-index i start end))
  (declare (optimize (safety 0) (speed 3)))
  (if (>= i end) ; Final word is the length.
      (logand (- end start) +speck-word-mask+)
      (let ((remaining-octets (- end i)))
        (declare (type array-index remaining-octets))
        (when (< remaining-octets +speck-word-size+)
          (replace buffer vector :start2 i :end2 end)
          ;; REMAINING-OCTETS is the start of padding.
          (setf (aref buffer remaining-octets) #x80)
          (fill buffer 0 :start (1+ remaining-octets))
          (setq vector buffer i 0))
        ;; BUFFER is used here for the padded portion.
        (%get-binary-byte vector i #.+speck-word-size+))))

(defmacro %rekey (key &rest key-words)
  `(setf ,.(loop for i = 0 then (1+ i)
                 for key-word in key-words
                 collect `(svref ,key ,i)
                 collect key-word)))

(defun digest (vector &aux (context (make-speck-context)))
  "Hirose (double-block-length) compression function."
  (check-type vector (or string (vector octet)))
  (when (stringp vector) (setq vector (encode-string-to-octets vector)))
  (let ((buffer (make-array +speck-word-size+ :element-type 'octet)))
    (with-array-data ((vector vector) (start 0) end)
      (loop with key = (make-array +speck-key-words+)
            with plaintext = (speck-plaintext context)
            with ciphertext = (speck-ciphertext context)
            with virtual-end of-type array-index = (+ end +speck-word-size+)
            with g = (copy-tree plaintext) and h = (copy-tree plaintext)
            for i of-type array-index from start below virtual-end by +speck-word-size+
            do (%rekey key (%get-speck-word vector i start end buffer) (car h) (cdr h))
               (setf (speck-key-schedule context) (make-key-schedule key))
               (setf (car plaintext) (car g))
               (setf (cdr plaintext) (cdr g))
               (%encrypt context)
               (%xar ciphertext (car plaintext))
               (%xdr ciphertext (cdr plaintext))
               (setf (car g) (car ciphertext))
               (setf (cdr g) (cdr ciphertext))
               (%xar plaintext +speck-word-mask+)
               (%xdr plaintext +speck-word-mask+)
               (%encrypt context)
               (%xar ciphertext (car plaintext))
               (%xdr ciphertext (cdr plaintext))
               (setf (car h) (car ciphertext))
               (setf (cdr h) (cdr ciphertext))
            ;; H||G produces a 192-bit integer.
            finally (destructuring-bind (w . x) h
                      (declare (type speck-word w))
                      (declare (type speck-word x))
                      (destructuring-bind (y . z) g
                        (declare (type speck-word y))
                        (declare (type speck-word z))
                        (return (logior (ash z (* 3 +speck-word-bits+))
                                        (ash y (* 2 +speck-word-bits+))
                                        (ash x +speck-word-bits+)
                                        w))))))))