Commit 12322989 authored by David O'Toole's avatar David O'Toole

rework dialog definers

parent 98c49dc4
This diff is collapsed.
......@@ -81,8 +81,8 @@
(defmethod initialize-instance :after ((self buffer) &key name)
(when name (setf (slot-value self 'name) name))
(with-shell
(bind-event self '(:f1) 'show-help)
(bind-event self '(:h :control) 'show-help)
(bind-event self '(:f1) 'show-help-command)
(bind-event self '(:h :control) 'show-help-command)
(bind-event self '(:c :control) 'edit-copy)
(bind-event self '(:x :control) 'edit-cut)
(bind-event self '(:v :control) 'edit-paste)
......@@ -152,13 +152,8 @@
;; [[file:~/xelf/gui.org::*Showing%20a%20help%20box][Showing a help box:1]]
(defmethod show-help ((self buffer))
(let ((help (make-instance 'text :text *help-text*)))
(add-node self help (window-x) (window-y))
(layout help)
(center help)
(align-to-pixels help)
(bring-to-front help)))
(defmethod show-help-command ((self buffer))
(show-help))
;; Showing a help box:1 ends here
;; Handling events
......@@ -2678,9 +2673,9 @@ See sidebar for more commands to try.
"Draw the cursor. By default, it is not drawn at all."
nil)
(defparameter *highlight-background-color* "gray90")
(defparameter *highlight-background-color* "white")
(defparameter *highlight-foreground-color* "gray10")
(defparameter *highlight-foreground-color* "gray50")
(defmethod draw-focus ((self node))
"Draw any additional indications of input focus." nil)
......@@ -2766,8 +2761,8 @@ See sidebar for more commands to try.
"Automatically center the node on the screen."
(with-slots (window-x window-y) *buffer*
(with-slots (x y width height) self
(let ((center-x (+ window-x (/ *gl-screen-width* 2)))
(center-y (+ window-y (/ *gl-screen-height* 2))))
(let ((center-x (+ window-x (/ *screen-width* 2)))
(center-y (+ window-y (/ *screen-height* 2))))
(setf x (+ (- center-x (/ width 2))))
(setf y (+ (- center-y (/ width 2))))))))
......@@ -4120,36 +4115,36 @@ See sidebar for more commands to try.
(string (evaluate action))
(symbol
(when (fboundp action)
(funcall (symbol-function action)
(or target (symbol-value '*system*))))))
(funcall (symbol-function action)))))
;;(or target (symbol-value '*system*))))))
(progn
;; we're a submenu, not an individual menu command.
;; first close any other open menus
(mapc #'unexpand (siblings self))
(toggle-expanded self)))))
(defparameter *menu-tab-color* "gray60")
(defparameter *menu-title-color* "white")
(defparameter *menu-tab-color* "gray80")
(defparameter *menu-title-color* "gray40")
(defmethod draw-expanded ((self menu) &optional label)
(with-slots (action x y width height parent inputs top-level) self
(let ((header (header-height self)))
(if top-level
;; draw the header a bit differently to avoid over-drawing
;; other headers in a menu bar situation.
(progn
;;(assert parent)
(progn
;; draw the tree background
(draw-patch self
x (dash 2 y header)
(dash 0 x width)
(- (dash 1 y height) (dash 1))
:color "gray18")
;; draw the header a bit differently to avoid over-drawing
;; other headers in a menu bar situation.
(draw-patch self x (+ 1 y)
(+ (dash 2) x (header-width self))
(dash 3 y header)
(dash 3 y header -2)
:color *menu-tab-color*)
(draw-label-string
self (or label *null-display-string*) *menu-title-color*)
;; draw the rest of the tree background
(draw-patch self
x (dash 2 y header)
(dash 0 x width)
(- (dash 1 y height) (dash 1))))
self (or label *null-display-string*) *menu-title-color*))
;; nope, draw in the typical fashion.
(when (parent self) (draw-expanded (slot-value self 'parent) label)))
;; draw status indicator on submenus
......@@ -4174,9 +4169,11 @@ See sidebar for more commands to try.
(let ((text (or label (display-string self))))
(draw-label-string self
text
(if (or (null action) (fboundp action))
"gray50"
"gray80")))))
(if (or (functionp action)
(null action)
(fboundp action))
"gray80"
"gray60")))))
(defmethod draw-highlight ((self menu))
(with-slots (y height expanded action parent top-level) self
......@@ -4189,7 +4186,7 @@ See sidebar for more commands to try.
(- width (dash 4))
(+ height 1)
:color *highlight-background-color*)
(draw-label-string self (display-string self) "white"))))))
(draw-label-string self (display-string self) *highlight-foreground-color*))))))
(defmethod layout :after ((self menu))
(with-slots (width height expanded) self
......
This diff is collapsed.
......@@ -158,84 +158,110 @@
;; [[file:~/xelf/gui.org::*Interactive%20dialog%20boxes][Interactive dialog boxes:1]]
(defmacro with-dialog-definers (&body body)
`(labels ((arglist-input-forms (argument-forms)
(mapcar #'(lambda (f)
`(make-sentence
(list
(make-instance 'symbol-entry :value ,(make-keyword (first f)) :read-only t)
(make-instance 'expression-entry :value ,(second f) :read-only nil))))
argument-forms))
(command-inputs (name arglist)
`(;;(let ((label (make-instance 'label :read-only t :font "sans-condensed-bold-18")))
;; (prog1 label (set-value label ,(command-name-string (symbol-name name)))))
(make-paragraph (list ,@(arglist-input-forms arglist)))))
(command-name-string (thing)
(let ((name (etypecase thing
(symbol (symbol-name thing))
(string thing))))
(coerce
(string-capitalize
(substitute #\Space #\-
(string-trim " " name)))
'simple-string)))
(command-argument-string (thing)
(concatenate 'string (command-name-string thing) ": "))
(action-name () (intern (concatenate 'string (symbol-name name) "-ACTION")))
(show-name () (intern (concatenate 'string "SHOW-" (symbol-name name))))
(dialog-class-name () (intern (concatenate 'string (symbol-name name) "-DIALOG"))))
,@body))
(defmacro define-dialog (name arglist &body body)
(labels ((arglist-input-forms (argument-forms)
(mapcar #'(lambda (f)
`(make-sentence
(list
(make-instance 'keyword-entry :value ,(make-keyword (first f)) :read-only t)
(make-instance 'expression-entry :value ,(second f) :read-only nil))))
argument-forms))
(command-inputs (name arglist)
`((let ((label (make-instance 'label :read-only t :font "sans-condensed-bold-18")))
(prog1 label (set-value label ,(command-name-string (symbol-name name)))))
(make-paragraph (list ,@(arglist-input-forms arglist)))))
(command-name-string (thing)
(let ((name (etypecase thing
(symbol (symbol-name thing))
(string thing))))
(coerce
(string-capitalize
(substitute #\Space #\-
(string-trim " " name)))
'simple-string)))
(command-argument-string (thing)
(concatenate 'string (command-name-string thing) ": "))
(action-name () (intern (concatenate 'string (symbol-name name) "-action"))))
(with-dialog-definers
`(progn
(defun ,(action-name) (&rest ^args^) ,@body)
(export ',(action-name))
(defun ,(show-name) (&rest args)
(show-dialog (apply #'make-instance ',(dialog-class-name) args)
,(command-name-string name)))
(export ',(show-name))
(define-visual-macro ,(dialog-class-name)
(:super phrase
:slots ((orientation :initform :vertical)
(instance :initform nil :initarg :instance))
:inputs ,(command-inputs name arglist)))
(export ',(dialog-class-name))
(defmethod evaluate ((self ,(dialog-class-name)))
;; call the command function
(funcall #',(action-name)
;; with the evaluated results of
(mapcar #'evaluate
;; all the argument names/values
(mapcan #'identity
(mapcar #'%inputs
;; from the dialog box
(%inputs (first (slot-value self 'inputs)))))))))))
(defmacro define-properties-dialog (name slots &body body)
(let ((instance (gensym)))
(labels ((place-form (slot) `(slot-value ,instance ',slot))
(init-form (slot) `(,slot ,(place-form slot)))
(setf-form (slot value) `(setf ,(place-form slot) ,value)))
`(progn
(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 #',(action-name)
;; with the evaluated results of
(mapcar #'evaluate
;; all the argument names/values
(mapcan #'identity
(mapcar #'%inputs
;; from the dialog box
(%inputs (second (slot-value self 'inputs)))))))))))
(defparameter *minimum-shell-width* 400)
(defparameter *shell-background-color* "gray20")
(defparameter *default-command-prompt-string* " > ")
(defun make-label (string &optional font)
(let ((label (make-instance 'label)))
(prog1 label
(set-value label string)
(set-read-only label t)
(when font
(setf (slot-value label 'font) font)))))
(define-visual-macro shell
(:super phrase
:slots
((orientation :initform :vertical)
(frozen :initform t)
(category :initform :system)
(spacing :initform 4)
;;
(entry-index :initform 0)
(target-x :initform 0)
(target-y :initform 0))
:inputs
(:output (make-instance 'phrase)
:modeline (make-instance 'modeline)
:command-area (make-sentence
(list
(make-label *default-command-prompt-string*)
(make-instance 'shell-prompt)))))
(at-next-update (evaluate-expression (shell-prompt) (list 'in-package (package-name (project-package)))))
(at-next-update (add-node (current-buffer) (make-instance 'menubar)))
(at-next-update (setf *system* (make-instance 'system))))
(defun create-shell-maybe ()
(when (null *shell*)
(setf *shell* (make-instance 'shell))))
(define-dialog ,name ,(mapcar #'init-form slots)
(loop while ^args^ do
(let ((slot (pop ^args^))
(value (pop ^args^)))
(setf (slot-value ,instance slot) value))))
(defmethod initialize-instance :after ((self ,name) &key instance)
(setf ,instance instance))))))
(defparameter *minimum-shell-width* 400)
(defparameter *shell-background-color* "gray20")
(defparameter *default-command-prompt-string* " > ")
(defun make-label (string &optional font)
(let ((label (make-instance 'label)))
(prog1 label
(set-value label string)
(set-read-only label t)
(when font
(setf (slot-value label 'font) font)))))
(define-visual-macro shell
(:super phrase
:slots
((orientation :initform :vertical)
(frozen :initform t)
(category :initform :system)
(spacing :initform 4)
;;
(entry-index :initform 0)
(target-x :initform 0)
(target-y :initform 0))
:inputs
(:output (make-instance 'phrase)
:modeline (make-instance 'modeline)
:command-area (make-sentence
(list
(make-label *default-command-prompt-string*)
(make-instance 'shell-prompt)))))
(at-next-update (evaluate-expression (shell-prompt) (list 'in-package (package-name (project-package)))))
(at-next-update (add-node (current-buffer) (make-instance 'menubar)))
(at-next-update (setf *system* (make-instance 'system))))
(defun create-shell-maybe ()
(when (null *shell*)
(setf *shell* (make-instance 'shell))))
;; Interactive dialog boxes:1 ends here
#+TODO: TODO WORKING | DONE
* Task list
** DONE draw non-working menu items as greyed
CLOSED: [2017-04-18 Tue 01:18]
** TODO redesign system menu
** DONE redesign system menu
CLOSED: [2017-04-18 Tue 19:34]
** TODO fix ugly dialog boxes
*** TODO remove old titlebar
*** TODO define-properties-dialog
*** TODO [#B] add nice Apply/Cancel buttons
** TODO make master system menu todo list
*** TODO save-changes
*** TODO show-edit-project-properties-dialog
*** TODO show-changes
*** TODO show-classes-dialog
*** TODO show-export-archive-dialog
*** TODO show-export-application-dialog
*** TODO show-publish-ftp-dialog
*** TODO edit-preferences
*** TODO show-exit-dialog
*** TODO edit-cut
*** TODO edit-copy
*** TODO edit-paste
*** TODO show-paste-as-new-buffer-dialog
*** TODO show-paste-from-dialog
*** TODO show-paste-selection-from-dialog
*** TODO edit-select-all
*** TODO edit-clear-selection
*** TODO edit-invert-selection
*** TODO show-node-properties-dialog
*** TODO show-shell-history-dialog
*** TODO transport-play
*** TODO transport-pause
*** TODO show-create-buffer-dialog
*** TODO show-load-buffer-from-file-dialog
*** TODO show-switch-to-buffer-dialog
*** TODO show-buffer-properties-dialog
*** TODO show-rename-buffer-dialog
*** TODO show-resize-buffer-dialog
*** TODO show-save-buffer-in-project-dialog
*** TODO show-copy-buffer-dialog
*** TODO show-destroy-buffer-dialog
*** TODO show-save-buffer-in-new-file-dialog
*** TODO show-revert-buffer-dialog
*** TODO resize-to-background-image
*** TODO show-take-snapshot-dialog
*** TODO view-clipboard
*** TODO view-buffer-list
*** TODO show-move-viewport-dialog
*** TODO show-scrolling-properties-dialog
*** TODO show-zoom-level-dialog
*** TODO reset-zoom-level
*** TODO show-import-resource-dialog
*** TODO show-resource-properties-dialog
*** TODO edit-resource-externally
*** TODO show-search-resources-dialog
*** TODO show-export-resources-dialog
*** TODO browse-resources
*** TODO show-create-sprite-sheet-dialog
*** TODO show-edit-sprite-sheet-dialog
*** TODO show-edit-fonts-dialog
*** TODO show-preload-resources-dialog
*** TODO show-clear-cached-resources-dialog
*** TODO switch-to-desktop
*** TODO auto-arrange-icons
*** TODO toggle-snap-to-grid
*** TODO previous-desktop
*** TODO create-desktop
*** TODO rename-desktop
*** TODO delete-desktop
*** TODO show-desktop-properties-dialog
*** TODO switch-to-emacs
*** TODO show-edit-lisp-dialog
*** TODO show-inspect-object-dialog
*** TODO show-version-control-dialog
*** TODO browse-devices
*** TODO scan-for-devices
*** TODO configure-joystick
*** TODO configure-keyboard
*** TODO show-copyright-notice
*** TODO show-documentation
*** TODO show-help
*** TODO show-examples
*** TODO show-reference
** 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 folders are virtual views, they don't nest
** TODO [#A] plist/variable properties editor
** TODO [#A] project properties: height width scale-output- resizable author title license frame-rate
** TODO [#A] create buffer switch menu
** TODO [#A] fix data entry widget validation
** TODO [#A] button class
** TODO [#A] checkbox
** DONE postpone project creation/loading dialogs, focus on working within one project
CLOSED: [2017-04-18 Tue 19:34]
** 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] button class
** TODO [#A] checkbox
** TODO [#A] fix disappearing shell prompt when clicking shell
** TODO [#A] controls for scrolling the buffer window
** TODO [#A] fix any move handle should move group
......@@ -476,3 +553,13 @@
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: TODO
:END:
** DONE draw non-working menu items as greyed
CLOSED: [2017-04-18 Tue 01:18]
:PROPERTIES:
:ARCHIVE_TIME: 2017-04-18 Tue 19:32
:ARCHIVE_FILE: ~/xelf/tasks.org
:ARCHIVE_OLPATH: Task list
:ARCHIVE_CATEGORY: tasks
:ARCHIVE_TODO: DONE
:END:
......@@ -45,8 +45,7 @@
;; [[file:~/xelf/xelf.org::*Compiler-specific%20notices][Compiler-specific notices:1]]
(defvar *ccl-copyright-notice*
"-----------------------------------------------------------------
This distribution of Xelf is compiled with Clozure Common Lisp.
"This distribution of Xelf is compiled with Clozure Common Lisp.
Clozure CL is (C) 2009 by Clozure Associates. Starting with version
1.11, Clozure CL is distributed under the terms of the Apache
License, version 2.0.More information on Clozure CL, and complete
......@@ -55,8 +54,7 @@ http://ccl.clozure.com/
")
(defvar *sbcl-copyright-notice*
"-----------------------------------------------------------------
This distribution of Xelf is compiled with Steel Bank Common Lisp (SBCL).
"This distribution of Xelf is compiled with Steel Bank Common Lisp (SBCL).
Steel Bank Common Lisp (SBCL) is free software, and comes with
absolutely no warranty. Please see the file named
./licenses/COPYING.SBCL.txt The PCL implementation is (C) 1985-1990
......@@ -67,8 +65,7 @@ and complete source code may be found at the SBCL website: http://sbcl.org
")
(defvar *ecl-copyright-notice*
"-----------------------------------------------------------------
This distribution of Xelf is compiled with Embeddable Common-Lisp (ECL).
"This distribution of Xelf is compiled with Embeddable Common-Lisp (ECL).
Copyright (C) 1984 Taiichi Yuasa and Masami Hagiya
Copyright (C) 1993 Giuseppe Attardi
Copyright (C) 2000 Juan J. Garcia-Ripoll
......@@ -96,9 +93,8 @@ https://common-lisp.net/project/ecl/
;; [[file:~/xelf/xelf.org::*Xelf%20copyright%20notices][Xelf copyright notices:1]]
(defvar *xelf-copyright-notice*
"-----------------------------------------------------------------
Welcome to Xelf.
Xelf is Copyright (C) 2006-2016 by David T O'Toole <dto@xelf.me>
"Welcome to Xelf.
Xelf is Copyright (C) 2006-2017 by David T O'Toole <dto@xelf.me>
http://xelf.me/
This program is free software: you can redistribute it and/or modify
......
......@@ -106,8 +106,7 @@ notice of your own.
#+begin_src lisp
(defvar *ccl-copyright-notice*
"-----------------------------------------------------------------
This distribution of Xelf is compiled with Clozure Common Lisp.
"This distribution of Xelf is compiled with Clozure Common Lisp.
Clozure CL is (C) 2009 by Clozure Associates. Starting with version
1.11, Clozure CL is distributed under the terms of the Apache
License, version 2.0.More information on Clozure CL, and complete
......@@ -116,8 +115,7 @@ http://ccl.clozure.com/
")
(defvar *sbcl-copyright-notice*
"-----------------------------------------------------------------
This distribution of Xelf is compiled with Steel Bank Common Lisp (SBCL).
"This distribution of Xelf is compiled with Steel Bank Common Lisp (SBCL).
Steel Bank Common Lisp (SBCL) is free software, and comes with
absolutely no warranty. Please see the file named
./licenses/COPYING.SBCL.txt The PCL implementation is (C) 1985-1990
......@@ -128,8 +126,7 @@ and complete source code may be found at the SBCL website: http://sbcl.org
")
(defvar *ecl-copyright-notice*
"-----------------------------------------------------------------
This distribution of Xelf is compiled with Embeddable Common-Lisp (ECL).
"This distribution of Xelf is compiled with Embeddable Common-Lisp (ECL).
Copyright (C) 1984 Taiichi Yuasa and Masami Hagiya
Copyright (C) 1993 Giuseppe Attardi
Copyright (C) 2000 Juan J. Garcia-Ripoll
......@@ -156,9 +153,8 @@ Here is the copyright notice for Xelf and its components:
#+begin_src lisp
(defvar *xelf-copyright-notice*
"-----------------------------------------------------------------
Welcome to Xelf.
Xelf is Copyright (C) 2006-2016 by David T O'Toole <dto@xelf.me>
"Welcome to Xelf.
Xelf is Copyright (C) 2006-2017 by David T O'Toole <dto@xelf.me>
http://xelf.me/
This program is free software: you can redistribute it and/or modify
......
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