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

rework a bit more

parent 15f955d5
...@@ -262,29 +262,27 @@ ...@@ -262,29 +262,27 @@
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*User%20dialogs][User dialogs:1]] ;; [[file:~/quicklisp/local-projects/xelf/gui.org::*User%20dialogs][User dialogs:1]]
(define-command-dialog rename-buffer (define-dialog rename-buffer
((new-name (slot-value (current-buffer) 'buffer-name))) ((new-name (slot-value (current-buffer) 'buffer-name)))
(rename (current-buffer) (arg 'new-name))) (rename (current-buffer) new-name))
(define-command-dialog resize-buffer (define-dialog resize-buffer
((width (slot-value (current-buffer) 'width)) ((width (slot-value (current-buffer) 'width))
(height (slot-value (current-buffer) 'height))) (height (slot-value (current-buffer) 'height)))
(resize (current-buffer) (resize (current-buffer) width height))
(arg 'width)
(arg 'height)))
(define-command-dialog visit-buffer (define-dialog visit-buffer
((buffer-name (or (first *buffer-history*) ((buffer-name (or (first *buffer-history*)
(buffer-name (current-buffer))))) (buffer-name (current-buffer)))))
(switch-to-buffer (arg 'buffer-name))) (switch-to-buffer buffer-name))
(define-command-dialog create-buffer (define-dialog create-buffer
((buffer-name (uniquify-buffer-name "*untitled-buffer*"))) ((buffer-name (uniquify-buffer-name "*untitled-buffer*")))
(switch-to-buffer (make-instance 'buffer :name (arg 'buffer-name)))) (switch-to-buffer (make-instance 'buffer :name buffer-name)))
(define-command-dialog paste-as-new-buffer (define-dialog paste-as-new-buffer
((buffer-name (uniquify-buffer-name "*pasted-buffer*"))) ((buffer-name (uniquify-buffer-name "*pasted-buffer*")))
(switch-to-buffer (make-instance 'buffer :name (arg 'buffer-name))) (switch-to-buffer (make-instance 'buffer :name buffer-name))
(paste (current-buffer)) (paste (current-buffer))
(trim (current-buffer))) (trim (current-buffer)))
......
...@@ -4206,6 +4206,87 @@ See sidebar for more commands to try. ...@@ -4206,6 +4206,87 @@ See sidebar for more commands to try.
(draw-highlight self))))))) (draw-highlight self)))))))
;; Menu widget:1 ends here ;; Menu widget:1 ends here
;; Dialog box builder
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Dialog%20box%20builder][Dialog box builder:1]]
(defmacro define-dialog (name arglist &body body)
`(progn
(defun ,(action-name name) (&key arglist) ,@body)
(export ',(action-name name))
(defun ,(show-name name) (&rest args)
(show-dialog (apply #'make-instance ',(dialog-class-name name) args)
,(command-name-string name)))
(export ',(show-name name))
(define-visual-macro ,(dialog-class-name name)
(:super phrase
:slots ((orientation :initform :vertical))
:inputs ,(command-inputs name arglist)))
(export ',(dialog-class-name name))
(defmethod evaluate ((self ,(dialog-class-name name)))
;; call the command function
(apply #'funcall #',(action-name 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-command-dialog (name arglist &body body)
`(define-dialog ,name ,arglist
(labels ((arg (name) (getf ^args^ name)))
,@body)))
(defclass property-sheet (phrase)
((orientation :initform :vertical)
(instance :initform nil :initarg :instance :accessor instance)
(properties :initform nil :initarg :properties :accessor properties)))
(defmethod initialize-instance :after ((sheet property-sheet) &key)
(with-slots (inputs properties instance) sheet
(dolist (property properties)
(let ((row (make-sentence
(list
(make-instance 'symbol-entry
:value property
:read-only t)
(make-instance 'expression-entry
:value (slot-value instance property)
:read-only nil)))))
(push row inputs)))
(setf inputs (nreverse inputs))
(update-parent-links sheet)
(freeze sheet)))
(defmethod get-property-list ((sheet property-sheet))
(mapcar #'evaluate
(mapcan #'identity
(mapcar #'inputs
(inputs (first (inputs sheet)))))))
(defmethod apply-properties ((sheet property-sheet) instance)
(let ((plist (get-property-list sheet)))
(loop while plist do
(let* ((slot (pop plist))
(value (pop plist)))
(setf (slot-value instance slot) value)))))
(defmethod evaluate ((sheet property-sheet))
(apply-properties sheet (instance sheet)))
(defvar *instance* nil)
(defmacro define-properties-dialog (name slot-names &rest body)
`(progn
(defun ,(show-name name) (&optional (instance *instance*))
(show-dialog (apply #'make-instance ',(dialog-class-name name) :instance instance)
,(command-name-string name)))
(defclass ,(dialog-class-name name) (property-sheet)
((properties :initform ',slot-names)))))
;; Dialog box builder:1 ends here
;; Show methods definitions in Emacs :emacs: ;; Show methods definitions in Emacs :emacs:
......
...@@ -4327,8 +4327,47 @@ supported compiler. ...@@ -4327,8 +4327,47 @@ supported compiler.
(draw-line x y (+ x width) y :color "gray50"))) (draw-line x y (+ x width) y :color "gray50")))
#+end_src #+end_src
** Shell prompt ** Interactive dialog box tools
#+begin_src lisp :tangle shell.lisp
(defun 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))
(defun command-inputs (name arglist)
`(list;;(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)))))
(defun command-name-string (thing)
(let ((name (etypecase thing
(symbol (symbol-name thing))
(string thing))))
(coerce
(string-capitalize
(substitute #\Space #\-
(string-trim " " name)))
'simple-string)))
(defun command-argument-string (thing)
(concatenate 'string (command-name-string thing) ": "))
(defun action-name (name)
(intern (concatenate 'string (symbol-name name) "-ACTION")))
(defun show-name (name)
(intern (concatenate 'string "SHOW-" (symbol-name name) "-DIALOG")))
(defun dialog-class-name (name)
(intern (concatenate 'string (symbol-name name) "-DIALOG")))
#+end_src
** Shell prompt
#+begin_src lisp :tangle shell.lisp #+begin_src lisp :tangle shell.lisp
(defclass shell-prompt (entry) (defclass shell-prompt (entry)
((result :initform nil) ((result :initform nil)
...@@ -4365,80 +4404,7 @@ supported compiler. ...@@ -4365,80 +4404,7 @@ supported compiler.
;; (bind-event self '(:escape) 'close-shell)) ;; (bind-event self '(:escape) 'close-shell))
#+end_src #+end_src
** Interactive dialog boxes
#+begin_src lisp :tangle shell.lisp #+begin_src lisp :tangle shell.lisp
(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")))
(dialog-class-name () (intern (concatenate 'string (symbol-name name) "-DIALOG"))))
,@body))
(defvar *instance* nil)
(defmacro define-dialog (name arglist &body body)
(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 *instance* :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-command-dialog (name arglist &body body)
`(define-dialog ,name ,arglist
(labels ((arg (name) (getf ^args^ name)))
,@body)))
(defmacro define-properties-dialog (name slots &body body)
(labels ((place-form (slot) `(slot-value ,instance ',slot))
(init-form (slot) `(,slot ,(place-form slot)))
(setf-form (slot value) `(setf ,(place-form slot) ,value)))
`(define-dialog ,name ,(mapcar #'init-form slots)
(loop while ^args^ do
(let ((slot (pop ^args^))
(value (pop ^args^)))
(setf (slot-value self slot) value))))))
(defparameter *minimum-shell-width* 400) (defparameter *minimum-shell-width* 400)
(defparameter *shell-background-color* "gray20") (defparameter *shell-background-color* "gray20")
...@@ -4655,6 +4621,86 @@ supported compiler. ...@@ -4655,6 +4621,86 @@ supported compiler.
* System menu and commands * System menu and commands
** Dialog box builder
#+begin_src lisp commands.lisp
(defmacro define-dialog (name arglist &body body)
`(progn
(defun ,(action-name name) (&key arglist) ,@body)
(export ',(action-name name))
(defun ,(show-name name) (&rest args)
(show-dialog (apply #'make-instance ',(dialog-class-name name) args)
,(command-name-string name)))
(export ',(show-name name))
(define-visual-macro ,(dialog-class-name name)
(:super phrase
:slots ((orientation :initform :vertical))
:inputs ,(command-inputs name arglist)))
(export ',(dialog-class-name name))
(defmethod evaluate ((self ,(dialog-class-name name)))
;; call the command function
(apply #'funcall #',(action-name 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-command-dialog (name arglist &body body)
`(define-dialog ,name ,arglist
(labels ((arg (name) (getf ^args^ name)))
,@body)))
(defclass property-sheet (phrase)
((orientation :initform :vertical)
(instance :initform nil :initarg :instance :accessor instance)
(properties :initform nil :initarg :properties :accessor properties)))
(defmethod initialize-instance :after ((sheet property-sheet) &key)
(with-slots (inputs properties instance) sheet
(dolist (property properties)
(let ((row (make-sentence
(list
(make-instance 'symbol-entry
:value property
:read-only t)
(make-instance 'expression-entry
:value (slot-value instance property)
:read-only nil)))))
(push row inputs)))
(setf inputs (nreverse inputs))
(update-parent-links sheet)
(freeze sheet)))
(defmethod get-property-list ((sheet property-sheet))
(mapcar #'evaluate
(mapcan #'identity
(mapcar #'inputs
(inputs (first (inputs sheet)))))))
(defmethod apply-properties ((sheet property-sheet) instance)
(let ((plist (get-property-list sheet)))
(loop while plist do
(let* ((slot (pop plist))
(value (pop plist)))
(setf (slot-value instance slot) value)))))
(defmethod evaluate ((sheet property-sheet))
(apply-properties sheet (instance sheet)))
(defvar *instance* nil)
(defmacro define-properties-dialog (name slot-names &rest body)
`(progn
(defun ,(show-name name) (&optional (instance *instance*))
(show-dialog (apply #'make-instance ',(dialog-class-name name) :instance instance)
,(command-name-string name)))
(defclass ,(dialog-class-name name) (property-sheet)
((properties :initform ',slot-names)))))
#+end_src
** System object ** System object
#+begin_src lisp :tangle commands.lisp #+begin_src lisp :tangle commands.lisp
...@@ -4740,29 +4786,27 @@ supported compiler. ...@@ -4740,29 +4786,27 @@ supported compiler.
** User dialogs ** User dialogs
#+begin_src lisp :tangle commands.lisp #+begin_src lisp :tangle commands.lisp
(define-command-dialog rename-buffer (define-dialog rename-buffer
((new-name (slot-value (current-buffer) 'buffer-name))) ((new-name (slot-value (current-buffer) 'buffer-name)))
(rename (current-buffer) (arg 'new-name))) (rename (current-buffer) new-name))
(define-command-dialog resize-buffer (define-dialog resize-buffer
((width (slot-value (current-buffer) 'width)) ((width (slot-value (current-buffer) 'width))
(height (slot-value (current-buffer) 'height))) (height (slot-value (current-buffer) 'height)))
(resize (current-buffer) (resize (current-buffer) width height))
(arg 'width)
(arg 'height)))
(define-command-dialog visit-buffer (define-dialog visit-buffer
((buffer-name (or (first *buffer-history*) ((buffer-name (or (first *buffer-history*)
(buffer-name (current-buffer))))) (buffer-name (current-buffer)))))
(switch-to-buffer (arg 'buffer-name))) (switch-to-buffer buffer-name))
(define-command-dialog create-buffer (define-dialog create-buffer
((buffer-name (uniquify-buffer-name "*untitled-buffer*"))) ((buffer-name (uniquify-buffer-name "*untitled-buffer*")))
(switch-to-buffer (make-instance 'buffer :name (arg 'buffer-name)))) (switch-to-buffer (make-instance 'buffer :name buffer-name)))
(define-command-dialog paste-as-new-buffer (define-dialog paste-as-new-buffer
((buffer-name (uniquify-buffer-name "*pasted-buffer*"))) ((buffer-name (uniquify-buffer-name "*pasted-buffer*")))
(switch-to-buffer (make-instance 'buffer :name (arg 'buffer-name))) (switch-to-buffer (make-instance 'buffer :name buffer-name))
(paste (current-buffer)) (paste (current-buffer))
(trim (current-buffer))) (trim (current-buffer)))
...@@ -4772,7 +4816,6 @@ supported compiler. ...@@ -4772,7 +4816,6 @@ supported compiler.
(with-slots (height width name) self (with-slots (height width name) self
(resize self height width) (resize self height width)
(rename self name))) (rename self name)))
#+end_src #+end_src
** Menu bar structure ** Menu bar structure
......
...@@ -115,8 +115,47 @@ ...@@ -115,8 +115,47 @@
(draw-line x y (+ x width) y :color "gray50"))) (draw-line x y (+ x width) y :color "gray50")))
;; Modeline:1 ends here ;; Modeline:1 ends here
;; Shell prompt ;; Interactive dialog box tools
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Interactive%20dialog%20box%20tools][Interactive dialog box tools:1]]
(defun 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))
(defun command-inputs (name arglist)
`(list;;(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)))))
(defun command-name-string (thing)
(let ((name (etypecase thing
(symbol (symbol-name thing))
(string thing))))
(coerce
(string-capitalize
(substitute #\Space #\-
(string-trim " " name)))
'simple-string)))
(defun command-argument-string (thing)
(concatenate 'string (command-name-string thing) ": "))
(defun action-name (name)
(intern (concatenate 'string (symbol-name name) "-ACTION")))
(defun show-name (name)
(intern (concatenate 'string "SHOW-" (symbol-name name) "-DIALOG")))
(defun dialog-class-name (name)
(intern (concatenate 'string (symbol-name name) "-DIALOG")))
;; Interactive dialog box tools:1 ends here
;; Shell prompt
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Shell%20prompt][Shell prompt:1]] ;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Shell%20prompt][Shell prompt:1]]
(defclass shell-prompt (entry) (defclass shell-prompt (entry)
...@@ -154,81 +193,7 @@ ...@@ -154,81 +193,7 @@
;; (bind-event self '(:escape) 'close-shell)) ;; (bind-event self '(:escape) 'close-shell))
;; Shell prompt:1 ends here ;; Shell prompt:1 ends here
;; Interactive dialog boxes ;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Shell%20prompt][Shell prompt:2]]
;; [[file:~/quicklisp/local-projects/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")))
(dialog-class-name () (intern (concatenate 'string (symbol-name name) "-DIALOG"))))
,@body))
(defvar *instance* nil)
(defmacro define-dialog (name arglist &body body)
(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 *instance* :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-command-dialog (name arglist &body body)
`(define-dialog ,name ,arglist
(labels ((arg (name) (getf ^args^ name)))
,@body)))
(defmacro define-properties-dialog (name slots &body body)
(labels ((place-form (slot) `(slot-value ,instance ',slot))
(init-form (slot) `(,slot ,(place-form slot)))
(setf-form (slot value) `(setf ,(place-form slot) ,value)))
`(define-dialog ,name ,(mapcar #'init-form slots)
(loop while ^args^ do
(let ((slot (pop ^args^))
(value (pop ^args^)))
(setf (slot-value self slot) value))))))
(defparameter *minimum-shell-width* 400) (defparameter *minimum-shell-width* 400)
(defparameter *shell-background-color* "gray20") (defparameter *shell-background-color* "gray20")
...@@ -267,4 +232,4 @@ ...@@ -267,4 +232,4 @@
(defun create-shell-maybe () (defun create-shell-maybe ()
(when (null *shell*) (when (null *shell*)
(setf *shell* (make-instance 'shell)))) (setf *shell* (make-instance 'shell))))
;; Interactive dialog boxes:1 ends here ;; Shell prompt:2 ends here
...@@ -3,8 +3,10 @@ ...@@ -3,8 +3,10 @@
** DONE redesign system menu ** DONE redesign system menu
CLOSED: [2017-04-18 Tue 19:34] CLOSED: [2017-04-18 Tue 19:34]
** TODO fix ugly dialog boxes ** TODO fix ugly dialog boxes
*** TODO remove old titlebar
*** TODO define-properties-dialog *** TODO define-properties-dialog
*** TODO improve layout of properties dialog
*** DONE remove old titlebar
CLOSED: [2017-04-19 Wed 09:58]
*** TODO [#B] add nice Apply/Cancel buttons *** TODO [#B] add nice Apply/Cancel buttons
** TODO make master system menu todo list ** TODO make master system menu todo list
*** TODO save-changes *** TODO save-changes
......
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