Commit 98c49dc4 authored by David O'Toole's avatar David O'Toole

draw non-working menu items as greyed

parent 867c89b2
......@@ -225,6 +225,7 @@
(resize-to-scroll box 300 300)
(setf (slot-value box 'max-displayed-lines) 20)
(center box)
(align-to-pixels box)
(bring-to-front box)))
(defmethod show-help ((self system))
......@@ -324,8 +325,8 @@
(:label "Clear selection" :action clear-selection)
(:label "Node properties" :action node-properties-dialog))))
(defparameter *transport-menu*
'(:label "Transport"
(defparameter *play-menu*
'(:label "Play"
:inputs
((:label "Play" :action transport-play)
(:label "Pause" :action transport-pause))))
......@@ -333,7 +334,7 @@
(defparameter *buffers-menu*
'(:label "Buffers"
:inputs
((:label "Create a buffer" :action create-buffer-dialog)
((:label "Create a new buffer" :action create-buffer-dialog)
(:label "Load a buffer from a file" :action load-buffer-from-file-dialog)
(:label "Switch to buffer" :action switch-to-buffer-dialog)
(:label "Rename buffer" :action rename-buffer-dialog)
......@@ -403,7 +404,7 @@
(apply #'append
(mapcar #'list (list *project-menu*
*edit-menu*
*transport-menu*
*play-menu*
*buffers-menu*
*resources-menu*
*tools-menu*
......@@ -577,7 +578,7 @@
(with-slots (inputs) self
(setf (second inputs) content)))
(defun open-frame (title content)
(defun make-frame (title content)
(let ((frame (make-instance 'frame)))
(prog1 frame
(set-title frame title)
......
......@@ -157,6 +157,7 @@
(add-node self help (window-x) (window-y))
(layout help)
(center help)
(align-to-pixels help)
(bring-to-front help)))
;; Showing a help box:1 ends here
......@@ -4160,7 +4161,6 @@ See sidebar for more commands to try.
:scale 1.6
:color "gray50")))))
(defmethod draw-unexpanded ((self menu) &optional label)
(with-slots (action target parent top-level) self
(let ((x (window-pointer-x))
......@@ -4174,11 +4174,13 @@ See sidebar for more commands to try.
(let ((text (or label (display-string self))))
(draw-label-string self
text
(find-color self :foreground)))))
(if (or (null action) (fboundp action))
"gray50"
"gray80")))))
(defmethod draw-highlight ((self menu))
(with-slots (y height expanded parent top-level) self
(when parent
(with-slots (y height expanded action parent top-level) self
(when (and parent (fboundp action))
(with-slots (x width) parent
;; don't highlight top-level trees.
(when (and (not expanded) (not top-level))
......@@ -4187,7 +4189,7 @@ See sidebar for more commands to try.
(- width (dash 4))
(+ height 1)
:color *highlight-background-color*)
(draw-label-string self (display-string self)))))))
(draw-label-string self (display-string self) "white"))))))
(defmethod layout :after ((self menu))
(with-slots (width height expanded) self
......
......@@ -204,6 +204,7 @@ See also "Command shell" below.
(add-node self help (window-x) (window-y))
(layout help)
(center help)
(align-to-pixels help)
(bring-to-front help)))
#+end_src
......@@ -4167,7 +4168,6 @@ supported compiler.
:scale 1.6
:color "gray50")))))
(defmethod draw-unexpanded ((self menu) &optional label)
(with-slots (action target parent top-level) self
(let ((x (window-pointer-x))
......@@ -4181,11 +4181,13 @@ supported compiler.
(let ((text (or label (display-string self))))
(draw-label-string self
text
(find-color self :foreground)))))
(if (or (null action) (fboundp action))
"gray50"
"gray80")))))
(defmethod draw-highlight ((self menu))
(with-slots (y height expanded parent top-level) self
(when parent
(with-slots (y height expanded action parent top-level) self
(when (and parent (fboundp action))
(with-slots (x width) parent
;; don't highlight top-level trees.
(when (and (not expanded) (not top-level))
......@@ -4194,7 +4196,7 @@ supported compiler.
(- width (dash 4))
(+ height 1)
:color *highlight-background-color*)
(draw-label-string self (display-string self)))))))
(draw-label-string self (display-string self) "white"))))))
(defmethod layout :after ((self menu))
(with-slots (width height expanded) self
......@@ -4391,17 +4393,18 @@ supported compiler.
(string-trim " " name)))
'simple-string)))
(command-argument-string (thing)
(concatenate 'string (command-name-string thing) ": ")))
(concatenate 'string (command-name-string thing) ": "))
(action-name () (intern (concatenate 'string (symbol-name name) "-action"))))
`(progn
(defun ,name (&key ,@arglist) ,@body)
(export ',name)
(defun ,(action-name) (&key ,@arglist) ,@body)
(export ',(action-name))
(define-visual-macro ,name
(:super phrase
:slots ((orientation :initform :vertical))
:inputs ,(command-inputs name arglist)))
(defmethod evaluate ((self ,name))
;; call the command function
(apply #'funcall #',name
(apply #'funcall #',(action-name)
;; with the evaluated results of
(mapcar #'evaluate
;; all the argument names/values
......@@ -4675,6 +4678,7 @@ supported compiler.
(resize-to-scroll box 300 300)
(setf (slot-value box 'max-displayed-lines) 20)
(center box)
(align-to-pixels box)
(bring-to-front box)))
(defmethod show-help ((self system))
......@@ -4772,8 +4776,8 @@ supported compiler.
(:label "Clear selection" :action clear-selection)
(:label "Node properties" :action node-properties-dialog))))
(defparameter *transport-menu*
'(:label "Transport"
(defparameter *play-menu*
'(:label "Play"
:inputs
((:label "Play" :action transport-play)
(:label "Pause" :action transport-pause))))
......@@ -4781,7 +4785,7 @@ supported compiler.
(defparameter *buffers-menu*
'(:label "Buffers"
:inputs
((:label "Create a buffer" :action create-buffer-dialog)
((:label "Create a new buffer" :action create-buffer-dialog)
(:label "Load a buffer from a file" :action load-buffer-from-file-dialog)
(:label "Switch to buffer" :action switch-to-buffer-dialog)
(:label "Rename buffer" :action rename-buffer-dialog)
......@@ -4851,7 +4855,7 @@ supported compiler.
(apply #'append
(mapcar #'list (list *project-menu*
*edit-menu*
*transport-menu*
*play-menu*
*buffers-menu*
*resources-menu*
*tools-menu*
......@@ -5025,7 +5029,7 @@ supported compiler.
(with-slots (inputs) self
(setf (second inputs) content)))
(defun open-frame (title content)
(defun make-frame (title content)
(let ((frame (make-instance 'frame)))
(prog1 frame
(set-title frame title)
......
......@@ -180,17 +180,18 @@
(string-trim " " name)))
'simple-string)))
(command-argument-string (thing)
(concatenate 'string (command-name-string thing) ": ")))
(concatenate 'string (command-name-string thing) ": "))
(action-name () (intern (concatenate 'string (symbol-name name) "-action"))))
`(progn
(defun ,name (&key ,@arglist) ,@body)
(export ',name)
(defun ,(action-name) (&key ,@arglist) ,@body)
(export ',(action-name))
(define-visual-macro ,name
(:super phrase
:slots ((orientation :initform :vertical))
:inputs ,(command-inputs name arglist)))
(defmethod evaluate ((self ,name))
;; call the command function
(apply #'funcall #',name
(apply #'funcall #',(action-name)
;; with the evaluated results of
(mapcar #'evaluate
;; all the argument names/values
......
......@@ -2,16 +2,22 @@
* Task list
** DONE draw non-working menu items as greyed
CLOSED: [2017-04-18 Tue 01:18]
** TODO redesign system menu
** TODO make master system menu todo list
** TODO Design user experience
*** TODO launching external programs to edit assets. gimp, audacity, switch-to-emacs,. etc
** TODO postpone project creation/loading dialogs, focus on working within one project
** TODO [#A] fix ugly dialog boxes
** TODO [#A] create buffer switch menu
** TODO [#A] fix data entry widget validation
** TODO Desktop buffer-class for workspace / task / folder management
*** TODO Icon class
*** TODO auto layout simple line rules with spacing
*** TODO auto scale icons and grid with window
*** TODO monochrome icons
*** TODO themeable vertex colors
** TODO [#A] fix ugly dialog boxes
** TODO [#A] create buffer switch menu
** TODO [#A] fix data entry widget validation
** TODO [#A] make each buffer have its own command-history?
** TODO [#A] button class
** TODO [#A] checkbox
** TODO [#A] fix disappearing shell prompt when clicking shell
......@@ -41,6 +47,7 @@
** TODO [#C] dropdown list
** TODO [#C] export-as-application
** TODO [#C] change xelf system menu to dark colors
** TODO [#C] make each buffer have its own command-history?
** TODO [#C] change :no-background to :inhibit-background-p
** TODO [#C] radio buttons
** TODO [#C] fix POSITION-WITHIN-PARENT error on pressing TAB
......
......@@ -70,16 +70,40 @@
(defmethod last-column ((desktop desktop))
(1- (truncate (/ *screen-width* (icon-stride desktop)))))
(defmethod last-row ((desktop desktop))
(- (truncate (/ *screen-height* (icon-stride desktop))) 2))
(defmethod snap-to-grid ((icon icon) (desktop desktop))
(with-slots (icon-spacing icon-size top-margin) desktop
(with-slots (x y) icon
(place-icon desktop icon
(truncate (/ x (icon-stride desktop)))
(truncate (/ y (icon-stride desktop)))))))
(with-slots (x y) icon
(place-icon desktop icon
(truncate (/ x (icon-stride desktop)))
(truncate (/ y (icon-stride desktop))))))
(defmethod arrange ((desktop desktop))
(dolist (icon (find-instances desktop 'icon))
(snap-to-grid icon desktop)
(auto-resize icon desktop)
(auto-resize icon desktop)))
(defmethod auto-arrange-column ((desktop desktop) icons column)
(let ((row 0))
(dolist (icon icons)
(multiple-value-bind (x y) (grid-position desktop column row)
(place-icon desktop icon x y)
(incf row)))))
(defmethod auto-arrange ((desktop desktop))
(let* ((icons-per-column (1+ (last-row desktop)))
(last-column (last-column desktop))
(column last-column)
(icons (find-instances desktop 'icon)))
(loop while (and icons
(not (minusp column)))
do (if (> (length icons) icons-per-column)
(progn
(auto-arrange-column desktop (subseq icons 0 (1- icons-per-column)) column)
(setf icons (subseq icons icons-per-column)))
(auto-arrange-column desktop icons column))
do (decf column))))
......@@ -25,24 +25,8 @@
;; start the buffer running
(switch-to-buffer plong)
(at-next-update
(add-node (current-buffer) (make-instance 'xelf::resize-buffer-dialog) 200 200)
;; (add-node (current-buffer) (make-instance 'xelf::resize-buffer-dialog) 200 200)
(bind-event (current-buffer) '(:f9) 'xelf::toggle-other-windows)
(add-node (current-buffer)
(xelf::open-frame
"Buffers"
(xelf::make-menu '(:label "ignored"
:expanded t
:inputs
((:label "Create a buffer" :action xelf::create-buffer-dialog)
(:label "Load a buffer from a file" :action xelf::load-buffer-from-file-dialog)
(:label "Switch to buffer" :action xelf::switch-to-buffer-dialog)
(:label "Rename buffer" :action xelf::rename-buffer-dialog)
(:label "Resize buffer" :action xelf::resize-buffer-dialog)
(:label "Save buffer in project" :action xelf::save-buffer-in-project-dialog)
(:label "Save buffer in new file" :action xelf::save-buffer-in-new-file-dialog)
(:label "Revert buffer" :action xelf::revert-buffer-dialog)
(:label "View clipboard" :action xelf::view-clipboard)
(:label "View buffer list" :action xelf::view-buffer-list)))))))
(start-game plong))))
(start-game plong)))))
(test-gui)
(test-gui)
......@@ -159,7 +159,7 @@ more information.
;; [[file:~/xelf/xelf.org::*Assembling%20a%20full%20copyright%20notice][Assembling a full copyright notice:1]]
(defvar *copyright-notice*
(concatenate 'string *compiler-copyright-notice* *xelf-copyright-notice*)
(concatenate 'string *xelf-copyright-notice* *compiler-copyright-notice*)
"Copyright notices for Xelf, its dependencies, and the current Lisp
implementation.")
......@@ -1857,13 +1857,13 @@ Returns a newly allocated list."
(optimize (speed 3)))
(not (or
;; is the top below the other bottom?
(< (+ o-top o-height) y)
(<= (+ o-top o-height) y)
;; is bottom above other top?
(< (+ y height) o-top)
(<= (+ y height) o-top)
;; is right to left of other left?
(< (+ x width) o-left)
(<= (+ x width) o-left)
;; is left to right of other right?
(< (+ o-left o-width) x))))
(<= (+ o-left o-width) x))))
(defmethod colliding-with-rectangle-p ((self quadrille) o-top o-left o-width o-height)
;; you must pass arguments in Y X order since this is TOP then LEFT
......
......@@ -218,7 +218,7 @@ See also the section "System terminal" below.
#+begin_src lisp
(defvar *copyright-notice*
(concatenate 'string *compiler-copyright-notice* *xelf-copyright-notice*)
(concatenate 'string *xelf-copyright-notice* *compiler-copyright-notice*)
"Copyright notices for Xelf, its dependencies, and the current Lisp
implementation.")
......
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