From 8fc1317f0c3c32e3d75b17260b9b0c3ed810fd76 Mon Sep 17 00:00:00 2001 From: Colin Okay Date: Sat, 23 Jul 2022 10:44:40 -0500 Subject: [add] menu basics and [example] --- examples/13-menus.lisp | 47 ++++++++++++++++++++++++++ gui/menus.lisp | 89 ++++++++++++++++++++++++++++++++++++++++++++++++++ src/region.lisp | 32 ++++++++++++++++++ src/wheelwork.lisp | 2 ++ wheelwork-examples.asd | 3 +- wheelwork-gui.asd | 3 +- 6 files changed, 174 insertions(+), 2 deletions(-) create mode 100644 examples/13-menus.lisp create mode 100644 gui/menus.lisp diff --git a/examples/13-menus.lisp b/examples/13-menus.lisp new file mode 100644 index 0000000..66d455c --- /dev/null +++ b/examples/13-menus.lisp @@ -0,0 +1,47 @@ +;;;; menus.lisp + +(defpackage #:ww.examples/13 + (:use #:cl) + (:export #:start)) + +(in-package :ww.examples/13) + +(defclass menus-demo (ww::application) ()) + +(defclass numbered-image (ww::image) + ((n :initarg :num :reader num))) + +(ww:defhandler option-clicked + (ww::on-mousedown (img) + (format t "~a was clicked~%" (num img)))) + +(defmethod ww::boot ((app menus-demo)) + (let ((vscroller + (make-instance 'ww::vscroller + :scroll-speed 10 + :region (make-instance 'ww::region + :left 0 :right 100 + :top 250 :bottom 0)))) + (loop for i to 10 + for img = (make-instance 'numbered-image + :num i + :texture (ww:get-asset "Fezghoul.png")) + do + (ww::add-handler img #'option-clicked) + (ww::add-menu-option vscroller img)) + (ww:add-unit vscroller) + (ww:refocus-on vscroller))) + + +(defun start (&optional (scale 1.0) (side 500)) + (ww:start + (make-instance + 'menus-demo + :fps 30 + :width (round (* scale side)) + :height (round (* scale side)) + :scale scale + :title "Canvas demo" + :asset-root (merge-pathnames + "examples/" + (asdf:system-source-directory :wheelwork))))) diff --git a/gui/menus.lisp b/gui/menus.lisp new file mode 100644 index 0000000..1c4166c --- /dev/null +++ b/gui/menus.lisp @@ -0,0 +1,89 @@ +;;;; menus.lisp + +(in-package :wheelwork) + +(defclass/std menu (unit interactive) + ((options :with :std nil + :doc "A list of interactive units") + (region :std (error "Menus require an explicit region")))) + +(defmethod initialize-instance :after ((menu menu) &key) + (with-slots (base-width base-height region) menu + (setf base-width (width region) + base-height (height region) + (x menu) (region-left region) + (y menu) (region-bottom region)))) + +(macrolet + ((def-menu-accessors (&rest accessor-names) + (let ((defs + (loop for name in accessor-names + collect + `(defmethod ,name ((menu menu)) + (,name (unit-region menu))) + + collect + `(defmethod (setf ,name) (newval (menu menu)) + (let ((diff (- newval (,name menu)))) + (setf (,name (unit-region menu)) newval) + (dolist (o (menu-options menu)) + (incf (,name o) diff))))))) + `(progn ,@defs)))) + (def-menu-accessors x y width height)) + + +(defgeneric add-menu-option (menu option)) +(defmethod add-menu-option ((menu menu) option) + (setf (unit-region option) (unit-region menu)) + (add-unit option) + (setf (menu-options menu) + (nconc (menu-options menu) (list option)))) + +(defun remove-menu-option (menu option) + (when (member option (menu-options menu)) + (drop-unit option) + (setf (unit-region option) *application*) + (setf (menu-options menu) + (delete option (menu-options menu))))) + +(defmethod render ((menu menu)) + (dolist (o (menu-options menu)) + (render o))) + + +(defclass/std vscroller (menu) + ((scroll-speed :std 1) + (vert-scroll :std 0 + :doc "Vertical distance options have been displaced."))) + +(defmethod (setf vert-scroll) :after (val (vs vscroller)) + (loop + for o in (menu-options vs) + for y = (+ (y vs) (height vs) val) then (- y (height o)) + do (setf (y o) y))) + +(defhandler vscroller-scroll + (on-mousewheel (vs horiz vert) + (let ((oh (vscroller-options-height vs)) + (h (height vs))) + (format t "oh: ~a h: ~a scroll:~a ~%" oh h (vert-scroll vs)) + (setf (vert-scroll vs) + (clamp 0 + (+ (vert-scroll vs) (* vert (scroll-speed vs))) + (- oh h)))))) + +(defun vscroller-options-height (vs) + (loop for o in (menu-options vs) summing (height o))) + +(defmethod add-menu-option :before ((vs vscroller) option) + (setf (x option) (x vs) + (y option) (- (+ (y vs) (height vs) (vert-scroll vs)) + (vscroller-options-height vs)))) + +(defmethod initialize-instance :after ((vscroller vscroller) &key) + (add-handler vscroller #'vscroller-scroll)) + + + + + diff --git a/src/region.lisp b/src/region.lisp index 2355db6..4f22763 100644 --- a/src/region.lisp +++ b/src/region.lisp @@ -4,3 +4,35 @@ (defclass/std region () ((left bottom top right :with :std 0))) + +(defmethod width ((region region)) + (- (region-right region) (region-left region))) + +(defmethod (setf width) (newval (region region)) + (with-slots (left right) region + (setf right (+ left newval)))) + +(defmethod height ((region region)) + (- (region-top region) (region-bottom region))) + +(defmethod (setf height) (newval (region region)) + (with-slots (top bottom) region + (setf top (+ bottom newval)))) + +(defmethod x ((r region)) + (region-left r)) + +(defmethod (setf x) (newval (region region)) + (let ((width (width region))) ;;get before change + (with-slots (left right) + (setf left newval + right (+ newval width))))) + +(defmethod y ((r region)) + (region-bottom r)) + +(defmethod (setf y) (newval (region region)) + (let ((height (height region))) ;;get before change + (with-slots (top bottom) region + (setf bottom newval + top (+ newval height))))) diff --git a/src/wheelwork.lisp b/src/wheelwork.lisp index 4a20553..e411c52 100644 --- a/src/wheelwork.lisp +++ b/src/wheelwork.lisp @@ -6,11 +6,13 @@ "current application") (defun add-unit (unit) + "Adds a unit to the display." (assert *application*) (push unit (application-scene *application*)) (setf (unit-in-scene-p unit) t)) (defun drop-unit (unit) + "A removes a unit from the display." (assert *application*) (setf (application-scene *application*) (delete unit (application-scene *application*))) diff --git a/wheelwork-examples.asd b/wheelwork-examples.asd index 31f6d0b..085523a 100644 --- a/wheelwork-examples.asd +++ b/wheelwork-examples.asd @@ -17,4 +17,5 @@ (:file "09-ghoulspree") (:file "10-canvas-sneks") (:file "11-canvas-geometry") - (:file "12-canvas-drawing-language"))) + (:file "12-canvas-drawing-language") + (:file "13-menus"))) diff --git a/wheelwork-gui.asd b/wheelwork-gui.asd index aa58010..b6483a3 100644 --- a/wheelwork-gui.asd +++ b/wheelwork-gui.asd @@ -6,4 +6,5 @@ :serial t :depends-on (#:wheelwork) :pathname "gui/" - :components ((:file "button"))) + :components ((:file "button") + (:file "menus"))) -- cgit v1.2.3