Untitled

;#lang r5rs
;(define error display)
;;;一种Scheme语言中基于消息传递的面向对象机制 上 -- 语言机制 - Closure
;;;面向对象的机制的实现方式很都多种，常见的比如基于向量和隐藏this指针的。
;;;这里是基于程序语言中的闭包特性来实现的，尝试了面向对象机制中的一些常见情况。
;;;参考1 OCaml http://caml.inria.fr/pub/docs/u3-ocaml/ocaml-objects.html
;;;参考2 SICP http://mitpress.mit.edu/sicp/full-text/book/book-Z-H-17.html
;;;参考3 R5RS http://www.schemers.org/Documents/Standards/R5RS/HTML/
;;;查找对象方法的时间复杂度依赖所用实现的case语句的实现方式，若有优化则为O(1)。


;;;========================= 定义部分 ============================

;;;function send
;;;向对象发送消息
;;;type = closure * symbol * object list -> object
;;;example. (send pair 'set-car! 1) == (set-car! pair 1)
(define (send object method . arguments)
  (cond ((object method)
         =>(lambda (x) (apply x arguments)))
        (else (error "method missing"))))
;;;function interface
;;;检验对象是否实现方法，注意方法名一致不能保证方法的语义正确
;;;type = symbol list -> (closure -> boolean)
;;;example. sequence? == (interface 'car 'cdr)
(define (interface . methods)
  (lambda (object)
    (let loop ((methods methods))
      (cond ((null? methods) #t)
            ((not (object (car methods))) #f)
            (else (loop (cdr methods)))))))
;;;functon coerce
;;;将对象绑定的若干方法表示为列表，用于调用泛型函数使用
;;;type = symbol list -> procedure list
;;;example. (coerce 'car 'cdr)
(define (coerce . methods)
  (map (lambda (method)
         (lambda (object . arguments) (apply send object method arguments)))
       methods))
;;;function method
;;;从对象链中查找方法
;;;type = symbol * closure list -> (procedure | false)
;;;example. ((method 'car pair)) == (send pair 'car)
(define (method symbol . objects)
  (let loop ((protos objects))
    (cond ((null? protos) #f)
          (((car protos) symbol) => (lambda (x) x))
          (else (loop (cdr protos))))))
;;;macro object
;;;创建对象
;;;syntax = (object (prototypes ...) ((method (arguments ...) body ...) ...))
;;;example. (send (object () ((one () 1)))) 'one) == 1
(define-syntax object
  (syntax-rules ()
    ((_  (prototypes ...) ((method-name (arguments ...) body ...) ...))
     (lambda (m)
       (case m
         ((method-name) (lambda (arguments ...) body ...)) ...
         (else (apply method m (list prototypes ...))))))))
;;;macro thunk
;;;用于延迟绑定
;;;syntax = (thunk object)
;;;example. (thunk 0)
(define-syntax thunk
  (syntax-rules () ((_ x) (lambda () x))))
;;;;macro object2
;;;上述“macro object”的 rich 版本
;;;syntax = (object2 self (prototype-news ...) ((slot value) ...) ((method (arguments ...) body ...) ...) init ...)
;;;example. <404>
(define-syntax object2;define
  (syntax-rules ()
    ((_ self (prototype-news ...) ((slot value) ...) ((method (arguments ...) body ...) ...) init ...)
     (letrec ((slot value) ...
              (self
               (lambda (m)
                 (case m
                   ((method) (lambda (arguments ...) body ...)) ...
                   (else (let loop ((protos (list (prototype-news (lambda () self)) ...)))
                           (cond ((null? protos) #f)
                                 (((car protos) m) => (lambda (x) x))
                                 (else (loop (cdr protos))))))))))
       init ... self))))
;;;object top-object2
;;;用于继承树的根节点
(define (top-object2 this)
  (object2 self () () ((init () (this)))))
;;;function new
;;;用来构造一个对象
(define (new class . arguments)
  (define self (apply send (class (thunk self)) 'init arguments))
  self)
;;;========================= 示例部分 ============================

;;;* 示例一 Pair::mcons
;;;该示例用来演示如何创建一个对象
;;;定义A
(define (mcons0 x y)
  (lambda (m)
    (case m
      ((car) (lambda () x))
      ((cdr) (lambda () y))
      ((set-car) (lambda (z) (set! x z)))
      ((set-cdr) (lambda (z) (set! x z)))
      ((->pair) (lambda ()(cons x y)))
      (else #f))))
;;;定义B
(define (mcons x y)
  (object ()
          ((car () x)
           (cdr () y)
           (set-car (z) (set! x z))
           (set-cdr (z) (set! y z))
           (->pair () (cons x y)))))
;;;泛型
(define (mcar mpair)
  ((mpair 'car)))
(define (mcdr mpair)
  ((mpair 'cdr)))
(define (set-mcar mpair obj)
  ((mpair 'set-car) obj))
(define (set-mcdr mpair obj)
  ((mpair 'set-cdr) obj))
(define (mpair->pair mpair)
  ((mpair '->pair)))
;;;使用
(let example-1 ()
  (define x (mcons 1 2))
  (display (mcdr x))
  (newline))

;;;* 示例二 sequence
;;;该示例用来演示接口和泛型的使用
(define sequence? (interface 'car 'cdr))
(define (mlist . objects)
  (if (null? objects) '()
      (mcons (car objects) (apply mlist (cdr objects)))))
(define (for-each0 p lst)
  (cond ((null? lst) '())
        (else (p (car lst)) (for-each p (cdr lst)))))
(define (mfor-each p lst)
  (cond ((null? lst) '())
        (else (p (mcar lst)) (mfor-each p (mcdr lst)))))
(define (generic-for-each prod lst car cdr)
  (cond ((null? lst) '())
        (else (prod (mcar lst)) (generic-for-each prod (mcdr lst) car cdr))))
(define (mrange start end step)
  (letrec ((self (object()
                        ((car () start)
                         (cdr () (let ((x (+ (send self 'car) step)))
                                   (if (cond ((> step 0) (<= start x end))
                                             ((< step 0) (>= start x end))
                                             (else (error "mrange")))
                                       (mrange x end step) '())))))))
    self))
(let example-2 ()
  (define x (mlist 1 2 3 4 5))
  (mfor-each display x)
  (display (sequence? x))
  ;(mfor-each display (mrange 0 10 2))
  ;(generic-for-each display (mrange 0 10 2) mcar mcdr)
  (apply generic-for-each display (mrange 0 -10 -3) (coerce 'car 'cdr))
  (newline))

;;;* 示例三 slots
;;;该示例用来演示构造器和私有成员
(define (box x)
  (letrec ((value '())
           (self (object()
                        ((ref () value)
                         (set! (x) (set! value x))
                         (add! (x) (send self 'set! (+ x (send self 'ref))))))))
    (set! value x)
    self))
(let example-3 ()
  (define x (box 1))
  (display (send x 'ref))
  (send x 'set! 2)
  (display (send x 'ref))
  (send x 'add! 2)
  (display (send x 'ref))
  (newline))

;;;* 示例四 inheritance
;;;该示例用来演示扩充一个类
(define (mlist2 . objects)
  (define super (apply mlist objects))
  (define self
    (object (super)
            ((for-each (prod) (apply generic-for-each prod self (coerce 'car 'cdr))))))
  self)
(let example-4 ()
  (define x (mlist2 1 2 3 4 5))
  (mfor-each display x)
  (send x 'for-each display)
  (newline))

;;;* 实例五 virtual/override
;;;该示例用来演示模板方法模式
(let example-5 ()
  (define (hello name)
    (letrec((self
             (object ()
                     ((name () (name))
                      (say () (for-each display (list "hello " (send self 'name) "!\n")))))))
      self))
  (send (hello (lambda () "world0")) 'say)
  (define (hello-world)
    (define super (hello (lambda () (send self 'name))))
    (define self (object (super) ((name () "world1"))))
    self)
  (send (hello-world) 'say)
  (define (hello2 this)
    (object ()
            ((name () "<null>")
             (say () (for-each display (list "hello " (send (this) 'name) "!\n"))))))
  (define (hello-world2)
    (define self
      (object
       ((hello2 (thunk self)))
       ((name () "world2"))))
    self)
  (send (hello-world2) 'say)
  (define (hello-world3)
    (define self
      (object2 self (top-object2 hello2) ()
               ((name () "world3"))))
    self)
  (send (hello-world3) 'say)
  (define (hello-world4 this)
    (define self
      (object2 self (top-object2 hello2) ()
               ((name () "world4"))))
    self)
  (send (new hello-world4) 'say)
  (newline))

;;;待续 一种Scheme语言中基于消息传递的面向对象机制 下 -- 使用模式