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

separate selection and halo concepts

parent 34c410e4
......@@ -609,6 +609,9 @@
(defun do-show-buffer-properties-dialog ()
(show-buffer-properties-dialog (current-buffer)))
(defun do-trim () (trim (current-buffer)))
(defun do-trim-conservatively () (trim-conservatively (current-buffer)))
(defparameter *view-menu*
'(:label "View"
:inputs
......
......@@ -340,25 +340,31 @@
;; [[file:~/xelf/gui.org::*The%20selection][The selection:1]]
(defmethod get-selection ((self buffer))
(let ((all (append (get-nodes self) (slot-value self 'inputs))))
(remove-if-not #'(lambda (x) (slot-value x 'halo)) all)))
(remove-if-not #'selected-p all)))
(defmethod draw :after ((node node))
(when (selected-p node)
(with-slots (x y width height) node
(draw-box x y width height :color "cyan" :alpha (max 0.2 (+ 0.2 (sin (/ *updates* 2))))))))
(defun selection ()
(get-selection (current-buffer)))
(defun selected-object ()
(let ((sel (selection)))
(assert (consp sel))
(first sel)))
(when (consp sel))
(first sel)))
(defun clear-selection ()
(clear-halos (current-buffer))
(do-nodes (node (current-buffer))
(unselect node))
nil)
(defun select-all ()
(clear-halos (current-buffer))
(loop for thing being the hash-keys in
(slot-value (current-buffer) 'objects)
do (make-halo thing)))
(do-nodes (node (current-buffer))
(select thing)))
(defmethod destroy-selection ((self buffer))
(prog1 nil (mapc #'destroy (selection))))
......@@ -1574,20 +1580,20 @@ See sidebar for more commands to try.
;; [[file:~/xelf/gui.org::*Mouse%20events][Mouse events:1]]
(defmethod select ((self node)) nil)
(defmethod alternate-tap ((self node) x y)
(show-context-menu self))
(defmethod alternate-tap ((self node) x y)
(if (holding-control)
(show-context-menu self)
(toggle-halo self)))
(defmethod tap ((self node) x y) nil)
(defmethod tap :after ((self node) x y)
(bring-to-front self)
(defmethod tap :after ((node node) x y)
(bring-to-front node)
(with-shell
(when (shell-p (current-buffer))
(when (not (holding-control))
(clear-halos (current-buffer)))
(toggle-halo self))))
(clear-selection))
(toggle-selected node))))
(defmethod scroll-tap ((self node) x y)
(declare (ignore x y))
......@@ -1811,7 +1817,8 @@ See sidebar for more commands to try.
(with-slots (x y width height) (slot-value self 'target)
(resize (slot-value self 'target)
(- x0 x)
(- y0 y))))
(- y0 y))
(layout (slot-value (slot-value self 'target) 'halo))))
;;; Rotating objects interactively
......@@ -1900,16 +1907,7 @@ See sidebar for more commands to try.
(mapc #'layout (mapcar #'find-object (slot-value self 'inputs))))))
(defmethod draw ((self halo))
(with-slots (target) self
(let ((wx (window-pointer-x))
(wy (window-pointer-y)))
(multiple-value-bind (cx cy) (center-point target)
(with-slots (x y width height) target
(multiple-value-bind (top left right bottom) (bounding-box self)
(when (and (< left wx) (< wx right)
(< top wy) (< wy bottom))
(mapc #'draw (slot-value self 'inputs)))
(draw-box x y width height :color "white" :alpha (max 0.2 (+ 0.2 (sin (/ *updates* 2)))))))))))
(mapc #'draw (slot-value self 'inputs)))
(defmethod can-pick ((self halo))
(can-pick (slot-value self 'target)))
......@@ -2868,9 +2866,11 @@ See sidebar for more commands to try.
"When non-nil, dragging and moving are disallowed for this node."
(slot-value self 'pinned))
(defmethod layout ((self node))
(when (slot-value self 'image)
(resize-to-image self)))
(defmethod layout ((self node))
(when (slot-value self 'halo)
(layout (slot-value self 'halo))))
;; (when (slot-value self 'image)
;; (resize-to-image self)))
;; (with-slots (height width label) self
;; (with-slots (x y inputs) self
......
......@@ -176,10 +176,12 @@ every BUFFER is also a NODE.)
(zerop (hash-table-count objects)))))
#+end_src
** Buffers can't have halos
** Buffers can't have halos or be selected
#+begin_src lisp
(defmethod make-halo ((self buffer)) nil)
(defmethod select ((self buffer)) nil)
(defmethod unselect ((self buffer)) nil)
#+end_src
** Pausing the action
......@@ -380,25 +382,31 @@ The Selection is a list of the currently selected objects.
#+begin_src lisp
(defmethod get-selection ((self buffer))
(let ((all (append (get-nodes self) (slot-value self 'inputs))))
(remove-if-not #'(lambda (x) (slot-value x 'halo)) all)))
(remove-if-not #'selected-p all)))
(defmethod draw :after ((node node))
(when (selected-p node)
(with-slots (x y width height) node
(draw-box x y width height :color "cyan" :alpha (max 0.2 (+ 0.2 (sin (/ *updates* 2))))))))
(defun selection ()
(get-selection (current-buffer)))
(defun selected-object ()
(let ((sel (selection)))
(assert (consp sel))
(first sel)))
(when (consp sel))
(first sel)))
(defun clear-selection ()
(clear-halos (current-buffer))
(do-nodes (node (current-buffer))
(unselect node))
nil)
(defun select-all ()
(clear-halos (current-buffer))
(loop for thing being the hash-keys in
(slot-value (current-buffer) 'objects)
do (make-halo thing)))
(do-nodes (node (current-buffer))
(select thing)))
(defmethod destroy-selection ((self buffer))
(prog1 nil (mapc #'destroy (selection))))
......@@ -420,7 +428,7 @@ Find out which objects intersect the region, and select them.
(when (slot-value self 'region)
(clear-selection)
(dolist (each (region-objects self))
(make-halo each))
(select each))
(clear-region self)))
#+end_src
......@@ -1589,20 +1597,20 @@ above.
* Mouse events
#+begin_src lisp
(defmethod select ((self node)) nil)
(defmethod alternate-tap ((self node) x y)
(show-context-menu self))
(if (holding-control)
(show-context-menu self)
(toggle-halo self)))
(defmethod tap ((self node) x y) nil)
(defmethod tap :after ((self node) x y)
(bring-to-front self)
(defmethod tap :after ((node node) x y)
(bring-to-front node)
(with-shell
(when (shell-p (current-buffer))
(when (not (holding-control))
(clear-halos (current-buffer)))
(toggle-halo self))))
(clear-selection))
(toggle-selected node))))
(defmethod scroll-tap ((self node) x y)
(declare (ignore x y))
......@@ -1825,7 +1833,8 @@ above.
(with-slots (x y width height) (slot-value self 'target)
(resize (slot-value self 'target)
(- x0 x)
(- y0 y))))
(- y0 y))
(layout (slot-value (slot-value self 'target) 'halo))))
;;; Rotating objects interactively
......@@ -1914,16 +1923,7 @@ above.
(mapc #'layout (mapcar #'find-object (slot-value self 'inputs))))))
(defmethod draw ((self halo))
(with-slots (target) self
(let ((wx (window-pointer-x))
(wy (window-pointer-y)))
(multiple-value-bind (cx cy) (center-point target)
(with-slots (x y width height) target
(multiple-value-bind (top left right bottom) (bounding-box self)
(when (and (< left wx) (< wx right)
(< top wy) (< wy bottom))
(mapc #'draw (slot-value self 'inputs)))
(draw-box x y width height :color "white" :alpha (max 0.2 (+ 0.2 (sin (/ *updates* 2)))))))))))
(mapc #'draw (slot-value self 'inputs)))
(defmethod can-pick ((self halo))
(can-pick (slot-value self 'target)))
......@@ -2876,9 +2876,11 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
"When non-nil, dragging and moving are disallowed for this node."
(slot-value self 'pinned))
(defmethod layout ((self node))
(when (slot-value self 'image)
(resize-to-image self)))
(defmethod layout ((self node))
(when (slot-value self 'halo)
(layout (slot-value self 'halo))))
;; (when (slot-value self 'image)
;; (resize-to-image self)))
;; (with-slots (height width label) self
;; (with-slots (x y inputs) self
......@@ -5239,6 +5241,9 @@ supported compiler.
(defun do-show-buffer-properties-dialog ()
(show-buffer-properties-dialog (current-buffer)))
(defun do-trim () (trim (current-buffer)))
(defun do-trim-conservatively () (trim-conservatively (current-buffer)))
(defparameter *view-menu*
'(:label "View"
:inputs
......
......@@ -48,6 +48,9 @@
;; (trace xelf::evaluate-expression)
;; (trace xelf::evaluate-output)
;; (trace xelf::layout)
(trace xelf::select)
(trace xelf::unselect)
(trace xelf::toggle-selected)
(trace xelf::backtab)
(trace xelf::handle-event)
(trace xelf::do-show-buffer-properties-dialog)
......
......@@ -5225,6 +5225,7 @@ Returns a newly allocated list."
;; [[file:~/xelf/xelf.org::*Node%20class][Node class:1]]
(defclass node (quadrille)
((tags :initform nil :accessor tags :initarg :tags)
(selected-p :initform nil :accessor selected-p :initarg :selected-p)
(events :initform nil :accessor events :initarg :events :documentation "Event bindings, if any. See also `bind-event'.")
(default-events :initform nil :accessor default-events :initarg :default-events)
(color :initform "white" :accessor color :initarg :color)
......@@ -5261,6 +5262,17 @@ Returns a newly allocated list."
(read-only :initform nil :accessor read-only :initarg :read-only)
(image :initform nil :accessor image :initarg :image :documentation "Name of texture to be displayed, if any.")))
(defmethod select ((node node))
(setf (selected-p node) t))
(defmethod unselect ((node node))
(setf (selected-p node) nil))
(defmethod toggle-selected ((node node))
(if (selected-p node)
(unselect node)
(select node)))
(defgeneric find-methods (object)
(:method-combination append))
......@@ -5359,8 +5371,8 @@ Returns a newly allocated list."
:blend blend :opacity opacity
:height height :width width)
(draw-box x y width height :color color))
(mapc #'draw inputs)
(when halo (draw halo))))
(mapc #'draw inputs)))
;; (when halo (draw halo))))
;; (progn (draw-patch self x y (+ x width) (+ y height))
;; (mapc #'draw %inputs)))))
;; Default node DRAW method:1 ends here
......
......@@ -5216,6 +5216,7 @@ subclasses.)
#+begin_src lisp
(defclass node (quadrille)
((tags :initform nil :accessor tags :initarg :tags)
(selected-p :initform nil :accessor selected-p :initarg :selected-p)
(events :initform nil :accessor events :initarg :events :documentation "Event bindings, if any. See also `bind-event'.")
(default-events :initform nil :accessor default-events :initarg :default-events)
(color :initform "white" :accessor color :initarg :color)
......@@ -5252,6 +5253,17 @@ subclasses.)
(read-only :initform nil :accessor read-only :initarg :read-only)
(image :initform nil :accessor image :initarg :image :documentation "Name of texture to be displayed, if any.")))
(defmethod select ((node node))
(setf (selected-p node) t))
(defmethod unselect ((node node))
(setf (selected-p node) nil))
(defmethod toggle-selected ((node node))
(if (selected-p node)
(unselect node)
(select node)))
(defgeneric find-methods (object)
(:method-combination append))
......@@ -5344,8 +5356,8 @@ a rectangle whose color is the value of the COLOR slot. See also [[file:dictiona
:blend blend :opacity opacity
:height height :width width)
(draw-box x y width height :color color))
(mapc #'draw inputs)
(when halo (draw halo))))
(mapc #'draw inputs)))
;; (when halo (draw halo))))
;; (progn (draw-patch self x y (+ x width) (+ y height))
;; (mapc #'draw %inputs)))))
#+end_src
......@@ -5400,6 +5412,7 @@ in the future.
(let ((dupe (duplicate thing)))
(prog1 (find-object dupe)
(setf (slot-value dupe 'halo) nil)
(setf (slot-value dupe 'selected-p) nil)
(setf (uuid dupe) (make-uuid))
(register-uuid dupe)
(setf (quadtree-node dupe) nil))))
......
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