;;;Skiplist programs
;;; skiplist5 is based on skiplist.lisp Optimized, extended, simplified.
;;;
;;; 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.

;;; if we know the indexes are all fixnums, they should be so declared and things will
;;; run faster!

(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. 



(defstruct slnode (key 0) (val 0) levels (height 0)) ;; 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

;; For printing a skiplist, convert to an association list.
;; This makes it plausible to just return a value that is a skiplist with default printing,
;; though it won't show the various linkages. For that, try looking at (slnode-levels x)

(defmethod print-object((x slnode) stream)  (format stream "~s" (sl2list x)))

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

(defun make-sl-node(key val height) ; usually height is from call to RL.
  (make-slnode :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)
;; see also sl2listnz which provides only non-zero values.
(defun sl2list(topsl &optional (level 0))
  (labels 
      ((sl2list1(sl)
	 (cond ((null sl) nil)
	       (t (cons (cons (slnode-key sl)(slnode-val sl))
			(sl2list1 
			 (and (slnode-levels sl)
			      (aref (the (simple-array t (*))
				      (slnode-levels sl))
				    level))))))))
    (sl2list1 topsl)))


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

(slnode-levels H)  will show the array of skiplists at each level of skiplist H.

;; to just see the indexes, do this
(defun showskeleton(s)			;
  (loop for i fixnum  from (1-(slnode-height s)) downto 0 collect 
	(mapcar #'car (sl2list s i))))

;; to just show number of nodes at each level, in a list
(defun showskeleton2(s)			;
  (loop for i fixnum from (1-(slnode-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

(defun SLup(S searchkey newval) ;; error checking version for user
  (if (typep S 'slnode)
	(if (<= (slnode-key S) searchkey)
	    (SLupdate S searchkey newval)
	  (error "SLup: key ~s < ~s, not in range of skiplist" searchkey (slnode-key S)))
      (error "SLup: expected skiplist, not ~s"S)))

;; 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 (slnode-levels newnode))
	 (header-height (slnode-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 (*))(slnode-levels sl))i) newnode))
	(setf (slnode-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" (slnode-key x))
					; forward one node from x
       (cond ((>= i (slnode-height x))
	      (return 'nexti))		;exit from while
	     ((null (setf kk (aref  (the (simple-array t (*)) (slnode-levels x)) i)));; insert here!
	      (setf (aref (the (simple-array t (*)) (slnode-levels x)) i)newnode);newnode.levels[i] already points to nil
	      (return 'nexti))		;exit from while
	     ((< searchkey (slnode-key kk));gone too far..
	      ;;(format t "~%i=~s, bracket ~s by ~s <~s < ~s" i searchkey(slnode-key x) searchkey  (if kk (slnode-key kk)))
	      (if (< i newlevel)  (setf (aref narray i) kk))
	      (if (< i (slnode-height x))
		  (setf (aref (slnode-levels x) i) newnode))
	      (return 'nexti))		;exit from while
	     (t (setf x kk)		;continue inside while
		)))) newnode)) ;; return a pointer into the list at the newnode

(defun SLupdate1(x searchkey newval) ;; works when searchkey is found, otherwise returns nil.
    (declare (optimize (speed 3)(safety 0)))
  (let ((kk nil)(tk nil)) ; tk=thekey
    (labels
	((slsrc1 ()
	      (loop for i fixnum from (1- (slnode-height x)) downto 0 do 
		    (cond ((null 
			    (setf kk (aref (the (simple-array t (*))(slnode-levels x)) i))) nil)
			  ((= (setf tk(slnode-key kk)) searchkey)
			   ;; update means "add newval into node"
			   (incf (slnode-val kk) newval) 
			    ;; return a pointer into the list at the updated node
		       (return-from SLupdate1 kk)) 
		      ((< tk searchkey) ;follow link to right
		       (setf x kk)
		      (return (slsrc1))))
		      ;;end of do: decrement i, proceed down spine.
		      )))
  
      (cond ((< searchkey (slnode-key x)) nil)
					  ;(error "illegal key:~s < ~s" searchkey (slnode-key x)))
	    ((= searchkey (slnode-key x))(incf (slnode-val x) newval) x) ;alter top level node
	    (t (slsrc1))))))

;; search for a key/value pair. return a pointer into the list at that matching node.
(defun SLsrc(x searchkey);; this works 
  (declare (optimize (speed 3)(safety 0)))
  (let ((kk nil))
    (labels
	((slsrc1 
	  ()
	  (loop for i fixnum from (1- (slnode-height x)) downto 0 do 
		(cond ((null (setf kk (aref (the (simple-array t (*))(slnode-levels x)) i))) 
		       nil)
		      ((= (slnode-key kk) searchkey)(return-from SLsrc  kk))
		      ((< (slnode-key kk) searchkey);follow link to right
		       (setf x kk)
		       (return (slsrc1)))))))
  
      (cond ((< searchkey (slnode-key x)) nil) ;just don't find, if key is bad.
	   ;; ((< searchkey (slnode-key x))(error "illegal key:~s < ~s" searchkey (slnode-key x)))
	    ((= searchkey (slnode-key x)) 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 slightly longer time vs 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)(declare (fixnum i))(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 reh399() ;; slower than redot399, by 1.4X  shows SL can win!
     (let ((ans nil))
	 (dotimes (i 1000 'done)
	   (incf (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))))
(defun redot399() (dotimes (i 1000 (sl2list H))(SLupdate H (1+ i) (* i 10))))

(defun t399x() (let ((fin))
		 (setf H (sl-init)) 
		 (setf fin H)
		 (dotimes (i 1000 (sl2list H))
		   (declare (fixnum i))
		   (setf fin  (SLupdate-finger H fin (1+ i) (* i 10))))))
(defun redot399x() (let ((fin))
		     (setf fin H)
		     (dotimes (i 1000 (sl2list H))
		       (declare (fixnum i))
		       (setf fin  (SLupdate-finger H fin (1+ i) (* i 10))))))

(defun redot399y() (let ((fin))
		     (setf fin H)
		     (dotimes (i 1000 H ) ;(sl2list H))
		       (declare (fixnum i))
		       (setf fin  (SLupdate-finger H fin (1+ i) (* i 10))))))


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

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


(defun ptimesSL (m n)		;multiply two polynomials, in skiplists, into skiplist result
  (declare (optimize (speed 3)(safety 0)))
  (let*((ans (sl-init))
	(f ans)
	(v 0)
	(e 0))
    (do ((i (aref (slnode-levels m) 0) (aref (slnode-levels i) 0)))
	((null i) ans)
      (unless (zerop(setf v (slnode-val i)))
	(setf e (slnode-key i))
	(do ((j (aref (slnode-levels n) 0) (aref (slnode-levels j) 0)))
	    ((null j) nil)
	  (setf f (SLupdate-finger ans f (+ e(slnode-key j)) ;key is exponent
				   (* v(slnode-val j)))))))))


;;; declare as single-floats, fixnum expns
#+ignore
(defun ptimesSL (m n)		;multiply two polynomials, in skiplists, into skiplist result
  (declare (optimize (speed 3)(safety 0)))
  (let*((ans (sl-init))
	(f ans)
	(v 0.0)
	(e 0))
    (declare (single-float v) (fixnum e))
    (do ((i (aref (slnode-levels m) 0) (aref (the (simple-array t (*))(slnode-levels i)) 0)))
	((null i) ans)
      (unless (zerop(setf v (slnode-val i)))
	(setf e (slnode-key i))
	(do ((j (aref (slnode-levels n) 0) (aref (the (simple-array t (*))(slnode-levels j)) 0)))
	    ((null j) nil)
	  (setf f (SLupdate-finger ans f (+ e(the fixnum (slnode-key j))) ;key is exponent
				   (* v (the single-float (slnode-val j))))))))))


(defun ptimes (m n)		;multiply two polynomials, in lists
  (declare (optimize (speed 3)(safety 0)))
  (let*((ans (sl-init))
	(f ans)
	(v 0)
	(e 0))
    (dolist (i m (sl2listnz ans))
      (unless (zerop(setf v (cdr i)))
	(setf e (car i))
	(dolist (j n nil)
	  (setf f (SLupdate-finger ans f (+ e(car j)) ;key is exponent
				 (* v(cdr j)))))))))

(defun alist2sl(a)
  (let ((ans (sl-init)))
    (dolist (i a ans)(SLupdate ans (car i)(cdr i)))))

#|
(setf m '((1 . 1) (2 . 1))) ;x+x^2
(setf msl (alist2sl m))
(time (dotimes (i 10 m) (setf m (ptimes m m)))) ; 1.8 sec
(time (dotimes (i 10 msl) (setf msl(ptimesSL msl msl)))) ;1.8 sec.  packexpons is about 1.2sec
;; this is about .9 seconds in (undeclared) single-floats.
;; about 0.82 if expons are declared fixnum, coeffs are single-float.

|#


(defun SLsrc-finger(s finger key) ; search starting at finger, but if not there, look to left
  (or (SLsrc finger key)
      (SLsrc s key)))

(defun SLupdate-finger(s finger key val)
  (if (SLsrc finger key)
      (SLupdate1 finger key val)
    ;; either key is to the left in the skiplist, or nowhere.
    ;; in either case, start with the list header to insert.
      (SLupdate s key val)))


(defun sl2listnz(topsl &optional (level 0)) ;don't show the 0 valued entries.
  (labels 
      ((sl2list1(sl)
	 (cond ((null sl) nil)
	       ((zerop(slnode-val sl))
		(sl2list1 
			 (and (slnode-levels sl)
			      (aref (the (simple-array t (*))
				      (slnode-levels sl))
				    level))))
		
	       (t (cons (cons (slnode-key sl)(slnode-val sl))
			(sl2list1 
			 (and (slnode-levels sl)
			      (aref (the (simple-array t (*))
				      (slnode-levels sl))
				    level))))))))
    (sl2list1 topsl)))




(defun mapXsl(fun S) ;; like maphash, except changes skiplist entries
  (labels 
      ((sl2list1(sl)
	 (cond ((null sl) nil)
	       (t (setf  (slnode-val sl)
		    (funcall fun  (slnode-key sl) (slnode-val sl)))
		  (sl2list1 (aref (the (simple-array t (*))
				    (slnode-levels sl))
				  0))))))
    (sl2list1 S)))
;; eg  (mapsl #'(lambda(k v)(1+ v)) H)  changes H so each value is 1 more.



(defun mapsl(fun S) ;; like maphash, make new skiplist
  (let ((ans (sl-init)))
    (labels 
      ((sl2list1(sl)
	 (cond ((null sl) nil)
	       (t (SLupdate ans (slnode-key sl)
		    (funcall fun  (slnode-key sl) (slnode-val sl)))
		  (sl2list1 (aref (the (simple-array t (*))
				    (slnode-levels sl))
				  0))))))
    (sl2list1 S) ans)))