From 6d9b8b48423dba99ecdba004f260c30e6717b6a6 Mon Sep 17 00:00:00 2001 From: Colin Okay Date: Thu, 21 Jul 2022 11:34:37 -0500 Subject: [add] gui package. moved button.lisp into gui --- gui/button.lisp | 113 ++++++++++++++++++++++++++++++++++++++++++++ src/interactive/button.lisp | 113 -------------------------------------------- wheelwork-gui.asd | 9 ++++ wheelwork.asd | 2 +- 4 files changed, 123 insertions(+), 114 deletions(-) create mode 100644 gui/button.lisp delete mode 100644 src/interactive/button.lisp create mode 100644 wheelwork-gui.asd diff --git a/gui/button.lisp b/gui/button.lisp new file mode 100644 index 0000000..7c94663 --- /dev/null +++ b/gui/button.lisp @@ -0,0 +1,113 @@ +;;;; button.lisp + +(in-package #:wheelwork) + +(defclass/std button (unit interactive) + ((up down :with + :std (error "UP and DOWN lots are required") + :doc "Any affine renderable unit") + (bg :with) + (on-press on-release :with :doc "Function accepting the button.")) + (:documentation "A basic button class. The UP and DOWN slots should + be filled with renderable objects having the same size.")) + +(defhandler button-released + (on-mouseup () + (with-slots (up down on-release) target + (setf (unit-visiblep up) t + (unit-visiblep down) nil) + (when on-release + (funcall on-release target))))) + +(defhandler button-pressed + (on-mousedown () + (with-slots (up down on-press) target + (setf (unit-visiblep up) nil + (unit-visiblep down) t) + (when on-press + (funcall on-press target))))) + +(defmethod (setf closer-mop:slot-value-using-class) :before + (newval class (button button) slot) + (let ((slot-name + (closer-mop:slot-definition-name slot))) + (case slot-name + ((up down bg) + (when (slot-boundp button slot-name) + (error "Swapping Button Faces Not Presently Supported")))))) + +(defmethod initialize-instance :after ((button button) &key) + (add-handler button #'button-pressed) + (add-handler button #'button-released) + (with-slots (up down bg) button + (when bg + (setf (unit-container bg) button + (unit-visiblep bg) t)) + (setf (unit-visiblep down) nil + (unit-visiblep up) t + (unit-container up) button + (unit-container down) button))) + +(defmethod cleanup ((button button)) + (with-slots (up down bg) button + (when bg (cleanup bg)) + (cleanup up) + (cleanup down))) + +(defmethod render ((button button)) + (with-slots (up down bg) button + (when bg (render bg)) + (if (unit-visiblep up) + (render up) + (render down)))) + +(macrolet + ((def-accessors (&rest accessor-names) + (let ((defs + (loop for accessor-name in accessor-names + collect + `(defmethod ,accessor-name ((button button)) + (,accessor-name (button-up button))) + + collect + `(defmethod (setf ,accessor-name) (newval (button button)) + (setf (,accessor-name (button-up button)) newval + (,accessor-name (button-down button)) newval) + (when (button-bg button) + (setf (,accessor-name (button-bg button)) newval)))))) + `(progn ,@defs)))) + + (def-accessors x y scale-x scale-y width height rotation)) + +(defmethod get-rect ((button button)) + (get-rect (button-up button))) + +(defun make-texture-button (up down &key pressed released) + "UP and DOWN should be strings naming assets to use as the up and + down images for the button." + (make-instance + 'button + :on-press pressed :on-release released + :up (make-instance 'image :texture (get-asset up)) + :down (make-instance 'image :texture (get-asset down)))) + +(defun make-text-button + (font up down + &key + pressed released + down-font + (up-color #(1.0 1.0 1.0 1.0)) + (down-color #(1.0 1.0 1.0 1.0))) + (make-instance + 'button + :on-release released :on-press pressed + :up (make-instance + 'text + :content up + :color up-color + :font font) + :down (make-instance + 'text + :content down + :color down-color + :font (or down-font font)))) diff --git a/src/interactive/button.lisp b/src/interactive/button.lisp deleted file mode 100644 index 7c94663..0000000 --- a/src/interactive/button.lisp +++ /dev/null @@ -1,113 +0,0 @@ -;;;; button.lisp - -(in-package #:wheelwork) - -(defclass/std button (unit interactive) - ((up down :with - :std (error "UP and DOWN lots are required") - :doc "Any affine renderable unit") - (bg :with) - (on-press on-release :with :doc "Function accepting the button.")) - (:documentation "A basic button class. The UP and DOWN slots should - be filled with renderable objects having the same size.")) - -(defhandler button-released - (on-mouseup () - (with-slots (up down on-release) target - (setf (unit-visiblep up) t - (unit-visiblep down) nil) - (when on-release - (funcall on-release target))))) - -(defhandler button-pressed - (on-mousedown () - (with-slots (up down on-press) target - (setf (unit-visiblep up) nil - (unit-visiblep down) t) - (when on-press - (funcall on-press target))))) - -(defmethod (setf closer-mop:slot-value-using-class) :before - (newval class (button button) slot) - (let ((slot-name - (closer-mop:slot-definition-name slot))) - (case slot-name - ((up down bg) - (when (slot-boundp button slot-name) - (error "Swapping Button Faces Not Presently Supported")))))) - -(defmethod initialize-instance :after ((button button) &key) - (add-handler button #'button-pressed) - (add-handler button #'button-released) - (with-slots (up down bg) button - (when bg - (setf (unit-container bg) button - (unit-visiblep bg) t)) - (setf (unit-visiblep down) nil - (unit-visiblep up) t - (unit-container up) button - (unit-container down) button))) - -(defmethod cleanup ((button button)) - (with-slots (up down bg) button - (when bg (cleanup bg)) - (cleanup up) - (cleanup down))) - -(defmethod render ((button button)) - (with-slots (up down bg) button - (when bg (render bg)) - (if (unit-visiblep up) - (render up) - (render down)))) - -(macrolet - ((def-accessors (&rest accessor-names) - (let ((defs - (loop for accessor-name in accessor-names - collect - `(defmethod ,accessor-name ((button button)) - (,accessor-name (button-up button))) - - collect - `(defmethod (setf ,accessor-name) (newval (button button)) - (setf (,accessor-name (button-up button)) newval - (,accessor-name (button-down button)) newval) - (when (button-bg button) - (setf (,accessor-name (button-bg button)) newval)))))) - `(progn ,@defs)))) - - (def-accessors x y scale-x scale-y width height rotation)) - -(defmethod get-rect ((button button)) - (get-rect (button-up button))) - -(defun make-texture-button (up down &key pressed released) - "UP and DOWN should be strings naming assets to use as the up and - down images for the button." - (make-instance - 'button - :on-press pressed :on-release released - :up (make-instance 'image :texture (get-asset up)) - :down (make-instance 'image :texture (get-asset down)))) - -(defun make-text-button - (font up down - &key - pressed released - down-font - (up-color #(1.0 1.0 1.0 1.0)) - (down-color #(1.0 1.0 1.0 1.0))) - (make-instance - 'button - :on-release released :on-press pressed - :up (make-instance - 'text - :content up - :color up-color - :font font) - :down (make-instance - 'text - :content down - :color down-color - :font (or down-font font)))) diff --git a/wheelwork-gui.asd b/wheelwork-gui.asd new file mode 100644 index 0000000..aa58010 --- /dev/null +++ b/wheelwork-gui.asd @@ -0,0 +1,9 @@ +(asdf:defsystem #:wheelwork-gui + :description "GUI elments for wheelwork" + :author "colin " + :license "GPL-3.0" + :version "0.0.1" + :serial t + :depends-on (#:wheelwork) + :pathname "gui/" + :components ((:file "button"))) diff --git a/wheelwork.asd b/wheelwork.asd index 0629d82..8d12b84 100644 --- a/wheelwork.asd +++ b/wheelwork.asd @@ -39,7 +39,7 @@ :components ((:file "interactive") (:file "image") (:file "text") - (:file "button") + (:file "frameset") (:file "sprite") (:file "canvas"))) -- cgit v1.2.3