;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:CL -*-

;;; Dependencies: DJ:JRM;CUSTOM

;;; Implementaion of CALL-BY-NEED ala Abelson and Sussman
;;; See Structure and Interpretation of Computer Programs by Abelson and Sussman
;;; Chapter 3 Modularity and State

(defstruct (latered (:conc-name "LATERED-")
		    (:constructor make-latered (evaluated? value))
		    (:print-function print-latered-object))
  evaluated?
  value)

;;;Continuation passing style selector.

(defsubst spread-latered (latered receiver)
  "Funcall RECEIVER on the elements of LATERED."
  (funcall receiver
	   (latered-evaluated? latered)
	   (latered-value      latered)))

;;; The value of a latered is either a thunk or the value computed from a thunk.
;;; The evaluated flag tells us which.  This must be a macro to avoid evaluating
;;; the sexpr.

(defmacro later (sexpr)
  `(MAKE-LATERED
     NIL
     #'(LAMBDA () ,sexpr)))

;;; Now forces the evaluation of a latered.  If it is already forced, we just get
;;; the old value.

(defun now (latered)
  "Force evaluation of a LATERED object."
  (spread-latered latered
    #'(lambda (evaluated? value)
	(if evaluated?
	    value
	    (let ((real-value (funcall value)))
	      (setf (latered-evaluated? latered) t
		    (latered-value      latered) real-value)
	      real-value)))))
	    
(defvar *latered-object-print-depth* 5)
(defvar *latered-object-current-print-depth* 0)

(defun print-latered-object (object stream depth)
  (declare (ignore depth))
  (si:printing-random-object (object stream :type)
    (spread-latered object
      #'(lambda (evaluated? value)
	  (if evaluated?
	      (if (or (null? *latered-object-print-depth*)
		      (< *latered-object-current-print-depth*
			 *latered-object-print-depth*))
		  (let ((*latered-object-current-print-depth*
			  (1+ *latered-object-current-print-depth*)))
		    (format stream "(~S)" value))
		  (format stream "#" value))
	      (format stream "(Unforced)"))))))

;;; A chain is a structure with a head and a latered tail.

(defstruct (chain (:conc-name "CHAIN-")
		  (:constructor make-chain (head tail))
		  (:print-function chain-print))
  head
  tail)

(defmacro cons-chain (head tail)
  `(MAKE-CHAIN
     ,head
     (LATER ,tail)))

(defmacro head (chain)
  `(CHAIN-HEAD ,chain))

;;; Asking for the tail automatically forces evaluation.

(defmacro tail (chain)
  `(NOW (CHAIN-TAIL ,chain)))

(defconstant the-empty-chain nil)
(deff empty-chain? #'null?)

(defvar *print-chain-length* 5)

;;; Hairy chain printer.

(defun print-chain (chain depth)
  (let ((*print-chain-length* depth))
    (chain-print chain terminal-io nil)))

(defun chain-print (chain stream depth)
  (declare (ignore depth))
  (si:printing-random-object (chain stream :type :no-pointer)
    (format stream "{")
    (unless (empty-chain? chain)
      (let ((chain chain))
	(block print-chain-loop
	  (do ((count *print-chain-length* (1- count)))
	      ((zero? count) (format stream "..."))
	    (let ((head (chain-head chain))
                  (tail (chain-tail chain)))
	      (format stream "~S" head)
	      (spread-latered tail
		#'(lambda (evaluated? value)
		    (cond ((not evaluated?) (format stream " ...") (return-from print-chain-loop (values)))
			  ((empty-chain? value) (return-from print-chain-loop (values)))
			  ('else (format stream " ") (setq chain value))))))))))
    (format stream "}")))
	    
;;; A very useful test.

(defun stop-on-chain-end (c if-not-stopping)
  (if (empty-chain? c)
      the-empty-chain
      (funcall if-not-stopping)))

;;; Useful chain operations.

(defun singleton-chain (element)
  (cons-chain element the-empty-chain))

(defun nth-chain (n chain)
  "Return the nth element of the chain."
  (do ((count n (decf count))
       (chain chain (tail chain)))
      ((zerop count) (head chain))))

(defun map-across-chains (function chain1 chain2)
  "Returns a chain which is the result of applying FUNCTION to the consecutive
heads of the CHAINS."
  (stop-on-chain-end chain1
    #'(lambda ()
	(stop-on-chain-end chain2
	  #'(lambda ()
	      (cons-chain (funcall function (head chain1) (head chain2))
			  (map-across-chains function (tail chain1) (tail chain2))))))))

(defun map-chain (f chain)
  (stop-on-chain-end chain
    #'(lambda () (cons-chain (funcall f (head chain)) (map-chain f (tail chain))))))

(defun filter-chain (filter chain)
  "Return a chain whose elements pass the filter."
  (stop-on-chain-end chain
    #'(lambda ()
	(let ((head (head chain)))
	  (if (funcall filter head)
	      (cons-chain head (filter-chain filter (tail chain)))
      	      (filter-chain filter (tail chain)))))))

(defun append-chains (c1 c2)
  (if (empty-chain? c1)
      c2
      (cons-chain (head c1) (append-chains (tail c1) c2))))

(defun chain-equal? (c1 c2)
  (cond ((empty-chain? c1) (empty-chain? c2))
	((empty-chain? c2) (empty-chain? c1))
	('else (if (eq? (head c1) (head c2))
		   (chain-equal? (tail c1) (tail c2))
		   nil))))

(defun chain-force-all (chain)
  (let ((h '())
        (c chain))
    (do-forever
      (if (empty-chain? c)
	  (return-from chain-force-all (values))
	  (setq h (head c)
		c (tail c))))))

(defun binary-function-stream-reduce (function base-case chain)
  (do ((c chain (tail c))
       (answer base-case (funcall function answer (head c))))
      ((empty-chain? c) answer)))

;;; List/chain operations

(defun list->chain (l)
  (if (null l)
      the-empty-chain
      (cons-chain (first l) (list->chain (rest l)))))

(defun chain->list (c)
  (if (empty-chain? c)
      '()
      (cons (head c) (chain->list (tail c)))))

(defun filter-list (filter l)
  (chain->list (filter-chain filter (list->chain l))))

(defun string->chain (string)
  (labels ((scanner (point)
	     (if (= point (string-length string))
		 the-empty-chain
		 (cons-chain (char string point)
			     (scanner (1+ point))))))
    (scanner 0)))
		 

(defun add-chains (c1 c2)
  (map-across-chains #'+ c1 c2))

;;; Higher order chain procedures

(defun accumulate (combiner initial-value chain)
  (if (empty-chain? chain)
      initial-value
      (funcall combiner (head chain)
	       (accumulate combiner initial-value (tail chain)))))

(defun flatten (chain)
  (accumulate #'append-chains the-empty-chain chain))

(defun flatmap (function chain)
  (flatten (map-chain function chain)))

(defvar fibs (cons-chain 1 (cons-chain 1 (add-chains fibs (tail fibs)))))

(defvar ones (cons-chain 1 ones))

(defvar ints (cons-chain 1 (add-chains ones ints)))

(defun make-primes-chain ()
  (labels ((inner-chain (chain)
	     (let ((prime (head chain)))
	       (cons-chain (head chain)
			   (filter-chain #'(lambda (element)
					     (not (funcall (divisible-by prime) element)))
					 (inner-chain (tail chain)))))))
    (inner-chain (tail ints))))

(defun divisible-by (dividend)
  #'(lambda (x)
      (zerop (rem x dividend))))