;;; -*- Mode: Lisp -*-
;;;
;;; $Header: /home/gene/library/website/docsrc/amo/RCS/chapter03.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 "CHAPTER-03"
  (:use "COMMON-LISP" "ORDERED")
  (:import-from "CYBERTIGGYR-TEST" "CHECK" "DEFTEST")
  (:import-from "UTILS" "FIRST-HALF" "HEAPSORT" "PAIRS" "SECOND-HALF"))
(in-package "CHAPTER-03")

(deftest test0000 ()
  "Null test.  Always succeeds."
  'test0000)

;;;
;;; Basic implementation of leftist heaps.
;;; This implementation is from Okasaki, Figure 3.2.
;;; Translated to Lisp from Standard ML by hand.
;;;

;;; Empty heap is NIL.
(defstruct heap r x left right)

(defun rank (heap)
  "Return the rank of the heap.  An empty heap has rank 0."
  (if heap
      (heap-r heap)
    0))

(defun maket (x a b)
  (if (>= (rank a) (rank b))
      (make-heap :r (1+ (rank b)) :x x :left a :right b)
    (make-heap :r (1+ (rank a)) :x x :left b :right a)))

(defun xmerge (heap1 heap2)
  (cond ((null heap2) heap1)
	((null heap1) heap2)
	(t (let ((x (heap-x heap1))
		 (a1 (heap-left heap1))
		 (b1 (heap-right heap1))
		 (y (heap-x heap2))
		 (a2 (heap-left heap2))
		 (b2 (heap-right heap2)))
	     (if (xleq x y)
		 (maket x a1 (xmerge b1 heap2))
	       (maket y a2 (xmerge heap1 b2)))))))

(defun insert (x heap)
  (xmerge (make-heap :r 1 :x x :right nil :left nil) heap))

(defun findMin (heap)
  (declare (type heap heap))
  (assert heap)                         ; will toss on NIL
  (heap-x heap))

(defun deleteMin (heap)
  (declare (type heap heap))
  (assert heap)                         ; will toss on NIL
  (xmerge (heap-left heap) (heap-right heap)))

(defun is-leftist (heap)
  "Return true if & only if HEAP is a leftist heap.  This function
isn't in Okasaki's book, but it's useful for testing."
  (if (null heap)
      t
    (and (>= (rank (heap-left heap)) (rank (heap-right heap)))
	 (is-leftist (heap-left heap))
	 (is-leftist (heap-right heap)))))

(deftest test0010 ()
  "Test that INSERT on an  empty heap (NIL) returns something
other than an empty heap."
  (insert 1 nil))

(deftest test0011 ()
  "Test that findMin returns the item we just inserted into an
empty heap."
  (eql (findMin (insert 2 nil)) 2))

(deftest test0012 ()
  "Insert 3 items into a heap, then use findMin & deleteMin
to examine all items in the heap.  They must exit the queue
in the order we expect."
  (let ((heap (insert 3 (insert 1 (insert 2 nil)))))
    (and (eql (findMin heap) 1)
	 (eql (findMin (deleteMin heap)) 2)
	 (eql (findMin (deleteMin (deleteMin heap))) 3)
	 (null (deleteMin (deleteMin (deleteMin heap)))))))

(deftest test0020 ()
  "Start with an empty leftist heap, insert a bunch of items
into it, & check that it is a valid leftist heap after each
insertion."
  (do ((heap nil (insert (random 100) heap))
       (count 0 (1+ count)))
      ((or (not (is-leftist heap)) (>= count 100))
       (is-leftist heap))))

;;;
;;; Exercise 3.2
;;;

(defun insert-3-2 (x heap)
  "Insert item X into the HEAP, returning a new heap, & without
calling XMERGE."
  (cond ((null heap)
         ;; If we insert an item into an empty heap, the new
         ;; heap has just one item -- our new item.  Our
         ;; MAKET function does that.
         (maket x nil nil))
        ((xleq x (heap-x heap))
         ;; The new item X comes before the current node's item.
         ;; So we make a new heap with X as its item, & we push
         ;; the current node's item into one of the subtrees.
         (makeT x (heap-left heap) (insert-3-2 (heap-x heap)
                                               (heap-right heap))))
        (t
         ;; X comes after the current node, so we recursively insert
         ;; it into a subtree.
         (makeT (heap-x heap)
                (heap-left heap)
                (insert-3-2 x (heap-right heap))))))

(deftest test0030 ()
  "Test that INSERT-3-2 on an empty heap does not crash."
  (insert-3-2 3 nil)
  'test0030)

(deftest test0031 ()
  "Test that INSERT-3-2 on a heap of one element does not crash."
  (insert-3-2 3 (insert-3-2 1 (insert-3-2 2 nil)))
  'test0031)

(deftest test0032 ()
  "Test that INSERT-3-2 always returns a valid leftist heap.
Do this by starting with an empty heap & inserting a bunch of
things into it.  This test is almost identical to TEST0020."
  (do ((heap nil (insert-3-2 (random 100) heap))
       (count 0 (1+ count)))
      ((or (not (is-leftist heap)) (>= count 100))
       (is-leftist heap))
      (unless (is-leftist heap)
        (format t "~&~A: ~A failed." 'test0032 'insert-3-2)
        (format t " No longer a leftist heap.")
        (format t "~&~S" heap))))

(deftest test0035 ()
  "Test that, after INSERT-3-2 into an empty heap, findMin
returns the item we inserted."
  (let ((x 3))
    (eql (findMin (insert-3-2 x nil)) x)))

(deftest test0036 ()
  "Test that, after INSERT-3-2 into an empty heap, deleteMin
returns an empty heap."
  (null (deleteMin (insert-3-2 3 nil))))

(deftest test0037 ()
  "Use INSERT-3-2 to insert 3 items into a heap, then use
findMin & deleteMin to examine all items in the heap.  They
must exit the queue in the order we expect.  This is like
TEST0012."
  (let ((heap (insert-3-2 3 (insert-3-2 1 (insert-3-2 2 nil)))))
    (and (eql (findMin heap) 1)
         (eql (findMin (deleteMin heap)) 2)
         (eql (findMin (deleteMin (deleteMin heap))) 3)
         (null (deleteMin (deleteMin (deleteMin heap)))))))

;;;
;;; This is my second solution to INSERT-3-2B.  It doesn't
;;; work.  I tried to improve the performance of INSERT-3-2
;;; by eliminating some of the recursion.  I kept it as a
;;; reminder of what kind of recursion-elimination trick does
;;; not work.
;;;
(defun insert-3-2b (x heap)
  "This is my second solution to Exercise 3.2.  It removes some
recursion.  I'll do a performance test to compare it to
INSERT-3-2 to satisfy my curiosity.
Insert item X into the HEAP, returning a new heap, & without
calling XMERGE."
  ;; Search a right path until we find an item which is
  ;; greater than or equal to X or we find the end of the
  ;; tree.  This loop removes the recursion from the third
  ;; arm of the COND in INSERT-3-2.
  ;; Notice that the loop alters HEAP.
  (do ()
      ((or (null heap) (xleq x (heap-x heap))))
      (setq heap (heap-right heap)))
  ;; Now we do what we would do in INSERT-3-2.
  (cond ((null heap)
         ;; If we insert an item into an empty heap, the new
         ;; heap has just one item -- our new item.  Our
         ;; MAKET function does that.
         (maket x nil nil))
        ((xleq x (heap-x heap))
         ;; The new item X comes before the current node's item.
         ;; So we make a new heap with X as its item, & we push
         ;; the current node's item into one of the subtrees.
         (makeT x (heap-left heap) (insert-3-2b (heap-x heap)
                                                (heap-right heap))))
        (t
         ;; X comes after the current node, so we recursively insert
         ;; it into a subtree.
         (makeT (heap-x heap)
                (heap-left heap)
                (insert-3-2b x (heap-right heap))))))

(deftest test0040 ()
  "Test that INSERT-3-2B on an empty heap does not crash."
  (insert-3-2b 3 nil)
  'test0040)

(deftest test0041 ()
  "Test that INSERT-3-2B on a heap of one element does not crash."
  (insert-3-2b 3 (insert-3-2b 1 (insert-3-2b 2 nil)))
  'test0041)

(deftest test0042 ()
  "Test that INSERT-3-2B always returns a valid leftist heap.
Do this by starting with an empty heap & inserting a bunch of
things into it.  This test is almost identical to TEST0020."
  (do ((heap nil (insert-3-2b (random 100) heap))
       (count 0 (1+ count)))
      ((or (not (is-leftist heap)) (>= count 100))
       (is-leftist heap))
      (unless (is-leftist heap)
        (format t "~&~A: ~A failed." 'test0042 'insert-3-2b)
        (format t " No longer a leftist heap.")
        (format t "~&~S" heap))))

(deftest test0045 ()
  "Test that, after INSERT-3-2B into an empty heap, findMin
returns the item we inserted."
  (let ((x 3))
    (eql (findMin (insert-3-2b x nil)) x)))

(deftest test0046 ()
  "Test that, after INSERT-3-2B into an empty heap, deleteMin
returns an empty heap."
  (null (deleteMin (insert-3-2b 3 nil))))

(deftest test0047 ()
  "Test that insert-3-2B does NOT work.
Use INSERT-3-2B to insert 3 items into a heap, then use
findMin & deleteMin to examine all items in the heap.  They
must exit the queue in the order we expect.  This is like
TEST0012."
  (not
   (let ((heap (insert-3-2b 3 (insert-3-2b 1 (insert-3-2b 2 nil)))))
     (and (eql (findMin heap) 1)
          (eql (findMin (deleteMin heap)) 2)
          (eql (findMin (deleteMin (deleteMin heap))) 3)
          (null (deleteMin (deleteMin (deleteMin heap))))))))

;;;
;;; Exercise 3.3
;;;
;;; I wrote three solutions to Exrecise 3.3.  The fastest one, &
;;; the one that's my official answer, is FROM-LIST-01.
;;;

(labels
    ((m00 (lst)
       (case (length lst)
	 (0 nil)                        ; empty heap
	 (1 (first lst))
	 (2 (apply #'xmerge lst))
	 (otherwise (xmerge (m00 (first-half lst))
			    (m00 (second-half lst)))))))

  (defun from-list-00 (lst)
    "This is my first solution to Exercise 3.3.  Its helper
function, M00, breaks the list into a fist half & a second
half & calls itself on the halves.
Given a list of elements, insert them into a leftist heap &
return the new heap.  Operates in O(N) time, where N is the
length of the list."
    (declare (type list lst))
    (m00
     ;; Convert each item in LST into a single-element heap.
     (mapcar #'(lambda (x) (makeT x nil nil)) lst))))

(defun test0050 (&optional (fn #'from-list-00))
  "Test that FROM-LIST on an empty list returns an empty heap."
  (declare (type function fn))
  (null (funcall fn ())))

(deftest test0051 (&optional (fn #'from-list-00))
  "Test that FROM-LIST on a list of one element returns a heap of
that one element."
  (declare (type function fn))
  (let ((heap (funcall fn '(17))))
    (and (is-leftist heap)
         (eql (findMin heap) 17)
         (null (deleteMin heap)))))

(deftest test0052 (&optional (fn #'from-list-00))
  "Test that FROM-LIST on a list of two elements returns a heap of
those two elements."
  (declare (type function fn))
  (let ((heap (funcall fn '(17 8))))
    (and (is-leftist heap)
         (eql (findMin heap) 8)
         (eql (findMin (deleteMin heap)) 17)
         (null (deleteMin (deleteMin heap))))))

(deftest test0053 (&optional (fn #'from-list-00))
  "Test that FROM-LIST on a list of three elements returns a heap of
those three elements."
  (declare (type function fn))
  (let ((heap (funcall fn '(17 8 11))))
    (and (is-leftist heap)
         (eql (findMin heap) 8)
         (eql (findMin (deleteMin heap)) 11)
         (eql (findMin (deleteMin (deleteMin heap))) 17)
         (null (deleteMin (deleteMin (deleteMin heap)))))))

(deftest test0054 (&optional (fn #'from-list-00) (n 4))
  "Test that FROM-LIST on a list of N elements returns a heap of
those N elements."
  (declare (type function fn) (type integer n))
  (let ((lst (loop for i from 1 to n collect (random 100))))
    (do ((i 0 (1+ i))
         (heap (funcall fn lst) (deleteMin heap))
         (x (sort (copy-list lst) #'<) (rest x)))
        ((or (null heap) (not (eql (findMin heap) (first x))))
         (null heap)))))

(deftest test0055 (&optional (fn #'from-list-00))
  "Like TEST0054, but works on a list of 100 elements."
  (test0054 fn 100))

(labels
    ((m01 (lst)
       (case (length lst)
         (0 nil)                        ; empty heap
         (1 (first lst))
         (2 (apply #'xmerge lst))
         (otherwise (m01 (mapcar #'(lambda (lst2)
                                     (apply #'xmerge lst2))
                                 (pairs lst)))))))

  (defun from-list-01 (lst)
    "This is my second solution to Exercise 3.3.  Its helper
function, M01, breaks the list into pairs, merges the pairs,
then calls itself on the result.
Given a list of elements, insert them into a leftist heap &
return the new heap.  Operates in O(N) time, where N is the
length of the list."
    (declare (type list lst))
    (m01
     ;; Convert each item in LST into a single-element heap.
     (mapcar #'(lambda (x) (makeT x nil nil)) lst))))

(defun test0060 ()
  "Test that FROM-LIST on an empty list returns an empty heap."
  (test0050 #'from-list-01))

(deftest test0061 ()
  "Test that FROM-LIST on a list of one element returns a heap of
that one element."
  (test0051 #'from-list-01))

(deftest test0062 ()
  "Test that FROM-LIST on a list of two elements returns a heap of
those two elements."
  (test0052 #'from-list-01))

(deftest test0063 ()
  "Test that FROM-LIST on a list of three elements returns a heap of
those three elements."
  (test0053 #'from-list-01))

(deftest test0064 ()
  "Test that FROM-LIST on a list of N elements returns a heap of
those N elements."
  (test0054 #'from-list-01))

(deftest test0065 ()
  "Like TEST0054, but works on a list of 100 elements."
  (test0055 #'from-list-01))

(labels
    ((m02 (lst)
       (do ((x lst (mapcar #'(lambda (lst2)
			      (apply #'xmerge lst2))
			  (pairs x))))
	   ((<= (length x) 1)
	    (first x)))))

  (defun from-list-02 (lst)
    "This is my second solution to Exercise 3.3.  Its helper
function, M02, breaks the list into pairs, merges the pairs,
then calls itself on the result.
Given a list of elements, insert them into a leftist heap &
return the new heap.  Operates in O(N) time, where N is the
length of the list."
    (declare (type list lst))
    (m02
     ;; Convert each item in LST into a single-element heap.
     (mapcar #'(lambda (x) (makeT x nil nil)) lst))))

(defun test0070 ()
  "Test that FROM-LIST on an empty list returns an empty heap."
  (test0050 #'from-list-02))

(deftest test0071 ()
  "Test that FROM-LIST on a list of one element returns a heap of
that one element."
  (test0051 #'from-list-02))

(deftest test0072 ()
  "Test that FROM-LIST on a list of two elements returns a heap of
those two elements."
  (test0052 #'from-list-02))

(deftest test0073 ()
  "Test that FROM-LIST on a list of three elements returns a heap of
those three elements."
  (test0053 #'from-list-02))

(deftest test0074 ()
  "Test that FROM-LIST on a list of N elements returns a heap of
those N elements."
  (test0054 #'from-list-02))

(deftest test0075 ()
  "Like TEST0054, but works on a list of 100 elements."
  (test0055 #'from-list-02))

;;;
;;; Exercise 3.4
;;;

(defstruct wheap weight x left right)

(defun weight (heap)
  "Return the weight of the heap.  An empty heap has weight 0."
  (if heap
      (wheap-weight heap)
    0))

(defun wmaket (x a b)
  (if (>= (weight a) (weight b))
      (make-wheap :weight (+ (weight a) (weight b) 1)
                  :x x :left a :right b)
    ;; else
    (make-wheap :weight (+ (weight a) (weight b) 1)
                :x x :left b :right a)))

(defun wmerge (heap1 heap2)
  (cond ((null heap2) heap1)
	((null heap1) heap2)
	(t (let ((x (wheap-x heap1))
		 (a1 (wheap-left heap1))
		 (b1 (wheap-right heap1))
		 (y (wheap-x heap2))
		 (a2 (wheap-left heap2))
		 (b2 (wheap-right heap2)))
	     (if (xleq x y)
		 (wmaket x a1 (wmerge b1 heap2))
	       (wmaket y a2 (wmerge heap1 b2)))))))

(defun winsert (x heap)
  (wmerge (make-wheap :weight 1 :x x :right nil :left nil) heap))

(defun wfindMin (heap)
  (declare (type wheap heap))
  (assert heap)                         ; will toss on NIL
  (wheap-x heap))

(defun wdeleteMin (heap)
  (declare (type wheap heap))
  (assert heap)                         ; will toss on NIL
  (wmerge (wheap-left heap) (wheap-right heap)))

(defun is-weighted-leftist (heap)
  "Return true if & only if HEAP is a weight-biased leftist
heap.  This function isn't in Okasaki's book, but it's useful
for testing."
  (if (null heap)
      t
    (and (>= (weight (wheap-left heap)) (weight (wheap-right heap)))
	 (is-weighted-leftist (wheap-left heap))
	 (is-weighted-leftist (wheap-right heap)))))

(deftest test0110 ()
  "Test that INSERT on an  empty heap (NIL) returns something
other than an empty heap."
  (winsert 1 nil))

(deftest test0111 ()
  "Test that findMin returns the item we just inserted into an
empty heap."
  (eql (wfindMin (winsert 2 nil)) 2))

(deftest test0112 ()
  "Insert 3 items into a heap, then use findMin & deleteMin
to examine all items in the heap.  They must exit the queue
in the order we expect."
  (let ((heap (winsert 3 (winsert 1 (winsert 2 nil)))))
    (and (eql (wfindMin heap) 1)
	 (eql (wfindMin (wdeleteMin heap)) 2)
	 (eql (wfindMin (wdeleteMin (wdeleteMin heap))) 3)
	 (null (wdeleteMin (wdeleteMin (wdeleteMin heap)))))))

(deftest test0120 ()
  "Start with an empty leftist heap, winsert a bunch of items
into it, & check that it is a valid leftist heap after each
winsertion."
  (do ((heap nil (winsert (random 100) heap))
       (count 0 (1+ count)))
      ((or (not (is-weighted-leftist heap)) (>= count 100))
       (is-weighted-leftist heap))))

;;;
;;; Exercise 3.4, part C
;;;

(labels
    ((m00 (stack a b)
       (cond ((null a)
              ;; Use the stack to call WmakeT to build the heap.
              (reduce #'(lambda (&optional x y)
                          (cond ((null x) y)
                                ((null y) x)
                                ((typep x 'wheap)
                                 (WmakeT (first y) (second y) x))
                                (t      ; X is a list, Y is a heap
                                 (WmakeT (first x) (second x) b))))
                      stack
                      :initial-value b))
             ((null b)
              ;; Like the previous case, but B is empty.  Instead
              ;; of duplicating the code, we'll swap A & B to use
              ;; the previous chunk of code.
              (m00 stack b a))
             ((xleq (wheap-x a) (wheap-x b))
              ;; A's X goes into a new node.  A's left will be
              ;; one of the subtrees.  We'll merge A's right &
              ;; B to make the other subtree.
              (m00 (cons (list (wheap-x a) (wheap-left a)) stack)
                   (wheap-right a)
                   b))
             (t                         ; A's X > B's X
              (m00 (cons (list (wheap-x b) (wheap-left b)) stack)
                   (wheap-right b)
                   a)))))

  (defun wmerge-3-4c (heap1 heap2)
    "This is the top-down merge for Part C of Exercise 3.4."
    (m00 () heap1 heap2)))

(deftest test0130 ()
  "Test WMERGE-3-4C by merging two empty heaps."
  (null (wmerge-3-4c nil nil)))

(deftest test0131 ()
  "Test WMERGE-3-4C by merging a heap of one element with an
empty heap."
  (let ((heap (wmerge-3-4c (wmaket 17 nil nil) nil)))
    (assert (eql (WfindMin heap) 17))
    (assert (null (WdeleteMin heap))))
  'test0131)

(deftest test0132 ()
  "Like TEST0131 but reverses the order of the singleton heap &
the empty heap."
  (let ((heap (wmerge-3-4c nil (wmaket 17 nil nil))))
    (assert (eql (WfindMin heap) 17))
    (assert (null (WdeleteMin heap))))
  'test0132)

(deftest test0135 ()
  "Test WMERGE-3-4C by merging two singleton heaps."
  (let ((heap (wmerge-3-4c (wmaket 11 nil nil)
                           (wmaket 17 nil nil))))
    (assert (eql (WfindMin heap) 11))
    (assert (eql (WfindMin (WdeleteMin heap)) 17))
    (assert (null (WdeleteMin (WdeleteMin heap)))))
  'test0135)

(deftest test0140 ()
  "Test WMERGE-3-4C by merging two larger heaps."
  (let* ((alst '(1 3 5 7 9))
         (aheap (reduce #'(lambda (heap x) (Winsert x heap))
                        alst
                        :initial-value nil))
         (blst '(2 4 6 8))
         (bheap (reduce #'(lambda (heap x) (Winsert x heap))
                        blst
                        :initial-value nil)))
    (do ((heap (Wmerge-3-4c aheap bheap) (WdeleteMin heap))
         (biglst (sort (append alst blst) #'<) (rest biglst)))
        ((or (null heap)
             (not (is-weighted-leftist heap))
             (not (eql (WfindMin heap) (first biglst))))
         (null heap)))))

;;;
;;; Exercise 3.5
;;;

(defun findMin-3-5 (heap)
  ; (assert (binomial-heap:is-heap heap))
  (let ((min0 (binomial-heap:root (first heap))))
    (if (= (length heap) 1)
	min0
      ;; else
      (let ((min1 (findMin-3-5 (rest heap))))
	(if (xleq min0 min1)
	    min0
	  ;; else
	  min1)))))

(deftest test0150 ()
  "Test findMin-3-5 on an empty heap.  It should cause an
exception, which we'll ignore.  For this test, an exception
is success."
  (let ((is-good t))
    (ignore-errors (findMin-3-5 nil)
		   (setq is-good nil))
    is-good))

(deftest test0151 ()
  "Test findMin-3-5 on a heap of one element."
  (check (eql (findMin-3-5 (binomial-heap:insert 17 nil)) 17)))

(deftest test0152 ()
  "Test findMin-3-5 on a heap of two elements."
  (let ((heap (binomial-heap:insert
	       17
	       (binomial-heap:insert 8 nil))))
    (and (check (= (findMin-3-5 heap) 8))
	 (check (= (findMin-3-5 (binomial-heap:deleteMin heap)) 17)))))

(deftest test0153 ()
  "Test findMin-3-5 on a heap of three elements."
  (let ((count 3))
    (labels
	((init-heap () (do ((i 0 (1+ i))
			    (heap nil (binomial-heap:insert i heap)))
			   ((>= i count) heap))))
    (do ((heap (init-heap) (binomial-heap:deleteMin heap))
	 (i 0 (1+ i)))
	((or (>= i count) (null heap) (not (= (findMin-3-5 heap) i)))
	 (and (= i count) (null heap)))))))

;;;
;;; Exercise 3.7
;;;

(defmacro def-explicit-min (basename insert findMin deleteMin)
  (let ((xmaker (intern (format nil "~A-~A" 'make basename)))
        (xmin (intern (format nil "~A-~A" basename 'min)))
        (xheap (intern (format nil "~A-~A" basename 'heap)))
        (xinsert (intern (format nil "~A-~A" basename 'insert)))
        (xfindMin (intern (format nil "~A-~A" basename 'findMin)))
        (xdeleteMin (intern (format nil "~A-~A" basename 'deleteMin)))
        (arg-x (gensym))
        (arg-heap (gensym))
        (tmp (gensym)))
    `(progn
       (defstruct ,basename min heap)
       (defun ,xinsert (,arg-x ,arg-heap)
         (declare (type (or ,basename null) ,arg-heap))
         (if ,arg-heap
             (,xmaker :min (if (xleq ,arg-x (,xmin ,arg-heap))
                               ,arg-x
                             (,xmin ,arg-heap))
                      :heap ,(if (symbolp insert)
                                 `(,insert ,arg-x (,xheap ,arg-heap))
                               `(funcall ,insert ,arg-x (,xheap ,arg-heap))))
           (,xmaker :min ,arg-x
                    :heap ,(if (symbolp insert)
                               `(,insert ,arg-x nil)
                             `(funcall ,insert ,arg-x nil)))))
       (defun ,xfindMin (,arg-heap)
         (declare (type ,basename ,arg-heap))
         (,xmin ,arg-heap))
       (defun ,xdeleteMin (,arg-heap)
         (declare (type ,basename ,arg-heap))
         (let ((,tmp ,(if (symbolp insert)
                          `(,deleteMin (,xheap ,arg-heap))
                        `(funcall ,deleteMin (,xheap ,arg-heap)))))
           ;; The only weird thing about this deleteMin is that
           ;; we must check for NIL.  If our implementation's
           ;; deleteMin gives us NIL, we don't create a heap object
           ;; around it.  We return NIL for NIL.  Otherwise, we
           ;; create a heap object around the object our
           ;; implementation returned.
           (if ,tmp
               (,xmaker :min ,(if (symbolp findMin)
                                  `(,findMin ,tmp)
                                `(funcall ,findMin ,tmp))
                        :heap ,tmp)
             nil)))
       '(,xmaker ,xmin ,xheap ,xinsert ,xfindMin ,xdeleteMin
                 ,arg-x ,arg-heap ,tmp))))

;;; Here's an ExplicitMin module for testing.
(def-explicit-min toasty binomial-heap:insert binomial-heap:findMin
  binomial-heap:deleteMin)

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

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

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

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

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

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

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

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

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

(deftest test0255 ()
  "Run TEST0250 a bunch of times."
  (every #'identity (loop for i from 1 to 100 collect (test0250))))

;;; --- end of file ---