Commit 54bc047a authored by David O'Toole's avatar David O'Toole

property sheets work

parent 96cf6113
......@@ -193,14 +193,14 @@
(mapc #'freeze (inputs dialog))
nil))
;; (defun edit-cut ()
;; (cut (current-buffer)))
(defun do-cut ()
(cut))
;; (defun edit-copy ()
;; (copy (current-buffer)))
(defun do-copy ()
(copy))
;; (defun edit-paste ()
;; (paste (current-buffer)))
(defun do-paste ()
(paste))
(defun transport-play ()
(play (current-buffer)))
......@@ -287,13 +287,13 @@
(trim (current-buffer)))
(define-properties-dialog buffer-properties
(buffer-name height width z-sort-p background-image background-color
(buffer-name width height 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
(with-slots (height width buffer-name) buffer
(resize buffer height width)
(rename buffer name)))
(rename-buffer buffer buffer-name)))
;; User dialogs:1 ends here
;; Menu bar structure
......@@ -318,9 +318,9 @@
(defparameter *edit-menu*
'(:label "Edit"
:inputs
((:label "Cut" :action edit-cut)
(:label "Copy" :action edit-copy)
(:label "Paste" :action edit-paste)
((:label "Cut" :action do-cut)
(:label "Copy" :action do-copy)
(:label "Paste" :action do-paste)
(:label "Paste as new buffer" :action show-paste-as-new-buffer-dialog)
(:label "Paste from" :action show-paste-from-dialog)
(:label "Paste selection from" :action show-paste-selection-from-dialog)
......@@ -342,9 +342,9 @@
((:label "Create a new buffer" :action show-create-buffer-dialog)
(:label "Load a buffer from a file" :action show-load-buffer-from-file-dialog)
(:label "Switch to buffer" :action show-switch-to-buffer-dialog)
(:label "Edit buffer properties" :action show-buffer-properties-dialog)
(:label "Rename buffer" :action show-rename-buffer-dialog)
(:label "Resize buffer" :action show-resize-buffer-dialog)
(:label "Edit buffer properties" :action do-show-buffer-properties-dialog)
;; (:label "Rename buffer" :action show-rename-buffer-dialog)
;; (:label "Resize buffer" :action show-resize-buffer-dialog)
(:label "Save buffer in project" :action show-save-buffer-in-project-dialog)
(:label "Copy buffer" :action show-copy-buffer-dialog)
(:label "Destroy buffer" :action show-destroy-buffer-dialog)
......@@ -355,6 +355,9 @@
(:label "View clipboard" :action view-clipboard)
(:label "View buffer list" :action view-buffer-list))))
(defun do-show-buffer-properties-dialog ()
(show-buffer-properties-dialog (current-buffer)))
(defparameter *view-menu*
'(:label "View"
:inputs
......@@ -629,8 +632,11 @@
(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 destroy :before ((frame frame))
(mapc #'destroy (inputs frame)))
(defmethod evaluate ((frame frame))
(evaluate (second (inputs frame))))
;; (defmethod as-drag ((self menu) x y)
;; (make-menu-frame self))
......
......@@ -1071,15 +1071,21 @@
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Tabbing%20between%20focused%20nodes][Tabbing between focused nodes:1]]
(defmethod find-tab-parent ((self node))
(parent self))
(defmethod find-tab-proxy ((self node))
self)
(defmethod tab ((self buffer) &optional backward)
(with-slots (focused-block) self
(when focused-block
(assert (xelfp focused-block))
(with-slots (parent) focused-block
(let ((index (position-within-parent focused-block)))
(with-slots (parent) (find-object focused-block)
(let ((index (position-within-parent (find-tab-proxy (find-object focused-block)))))
(when (numberp index)
(focus-on self
(with-slots (inputs) parent
(with-slots (inputs) (find-tab-parent (find-object focused-block))
(nth (mod (+ index
(if backward -1 1))
(length inputs))
......@@ -1600,7 +1606,7 @@ See sidebar for more commands to try.
(defmethod pick-focus ((self node)) self)
;; Mouse events:1 ends here
;; Halos
;; TODO Halos
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Halos][Halos:1]]
......@@ -1632,7 +1638,8 @@ See sidebar for more commands to try.
(foreground-color :initform nil)))
(defmethod initialize-instance :after ((self handle) &key target)
(setf (slot-value self 'target) target))
(setf (slot-value self 'target) target)
(bring-to-front self))
(defmethod can-pick ((self handle)) t)
(defmethod pick ((self handle)) self)
......@@ -1687,7 +1694,7 @@ See sidebar for more commands to try.
(define-handle evaluate :define)
(defmethod tap ((self evaluate) x y)
(evaluate-here (slot-value self 'target)))
(evaluate (slot-value self 'target)))
;;; Getting a context menu
......@@ -1948,7 +1955,7 @@ See sidebar for more commands to try.
(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")
......@@ -2187,6 +2194,17 @@ See sidebar for more commands to try.
(:inactive
*inactive-prompt-color*))))))
;; (defmethod draw-input-area :after ((self prompt) state)
;; (when (eq state :inactive)
;; (with-slots (x y width height) self
;; (draw-patch self x y (+ x width) (+ y height) :depressed t :style :flat))))
;; (when (eq :inactive state)
;; (draw-box (1+ (dash 0.5 x label-width))
;; (1+ (dash 0.2 y))
;; (1- (dash 2 line-width))
;; (1- (dash 0.8 (font-height (slot-value self 'font))))
;; :color "cyan")))))
(defmethod draw-indicators ((self prompt) state)
(with-slots (x y options text-color width parent height line) self
(let ((label-width (label-width self))
......@@ -2576,7 +2594,7 @@ See sidebar for more commands to try.
(+ x0 diameter) (- y1 radius)
fill)
(line (+ x0 1) (+ y0 radius)
(+ x0 1) (- y1 radius -3) bevel)
(+ x0 1) (- y1 radius -2) bevel)
;; x1
(box (- x1 diameter) (+ y0 radius)
x1 (- y1 radius)
......@@ -3095,8 +3113,8 @@ See sidebar for more commands to try.
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Phrase%20/%20S-expression%20correspondence][Phrase / S-expression correspondence:1]]
(defun make-sentence (contents)
(let ((phrase (apply #'new 'phrase :inputs (list contents))))
(defun make-sentence (contents &optional (class 'phrase))
(let ((phrase (apply #'new class :inputs (list contents))))
(prog1 phrase
(update-parent-links phrase)
(with-slots (orientation no-background dash spacing) phrase
......@@ -3222,16 +3240,14 @@ See sidebar for more commands to try.
(slot-value self 'value) value)
;; fill in the input box with the value, unless LINE was provided
(if line
(progn
(setf (slot-value self 'line) (coerce line 'simple-string))
(setf (slot-value self 'value) (read-from-string line)))
(setf (slot-value self 'line)
(if (null value)
""
(format nil "~S" value))))
(progn
(setf (slot-value self 'line) (coerce line 'simple-string))
(setf (slot-value self 'value) (read-from-string line)))
(setf (slot-value self 'line)
(format nil "~S" value)))
(setf (slot-value self 'label)
(or label
(getf options :label)))
(or label
(getf options :label)))
(when font (setf (slot-value self 'font) font))
(when label-color (setf (slot-value self 'label-color) label-color)))
......@@ -3402,6 +3418,9 @@ See sidebar for more commands to try.
(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)
......@@ -3453,6 +3472,9 @@ See sidebar for more commands to try.
(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)
;; Data entry and validation:1 ends here
;; Multiline text edit control
......@@ -4224,7 +4246,14 @@ See sidebar for more commands to try.
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Dialog%20box%20builder][Dialog box builder:1]]
(defclass dialog (phrase) ())
(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)))
......@@ -4263,6 +4292,26 @@ See sidebar for more commands to try.
(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 find-tab-parent ((entry expression-entry))
(parent (parent entry)))
(defmethod find-tab-proxy ((entry expression-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) sheet
(dolist (property properties)
......@@ -4272,9 +4321,11 @@ See sidebar for more commands to try.
:value property
:locked t
:read-only t)
(make-instance 'expression-entry
(make-instance 'property-value-entry
:value (slot-value instance property)
:read-only nil)))))
:read-only nil))
'property-row)))
;; (setf (no-background row) nil)
(push row inputs)))
(setf inputs (nreverse inputs))
(update-parent-links sheet)
......@@ -4282,11 +4333,14 @@ See sidebar for more commands to try.
;; (defmethod layout :after ((sheet property-sheet))
(defmethod get-property-object-pairs ((sheet property-sheet))
(mapcar #'inputs (inputs sheet)))
(defmethod get-property-entries ((sheet property-sheet))
(mapcan #'identity (get-property-object-pairs sheet)))
(defmethod get-property-list ((sheet property-sheet))
(mapcar #'evaluate
(mapcan #'identity
(mapcar #'inputs
(inputs (first (inputs sheet)))))))
(mapcar #'evaluate (get-property-entries sheet)))
(defmethod apply-properties ((sheet property-sheet) instance)
(let ((plist (get-property-list sheet)))
......
This diff is collapsed.
......@@ -176,12 +176,13 @@
(defmethod enter :after ((self shell-prompt) &optional no-clear)
(with-slots (result error-output) self
(if error-output
(progn
(replace-output (shell) (list (make-phrase (clean-string error-output))))
(notify "There was an error. Check the output area for more info."))
(when result
(replace-output (shell) (list (make-phrase result)))))))
(progn
(replace-output (shell) (list (make-phrase (clean-string error-output))))
(notify "There was an error. Check the output area for more info."))
(when result
(replace-output (shell) (list (make-phrase result))))))
(clear-line self))
(defmethod lose-focus ((self shell-prompt))
(cancel-editing self))
......
* Task list
** DONE redesign system menu
CLOSED: [2017-04-18 Tue 19:34]
** 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
*** DONE [#A] fix eval not happening
CLOSED: [2017-04-19 Wed 18:19]
*** TODO [#A] show error bubble and restore value when input incorrect
*** TODO [#A] fix BACKTAB not working
*** TODO [#A] fix halos not being in front
*** TODO [#B] don't allow halo on properties dialog
*** TODO [#B] fix click in text doesn't go to correct column
*** TODO [#B] ENTER should update value in property field
*** TODO [#C] fix menubar not drawing over dialogs
*** TODO [#C] fix clicking away from menubar doesn't close menus or allow focusing
*** TODO [#C] add nice Apply/Cancel buttons
** TODO make master system menu todo list
*** TODO save-changes
*** TODO show-edit-project-properties-dialog
......@@ -581,3 +569,113 @@
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE remove old titlebar
CLOSED: [2017-04-19 Wed 09:58]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-19 Wed 16:47
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/fix dialog boxes
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE improve layout of properties dialog by proper column alignment
CLOSED: [2017-04-19 Wed 16:47]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-19 Wed 16:47
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/fix dialog boxes
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE define-properties-dialog
CLOSED: [2017-04-19 Wed 14:21]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-19 Wed 16:47
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/fix dialog boxes
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE custom label entry displays pretty-string but evals to ugly-symbol
CLOSED: [2017-04-19 Wed 16:42]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-19 Wed 16:47
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/fix dialog boxes
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE fix editable titlebar
CLOSED: [2017-04-19 Wed 16:42]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-19 Wed 16:47
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/fix dialog boxes
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE fix clickable non-read-only toggle
CLOSED: [2017-04-19 Wed 14:37]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-19 Wed 16:47
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/fix dialog boxes
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE remove package prefix from property sheet names
CLOSED: [2017-04-19 Wed 14:37]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-19 Wed 16:47
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/fix dialog boxes
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE destroy dialog when destroying frame
CLOSED: [2017-04-19 Wed 15:09]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-19 Wed 16:47
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/fix dialog boxes
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE redesign system menu
CLOSED: [2017-04-18 Tue 19:34]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-19 Wed 16:47
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#A] Fix command prompt not clearing
CLOSED: [2017-04-19 Wed 16:52]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-19 Wed 16:52
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/fix dialog boxes
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#B] fix TAB error
CLOSED: [2017-04-19 Wed 17:39]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-19 Wed 17:40
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/fix dialog boxes
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
......@@ -29,6 +29,19 @@
(xelf::show-buffer-properties-dialog (current-buffer))
(bind-event (current-buffer) '(:f9) 'xelf::toggle-other-windows)
(start-game plong)))))
(trace xelf::evaluate)
(trace xelf::get-property-list)
(trace xelf::apply-properties)
(trace xelf::show-dialog)
(trace xelf::tab)
(trace xelf::find-tab-parent)
(trace xelf::find-tab-proxy)
(trace xelf::position-within-parent)
(trace xelf::show-dialog)
(trace xelf::tap)
(trace xelf::get-property-object-pairs)
(trace xelf::get-property-entries)
(test-gui)
......@@ -404,10 +404,9 @@ more information.
(symbol (symbol-name thing))
(string thing))))
(coerce
(substitute #\Space #\-
(string-downcase
(string-trim " " name)))
'simple-string)))
(string-downcase
(string-trim " " name))
'simple-string)))
(defun-memo ugly-symbol (string)
(:key #'first :test 'equal :validator #'identity)
......@@ -5504,7 +5503,7 @@ Returns a newly allocated list."
(find-object node))))
(defmethod position-within-parent ((self node))
(input-position (find-object (slot-value self 'parent)) self))
(input-position (find-tab-parent self) self))
(defmethod set-parent ((self node) parent)
"Store a link to the enclosing block PARENT."
......
......@@ -483,10 +483,9 @@ shortening long strings, and filtering out non-printable characters.
(symbol (symbol-name thing))
(string thing))))
(coerce
(substitute #\Space #\-
(string-downcase
(string-trim " " name)))
'simple-string)))
(string-downcase
(string-trim " " name))
'simple-string)))
(defun-memo ugly-symbol (string)
(:key #'first :test 'equal :validator #'identity)
......@@ -5487,7 +5486,7 @@ in the future.
(find-object node))))
(defmethod position-within-parent ((self node))
(input-position (find-object (slot-value self 'parent)) self))
(input-position (find-tab-parent self) self))
(defmethod set-parent ((self node) parent)
"Store a link to the enclosing block PARENT."
......
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