Commit a9a84f41 authored by David O'Toole's avatar David O'Toole

revise menu click handling

parent 4c1f1b7a
......@@ -81,6 +81,22 @@
(dolist (item items)
(insert-output self item)))
(defmethod hit ((self menu) mouse-x mouse-y)
(with-slots (x y expanded inputs width height) self
(when (within-extents mouse-x mouse-y x y (+ x width) (+ y height))
(flet ((try (item)
(hit item mouse-x mouse-y)))
(if (not expanded)
self
(some #'try inputs))))))
;; ;; we're expanded. is the mouse to the left of this
;; ;; tree's header tab thingy?
;; (if (slot-value self 'top-level)
;; (when (and (< mouse-x (+ x (header-width self)))
;; (< (header-height self) mouse-y))
;; (some #'try inputs))
;; (or (some #'try inputs) self)))))))
(defmethod hit ((self shell) x y)
(with-buffer self
(with-slots (inputs) self
......@@ -178,6 +194,150 @@
(update *menubar*)))
;; Automatic layout:1 ends here
;; Dialog box builder
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Dialog%20box%20builder][Dialog box builder:1]]
(defclass dialog (phrase)
((orientation :initform :vertical)
(no-background :initform nil)
(style :initform :rounded)))
(defmethod draw-background ((self dialog) &key color)
(with-slots (x y width height) self
(draw-patch self x y (+ x width) (+ y height) :color color :style :rounded)))
(defmethod tap ((dialog dialog) x y)
(bring-to-front (or (parent dialog) dialog)))
(defmacro define-dialog (name arglist &body body)
`(progn
(defun ,(action-name name) (&key arglist) ,@body)
(export ',(action-name name))
(defun ,(show-name name) (&rest args)
(show-dialog (apply #'make-instance ',(dialog-class-name name) args)
,(command-name-string name)))
(export ',(show-name name))
(define-visual-macro ,(dialog-class-name name)
(:super dialog
:slots ((orientation :initform :vertical))
:inputs ,(command-inputs name arglist)))
(export ',(dialog-class-name name))
(defmethod evaluate ((self ,(dialog-class-name name)))
;; call the command function
(apply #'funcall #',(action-name name)
;; with the evaluated results of
(mapcar #'evaluate
;; all the argument names/values
(mapcan #'identity
(mapcar #'%inputs
;; from the dialog box
(%inputs (first (slot-value self 'inputs))))))))))
(defmacro define-command-dialog (name arglist &body body)
`(define-dialog ,name ,arglist
(labels ((arg (name) (getf ^args^ name)))
,@body)))
(defclass property-sheet (dialog)
((orientation :initform :vertical)
(default-values :initform nil)
(methods :initform '(apply-properties restore-default-values cancel-properties))
(instance :initform nil :initarg :instance :accessor instance)
(properties :initform nil :initarg :properties :accessor properties)))
(defclass property-row (phrase)
((no-background :initform nil)
(style :initform :rounded)))
(defmethod focus-on :after ((buffer buffer) (row property-row) &key (clear-selection t))
(when row
(focus-on buffer (second (inputs row)))))
(defclass property-value-entry (expression-entry) ())
(defmethod backtab ((entry property-value-entry))
(backtab (current-buffer)))
(defmethod find-tab-parent ((entry property-value-entry))
(parent (parent entry)))
(defmethod find-tab-proxy ((entry property-value-entry))
(parent entry))
(defmethod draw-background ((self property-row) &key color)
(with-slots (x y width height) self
(draw-patch self x y (+ x width) (+ y height) :depressed nil :style :rounded)))
(defmethod initialize-instance :after ((sheet property-sheet) &key)
(with-slots (inputs properties instance default-values) sheet
(dolist (property properties)
(let ((row (make-sentence
(list
(make-instance 'pretty-symbol-entry
:value property
:locked t
:read-only t)
(make-instance 'property-value-entry
:value (slot-value instance property)
:read-only nil))
'property-row)))
;; (setf (no-background row) nil)
(push row inputs)
(push (slot-value instance property) default-values)))
(setf default-values (nreverse default-values))
(setf inputs (nreverse inputs))
(update-parent-links sheet)
(freeze sheet)))
(defmethod restore-default-values ((sheet property-sheet))
(with-slots (inputs properties instance default-values) sheet
(let ((i inputs)
(d default-values))
(flet ((entry () (second (inputs (first i)))))
(dolist (property properties)
(set-value (entry) (pop d))
(pop i))))))
(defmethod layout :after ((sheet property-sheet))
(assert (every #'(lambda (d) (= 2 (length (inputs d)))) (inputs sheet))))
(defmethod get-property-object-pairs ((sheet property-sheet))
(mapcar #'inputs (inputs sheet)))
(defmethod get-property-entries ((sheet property-sheet))
(apply #'append (get-property-object-pairs sheet)))
(defmethod get-property-list ((sheet property-sheet))
(mapcar #'evaluate (get-property-entries sheet)))
(defmethod apply-properties ((sheet property-sheet) &optional instance)
(let ((plist (get-property-list sheet))
(i (or instance (instance sheet))))
(loop while plist do
(let* ((slot (pop plist))
(value (pop plist)))
(setf (slot-value i slot) value)))))
(defmethod cancel-properties ((sheet property-sheet))
(if (parent sheet)
(destroy (parent sheet))
(destroy sheet)))
(defmethod evaluate ((sheet property-sheet))
(prog1 nil (apply-properties sheet (instance sheet))))
(defvar *instance* nil)
(defmacro define-properties-dialog (name slot-names &rest body)
`(progn
(defun ,(show-name name) (&optional (instance *instance*))
(show-dialog (make-instance ',(dialog-class-name name) :instance instance)
,(command-name-string name)))
(defclass ,(dialog-class-name name) (property-sheet)
((properties :initform ',slot-names)))))
;; Dialog box builder:1 ends here
;; System object
......@@ -527,7 +687,7 @@
(expand candidate))
;; no menu was open---just hit the menu headers
(some #'try inputs)))))))))))
(defmethod draw-border ((self menubar) &optional ignore) nil)
(defmethod layout ((self menubar))
......@@ -563,6 +723,7 @@
(defmethod tap ((self menubar) x y)
(let ((target (hit self x y)))
(show-status (format nil "Hitting target ~S" target))
(when (not (object-eq target self))
(tap target x y))
(close-menus self)))
......@@ -590,6 +751,8 @@
(defmethod layout ((self frame-close-button))
(resize self 20 20))
(define-visual-macro titlebar
(:super phrase
:slots ((frozen :initform t)
......
......@@ -4141,6 +4141,10 @@ See sidebar for more commands to try.
(when (slot-value self 'parent)
(remove-if-not #'menup (slot-value (slot-value self 'parent) 'inputs))))
;; (defmethod layout-as-string :after ((self menu) string)
;; (with-slots (width parent) self
;; (when parent (setf width (1- (slot-value parent 'width))))))
(defmethod make-halo ((self menu)) nil)
(defvar *menu-prototype* nil)
......@@ -4252,20 +4256,21 @@ See sidebar for more commands to try.
(when (and parent (fboundp action))
(with-slots (x width) parent
;; don't highlight top-level trees.
(when (and (not expanded) (not top-level))
(when (and (not expanded) (not top-level))
(draw-box (+ x (dash 2))
(+ y (dash 1))
(- width (dash 4))
(+ height 1)
:color *highlight-background-color*)
:color *highlight-background-color*)
(draw-label-string self (display-string self) *highlight-foreground-color*))))))
(defmethod layout :after ((self menu))
(with-slots (width height expanded) self
(when expanded
(incf width 75)
(incf height 10))))
(incf width 20)
(incf height 10)
(mapc #'layout (inputs self)))))
(defmethod draw :after ((self menu))
(with-slots (inputs) self
(let ((x (window-pointer-x))
......@@ -4278,150 +4283,6 @@ See sidebar for more commands to try.
(draw-highlight self)))))))
;; Menu widget:1 ends here
;; Dialog box builder
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Dialog%20box%20builder][Dialog box builder:1]]
(defclass dialog (phrase)
((orientation :initform :vertical)
(no-background :initform nil)
(style :initform :rounded)))
(defmethod draw-background ((self dialog) &key color)
(with-slots (x y width height) self
(draw-patch self x y (+ x width) (+ y height) :color color :style :rounded)))
(defmethod tap ((dialog dialog) x y)
(bring-to-front (or (parent dialog) dialog)))
(defmacro define-dialog (name arglist &body body)
`(progn
(defun ,(action-name name) (&key arglist) ,@body)
(export ',(action-name name))
(defun ,(show-name name) (&rest args)
(show-dialog (apply #'make-instance ',(dialog-class-name name) args)
,(command-name-string name)))
(export ',(show-name name))
(define-visual-macro ,(dialog-class-name name)
(:super dialog
:slots ((orientation :initform :vertical))
:inputs ,(command-inputs name arglist)))
(export ',(dialog-class-name name))
(defmethod evaluate ((self ,(dialog-class-name name)))
;; call the command function
(apply #'funcall #',(action-name name)
;; with the evaluated results of
(mapcar #'evaluate
;; all the argument names/values
(mapcan #'identity
(mapcar #'%inputs
;; from the dialog box
(%inputs (first (slot-value self 'inputs))))))))))
(defmacro define-command-dialog (name arglist &body body)
`(define-dialog ,name ,arglist
(labels ((arg (name) (getf ^args^ name)))
,@body)))
(defclass property-sheet (dialog)
((orientation :initform :vertical)
(default-values :initform nil)
(methods :initform '(apply-properties restore-default-values cancel-properties))
(instance :initform nil :initarg :instance :accessor instance)
(properties :initform nil :initarg :properties :accessor properties)))
(defclass property-row (phrase)
((no-background :initform nil)
(style :initform :rounded)))
(defmethod focus-on :after ((buffer buffer) (row property-row) &key (clear-selection t))
(when row
(focus-on buffer (second (inputs row)))))
(defclass property-value-entry (expression-entry) ())
(defmethod backtab ((entry property-value-entry))
(backtab (current-buffer)))
(defmethod find-tab-parent ((entry property-value-entry))
(parent (parent entry)))
(defmethod find-tab-proxy ((entry property-value-entry))
(parent entry))
(defmethod draw-background ((self property-row) &key color)
(with-slots (x y width height) self
(draw-patch self x y (+ x width) (+ y height) :depressed nil :style :rounded)))
(defmethod initialize-instance :after ((sheet property-sheet) &key)
(with-slots (inputs properties instance default-values) sheet
(dolist (property properties)
(let ((row (make-sentence
(list
(make-instance 'pretty-symbol-entry
:value property
:locked t
:read-only t)
(make-instance 'property-value-entry
:value (slot-value instance property)
:read-only nil))
'property-row)))
;; (setf (no-background row) nil)
(push row inputs)
(push (slot-value instance property) default-values)))
(setf default-values (nreverse default-values))
(setf inputs (nreverse inputs))
(update-parent-links sheet)
(freeze sheet)))
(defmethod restore-default-values ((sheet property-sheet))
(with-slots (inputs properties instance default-values) sheet
(let ((i inputs)
(d default-values))
(flet ((entry () (second (inputs (first i)))))
(dolist (property properties)
(set-value (entry) (pop d))
(pop i))))))
(defmethod layout :after ((sheet property-sheet))
(assert (every #'(lambda (d) (= 2 (length (inputs d)))) (inputs sheet))))
(defmethod get-property-object-pairs ((sheet property-sheet))
(mapcar #'inputs (inputs sheet)))
(defmethod get-property-entries ((sheet property-sheet))
(apply #'append (get-property-object-pairs sheet)))
(defmethod get-property-list ((sheet property-sheet))
(mapcar #'evaluate (get-property-entries sheet)))
(defmethod apply-properties ((sheet property-sheet) &optional instance)
(let ((plist (get-property-list sheet))
(i (or instance (instance sheet))))
(loop while plist do
(let* ((slot (pop plist))
(value (pop plist)))
(setf (slot-value i slot) value)))))
(defmethod cancel-properties ((sheet property-sheet))
(if (parent sheet)
(destroy (parent sheet))
(destroy sheet)))
(defmethod evaluate ((sheet property-sheet))
(prog1 nil (apply-properties sheet (instance sheet))))
(defvar *instance* nil)
(defmacro define-properties-dialog (name slot-names &rest body)
`(progn
(defun ,(show-name name) (&optional (instance *instance*))
(show-dialog (make-instance ',(dialog-class-name name) :instance instance)
,(command-name-string name)))
(defclass ,(dialog-class-name name) (property-sheet)
((properties :initform ',slot-names)))))
;; Dialog box builder:1 ends here
;; Show methods definitions in Emacs :emacs:
......
......@@ -4149,6 +4149,10 @@ supported compiler.
(when (slot-value self 'parent)
(remove-if-not #'menup (slot-value (slot-value self 'parent) 'inputs))))
;; (defmethod layout-as-string :after ((self menu) string)
;; (with-slots (width parent) self
;; (when parent (setf width (1- (slot-value parent 'width))))))
(defmethod make-halo ((self menu)) nil)
(defvar *menu-prototype* nil)
......@@ -4260,20 +4264,21 @@ supported compiler.
(when (and parent (fboundp action))
(with-slots (x width) parent
;; don't highlight top-level trees.
(when (and (not expanded) (not top-level))
(when (and (not expanded) (not top-level))
(draw-box (+ x (dash 2))
(+ y (dash 1))
(- width (dash 4))
(+ height 1)
:color *highlight-background-color*)
:color *highlight-background-color*)
(draw-label-string self (display-string self) *highlight-foreground-color*))))))
(defmethod layout :after ((self menu))
(with-slots (width height expanded) self
(when expanded
(incf width 75)
(incf height 10))))
(incf width 20)
(incf height 10)
(mapc #'layout (inputs self)))))
(defmethod draw :after ((self menu))
(with-slots (inputs) self
(let ((x (window-pointer-x))
......@@ -4603,6 +4608,22 @@ supported compiler.
(dolist (item items)
(insert-output self item)))
(defmethod hit ((self menu) mouse-x mouse-y)
(with-slots (x y expanded inputs width height) self
(when (within-extents mouse-x mouse-y x y (+ x width) (+ y height))
(flet ((try (item)
(hit item mouse-x mouse-y)))
(if (not expanded)
self
(some #'try inputs))))))
;; ;; we're expanded. is the mouse to the left of this
;; ;; tree's header tab thingy?
;; (if (slot-value self 'top-level)
;; (when (and (< mouse-x (+ x (header-width self)))
;; (< (header-height self) mouse-y))
;; (some #'try inputs))
;; (or (some #'try inputs) self)))))))
(defmethod hit ((self shell) x y)
(with-buffer self
(with-slots (inputs) self
......@@ -4703,7 +4724,7 @@ supported compiler.
** Dialog box builder
#+begin_src lisp commands.lisp
#+begin_src lisp :tangle commands.lisp
(defclass dialog (phrase)
((orientation :initform :vertical)
(no-background :initform nil)
......@@ -5192,7 +5213,7 @@ supported compiler.
(expand candidate))
;; no menu was open---just hit the menu headers
(some #'try inputs)))))))))))
(defmethod draw-border ((self menubar) &optional ignore) nil)
(defmethod layout ((self menubar))
......@@ -5228,6 +5249,7 @@ supported compiler.
(defmethod tap ((self menubar) x y)
(let ((target (hit self x y)))
(show-status (format nil "Hitting target ~S" target))
(when (not (object-eq target self))
(tap target x y))
(close-menus self)))
......@@ -5254,6 +5276,8 @@ supported compiler.
(defmethod layout ((self frame-close-button))
(resize self 20 20))
(define-visual-macro titlebar
(:super phrase
:slots ((frozen :initform t)
......
......@@ -5,6 +5,7 @@
*** TODO [#A] context-menu with reset-to-current-values
**** TODO [#A] pin down context menu elements
**** TODO [#A] fix broken layout/rendering of context menu
*** TODO add more notifications for cut/copy etc
*** TODO [#A] show error bubble and restore value when input incorrect
*** TODO [#C] fix halos not always being in front
*** TODO [#C] don't allow halo on properties dialog
......
......@@ -60,6 +60,11 @@
(trace xelf::make-tree)
(trace xelf::make-halo)
(trace xelf::make-method-menu-item)
(trace xelf::release)
(trace xelf::press)
;; (trace xelf::display-string)
;; (trace xelf::layout-as-string)
;; (trace xelf::layout)
;; (trace xelf::hit)
(test-gui)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment