;;; -*- Lisp -*-
;; implementation of heap data structure in lists
;;; heapl is heap using lists.

(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 500 collect (> (random 2) 0))))
		(nconc h h)))
(defun yn ()(declare (special yesno)(optimize (speed 3)(safety 0))) (pop yesno))


(defun create-heapl (ic)			;initial contents.  ic  should be ordered.
  (cond ((null ic) nil)
	(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)
  (cond 
   ((null heap) (list x nil nil))

   ;;(here (car heap))
   ;;(left (car (cadr heap)))
   ;;(right (car (caddr heap)))
   ((> x (car heap))
    ;; move down to left or right...
    (if (pop yesno) 
	;;(> (random 2) 0)
	(setf (caddr heap)(heap-insertl (caddr heap) x))
      (setf (cadr heap) (heap-insertl (cadr heap) x)))
    heap)
   (t;; x is <= here
    (if (pop yesno)		
	;;(> (random 2) 0)
	(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)
  
  (let ((here (car heap))
	(newheap (merge-heapsl (cadr heap)(caddr heap))))
    (setf (car heap) (car newheap))
    (setf (cdr heap)(cdr newheap))
    here))


(defun merge-heapsl(a b) ;destructive
  (cond ((null a) b)
	((null b) a)
	((< (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 h (create-heapl '(123)))

(defparameter g (create-heap :initial-size 2))
(time (progn (dotimes (i 10)(testl-in h data))))
... 15ms, 30k cons cells
(time (progn (dotimes (i 10)(testl-out h 1000))))
.. 15 ms 106 cons cells.

;; ARRAY times
;; depends on whether g is big enough or not..
(time (progn (dotimes (i 10)(testa-in g data))))
... 16ms, 106 cons cells, 1,208 other bytes ; g already set
... 16ms, 176 cons cells, 121,400 other bytes ; g not set up.; uses vector-extend

(time (progn (dotimes (i 10)(testa-out g 1000))))
... 141 ms, 


|#


;; 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)
	(t (max (maxdepth (cadr h) (1+ c))
		(maxdepth (caddr h) (1+ c))))))

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