my first try for HAMT

gistfile1.lisp

(defpackage hamt
  (:use :common-lisp)
  (:export amt-base-node
           amt-node
           make-amt-base-node
           get-entry
           put-entry))

(in-package :hamt)

(defconstant lastbits #x1F
  "constant needed to mask last 5 bits of an integer")

(defun ctpop (bitmap &key (start 0) (end 32))
  (logcount (ldb (byte (- end start) start) bitmap)))

(defun mask (hash shift)
  (logand (ash hash (- (* shift 5))) lastbits))

(defun bitpos (hash shift)
  (ash 1 (mask hash shift)))

(defun generate-random-str (&optional (length 10))
  (map 'string #'code-char (loop for i from 0 to length collect (+ 97 (random 26)))))

(defstruct key-val
  key
  val)

(defstruct amt-base-node
  (entries (make-array 32 :initial-element nil) :type simple-vector))

(defstruct amt-node
  (bitmap  0   :type (unsigned-byte 32))
  (entries #() :type simple-vector))

(defgeneric get-entry (node key &key shift hash test hash-fun))

(defmethod get-entry ((node amt-base-node) key
                      &key (shift 0) (hash nil) (test #'equal) (hash-fun #'sxhash))
  (when (null hash)
    (setf hash (funcall hash-fun key)))
  (let ((bitpos (mask hash shift))
        (entries (amt-base-node-entries node)))
    (let ((entry (aref entries bitpos)))
      (cond ((null entry) nil)
            ((eq (type-of entry) 'amt-node)
             (get-entry entry key :shift (1+ shift) :hash hash :test test :hash-fun hash-fun))
            ((funcall test (key-val-key entry) key) (key-val-val entry))
            (t nil)))))

(defmethod get-entry ((node amt-node) key
                      &key (shift 0) (hash nil) (test #'equal) (hash-fun #'sxhash))
  (when (null hash)
    (setf hash (funcall hash-fun key)))
  (with-slots (bitmap entries) node
    (let ((bitpos (mask hash shift)))
      (if (zerop (logand (ash 1 bitpos) bitmap))
          nil
          (let* ((ones (ctpop bitmap :end bitpos))
                 (keyval-or-node (aref entries ones)))
            (cond ((eq (type-of keyval-or-node) 'amt-node)
                   (get-entry keyval-or-node key :shift (1+ shift) :hash hash :test test :hash-fun hash-fun))
                  ((funcall test (key-val-key keyval-or-node))
                   (key-val-val keyval-or-node))
                  (t nil)))))))

(defgeneric put-entry (node key-val &key shift hash test hash-fun))

(defmethod put-entry ((node amt-base-node) key-val
                      &key (shift 0) (hash nil) (test #'equal) (hash-fun #'sxhash))
  (with-slots (key val) key-val
    (when (null hash)
      (setf hash (funcall hash-fun key)))
    (let ((bitpos (mask hash shift))
          (entries (amt-base-node-entries node)))
      (let ((entry (aref entries bitpos)))
        (cond ((null entry)
               (setf (aref entries bitpos) key-val))
              ((eq (type-of entry) 'amt-node)
               (put-entry entry key-val (1+ shift) hash test hash-fun))
              ((funcall test (key-val-key entry) key)
               (setf (key-val-val entry) val))
              (t
               (let ((new-node (make-amt-node)))
                 (setf (aref entries bitpos) new-node)
                 (put-entry new-node entry :shift (1+ shift) :test test :hash-fun hash-fun)
                 (put-entry new-node key-val :shift (1+ shift) :test test :hash-fun hash-fun))))))))

(defmethod put-entry ((node amt-node) key-val
                      &key (shift 0) (hash nil) (test #'equal) (hash-fun #'sxhash))
  (with-slots (key val) key-val
    (with-slots (bitmap entries) node
      (when (null hash)
        (setf hash (funcall hash-fun key)))
      (let ((bitpos (mask hash shift)))
        (if (zerop (logand (ash 1 bitpos) bitmap))
            (progn (setf bitmap (logior (ash 1 bitpos) bitmap))
                   (setf entries (adjust-array entries (1+ (length entries))))
                   (loop for i from (1- (length entries)) downto (1+ (ctpop bitmap :end bitpos)) do
                     (setf (aref entries i) (aref entries (1- i))))
                   (setf (aref entries (ctpop bitmap :end bitpos)) key-val))
            (let* ((ones (ctpop bitmap :end bitpos))
                   (keyval-or-node (aref entries ones)))
              (cond ((eq (type-of keyval-or-node) 'amt-node)
                     (put-entry keyval-or-node key-val :shift (1+ shift) :hash hash :test test :hash-fun hash-fun))
                    ((funcall test key (key-val-key keyval-or-node))
                     (setf (key-val-val keyval-or-node) val))
                    (t
                     (let ((new-node (make-amt-node)))
                       (setf (aref entries ones) new-node)
                       (put-entry new-node keyval-or-node :shift (1+ shift))
                       (put-entry new-node key-val :shift (1+ shift)))))))))))