(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
|#

You are viewing proxied material from tilde.institute. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.