;;; -*- Mode: Lisp -*-
;;;
;;; $Header: /home/gene/library/website/docsrc/amo/RCS/binomial-heap.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
;;;

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

;; I hate the length of the name "binomial-tree", but
;; consistency reduces insanity.

(defstruct xtree (r 0) x (c nil))

(defun rank (tree)
  (if tree
      (xtree-r tree)
    0))

(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."
  (cond ((not (listp x))
	 (format t "~&~A: ~S is not a list." 'is-heap x)
	 nil)
	((not (every #'xtree-p x))
	 (format t "~&~A: ~S ~A ~A." 'is-heap x
		 "contains elements which are not"
		 "binomial trees")
	 nil)
	((not (every #'identity (maplist
				 #'(lambda (lst)
				     (let ((tree0 (first lst))
					   (tree1 (second lst)))
				       (or (null tree1)
					   (< (rank tree0)
					      (rank tree1)))))
				 x)))
	 (format t "~&~A: Trees are not in proper order."
		 'is-heap)
	 nil)
	(t)))

(defun root (tree)
  (if tree
      (xtree-x tree)
    (error "~A: Can't get root of empty binomial tree" 'root)))

(defun link (tree1 tree2)
  (if (xleq (xtree-x tree1) (xtree-x tree2))
      (make-xtree :r (1+ (xtree-r tree1))
		  :x (xtree-x tree1)
		  :c (cons tree2 (xtree-c tree1)))
    ;; else
    (make-xtree :r (1+ (xtree-r tree1))
		:x (xtree-x tree2)
		:c (cons tree1 (xtree-c tree2)))))

(defun insTree (tree heap)
  (assert (is-heap heap))
  (cond ((null heap) (list tree))
        ((< (rank tree) (rank (first heap))) (cons tree heap))
        (t (insTree (link tree (first heap)) (rest heap)))))

(defun insert (x heap)
  (assert (is-heap heap))
  (insTree (make-xtree :x x) heap))

(defun xmerge (heap1 heap2)
  (assert (is-heap heap1))
  (assert (is-heap heap2))
  (cond ((endp heap2) heap1)
        ((endp heap1) heap2)
        ((< (rank (first heap1)) (rank (first heap2)))
         (cons (first heap1) (xmerge (rest heap1) heap2)))
        ((< (rank (first heap2)) (rank (first heap1)))
         (cons (first heap2) (xmerge heap1 (rest heap2))))
        (t (insTree (link (first heap1) (first heap2))
                           (xmerge (rest heap1) (rest heap2))))))

(defun removeMinTree (heap)
  (assert heap)
  (assert (is-heap heap))
  (if (= (length heap) 1)
      (list (first heap) nil)
    ;; else
    (destructuring-bind (tree heap2) (removeMinTree (rest heap))
      (if (xleq (root (first heap)) (root tree))
	  (list (first heap) (rest heap))
	;; else
	(list tree (cons (first heap) heap2))))))

(defun findMin (heap)
  (root (first (removeMinTree heap))))

(defun deleteMin (heap)
  (destructuring-bind (tree heap2) (removeMinTree heap)
    (xmerge (reverse (xtree-c tree)) heap2)))

(deftest test0010 ()
  "Test that MAKE-XTREE doesn't crash."
  (make-xtree :x 2 :c nil))

(deftest test0020 ()
  "Test RANK on an empty tree."
  (zerop (rank nil)))

(deftest test0021 ()
  "Test RANK on a tree of one node."
  (= (rank (make-xtree :x 2)) 0))

(deftest test0050 ()
  "Test IS-HEAP on an empty heap."
  (is-heap nil))

(deftest test0051 ()
  "Test IS-HEAP on a heap with one tree in it."
  (is-heap (list (make-xtree :x 2))))

(deftest test0060 ()
  "Test ROOT on an empty binomial tree."
  (let ((is-good t))
    (ignore-errors
     (root nil)
     (setq is-good nil))
    is-good))

(deftest test0061 ()
  "Test ROOT on a binomial tree of one element."
  (= (root (make-xtree :x 2)) 2))

(deftest test0070 ()
  "Test LINK on two single-element trees."
  (let* ((tree1 (make-xtree :x 2))
	 (tree2 (make-xtree :x 3))
	 (link (link tree1 tree2)))
    (and (= (xtree-r link) 1)
	 (= (xtree-x link) 2)
	 (listp (xtree-c link))
	 (= (length (xtree-c link)) 1)
	 (eq (first (xtree-c link)) tree2))))

(deftest test0071 ()
  "Test LINK on two single-element trees.  Like TEST0070 but reverses
the two arguments."
  (let* ((tree1 (make-xtree :x 2))
	 (tree2 (make-xtree :x 3))
	 (link (link tree2 tree1)))
    (and (= (xtree-r link) 1)
	 (= (xtree-x link) 2)
	 (listp (xtree-c link))
	 (= (length (xtree-c link)) 1)
	 (eq (first (xtree-c link)) tree2))))

(deftest test0080 ()
  "Test INSTREE on an empty heap."
  (let* ((tree (make-xtree :x 2))
	 (heap (insTree tree ())))
    (and (is-heap heap)
	 (= (length heap) 1)
	 (eq (first heap) tree))))

(deftest test0081 ()
  "Test INSTREE on a heap of 1 item."
  (let* ((tree (make-xtree :x 2))
	 (heap0 (list (make-xtree :x 3)))
	 (heap (insTree tree heap0)))
    (and (is-heap heap)
	 (= (length heap) 1)
	 (= (xtree-r (first heap)) 1)
	 (= (xtree-x (first heap)) 2)
	 (listp (xtree-c (first heap)))
	 (= (xtree-r (first (xtree-c (first heap)))) 0)
	 (= (xtree-x (first (xtree-c (first heap)))) 3)
	 (endp (xtree-c (first (xtree-c (first heap))))))))

(deftest test0090 ()
  "Test INSERT, FINDMIN, & DELETEMIN on an empty heap by
inserting one element into it."
  (let ((heap (insert 17 nil)))
    (and (is-heap heap)
	 (= (findMin heap) 17)
	 (endp (deleteMin heap)))))

(deftest test0091 ()
  "Test INSERT, FINDMIN, & DELETEMIN on an empty heap by
inserting two elements into it."
  (let ((heap (insert 8 (insert 17 nil))))
    (cond ((not (is-heap heap))
	   (format t "~&~A: Heap isn't a heap." 'test0091)
	   nil)
	  ((not (= (findMin heap) 8))
	   (format t "~&~A: findMin returned ~A.  Expected 8." 'test0091
		   (findMin heap))
	   nil)
	  ((not (= (findMin (deleteMin heap)) 17))
	   (format t "~&~A: Second findMin returned ~A.  Expected 17."
		   'test0091 (findMin (deleteMin heap)))
	   nil)
	  ((not (endp (deleteMin (deleteMin heap))))
	   (format t "~&~A:" 'test0091)
	   (format t " After deleting two elements, heap should be")
	   (format t " empty.  It is ~S." heap)
	   nil)
	  (t))))

(deftest test0092 ()
  "Test deleteMin on a heap of many elements."
  (let ((heap (do ((i 0 (1+ i))
		   (heap nil (insert i heap)))
		  ((>= i 10) heap))))
    (do ((i 0 (1+ i)))
	((or (>= i 10) (null heap))
	 ;; Success if we've counted as high as we want, &
	 ;; the heap is empty (and not before).
	 (and (= i 10) (null heap)))
	(setq heap (deleteMin heap)))))

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