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

Diff of /mcclim/frames.lisp

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

revision 1.103 by hefner1, Fri Nov 12 06:38:50 2004 UTC revision 1.104 by tmoore, Tue Jan 11 13:14:18 2005 UTC
# Line 1337  frame, if any") Line 1337  frame, if any")
1337                                      (cdr hilited)                                      (cdr hilited)
1338                                      :unhighlight)))))                                      :unhighlight)))))
1339    
1340    ;;; Poor man's find-applicable-translators. tracking-pointer doesn't want to
1341    ;;; see any results from presentation translators.
1342    
1343    (defun highlight-for-tracking-pointer (frame stream x y input-context)
1344      (let ((context-ptype (input-context-type (car input-context)))
1345            (presentation nil)
1346            (current-hilited (frame-hilited-presentation frame)))
1347        (if (output-recording-stream-p stream)
1348            (progn
1349              (block found-presentation
1350                (flet ((do-presentation (p)
1351                         (when (presentation-subtypep (presentation-type p)
1352                                                      context-ptype)
1353                           (setq presentation p)
1354                           (return-from found-presentation nil))))
1355                  (declare (dynamic-extent #'do-presentation))
1356                  (map-over-presentations-containing-position
1357                   #'do-presentation (stream-output-history stream) x y)))
1358              (when (and current-hilited
1359                         (not (eq (car current-hilited) presentation)))
1360                (highlight-presentation-1 (car current-hilited)
1361                                          (cdr current-hilited)
1362                                          :unhighlight))
1363              (if presentation
1364                  (progn
1365                    (setf (frame-hilited-presentation frame)
1366                          (cons presentation stream))
1367                    (highlight-presentation-1 presentation stream :highlight)))
1368              presentation))))
1369    
1370  (defmethod tracking-pointer-loop-step :before  (defmethod tracking-pointer-loop-step :before
1371      ((state frame-tracking-pointer-state) (event pointer-event) x y)      ((state frame-tracking-pointer-state) (event pointer-event) x y)
1372    (declare (ignore x y))    (declare (ignore x y))
1373    (when (highlight state)    (when (highlight state)
1374      (let ((stream (event-sheet event)))      (let ((stream (event-sheet event)))
1375        (setf (applicable-presentation state)        (setf (applicable-presentation state)
1376              (frame-highlight-at-position *application-frame* stream              (highlight-for-tracking-pointer *application-frame* stream
1377                                           (device-event-x event)                                              (device-event-x event)
1378                                           (device-event-y event)                                              (device-event-y event)
1379                                           (event-modifier-state event)                                              (input-context state))))))
1380                                           (input-context state)  
                                          :highlight (highlight state)))  
       ;;; Hmmm, probably don't want to do this  
       #+nil (frame-update-pointer-documentation frame  
                                           (input-context state)  
                                           stream  
                                           event))))  
1381    
1382  (macrolet ((frob (event handler)  (macrolet ((frob (event handler)
1383               `(defmethod tracking-pointer-loop-step               `(defmethod tracking-pointer-loop-step

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

  ViewVC Help
Powered by ViewVC 1.1.5