;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; A Scheme implementation of SipHash, a cryptographically strong
;;; family of hash functions designed by Jean-Philippe Aumasson and
;;; Daniel J. Bernstein.
;;;
;;; http://131002.net/siphash/
;;; 
;;; Copyright (c) 2013, Evan Hanson
;;; BSD-style license. See LICENSE for details.
;;;

;; Shorthand.
(define & bitwise-and)
(define ⊕ bitwise-xor)
(define ❘ bitwise-ior)

;; 64-bit-word-bounded operations.
(define-syntax w (syntax-rules () ((_ n)   (& n 18446744073709551615))))
(define-syntax « (syntax-rules () ((_ n m) (w (arithmetic-shift n m)))))
(define-syntax ↺ (syntax-rules () ((_ n m) (❘ (« n m) (« n (- (- 64 m)))))))

;; Repeat body `b` `n` times.
(define-syntax do-times
  (syntax-rules ()
    ((_ n . b)
     (do ((i n (- i 1)))
         ((zero? i))
       (begin . b)))))

(define-syntax assert
  (syntax-rules ()
    ((_ t)   (or t (error "assertion failed" 't)))
    ((_ t m) (or t (error (string-append "assertion failed: " m) 't)))))

;; Treats `v` as little-endian.
(define bytevector->integer
  (case-lambda
    ((v)
     (bytevector->integer v 0 (bytevector-length v)))
    ((v e)
     (bytevector->integer v 0 e))
    ((v s e)
     (do ((s s (+ s 1))
          (i 0 (+ i 1))
          (a 0 (+ a (« (bytevector-u8-ref v s) (* i 8)))))
         ((= s e) a)))))

(define (->bytevector o)
  (cond ((bytevector? o) o)
        ((string? o) (string->utf8 o))
        ((error "neither string nor bytevector" o))))

;; One SipRound.
(define-syntax sip-round!
  (syntax-rules ()
    ((_ v0 v1 v2 v3)
     (let-syntax ((+ (syntax-rules () ((_ . n) (w (+ . n))))))
       (set! v0 (+ v0 v1))
       (set! v2 (+ v2 v3))
       (set! v1 (↺ v1 13))
       (set! v3 (↺ v3 16))
       (set! v1 (⊕ v1 v0))
       (set! v3 (⊕ v3 v2))
       (set! v0 (↺ v0 32))
       (set! v2 (+ v2 v1))
       (set! v0 (+ v0 v3))
       (set! v1 (↺ v1 17))
       (set! v3 (↺ v3 21))
       (set! v1 (⊕ v1 v2))
       (set! v3 (⊕ v3 v0))
       (set! v2 (↺ v2 32))))))

(define make-siphash
  (let ((m0 (string->number "736f6d6570736575" 16))
        (m1 (string->number "646f72616e646f6d" 16))
        (m2 (string->number "6c7967656e657261" 16))
        (m3 (string->number "7465646279746573" 16)))
    (lambda (c d)
      (define (siphash-c-d k)
        (assert (= (bytevector-length k) 16) "key must be 16 bytes")
        (let* ((k0 (bytevector->integer k 0 8))
               (k1 (bytevector->integer k 8 16))
               (v0 (⊕ k0 m0))
               (v1 (⊕ k1 m1))
               (v2 (⊕ k0 m2))
               (v3 (⊕ k1 m3)))
          (let-syntax ((process-message!
                        (syntax-rules ()
                          ((_ m) (let ((mi m))
                                   (set! v3 (⊕ v3 mi))
                                   (do-times c
                                     (sip-round! v0 v1 v2 v3))
                                   (set! v0 (⊕ v0 mi)))))))
            (lambda (m)
              (let ((l (bytevector-length m)))
                (do ((i 0 (+ i 8)))
                    ((> i (- l 8))
                     (process-message!
                      (❘ (« (modulo l 256) 56)
                         (bytevector->integer m i l))))
                  (process-message!
                   (bytevector->integer m i (+ i 8))))
                (set! v2 (⊕ v2 255))
                (do-times d
                  (sip-round! v0 v1 v2 v3))
                (⊕ v0 v1 v2 v3))))))
      (case-lambda
        ((k)
         (siphash-c-d (->bytevector k)))
        ((k m)
         ((siphash-c-d (->bytevector k)) (->bytevector m)))))))

(define siphash-2-4 (make-siphash 2 4))
(define siphash-4-8 (make-siphash 4 8))