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

Diff of /mcclim/frames.lisp

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

revision 1.129 by thenriksen, Tue Jan 22 08:51:02 2008 UTC revision 1.130 by thenriksen, Sun Jan 27 22:24:07 2008 UTC
# Line 1115  documentation produced by presentations. Line 1115  documentation produced by presentations.
1115    (declare (ignore input-context stream))    (declare (ignore input-context stream))
1116    (equal old-state new-state))    (equal old-state new-state))
1117    
1118    (defun record-on-display (stream record)
1119      "Return true if `record' is part of the output history of
1120    `stream', false otherwise."
1121      (labels ((worker (record)
1122                 (or (eq record (stream-output-history stream))
1123                     (and (not (null (output-record-parent record)))
1124                          (worker (output-record-parent record))))))
1125        (worker record)))
1126    
1127  (defgeneric frame-print-pointer-documentation  (defgeneric frame-print-pointer-documentation
1128      (frame input-context stream state event))      (frame input-context stream state event))
1129    
# Line 1127  documentation produced by presentations. Line 1136  documentation produced by presentations.
1136      (let ((x (device-event-x event))      (let ((x (device-event-x event))
1137            (y (device-event-y event))            (y (device-event-y event))
1138            (pstream *pointer-documentation-output*))            (pstream *pointer-documentation-output*))
1139        (loop for (button presentation translator context)        (if (null new-translators)
1140              in new-translators            (when (and (background-message pstream)
1141              for name = (cadr (assoc button +button-documentation+))                       (not (record-on-display pstream (background-message pstream))))
1142              for first-one = t then nil              (cond ((> (get-universal-time)
1143              do (progn                        (+ (background-message-time pstream)
1144                   (unless first-one                           *background-message-minimum-lifetime*))
1145                     (write-string "; " pstream))                     (setf (background-message pstream) nil))
1146                   (unless (zerop current-modifier)                    (t
1147                     (print-modifiers pstream current-modifier :short)                     (setf (output-record-parent (background-message pstream)) nil)
1148                     (write-string "-" pstream))                     (stream-add-output-record pstream (background-message pstream))
1149                   (format pstream "~A: " name)                     (replay (background-message pstream) pstream))))
1150                   (document-presentation-translator translator            (loop for (button presentation translator context)
1151                                                     presentation                  in new-translators
1152                                                     (input-context-type context)                  for name = (cadr (assoc button +button-documentation+))
1153                                                     *application-frame*                  for first-one = t then nil
1154                                                     event                  do (progn
1155                                                     stream                       (unless first-one
1156                                                     x y                         (write-string "; " pstream))
1157                                                     :stream pstream                       (unless (zerop current-modifier)
1158                                                     :documentation-type                         (print-modifiers pstream current-modifier :short)
1159                                                     :pointer))                         (write-string "-" pstream))
1160              finally (when new-translators                       (format pstream "~A: " name)
1161                        (write-char #\. pstream)))                       (document-presentation-translator translator
1162                                                           presentation
1163                                                           (input-context-type context)
1164                                                           *application-frame*
1165                                                           event
1166                                                           stream
1167                                                           x y
1168                                                           :stream pstream
1169                                                           :documentation-type
1170                                                           :pointer))
1171                    finally (when new-translators
1172                              (write-char #\. pstream))))
1173        ;; Wasteful to do this after doing        ;; Wasteful to do this after doing
1174        ;; find-innermost-presentation-context above... look at doing this        ;; find-innermost-presentation-context above... look at doing this
1175        ;; first and then doing the innermost test.        ;; first and then doing the innermost test.
1176        (let ((all-translators (find-applicable-translators        (let ((all-translators (find-applicable-translators
1177                                (stream-output-history stream)                                (stream-output-history stream)
1178                                input-context                                input-context
1179                                *application-frame*                                *application-frame*
1180                                stream                                stream
1181                                x y                                x y
1182                                :for-menu t))                                :for-menu t))
1183              (other-modifiers nil))              (other-modifiers nil))
1184          (loop for (translator) in all-translators          (loop for (translator) in all-translators
1185                for gesture = (gesture translator)                for gesture = (gesture translator)
1186                unless (eq gesture t)                unless (eq gesture t)
1187                do (loop for (name type modifier) in gesture                do (loop for (name type modifier) in gesture
1188                         unless (eql modifier current-modifier)                         unless (eql modifier current-modifier)
1189                         do (pushnew modifier other-modifiers)))                         do (pushnew modifier other-modifiers)))
1190          (when other-modifiers          (when other-modifiers
1191            (setf other-modifiers (sort other-modifiers #'cmp-modifiers))            (setf other-modifiers (sort other-modifiers #'cmp-modifiers))
1192            (terpri pstream)            (terpri pstream)
1193            (write-string "To see other commands, press " pstream)            (write-string "To see other commands, press " pstream)
1194            (loop for modifier-tail on other-modifiers            (loop for modifier-tail on other-modifiers
1195                  for (modifier) = modifier-tail                  for (modifier) = modifier-tail
1196                  for count from 0                  for count from 0
1197                  do (progn                  do (progn
1198                       (if (null (cdr modifier-tail))                       (if (null (cdr modifier-tail))
1199                           (progn                           (progn
1200                             (when (> count 1)                             (when (> count 1)
1201                               (write-char #\, pstream))                               (write-char #\, pstream))
1202                             (when (> count 0)                             (when (> count 0)
1203                               (write-string " or " pstream)))                               (write-string " or " pstream)))
1204                           (when (> count 0)                           (when (> count 0)
1205                             (write-string ", " pstream)))                             (write-string ", " pstream)))
1206                       (print-modifiers pstream modifier :long)))                       (print-modifiers pstream modifier :long)))
1207            (write-char #\. pstream))))))            (write-char #\. pstream))))))
1208    
1209  (defmethod frame-update-pointer-documentation  (defmethod frame-update-pointer-documentation
1210      ((frame standard-application-frame) input-context stream event)      ((frame standard-application-frame) input-context stream event)
1211    (when *pointer-documentation-output*    (when *pointer-documentation-output*
1212      (with-accessors ((frame-documentation-state frame-documentation-state)      (with-accessors ((frame-documentation-state frame-documentation-state)
1213                       (documentation-record documentation-record))                       (documentation-record documentation-record))
1214        frame          frame
1215        (setf frame-documentation-state        (setf frame-documentation-state
1216              (frame-compute-pointer-documentation-state frame              (frame-compute-pointer-documentation-state frame
1217                                                         input-context                                                         input-context
# Line 1206  documentation produced by presentations. Line 1226  documentation produced by presentations.
1226              (%event% event))              (%event% event))
1227          (declare (special %input-context% %stream% %doc-state% %event&))          (declare (special %input-context% %stream% %doc-state% %event&))
1228          (if (and documentation-record          (if (and documentation-record
1229                   (output-record-parent documentation-record))                   (output-record-parent documentation-record))
1230              (redisplay documentation-record *pointer-documentation-output*)              (redisplay documentation-record *pointer-documentation-output*)
1231              (progn              (progn
1232                (window-clear *pointer-documentation-output*)                (window-clear *pointer-documentation-output*)
1233                (setf documentation-record                (setf documentation-record
1234                      (updating-output (*pointer-documentation-output*)                      (updating-output (*pointer-documentation-output*)
1235                        (updating-output (*pointer-documentation-output*                        (updating-output (*pointer-documentation-output*
1236                                          :cache-value %doc-state%                                          :cache-value %doc-state%
1237                                          :cache-test                                          :cache-test #'equal)
1238                                          #'equal)                          (frame-print-pointer-documentation frame
1239                          (frame-print-pointer-documentation frame                                                             %input-context%
1240                                                             %input-context%                                                             %stream%
1241                                                             %stream%                                                             %doc-state%
1242                                                             %doc-state%                                                             %event%))))))))))
1243                                                             %event%))))))))))  
1244    (defgeneric invoke-with-output-to-pointer-documentation (frame continuation)
1245  #-(and)    (:documentation "Invoke `continuation' with a single argument -
1246  (defmethod frame-update-pointer-documentation  a stream that the continuation can write to, the output of which
1247      ((frame standard-application-frame) input-context stream event)  will be used as the background message of the pointer
1248    (when *pointer-documentation-output*  documentation pane of `frame'. If the pointer-documentation of
1249      (with-accessors ((frame-documentation-state frame-documentation-state))  `frame' is not a `pointer-documentation-pane', `continuation'
1250          frame  will not be called."))
1251        (let ((new-state (frame-compute-pointer-documentation-state frame  
1252                                                                    input-context  (defmethod invoke-with-output-to-pointer-documentation
1253                                                                    stream      ((frame standard-application-frame) continuation)
1254                                                                    event)))    (with-accessors ((pointer-documentation frame-pointer-documentation-output)) frame
1255          (unless (frame-compare-pointer-documentation-state      (when (typep pointer-documentation 'pointer-documentation-pane)
1256                   frame        (setf (background-message pointer-documentation)
1257                   input-context              (with-output-to-output-record (pointer-documentation)
1258                   stream                (funcall continuation pointer-documentation))
1259                   frame-documentation-state              (background-message-time pointer-documentation) (get-universal-time)))))
1260                   new-state)  
1261            (window-clear *pointer-documentation-output*)  (defmacro with-output-to-pointer-documentation ((stream frame) &body body)
1262            (frame-print-pointer-documentation frame    "Bind `stream' to the pointer-documentation pane of `frame' and
1263                                               input-context  capture the output of `body' on `stream' as the background
1264                                               stream  message of the pointer documentation pane. If `frame' does not
1265                                               new-state  have a `pointer-documentation-pane' as pointer documentation,
1266                                               event)  `body' will not be evaluated."
1267            (setq frame-documentation-state new-state))))))    `(invoke-with-output-to-pointer-documentation
1268        ,frame #'(lambda (,stream)
1269                   ,@body)))
1270    
1271  ;;; A hook for applications to draw random strings in the  ;;; A hook for applications to draw random strings in the
1272  ;;; *pointer-documentation-output* without screwing up the real pointer  ;;; *pointer-documentation-output* without screwing up the real pointer
1273  ;;; documentation too badly.  ;;; documentation too badly.
1274    
1275  (defgeneric frame-display-pointer-documentation-string  (defun frame-display-pointer-documentation-string (frame string)
1276      (frame documentation-stream string))    (with-output-to-pointer-documentation (stream frame)
1277        (write-string string stream)))
 (defmethod frame-display-pointer-documentation-string  
     ((frame standard-application-frame) documentation-stream string)  
   (when *pointer-documentation-output*  
     (with-accessors ((frame-documentation-state frame-documentation-state))  
         frame  
       (unless (frame-compare-pointer-documentation-state  
                frame nil documentation-stream frame-documentation-state string)  
         (window-clear documentation-stream)  
         (write-string string documentation-stream)  
         (setq frame-documentation-state string)))))  
1278    
1279  (defmethod frame-input-context-track-pointer  (defmethod frame-input-context-track-pointer
1280      ((frame standard-application-frame)      ((frame standard-application-frame)

Legend:
Removed from v.1.129  
changed lines
  Added in v.1.130

  ViewVC Help
Powered by ViewVC 1.1.5