Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8927

Modified Files: frames.lisp presentation-defs.lisp presentations.lisp Log Message: drag-and-drop, not quite working yet

--- /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/10 21:58:12 1.114 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/12 23:09:27 1.115 @@ -1566,46 +1566,162 @@ (buffer-rectangle)) (stream-replay stream buffer-rectangle))))))))

-(defgeneric frame-drag-and-drop-highlighting (frame to-presentation state)) +(defgeneric frame-drag-and-drop-highlighting + (frame to-presentation stream state))

(defmethod frame-drag-and-drop-highlighting - ((frame standard-application-frame) to-presentation state) - ) + ((frame standard-application-frame) to-presentation stream state) + (highlight-presentation-1 to-presentation stream state))

-(defun frame-drag-and-drop (translator-name command-table object presentation - context-type frame event window x y) - (let* ((translators (mapcan (lambda (trans) +(defun frame-drag-and-drop (translator-name command-table + from-presentation context-type frame event window + x y) + (declare (ignore command-table)) + (let* ((*dragged-presentation* from-presentation) + (*dragged-object* (presentation-object from-presentation)) + (translators (mapcan (lambda (trans) (and (typep trans 'drag-n-drop-translator) - (test-presentation-translator - trans presentation context-type frame - window x y :event event))) + (funcall (tester trans) + (presentation-object + from-presentation) + :presentation from-presentation + :context-type context-type + :frame frame + :window window + :x x + :y y + :event event))) (find-presentation-translators - (presentation-type presentation) + (presentation-type from-presentation) context-type (frame-command-table frame)))) + ;; Try to run the feedback and highlight functions of the translator + ;; that got us here. (translator (or (find translator-name translators :key #'name) (car translators))) - (tester (tester translator)) - (drag-type (from-type translator)) - (feedback-fn (feedback translator)) - (hilite-fn (highlighting translator)) - (drag-context (make-fake-input-context drag-c-type)) - (*dragged-object* object) - (destination-object nil)) - (multiple-value-bind (x0 y0) - (stream-pointer-position window) - (funcall feedback-fn *application-frame* object window - x0 y0 x0 y0 :highlight) - (tracking-pointer (window :context-type `(or ,(mapcar #'from-type - translators)) - :highlight nil) - (:presentation (&key presentation event x y) - ) - (:pointer-motion (&key event x y) - (multiple-value-bind (presentation translator) - (find-innermost-presentation-match drag-context window - x y :event event))) - (:presentation-button-press (&key presentation x y)) - (:presentation-button-release (&key presentation x y)) - (:button-press (&key x y)) - (:button-release (&key x y)))))) + (initial-feedback-fn (feedback translator)) + (initial-hilite-fn (highlighting translator)) + (destination-presentation nil) + (initial-x x) + (initial-y y) + (last-presentation nil) + (feedback-activated nil) + (feedback-fn initial-feedback-fn) + (hilite-fn initial-hilite-fn) + (last-event nil)) + ;; We shouldn't need to use find-innermost-presentation-match + ;; This repeats what tracking-pointer has already done, but what are you + ;; gonna do? + (flet ((find-dest-translator (presentation window x y) + (loop for translator in translators + when (and (presentation-subtypep + (presentation-type presentation) + (destination-ptype translator)) + (test-presentation-translator translator + presentation + context-type frame + window x y)) + do (return-from find-dest-translator translator)) + nil) + (do-feedback (window x y state do-it) + (when do-it + (funcall feedback-fn frame from-presentation window + initial-x initial-y x y state))) + (do-hilite (presentation window state) + (when presentation + (funcall hilite-fn frame presentation window state))) + (last-window () + (event-sheet last-event)) + (last-x () + (pointer-event-x last-event)) + (last-y () + (pointer-event-y last-event))) + ;; :highlight nil will cause the presentation that is the source of the + ;; dragged object to be unhighlighted initially. + (block do-tracking + (tracking-pointer (window :context-type `(or ,(mapcar #'from-type + translators)) + :highlight nil + :multiple-window t) + (:presentation (&key presentation window event x y) + (let ((dest-translator (find-dest-translator presentation window + x y))) + (do-feedback (last-window) (last-x) (last-y) + :unhighlight feedback-activated) + (setq feedback-activated t + last-event event) + (do-hilite last-presentation (last-window) :unhighlight) + (setq last-presentation presentation + feedback-fn (feedback dest-translator) + hilite-fn (highlighting dest-translator)) + (do-hilite presentation window :highlight) + (do-feedback window x y :highlight t) + (document-drag-n-drop dest-translator presentation + context-type frame event window + x y))) + (:pointer-motion (&key event window x y) + (do-feedback (last-window) (last-x) (last-y) + :unhighlight feedback-activated) + (setq feedback-activated t + last-event event) + (do-hilite last-presentation (last-window) :unhighlight) + (setq last-presentation nil) + (do-feedback window x y :highlight t) + (document-drag-n-drop translator nil + context-type frame event window + x y)) + ;; XXX only support finish-on-release for now. + #-(and)(:presentation-button-press ()) + (:presentation-button-release (&key presentation event) + (setq destination-presentation presentation + last-event event) + (return-from do-tracking nil)) + #-(and)(:button-press ()) + (:button-release (&key event) + (setq last-event event) + (return-from do-tracking nil)))) + ;; + ;; XXX Assumes x y from :button-release are the same as for the preceding + ;; button-motion; is that correct? + (do-feedback (last-window) (last-x) (last-y) + :unhighlight feedback-activated) + (do-hilite last-presentation (last-window) :unhighlight) + (if destination-presentation + (let ((final-translator (find-dest-translator destination-presentation + (last-window) + (last-x) + (last-y)))) + (if final-translator + (funcall (destination-translator final-translator) + *dragged-object* + :presentation *dragged-presentation* + :destination-object (presentation-object + destination-presentation) + :destination-presentation destination-presentation + :context-type context-type + :frame frame + :event event + :window window + :x x + :y y) + (values nil nil))) + (values nil nil))))) + +(defun document-drag-n-drop + (translator presentation context-type frame event window x y) + (when *pointer-documentation-output* + (let ((s *pointer-documentation-output*)) + (window-clear s) + (with-end-of-page-action (s :allow) + (with-end-of-line-action (s :allow) + (document-presentation-translator translator + presentation + context-type + frame + event + window + x y + :stream s + :documentation-type :pointer)))))) + + --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/03/10 21:58:13 1.51 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/03/12 23:09:27 1.52 @@ -2002,30 +2002,44 @@ (destination-translator :reader destination-translator :initarg :destination-translator)))

+ +(defvar *dragged-presentation* nil + "Bound to the presentation dragged in a drag-and-drop context") (defvar *dragged-object* nil "Bound to the object dragged in a drag-and-drop context")

+() ;;; According to the Franz User's guide, the destination object is ;;; available in the tester, documentation, and translator function ;;; as destination-object. Therefore OBJECT is the dragged object. In ;;; our scheme the tester function, translator function etc. is ;;; really called on the destination object. So, we do a little -;;; shuffling of arguments here. +;;; shuffling of arguments here. We don't do that for the destination +;;; translator because we can call that ourselves in frame-drag-and-drop. +;;; +;;; Also, in Classic CLIM the destination presentation is passed as a +;;; destination-presentation keyword argument; hence the presentation argument +;;; is the dragged presentation.

(defmethod initialize-instance :after ((obj drag-n-drop-translator) - &key tester documentation + &key documentation pointer-documentation - translator-function) + destination-translator) + ;; This is starting to smell... (flet ((make-adapter (func) - (lambda (object &rest args) - (apply func *dragged-object* :destination-object object args)))) - (setf (slot-value obj 'tester) (make-adapter tester)) + (lambda (object &rest args &key presentation &allow-other-keys) + (if *dragged-presentation* + (apply func + *dragged-object* + :presentation *dragged-presentation* + :destination-object object + :destination-presentation presentation + args) + (apply func object args))))) (setf (slot-value obj 'documentation) (make-adapter documentation)) (when pointer-documentation (setf (slot-value obj 'pointer-documentation) - (make-adapter pointer-documentation))) - (setf (slot-value obj 'translator-function) - (make-adapter translator-function)))) + (make-adapter pointer-documentation)))))

(defmacro define-drag-and-drop-translator (name (from-type to-type destination-type command-table @@ -2048,17 +2062,14 @@ (with-keywords-removed (args (:feedback :highlighting)) `(progn (define-presentation-translator ,name - (,from-type ,to-type + (,from-type ,to-type ,command-table ,@args :feedback #',feedback :highlighting #',highlighting :destination-ptype ',real-dest-type :destination-translator #',(make-translator-fun arglist body) :translator-class drag-n-drop-translator) - (object presentation context-type frame event window x y) - (frame-drag-and-drop ',name ',command-table object + (presentation context-type frame event window x y) + (frame-drag-and-drop ',name ',command-table presentation context-type frame event window x y))))))

- - - --- /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/10 21:58:13 1.72 +++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/03/12 23:09:27 1.73 @@ -1497,17 +1497,20 @@ (defmethod call-presentation-translator ((translator presentation-translator) presentation context-type frame event window x y) - (multiple-value-bind (object ptype options) - (funcall (translator-function translator) - (presentation-object presentation) - :presentation presentation - :context-type context-type - :frame frame - :event event - :window window - :x x - :y y) - (values object (or ptype context-type) options))) + ;; Let the translator return an explict ptype of nil to, in effect, abort the + ;; presentation throw. + (multiple-value-call + #'(lambda (object &optional (ptype context-type) options) + (values object ptype options)) + (funcall (translator-function translator) + (presentation-object presentation) + :presentation presentation + :context-type context-type + :frame frame + :event event + :window window + :x x + :y y)))

(defmethod call-presentation-translator ((translator presentation-action) presentation context-type