Ability to add additional superclasses to a sketch.

README.org

@@ -549,6 +549,48 @@ This can be used, for example, to draw a static sketch and then disable the draw
 
 Example: [[https://github.com/vydd/sketch/blob/master/examples/control-flow.lisp][control-flow.lisp]].
 
+*** Sharing behaviour between sketches
+Let's say you want all your sketches to have a black background, but you don't want to have to reimplement that feature every time. The answer is to implement the feature in a class, and then pass the name of that class to =defsketch= through the =:mixins= option.
+
+First, define a mixin class that implements the desired behaviour in the =draw= method (with the =:before= method specialiser, so that it doesn't override the behaviour of your sketches):
+
+#+BEGIN_SRC lisp
+  (defclass black-background () ())
+  (defmethod draw :before ((instance black-background) &key &allow-other-keys)
+    (background +black+))
+#+END_SRC
+
+Then add the =:mixins= option to your =defsketch= bindings:
+
+#+BEGIN_SRC lisp
+  (defsketch moon
+      ((:mixins black-background))
+       (width 200)
+       (height 200))
+    (circle 100 100 50))
+#+END_SRC
+
+The resulting sketch should have a black background. Initialization/setup logic for =black-background=, and sketches inheriting from it, could be put in an =initialize-instance= or =setup= method:
+
+#+BEGIN_SRC lisp
+  (defmethod initialize-instance :before ((instance black-background) &key &allow-other-keys)
+    (format t "Initializing black background!"))
+  (defmethod setup :before ((instance black-background) &key &allow-other-keys)
+    (format t "Setting up black background!"))
+#+END_SRC
+
+If the mixin class has state that you need to access in the body of your sketch, then use =(sketch-slot-value 'slot-name)=.
+
+Example:
+
+#+BEGIN_SRC lisp
+  (defclass mixin-with-state () ((name :initform "Ruth" :reader name)))
+  (defsketch slot-example
+      ((:mixins mixin-with-state black-background))
+    (with-font (make-font :color +white+)
+      (text (format nil "Hi ~a!" (sketch-slot-value 'name)) 100 100)))
+#+END_SRC
+
 ** Made with Sketch
 - [[https://vydd.itch.io/qelt][QELT]]
 - [[https://github.com/sjl/coding-math][sjl's implementation of coding math videos]]

src/package.lisp

@@ -16,6 +16,7 @@
 
            :defsketch
 
+           :sketch-slot-value
            :sketch-title
            :sketch-width
            :sketch-height

src/sketch.lisp

@@ -269,8 +269,8 @@
 
 ;;; DEFSKETCH macro
 
-(defun define-sketch-defclass (name bindings)
-  `(defclass ,name (sketch)
+(defun define-sketch-defclass (name superclasses bindings)
+  `(defclass ,name (sketch ,@superclasses)
      (,@(loop for b in bindings
               unless (eq 'sketch (binding-prefix b))
               collect `(,(binding-name b)
@@ -309,10 +309,36 @@
                    collect (binding-name b)))))
 
 (defmacro defsketch (sketch-name binding-forms &body body)
+  (multiple-value-bind (options binding-forms)
+      (extract-options binding-forms)
+    (make-defsketch sketch-name
+                    (getf options :mixins)
+                    binding-forms
+                    body)))
+
+(defun sketch-slot-value (slot-sym)
+  (slot-value *sketch* slot-sym))
+
+;;; To be able to set the slots of the currently bound sketch
+;;; class without needing a reference to it.
+(defun (setf sketch-slot-value) (val slot-sym)
+  (setf (slot-value *sketch* slot-sym) val))
+
+(defun extract-options (binding-forms)
+  (let (options)
+    (loop for form in binding-forms
+          if (keywordp (car form))
+            do (progn
+                 (push (cdr form) options)
+                 (push (car form) options))
+          else collect form into the-rest
+          finally (return (values options the-rest)))))
+
+(defun make-defsketch (sketch-name superclasses binding-forms body)
   (let ((bindings (parse-bindings sketch-name binding-forms
                                   (class-bindings (find-class 'sketch)))))
     `(progn
-       ,(define-sketch-defclass sketch-name bindings)
+       ,(define-sketch-defclass sketch-name superclasses bindings)
        ,@(define-sketch-channel-observers bindings)
        ,(define-sketch-prepare-method sketch-name bindings)
        ,(define-sketch-draw-method sketch-name bindings body)