Add extensible environment system

src/environment.lisp

@@ -8,9 +8,8 @@
 ;;; | |___| |\  | \ V /  | ||  _ <| |_| | |\  | |  | | |___| |\  | | |
 ;;; |_____|_| \_|  \_/  |___|_| \_\\___/|_| \_|_|  |_|_____|_| \_| |_|
 
-(defstruct env
+(defstruct (env (:constructor %make-env) (:copier nil))
   ;; Drawing
-  (pen nil)
   (programs nil)
   (model-matrix (sb-cga:identity-matrix)) ; TODO: sb-cga shouldn't be used directly from here
   (view-matrix nil)
@@ -27,10 +26,93 @@
   (resources (make-hash-table))
   ;; Debugging
   (debug-key-pressed nil)
-  (red-screen nil))
+  (red-screen nil)
+  ;; Extensible properties
+  (extensions (make-hash-table)))
 
 (defparameter *env* nil)
 
+;;; Extensible environment properties
+;;;
+;;; This system allows new environment properties to be defined outside of this
+;;; file, near the code that uses them. Use DEFINE-ENVIRONMENT-PROPERTY to add
+;;; new properties with automatic accessor generation and initialization.
+
+(defparameter *environment-initializers* (make-hash-table)
+  "Registry of initializer functions for environment properties.
+Keys are property names (keywords), values are thunks that return initial values.")
+
+(defun register-environment-initializer (name initializer)
+  "Register an initializer function for environment property NAME."
+  (setf (gethash name *environment-initializers*) initializer))
+
+(defun get-environment-extension (env name)
+  "Get an extension property from ENV."
+  (gethash name (env-extensions env)))
+
+(defun set-environment-extension (env name value)
+  "Set an extension property in ENV."
+  (setf (gethash name (env-extensions env)) value))
+
+(defun initialize-environment-extensions (env)
+  "Initialize all registered extension properties in ENV."
+  (maphash (lambda (name initializer)
+             (set-environment-extension env name (funcall initializer)))
+           *environment-initializers*))
+
+(defun make-env (&rest args)
+  "Create a new environment, optionally setting extension properties.
+Extension properties are initialized to their defaults, then any provided
+keyword arguments override them.
+
+Example: (make-env :pen my-custom-pen)"
+  (let ((env (%make-env)))
+    (initialize-environment-extensions env)
+    (loop for (key val) on args by #'cddr
+          do (if (gethash key *environment-initializers*)
+                 (set-environment-extension env key val)
+                 (error "Unknown environment property: ~a. ~
+                         Only registered extension properties can be set via make-env."
+                        key)))
+    env))
+
+(defun copy-env (env)
+  "Create a copy of ENV, including all extension properties."
+  (let ((new-env (copy-structure env)))
+    (setf (env-extensions new-env)
+          (alexandria:copy-hash-table (env-extensions env)))
+    new-env))
+
+(defmacro define-environment-property (name &body initializer)
+  "Define an extensible environment property.
+
+NAME should be a keyword like :my-property.
+INITIALIZER is code that returns the initial value (evaluated at env creation time).
+
+This generates:
+  - (env-NAME env) accessor function
+  - (setf (env-NAME env) value) setter
+  - Registration of the initializer
+
+Example:
+  (define-environment-property :my-cache
+    (make-hash-table))
+
+Then use: (env-my-cache *env*)"
+  (let* ((name-string (if (keywordp name)
+                          (symbol-name name)
+                          (string name)))
+         (accessor (alexandria:symbolicate 'env- name-string))
+         (setter (alexandria:symbolicate 'set-env- name-string)))
+    `(progn
+       (register-environment-initializer ,name (lambda () ,@initializer))
+       (defun ,accessor (env)
+         (get-environment-extension env ,name))
+       (defun ,setter (env value)
+         (set-environment-extension env ,name value))
+       (defsetf ,accessor ,setter)
+       ,name)))
+
 (defun make-white-pixel-texture ()
   "Sent to shaders when no image is active."
   (let ((texture (car (gl:gen-textures 1))))
@@ -45,7 +127,6 @@
           (env-vao env) (make-instance 'kit.gl.vao:vao :type 'sketch-vao)
           (env-white-pixel-texture env) (make-white-pixel-texture)
           (env-white-color-vector env) #(255 255 255 255)
-          (env-pen env) (make-default-pen)
           (env-font env) (make-default-font))
     (initialize-view-matrix sketch)
     (kit.gl.shader:use-program (env-programs env) :fill-shader)))

src/package.lisp

@@ -212,4 +212,8 @@
            :noise
            :noise-seed
            :noise-detail
+
+           ;; Environment extension
+           :define-environment-property
+           :*env*
            ))

src/pen.lisp

@@ -16,6 +16,12 @@
   (winding-rule :nonzero
    :type (member :odd :nonzero :positive :negative :abs-geq-two)))
 
+(defun make-default-pen ()
+  (make-pen :weight 1 :fill +white+ :stroke +black+))
+
+(define-environment-property :pen
+  (make-default-pen))
+
 (defmacro with-pen (pen &body body)
   (with-shorthand (pen make-pen)
     (alexandria:with-gensyms (previous-pen)
@@ -42,10 +48,3 @@
   "Fills the sketch window with COLOR."
   (apply #'gl:clear-color (color-rgba color))
   (gl:clear :color-buffer))
-
-(let ((pen))
-  (defun make-default-pen ()
-    (setf pen (or pen
-                  (make-pen :weight 1
-                            :fill +white+
-                            :stroke +black+)))))