[add] menu basics and [example]

1 files changed, 89 insertions, 0 deletions

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