Commit 36f71eb0 authored by David O'Toole's avatar David O'Toole

z-ordering when shell is open

parent 2c279e23
......@@ -2679,7 +2679,9 @@ See sidebar for more commands to try.
(width (when parent (- (slot-value parent 'width) 1))))
(multiple-value-bind (top left right bottom) (bounding-box self)
(when (and (< left x right) (< top y bottom))
(draw-box (- left 3) (+ top 1) (or width (- right left -8)) (- bottom top -2) :color "gray30"))))
(if top-level
(draw-box (+ left 2) (+ top 1) (or width (- right left -2)) (- bottom top -2) :color "gray30")
(draw-box (- left 3) (+ top 1) (or width (- right left -8)) (- bottom top -2) :color "gray30")))))
(let ((text (or label (display-string self))))
(draw-label-string self
text
......
......@@ -3324,7 +3324,9 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
(let ((box (make-instance 'text :text *copyright-notice*)))
(add-node (current-buffer) box 80 80)
(resize-to-scroll box 300 300)
(setf (slot-value box 'max-displayed-lines) 20)))
(setf (slot-value box 'max-displayed-lines) 20)
(center box)
(bring-to-front box)))
(defmethod show-help ((self system))
(show-help (current-buffer)))
......
* Task list
** TODO scrolling the buffer window
** TODO [#A] Buffer switch menu
** TODO [#A] test command dialogs
** TODO [#A] create buffer switch menu
** TODO [#A] fix command dialogs
** TODO [#A] fix can't drag item out of shell
** TODO [#A] save-buffer
** TODO [#A] load-buffer
** TODO [#A] load-project
** TODO [#B] select-all
** TODO [#A] scrolling the buffer window
** TODO [#A] snap-to-grid and offset
** TODO [#A] select-all
** TODO [#A] general properties browser
*** TODO shell create/pop out 1 property of 1 object
*** TODO shell create/pop out property/method browser
*** TODO controls in sidebar?
*** TODO create GUI for scrolling the window
** TODO [#B] test find-buffer
** TODO [#B] destroy-selection
** TODO [#B] (paste (get-selection (find-buffer "palette")))
** TODO [#B] recover sidebar
** TODO [#B] test multiline text edit
** TODO [#B] any move handle should move group
** TODO [#B] snap-to-grid and offset
** TODO [#B] general properties browser
*** TODO shell create/pop out 1 property of 1 object
*** TODO shell create/pop out property/method browser
*** TODO controls in sidebar?
*** TODO create GUI for scrolling the window
** TODO [#B] fix any move handle should move group
** TODO [#B] choose and export more accessor names for buffer/node slots
** TODO [#B] Document how to clear all caches
** TODO [#B] should block widgets be marked as :collision-type nil?
......
......@@ -4273,6 +4273,14 @@ Returns a newly allocated list."
(tasks :initform nil)
(image :initform nil :accessor image :initarg :image :documentation "Name of texture to be displayed, if any.")))
(defmethod bring-to-front ((self node))
(with-slots (z) self
(setf z (max (or z 1)
(+ 1 (maximum-z-value (current-buffer)))))))
(defmethod send-to-back ((self node))
(setf (slot-value self 'z) 1))
(defmethod destroy :before ((self node))
(destroy-halo self))
......@@ -4428,7 +4436,8 @@ Returns a newly allocated list."
non-nil to indicate that the block was accepted, nil otherwise."
nil)
(defmethod finish-drag ((self node)) nil)
(defmethod finish-drag ((self node))
(bring-to-front self))
(defvar *buffers* nil
"When non-nil, the UUID of the current buffer object.")
......@@ -4953,6 +4962,9 @@ Returns a newly allocated list."
(defclass buffer (node qbuffer)
((name :initform nil)
(object-bag :initform nil :accessor object-bag :initarg :object-bag)
(zbuffer :initform (make-array 100 :adjustable t :initial-element nil :fill-pointer t)
:accessor zbuffer
:initarg :zbuffer)
(selection :initform nil)
(buffer-name :initform "*untitled-buffer*" :accessor buffer-name :initarg :buffer-name)
(variables :initform nil :accessor variables :initarg :variables)
......@@ -5056,7 +5068,7 @@ Returns a newly allocated list."
(with-shell
(setf (shell-p self) nil)
(with-slots (last-focus focused-block selection) self
(when *amenubar* (close-menus *menubar*))
(when *menubar* (close-menus *menubar*))
(focus-on self last-focus)
(setf last-focus nil)
(setf selection nil))))
......@@ -5440,6 +5452,16 @@ Returns a newly allocated list."
(when (colliding-with-bounding-box-p (find-object object) top left right bottom)
(draw (find-object object))))))
(defmethod draw-object-layer-z-sorted ((self buffer))
(with-slots (zbuffer) self
(setf (fill-pointer zbuffer) 0)
(multiple-value-bind (top left right bottom) (window-bounding-box self)
(loop for object being the hash-keys of (slot-value self 'objects) do
(when (colliding-with-bounding-box-p (find-object object) top left right bottom)
(vector-push-extend (find-object object) zbuffer))))
(setf zbuffer (sort zbuffer #'< :key #'%z))
(map nil #'draw zbuffer)))
(defmethod draw :before ((self buffer))
(with-buffer self
(project-window self)))
......@@ -5455,7 +5477,9 @@ Returns a newly allocated list."
(draw-box 0 0 width height
:color background-color)))
;; now draw the object layer
(draw-object-layer self)
(if (shell-p self)
(draw-object-layer-z-sorted self)
(draw-object-layer self))
;; draw shell
(with-shell
(when (shell-p self)
......
......@@ -5169,6 +5169,18 @@ subclasses.
(image :initform nil :accessor image :initarg :image :documentation "Name of texture to be displayed, if any.")))
#+end_src
** Z-order
#+begin_src lisp
(defmethod bring-to-front ((self node))
(with-slots (z) self
(setf z (max (or z 1)
(+ 1 (maximum-z-value (current-buffer)))))))
(defmethod send-to-back ((self node))
(setf (slot-value self 'z) 1))
#+end_src
** Destruction
#+begin_src lisp
......@@ -5372,7 +5384,8 @@ in the future.
non-nil to indicate that the block was accepted, nil otherwise."
nil)
(defmethod finish-drag ((self node)) nil)
(defmethod finish-drag ((self node))
(bring-to-front self))
(defvar *buffers* nil
"When non-nil, the UUID of the current buffer object.")
......@@ -5957,6 +5970,9 @@ every BUFFER is also a NODE.)
(defclass buffer (node qbuffer)
((name :initform nil)
(object-bag :initform nil :accessor object-bag :initarg :object-bag)
(zbuffer :initform (make-array 100 :adjustable t :initial-element nil :fill-pointer t)
:accessor zbuffer
:initarg :zbuffer)
(selection :initform nil)
(buffer-name :initform "*untitled-buffer*" :accessor buffer-name :initarg :buffer-name)
(variables :initform nil :accessor variables :initarg :variables)
......@@ -6074,7 +6090,7 @@ See also "Command shell" below.
(with-shell
(setf (shell-p self) nil)
(with-slots (last-focus focused-block selection) self
(when *amenubar* (close-menus *menubar*))
(when *menubar* (close-menus *menubar*))
(focus-on self last-focus)
(setf last-focus nil)
(setf selection nil))))
......@@ -6087,7 +6103,8 @@ See also "Command shell" below.
(let ((help (make-instance 'text :text *help-text*)))
(add-node self help (window-x) (window-y))
(layout help)
(center help)))
(center help)
(bring-to-front help)))
#+end_src
** Handling events
......@@ -6312,7 +6329,7 @@ Destroy the objects intersecting the region, without selecting them.
(let ((z 0))
(loop for object being the hash-values in (slot-value (current-buffer) 'objects)
do (when (find-object object t)
(setf z (max z (slot-value (find-object object) 'z)))))
(setf z (max z (%z (find-object object))))))
z)))
#+end_src
......@@ -6540,6 +6557,16 @@ This section is obsolete and will be removed in the future.
(when (colliding-with-bounding-box-p (find-object object) top left right bottom)
(draw (find-object object))))))
(defmethod draw-object-layer-z-sorted ((self buffer))
(with-slots (zbuffer) self
(setf (fill-pointer zbuffer) 0)
(multiple-value-bind (top left right bottom) (window-bounding-box self)
(loop for object being the hash-keys of (slot-value self 'objects) do
(when (colliding-with-bounding-box-p (find-object object) top left right bottom)
(vector-push-extend (find-object object) zbuffer))))
(setf zbuffer (sort zbuffer #'< :key #'%z))
(map nil #'draw zbuffer)))
(defmethod draw :before ((self buffer))
(with-buffer self
(project-window self)))
......@@ -6555,7 +6582,9 @@ This section is obsolete and will be removed in the future.
(draw-box 0 0 width height
:color background-color)))
;; now draw the object layer
(draw-object-layer self)
(if (shell-p self)
(draw-object-layer-z-sorted self)
(draw-object-layer self))
;; draw shell
(with-shell
(when (shell-p self)
......
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