"NEXT: Point class - basic stuff"

(define (send message obj . par)
  (let ((method (obj message)))
    (apply method par)))

(define (point x y)
  (letrec ((getx    (lambda () x))
           (gety    (lambda () y))
           (add     (lambda (p) 
                      (point 
                       (+ x (send 'getx p))
                       (+ y (send 'gety p)))))
           (type-of (lambda () 'point))
          )
    (lambda (message)
      (cond ((eq? message 'getx) getx)
            ((eq? message 'gety) gety)
            ((eq? message 'add)  add)
            ((eq? message 'type-of) type-of)
            (else (error "Message not understood"))))))

(define p1 (point 1 2))
(define p2 (point 3 4))

(send 'type-of p1)
(list (send 'getx p1) (send 'gety p1))
(define p3 (send 'add p1 p2))
(list (send 'getx p3) (send 'gety p3))


"NEXT: Color point example"

(define (new-instance class . parameters)
  (apply class parameters))

(define (new-part class . parameters)
  (apply class parameters))

(define (method-lookup object selector)
  (cond ((procedure? object) (object selector))
         (else (error "Inappropriate object in method-lookup: " object))))

(define (send message object . args)
  (let ((method (method-lookup object message)))
    (cond ((procedure? method) (apply method args))
          ((null? method) (error "Message not understood: " message))
          (else (error "Inappropriate result of method lookup: " method)))))


(define (object)
  (let ((super '())
        (self 'nil))

   (define (dispatch message)
       '())
 
   (set! self dispatch)
   self))

(define (point x y)
 (let ((super (new-part object))
       (self 'nil))
  (let ((x x) 
        (y y)
       )
     
     (define (getx) x)
  
     (define (gety) y)
  
     (define (add p) 
      (point 
       (+ x (send 'getx p))
       (+ y (send 'gety p))))
  
     (define (type-of) 'point)

     (define (point-info)
       (list (send 'getx self) (send 'gety self) (send 'type-of self)))
       
     (define (dispatch message)
       (cond ((eqv? message 'getx) getx)
             ((eqv? message 'gety) gety)
             ((eqv? message 'add)  add)
             ((eqv? message 'point-info)  point-info)
             ((eqv? message 'type-of) type-of)
  	     (else (method-lookup super message))))
     
     (set! self dispatch)
   )

   self))  


(define (color-point x y color)
 (let ((super (new-part point x y))
       (self 'nil))
   (let ((color color))
       
     (define (get-color)
       color)

     (define (type-of) 'color-point)
       
     (define (dispatch message)
       (cond ((eqv? message 'get-color) get-color)
             ((eqv? message 'type-of) type-of)
             (else (method-lookup super message))))
       
     (set! self dispatch)
   )
     
   self))

(define cp (new-instance color-point 5 6 'red))
(send 'get-color cp)
(list (send 'getx cp) (send 'gety cp))
(send 'type-of cp)
(send 'point-info cp)   ; observe that type-of is not a virtual method

"NEXT: Color point with virtual methods"

(define (new-instance class . parameters)
 (let ((instance (apply class parameters)))
   (virtual-operations instance)
   instance))

; Arrange for virtual operations in object
(define (virtual-operations object)
  (send 'set-self! object object))

(define (new-part class . parameters)
  (apply class parameters))


(define (object)
  (let ((super '())
        (self 'nil))

   (define (set-self! object-part)
     (set! self object-part))

   (define (dispatch message)
     (cond ((eqv? message 'set-self!) set-self!)
           (else '())))
 
   (set! self dispatch)
   self))


(define (point x y)
 (let ((super (new-part object))
       (self 'nil))
  (let ((x x) 
        (y y)
       )
     
     (define (getx) x)
  
     (define (gety) y)
  
     (define (add p) 
      (point 
       (+ x (send 'getx p))
       (+ y (send 'gety p))))
  
     (define (type-of) 'point)

     (define (point-info)
       (list (send 'getx self) (send 'gety self) (send 'type-of self)))

     (define (set-self! object-part)
         (set! self object-part)
         (send 'set-self! super object-part))
       
     (define (dispatch message)
       (cond ((eqv? message 'getx) getx)
             ((eqv? message 'gety) gety)
             ((eqv? message 'add)  add)
             ((eqv? message 'point-info)  point-info)
             ((eqv? message 'type-of) type-of)
             ((eqv? message 'set-self!) set-self!)
             (else (method-lookup super message))))
     
     (set! self dispatch)
   )

   self))  


(define (color-point x y color)
 (let ((super (new-part point x y))
       (self 'nil))
   (let ((color color))
       
     (define (get-color)
       color)

     (define (type-of) 'color-point)

     (define (set-self! object-part)
         (set! self object-part)
         (send 'set-self! super object-part))
       
     (define (dispatch message)
       (cond ((eqv? message 'get-color) get-color)
             ((eqv? message 'type-of) type-of)
             ((eqv? message 'set-self!) set-self!)
             (else (method-lookup super message))))
       
     (set! self dispatch)
   )
     
   self))

(define cp (new-instance color-point 5 6 'red))
(send 'get-color cp)
(list (send 'getx cp) (send 'gety cp))
(send 'type-of cp)
(send 'point-info cp)

"NEXT: Trampolining 1"

(define (fact-iter n acc)
  (if (zero? n)
      acc
      (fact-iter
        (- n 1)
        (* acc n))))

(fact-iter 5 1)

(define (mem? n lst)
  (cond ((null? lst) #f)
        ((= (car lst ) n) #t)
        (else (mem? n (cdr lst)))))

(mem? 5 (list 1 2 3 4 5 6))

(define (fib n)
  (fib-iter n 0 0 1))

(define (fib-iter n i small large)
  (if (< i n)
      (fib-iter n (+ i 1) large (+ large small))
      small))

(fib 8)

"NEXT: Trampolining 2"
(define (return x) x)             
(define (bounce thunk) (call thunk))     
(define (call thunk) (thunk))    

(define (fact-iter n acc)
  (if (zero? n)
      (return acc)
      (bounce 
        (lambda ()
          (fact-iter
            (- n 1)
            (* acc n))))))

(fact-iter 5 1)

(define (mem? n lst)
  (cond ((null? lst) (return #f))
        ((= (car lst ) n) (return #t))
        (else (bounce
                (lambda ()
                  (mem? n (cdr lst)))))))

(mem? 5 (list 1 2 3 4 5 6))

(define (fib n)
  (fib-iter n 0 0 1))

(define (fib-iter n i small large)
  (if (< i n)
      (bounce
        (lambda () 
          (fib-iter n (+ i 1) large (+ large small))))
      (return small)))

(fib 8)

"NEXT: Trampolining 3"

(define (return x) (tag 'done x))                 
(define (bounce thunk) (tag 'doing thunk))        
(define (tag label thing) (cons label thing))     

(define (fact-iter n acc)
  (if (zero? n)
      (return acc)
      (bounce 
        (lambda ()
          (fact-iter
            (- n 1)
            (* acc n))))))

(fact-iter 5 1)

(define (mem? n lst)
  (cond ((null? lst) (return #f))
        ((= (car lst ) n) (return #t))
        (else (bounce
                (lambda ()
                  (mem? n (cdr lst)))))))

(mem? 5 (list 1 2 3 4 5 6))

(define (fib n)
  (fib-iter n 0 0 1))

(define (fib-iter n i small large)
  (if (< i n)
      (bounce
        (lambda () 
          (fib-iter n (+ i 1) large (+ large small))))
      (return small)))

(fib 8)

"NEXT: Trampolining 4"

(define (tag label thing) (cons label thing))
(define tag-of car)
(define tag-value cdr)

(define (pogo-stick thread)                                
  (cond ((eqv? 'done (tag-of thread))                      
          (tag-value thread))                              
        ((eqv? 'doing (tag-of thread))                     
          (pogo-stick (call (tag-value thread))))))          

(define (fact-iter n acc)
  (if (zero? n)
      (return acc)
      (bounce 
        (lambda ()
          (fact-iter
            (- n 1)
            (* acc n))))))

(pogo-stick (fact-iter 5 1))

(define (mem? n lst)
  (cond ((null? lst) (return #f))
        ((= (car lst ) n) (return #t))
        (else (bounce
                (lambda ()
                  (mem? n (cdr lst)))))))

(pogo-stick (mem? 5 (list 1 2 3 4 5 6)))

(define (fib n)
  (fib-iter n 0 0 1))

(define (fib-iter n i small large)
  (if (< i n)
      (bounce
        (lambda () 
          (fib-iter n (+ i 1) large (+ large small))))
      (return small)))

(pogo-stick (fib 8))

"NEXT: Trampolining 5"

(define (seesaw thread-1 thread-2)                           
  (cond ((eqv? 'done (tag-of thread-1))                      
          (tag-value thread-1))
        ((eqv? 'doing (tag-of thread-1))
          (seesaw thread-2 (call (tag-value thread-1))))))

(define (fact-iter n acc)
  (if (zero? n)
      (return acc)
      (bounce 
        (lambda ()
          (fact-iter
            (- n 1)
            (* acc n))))))

(define (fib n)
  (fib-iter n 0 0 1))

(define (fib-iter n i small large)
  (if (< i n)
      (bounce
        (lambda () 
          (fib-iter n (+ i 1) large (+ large small))))
      (return small)))


(seesaw (fact-iter 5 1) (fib 8))
(seesaw (fact-iter -1 1) (fib 8))



"NEXT: Trampolining 6"

(define (trampoline thread-queue)                            
  (let ((head (car thread-queue)))
   (cond ((eqv? 'done (tag-of head)) (tag-value head))
         ((eqv? 'doing (tag-of head)) 
             (trampoline
                (append 
                   (cdr thread-queue)
                   (list (call (tag-value head)))))))))

(define (fact-iter n acc)
  (if (zero? n)
      (return acc)
      (bounce 
        (lambda ()
          (fact-iter
            (- n 1)
            (* acc n))))))

(define (mem? n lst)
  (cond ((null? lst) (return #f))
        ((= (car lst ) n) (return #t))
        (else (bounce
                (lambda ()
                  (mem? n (cdr lst)))))))

(define (fib n)
  (fib-iter n 0 0 1))

(define (fib-iter n i small large)
  (if (< i n)
      (bounce
        (lambda () 
          (fib-iter n (+ i 1) large (+ large small))))
      (return small)))

(trampoline (list (fact-iter -1 1) (mem? 5 (list 2 8 9 1 3 4  3 5 )) (fib 8)))

(trampoline (list (fact-iter -1 1) (fib 7)  (mem? 5 (list 2 8 9 1 3 4  3 5 ))))

"THE END"