;;;Skiplist programs
;;; skiplist4 is based on skiplist, but minor optimizations and simplifications, declarations
;;;
;;; after reading on "A Skip List Cookbook"
;;; RJF June 28, 2008

;;; We simplified coding somewhat:  There is a top-level node with key 0.
;;; All other keys are non-negative integers.
;;; We did not write a Delete function.
;;; searching via an index gives a pair: index, value
;;; updating at a key k which has  value v with a new value nv replaces v by v+nv
;;; updating a non-existent key location k inserts nv at k.

(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*))))))	))

;; a skiplist -- the top of the list is just (a skiplist node)
;; including key, value, height and an array of level pointers of length *MaxLevel*
;; Height is the maximum size of the
;; level array in any node in the skiplist, and also the size of the
;; level array in the first node.  A global value *MaxLevel* limits
;; the largest this could grow. 

(defun sl-init()(let ((ans (make-sl-node 0 0 *MaxLevel*)))
		  (setf (node-height ans) 0)
		  ans))

(defstruct node key val levels height) ;; 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 :height height :levels
		     (make-array height :initial-element nil)))

;; given a skiplist S, return an association list. Sorted by key: (sl2list S)
;; given a skiplist S, return an association list of level i nodes. Sorted by key: (sl2list S i)
(defun sl2list(topsl &optional (level 0))
  (labels 
      ((sl2list1(sl)
		(cond ((null sl) nil)
		      (t (cons (cons (node-key sl)(node-val sl))
			       (sl2list1 
				(and (node-levels sl)
				     (aref (the (simple-array t (*))
					     (node-levels sl))
					   level))))))))
    (sl2list1 topsl)))

#| ;we can show the shape of a skip list in various ways.

;; a list of lists of the indexes of nodes at each level, starting at highest level

