;;; -*- Mode: Lisp -*-
;;;
;;; $Header: /home/gene/library/website/docsrc/amo/RCS/chapter02.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-02"
  (:use "COMMON-LISP" "ORDERED")
  (:import-from "CYBERTIGGYR-TEST" "DEFTEST"))
(in-package "CHAPTER-02")

;;;
;;; Binary Search Trees
;;; This is a Lisp implementation of Unbalanced Set from page 14
;;; of Okasaki.
;;;

(defstruct bst
  value
  left
  right)

(defun xmember (x tree)
  "Return true if & only if X is contained in the binary search
tree, TREE."
  (and tree
       (let ((bst tree))
	 (declare (type bst bst))
	 (let ((value (bst-value bst)))
	   (cond ((xlt x value) (xmember x (bst-left bst)))
		 ((xgt x value) (xmember x (bst-right bst)))
		 ;; The code in Okasaki's book simply returns
		 ;; true, but if we return the value now, it
		 ;; will help us later, in Exercise 2.6.
		 (t value))))))

(defun insert (x tree)
  (if (null tree)
      (make-bst :value x :left nil :right nil)
    (let ((value (bst-value tree)))
      (cond ((xlt x value) (make-bst :value value
				     :left (insert x (bst-left tree))
				     :right (bst-right tree)))
	    ((xgt x value) (make-bst :value value
				     :left (bst-left tree)
				     :right (insert x (bst-right tree))))
	    (t tree)))))

;; These next few functions are not from Okasaki, but they
;; are useful for test programs.

(defun depth (tree)
  (if (null tree)
      0
    (1+ (max (depth (bst-left tree))
	     (depth (bst-right tree))))))

(defun is-complete (tree)
  "A tree is complete if its sub-trees are complete & have the
same depth."
  (or (null tree)
      (and (is-complete (bst-left tree))
	   (is-complete (bst-right tree))
	   (eql (depth (bst-left tree))
		(depth (bst-right tree))))))

(defun is-more-or-less-balanced (tree)
  (or (null tree)
      (and (>= 1
	       (abs (- (depth (bst-left tree))
		       (depth (bst-right tree)))))
	   (is-more-or-less-balanced (bst-left tree))
	   (is-more-or-less-balanced (bst-right tree)))))

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

