Created
December 30, 2011 19:00
-
-
Save osa1/1541028 to your computer and use it in GitHub Desktop.
my first try for HAMT
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(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))))))))))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment