Commit 34c410e4 authored by David O'Toole's avatar David O'Toole

validate property types before applying

parent 56cb6971
......@@ -216,7 +216,8 @@
(defmethod tap ((dialog dialog) x y)
(bring-to-front (or (parent dialog) dialog))
(tap (or (parent dialog) dialog) x y))
(when (parent dialog)
(tap (parent dialog) x y)))
(defmethod freeze :after ((dialog dialog))
(mapc #'freeze (inputs dialog)))
......@@ -254,11 +255,13 @@
(defclass property-sheet (dialog)
((orientation :initform :vertical)
(default-values :initform nil)
(methods :initform '(apply-properties restore-default-values cancel-properties))
(initial-values :initform nil)
(instance :initform nil :initarg :instance :accessor instance)
(properties :initform nil :initarg :properties :accessor properties)))
(defmethod find-methods append ((dialog dialog))
'(evaluate restore-initial-values cancel))
(defclass property-row (phrase)
((no-background :initform nil)
(style :initform :rounded)))
......@@ -286,7 +289,7 @@
(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 default-values) sheet
(with-slots (inputs properties instance initial-values) sheet
(dolist (property properties)
(let ((row (make-sentence
(list
......@@ -300,24 +303,21 @@
'property-row)))
;; (setf (no-background row) nil)
(push row inputs)
(push (slot-value instance property) default-values)))
(setf default-values (nreverse default-values))
(push (slot-value instance property) initial-values)))
(setf initial-values (nreverse initial-values))
(setf inputs (nreverse inputs))
(update-parent-links sheet)
(freeze sheet)))
(defmethod restore-default-values ((sheet property-sheet))
(with-slots (inputs properties instance default-values) sheet
(defmethod restore-initial-values ((sheet property-sheet))
(with-slots (inputs properties instance initial-values) sheet
(let ((i inputs)
(d default-values))
(d initial-values))
(flet ((entry () (second (inputs (first i)))))
(dolist (property properties)
(set-value (entry) (pop d))
(pop i))))))
;; (defmethod layout :after ((sheet property-sheet))
;; (assert (every #'(lambda (d) (= 2 (length (inputs d)))) (inputs sheet))))
(defmethod get-property-object-pairs ((sheet property-sheet))
(mapcar #'inputs (inputs sheet)))
......@@ -335,13 +335,26 @@
(value (pop plist)))
(setf (slot-value i slot) value)))))
(defmethod cancel-properties ((sheet property-sheet))
(defmethod check-properties ((sheet property-sheet) &optional instance)
(let ((plist (get-property-list sheet))
(i (or instance (instance sheet))))
(block checking
(loop while plist do
(let* ((slot (pop plist))
(value (pop plist)))
(when (not (check-value-for-slot value i slot))
(notify (format nil "Error: Value ~S is of wrong type for slot ~S." value slot))
(return-from checking nil))))
(return-from checking t))))
(defmethod cancel ((sheet property-sheet))
(if (parent sheet)
(destroy (parent sheet))
(destroy sheet)))
(defmethod evaluate ((sheet property-sheet))
(prog1 nil (apply-properties sheet (instance sheet))))
(when (check-properties sheet)
(apply-properties sheet (instance sheet))))
(defvar *instance* nil)
......@@ -910,9 +923,20 @@
(when (destroy-after-evaluate-p frame)
(destroy frame)))
(defmethod make-halo :after ((frame frame))
(bring-to-front (slot-value frame 'halo))
(bring-to-front frame))
(defmethod context-menu ((frame frame))
(context-menu (second (inputs frame))))
(defmethod show-context-menu ((node node))
(let ((menu (context-menu node)))
(when menu
(add-node (current-buffer) menu)
(move-to menu (window-pointer-x) (window-pointer-y))
(bring-to-front menu))))
;; (defmethod as-drag ((self menu) x y)
;; (make-menu-frame self))
;; Floating window frames:1 ends here
......@@ -932,23 +956,47 @@
:action (make-instance 'task :method-name method :target (find-object target)))))
(defclass context-menu (menu)
((no-background :initform nil)))
((no-background :initform nil)
(category :initform :text)))
(defclass context-menu-item (menu)
((category :initform :text)))
(defmethod tap :around ((menu context-menu-item) x y)
(call-next-method)
(destroy (parent menu)))
(defmethod context-menu ((self node))
(let ((methods (slot-value self 'methods)))
(let (inputs)
(dolist (method (sort methods #'string<))
(push (make-method-menu-item self method (uuid self)) inputs))
(flet ((menu-item (args)
(make-menu args :target self)))
(make-instance 'context-menu
:inputs (mapcar #'menu-item (nreverse inputs))
:pinned nil
:expanded t
:locked t)))))
(let ((methods (find-methods self)))
(when methods
(let (inputs)
(dolist (method methods)
(push (make-method-menu-item self method self) inputs))
(flet ((menu-item (args)
(make-menu args :target self :class 'context-menu-item)))
(make-instance 'context-menu
:inputs (mapcar #'menu-item (nreverse inputs))
:pinned nil
:expanded t
:locked t))))))
(defmethod initialize-instance :after ((menu context-menu) &key)
(layout menu)
(freeze menu))
(defmethod draw :before ((menu context-menu))
(layout menu)
(with-slots (x y width height) menu
(draw-patch menu x y width height :style :flat :color "gray30")))
(draw-patch menu x y (+ width x) (+ y height) :style :rounded )))
(defmethod draw-highlight ((self context-menu))
(with-slots (y height expanded action parent) self
(when parent
(with-slots (x width) parent
(when (not expanded)
(draw-box (+ x (dash 3))
(+ y (dash 1))
(- width (dash 4))
(+ height 1)
:color *highlight-background-color*)
(draw-label-string self (display-string self) *highlight-foreground-color*))))))
;; Context menus:1 ends here
......@@ -9,30 +9,37 @@
;; [[file:~/xelf/gui.org::*Class%20declaration][Class declaration:1]]
(defclass buffer (node qbuffer)
((name :initform nil)
(defun optional-string-p (s)
(or (null s) (stringp s)))
(deftype optional-string () '(satisfies optional-string-p))
(defclass buffer (node qbuffer)
((name :initform nil :type optional-string :accessor name :initarg :name)
(zbuffer :initform (make-array 100 :adjustable t :initial-element nil :fill-pointer t)
:accessor zbuffer
:documentation "Temporary array of z-sorted nodes for rendering."
:initarg :zbuffer)
(z-sort-p :initform t :initarg :z-sort-p :accessor z-sort-p
:documentation "When non-nil, draw objects in correct Z-order.")
:documentation "When non-nil, draw objects in correct Z-order."
:type symbol)
(selection :initform nil)
(buffer-name :initform "*untitled*"
:accessor buffer-name
:initarg :buffer-name)
:initarg :buffer-name
:type string)
(variables :initform nil :accessor variables :initarg :variables)
(point :initform nil)
(modified-p :initform nil)
(redraw-cursor :initform t)
(followed-object :initform nil)
(background-image :initform nil :accessor background-image :initarg nil)
(background-color :initform nil :accessor background-color :initarg nil)
(background-image :initform nil :accessor background-image :initarg nil :type optional-string)
(background-color :initform nil :accessor background-color :initarg nil :type optional-string)
(x :initform 0)
(y :initform 0)
(paused :initform nil :accessor paused-p :initarg :paused-p)
(height :initform 256)
(width :initform 256)
(height :initform 256 :type number)
(width :initform 256 :type number)
(depth :initform *z-far*)
(layered :initform nil)
(field-of-view :initform *field-of-view*)
......@@ -44,9 +51,15 @@
(window-x0 :initform nil) ;; :accessor window-x0 :initarg :window-x0)
(window-y0 :initform nil) ;; :accessor window-y0 :initarg :window-y0)
(window-z0 :initform nil) ;; :accessor window-z0 :initarg :window-z0)
(horizontal-scrolling-margin :initform 1/4 :accessor horizontal-scrolling-margin :initarg :horizontal-scrolling-margin)
(vertical-scrolling-margin :initform 1/4 :accessor vertical-scrolling-margin :initarg :vertical-scrolling-margin)
(window-scrolling-speed :initform 5 :accessor window-scrolling-speed :initarg :window-scrolling-speed)
(horizontal-scrolling-margin :initform 1/4 :type number
:accessor horizontal-scrolling-margin
:initarg :horizontal-scrolling-margin)
(vertical-scrolling-margin :initform 1/4 :type number
:accessor vertical-scrolling-margin
:initarg :vertical-scrolling-margin)
(window-scrolling-speed :initform 5 :type number
:accessor window-scrolling-speed
:initarg :window-scrolling-speed)
(window-scale-x :initform 1 :accessor window-scale-x :initarg :window-scale-x)
(window-scale-y :initform 1 :accessor window-scale-y :initarg :window-scale-y)
(window-scale-z :initform 1 :accessor window-scale-z :initarg :window-scale-z)
......@@ -1563,7 +1576,8 @@ 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))
(defmethod alternate-tap ((self node) x y)
(show-context-menu self))
(defmethod tap ((self node) x y) nil)
......@@ -1729,10 +1743,7 @@ See sidebar for more commands to try.
(define-handle open-menu :menu)
(defmethod tap ((self open-menu) x y)
(let ((menu (context-menu (slot-value self 'target))))
(add-node (current-buffer) menu)
(move-to menu x y)
(bring-to-front menu)))
(show-context-menu (slot-value self 'target)))
;;; Dropping things down into the object layer
......@@ -2010,7 +2021,6 @@ See sidebar for more commands to try.
(line :initform "" :documentation "Currently edited command line.")
(last-line :initform nil)
(background :initform t)
(methods :initform '(:toggle-read-only))
(error-output :initform "")
(minimum-width :initform 100)
(text-color :initform *default-prompt-text-color*)
......@@ -2023,6 +2033,9 @@ See sidebar for more commands to try.
(history :initform nil :documentation "A queue of strings containing the command history.")
(history-position :initform 0)))
(defmethod find-methods append ((prompt prompt))
'(toggle-read-only))
(defmethod accept ((self prompt) arg)
nil)
......@@ -2970,6 +2983,32 @@ See sidebar for more commands to try.
(apply #'reinitialize-instance new-node initargs)))))
;; Duplicating a node:1 ends here
;; Checking values against slot type declarations :ccl:sbcl:ecl:
;; [[file:~/xelf/gui.org::*Checking%20values%20against%20slot%20type%20declarations][Checking values against slot type declarations:1]]
(defun slot-type (object slot)
(flet ((class-slots (class)
#+ecl (clos::class-slots class)
#+ccl (ccl:class-slots class)
#+sbcl (sb-mop:class-slots class))
(slot-definition-name (slot)
#+ecl (clos::slot-definition-name slot)
#+ccl (ccl:slot-definition-name slot)
#+sbcl (sb-mop:slot-definition-name slot)))
(let ((slots (class-slots (class-of object))))
(block searching
(dolist (slot0 slots)
(when (eq slot (slot-definition-name slot0))
(return-from searching
#+ecl (clos::slot-definition-type slot0)
#+ccl (ccl:slot-definition-type slot0)
#+sbcl (sb-mop:slot-definition-type slot0))))))))
(defun check-value-for-slot (value object slot)
(typep value (slot-type object slot)))
;; Checking values against slot type declarations:1 ends here
;; Phrase class
......@@ -3543,8 +3582,7 @@ See sidebar for more commands to try.
(defparameter *text-monospace* "sans-mono-bold-11")
(defclass text (node)
((methods :initform '(:page-up :page-down :center :resize-to-fit :view-messages))
(font :initform "sans-11")
((font :initform "sans-11")
(buffer :initform nil)
(category :initform :comment)
(timeout :initform nil)
......@@ -3561,6 +3599,9 @@ See sidebar for more commands to try.
(auto-fit :initform t)
(visible :initform t)))
(defmethod find-methods append ((text text))
'(page-up page-down center resize-to-fit view-messages))
(defmethod tap ((self text) x y)
(with-slots (buffer width parent height) self
(with-slots (x y font point-row point-column indicator) self
......@@ -4212,12 +4253,12 @@ See sidebar for more commands to try.
;; menu items should not accept any dragged widgets.
(defmethod accept ((self menu) arg) nil)
(defmethod can-pick ((self menu))
;; allow making code blocks from menu items
(or (slot-value self 'method)
(or (keywordp (slot-value self 'action))
;; disallow pulling main menus
(not (slot-value self 'top-level)))))
(defmethod can-pick ((self menu)) nil)
;; ;; allow making code blocks from menu items
;; (or (slot-value self 'method)
;; (or (keywordp (slot-value self 'action))
;; ;; disallow pulling main menus
;; (not (slot-value self 'top-level)))))
(defmethod pick ((self menu))
(when (slot-value self 'target)
......@@ -4243,7 +4284,8 @@ See sidebar for more commands to try.
(string (evaluate action))
(symbol
(when (fboundp action)
(funcall (symbol-function action)))))
(funcall (symbol-function action))))
(node (evaluate action)))
(progn
;; we're a submenu, not an individual menu command.
;; first close any other open menus
......@@ -4317,12 +4359,13 @@ See sidebar for more commands to try.
:color *highlight-background-color*)
(draw-label-string self (display-string self) *highlight-foreground-color*))))))
(defmethod layout :after ((self menu))
(with-slots (width height expanded) self
(when expanded
(incf width 45)
(incf height 10)
(mapc #'layout (inputs self)))))
(defmethod layout :after ((self menu))
(assert (valid-bounding-box-p (multiple-value-list (bounding-box self))))
(with-slots (width height expanded top-level) self
(when (and expanded top-level)
(incf width 45)
(incf height 10)
(mapc #'layout (inputs self)))))
(defmethod draw :after ((self menu))
(with-slots (inputs) self
......
This diff is collapsed.
* Task list
** TODO fix dialog boxes
*** TODO [#A] context-menu with reset-to-current-values
**** TODO pin down context menu elements
**** TODO fix broken layout/rendering of context menu
*** TODO [#A] show error bubble and restore value when input incorrect
*** TODO [#A] fix halos not always being in front
*** TODO [#C] project properties: height width scale-output- resizable author title license frame-rate
*** TODO [#B] Split MAKE-HALO and selection concept
**** TODO revise selection functions to use flag instead of HALO slot
*** TODO [#B] add more notifications for cut/copy etc
*** TODO [#C] add more notifications for cut/copy etc
**** TODO Show yellow notification string on modeline
*** TODO [#C] don't allow halo on properties dialog
*** TODO [#C] ENTER should update value in property field
*** TODO [#C] fix menubar not drawing over dialogs
*** TODO [#C] add nice Apply/Cancel buttons
** TODO [#A] create buffer switch menu
** TODO implement all main system menu dialogs
*** TODO [#A] save-changes
*** TODO [#A] show-project-properties-dialog
*** TODO [#A] show-exit-dialog
*** TODO [#A] edit-cut
*** TODO [#A] edit-copy
*** TODO [#A] edit-paste
*** TODO [#A] show-paste-as-new-buffer-dialog
*** TODO [#A] edit-select-all
*** TODO [#A] edit-clear-selection
*** TODO [#A] transport-play
*** TODO [#A] transport-pause
*** TODO [#A] show-create-buffer-dialog
*** TODO [#A] show-buffer-properties-dialog
*** TODO [#A] show-save-buffer-in-project-dialog
*** TODO [#A] view-clipboard
*** TODO [#A] view-buffer-list
*** TODO [#A] show-copyright-notice
*** TODO [#A] show-help
*** TODO [#B] save-changes
*** TODO [#B] show-classes-dialog
*** TODO [#B] show-paste-from-dialog
*** TODO [#B] show-paste-selection-from-dialog
......@@ -50,6 +31,7 @@
*** TODO [#B] show-import-resource-dialog
*** TODO [#B] show-resource-properties-dialog
*** TODO [#B] show-documentation
*** TODO [#C] show-exit-dialog
*** TODO [#C] show-changes
*** TODO [#C] show-export-archive-dialog
*** TODO [#C] show-export-application-dialog
......@@ -852,3 +834,156 @@
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#C] fix menubar not drawing over dialogs
CLOSED: [2017-04-22 Sat 17:30]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-22 Sat 17:30
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/fix dialog boxes
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#C] don't allow halo on properties dialog
CLOSED: [2017-04-22 Sat 17:30]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-22 Sat 17:30
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/fix dialog boxes
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** TODO [#A] create buffer switch menu
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-22 Sat 17:30
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: TODO
:END:
** DONE [#A] show-project-properties-dialog
CLOSED: [2017-04-22 Sat 17:45]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-22 Sat 17:45
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/implement all main system menu dialogs
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#A] edit-cut
CLOSED: [2017-04-22 Sat 17:44]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-22 Sat 17:45
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/implement all main system menu dialogs
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#A] edit-copy
CLOSED: [2017-04-22 Sat 17:44]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-22 Sat 17:45
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/implement all main system menu dialogs
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#A] edit-paste
CLOSED: [2017-04-22 Sat 17:44]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-22 Sat 17:45
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/implement all main system menu dialogs
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#A] show-paste-as-new-buffer-dialog
CLOSED: [2017-04-22 Sat 17:44]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-22 Sat 17:45
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/implement all main system menu dialogs
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#A] transport-play
CLOSED: [2017-04-22 Sat 17:44]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-22 Sat 17:45
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/implement all main system menu dialogs
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#A] transport-pause
CLOSED: [2017-04-22 Sat 17:45]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-22 Sat 17:45
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/implement all main system menu dialogs
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#A] show-create-buffer-dialog
CLOSED: [2017-04-22 Sat 17:45]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-22 Sat 17:45
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/implement all main system menu dialogs
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#A] show-buffer-properties-dialog
CLOSED: [2017-04-22 Sat 17:45]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-22 Sat 17:45
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/implement all main system menu dialogs
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#A] view-buffer-list
CLOSED: [2017-04-22 Sat 17:45]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-22 Sat 17:45
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/implement all main system menu dialogs
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
** DONE [#A] context-menu with reset-to-current-values
CLOSED: [2017-04-22 Sat 19:09]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-22 Sat 19:14
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/fix dialog boxes
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
*** DONE pin down context menu elements
CLOSED: [2017-04-22 Sat 18:47]
*** DONE fix broken layout/rendering o context menu
CLOSED: [2017-04-22 Sat 18:47]
** DONE [#A] fix halos not always being in front
CLOSED: [2017-04-22 Sat 19:09]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-22 Sat 19:14
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list/fix dialog boxes
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
......@@ -72,5 +72,6 @@
;; (trace xelf::drag-fail)
;; (trace xelf::hit-inputs)
;; (trace xelf::draw-focus)
(trace xelf::destroy)
(test-gui)
......@@ -5231,7 +5231,6 @@ Returns a newly allocated list."
(parent :initform nil :initarg :parent :accessor parent)
(inputs :initform nil :initarg :inputs :accessor inputs)
(results :initform nil :initarg :results :accessor results)
(methods :initform nil :initarg :methods :accessor methods)
(input-widths :initform nil :initarg :input-widths :accessor input-widths)
(focused-p :initform nil :accessor focused-p)
(label :initform nil :initarg :label :accessor label)
......@@ -5261,6 +5260,12 @@ 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.")))
(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
;; Destruction
......@@ -5269,6 +5274,7 @@ Returns a newly allocated list."
;; [[file:~/xelf/xelf.org::*Destruction][Destruction:1]]
(defmethod destroy :before ((self node))
(destroy-halo self))
;; (unplug-from-parent self))
;; Destruction:1 ends here
;; Layout
......@@ -5373,6 +5379,7 @@ Returns a newly allocated list."
;; [[file:~/xelf/xelf.org::*Legacy%20GUI%20compatibility][Legacy GUI compatibility:2]]
(defmethod freeze ((self node)) nil)
(defmethod cancel ((self node)) nil)
(defmethod proper-name ((self node))
(pretty-string (class-name (class-of self))))
......
......@@ -5222,7 +5222,6 @@ subclasses.)
(parent :initform nil :initarg :parent :accessor parent)
(inputs :initform nil :initarg :inputs :accessor inputs)
(results :initform nil :initarg :results :accessor results)
(methods :initform nil :initarg :methods :accessor methods)
(input-widths :initform nil :initarg :input-widths :accessor input-widths)
(focused-p :initform nil :accessor focused-p)
(label :initform nil :initarg :label :accessor label)
......@@ -5252,6 +5251,12 @@ 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.")))
(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))
#+end_src
** Destruction
......@@ -5259,6 +5264,7 @@ subclasses.)
#+begin_src lisp
(defmethod destroy :before ((self node))
(destroy-halo self))
;; (unplug-from-parent self))
#+end_src
** Layout
......@@ -5357,6 +5363,7 @@ in the future.
#+begin_src lisp
(defmethod freeze ((self node)) nil)
(defmethod cancel ((self node)) nil)
(defmethod proper-name ((self node))
(pretty-string (class-name (class-of 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