/[mcclim]/mcclim/frames.lisp
ViewVC logotype

Diff of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.114 by tmoore, Fri Mar 10 21:58:12 2006 UTC revision 1.115 by tmoore, Sun Mar 12 23:09:27 2006 UTC
# Line 1566  documentation produced by presentations. Line 1566  documentation produced by presentations.
1566                  (buffer-rectangle))                  (buffer-rectangle))
1567               (stream-replay stream buffer-rectangle))))))))               (stream-replay stream buffer-rectangle))))))))
1568    
1569  (defgeneric frame-drag-and-drop-highlighting (frame to-presentation state))  (defgeneric frame-drag-and-drop-highlighting
1570        (frame to-presentation stream state))
1571    
1572  (defmethod frame-drag-and-drop-highlighting  (defmethod frame-drag-and-drop-highlighting
1573      ((frame standard-application-frame) to-presentation state)      ((frame standard-application-frame) to-presentation stream state)
1574    )    (highlight-presentation-1 to-presentation stream state))
1575    
1576  (defun frame-drag-and-drop (translator-name command-table object presentation  (defun frame-drag-and-drop (translator-name command-table
1577                              context-type frame event window x y)                              from-presentation context-type frame event window
1578    (let* ((translators (mapcan (lambda (trans)                              x y)
1579      (declare (ignore command-table))
1580      (let* ((*dragged-presentation* from-presentation)
1581             (*dragged-object* (presentation-object from-presentation))
1582             (translators (mapcan (lambda (trans)
1583                                  (and (typep trans 'drag-n-drop-translator)                                  (and (typep trans 'drag-n-drop-translator)
1584                                       (test-presentation-translator                                       (funcall (tester trans)
1585                                        trans presentation context-type frame                                                (presentation-object
1586                                        window x y :event event)))                                                 from-presentation)
1587                                                  :presentation from-presentation
1588                                                  :context-type context-type
1589                                                  :frame frame
1590                                                  :window window
1591                                                  :x x
1592                                                  :y y
1593                                                  :event event)))
1594                                (find-presentation-translators                                (find-presentation-translators
1595                                 (presentation-type presentation)                                 (presentation-type from-presentation)
1596                                 context-type                                 context-type
1597                                 (frame-command-table frame))))                                 (frame-command-table frame))))
1598             ;; Try to run the feedback and highlight functions of the translator
1599             ;; that got us here.
1600           (translator (or (find translator-name translators :key #'name)           (translator (or (find translator-name translators :key #'name)
1601                           (car translators)))                           (car translators)))
1602           (tester (tester translator))           (initial-feedback-fn (feedback translator))
1603           (drag-type (from-type translator))           (initial-hilite-fn (highlighting translator))
1604           (feedback-fn (feedback translator))           (destination-presentation nil)
1605           (hilite-fn (highlighting translator))           (initial-x x)
1606           (drag-context (make-fake-input-context drag-c-type))           (initial-y y)
1607           (*dragged-object* object)           (last-presentation nil)
1608           (destination-object nil))           (feedback-activated nil)
1609      (multiple-value-bind (x0 y0)           (feedback-fn initial-feedback-fn)
1610          (stream-pointer-position window)           (hilite-fn initial-hilite-fn)
1611        (funcall feedback-fn *application-frame* object window           (last-event nil))
1612                 x0 y0 x0 y0 :highlight)      ;; We shouldn't need to use find-innermost-presentation-match
1613        (tracking-pointer (window :context-type `(or ,(mapcar #'from-type      ;; This repeats what tracking-pointer has already done, but what are you
1614                                                              translators))      ;; gonna do?
1615                                  :highlight nil)      (flet ((find-dest-translator (presentation window x y)
1616          (:presentation (&key presentation event x y)               (loop for translator in translators
1617           )                     when (and (presentation-subtypep
1618          (:pointer-motion (&key event x y)                                (presentation-type presentation)
1619            (multiple-value-bind (presentation translator)                                (destination-ptype translator))
1620                (find-innermost-presentation-match drag-context window                               (test-presentation-translator translator
1621                                                   x y :event event)))                                                             presentation
1622          (:presentation-button-press (&key presentation x y))                                                             context-type frame
1623          (:presentation-button-release (&key presentation x y))                                                             window x y))
1624          (:button-press (&key x y))                     do (return-from find-dest-translator translator))
1625          (:button-release (&key x y))))))               nil)
1626               (do-feedback (window x y state do-it)
1627                 (when do-it
1628                   (funcall feedback-fn frame from-presentation window
1629                            initial-x initial-y x y state)))
1630               (do-hilite (presentation window state)
1631                 (when presentation
1632                   (funcall hilite-fn frame presentation window state)))
1633               (last-window ()
1634                 (event-sheet last-event))
1635               (last-x ()
1636                 (pointer-event-x last-event))
1637               (last-y ()
1638                 (pointer-event-y last-event)))
1639          ;; :highlight nil will cause the presentation that is the source of the
1640          ;; dragged object to be unhighlighted initially.
1641          (block do-tracking
1642            (tracking-pointer (window :context-type `(or ,(mapcar #'from-type
1643                                                                  translators))
1644                                      :highlight nil
1645                                      :multiple-window t)
1646              (:presentation (&key presentation window event x y)
1647                (let ((dest-translator (find-dest-translator presentation window
1648                                                             x y)))
1649                  (do-feedback (last-window) (last-x) (last-y)
1650                               :unhighlight feedback-activated)
1651                  (setq feedback-activated t
1652                        last-event event)
1653                  (do-hilite last-presentation (last-window) :unhighlight)
1654                  (setq last-presentation presentation
1655                        feedback-fn (feedback dest-translator)
1656                        hilite-fn (highlighting dest-translator))
1657                  (do-hilite presentation window :highlight)
1658                  (do-feedback window x y :highlight t)
1659                  (document-drag-n-drop dest-translator presentation
1660                                        context-type frame event window
1661                                        x y)))
1662              (:pointer-motion (&key event window x y)
1663                (do-feedback (last-window) (last-x) (last-y)
1664                             :unhighlight feedback-activated)
1665                (setq feedback-activated t
1666                      last-event event)
1667                (do-hilite last-presentation (last-window) :unhighlight)
1668                (setq last-presentation nil)
1669                (do-feedback window x y :highlight t)
1670                (document-drag-n-drop translator nil
1671                                      context-type frame event window
1672                                      x y))
1673              ;; XXX only support finish-on-release for now.
1674              #-(and)(:presentation-button-press ())
1675              (:presentation-button-release (&key presentation event)
1676                (setq destination-presentation presentation
1677                      last-event event)
1678                (return-from do-tracking nil))
1679              #-(and)(:button-press ())
1680              (:button-release (&key event)
1681                (setq last-event event)
1682                (return-from do-tracking nil))))
1683          ;;
1684          ;; XXX Assumes x y from :button-release are the same as for the preceding
1685          ;; button-motion; is that correct?
1686          (do-feedback (last-window) (last-x) (last-y)
1687                       :unhighlight feedback-activated)
1688          (do-hilite last-presentation (last-window) :unhighlight)
1689          (if destination-presentation
1690              (let ((final-translator (find-dest-translator destination-presentation
1691                                                            (last-window)
1692                                                            (last-x)
1693                                                            (last-y))))
1694                (if final-translator
1695                    (funcall (destination-translator final-translator)
1696                             *dragged-object*
1697                             :presentation *dragged-presentation*
1698                             :destination-object (presentation-object
1699                                                  destination-presentation)
1700                             :destination-presentation destination-presentation
1701                             :context-type context-type
1702                             :frame frame
1703                             :event event
1704                             :window window
1705                             :x x
1706                             :y y)
1707                    (values nil nil)))
1708              (values nil nil)))))
1709    
1710    (defun document-drag-n-drop
1711        (translator presentation context-type frame event window x y)
1712      (when *pointer-documentation-output*
1713        (let ((s *pointer-documentation-output*))
1714          (window-clear s)
1715          (with-end-of-page-action (s :allow)
1716            (with-end-of-line-action (s :allow)
1717              (document-presentation-translator translator
1718                                                presentation
1719                                                context-type
1720                                                frame
1721                                                event
1722                                                window
1723                                                x y
1724                                                :stream s
1725                                                :documentation-type :pointer))))))
1726    
1727    

Legend:
Removed from v.1.114  
changed lines
  Added in v.1.115

  ViewVC Help
Powered by ViewVC 1.1.5