s;;; -*- Lisp -*-
;; implementation of heap data structure in lists
;;; heapl is heap using lists.
;;; heap-list has all nodes as list of 3 items.
;;; this version has leaf nodes as numbers.

(defmacro leafp(x) `(numberp  ,x))

(eval-when (compile load) (declaim (optimize (speed 3)(safety 0))))

;; we need a selection of random numbers! ; 100 is not enough for our tests!
(defparameter yesno (let ((h (loop for i from 1 to 3597 collect (> (random 2) 0))))
		      (nconc h h)))

(defmacro nextyn () `(pop yesno))  ;; fastest, lotsa memory.

#+ignore ; almost as fast, much less memory by factor of 32X
(defun yngen()
  (let* ((ybc 0) ;yes-no-bit-array-count
	 (yl  #.(expt 2 16)) ;yes-no-bit-array-length
	 (yb (make-array #.(expt 2 16) :element-type '(mod 2)))) ;yes-no-bit-array
    (declare (fixnum ybc yl)
	     (type (simple-array (mod 2) (*)) yb))
    ;; set up the lexically closed array of bits
    (loop for i from 0 to (1-(length yb)) do(setf (aref yb i)(random 2)))
    #'(lambda()
         (declare (optimize (speed 3)(safety 0)))
	 (if (= ybc yl)(setf ybc -1)) ;loop around when you exhaust the bits
	 (= 1 (aref yb (incf ybc)))))) ;

#+ignore
(defparameter yngenfun (yngen))
#+ignore
(defmacro nextyn() `(funcall yngenfun))

(defun create-heapl (ic)			;initial contents.  ic  should be ordered.
  (cond ((null ic) nil)
	((null(cdr ic)) (car ic)) ;final leaf node
	(t (multiple-value-bind (a b)(split (cdr ic))
	     (list (car ic)(create-heapl a)(create-heapl b))))))


(defun split(z) ;; used to balance the initial contents.
  (cond ((null z)(values nil nil))
	(t  (let ((even z)
	(odd (cdr z)))
    (do ((i even (cdr i))
	 (j odd (cdr j)))
	((null j)(values even odd))
    ;  (format t "~% even=~s odd=~s" even odd)
      (setf (cdr i) (cddr i))
      (setf (cdr j) (cddr j)))))))

(defun heap-insertl (heap x)
  (declare (optimize (speed 3)(safety 0)))
  ;; a heap could be nil or
  ;; (top left right)
  ;; number
  (cond 
   ((null heap)		;		(list x nil nil); returns heap
					x
					)
   ((leafp heap)
    (if (< x heap)(if (nextyn)
		      ;;(pop yesno)
		      (list x heap nil)(list x nil heap))
      (if (nextyn)
	  ;;(pop yesno)
	  (list heap x nil)(list heap nil x))))

   ;;(here (car heap))
   ;;(left (car (cadr heap)))
   ;;(right (car (caddr heap)))
   ((> x (car heap))  ;;; maybe should test if left or right is nil, put it there...
    (cond ((null (cadr heap))(setf (cadr heap) x))
	  ((null (caddr heap))(setf (caddr heap) x))
	  (t
	   ;; move down to left or right...
	   (if        
	       (nextyn)
	       (setf (caddr heap)(heap-insertl (caddr heap) x))
	     (setf (cadr heap) (heap-insertl (cadr heap) x)))))
    heap)
   (t;; x is <= here
    
        (cond ((null (cadr heap))(setf (cadr heap) (car heap)))
	      ((null (caddr heap))(setf (caddr heap) (car heap)))
	      (t

	       (if 
		   
		   (nextyn)
		   (setf (caddr heap)  (heap-insertl (caddr heap) (car heap)))
		   
		 (setf (cadr heap) (heap-insertl (cadr heap) (car heap))))))
	(setf (car heap) x)
	heap)))

(defun heap-removel(heap)
  (if (leafp heap) nil ;(error "~s heap empty" heap) ;; but its empty... bad.
  (let ((here (car heap))
	(newheap (merge-heapsl (cadr heap)(caddr heap))))
    (if (leafp newheap)(setf newheap (list newheap nil nil)))
    (setf (car heap) (car newheap))
    (setf (cdr heap)(cdr newheap))
    here)))


(defun merge-heapsl(a b) ;destructive
  (cond ((null a) b)
	((null b) a)
	((leafp a) (heap-insertl b a))
	((leafp b) (heap-insertl a b))
	
	((< (car a)(car b))
	 (setf (cadr a)(merge-heapsl (cadr a)(caddr a)))
	 (setf (caddr a) b)
	 a)
	(t (setf (cadr b)(merge-heapsl (cadr b)(caddr b)))
	   (setf (caddr b) a)
	   b)))

  
;;;;;;;;;;
;;; testing


;; lists

(defun testl-in(heap data)(dolist (i data)(heap-insertl heap i)))
(defun testl-out(heap count)(dotimes (i count)(heap-removel heap)))

;; arrays

(defun testa-in(heap data)(dolist (i data)(heap-insert heap i)))
(defun testa-out(heap count)(dotimes (i count)(heap-remove heap)))
;; timing results
#|
;; data is 1000 integers between 0 and 1000
(defparameter data (loop for i from 1 to 1000 collect (random 1000)))
(defparameter data (loop for i from 1 to 100000 collect (random 100000)))
(defparameter h  (list 99999999 nil nil))

;;or is it
 ;; necessary??
  


(time (progn (dotimes (i 100)(testl-in h data))))
... 781ms, 151k cons cells ;; with 500 random numbers , maxdepth 115, avdepth 10.3
;;; with 5000 random numbers, I get, maxdepth 31, avdepth 13.5
....282ms, 154k cons cells
(time (progn (dotimes (i 100)(testl-out h 1000)))) 
... 281 ms 150k cons cells ??

;; ARRAY times
(defparameter g (create-heap :initial-size 2))
;; depends on whether g is big enough or not..
(time (progn (dotimes (i 100)(testa-in g data))))
... 219ms, 1028 cons cells, 1,050,526 other bytes 

(time (progn (dotimes (i 100)(testa-out g 1000))))
.. 1937 ms ????  1060 cons cells.


|#


;; a sorting program, for n>=1 items.
(defun mergesort(a); a is a list of numbers
  (cond ((null a) nil)
	(t (heapl2list (list2heapl a)))))

(defun list2heapl(a)
  (let ((h (list (car a) nil nil)))
    (loop for i in (cdr a) do (heap-insertl h i))
    h))

(defun heapl2list(h)  (loop while (car h)  collect (heap-removel h)))

	   

(defun maxdepth (h c)			; initially heap 0
  (cond ((null h) c)
	((leafp h) c)
	(t (max (maxdepth (cadr h) (1+ c))
		(maxdepth (caddr h) (1+ c))))))

(defun avdepth (h c)			; initially heap 0
  (cond ((null h) c)
	((leafp h) c)
	(t (* 0.5d0(+ (avdepth (cadr h) (1+ c))
		(avdepth (caddr h) (1+ c)))))))