;;; -*- Mode: Lisp -*-
;;;
;;; $Header: /home/gene/library/website/docsrc/amo/RCS/binomial-heap2.lisp,v 395.1 2008/04/20 17:25:45 gene Exp $
;;;
;;; Copyright (c) 2005 Gene Michael Stover.  All rights reserved.
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation; either version 2 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301
;;; USA
;;;

;;;
;;; This is an implementation of BINOMIAL HEAPs as requested for
;;; Exercise 3.6.  It's like that of package BINOMIAL-HEAP except
;;; that it stores rank more efficiently.
;;;

(defpackage "BINOMIAL-HEAP2"
  (:use "COMMON-LISP" "ORDERED")
  (:import-from "CYBERTIGGYR-TEST" "CHECK" "DEFTEST")
  (:import-from "UTILS" "HEAPSORT")
  (:export "DELETEMIN"
	   "FINDMIN"
	   "HEAP"
	   "INSERT"
	   "INSTREE"
	   "IS-HEAP"
	   "LINK"
	   "RANK"
	   "REMOVEMINTREE"
	   "ROOT"
	   "XMERGE"
	   "XTREE"))
(in-package "BINOMIAL-HEAP2")

(defstruct xtree x (c nil))

(defun xtree-rank (tree)
  "Return the rank of the binomial tree.  Actually compute the
rank, whereas in the BINOMIAL-HEAP package, the rank is stored &
we just return that."
  (cond ((null tree) -1)
	((endp (xtree-c tree)) 0)
	(t (1+ (reduce #'max (mapcar #'xtree-rank (xtree-c tree)))))))

(defstruct heapnode r tree)

;;;
;;; Heap is a list of HEAPNODE.
;;;

(defun is-heap (x)
  "Return true if & only if X is a binomial heap.  A binomial heap
is a list of binomial trees ordered in increasing rank."
  (and
   ;; A binomial heap is a list.
   (check (listp x))
   ;; Every element in the list is a HEAPNODE.
   (check (every #'heapnode-p x))
   ;; The rank of each HEAPNODE is less than the rank of the
   ;; next HEAPNODE (if there is a next).
   (check (every #'identity (maplist
			     #'(lambda (lst)
				 (let ((hn0 (first lst))
				       (hn1 (second lst)))
				   (or (null hn1)
				       (< (heapnode-r hn0)
					  (heapnode-r hn1)))))
			     x)))))

(defun rank (heapnode)
  (declare (type heapnode heapnode))
  (heapnode-r heapnode))

(defun root (tree)
  "Unchanged from the first binomial heap implementation.  Still
operates on a tree."
  (if tree
      (xtree-x tree)
    (error "~A: Can't get root of empty binomial tree" 'root)))

(defun link-trees (tree1 tree2)
  "Unchanged from the first binomial heap implementation.  Still
operates on trees."
  (if (xleq (xtree-x tree1) (xtree-x tree2))
      (make-xtree :x (xtree-x tree1)
		  :c (cons tree2 (xtree-c tree1)))
    ;; else
    (make-xtree :x (xtree-x tree2)
		:c (cons tree1 (xtree-c tree2)))))

(defun link-nodes (hn0 hn1)
  (declare (type (or heapnode null) hn0 hn1))
  (make-heapnode :r (1+ (heapnode-r hn0))
		 :tree (link-trees (heapnode-tree hn0)
				   (heapnode-tree hn1))))

(defun insTree (hn heap)
  "Insert the heapnode HN into the heap."
  (declare (type (or heapnode null) hn))
  (assert (is-heap heap))
  (cond ((null heap) (list hn))
        ((< (rank hn) (rank (first heap))) (cons hn heap))
        (t (insTree (link-nodes hn (first heap)) (rest heap)))))

(defun insert (x heap)
  (assert (is-heap heap))
  (insTree (make-heapnode :r 0
			  :tree (make-xtree :x x))
	   heap))

(defun xmerge (heap1 heap2)
  (declare (type list heap1 heap2))
  ;; (assert (is-heap heap1))
  ;; (assert (is-heap heap2))
  (symbol-macrolet ((hn1 (first heap1)) (r1 (rank hn1))
		    (rest1 (rest heap1))
		    (hn2 (first heap2)) (r2 (rank hn2))
		    (rest2 (rest heap2)))
    (cond ((endp heap2) heap1)
	  ((endp heap1) heap2)
	  ((< r1 r2) (cons hn1 (xmerge rest1 heap2)))
	  ((< r2 r1) (cons hn2 (xmerge heap1 rest2)))
	  (t (insTree (link-nodes hn1 hn2)
		      (xmerge rest1 rest2))))))

(defun removeMinHeapnode (heap)
  ;; These macro symbols are different ways of looking at HEAP.
  ;; The first & third are Lisp versions of Okasaki's Standard
  ;; ML code.  The second is useful because in this
  ;; implementation of binomial heap, a heap is a list of
  ;; heapnodes, & heapnodes contain trees.
  (assert heap)                         ; heap must not be empty
  (assert (is-heap heap))
  (symbol-macrolet ((heapnode (first heap))
		    (tree (heapnode-tree heapnode))
		    (hrest (rest heap)))
    (if (= (length heap) 1)
	(list heapnode nil)
      ;; else
      (destructuring-bind
	  (heapnode0 heap2) (removeMinHeapnode hrest)
	(symbol-macrolet ((tree0 (heapnode-tree heapnode0)))
            (if (xleq (root tree) (root tree0))
		(list heapnode hrest)
	      ;; else
	      (list heapnode0 (cons heapnode heap2))))))))

(defun findMin (heap)
  (destructuring-bind (heapnode heap0) (removeMinHeapnode heap)
    (declare (ignore heap0))
    (root (heapnode-tree heapnode))))

(defun deleteMin (heap)
  (destructuring-bind (heapnode heap2) (removeMinHeapnode heap)
    (xmerge
     (mapcar #'(lambda (tree)
		 (make-heapnode :r (xtree-rank tree)
				:tree tree))
	     (reverse (xtree-c (heapnode-tree heapnode))))
     heap2)))

(deftest test0100 ()
  "Test that INSERT an item into an empty heap returns a heap."
  (check (is-heap (insert 17 nil))))

(deftest test0110 ()
  "Test that findMin on a heap of 1 item returns the item we
INSERTed."
  (check (= (findMin (insert 17 nil)) 17)))

(deftest test0115 ()
  "Test that deleteMin on a heap of 1 item returns NIL."
  (check (null (deleteMin (insert 17 nil)))))

(deftest test0120 ()
  "Test that findMin on a heap of 2 items retrns the lesser
item."
  (check (= (findMin (insert 17 (insert 42 nil))) 17)))

(deftest test0121 ()
  "Test that deleteMin on a heap of 2 items gives us a heap
with one item, & it's the item we expected."
  (check (= (findMin (deleteMin (insert 17 (insert 42 nil)))) 42)))

(deftest test0122 ()
  "Test that deleteMin twice on a heap of 2 items gives us an
empty heap."
  (check (null (deleteMin (deleteMin (insert 17 (insert 42 nil)))))))

(deftest test0130 ()
  "Test findMin on a heap of 3 items."
  (check (= (findMin (insert 101 (insert 17 (insert 42 nil)))) 17)))

(deftest test0131 ()
  "Test findMin on a heap of 4 items."
  (check (= (findMin (insert 3 (insert 101 (insert 17 (insert 42 nil)))))
	    3)))

(deftest test0140 ()
  "Test INSERT, findMin, & deleteMin by using UTILS:HEAPSORT."
  (let* ((lst0 '(1 0 2 9 3 8 4 7 5 6))
	 (lst1 (heapsort lst0 nil #'insert #'findMin #'deleteMin)))
    (setq lst0 (sort lst0 #'<))
    (unless (equal lst0 lst1)
      (format t "~&~A: error" 'test0140)
      (format t " ~A is ~S." 'lst1 lst1)
      (format t " Expected ~S." lst0))
    (equal lst0 lst1)))

(deftest test0150 ()
  "Like TEST0140, but do it on a randomly generated list."
  (let* ((lst0 (loop for i from 1 to 10 collect (random 100)))
	 (lst1 (heapsort lst0 nil #'insert #'findMin #'deleteMin)))
    (setq lst0 (sort lst0 #'<))
    (unless (equal lst0 lst1)
      (format t "~&~A: error" 'test0150)
      (format t " ~A is ~S." 'lst1 lst1)
      (format t " Expected ~S." lst0))
    (equal lst0 lst1)))

(deftest test0155 ()
  "Run TEST0150 a bunch of times."
  (every #'identity (loop for i from 1 to 100 collect (test0150))))
  
;;; --- end of file ---