(defun showskeleton(s)			;
  (loop for i fixnum  from (1-(node-height s)) downto 0 collect 
	(mapcar #'car (sl2list s i))))

;; number of nodes at each level, in a list
(defun showskeleton2(s)			;
  (loop for i fixnum from (1-(node-height s)) downto 0 collect (length (sl2list s i))))

;; to test

(defun t4() (setf H (sl-init)) (dotimes (i 10 (sl2list H))(SLupdate3 H (1+ i) (* i 10))))
(defun t5() (setf H (sl-init)) (dotimes (i 10 (sl2list H))(SLupdate3 H (- 100 i) (* i 10))))
(defun t40() (setf H (sl-init)) (dotimes (i 100 (sl2list H))(SLupdate3 H (1+ i) (* i 10))))
(defun t400() (setf H (sl-init)) (dotimes (i 1000 'done)(SLupdate3 H (1+ i) (* i 10))))
(defun t401() (setf H (sl-init)) (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)

;; to do ... 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.
We started to do this, but need to have search  and update that returns a finger.								  
|#

;; Insert New Node.
;; this works for key that is known to be not present. 

(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))
	 (header-height (node-height sl)))
    (declare (fixnum newlevel header-height)
	     (type (simple-array t (*)) narray newarray))
	 
    ;; (format t "~%inserting key ~s, RL=~s" searchkey newlevel)
    (unless (<= newlevel header-height) ;; i.e.hardly ever run. Just when new max height of node
	(loop for i fixnum from header-height to (1- newlevel) do 
	      (setf (aref (the (simple-array t (*))(node-levels sl))i) newnode))
	(setf (node-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.
    (loop 
     for i fixnum from (1-(min (the fixnum header-height)(the fixnum newlevel))) downto 0 do
     (setf x 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 (node-height x))
	      (return 'nexti))		;exit from while
	     ((null (setf kk (aref  (the (simple-array t (*)) (node-levels x)) i)));; insert here!
	      (setf (aref (the (simple-array t (*)) (node-levels x)) i)newnode);newnode.levels[i] already points to nil
	      (return 'nexti))		;exit from while
	     ((< 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 (node-height x))
		  (setf (aref (node-levels x) i) newnode))
	      (return 'nexti))		;exit from while
	     (t (setf x kk)		;continue inside while
		))))
    sl))

(defun SLupdate1(x searchkey newval) ;; works when searchkey is found, otherwise returns nil.
    (declare (optimize (speed 3)(safety 0)))
  (let ((kk nil))
    (labels((slsrc1 ()
	      (do ((i (1-(node-height x)) (1- i)))
		  ((< i 0) nil)
		(declare (fixnum i))
		(cond ((null (setf kk (aref (the (simple-array t (*))(node-levels x)) i))) 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  (the (simple-array t (*))(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(x searchkey);; this works 
  (declare (optimize (speed 3)(safety 0)))
  (let ((kk nil))
    (labels((slsrc1 ()
	      (do ((i (1- (node-height x))(1- i)))
		  ((< i 0) nil)
		(declare (fixnum i))
		(cond ((null (setf kk (aref (the (simple-array t (*))(node-levels x)) i))) 
		       nil )
		      ((= (node-key kk) searchkey)(return-from SLsrc
						    (node-val kk)))
		      ((< (node-key kk) searchkey) ;follow link to right
		       (setf x (aref (the (simple-array t (*))(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 (sl-init)) (dotimes (i 1000 'done)(SLupdate3 H (1+ i) (* i 10))))
(defun t401() (setf H (sl-init)) (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 22X 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 (sl-init)) (dotimes (i 1000 (sl2list H))(SLupdate3 H (1+ i) (* i 10))))

;; um, something like this..
(defun m399x() (let((fin H))
		 (dotimes (i 1000 'done)(setf fin (SLreturnfingersrc fin (1+ i))))))

;; for h399 and t399, both guys are sorted, finally.
;; h399, the hashing version, is about 4.5X 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 (sl-init)))
    (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))))


(defun SLfinsrc(s finger key)
  (or (SLsrc-noerr finger key)
      (SLsrc s key)))


(defun SLreturnfingersrc(sl searchkey);; this works 
  (declare (optimize (speed 3)(safety 0)))
  
  (let ((x sl)(kk 0))
    (labels((slsrc1 ()
	      (do ((i (1-(node-height x)) (1- i)))
		  ((< i 0) nil)
		(declare (fixnum i))
		(cond ((null (setf kk (aref (the (simple-array t (*))(node-levels x)) i))) (return-from slsrc1 nil))
		      ((= (node-key kk) searchkey)(return-from SLreturnfingersrc
						    kk))
		      ((< (node-key kk) searchkey) ;follow link to right
		       (setf x (aref (the (simple-array t (*))(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)) x) ;top level node
	    (t;; set the spine at node x
	     ;; look for the searchkey
	     (slsrc1))))))

(defun SLsrc-noerr(sl searchkey);; this works ; if key is too small, just return nil
  (declare (optimize (speed 3)(safety 0)))
  
  (let ((x sl)(kk 0))
    (labels((slsrc1 ()
	      (do ((i (1-(node-height x)) (1- i)))
		  ((< i 0) nil)
		(declare (fixnum i))
		(cond ((null (setf kk (aref (the (simple-array t (*))(node-levels x)) i))) (return-from slsrc1 nil))
		      ((= (node-key kk) searchkey)(return-from SLsrc-noerr
						    (node-val kk)))
		      ((< (node-key kk) searchkey) ;follow link to right
		       (setf x (aref (the (simple-array t (*))(node-levels x)) i))
		       (slsrc1)))
		      ;;end of do: decrement i, proceed down spine.
		      )))
  
      (cond ((< searchkey (node-key x)) nil)
	    ((= searchkey (node-key x)) (node-val x)) ;top level node
	    (t;; set the spine at node x
	     ;; look for the searchkey
	     (slsrc1))))))