Commit 097076ca authored by David O'Toole's avatar David O'Toole

tidy up gui code

parent 735ec9c2
;; Captions and labels
;; Captions and labels (commands.lisp)
;; [[file:~/xelf/gui.org::*Captions%20and%20labels][Captions and labels:1]]
;; [[file:~/xelf/gui.org::*Captions%20and%20labels%20(commands.lisp)][Captions and labels (commands.lisp):1]]
(in-package :xelf)
(defmethod set-caption-string ((self node) caption)
......@@ -35,7 +35,7 @@
(defmethod draw-caption ((self node) expression)
(draw-caption-string self (fancy-format-expression expression)))
;; Captions and labels:1 ends here
;; Captions and labels (commands.lisp):1 ends here
;; Shell operations
......@@ -205,11 +205,6 @@
(no-background :initform nil)
(style :initform :rounded)))
;; (defmethod draw-expanded :around ((self dialog) &optional label)
;; (if (typep (parent self) (find-class 'frame))
;; (mapc #'draw (inputs self))
;; (call-next-method)))
(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)))
......@@ -422,14 +417,6 @@
(align-to-pixels notice)
(bring-to-front notice)))
(defun show-help ()
(let ((help (make-instance 'text :text *help-text*)))
(add-node (current-buffer) help (window-x) (window-y))
(layout help)
(center help)
(align-to-pixels help)
(bring-to-front help)))
(defun save-before-exit ())
(defun create-project ())
......@@ -463,63 +450,54 @@
;; [[file:~/xelf/gui.org::*User%20dialogs][User dialogs:1]]
;; (define-dialog rename-buffer
;; ((new-name (slot-value (current-buffer) 'buffer-name)))
;; (rename-buffer (current-buffer) new-name))
;; (define-dialog resize-buffer
;; ((width (slot-value (current-buffer) 'width))
;; (height (slot-value (current-buffer) 'height)))
;; (resize (current-buffer) width height))
(define-dialog visit-buffer
((buffer-name (or (first *buffer-history*)
(define-dialog visit-buffer
((buffer-name (or (first *buffer-history*)
(buffer-name (current-buffer)))))
(at-next-update (switch-to-buffer buffer-name)))
(define-dialog create-buffer
((buffer-name (uniquify-buffer-name "*untitled*"))
(buffer-class (class-name (class-of (current-buffer)))))
(at-next-update
(switch-to-buffer (make-instance buffer-class :buffer-name buffer-name))))
(define-dialog paste-as-new-buffer
((buffer-name (uniquify-buffer-name "*pasted-buffer*"))
(buffer-class (class-name (class-of (current-buffer))))
(offset-x 0)
(offset-y 0))
(at-next-update
(let ((buffer (make-instance buffer-class :buffer-name buffer-name)))
(switch-to-buffer buffer-name)
(paste (current-buffer) offset-x offset-y)
(trim-conservatively (current-buffer)))))
(define-properties-dialog buffer-properties
(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) &optional buffer)
(notify (format nil "Applied buffer properties to ~S." buffer))
(let ((buffer (or buffer (current-buffer))))
(with-slots (height width buffer-name) buffer
(resize buffer width height)
(rename-buffer buffer buffer-name))))
(define-properties-dialog project-properties
(path width height scale-output-to-window frame-rate resizable author author-contact title license))
(defmethod apply-properties :after ((dialog project-properties-dialog) &optional project)
(with-slots (name path resizable scale-output-to-window frame-rate title author author-contact
width height license) project
(setf *scale-output-to-window* scale-output-to-window)
(set-frame-rate frame-rate)
(setf *title* title)
(setf *author* author)
(setf *author-contact* author)
(setf *screen-width* width)
(setf *screen-height* height)
(setf *resizable* resizable))
(notify (format nil "Applied project properties to ~S." project)))
(at-next-update (switch-to-buffer buffer-name)))
(define-dialog create-buffer
((buffer-name (uniquify-buffer-name "*untitled*"))
(buffer-class (class-name (class-of (current-buffer)))))
(at-next-update
(switch-to-buffer (make-instance buffer-class :buffer-name buffer-name))))
(define-dialog paste-as-new-buffer
((buffer-name (uniquify-buffer-name "*pasted-buffer*"))
(buffer-class (class-name (class-of (current-buffer))))
(offset-x 0)
(offset-y 0))
(at-next-update
(let ((buffer (make-instance buffer-class :buffer-name buffer-name)))
(switch-to-buffer buffer-name)
(paste (current-buffer) offset-x offset-y)
(trim-conservatively (current-buffer)))))
(define-properties-dialog buffer-properties
(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) &optional buffer)
(notify (format nil "Applied buffer properties to ~S." buffer))
(let ((buffer (or buffer (current-buffer))))
(with-slots (height width buffer-name) buffer
(resize buffer width height)
(rename-buffer buffer buffer-name))))
(define-properties-dialog project-properties
(path width height scale-output-to-window frame-rate resizable author author-contact title license))
(defmethod apply-properties :after ((dialog project-properties-dialog) &optional project)
(with-slots (name path resizable scale-output-to-window frame-rate title author author-contact
width height license) project
(setf *scale-output-to-window* scale-output-to-window)
(set-frame-rate frame-rate)
(setf *title* title)
(setf *author* author)
(setf *author-contact* author)
(setf *screen-width* width)
(setf *screen-height* height)
(setf *resizable* resizable))
(notify (format nil "Applied project properties to ~S." project)))
(defun all-buffer-names ()
(loop for name being the hash-keys of *buffers* collect name))
......
This source diff could not be displayed because it is too large. You can view the blob instead.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
* Task list
** TODO [#A] show-save-buffer-in-project-dialog
** TODO [#A] view-clipboard
** TODO [#A] fix data entry widget validation
** TODO [#A] button class
** TODO [#A] checkbox
** TODO [#A] revise/clean up/document new GUI code
** TODO [#A] command undo/redo
** TODO [#A] design layered tile map editing
** TODO [#A] snap-to-grid and offset
** TODO [#A] modeline and mousewheel controls for scrolling the buffer window
** TODO [#A] Desktop buffer-class for workspace / task / folder management
*** TODO Icon class
*** TODO auto layout simple line rules with spacing
......@@ -13,10 +13,16 @@
*** TODO Design user experience
**** TODO launching external programs to edit assets. gimp, audacity, switch-to-emacs,. etc
**** TODO folders are virtual views, they don't nest
** TODO [#A] modeline and mousewheel controls for scrolling the buffer window
** TODO [#A] command undo/redo
** TODO [#A] fix can't drag item out of shell
** TODO [#B] save-changes
** TODO [#A] toggle-snap-to-grid
** TODO save/load functionality
*** TODO [#A] test serialization
*** TODO [#A] show-save-buffer-in-project-dialog
*** TODO [#A] save-changes
*** TODO [#A] loading projects
** TODO [#B] button class
** TODO [#B] checkbox
** TODO [#B] recover sidebar
** TODO [#B] fix can't drag item out of shell
** TODO [#B] show-classes-dialog
** TODO [#B] show-paste-from-dialog
** TODO [#B] show-paste-selection-from-dialog
......@@ -28,9 +34,7 @@
** TODO [#B] show-import-resource-dialog
** TODO [#B] show-resource-properties-dialog
** TODO [#B] show-documentation
** TODO [#B] snap-to-grid and offset
** TODO [#B] hand me a tile / reference
** TODO [#B] recover sidebar
** TODO [#B] test multiline text edit
** TODO [#B] choose and export more accessor names for buffer/node slots
** TODO [#B] Document how to clear all caches
......@@ -56,7 +60,7 @@
** TODO [#B] Factory class
** TODO [#B] Network class
** TODO [#B] Viewport class (buffer window)
** TODO [#C] view-clipboard
** TODO [#C] add more notifications for cut/copy etc
*** TODO Show yellow notification string on modeline
** TODO [#C] show-exit-dialog
......@@ -83,7 +87,6 @@
** TODO [#C] show-clear-cached-resources-dialog
** TODO [#C] switch-to-desktop
** TODO [#C] auto-arrange-icons
** TODO [#C] toggle-snap-to-grid
** TODO [#C] previous-desktop
** TODO [#C] create-desktop
** TODO [#C] rename-desktop
......@@ -108,7 +111,6 @@
** TODO [#C] allow tear-off menus
** TODO [#C] object/tool palette
** TODO [#C] mimic eldoc mode on hintline
** TODO [#C] solve too-many-halos problem by showing only nearest halo
** TODO [#C] test sexp correspondence
** TODO [#C] phrase creation
** TODO [#C] phrase fillout
......@@ -1211,3 +1213,22 @@
:ARCHIVE_TODO: TODO
:END:
** DONE [#B] fix data entry widget validation
CLOSED: [2017-04-24 Mon 11:45]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-24 Mon 11:45
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#C] solve too-many-halos problem by showing only nearest halo
CLOSED: [2017-04-24 Mon 11:46]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-24 Mon 11:46
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
......@@ -18,6 +18,7 @@
(setf *scale-output-to-window* nil)
(setf *debug-on-error* nil)
(setf *shell-enabled-p* t)
(setf xelf::*font* "sans-11")
(with-session
(open-project :plong)
(index-pending-resources)
......
......@@ -5261,7 +5261,23 @@ Returns a newly allocated list."
(tasks :initform nil)
(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.")))
;; Node class:1 ends here
;; Determining whether a node is visible onscreen
;; [[file:~/xelf/xelf.org::*Determining%20whether%20a%20node%20is%20visible%20onscreen][Determining whether a node is visible onscreen:1]]
(defun on-screen-p (node)
"Return non-nil when NODE touches the buffer's window bounding box."
(contained-in-bounding-box
node
(multiple-value-list (window-bounding-box (current-buffer)))))
;; Determining whether a node is visible onscreen:1 ends here
;; Selecting nodes in the editor
;; [[file:~/xelf/xelf.org::*Selecting%20nodes%20in%20the%20editor][Selecting nodes in the editor:1]]
(defmethod select ((node node))
(setf (selected-p node) t))
......@@ -5272,13 +5288,18 @@ Returns a newly allocated list."
(if (selected-p node)
(unselect node)
(select node)))
;; Selecting nodes in the editor:1 ends here
;; Finding methods for a context menu
;; [[file:~/xelf/xelf.org::*Finding%20methods%20for%20a%20context%20menu][Finding methods for a context menu:1]]
(defgeneric find-methods (object)
(:method-combination append))
(defmethod find-methods append ((node node))
'(destroy copy raise lower bring-to-front send-to-back resize-to-image))
;; Node class:1 ends here
;; Finding methods for a context menu:1 ends here
;; Destruction
......@@ -5424,15 +5445,6 @@ Returns a newly allocated list."
(defmethod after-paste ((thing node)) nil)
(defmethod duplicate-safely ((thing node))
(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))))
(defparameter *block-categories*
'(:system :motion :event :message :looks :sound :structure :data :button
:expression :menu :hover :control :parameters :comment :sensing :operators :variables)
......@@ -5505,11 +5517,6 @@ Returns a newly allocated list."
(when (object-eq block this)
(return-from finding this)))))
;; (find (find-object block)
;; (slot-value self 'inputs)
;; :test 'eq
;; :key #'find-object))
(defmethod input-position ((self node) input)
(assert (not (null input)))
(position (uuid input) (slot-value self 'inputs) :key #'uuid :test 'equal))
......
......@@ -5252,7 +5252,23 @@ subclasses.)
(tasks :initform nil)
(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.")))
#+end_src
** Determining whether a node is visible onscreen
#+begin_src lisp
(defun on-screen-p (node)
"Return non-nil when NODE touches the buffer's window bounding box."
(contained-in-bounding-box
node
(multiple-value-list (window-bounding-box (current-buffer)))))
#+end_src
** Selecting nodes in the editor
#+begin_src lisp
(defmethod select ((node node))
(setf (selected-p node) t))
......@@ -5263,7 +5279,11 @@ subclasses.)
(if (selected-p node)
(unselect node)
(select node)))
#+end_src
** Finding methods for a context menu
#+begin_src lisp
(defgeneric find-methods (object)
(:method-combination append))
......@@ -5408,15 +5428,6 @@ in the future.
(defmethod after-paste ((thing node)) nil)
(defmethod duplicate-safely ((thing node))
(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))))
(defparameter *block-categories*
'(:system :motion :event :message :looks :sound :structure :data :button
:expression :menu :hover :control :parameters :comment :sensing :operators :variables)
......@@ -5488,11 +5499,6 @@ in the future.
(when (object-eq block this)
(return-from finding this)))))
;; (find (find-object block)
;; (slot-value self 'inputs)
;; :test 'eq
;; :key #'find-object))
(defmethod input-position ((self node) input)
(assert (not (null input)))
(position (uuid input) (slot-value self 'inputs) :key #'uuid :test 'equal))
......
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