;;;Skiplist programs
;;; based on "A Skip List Cookbook"
;;; RJF June 20, 2008

;;; We simplified coding somewhat:  There is a top-level node with key 0.
;;; All keys are non-negative integers.
;;; We did not write a Delete function.
(eval-when (compile)
   (declaim (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))))

(defconstant *MaxLevel* 20)

(defun RL() ;; random level. 1/2 time returns 1, 1/4 the time 2, 1/8 the time 3 etc.
  (declare (optimize (speed 3)(safety 0)))
  (- (the fixnum *MaxLevel*) 
	(the fixnum (integer-length 
		     (the fixnum (random #.(expt 2 (1- *MaxLevel*))))))	))

(defstruct SL  
;; a skiplist -- the top of the list includes a header (a node) + maxheight.
;; maxheight is the maximum size of the level array in any node in the skiplist.
;; header is a node of exactly that number of levels. (so maxheight is redundant)
;; Global value *MaxLevel* determines the largest this could grow.
;; Unusual for skiplist nodes, this header node can (and will) grow
;; its level array. but otherwise, header is a regular node. 
  (header (make-sl-node 0 0 0));  use NO level to initialize. First insertion changes it.
  (maxheight 0))

(defstruct node key val levels) ;; a skiplist node
;; key is a non-negative integer k
;; value is arbitrary
;; levels is an array. 
;; levels[0] is always the node with the next larger key, or nil if the end of the list.
;; levels[1] is some node with key > k  or nil, at level 1
;; levels[i] is some node with key > k  or nil, at level i


(defun make-sl-node(key val height) ; usually height is from call to RL.
  (make-node :key key :val val :levels
		     (make-array height :initial-element nil)))

;; convert a skiplist to an association list, sorted.
(defun sl2list(topsl &optional (level 0));; traverse skiplist , given the top node, using level 0 links.
  (labels 
      ((sl2list1(sl)
	 (cond ((null sl) nil)
	       (t
		 (cons (cons (node-key sl)(node-val sl))
		       (sl2list1 (and (node-levels sl)
				      (aref (node-levels sl) level))))))))
    (sl2list1 (SL-header topsl))))


;;; 

#| to test

(defun t4() (setf H (make-SL)) (dotimes (i 10 (sl2list H))(SLupdate3 H (1+ i) (* i 10))))
(defun t5() (setf H (make-SL)) (dotimes (i 10 (sl2list H))(SLupdate3 H (- 100 i) (* i 10))))
(defun t40() (setf H (make-SL)) (dotimes (i 100 (sl2list H))(SLupdate3 H (1+ i) (* i 10))))
(defun t400() (setf H (make-SL)) (dotimes (i 1000 'done)(SLupdate3 H (1+ i) (* i 10))))
(defun t401() (setf H (make-SL)) (dotimes (i 1000 'done)(SLupdate H (1+ i) (* i 10))))

(defun h400() (setf G (make-hash-table)) (dotimes (i 1000 'done)(setf (gethash (1+ i) G)
							    (* i 10))))


(loop for i from (1- (SL-maxheight H)) downto 0 collect  (sl2list H i))
;; show just the indexes
(loop for i from (1- (SL-maxheight H)) downto 0 collect  (mapcar #'car (sl2list H i)))
;; we might want 2 versions of the update program.
;; 1.  start from beginning.
;; 2.  start from a "finger" into the list when we expect to be near (or just ahead) of key.
|#
;; Insert New Node .
;; this works for key that is known to be not present. 


(defun copy-ar(from to i j) ; copy over from[i] through from[j]. e.g. 0 to h-1 for length h.
	(do ((k i (1+ k)))
	    ((> k j) to)
	  (setf (aref to k)(aref from k))))

(defun SLupdate(S searchkey newval)
  (or (SLupdate1 S searchkey newval) ;; is it there? if so update it
      (SLupdate3 S searchkey newval))) ;; otherwise insert it


;; this works.
(defun SLupdate3(sl searchkey newval)	; node not present; inserts one.
    (declare (optimize (speed 3)(safety 0)))
  (let* ((x nil)
	 (kk nil)
	 (newlevel (RL))
	 (newnode (make-sl-node searchkey newval newlevel));create a new node, levels nil
	 (narray (node-levels newnode))
	 (newarray nil)
	 (header-height (SL-maxheight sl)))
    (declare (fixnum newlevel header-height)
	     (type (simple-array t (*)) narray newarray)
	     )
	 
 ;;   (format t "~%inserting key ~s, RL=~s" searchkey newlevel)
    (if(> newlevel header-height)
	(let ((oldarray (node-levels(SL-header sl))))
	  (setf newarray (make-array newlevel :initial-element newnode));; make a new header
	 ;; (format t "~%adjust header from ~s to ~s" header-height newlevel)
	  (copy-ar oldarray newarray 0 (1- (SL-maxheight sl)))
	  (setf (node-levels (SL-header sl)) newarray)
	  (setf (SL-height sl) newlevel) ))

    ;; for each level from (1-(min header-height newlevel)) down to 0
    ;; find the node that is just smaller than key, at that level.
    ;; point it to newnode.
    ;; find the next node (just larger than key), and point newnode[i] to it.
   ;; (format t "~%2, i= ~s" i)
    (do ((i (1-(min (the fixnum header-height)(the fixnum newlevel))) (1- i)))
	((< i 0) nil)
      (declare (fixnum i))
     ;; (format t "~%2, i= ~s" i)
      (setf x (SL-header sl))		; initially the header has key 0
      (while x
	;;(format t "~%x's key is ~s" (node-key x))
	; forward one node from x
	(cond ((>= i (length (the simple-array (node-levels x))))
	       (return 'nexti))
	      ((null (setf kk (aref  (the simple-array (node-levels x)) i)));; insert here!
	       (setf (aref  (the simple-array (node-levels x)) i)newnode);newnode.levels[i] already points to nil
	       (return 'nexti))
		   
	      ((< searchkey (node-key kk));gone too far..
	  ;;     (format t "~%i=~s, bracket ~s by ~s <~s < ~s" i searchkey  		       (node-key x)  searchkey  (if kk (node-key kk)))
	       (if (< i newlevel)  (setf (aref narray i) kk))
	       (if (< i (length (the simple-array(node-levels x))))  (setf (aref (node-levels x) i) newnode))
	       (return 'nexti))		;exit from while
	      (t (setf x kk)))))
    sl))



(defun SLupdate1(sl searchkey newval) ;; works only if searchkey is found, otherwise returns nil.
    (declare (optimize (speed 3)(safety 0)))
  (let ((x (SL-header sl))(kk 0))
    (labels((slsrc1 ()
	      (do ((i (1-(length (the simple-array (node-levels x)))) (1- i)))
		  ((< i 0) nil)
		(declare (fixnum i))
		(cond ((null (setf kk (aref (node-levels x) i))) (return-from SLupdate1 nil))
		      ((= (node-key kk) searchkey)
		       (return-from SLupdate1
			 ;; update means "add newval into node"
			 (incf (node-val kk) newval)))
		      ((< (node-key kk) searchkey) ;follow link to right
		       (setf x (aref (node-levels x) i))
		       (slsrc1)))
		      ;;end of do: decrement i, proceed down spine.
		      )))
  
      (cond ((< searchkey (node-key x)) (error "illegal key:~s < ~s" searchkey (node-key x)))
	    ((= searchkey (node-key x))(incf (node-val x) newval)) ;top level node
	    (t;; set the spine at node x
	     ;; look for the searchkey
	     (slsrc1))))))

;; search for a key/value pair.  
(defun SLsrc(sl searchkey);; this works 
  (declare (optimize (speed 3)(safety 0)))
  
  (let ((x (SL-header sl))(kk 0))
    (labels((slsrc1 ()
	      (do ((i (1-(length (the simple-array(node-levels x)))) (1- i)))
		  ((< i 0) nil)
		(declare (fixnum i))
		(cond ((null (setf kk (aref (node-levels x) i))) (return-from slsrc1 nil))
		      ((= (node-key kk) searchkey)(return-from SLsrc
						    (node-val kk)))
		      ((< (node-key kk) searchkey) ;follow link to right
		       (setf x (aref (node-levels x) i))
		       (slsrc1)))
		      ;;end of do: decrement i, proceed down spine.
		      )))
  
      (cond ((< searchkey (node-key x)) (error "illegal key:~s < ~s" searchkey (node-key x)))
	    ((= searchkey (node-key x)) (node-val x)) ;top level node
	    (t;; set the spine at node x
	     ;; look for the searchkey
	     (slsrc1))))))

;; same execution time for t400 and t401, so searching first, and then
;; re-searching to insert if not found, is apparently OK, time/space -wise.

(defvar H nil)
(defvar G nil)
(defun t400() (setf H (make-SL)) (dotimes (i 1000 'done)(SLupdate3 H (1+ i) (* i 10))))
(defun t401() (setf H (make-SL)) (dotimes (i 1000 'done)(SLupdate  H (1+ i) (* i 10))))
;; t401 is same time as t400.

(defun h400() (setf G (make-hash-table)) (dotimes (i 1000 'done)(setf (gethash (1+ i) G)
								  (* i 10))))
;; hashing is like 32X faster , h400 vs t400.
;; but hashing is not sorted.

(defun m400()  (dotimes (i 1000 'done)(SLsrc H (1+ i) )))
(defun n400()  (dotimes (i 1000 'done)(gethash (1+ i) G ))) ;;10X faster than m400. SL loses.

(defun h399() (setf G (make-hash-table)) 
       (let ((ans nil))
	 (dotimes (i 1000 'done)
	   (setf (gethash (1+ i) G)(* i 10)))
	 (maphash #'(lambda (i v)(push (cons i v) ans)) G)
	 (sort ans #'< :key #'car)))

(defun t399() (setf H (make-SL)) (dotimes (i 1000 (sl2list H))(SLupdate3 H (1+ i) (* i 10))))

;; for h399 and t399, both guys are sorted, finally.
;; h399, the hashing version, is about 9.8X faster than the skiplist version.

;; still to try out: do the updates starting somewhere other than the top of list...
;; so-called fingers

;; encode polynomials like this: ((coef . expon) ....)

(defun ptimes-SL (m n)		;multiply two polynomials, in lists, into skiplist result
  (declare (optimize (speed 3)(safety 0)))
  (let((ans (make-SL)))
    (dolist (i m ans) ;; the cross product
      (dolist (j n)
	(SLupdate ans (+ (cdr i)(cdr j)) ;key is exponent
		  (* (car i)(car j))))	;record is product of coefficients
		  (sl2list ans))))