Commit 96cf6113 authored by David O'Toole's avatar David O'Toole

improve look of dialog box

parent e3f5d0f9
......@@ -193,14 +193,14 @@
(mapc #'freeze (inputs dialog))
nil))
(defun edit-cut ()
(cut (current-buffer)))
;; (defun edit-cut ()
;; (cut (current-buffer)))
(defun edit-copy ()
(copy (current-buffer)))
;; (defun edit-copy ()
;; (copy (current-buffer)))
(defun edit-paste ()
(paste (current-buffer)))
;; (defun edit-paste ()
;; (paste (current-buffer)))
(defun transport-play ()
(play (current-buffer)))
......@@ -287,11 +287,13 @@
(trim (current-buffer)))
(define-properties-dialog buffer-properties
(name height width z-sort-p background-image background-color
window-scrolling-speed horizontal-scrolling-margin vertical-scrolling-margin)
(with-slots (height width name) self
(resize self height width)
(rename self name)))
(buffer-name height width z-sort-p background-image background-color
window-scrolling-speed horizontal-scrolling-margin vertical-scrolling-margin))
(defmethod apply-properties :after ((dialog buffer-properties-dialog) buffer)
(with-slots (height width name) buffer
(resize buffer height width)
(rename buffer name)))
;; User dialogs:1 ends here
;; Menu bar structure
......@@ -587,7 +589,7 @@
(dash :initform 1)
(category :initform :system))
:inputs (:close-button (make-instance 'frame-close-button)
:title (make-instance 'label :font "sans-bold-11" :read-only t))))
:title (make-instance 'label :font "sans-bold-11" :read-only t :locked t))))
(defmethod set-title ((self titlebar) title)
(set-value (input-node self :title) title))
......@@ -627,6 +629,9 @@
(multiple-value-bind (top left right bottom) (bounding-box self)
(draw-patch self left top right bottom :color "gray30" :style :rounded)))
(defmethod destroy :before ((self frame))
(mapc #'destroy (inputs self)))
;; (defmethod as-drag ((self menu) x y)
;; (make-menu-frame self))
;; Floating window frames:1 ends here
......
......@@ -1580,7 +1580,7 @@ See sidebar for more commands to try.
(loop while this do
(setf next (slot-value this 'parent))
(when (or (null next)
(is-a 'buffer next))
(typep next (find-class 'buffer)))
(return-from searching this))
(setf this next)))))
......@@ -3396,6 +3396,20 @@ See sidebar for more commands to try.
(defentry float-entry floatp 0.0)
(defentry symbol-entry symbolp nil
(category :initform :data))
(defentry pretty-symbol-entry symbolp nil)
(defmethod evaluate ((self pretty-symbol-entry))
(get-value self))
(defmethod tap ((self pretty-symbol-entry) x y) nil)
(defmethod alternate-tap ((self pretty-symbol-entry) x y) nil)
(defmethod initialize-instance :after ((self pretty-symbol-entry) &key)
(with-slots (value line locked pinned read-only) self
(setf locked t pinned t read-only t)
(setf line (pretty-string value))))
(defentry positive-integer-entry (integer 1 *) 1)
(defentry non-negative-integer-entry (integer 0 *) 0)
(defentry string-entry stringp "")
......@@ -4210,6 +4224,11 @@ See sidebar for more commands to try.
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Dialog%20box%20builder][Dialog box builder:1]]
(defclass dialog (phrase) ())
(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)
......@@ -4219,7 +4238,7 @@ See sidebar for more commands to try.
,(command-name-string name)))
(export ',(show-name name))
(define-visual-macro ,(dialog-class-name name)
(:super phrase
(:super dialog
:slots ((orientation :initform :vertical))
:inputs ,(command-inputs name arglist)))
(export ',(dialog-class-name name))
......@@ -4239,7 +4258,7 @@ See sidebar for more commands to try.
(labels ((arg (name) (getf ^args^ name)))
,@body)))
(defclass property-sheet (phrase)
(defclass property-sheet (dialog)
((orientation :initform :vertical)
(instance :initform nil :initarg :instance :accessor instance)
(properties :initform nil :initarg :properties :accessor properties)))
......@@ -4249,8 +4268,9 @@ See sidebar for more commands to try.
(dolist (property properties)
(let ((row (make-sentence
(list
(make-instance 'symbol-entry
(make-instance 'pretty-symbol-entry
:value property
:locked t
:read-only t)
(make-instance 'expression-entry
:value (slot-value instance property)
......@@ -4259,7 +4279,9 @@ See sidebar for more commands to try.
(setf inputs (nreverse inputs))
(update-parent-links sheet)
(freeze sheet)))
;; (defmethod layout :after ((sheet property-sheet))
(defmethod get-property-list ((sheet property-sheet))
(mapcar #'evaluate
(mapcan #'identity
......@@ -4281,7 +4303,7 @@ See sidebar for more commands to try.
(defmacro define-properties-dialog (name slot-names &rest body)
`(progn
(defun ,(show-name name) (&optional (instance *instance*))
(show-dialog (apply #'make-instance ',(dialog-class-name name) :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)))))
......
......@@ -1597,7 +1597,7 @@ above.
(loop while this do
(setf next (slot-value this 'parent))
(when (or (null next)
(is-a 'buffer next))
(typep next (find-class 'buffer)))
(return-from searching this))
(setf this next)))))
......@@ -1961,7 +1961,7 @@ above.
(defvar *prompt* nil)
(defparameter *active-prompt-color* "red")
(defparameter *inactive-prompt-color* "gray10")
(defparameter *inactive-prompt-color* "gray40")
(defparameter *prompt-cursor-inactive-color* "gray50")
(defparameter *default-prompt-text-color* "white")
(defparameter *default-prompt-outside-text-color* "yellow")
......@@ -3406,6 +3406,23 @@ supported compiler.
(defentry float-entry floatp 0.0)
(defentry symbol-entry symbolp nil
(category :initform :data))
(defentry pretty-symbol-entry symbolp nil)
(defmethod evaluate ((self pretty-symbol-entry))
(get-value self))
(defmethod layout :after ((self pretty-symbol-entry))
(resize self 210 (slot-value self 'height)))
(defmethod tap ((self pretty-symbol-entry) x y) nil)
(defmethod alternate-tap ((self pretty-symbol-entry) x y) nil)
(defmethod initialize-instance :after ((self pretty-symbol-entry) &key)
(with-slots (value line locked pinned read-only) self
(setf locked t pinned t read-only t)
(setf line (pretty-string value))))
(defentry positive-integer-entry (integer 1 *) 1)
(defentry non-negative-integer-entry (integer 0 *) 0)
(defentry string-entry stringp "")
......@@ -3449,6 +3466,10 @@ supported compiler.
(when (stringp value)
(setf (slot-value self 'value) value)
(setf (slot-value self 'line) value)))
(defmethod tap ((self label) x y) nil)
(defmethod alternate-tap ((self label) x y) nil)
#+end_src
* Multiline text edit control
......@@ -4624,6 +4645,11 @@ supported compiler.
** Dialog box builder
#+begin_src lisp commands.lisp
(defclass dialog (phrase) ())
(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)
......@@ -4633,7 +4659,7 @@ supported compiler.
,(command-name-string name)))
(export ',(show-name name))
(define-visual-macro ,(dialog-class-name name)
(:super phrase
(:super dialog
:slots ((orientation :initform :vertical))
:inputs ,(command-inputs name arglist)))
(export ',(dialog-class-name name))
......@@ -4653,7 +4679,7 @@ supported compiler.
(labels ((arg (name) (getf ^args^ name)))
,@body)))
(defclass property-sheet (phrase)
(defclass property-sheet (dialog)
((orientation :initform :vertical)
(instance :initform nil :initarg :instance :accessor instance)
(properties :initform nil :initarg :properties :accessor properties)))
......@@ -4663,8 +4689,9 @@ supported compiler.
(dolist (property properties)
(let ((row (make-sentence
(list
(make-instance 'symbol-entry
(make-instance 'pretty-symbol-entry
:value property
:locked t
:read-only t)
(make-instance 'expression-entry
:value (slot-value instance property)
......@@ -4673,7 +4700,9 @@ supported compiler.
(setf inputs (nreverse inputs))
(update-parent-links sheet)
(freeze sheet)))
;; (defmethod layout :after ((sheet property-sheet))
(defmethod get-property-list ((sheet property-sheet))
(mapcar #'evaluate
(mapcan #'identity
......@@ -4695,7 +4724,7 @@ supported compiler.
(defmacro define-properties-dialog (name slot-names &rest body)
`(progn
(defun ,(show-name name) (&optional (instance *instance*))
(show-dialog (apply #'make-instance ',(dialog-class-name name) :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)))))
......@@ -4718,14 +4747,14 @@ supported compiler.
(mapc #'freeze (inputs dialog))
nil))
(defun edit-cut ()
(cut (current-buffer)))
;; (defun edit-cut ()
;; (cut (current-buffer)))
(defun edit-copy ()
(copy (current-buffer)))
;; (defun edit-copy ()
;; (copy (current-buffer)))
(defun edit-paste ()
(paste (current-buffer)))
;; (defun edit-paste ()
;; (paste (current-buffer)))
(defun transport-play ()
(play (current-buffer)))
......@@ -4811,11 +4840,13 @@ supported compiler.
(trim (current-buffer)))
(define-properties-dialog buffer-properties
(name height width z-sort-p background-image background-color
window-scrolling-speed horizontal-scrolling-margin vertical-scrolling-margin)
(with-slots (height width name) self
(resize self height width)
(rename self name)))
(buffer-name height width z-sort-p background-image background-color
window-scrolling-speed horizontal-scrolling-margin vertical-scrolling-margin))
(defmethod apply-properties :after ((dialog buffer-properties-dialog) buffer)
(with-slots (height width name) buffer
(resize buffer height width)
(rename buffer name)))
#+end_src
** Menu bar structure
......@@ -5110,7 +5141,7 @@ supported compiler.
(dash :initform 1)
(category :initform :system))
:inputs (:close-button (make-instance 'frame-close-button)
:title (make-instance 'label :font "sans-bold-11" :read-only t))))
:title (make-instance 'label :font "sans-bold-11" :read-only t :locked t))))
(defmethod set-title ((self titlebar) title)
(set-value (input-node self :title) title))
......@@ -5150,6 +5181,9 @@ supported compiler.
(multiple-value-bind (top left right bottom) (bounding-box self)
(draw-patch self left top right bottom :color "gray30" :style :rounded)))
(defmethod destroy :before ((self frame))
(mapc #'destroy (inputs self)))
;; (defmethod as-drag ((self menu) x y)
;; (make-menu-frame self))
#+end_src
......
......@@ -2,9 +2,25 @@
** DONE redesign system menu
CLOSED: [2017-04-18 Tue 19:34]
** TODO fix ugly dialog boxes
*** TODO define-properties-dialog
*** TODO improve layout of properties dialog
** TODO fix dialog boxes
*** TODO fix eval not happening
*** TODO don't allow halo on properties dialog
*** DONE destroy dialog when destroying frame
CLOSED: [2017-04-19 Wed 15:09]
*** DONE remove package prefix from property sheet names
CLOSED: [2017-04-19 Wed 14:37]
*** DONE fix clickable non-read-only toggle
CLOSED: [2017-04-19 Wed 14:37]
*** TODO fix editable titlebar
*** TODO fix click in text doesn't go to correct column
*** TODO ENTER should update value in property field
*** TODO show error bubble and restore value when input incorrect
*** TODO custom label entry displays pretty-string but evals to ugly-symbol
*** TODO
*** DONE define-properties-dialog
CLOSED: [2017-04-19 Wed 14:21]
*** TODO improve layout of properties dialog by proper column alignment
*** DONE remove old titlebar
CLOSED: [2017-04-19 Wed 09:58]
*** TODO [#B] add nice Apply/Cancel buttons
......
......@@ -26,6 +26,7 @@
(switch-to-buffer plong)
(at-next-update
;; (add-node (current-buffer) (make-instance 'xelf::resize-buffer-dialog) 200 200)
(xelf::show-buffer-properties-dialog (current-buffer))
(bind-event (current-buffer) '(:f9) 'xelf::toggle-other-windows)
(start-game plong)))))
......
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