(require :asdf)
(require :alexandria)
(require :trivial-garbage)
(require :closer-mop)

(in-package :cl-user)

(defmacro capture-read (&body body)
 `(with-input-from-string
   (*standard-input* (with-output-to-string 
                      (*standard-output*) ,@body))
    (read)))

(defgeneric (setf form) (obj val))
(defgeneric (setf state-alist) (obj val))

(defclass eve () (form))

(defmethod make-load-form 
 ((obj eve) &optional env
  &aux (class (class-name (class-of obj))))
 (declare (ignore env))
 (eval
  `(defmethod make-load-form 
    :around ((obj ,class) &optional env)
    (declare (ignore env))
    (capture-read
     (format t "
(let
    ((form
      '~s))
 (let ((particular-quine (eval form)))
  (setf (form particular-quine) form)
  (values particular-quine)))
"
      (form obj)))))
  (make-load-form obj))

(defun form-eve (&rest other-classes)
 (let
  ((form
    `(macrolet
      ((ana-quine-class
        ((&rest class-paraphernalia) &body body)
        (alexandria:with-gensyms (classname)
         `(let ((quine
                 (defclass ,classname
                  ,@class-paraphernalia)))
           ,@body))))
      (ana-quine-class
       ((,@other-classes eve) ((form :accessor form))
        (:documentation " . . . "))
       (values (make-instance quine))))))
    (let ((particular-quine (eval form)))
      (setf (form particular-quine) form)
      (values particular-quine))))

(defclass stately (eve)
 ((state-alist :initform (list) :accessor state-alist)))

(defmethod make-load-form 
 ((obj stately) &optional env
  &aux (class (class-name (class-of obj))))
 (declare (ignore env))
 (capture-read (format t "
  (let* ((parent-quine (eval '~s))
         (stately (eval parent-quine)))
   (setf (state-alist stately) '~s)
   (values stately))" (call-next-method) (state-alist obj))))

(defclass heritable (eve) ())

(defmethod make-load-form 
 ((obj heritable) &optional env
  &aux (class (class-of obj))) "
"
 (declare (ignore env))
 (alexandria:with-gensyms (form classer)
 `(let ((,form ,(call-next-method)))
   (change-class (eval ,form) ,class))))

(defclass mempubsub (eve) 
 ((peers :initform (tg:make-weak-hash-table :weakness :value)
   :allocation :class :reader peers)))

(defmethod shared-initialize :after ((obj mempubsub) names 
                                     &rest rest)
 (declare (ignore names rest))
 (setf (gethash obj (peers obj)) obj))

(defmethod bread-massage ((obj mempubsub) (lambda function)) "
When you knead assistants
" (with-hash-table-iterator (iter (peers obj))
   (loop initially (tg:gc)
        for k = (nth-value 1 (funcall iter)) while k 
        when (and (member (class-of obj)
                   (clos:class-direct-superclasses 
                    (class-of k))))
            do (funcall lambda k)
    finally (unless (next-method-p) (return))
           (call-next-method))))

#|----AD-HOC-EXAMPLES----------------------------------------------
(load #p"eve-quine.lisp")

(print "Eve quines:")
(let* ((eve-1 (print (form-eve)))
       (eve-2 (print (form-eve 'mempubsub)))
       (eve-3 (print (form-eve (class-name (class-of eve-2)))))
       (fun (lambda (x) (print x))))
 (terpri)
 (print "eve-2 calls fun on her child, eve-3")
 (bread-massage eve-2 fun)
 (terpri)
 (print "eve-3 has no children")
 (bread-massage eve-3 fun)
 (terpri)
 (print "eve-3 directly adopts eve-2")
 (push (class-of eve-3)
  (clos:class-direct-superclasses (class-of eve-2)))
 (bread-massage eve-3 fun)
 (terpri)
 (print "eve-2 calls fun on her child, eve-3")
 (bread-massage eve-2 fun)
 (terpri)
 (print "Now badly named 'heritable class instance and their clone")
 (let* ((heri-1 (print (form-eve 'heritable 'mempubsub)))
        (heri-2 (print (eval (make-load-form heri-1))))
        (tage-1 (print (form-eve (class-name (class-of heri-1))))))
  (terpri)
  (print "heri-1 has one child")
  (bread-massage heri-1 fun)
  (terpri)
  (print "hence so too heri-2")
  (bread-massage heri-2 fun)
  (terpri)
  (print "eve-2 adopts heri-1 (and hence her clone heri-2)")
  (push (class-of eve-2)
   (clos:class-direct-superclasses (class-of heri-2)))
  (bread-massage eve-2 fun)))

(terpri)
(si:quit)
|#
#|----AD-HOC-OUTPUTS-----------------------------------------------

;;; Loading #P"path/to/asdf.fas"
;;; Loading #P"path/to/common-lisp/eve-quine/test-eve-quines.lisp"

"Eve quines:" 
#<a #:CLASSNAME98  ; eve-1
#<a #:CLASSNAME104 ; eve-2
#<a #:CLASSNAME110 ; eve-3

"eve-2 calls fun on her child, eve-3" 
#<a #:CLASSNAME110 

"eve-3 has no children" 

"eve-3 directly adopts eve-2" 
#<a #:CLASSNAME104 

"eve-2 calls fun on her child, eve-3" 
#<a #:CLASSNAME110 

"Now badly named 'heritable class instance and their clone" 
#<a #:CLASSNAME116 0x1 ; heri-1
#<a #:CLASSNAME116 0x2 ; heri-2
#<a #:CLASSNAME132     ; tage-1

"heri-1 has one child" 
#<a #:CLASSNAME132

"hence so too heri-2" 
#<a #:CLASSNAME132

"eve-2 adopts heri-1 (and hence her clone heri-2)" 
#<a #:CLASSNAME116
#<a #:CLASSNAME110
#<a #:CLASSNAME116
|#