Commit 3cd85d48 authored by David O'Toole's avatar David O'Toole

paste-as-new-buffer-dialog works

parent a9a84f41
......@@ -212,7 +212,7 @@
(defmacro define-dialog (name arglist &body body)
`(progn
(defun ,(action-name name) (&key arglist) ,@body)
(defun ,(action-name name) (&key ,@(mapcar #'car arglist)) ,@body)
(export ',(action-name name))
(defun ,(show-name name) (&rest args)
(show-dialog (apply #'make-instance ',(dialog-class-name name) args)
......@@ -442,13 +442,17 @@
(define-dialog create-buffer
((buffer-name (uniquify-buffer-name "*untitled-buffer*")))
(switch-to-buffer (make-instance 'buffer :name buffer-name)))
(switch-to-buffer (make-instance 'buffer :buffer-name buffer-name)))
(define-dialog paste-as-new-buffer
((buffer-name (uniquify-buffer-name "*pasted-buffer*")))
(switch-to-buffer (make-instance 'buffer :name buffer-name))
(paste (current-buffer))
(trim (current-buffer)))
((buffer-name (uniquify-buffer-name "*pasted-buffer*"))
(offset-x 0)
(offset-y 0))
(at-next-update
(add-buffer buffer-name (make-instance 'buffer))
(switch-to-buffer buffer-name)
(paste (current-buffer))
(trim-conservatively (current-buffer))))
(define-properties-dialog buffer-properties
(buffer-name width height z-sort-p background-image background-color
......@@ -844,11 +848,14 @@
(push (make-method-menu-item self method (uuid self)) inputs))
(flet ((menu-item (args)
(make-menu args :target self)))
(let ((menu (make-instance 'context-menu
:inputs (mapcar #'menu-item (nreverse inputs))
:pinned nil
:expanded t
:locked t)))
(prog1 menu
(bring-to-front menu)))))))
(make-instance 'context-menu
:inputs (mapcar #'menu-item (nreverse inputs))
:pinned nil
:expanded t
:locked t)))))
(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")))
;; Context menus:1 ends here
......@@ -78,8 +78,7 @@
;; [[file:~/quicklisp/local-projects/xelf/gui.org::*Initialization][Initialization:1]]
(defmethod initialize-instance :after ((self buffer) &key name)
(when name (setf (slot-value self 'name) name))
(defmethod initialize-instance :after ((self buffer) &key)
(with-shell
(bind-event self '(:f1) 'show-help-command)
(bind-event self '(:h :control) 'show-help-command)
......@@ -703,6 +702,14 @@
(with-slots (x y) object
(with-quadtree quadtree
(move-to object (- x left) (- y top)))))))))))
(defmethod trim-conservatively ((self buffer))
(prog1 self
(let ((objects (get-nodes self)))
(when objects
(multiple-value-bind (top left right bottom)
(find-bounding-box objects)
(resize self right bottom))))))
;; Trimming empty space:1 ends here
;; Copy, cut, and paste
......@@ -1711,7 +1718,8 @@ See sidebar for more commands to try.
(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)))
(move-to menu x y)
(bring-to-front menu)))
;;; Dropping things down into the object layer
......@@ -2620,7 +2628,7 @@ See sidebar for more commands to try.
(- x1 radius) (+ y0 diameter)
fill)
(line (+ x0 radius) (+ y0 0)
(- x1 radius -4) (+ y0 1) bevel)
(- x1 radius -2) (+ y0 1) bevel)
;; left
(box x0 (+ y0 radius)
(+ x0 diameter) (- y1 radius)
......@@ -4245,7 +4253,7 @@ See sidebar for more commands to try.
text
(if (or (functionp action)
(null action)
(xelfp action)
(typep action (find-class 'task))
(and (functionp action)
(fboundp action)))
"gray80"
......@@ -4267,7 +4275,7 @@ See sidebar for more commands to try.
(defmethod layout :after ((self menu))
(with-slots (width height expanded) self
(when expanded
(incf width 20)
(incf width 45)
(incf height 10)
(mapc #'layout (inputs self)))))
......
......@@ -129,8 +129,7 @@ every BUFFER is also a NODE.)
** Initialization
#+begin_src lisp
(defmethod initialize-instance :after ((self buffer) &key name)
(when name (setf (slot-value self 'name) name))
(defmethod initialize-instance :after ((self buffer) &key)
(with-shell
(bind-event self '(:f1) 'show-help-command)
(bind-event self '(:h :control) 'show-help-command)
......@@ -732,8 +731,18 @@ This section is obsolete and will be removed in the future.
(with-slots (x y) object
(with-quadtree quadtree
(move-to object (- x left) (- y top)))))))))))
(defmethod trim-conservatively ((self buffer))
(prog1 self
(let ((objects (get-nodes self)))
(when objects
(multiple-value-bind (top left right bottom)
(find-bounding-box objects)
(resize self right bottom))))))
#+end_src
** Copy, cut, and paste
#+begin_src lisp
......@@ -1727,7 +1736,8 @@ above.
(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)))
(move-to menu x y)
(bring-to-front menu)))
;;; Dropping things down into the object layer
......@@ -2631,7 +2641,7 @@ hybrid GUI inspired by MIT Scratch and its derivatives.
(- x1 radius) (+ y0 diameter)
fill)
(line (+ x0 radius) (+ y0 0)
(- x1 radius -4) (+ y0 1) bevel)
(- x1 radius -2) (+ y0 1) bevel)
;; left
(box x0 (+ y0 radius)
(+ x0 diameter) (- y1 radius)
......@@ -4253,7 +4263,7 @@ supported compiler.
text
(if (or (functionp action)
(null action)
(xelfp action)
(typep action (find-class 'task))
(and (functionp action)
(fboundp action)))
"gray80"
......@@ -4275,7 +4285,7 @@ supported compiler.
(defmethod layout :after ((self menu))
(with-slots (width height expanded) self
(when expanded
(incf width 20)
(incf width 45)
(incf height 10)
(mapc #'layout (inputs self)))))
......@@ -4414,12 +4424,12 @@ supported compiler.
(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))))
(make-instance 'pretty-symbol-entry :value ,(make-keyword (first f)) :read-only t)
(make-instance 'property-value-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")))
`(;;(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)))))
......@@ -4739,7 +4749,7 @@ supported compiler.
(defmacro define-dialog (name arglist &body body)
`(progn
(defun ,(action-name name) (&key arglist) ,@body)
(defun ,(action-name name) (&key ,@(mapcar #'car arglist)) ,@body)
(export ',(action-name name))
(defun ,(show-name name) (&rest args)
(show-dialog (apply #'make-instance ',(dialog-class-name name) args)
......@@ -4967,13 +4977,17 @@ supported compiler.
(define-dialog create-buffer
((buffer-name (uniquify-buffer-name "*untitled-buffer*")))
(switch-to-buffer (make-instance 'buffer :name buffer-name)))
(switch-to-buffer (make-instance 'buffer :buffer-name buffer-name)))
(define-dialog paste-as-new-buffer
((buffer-name (uniquify-buffer-name "*pasted-buffer*")))
(switch-to-buffer (make-instance 'buffer :name buffer-name))
(paste (current-buffer))
(trim (current-buffer)))
((buffer-name (uniquify-buffer-name "*pasted-buffer*"))
(offset-x 0)
(offset-y 0))
(at-next-update
(add-buffer buffer-name (make-instance 'buffer))
(switch-to-buffer buffer-name)
(paste (current-buffer))
(trim-conservatively (current-buffer))))
(define-properties-dialog buffer-properties
(buffer-name width height z-sort-p background-image background-color
......@@ -4985,7 +4999,6 @@ supported compiler.
(with-slots (height width buffer-name) buffer
(resize buffer width height)
(rename-buffer buffer buffer-name))))
#+end_src
** Menu bar structure
......@@ -5368,14 +5381,16 @@ supported compiler.
(push (make-method-menu-item self method (uuid self)) inputs))
(flet ((menu-item (args)
(make-menu args :target self)))
(let ((menu (make-instance 'context-menu
:inputs (mapcar #'menu-item (nreverse inputs))
:pinned nil
:expanded t
:locked t)))
(prog1 menu
(bring-to-front menu)))))))
(make-instance 'context-menu
:inputs (mapcar #'menu-item (nreverse inputs))
:pinned nil
:expanded t
:locked t)))))
(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")))
#+end_src
* TODO Emacs live integration :experimental:
......
......@@ -125,12 +125,12 @@
(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))))
(make-instance 'pretty-symbol-entry :value ,(make-keyword (first f)) :read-only t)
(make-instance 'property-value-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")))
`(;;(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)))))
......
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