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

(in-package "ZTREAM")

(import 'lazy:force)
(import 'lazy:suspend)

(export 'drop)
(export 'head)
(export 'isEmpty)
(export 'make-ztream)
(export 'tail)
(export 'take)
(export 'zappend)
(export 'zpush)
(export 'zreverse)

(defun make-ztream ()
  "Return an empty ZTREAM."
  (suspend make-ztream nil))

;;
;; Here are three accessors which are not in Okasaki.  I use them
;; here for convenience, especially convenience in testing.
;;
(defun ztream-p (x)
  "Return true if & only if X is a ZTREAM.  Actually, it's just an
approximation because not all functions are ZTREAMs."
  (functionp x))
(defun isEmpty (ztream)
  "Return true if & only if the ZTREAM is empty."
  (null (force ztream)))
(defun head (ztream) "Return first item from the ZTREAM"
  (car (force ztream)))
(defun tail (ztream)
  "Return the rest of the ZTREAM."
  (cdr (force ztream)))
(defun zpush (x z)
  (assert (ztream-p z))
  (suspend zpush-0
	   (cons x z)))

(defun zappend (a b)
  "Return a new ZTREAM which is the concatenation of A & B."
  (assert (ztream-p a))
  (assert (ztream-p b))
  (if (isEmpty a)
      b
    (let ((afirst (head a))
	  (atail (tail a)))
      (suspend zappend-2
	       (cons afirst (zappend atail b))))))

(defun take (n z)
  (declare (type integer n))
  (assert (ztream-p z))
  (cond ((zerop n) (suspend take-0 nil))
	((isEmpty z) (suspend take-1 nil))
	(t
	 ;; We evaluate Z now to reduce stack depth.  Clisp seems
	 ;; to have a very limited stack.  This might defeat alter
	 ;; of the performance characteristics of ZTREAMs from
	 ;; the implementation given in Okasaki.
	 (let ((zhead (head z))
	       (ztail (tail z)))
	   (suspend take-2
		    (cons zhead (take (1- n) ztail)))))))

(defun drop (n z)
  (declare (type integer n))
  (assert (ztream-p z))
  (cond ((zerop n) z)
	((isEmpty z) (suspend drop-0 nil))
	(t (drop (1- n) (tail z)))))

(defun zreverse (z)
  (labels
   ((zreverse2 (z2 r)
      (if (isEmpty z2)
	  r
	(let ((z2head (head z2))
	      (z2tail (tail z2)))
	  (zreverse2 z2tail
		    (suspend zreverse-0
			     (cons z2head r)))))))
   (zreverse2 z (suspend zreverse-1 nil))))

;;;
;;; For the insertion sort to perform minimal work each
;;; time you extract an element, it is CRITICAL that
;;; ZINSERT do minimal work.  (It's, like, "duh", but
;;; it took a long time to remember to implement
;;; ZINSERT that way, & until I did, I had an insertion
;;; sort which did all of its work the first time you
;;; evaluated the sorted ZTREAM.
;;;
(defun zinsert (x z lessp)
  "Insert X into Z in order, returning a new ZTREAM."
  (declare (type function lessp))
  (let ((z0 (force z)))
    (symbol-macrolet ((head (car z0))
		      (tail (cdr z0)))
      (cond ((null z0) (zpush x z))
	    ((funcall lessp x head) (zpush x z))
	    (t (zpush head
		      ;; This suspension is the critical part.
		      (suspend zinsert-0
			       (force (zinsert x tail lessp)))))))))

(defun insertion-sort (z lessp)
  "Return a new ZTREAM which is a sorted version of Z.  If
you remove the first K elements from the new ZTREAM, the
cost will be O(K * N), where N is the length of Z and also
the length of the new ZTREAM."
  (declare (type function lessp))
  (let ((z0 (force z)))
    (if (null z0)
	;; Empty ZTREAM is already sorted.
	z
      ;; Else
;; It works whether you use this next suspension or not (as
;; the expression following it does).  With the suspension,
;; it doesn't do any work until you extract the first
;; element from the sorted ZTREAM.  Without the suspension,
;; it does that exact same work immediately, so extracting
;; the first element is immediate.
;; If you embrace suspensions fully, you'd probably use the
;; version with the suspension, but since suspensions have
;; an overhead cost, since it seems likely that if you sort
;; a collection, you'll want at least the first element from
;; it, & since the cost of fetching that first element is
;; O(N), I choose to forgoe the suspension.
;; Note that the suspension within ZINSERT is critical!  You
;; can't do without it.
;;      (suspend insertion-sort-0
;;	       (let ((head (car z0))
;;		     (tail (insertion-sort (cdr z0) lessp)))
;;		 (force (zinsert head tail lessp)))))))
      (let ((head (car z0))
	    (tail (insertion-sort (cdr z0) lessp)))
	(zinsert head tail lessp)))))

;;;
;;; TESTS
;;;

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

(defun test0001 ()
  "Verify that MAKE-ZTREAM does not crash."
  (make-ztream)
  'test0001)

(defun test0002 ()
  "Verify that MAKE-ZTREAM returns an empty ZTREAM."
  (isEmpty (make-ztream)))

(defun test0003 ()
  "Verify that the HEAD of an empty ZTREAM is NIL."
  (null (head (make-ztream))))

(defun test0004 ()
  "Verify that the TAIL of an empty ZTREAM is NIL."
  (null (tail (make-ztream))))

(defun test0010 ()
  "Verify that the HEAD of a ZTREAM on which we just ZPUSHed a
thing is the thing."
  (eq (head (zpush 'thing (make-ztream)))
      'thing))

(defun test0015 ()
  "Verify that the TAIL of a ZTREAM containing one thing is
empty."
  (isEmpty (tail (zpush 'thing (make-ztream)))))

(defun test0100 ()
  "Test that if we have a ZTREAM of 1 thing, then we TAKE 1
thing from it, we get a ZTREAM whose HEAD is the thing."
  (eq (head (take 1 (zpush 'thing (make-ztream))))
      'thing))

(defun test0110 ()
  "Test that if we have a ZTREAM of 1 thing, then we DROP 1
thing from it, we get a ZTREAM that is empty."
  (isEmpty (drop 1 (zpush 'thing (make-ztream)))))

(defun test0200 ()
  "Test that we can REVERSE an empty ZTREAM & get an empty ZTREAM
in return."
  (isEmpty (zreverse (make-ztream))))

(defun test0210 ()
  "Test that we can REVERSE a ZTREAM of one item, & the new ZTREAM's
HEAD is the item."
  (eq (head (zreverse (zpush 'thing (make-ztream))))
      'thing))

(deftest test0230 ()
  "Test ZINSERT by inserting an item into an empty ZTREAM."
  (let ((z (zinsert 1 (make-ztream) #'<)))
    (and (eql (head z) 1)
	 (isEmpty (tail z)))))

(deftest test0232 ()
  "Test ZINSERT by inserting an item into a ZTREAM containing
one item.  The new item will go in front of the ZTREAM."
  (let ((z (zinsert 1 (zpush 2 (make-ztream)) #'<)))
    (and (eql (head z) 1)
	 (eql (head (tail z)) 2)
	 (isEmpty (tail (tail z))))))

(deftest test0234 ()
  "Test ZINSERT by inserting an item into a ZTREAM containing
one item.  The new item will go behind the item that's already
in the ZTREAM."
  (let ((z (zinsert 3 (zpush 2 (make-ztream)) #'<)))
    (and (eql (head z) 2)
	 (eql (head (tail z)) 3)
	 (isEmpty (tail (tail z))))))

(deftest test0236 ()
  "Test ZINSERT by inserting an item into a ZTREAM containing
two items.  The new item will be the second item of the new
ZTREAM."
  (let (z)
    ;; I broke the initialization steps into separate lines
    ;; for readability.
    ;; Start with a two-item ZTREAM.  Its elements will
    ;; be (2 4).
    (setq z (zpush 2 (zpush 4 (make-ztream))))
    ;; Insert 3.  We should get (2 3 4) in a ZTREAM.
    (setq z (zinsert 3 z #'<))
    ;; Check the results.
    (and (eql (head z) 2)
	 (eql (head (tail z)) 3)
	 (eql (head (tail (tail z))) 4)
	 (isEmpty (tail (tail (tail z)))))))

(deftest test0238 ()
  "Test ZINSERT by inserting an item into a ZTREAM containing
two items.  The new item will be the last item of the new
ZTREAM."
  (let (z)
    ;; I broke the initialization steps into separate lines
    ;; for readability.
    ;; Start with a two-item ZTREAM.  Its elements will
    ;; be (2 3).
    (setq z (zpush 2 (zpush 3 (make-ztream))))
    ;; Insert 4.  We should get (2 3 4) in a ZTREAM.
    (setq z (zinsert 4 z #'<))
    ;; Check the results.
    (and (eql (head z) 2)
	 (eql (head (tail z)) 3)
	 (eql (head (tail (tail z))) 4)
	 (isEmpty (tail (tail (tail z)))))))

(deftest test0250 ()
  "Test that INSERTION-SORT properly sorts an empty ZTREAM.
A properly sorted empty ZTREAM is an empty ZTREAM."
  (isEmpty (insertion-sort (make-ztream) #'<)))

(deftest test0252 ()
  "Test that INSERTION-SORT properly sorts a ZTREAM which
contains one element.  A properly ZTREAM of length 1 is
another ZTREAM of length 1 & containing that same element."
  (let* ((z0 (zpush 1 (make-ztream)))
	 (z1 (insertion-sort z0 #'<)))
    (and (eql (head z1) 1)
	 (isEmpty (tail z1)))))

(deftest test0254 ()
  "Test that INSERTION-SORT properly sorts a ZTREAM which
contains two element, 1 & 2.  A properly sorted version of
that ZTREAM is 1, then 2."
  (let ((z (insertion-sort (zpush 1 (zpush 2 (make-ztream))) #'<)))
    (and (eql (head z) 1)
	 (eql (head (tail z)) 2)
	 (isEmpty (tail (tail z))))))

(deftest test0256 ()
  "Like TEST0254 except that the initial order of the elements
is 2, then 1.  The proper sorted order is 1, then 2."
  (let ((z (insertion-sort (zpush 2 (zpush 1 (make-ztream))) #'<)))
    (and (eql (head z) 1)
	 (eql (head (tail z)) 2)
	 (isEmpty (tail (tail z))))))

(deftest test0258 ()
  "Like TEST0256 except that the ZTREAM contains 3 elements."
  (let ((z (insertion-sort (zpush 3 (zpush 2 (zpush 1 (make-ztream))))
			   #'<)))
    (and (eql (head z) 1)
	 (eql (head (tail z)) 2)
	 (eql (head (tail (tail z))) 3)
	 (isEmpty (tail (tail (tail z)))))))

(deftest test0260 (&optional (n 10))
  "Create a ZTREAM of 10 randomly selected numbers, sort it, &
verify that it is correctly sorted."
  (let ((z (make-ztream)))
    ;; Insert 10 random numbers into Z.
    (dotimes (i n) (setq z (zpush (random 100) z)))
    ;; Sort it.
    (setq z (insertion-sort z #'<))
    ;; Verify that it's sorted
    (do ((i 0 (1+ i))
	 (j -100 (head z0))
	 (z0 z (tail z0)))
	((or (>= i n)
	     (isEmpty z0)
	     (< (head z0) j))
	 ;; We have success if we inspected N items, &
	 ;; there are no more items.
	 (and (= i n) (isEmpty z0))))))

(deftest test0262 ()
  "Uses TEST0260 but for a ZTREAM of length 17."
  (test0260 17))

(defun perf-insertion-sort ()
  "Print a table of list lengths & number of comparisons
for INSERTION-SORT."
  (format t "~&   N     K  early count  later count")
  (format t "~&----  ----  -----------  -----------")
  (loop for n in '(256 512 1024) do
	(loop for k in (list 1 (floor (/ n 2)) n) do
	      (format t "~&~4D  ~4D" n k)
	      (let ((z (make-ztream))  (cmp-count 0))
		;; Fill the ZTREAM
		(dotimes (j n) (setq z (zpush (random 100) z)))
		;; Sort the ZTREAM, counting the comparisons.
		(setq z (insertion-sort z #'(lambda (a b)
					      (incf cmp-count)
					      (< a b))))
		(format t "  ~11D" cmp-count)
		;; Remove K items from the ZTREAM.  Due to delayed
		;; evaluation, this may update the comparison counter.
		(dotimes (i k) (setq z (tail z)))
		(format t "  ~11D" cmp-count)
		;; The ratio of the actual count & the theoretical
		;; count.
		(format t "  ~7,2F" (/ cmp-count (* n k)))
		;; The tatio of the actual count & the worse case
		;; count.
		(format t "  ~7,2F" (/ cmp-count (* n n)))))))

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