dumb string hash reversal

ql-dumb-string-hash-reversal.lisp

(defpackage #:snippets/ql-dumb-string-hash-reversal
  (:documentation "A reversal of ql-setup::dumb-string-hash.")
  (:use #:cl))

(in-package #:snippets/ql-dumb-string-hash-reversal)

(defconstant dumb-modulus 88888901)

(defconstant dumb-initial #xD13CCD13)

(defun dumb-string-hash (string)
  "Simple reimplementation of ql-setup::dumb-string-hash."
  (base36 (dumb-octet-hash (map 'list #'char-code string))))

(defun base36 (x)
  "Create the 6-character string from the octet hash."
  (subseq (format nil "~(~36,6,'0R~)" (mod x dumb-modulus)) 0 6))

(defun dumb-octet-hash (octets)
  "Return the octet hash for supplied octets."
  (reduce #'hash-update octets :initial-value dumb-initial))

(defun hash-update (h x)
  "Rotate H left by 5 and xor with X."
  (32bit (logxor (ash h 5) (ash h -27) (8bit x))))

(defun 32bit (x)
  "Return the 32 least significant bits of X."
  (logand x #xFFFFFFFF))

(defun 8bit (x)
  "Return the 8 least significant bits of X."
  (logand x #xFF))

(defun rotate-forward (x &optional (n 1))
  "Perform the rotation step on X, N times."
  (if (= n 1)
      (32bit (logxor (ash x 5) (ash x -27)))
      (rotate-forward (rotate-forward x (- n 1)))))

(defun rotate-backward (x &optional (n 1))
  "Perform the backwards rotation step on X, N times."
  (if (= n 1)
      (32bit (logxor (ash x -5) (ash x 27)))
      (rotate-backward (rotate-backward x (- n 1)))))

(defun list-rotate (list &optional (n 1))
  "Perform the rotation step on LIST, N times."
  (if (= n 1)
      (append (subseq list 5) (subseq list 0 5))
      (list-rotate (list-rotate list (- n 1)))))

(defun rot-print (name h &optional (k 6))
  "Print K rotations for named H."
  (flet ((r (x) (format nil "R(~A)" x)))
    (do ((i 0 (1+ i))
         (n name (r n))
         (h h (rotate-forward h)))
        ((> i k))
      (hash-print n h))))

(defun hash-print (title h)
  "Print hash in hex/bin representation with supplied title."
  (format t "~20A: ~8,'0X ~32,'0B~%" title h h))

(defun possible (x)
  "Return a list of 32-bit words that are X when modulated with
DUMB-MODULUS."
  (loop for i from 0 to 48
        for y = (+ x (* i dumb-modulus))
        when (<= y #xFFFFFFFF)
        collect y))

;; It's quite possible to use fewer than 6 characters to fix up the
;; hash, but who cares?

(defun fixup (desired-hash &optional (prefix ""))
  "Return a string that, when appended to PREFIX, hashes to
DESIRED-HASH."
  (when (stringp desired-hash)
    (setf desired-hash (parse-integer desired-hash :radix 36)))
  (do* ((h (dumb-octet-hash (map 'list #'char-code prefix)))
        (seed (rotate-backward desired-hash 5) (rotate-forward seed))
        (octet (8bit (hash-update h seed)) (8bit (hash-update hp seed)))
        (hp (hash-update h octet) (hash-update hp octet))
        (octets (list octet) (cons octet octets))
        (i 0 (1+ i)))
       ((= i 5) (map 'string #'code-char (nreverse octets)))))