(deftest test0010 ()
  "Test that we can create an empty tree without crashing.  It's not
really an empty tree because a true empty tree is NIL."
  (make-bst)
  'test0010)

(deftest test0050 ()
  "Test that INSERT into an empty tree does not crash."
  (insert 42 ()))

(deftest test0051 ()
  "Test that XMEMBER returns true if we look for an item
we just INSERTed into an empty tree."
  (xmember 42 (insert 42 nil)))

(deftest test0055 ()
  "Test that INSERT into a non-empty tree does not crash."
  (insert 51 (insert 1 (insert 42 nil)))
  'test0055)

(deftest test0057 ()
  "Test that XMEMBER can find all three items we insert into
a tree of three items."
  (let ((tree (insert 51 (insert 1 (insert 42 nil)))))
    (and (xmember 51 tree) (xmember 1 tree) (xmember 42 tree))))

;;;
;;; Exercise 2.2
;;;

(labels
    ((member3 (x tree candidate)
       (if (null tree)
	   (xeq x candidate)
	 (let ((value (bst-value tree)))
	   (if (xlt x value)
	       (member3 x (bst-left tree) candidate)
	     ;; else
	     (member3 x (bst-right tree) value))))))

  (defun tree-member-2-2 (x tree)
    ;; This IF is not a performance optimization; it would be
    ;; dumb to use it as a performance optimization.  Instead,
    ;; it's the easiest way to keep NIL out of the candidate.
    (if tree
	(member3 x tree (bst-value tree))
      nil)))

(deftest test0110 ()
  "Test that TREE-MEMBER-2-2 doesn't crash."
  (tree-member-2-2 42 nil)
  'test0110)

(deftest test0120 ()
  "Test that TREE-MEMBER-2-2 works on a tree of one element when
we search for that element."
  (tree-member-2-2 42 (insert 42 nil)))

(deftest test0130 ()
  "Test that TREE-MEMBER-2-2 does not find an element in a tree
of one when we don't search for the element that's in the tree."
  (not (tree-member-2-2 111 (insert 42 nil))))

(deftest test0140 ()
  "Test that TREE-MEMBER-2-2 finds all three items in a
three-item tree."
  (let ((tree (insert 1 (insert 3 (insert 2 nil)))))
    (and (tree-member-2-2 1 tree)
	 (tree-member-2-2 2 tree)
	 (tree-member-2-2 3 tree))))

(deftest test0150 ()
  "Test that TREE-MEMBER-2-2 does not find an item that is not
in the three."
  (not (tree-member-2-2 101 (insert 1 (insert 3 (insert 2 nil))))))

;;;
;;; Exercise 2.3
;;;

(labels
  ((insert2 (x tree root)
     (if (null tree)
	 (make-bst :value x :left nil :right nil)
       (let ((bst tree))
	 (declare (type bst bst))
	 (let ((value (bst-value bst)))
	   (cond ((xlt x value)
		  (make-bst :value value
			    :left (insert2 x (bst-left tree) root)
			    :right (bst-right bst)))
		 ((xgt x value)
		  (make-bst :value value
			    :left (bst-left bst)
			    :right (insert2 x (bst-right bst) root)))
		 (t (throw 'already-a-member root))))))))

  (defun insert-2-3 (x tree)
    (catch 'already-a-member
      (insert2 x tree tree))))

(deftest test0210 ()
  "Test that INSERT-2-3 does not crash."
  (insert-2-3 42 nil)
  'test0210)

(deftest test0220 ()
  "Test that TREE-INSERT-2-3 inserts an element into an empty
tree.  We have success if (a) the element was not found by
TREE-MEMBER, (b) then we use TREE-INSERT-2-3, & (c) then the
element is found by TREE-MEMBER."
  (and (not (xmember 42 nil))
       (xmember 42 (insert-2-3 42 nil))))

(deftest test0230 (&optional (tree nil) (lst ()))
  "Test that INSERT-2-3 inserts three elements into an
empty tree.  Once again, we have success if we cannot find
the element, then we insert it, then we can find it.  We do
that for each element."
  (if (endp lst)
      'test0230 ; nothing to insert, success
    (let* ((x (first lst))
	   (new-tree (insert-2-3 x tree)))
      (and
       ;; The item is not in the old tree.
       (not (xmember (first lst) tree))
       ;; The item is in the new tree.
       (xmember x new-tree)
       ;; We can insert the remaining items into the new
       ;; tree.
       (test0230 new-tree (rest lst))))))

;;;
;;; Exercise 2.4
;;;

(labels
  ((insert4 (x tree candidate root)
     (cond ((equal x candidate) (throw 'already-a-member root))
	   ((endp tree) (make-bst :value x))
	   ((< x (bst-value tree))
	    (insert4 x (bst-left tree) candidate root))
	   (t
	    (insert4 x (bst-right tree) (bst-value tree) root)))))

 (defun tree-insert-2-4 (x tree)
   (catch 'already-a-member
     (insert4 x tree (if tree (bst-value tree) nil) tree))))

(deftest test0310 ()
  "Test that TREE-INSERT-2-4 does not crash."
  (tree-insert-2-4 42 nil)
  'test0310)

(deftest test0320 ()
  "Test that TREE-INSERT-2-4 inserts an element into an empty
tree.  We have success if (a) the element was not found by
TREE-MEMBER, (b) then we use TREE-INSERT-2-4, & (c) then the
element is found by TREE-MEMBER."
  (let ((is-good (and (not (xmember 42 nil))
		      (xmember 42 (tree-insert-2-4 42 nil)))))
    (unless is-good
      (format t "~&~A: (~A 42 nil) returns ~S." 'test0320
	      'tree-insert-2-4 (tree-insert-2-4 42 nil)))
    is-good))

(deftest test0330 (&optional (tree nil) (lst ()))
  "Test that TREE-INSERT-2-4 inserts three elements into an
empty tree.  Once again, we have success if we cannot find
the element, then we insert it, then we can find it.  We do
that for each element."
  (if (endp lst)
      'test0330 ; nothing to insert, success
    (let* ((x (first lst))
	   (new-tree (tree-insert-2-4 x tree)))
      (and
       ;; The item is not in the old tree.
       (not (xmember (first lst) tree))
       ;; The item is in the new tree.
       (xmember x new-tree)
       ;; We can insert the remaining items into the new
       ;; tree.
       (test0330 new-tree (rest lst))))))

;;;
;;; Exercise 2.5.a
;;;

(defvar *complete-2-5-count* 0)

(defun complete-2-5 (x d)
  (incf *complete-2-5-count*)
  (if (zerop d)
      nil
    (let ((tree (complete-2-5 x (1- d))))
      (make-bst :value x :left tree :right tree))))

(deftest test0410 ()
  "Test that COMPLETE-2-5 makes complete trees.  The tree is
complete if the depth of its sub-trees are the same & if each
sub-tree is complete."
  (let* ((d 10)
	 (tree (complete-2-5 42 d))
	 (is-good (and (eql (depth tree) d)
		       (is-complete tree))))
    (unless is-good
      (format t "~&TEST0410: COMPLETE-2-5 returned ~S." tree))
    is-good))

(defun print-table-2-5-a (count)
  (with-open-file (strm "tab-ex-2-5-a.tex" :element-type 'character
			:direction :output :if-exists :rename-and-delete)
    (format strm "~&\\begin{tabular}{|r|r|r|} \\hline")
    (format strm "~&{\\bf n} & {\\bf seconds} {\\bf calls} \\\\ \\hline")
    (do ((dn (max (round (/ count 10)) 1))
	 (n 0 (+ n dn)))
	((> n count))
	(setq *complete-2-5-count* 0)
	(let ((start-time (get-internal-run-time)))
	  (complete-2-5 'print-table-2-5-a n)
	  (let ((end-time (get-internal-run-time)))
	    (format strm "~&~D & ~,2e & ~D \\\\ \\hline" n
		    (/ (- end-time start-time)
		     internal-time-units-per-second)
		    *complete-2-5-count*))))
    (format strm "~&\\end{tabular}")
    (format strm "~&")
    (truename strm)))

;;;
;;; Exercise 2.5.b
;;;

(defvar *balanced-2-5-count* 0)

(defun balanced-2-5 (x n)
  "Given a size, create a tree of size N & populate it with X.
The tree will be more-or-less balanced."
  (incf *balanced-2-5-count*)
  (cond ((zerop n) nil)
	((eql n 1) (make-bst :value x :left nil :right nil))
	((evenp (1- n))
	 (let ((subtree (balanced-2-5 x (/ (1- n) 2))))
	   (make-bst :value x :left subtree :right subtree)))
	(t (let* ((half (floor (/ (1- n) 2)))
		  (subtree (balanced-2-5 x half))
		  (subtree1 (balanced-2-5 x (1+ half))))
	     (make-bst :value x :left subtree :right subtree1)))))

(deftest test0510 ()
  "Test that BALANCED-2-5 makes more-or-less balanced trees.
The tree is more-or-less balanced if the heights of its
left & right children differ by at most one & the left &
right children are themselves balanced.  An empty tree is
balanced."
  (is-more-or-less-balanced (balanced-2-5 'x 43)))

(defun print-table-2-5-b (count)
  (with-open-file (strm "tab-ex-2-5-b.tex" :element-type 'character
			:direction :output :if-exists :rename-and-delete)
    (format strm "~&\\begin{tabular}{|r|r|r|r|} \\hline")
    (format strm "~&{\\bf n} & {\\bf seconds} & {\\bf calls} &")
    (format strm " {\\bf $\frac{calls}{lg N}$} \\\\ \\hline")
    (do ((dn (max (round (/ count 10)) 1))
	 (n 2 (+ n dn)))
	((> n count))
	(setq *balanced-2-5-count* 0)
	(let ((start-time (get-internal-run-time)))
	  (balanced-2-5 'print-table-2-5-a n)
	  (let ((end-time (get-internal-run-time)))
	    (format strm "~&~D & ~,2e & ~D & ~,2e \\\\ \\hline" n
		    (/ (- end-time start-time)
		     internal-time-units-per-second)
		    *balanced-2-5-count*
		    (/ *balanced-2-5-count* (log n 2))))))
    (format strm "~&\\end{tabular}")
    (format strm "~&")
    (truename strm)))

;;;
;;; Exercise 2.6
;;;

(defclass finite-map-node ()
  ((key :initarg :key :accessor finite-map-node-key)
   (value :initarg :value :accessor finite-map-node-value)))

(defmethod xeq ((x finite-map-node) (y finite-map-node))
  (xeq (finite-map-node-key x) (finite-map-node-key y)))
(defmethod xgeq ((x finite-map-node) (y finite-map-node))
  (xgeq (finite-map-node-key x) (finite-map-node-key y)))
(defmethod xgt ((x finite-map-node) (y finite-map-node))
  (xgt (finite-map-node-key x) (finite-map-node-key y)))
(defmethod xlt ((x finite-map-node) (y finite-map-node))
  (xlt (finite-map-node-key x) (finite-map-node-key y)))
(defmethod xlt ((x finite-map-node) (y (eql nil)))
  nil)
(defmethod xleq ((x finite-map-node) (y finite-map-node))
  (xleq (finite-map-node-key x) (finite-map-node-key y)))

(defun bind (key value map)
  (insert (make-instance 'finite-map-node :key key :value value) map))

;; This LOOKUP function satisfied the interface described in
;; Okasaki except that it does not throw.  When the key is
;; not found in the map, instead of tossing an exception, it
;; returns NIL.  So a key bound to NIL is indistinguishable
;; from a key that is not in the table.  I implemented it this
;; way because (a) it resembles the semantics of Common Lisp's
;; hash tables & (b) I dislike exceptions.
(defun lookup (x map)
  (let ((node (xmember (make-instance 'finite-map-node
				      :key x :value nil)
		       map)))
    (and node
	 (finite-map-node-value node))))

(deftest test0610 ()
  "Ensure that BIND doesn't crash."
  (bind "a" 1 nil)
  'test0610)

(deftest test0620 ()
  "Ensure that LOOKUP doesn't find something in NIL."
  (null (lookup "a" nil)))

(deftest test0630 ()
  "Ensure that LOOKUP does find the one item in a map of
one item."
  (eql (lookup "a" (bind "a" 1 nil))
       1))

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