[add] menu basics and [example]

6 files changed, 174 insertions, 2 deletions

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")))