;; -*- gauche -*-
;; Experiment with and overview of Gauche's CLOS/MOP features
;; references:
;; - $gauche/{test/object.scm,lib/gauche/{object.scm,mop}}
;; - CL CLOS docs
;; - guile GOOPS docs

(define-class <slot-features> ()
  ((aap :init-keyword :aap              ; constructor keyword
        :init-value 0                   ; simple value
        :init-form (lambda () #t)       ; form
        :getter get-aap                 ; read
        :setter set-aap                 ; write
        :accessor aap-accessor          ; read/write
        :allocation :instance)))        ; instance, class,
                                        ; each-subclass, virtual

(let ((sf (make <slot-features> :aap 'aap)))
  (print (get-aap sf)))

;; books
(define-class <literature> ()
  ((title :accessor title)
   (author :accessor author)))

(define-method initialize ((self <literature>) init-args)
  ;; explicitly call base class
  (next-method)
  (print "literature.initialize"))

(let ((book (make <literature>)))
  ;; accessor and slot-ref/set! access to slots
  (set! (title book) "The Hitchhiker's Guide to the Galaxy")
  (set! (author book) "Douglas N. Adams")
  (print (list (author book) (slot-ref book 'author)))
  (print book))

;; shapes
(define-class <shape> ()
  ((x :accessor x)
   (y :accessor y)))

(define-class <square> (<shape>)
  ((side :init-keyword :side)
   (area :getter area)))

;; convenience constructor
(define (make-square side)
  (make <square> :side side))

;; generic method
(define-method area ((self <square>))
  (* (slot-ref self 'side) (slot-ref self 'side)))

;; call-back used by display (print, format, &c)
(define-method write-object ((self <square>) port)
  (format port "#<square ~d>" (slot-ref self 'side)))

;; unspecialized method, applicable to any type
(define-method unspec (self)
  (print (class-of self)))

(let ((sq (make <square> :side 3)))
  (print sq)
  (unspec sq)
  (unspec (make <shape>))
  (print (area sq)))

;; GoF pattern
;; observer
(define-class <observer> ()
  ((id :init-keyword :id :getter id-of)))

(define-method update ((self <observer>) data)
  (print "observer " (id-of self) ": new data " data))

(define-method write-object ((self <observer>) port)
  (format port "#<observer ~s>" (id-of self)))

;; subject
(define-class <subject> ()
  ((observers :init-value '() :accessor observers-of)))

(define-method attach ((self <subject>) (obj <observer>))
  (set! (observers-of self) (cons obj (observers-of self))))

(define-method notify ((self <subject>) data)
  (for-each (cut update <> data) (observers-of self)))

(let ((sub (make <subject>))
      (ob1 (make <observer> :id 'ob1))
      (ob2 (make <observer> :id 'ob2)))
  (attach sub ob1)
  (notify sub 'aap)
  (attach sub ob2)
  (print (observers-of sub))
  (notify sub 'noot))

;; calling order: Class Precedence List
;; (see successful-lisp, chp 14)
(define-class c1 () ())
(define-class c2 () ())
(define-class c3 (c1) ())
(define-class c4 (c2) ())
(define-class c5 (c3 c2) ())
(define-class c6 (c5 c1) ())
(define-class c7 (c4 c3) ())

(print (map class-name (class-precedence-list c5))) ; c5 c3 c1 c2
(print (map class-name (class-precedence-list c6))) ; c6 c5 c3 c1 c2
(print (map class-name (class-precedence-list c7))) ; c7 c4 c2 c3 c1

;; mix-ins
(define-class <comparable> () ())

(define-method <=> ((self <comparable>) other)
  (error "abstract <=> in <comparable>"))

(define-class <anumber> (<comparable>)
  ((value :init-keyword :value)))

(define-method <=> ((self <anumber>) other)
  (cond ((< (slot-ref self 'value) (slot-ref other 'value)) -1)
        ((> (slot-ref self 'value) (slot-ref other 'value)) +1)
        (else 0)))

(let ((n1 (make <anumber> :value 1))
      (n2 (make <anumber> :value 2))
      (n3 (make <anumber> :value 3)))
  (print (<=> n1 n2))
  (print (<=> n3 n2))
  (print (<=> n1 n1)))

;; catching unbound-slot
(define-class <person> ()
  ((name :accessor name :init-keyword :name)
   (age :accessor age :init-keyword :age)))

(define-method slot-unbound ((class <class>) obj slot)
  (format #t "slot '~s:~s' unbound, enter a value:\n" obj slot)
  (set! (age obj) (read))
  (age obj))

(let ((p (make <person> :name "Pascal")))
  (print "age: " (age p)))

;; comparable using a metaclass (other methods are unchanged)
(define-class <comparable> (<class>) ())

(define-class <anumber> ()
  ((value :init-keyword :value))
  :metaclass <comparable>)

;; differences between class+subclass and metaclass
;; subclass:
;; <number> => #<class <number>>
;; (class-precedence-list <number>) =>
;;   (#<class <number>> #<class <comparable>> #<class <object>> #<class <top>>)
;; metaclass:
;; <number> => #<<comparable> 0x8111240> instance of comparable!
;; (class-precedence-list <number>) =>
;;   (#<<comparable> 0x8111240> #<class <object>> #<class <top>>)

;; metaclass = class-of-classes. Gauche uses this to implement
;; singletons, validators, propagators, &c. See gauche.mop.* module.
(define-class <documentation-meta> (<class>)
  ((doc :init-keyword :doc :initform #f)))

(define-class <foo> ()
  (a b c)
  :metaclass <documentation-meta>
  :doc "new :doc keyword for class definitions")

(print (slot-ref <foo> 'doc))