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

Diff of /mcclim/frames.lisp

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

revision 1.104 by tmoore, Tue Jan 11 13:14:18 2005 UTC revision 1.105 by tmoore, Wed Feb 2 11:33:58 2005 UTC
# Line 1394  frame, if any") Line 1394  frame, if any")
1394    (frob pointer-button-press-event presentation-button-press-handler)    (frob pointer-button-press-event presentation-button-press-handler)
1395    (frob pointer-button-release-event presentation-button-release-handler))    (frob pointer-button-release-event presentation-button-release-handler))
1396    
1397    (defun make-drag-bounding (old-highlighting new-highlighting
1398                               old-presentation new-presentation)
1399      (let (x1 y1 x2 y2)
1400        (flet ((union-with-bounds (rect)
1401                 (cond ((null rect)
1402                        nil)
1403                       ((null x1)
1404                        (setf (values x1 y1 x2 y2) (bounding-rectangle* rect)))
1405                       (t (with-bounding-rectangle* (r-x1 r-y1 r-x2 r-y2)
1406                              rect
1407                            (setf (values x1 y1 x2 y2)
1408                                  (bound-rectangles x1 y1 x2 y2
1409                                                    r-x1 r-y1 r-x2 r-y2)))))))
1410          (union-with-bounds old-highlighting)
1411          (union-with-bounds new-highlighting)
1412          (union-with-bounds old-presentation)
1413          (union-with-bounds new-presentation)
1414          (values x1 y1 x2 y2))))
1415    
1416    (defun make-drag-and-drop-feedback-function (from-presentation)
1417      (multiple-value-bind (record-x record-y)
1418          (output-record-position from-presentation)
1419        (let ((current-to-presentation nil)
1420              (current-from-higlighting nil))
1421          (lambda (frame from-presentation to-presentation initial-x initial-y
1422                   x y event)
1423            (let ((dx (- record-x initial-x))
1424                  (dy (- record-y initial-y)))
1425              (typecase event
1426                (null
1427                 ())))))))
1428    
1429  (defun frame-drag (translator-name command-table object presentation  (defun frame-drag (translator-name command-table object presentation
1430                     context-type frame event window x y)                     context-type frame event window x y)
# Line 1416  frame, if any") Line 1447  frame, if any")
1447        (tracking-pointer (window :context-type drag-c-type :highlight nil)        (tracking-pointer (window :context-type drag-c-type :highlight nil)
1448         (:pointer-motion (&key event x y)         (:pointer-motion (&key event x y)
1449           (multiple-value-bind (presentation translator)           (multiple-value-bind (presentation translator)
1450               (find-innermost-presentation-context drag-context window               (find-innermost-presentation-match drag-context window
1451                     x y :event event)))))))                                                  x y :event event)))))))

Legend:
Removed from v.1.104  
changed lines
  Added in v.1.105

  ViewVC Help
Powered by ViewVC 1.1.5