(in-package :clim-clx) (in-package :climi) (defun update-mirror-geometry (sheet &key) "This function reflects the current sheet region and sheet transformation to the mirror. It also sets up the native transformation. This function is supposed to be called whenever one of the following happens: - the sheet's transformation changed - the sheet's region changed - the parent's native transformation changed - the parent's transformation changed - the parent's mirror region changed Also if the sheet's native transformation changes the mirror's contents need to be redrawn, which is achieved by calling PORT-DIRTY-MIRROR-REGION. Since changing the sheet's native transformation might thus be expensive, this function tries to minimize changes to it. (although it does not try very hard)." (let ((old-native-transformation (%%sheet-native-transformation sheet))) (cond ((null (sheet-parent sheet)) ;; Ugh, we have no parent, this must be the graft, we cannot resize it can we? nil) ;; ;; Otherwise, the native transformation has to changed or needs to be computed initially ;; (t (let* ((parent (sheet-parent sheet)) (sheet-region-in-native-parent ;; this now is the wanted sheet mirror region (transform-region (sheet-native-transformation parent) (transform-region (sheet-transformation sheet) (sheet-region sheet))))) (when (region-equal sheet-region-in-native-parent +nowhere+) ;; hmm (setf (%sheet-mirror-transformation sheet) (make-translation-transformation -5 -5)) (setf (%sheet-mirror-region sheet) (make-rectangle* 0 0 1 1)) (when (sheet-direct-mirror sheet) (port-set-mirror-region (port sheet) (sheet-direct-mirror sheet) (%sheet-mirror-region sheet)) (port-set-mirror-transformation (port sheet) (sheet-direct-mirror sheet) (%sheet-mirror-transformation sheet)) ) (return-from update-mirror-geometry)) ;; mx1 .. my2 are is now the wanted mirror region in the parent ;; coordinate system. (with-bounding-rectangle* (mx1 my1 mx2 my2) sheet-region-in-native-parent (let (;; pw, ph is the width/height of the parent (pw (bounding-rectangle-width (sheet-mirror-region parent))) (ph (bounding-rectangle-height (sheet-mirror-region parent)))) (labels ((choose (MT) ;; -> fits-p mirror-region (multiple-value-bind (x1 y1) (transform-position MT 0 0) (let ((x2 (if (<= mx2 pw) mx2 (floor (+ pw (min mx2 (+ #x8000 x1) #x8000)) 2))) (y2 (if (<= my2 ph) my2 (floor (+ ph (min my2 (+ #x8000 y1) #x8000)) 2)))) (when (and (< (- x2 x1) #x8000) (or (<= (max (- pw #x8000) mx1) x1 0) (coordinate= x1 mx1)) (< (- y2 y1) #x8000) (or (<= (max (- pw #x8000) my1) y1 0) (coordinate= y1 my1)) (> (round (- x2 x1)) 0) (> (round (- y2 y1)) 0)) (values t (make-rectangle* 0 0 (round (- x2 x1)) (round (- y2 y1))))))))) ;; ;; Try reusing the native transformation: ;; (when old-native-transformation (let ((MT (compose-transformations (compose-transformations (sheet-native-transformation (sheet-parent sheet)) (sheet-transformation sheet)) (invert-transformation old-native-transformation)))) (multiple-value-bind (fits-p MR) (choose MT) (when fits-p (setf (%sheet-mirror-region sheet) MR) (setf (%sheet-mirror-transformation sheet) MT) (when (sheet-direct-mirror sheet) (let ((port (port sheet)) (mirror (sheet-direct-mirror sheet))) (port-set-mirror-region port mirror MR) (port-set-mirror-transformation port mirror MT) )) (return-from update-mirror-geometry nil) )))) ;; Otherwise just choose ;; Conditions to be met: ;; x2 < #x8000 + x1 ;; x1 in [max(pw - #x8000, mx1), 0] u {mx1} ;; x2 in [pw, min (#x8000, mx2)] u {mx2} ;; ;; It can still happend, that we cannot meet the ;; window system limitations => the sheet is ;; unvisible. (let* ((x1 (if (>= mx1 0) (round mx1) (floor (max (- pw #x8000) mx1) 2))) (y1 (if (>= my1 0) (round my1) (floor (max (- ph #x8000) my1) 2))) (x2 (if (<= mx2 pw) mx2 (floor (+ pw (min mx2 (- #x8000 x1))) 2))) (y2 (if (<= my2 ph) my2 (floor (+ ph (min my2 (- #x8000 y1))) 2))) (MT (make-translation-transformation x1 y1)) (MR (make-rectangle* 0 0 (round (- x2 x1)) (round (- y2 y1)))) (native-transformation ;; NT = T o PNT o -MT (compose-transformations (invert-transformation MT) (compose-transformations (sheet-native-transformation (sheet-parent sheet)) (sheet-transformation sheet)))) (old-native-transformation (%%sheet-native-transformation sheet))) (cond ((and (> (round (- x2 x1)) 0) (> (round (- y2 y1)) 0)) ;; finally reflect the change to the host window system (setf (%sheet-mirror-region sheet) MR) (setf (%sheet-mirror-transformation sheet) MT) (when (sheet-direct-mirror sheet) (let ((port (port sheet)) (mirror (sheet-direct-mirror sheet))) (port-set-mirror-region port mirror MR) (port-set-mirror-transformation port mirror MT) )) ;; update the native transformation if neccessary. (unless (and old-native-transformation (transformation-equal native-transformation old-native-transformation)) (invalidate-cached-transformations sheet) (%%set-sheet-native-transformation native-transformation sheet) (when old-native-transformation (care-for-new-native-transformation sheet old-native-transformation native-transformation)))) (t (setf (%sheet-mirror-transformation sheet) (make-translation-transformation -5 -5)) (setf (%sheet-mirror-region sheet) (make-rectangle* 0 0 1 1)) (when (sheet-direct-mirror sheet) (port-set-mirror-region (port sheet) (sheet-direct-mirror sheet) (%sheet-mirror-region sheet)) (port-set-mirror-transformation (port sheet) (sheet-direct-mirror sheet) (%sheet-mirror-transformation sheet)) )) )))))))))) (in-package :clim-clx) (defvar *forgetting-p* nil) (defun start-forgetting-redraw (port sheet) (error "do not call me")) (defun stop-forgetting-redraw (port sheet) (error "do not call me")) (defun event-handler (&rest event-slots &key display window event-key code state mode time width height x y root-x root-y data override-redirect-p send-event-p hint-p type &allow-other-keys) ;; NOTE: Although it might be tempting to compress (consolidate) ;; events here, this is the wrong place. In our current architecture ;; the process calling this function (the port's event handler ;; process) just reads the events from the X server, and does it ;; with almost no lack behind the reality. While the application ;; frame's event top level loop does the actual processing of events ;; and thus may produce lack. So the events have to be compressed in ;; the frame's event queue. ;; ;; So event compression is implemented in EVENT-QUEUE-APPEND. ;; ;; This changes for possible _real_ immediate repainting sheets, ;; here a possible solution for the port's event handler loop can be ;; to read all available events off into a temponary queue (and ;; event compression for immediate events is done there) and then ;; dispatch all events from there as usual. ;; ;;--GB ;; XXX :button code -> :button (decode-x-button-code code) (declare (ignorable event-slots)) (declare (special *clx-port*)) (let ((sheet (and window (port-lookup-sheet *clx-port* window)))) (when sheet (case event-key ((:key-press :key-release) (multiple-value-bind (keyname modifier-state) (x-event-to-key-name-and-modifiers *clx-port* event-key code state) (make-instance (if (eq event-key :key-press) 'key-press-event 'key-release-event) :key-name keyname :key-character (and (characterp keyname) keyname) :x x :y y :graft-x root-x :graft-y root-y :sheet sheet :modifier-state modifier-state :timestamp time))) ((:button-press :button-release) (let ((modifier-state (x-event-state-modifiers *clx-port* state))) (make-instance (if (eq event-key :button-press) 'pointer-button-press-event 'pointer-button-release-event) :pointer 0 :button (decode-x-button-code code) :x x :y y :graft-x root-x :graft-y root-y :sheet sheet :modifier-state modifier-state :timestamp time))) (:enter-notify (make-instance 'pointer-enter-event :pointer 0 :button code :x x :y y :graft-x root-x :graft-y root-y :sheet sheet :modifier-state (x-event-state-modifiers *clx-port* state) :timestamp time)) (:leave-notify (make-instance (if (eq mode :ungrab) 'pointer-ungrab-event 'pointer-exit-event) :pointer 0 :button code :x x :y y :graft-x root-x :graft-y root-y :sheet sheet :modifier-state (x-event-state-modifiers *clx-port* state) :timestamp time)) ;; (:configure-notify ;; it would be nice to consolidate these for resizes, but because of the ;; interleaving exposures it becomes a bit tricky to do at this point. - BTS (cond ((and (eq (sheet-parent sheet) (graft sheet)) (not override-redirect-p) (not send-event-p)) ;; this is genuine event for a top-level sheet (with ;; override-redirect off) ;; ;; Since the root window is not our real parent, but ;; there the window managers decoration in between, ;; only the size is correct, so we need to deduce the ;; position from our idea of it. (multiple-value-bind (x y) (transform-position (compose-transformations (sheet-transformation sheet) (sheet-native-transformation (graft sheet))) 0 0) (make-instance 'window-configuration-event :sheet sheet :x x :y y :width width :height height))) (t ;; nothing special here (make-instance 'window-configuration-event :sheet sheet :x x :y y :width width :height height)))) (:destroy-notify (make-instance 'window-destroy-event :sheet sheet)) (:motion-notify (let ((modifier-state (x-event-state-modifiers *clx-port* state))) (if hint-p (multiple-value-bind (x y same-screen-p child mask root-x root-y) (xlib:query-pointer window) (declare (ignore mask)) ;; If not same-screen-p or the child is different ;; from the original event, assume we're way out of date ;; and don't return an event. (when (and same-screen-p (not child)) (make-instance 'pointer-motion-hint-event :pointer 0 :button code :x x :y y :graft-x root-x :graft-y root-y :sheet sheet :modifier-state modifier-state :timestamp time))) (progn (make-instance 'pointer-motion-event :pointer 0 :button code :x x :y y :graft-x root-x :graft-y root-y :sheet sheet :modifier-state modifier-state :timestamp time))))) ;; ((:exposure :display) ;; Notes: ;; . Do not compare count with 0 here, last rectangle in an ;; :exposure event sequence does not cover the whole region. ;; ;; . Do not transform the event region here, since ;; WINDOW-EVENT-REGION does it already. And rightfully so. ;; (think about changing a sheet's native transformation). ;;--GB ;; ;; Mike says: ;; One of the lisps is bogusly sending a :display event instead of an ;; :exposure event. I don't remember if it's CMUCL or SBCL. So the ;; :display event should be left in. ;; (port-repaint-event sheet time x y (+ x width) (+ y height)) ) ;; (:client-message (port-client-message sheet time type data)) (t nil))))) (defmethod scroll-extent ((pane basic-pane) x y) (setf x (round x)) (setf y (round y)) (when (pane-viewport pane) (let* ((old-region (region-intersection (untransform-region (sheet-transformation pane) (sheet-region (sheet-parent pane))) (sheet-region pane))) (new-region (region-intersection (untransform-region (make-translation-transformation (- x) (- y)) (sheet-region (sheet-parent pane))) (sheet-region pane))) (diff (region-difference new-region old-region))) (print diff *trace-output*) (finish-output *trace-output*) (clim-clx::port-invoke-with-unexpose pane diff (lambda () (move-sheet pane (round (- x)) (round (- y))))) (handle-repaint pane diff)) (when (pane-scroller pane) (climi::scroller-pane/update-scroll-bars (pane-scroller pane))) )) ;;;; Negative Exposures ;; We introduce two new private messages: ;; :_mcclim_start_unexpose id ;; :_mcclim_stop_unexpose id ;; These are send as client messages to the relevant pane. 'id' refers ;; to the *unexpose-regions* array. (defvar *id-expose-regions* (make-array 10 :adjustable t :fill-pointer 0)) (defun expose-id-name-region (region) (let ((x (position nil *id-expose-regions*))) (cond ((null x) (vector-push-extend region *id-expose-regions*)) (t (setf (aref *id-expose-regions* x) region) x)))) (defun expose-id-unname (id) (setf (aref *id-expose-regions* id) nil)) (defun port-invoke-with-unexpose (sheet region cont) (let ((id (expose-id-name-region region))) (xlib:send-event (sheet-direct-mirror sheet) :client-message '(:exposure) :window (sheet-direct-mirror sheet) :format 32 :type :_mcclim_start_unexpose :data (list id)) (funcall cont) (xlib:send-event (sheet-direct-mirror sheet) :client-message '(:exposure) :window (sheet-direct-mirror sheet) :format 32 :type :_mcclim_end_unexpose :data (list id)))) (defmethod resize-sheet :around ((pane basic-pane) x y) ;;(start-forgetting-redraw (port pane) (sheet-direct-mirror pane)) (call-next-method) ;;(stop-forgetting-redraw (port pane) (sheet-direct-mirror pane)) ) (defmethod port-client-message (sheet time (type (eql :wm_protocols)) data) (port-wm-protocols-message sheet time (xlib:atom-name (slot-value *clx-port* 'display) (aref data 0)) data)) (defvar *unexpose-regions* nil) (defmethod port-client-message (sheet time (type (eql :_mcclim_start_unexpose)) data) (push (aref *id-expose-regions* (elt data 0)) *unexpose-regions*) nil) (defmethod port-client-message (sheet time (type (eql :_mcclim_end_unexpose)) data) (setf *unexpose-regions* (remove (aref *id-expose-regions* (elt data 0)) *unexpose-regions*)) (expose-id-unname (elt data 0)) nil) (defmethod port-client-message (sheet time (type t) data) (warn "Unprocessed client message: ~:_type = ~S;~:_ data = ~S;~_ sheet = ~S." type data sheet)) (defmethod port-wm-protocols-message (sheet time (message (eql :wm_delete_window)) data) (declare (ignore data)) (make-instance 'window-manager-delete-event :sheet sheet :timestamp time)) (defmethod port-wm-protocols-message (sheet time (message t) data) (warn "Unprocessed WM Protocols message: ~:_message = ~S;~:_ data = ~S;~_ sheet = ~S." message data sheet)) #+NIL (defun port-client-message (type message sheet time) (case message (:wm_delete_window (make-instance 'window-manager-delete-event :sheet sheet :timestamp time)) (:clim-stop-forget (setf *forgetting-p* nil) nil) (:clim-start-forget (setf *forgetting-p* t) nil) )) (defun port-repaint-event (sheet time x1 y1 x2 y2) (let ((rgn (make-rectangle* x1 y1 x2 y2))) (dolist (k *unexpose-regions*) (setf rgn (region-difference rgn k))) (unless (eql rgn +nowhere+) (print (list :repaint rgn) *trace-output*) (finish-output *trace-output*) (make-instance 'window-repaint-event :timestamp time :sheet sheet :region rgn)))) ; Evaluation took: ; 0.16 seconds of real time ; 0.1 seconds of user run time ; 0.0 seconds of system run time ; 224,275,110 CPU cycles ; 0 page faults and ; 1,442,576 bytes consed. ; ;;;; ; Evaluation took: ; 0.2 seconds of real time ; 0.18 seconds of user run time ; 0.02 seconds of system run time ; 288,010,520 CPU cycles ; [Run times include 0.09 seconds GC run time] ; 0 page faults and ; 1,463,080 bytes consed. ;