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

Diff of /mcclim/frames.lisp

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

revision 1.46 by adejneka, Wed Jul 31 11:56:33 2002 UTC revision 1.47 by moore, Fri Aug 2 08:05:16 2002 UTC
# Line 181  FRAME-EXIT condition.")) Line 181  FRAME-EXIT condition."))
181    ((event-queue :initarg :frame-event-queue    ((event-queue :initarg :frame-event-queue
182                  :accessor frame-event-queue                  :accessor frame-event-queue
183                  :documentation "The event queue that, by default, will be                  :documentation "The event queue that, by default, will be
184    shared by all panes in the stream")))    shared by all panes in the stream")
185       (documentation-state :accessor frame-documentation-state
186                            :initform nil
187                            :documentation "Used to keep of track of what
188      needs to be rendered in the pointer documentation frame.")))
189    
190  ;;; Support the :input-buffer initarg for compatibility with "real CLIM"  ;;; Support the :input-buffer initarg for compatibility with "real CLIM"
191    
# Line 333  FRAME-EXIT condition.")) Line 337  FRAME-EXIT condition."))
337      (let ((*standard-input* (frame-standard-input frame))      (let ((*standard-input* (frame-standard-input frame))
338            (*standard-output* (frame-standard-output frame))            (*standard-output* (frame-standard-output frame))
339            (*query-io* (frame-query-io frame))            (*query-io* (frame-query-io frame))
340              (*pointer-documentation-output* (frame-pointer-documentation-output
341                                               frame))
342            ;; during development, don't alter *error-output*            ;; during development, don't alter *error-output*
343            ;; (*error-output* (frame-error-output frame))            ;; (*error-output* (frame-error-output frame))
344            (*command-parser* command-parser)            (*command-parser* command-parser)
# Line 438  FRAME-EXIT condition.")) Line 444  FRAME-EXIT condition."))
444           (setf (slot-value frame 'pane) pane)))))           (setf (slot-value frame 'pane) pane)))))
445    
446  ; could do with some refactoring [BTS] FIXME  ; could do with some refactoring [BTS] FIXME
447  (defun make-panes-generate-panes-form (class-name menu-bar panes layouts)  (defun make-panes-generate-panes-form (class-name menu-bar panes layouts
448                                           pointer-documentation)
449      (when pointer-documentation
450        (setf panes (append panes
451                            '((%pointer-documentation%
452                               pointer-documentation-pane)))))
453    `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))    `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
454       (let ((*application-frame* frame))       (let ((*application-frame* frame))
455         (with-look-and-feel-realization (fm frame)         (with-look-and-feel-realization (fm frame)
# Line 467  FRAME-EXIT condition.")) Line 478  FRAME-EXIT condition."))
478             ; [BTS] added this, but is not sure that this is correct for adding             ; [BTS] added this, but is not sure that this is correct for adding
479             ; a menu-bar transparently, should also only be done where the             ; a menu-bar transparently, should also only be done where the
480             ; exterior window system does not support menus             ; exterior window system does not support menus
481            ,(if menu-bar            ,(if (or menu-bar pointer-documentation)
482                `(setf (slot-value frame 'pane)                `(setf (slot-value frame 'pane)
483                   (ecase (frame-current-layout frame)                   (ecase (frame-current-layout frame)
484                     ,@(mapcar (lambda (layout)                     ,@(mapcar (lambda (layout)
485                                 `(,(first layout) (vertically ()                                 `(,(first layout)
486                                                    ,(cond                                   (vertically ()
487                                                      ((eq menu-bar t)                                    ,@(cond
488                                                       `(clim-internals::make-menu-bar                                       ((eq menu-bar t)
489                                                          ',class-name))                                        `((clim-internals::make-menu-bar
490                                                      ((consp menu-bar)                                          ',class-name)))
491                                                       `(raising (:border-width 2 :background +Gray83+)                                       ((consp menu-bar)
492                                                          (clim-internals::make-menu-bar                                        `((raising (:border-width 2 :background +Gray83+)
493                                                             (make-command-table nil                                           (clim-internals::make-menu-bar
494                                                               :menu ',menu-bar))))                                            (make-command-table
495                                                      (menu-bar                                             nil
496                                                       `(clim-internals::make-menu-bar                                             :menu ',menu-bar)))))
497                                                          ',menu-bar)))                                       (menu-bar
498                                                     ,@(rest layout))))                                        `((clim-internals::make-menu-bar
499                                             ',menu-bar)))
500                                         (t nil))
501                                      ,@(rest layout)
502                                      ,@(when pointer-documentation
503                                              '(%pointer-documentation%)))))
504                               layouts)))                               layouts)))
505                `(setf (slot-value frame 'pane)                `(setf (slot-value frame 'pane)
506                   (ecase (frame-current-layout frame)                   (ecase (frame-current-layout frame)
# Line 503  FRAME-EXIT condition.")) Line 519  FRAME-EXIT condition."))
519          (command-definer t)          (command-definer t)
520          (top-level '(default-frame-top-level))          (top-level '(default-frame-top-level))
521          (others nil)          (others nil)
522          (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name) "-COMMAND"))))          (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name)
523                                               "-COMMAND")))
524            (pointer-documentation nil))
525      (loop for (prop . values) in options      (loop for (prop . values) in options
526          do (case prop          do (case prop
527               (:pane (setq pane (first values)))               (:pane (setq pane (first values)))
# Line 516  FRAME-EXIT condition.")) Line 534  FRAME-EXIT condition."))
534               (:disabled-commands (setq disabled-commands values))               (:disabled-commands (setq disabled-commands values))
535               (:command-definer (setq command-definer (first values)))               (:command-definer (setq command-definer (first values)))
536               (:top-level (setq top-level (first values)))               (:top-level (setq top-level (first values)))
537                 (:pointer-documentation (setq pointer-documentation (car values)))
538               (t (push (cons prop values) others))))               (t (push (cons prop values) others))))
539      (if (or (and pane panes)      (if (or (and pane panes)
540              (and pane layouts))              (and pane layouts))
# Line 540  FRAME-EXIT condition.")) Line 559  FRAME-EXIT condition."))
559           ,@others)           ,@others)
560         ,(if pane         ,(if pane
561              (make-single-pane-generate-panes-form name menu-bar pane)              (make-single-pane-generate-panes-form name menu-bar pane)
562              (make-panes-generate-panes-form name menu-bar panes layouts))              (make-panes-generate-panes-form name menu-bar panes layouts
563                                                pointer-documentation))
564         ,@(if command-table         ,@(if command-table
565               `((define-command-table ,@command-table)))               `((define-command-table ,@command-table)))
566         ,@(if command-definer         ,@(if command-definer
# Line 629  FRAME-EXIT condition.")) Line 649  FRAME-EXIT condition."))
649      ((frame standard-application-frame)      ((frame standard-application-frame)
650       (stream output-recording-stream)       (stream output-recording-stream)
651       button-press-event)       button-press-event)
   (format *debug-io* "frame button press event: ~D ~D in ~S~%"  
           (pointer-event-x button-press-event)  
           (pointer-event-y button-press-event)  
           stream)  
652    (let ((presentation (find-innermost-applicable-presentation    (let ((presentation (find-innermost-applicable-presentation
653                         *input-context*                         *input-context*
654                         stream                         stream
# Line 641  FRAME-EXIT condition.")) Line 657  FRAME-EXIT condition."))
657                         :frame frame                         :frame frame
658                         :event button-press-event)))                         :event button-press-event)))
659      (when presentation      (when presentation
       (format *debug-io* "presentation: ~S of type ~S~%"  
               (presentation-object presentation)  
               (presentation-type presentation))  
660        (throw-highlighted-presentation presentation        (throw-highlighted-presentation presentation
661                                        *input-context*                                        *input-context*
662                                        button-press-event))))                                        button-press-event))))
# Line 653  FRAME-EXIT condition.")) Line 666  FRAME-EXIT condition."))
666    (declare (ignore stream button-press-event))    (declare (ignore stream button-press-event))
667    nil)    nil)
668    
669    (defgeneric frame-update-pointer-documentation
670        (frame input-context stream event))
671    
672    (defconstant +button-documentation+ '((#.+pointer-left-button+ "L")
673                                          (#.+pointer-middle-button+ "M")
674                                          (#.+pointer-right-button+ "R")))
675    
676    (defmethod frame-update-pointer-documentation
677        ((frame standard-application-frame) input-context stream event)
678      (when *pointer-documentation-output*
679        (with-accessors ((frame-documentation-state frame-documentation-state))
680            frame
681          (destructuring-bind (&optional modifier-bits translators)
682              frame-documentation-state
683            (let* ((current-modifier (event-modifier-state event))
684                   (x (pointer-event-x event))
685                   (y (pointer-event-y event))
686                   (new-translators
687                    (loop for (button) in +button-documentation+
688                          for context-list = (multiple-value-list
689                                              (find-innnermost-presentation-context
690                                               input-context
691                                               stream
692                                               x y
693                                               :modifier-state current-modifier
694                                               :button button))
695                          when (car context-list)
696                          collect (cons button context-list))))
697              (unless (and (eql modifier-bits current-modifier)
698                           (equal translators new-translators))
699                ;; State is different, so print out new documentation
700                (window-clear *pointer-documentation-output*)
701                (loop for (button presentation translator context)
702                        in new-translators
703                      for name = (cadr (assoc button +button-documentation+))
704                      do (progn
705                           (format *pointer-documentation-output* "~A: " name)
706                           (document-presentation-translator
707                            translator
708                            presentation
709                            (input-context-type context)
710                            *application-frame*
711                            event
712                            stream
713                            x y
714                            :stream *pointer-documentation-output*
715                            :documentation-type :pointer)
716                           (write-string " " *pointer-documentation-output*)))
717                (setq frame-documentation-state (list current-modifier
718                                                      new-translators))))))))
719    
720  (defmethod frame-input-context-track-pointer  (defmethod frame-input-context-track-pointer
721      ((frame standard-application-frame)      ((frame standard-application-frame)
722       input-context       input-context
# Line 667  FRAME-EXIT condition.")) Line 731  FRAME-EXIT condition."))
731    
732  (defmethod frame-input-context-track-pointer :before  (defmethod frame-input-context-track-pointer :before
733      ((frame standard-application-frame) input-context stream event)      ((frame standard-application-frame) input-context stream event)
734      (flet ((maybe-unhighlight (presentation)
735               (when (and (frame-hilited-presentation frame)
736                          (not (eq presentation
737                                   (car (frame-hilited-presentation frame)))))
738                 (highlight-presentation-1 (car (frame-hilited-presentation frame))
739                                           (cdr (frame-hilited-presentation frame))
740                                           :unhighlight))))
741      (if (output-recording-stream-p stream)      (if (output-recording-stream-p stream)
742          (let ((presentation (find-innermost-applicable-presentation          (let ((presentation (find-innermost-applicable-presentation
743                               input-context                               input-context
# Line 675  FRAME-EXIT condition.")) Line 746  FRAME-EXIT condition."))
746                               (pointer-event-y event)                               (pointer-event-y event)
747                               :frame frame                               :frame frame
748                               :modifier-state (event-modifier-state event))))                               :modifier-state (event-modifier-state event))))
749            (when (and (frame-hilited-presentation frame)            (maybe-unhighlight presentation)
                      (not (eq presentation  
                               (car (frame-hilited-presentation frame)))))  
             (highlight-presentation-1 (car (frame-hilited-presentation frame))  
                                       (cdr (frame-hilited-presentation frame))  
                                       :unhighlight))  
750            (if presentation            (if presentation
751                (when (not (eq presentation                (when (not (eq presentation
752                               (car (frame-hilited-presentation frame))))                               (car (frame-hilited-presentation frame))))
753                  (setf (frame-hilited-presentation frame)                  (setf (frame-hilited-presentation frame)
754                        (cons presentation stream))                        (cons presentation stream))
755                  (highlight-presentation-1 presentation stream :highlight))                  (highlight-presentation-1 presentation stream :highlight))
756                (setf (frame-hilited-presentation frame) nil)))))                (setf (frame-hilited-presentation frame) nil)))
757            (progn
758              (maybe-unhighlight nil)
759              (setf (frame-hilited-presentation frame) nil))))
760      (frame-update-pointer-documentation frame input-context stream event))
761    
762    
763  (defun simple-event-loop ()  (defun simple-event-loop ()

Legend:
Removed from v.1.46  
changed lines
  Added in v.1.47

  ViewVC Help
Powered by ViewVC 1.1.5