;; Streams, and Lazy Evaluation
;; D.S. Blank, Fall 2002
;; Programming Languages

;; Can we come up with a data abstraction that would allow us to
;; manipulate infinite sets? Yes! First, we examine lazy evaluation.

;; We will need define-syntax:

;; (require 'macro) ;; SCM Scheme Command
(load "chez-init.scm")
(define =? =)

;; First, we make a freeze operator that takes an element and
;; wraps a lambda around it:

(define-syntax freeze
  (syntax-rules ()
    ((_ expr) (lambda () expr))))

;; We'll call that a thunk. To thaw a thunk, we'll use:

(define thaw
  (lambda (thunk)
    (thunk)))

;; which is just an application of the thunk. Now, let's make
;; some new operators:

(define-syntax $cons
  (syntax-rules ()
    ((_ item stream) (cons item (freeze stream)))))

;; $cons (pronounced "stream cons") conses an item on to a
;; thunk.

(define $cdr
  (lambda (s)
    (thaw (cdr s))))

;; stream cdr will thaw the thunk.

;; stream car is just car:

(define $car car)

;; Now, we can do some weird things, like assume the set "ones"
;; exist, and cons a 1 onto it:

(define ones ($cons 1 ones))

;; That gives an infinite set of ones. Why? How?

;; ($car ones) => 1
;; ($car ($cdr ones)) => 1
;; ($car ($cdr ($cdr ones))) => 1

;; Ok, now let's define stream map:

(define $map
  (lambda (f s)
    ($cons (f ($car s))
	   ($map f ($cdr s)))))

;; Now we can do something really, really weird. First, assume the
;; natural numbers exist (0 1 2 3 4 5 ...). Now add one to all of
;; them. That gives (1 2 3 4 5 6 ...). Now cons a zero on the
;; front. What do you have?

(define add1 (lambda (x) (+ x 1)))
(define nats ($cons 0 ($map add1 nats)))

;; Now, to make things more efficient, let's do something called
;; memoize:

(define $cdr
  (lambda (s)
    (if (procedure? (cdr s))
	(set-cdr! s (thaw (cdr s))))
    (cdr s)))

;; This is just like the previous $cdr, but with a little side
;; effect. What is the effect?

;; A function to make it easier to see what is happening:

(define $list
  (lambda (s n)
    (cond
      ((=? n 0) '())
      (else (cons ($car s) ($list ($cdr s) (- n 1)))))))

;; Stream add:

(define $+
  (lambda (s1 s2)
    ($cons (+ ($car s1)
	      ($car s2))
	   ($+ ($cdr s1)
	       ($cdr s2)))))

;; What's this?

($list ($+ nats nats) 10)

;; Stream add1:

(define $add1
  (lambda (s)
    ($map add1 s)))

;;(require 'random) ;; SCM Scheme Command

(define rands ($map (lambda (n) (random 10)) nats))

;; Without memoizing, this is strange. Why?

;; Here's fibs, by passing in two params:

(define $fibs
  (lambda (a b)
    ($cons a ($fibs b (+ a b)))))

;; Here's fibs again, this time assuming that they first exist:

(define $fibs2
  ($cons 1 ($+ ($cons 0 $fibs2)
	       $fibs2)))

;; and another method:

(define $fibs3
  ($cons 1 ($cons 1 ($+ $fibs3 ($cdr $fibs3)))))

($list ($fibs 1 1) 10)
($list $fibs2 10)
($list $fibs3 10)

;; Where is the recursion?

;; Some additional musings:

(define $skip-every-other
  (lambda (s)
    ($cons ($car s)
	   ($skip-every-other ($cdr ($cdr s))))))

;; The following is based on work by Jim Marshall. 

(define square (lambda (x) (* x x)))
(define increment (lambda (x) (+ x 1)))
(define decrement (lambda (x) (- x 1)))
(define average (lambda (x y) (/ (+ x y) 2)))

;;-------------------------------------------------------

(define nth
  (lambda (n s)
    (if (= n 0)
	($car s)
	(nth (- n 1) ($cdr s)))))

(define $print
  (lambda (n s)
    (if (= n 0)
	(begin
	  (newline)
	  'done)
	(begin
	  (display ($car s))
	  (display " ")
	  ($print (- n 1) ($cdr s))))))

(define $println
  (lambda (n s)
    (if (= n 0)
	'done
	(begin
	  (display ($car s))
	  (newline)
	  ($println (- n 1) ($cdr s))))))

(define $filter
  (lambda (pred? s)
    (if (pred? ($car s))
      ($cons ($car s) ($filter pred? ($cdr s)))
      ($filter pred? ($cdr s)))))

(define $filter-out
  (lambda (pred? s)
    ($filter (lambda (x) (not (pred? x))) s)))

(define scale
  (lambda (factor s)
    ($map (lambda (x) (* factor x)) s)))

(define naturals ($cons 0 ($map increment naturals)))

(define positives ($cdr naturals))

(define negatives ($map - positives))

(define $merge
  (lambda (s1 s2)
    ($cons ($car s1) ($cons ($car s2) ($merge ($cdr s1) ($cdr s2))))))

(define integers ($merge naturals negatives))

;; combine-streams creates a function that combines two streams:

(define combine-streams
  (lambda (op)
    (lambda (s1 s2)
      ($cons (op ($car s1) ($car s2))
             ((combine-streams op) ($cdr s1) ($cdr s2))))))

(define add-streams (combine-streams +))
(define sub-streams (combine-streams -))
(define mul-streams (combine-streams *))
(define div-streams (combine-streams /))

;; Now we can define the stream of Fibonacci numbers and
;; the stream of factorials in a rather dizzying way:

(define fibs ($cons 0 ($cons 1 (add-streams fibs ($cdr fibs)))))
(define facts ($cons 1 (mul-streams facts positives)))

;; Conceptually, ! doesn't do any "computation" at all, at least
;; in the traditional sense.  It simply picks the appropriate
;; ready-made answer from its (infinite!) collection of answers:

(define !
  (lambda (n)
    (nth n facts)))

;; (multiple? n) returns a predicate function that tests whether
;; a particular number is a multiple of n:

(define multiple?
  (lambda (n)
    (lambda (x) (= (remainder x n) 0))))

(define odds ($filter-out (multiple? 2) naturals))
(define evens ($map decrement odds))

;; The "Sieve of Eratosthenes":

(define sieve
  (lambda (s)
    ($cons ($car s) (sieve ($filter-out (multiple? ($car s)) ($cdr s))))))

(define primes (sieve ($cdr positives)))

(define random-stream
  (lambda (n)
    ($cons (random n) (random-stream n))))

(define rands (random-stream 100))

;; A stream representing the computation of sqrt(2) using Newton's method:

(define computation-stream
  (lambda (guess improve)
    ($cons guess (computation-stream (improve guess) improve))))

(define sqrt-stream
  (lambda (x)
    (computation-stream 1.0 (lambda (guess) (average guess (/ x guess))))))

(define sqrt2 (sqrt-stream 2.0))

;; An alternative way of defining sqrt-stream, using $map:

(define sqrt-stream
  (lambda (x)
    ($cons 1.0 ($map (lambda (guess) (average guess (/ x guess)))
                     (sqrt-stream x)))))

;; constant-stream returns an infinite stream of n's:

(define constant-stream
  (lambda (n)
    ($cons n (constant-stream n))))

;; partial-sums takes a stream of values (a0 a1 a2 a3 a4 ...) and returns
;; a stream of partial sums  (a0  a0+a1  a0+a1+a2  a0+a1+a2+a3  ...)

(define partial-sums
  (lambda (s)
    ($cons ($car s)
           (add-streams (constant-stream ($car s))
                        (partial-sums ($cdr s))))))

;; alternating-signs is the stream (+1 -1 +1 -1 +1 ...)
;; odd-reciprocals is the stream (1 1/3 1/5 1/7 1/9 ...)

(define alternating-signs
  ($cons +1 ($map - alternating-signs)))

(define odd-reciprocals
  ($map (lambda (x) (/ 1 x)) odds))

;; pi-stream is a stream representing a pi computation based on the
;; following infinite series:
;;
;;      pi/4  =  1 - 1/3 + 1/5 - 1/7 + 1/9 - 1/11 + . . .
;;
;; This series converges VERY slowly.  

(define pi-stream
  (scale 4.0
     (partial-sums (mul-streams alternating-signs odd-reciprocals))))

;;-----------------------------------------------------------------
;; 2-way stream abstract data type

(define make-2way-stream
  (lambda (down curr up)
    (list down curr up)))

(define downstream
  (lambda (tw)
    (car tw)))

(define current
  (lambda (tw)
    (cadr tw)))

(define upstream
  (lambda (tw)
    (caddr tw)))

;;-----------------------------------------------------------------
;; operations on 2-way streams

(define nth-2way
  (lambda (n tw)
    (cond
      ((< n 0) (nth (- (- n) 1) (downstream tw)))
      ((= n 0) (current tw))
      ((> n 0) (nth (- n 1) (upstream tw))))))

(define $map-2way
  (lambda (f tw)
    (make-2way-stream
      ($map f (downstream tw))
      (f (current tw))
      ($map f (upstream tw)))))

(define shift-left
  (lambda (tw)
    (make-2way-stream
      ($cdr (downstream tw))
      ($car (downstream tw))
      ($cons (current tw) (upstream tw)))))

(define shift-right
  (lambda (tw)
    (make-2way-stream
      ($cons (current tw) (downstream tw))
      ($car (upstream tw))
      ($cdr (upstream tw)))))

(define add-2way-streams
  (lambda (tw1 tw2)
    (make-2way-stream
      (add-streams (downstream tw1) (downstream tw2))
      (+ (current tw1) (current tw2))
      (add-streams (upstream tw1) (upstream tw2)))))

(define print-radius
  (lambda (n tw)
    (define print
      (lambda (n)
	(if (= n 0)
	  (begin
	    (display "[")
	    (display (current tw))
	    (display "] "))
	  (begin
	    (display (nth-2way (- n) tw))
	    (display " ")
	    (print (- n 1))
	    (display (nth-2way n tw))
	    (display " ")))))
    (print n)
    (newline)
    'done))

(define ints
  (make-2way-stream negatives 0 positives))

;; Examples:
;; (print-radius 10 ints)
;; -10 -9 -8 -7 -6 -5 -4 -3 -2 -1 [0] 1 2 3 4 5 6 7 8 9 10 
;; (print-radius 10 (shift-left ints))
;; -11 -10 -9 -8 -7 -6 -5 -4 -3 -2 [-1] 0 1 2 3 4 5 6 7 8 9 

;;-----------------------------------------------------------------
;; Pascal's Triangle

(define zeros (constant-stream 0))

(define pascal
  (lambda (row)
    ($cons row (pascal (add-2way-streams row (shift-left row))))))

(define pascals-triangle (pascal (make-2way-stream zeros 1 zeros)))

(define number->bit
  (lambda (n)
    (if (odd? n) '* " ")))

(define pascals-triangle-mod2
  ($map
    (lambda (row) ($map-2way number->bit row))
    pascals-triangle))

(define print-rows
  (lambda (n triangle)
    (letrec
      ((print-row
         (lambda (i s)
           (if (= i n)
             (newline)
             (begin
               (newline)
               (display (current ($car s)))
               (display " ")
               ($print i (upstream ($car s)))
               (print-row (+ i 1) ($cdr s)))))))
      (print-row 0 triangle)
      (newline)
      'done)))

;; Examples:
;; (print-rows 16 pascals-triangle)
;; 1 
;; 1 1 
;; 1 2 1 
;; 1 3 3 1 
;; 1 4 6 4 1 
;; 1 5 10 10 5 1 
;; 1 6 15 20 15 6 1 
;; 1 7 21 35 35 21 7 1 
;; 1 8 28 56 70 56 28 8 1 
;; 1 9 36 84 126 126 84 36 9 1 
;; 1 10 45 120 210 252 210 120 45 10 1 
;; 1 11 55 165 330 462 462 330 165 55 11 1 
;; 1 12 66 220 495 792 924 792 495 220 66 12 1 
;; 1 13 78 286 715 1287 1716 1716 1287 715 286 78 13 1 
;; 1 14 91 364 1001 2002 3003 3432 3003 2002 1001 364 91 14 1 
;; 1 15 105 455 1365 3003 5005 6435 6435 5005 3003 1365 455 105 15 1 

;; (print-rows 16 pascals-triangle-mod2)
;; * 
;; * * 
;; *   * 
;; * * * * 
;; *       * 
;; * *     * * 
;; *   *   *   * 
;; * * * * * * * * 
;; *               * 
;; * *             * * 
;; *   *           *   * 
;; * * * *         * * * * 
;; *       *       *       * 
;; * *     * *     * *     * * 
;; *   *   *   *   *   *   *   * 
;; * * * * * * * * * * * * * * * *