diff --git a/src/environment.lisp b/src/environment.lisp index 6a2ef22..16b5447 100644 --- a/src/environment.lisp +++ b/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))) diff --git a/src/package.lisp b/src/package.lisp index 5756f14..7eff119 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -212,4 +212,8 @@ :noise :noise-seed :noise-detail + + ;; Environment extension + :define-environment-property + :*env* )) diff --git a/src/pen.lisp b/src/pen.lisp index 883b958..1ab1d5e 100644 --- a/src/pen.lisp +++ b/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+)))))