Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv29764/renderer Modified Files: clim-device.lisp renderer2.lisp Log Message: Distinguish between pane and medium in the CLIM GUI. This should fix image display. Date: Sun Jul 10 13:18:35 2005 Author: emarsden Index: closure/src/renderer/clim-device.lisp diff -u closure/src/renderer/clim-device.lisp:1.10 closure/src/renderer/clim-device.lisp:1.11 --- closure/src/renderer/clim-device.lisp:1.10 Mon Jun 20 17:37:33 2005 +++ closure/src/renderer/clim-device.lisp Sun Jul 10 13:18:35 2005 @@ -31,7 +31,7 @@ (defclass clim-device () ((medium :accessor clim-device-medium :initarg :medium) (font-database :initform nil) - (zoom-factor :initform closure::*zoom-factor* :initarg :zoom-factor))) + (zoom-factor :initform gui:*zoom-factor* :initarg :zoom-factor))) (defmethod device-dpi ((device clim-device)) (with-slots (zoom-factor) device @@ -221,6 +221,7 @@ res)) (defun background-pixmap+mask (document drawable bg) + #+emarsden2005-06-23 (print `(background-pixmap+mask ,bg)) (cond ((r2::background-%pixmap bg) ;; already there @@ -243,6 +244,62 @@ (values (r2::background-%pixmap bg) (r2::background-%mask bg)))))) )) +(defun ws/x11::x11-put-pixmap-tiled (drawable ggc pixmap mask x y w h &optional (xo 0) (yo 0)) + (cond ((null mask) ;; xxx + (xlib:with-gcontext (ggc :exposures :off + :fill-style :tiled + :tile pixmap + :ts-x xo + :ts-y yo) + ;;mask wird momentan noch ignoriert! + (xlib:draw-rectangle drawable ggc x y w h t))) + (t + (let* ((old-clip-mask (car (or (ignore-errors (list (xlib:gcontext-clip-mask ggc))) + (list :none)))) + (clip-region (let ((q old-clip-mask)) + (if (consp q) + (region-from-x11-rectangle-list q) + +everywhere+))) + (paint-region (region-intersection + clip-region + (make-rectangle* x y (+ x w) (+ y h)))) ) + ;; There is a bug in CLX wrt to clip-x / clip-y + ;; Turning off caching helps + (setf (xlib:gcontext-cache-p ggc) nil) + + ;; we have to do our own clipping here. + (let ((iw (xlib:drawable-width pixmap)) + (ih (xlib:drawable-height pixmap))) + (loop for i from (floor (- x xo) iw) to (ceiling (- (+ x w) (+ xo iw)) iw) + do + (loop for j from (floor (- y yo) ih) to (ceiling (- (+ y h) (+ yo ih)) ih) + do + (let ((rect (make-rectangle* + (+ xo (* i iw)) + (+ yo (* j ih)) + (+ (+ xo (* i iw)) iw) + (+ (+ yo (* j ih)) ih)))) + (map-region-rectangles + (lambda (rx0 ry0 rx1 ry1) + (xlib:with-gcontext (ggc :exposures :off + :fill-style :tiled + :tile pixmap + :clip-mask mask + :clip-x (+ xo (* i iw)) + :clip-y (+ yo (* j ih)) + :ts-x xo + :ts-y yo) + (xlib:draw-rectangle drawable ggc + rx0 ry0 (max 0 (- rx1 rx0)) (max 0 (- ry1 ry0)) + t))) + (region-intersection paint-region rect))))) ) + ;; turn on caching again (see above) + (setf (xlib:gcontext-cache-p ggc) t) + ;; + ;; and xlib:with-gcontext also is broken! + (setf (xlib:gcontext-clip-mask ggc) old-clip-mask))))) + +#+emarsden #.((lambda (x) #+:CMU `(eval ',x) ;compiler bug #-:CMU x) @@ -396,8 +453,8 @@ (+ x (nth-value 0 (r2::ro/size ro))) (+ y 0))) -(defmethod medium-draw-ro* (medium (self ro/img) x y) - (ignore-errors ;xxx +(defmethod medium-draw-ro* ((medium clim:medium) (self ro/img) x y) + (progn ;; ignore-errors ;xxx (progn (assert (realp x)) (assert (realp y)) Index: closure/src/renderer/renderer2.lisp diff -u closure/src/renderer/renderer2.lisp:1.7 closure/src/renderer/renderer2.lisp:1.8 --- closure/src/renderer/renderer2.lisp:1.7 Sun Mar 13 19:03:25 2005 +++ closure/src/renderer/renderer2.lisp Sun Jul 10 13:18:35 2005 @@ -4,7 +4,7 @@ ;;; Created: somewhen late 2002 ;;; Author: Gilbert Baumann <gilbert@base-engineering.com> ;;; License: MIT style (see below) -;;; $Id: renderer2.lisp,v 1.7 2005/03/13 18:03:25 gbaumann Exp $ +;;; $Id: renderer2.lisp,v 1.8 2005/07/10 11:18:35 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1997-2003 by Gilbert Baumann @@ -1177,6 +1177,7 @@ (defvar *zzz* nil) (defvar *dyn-elm* nil) +#+emarsden2005-06-23 (defun tata (mode) (let ((clim-user::*medium* (clim:find-pane-named clim-user::*frame* 'clim-user::canvas)) (closure-protocol:*document-language* @@ -1262,7 +1263,7 @@ (clim:delete-output-record (para-box-output-record the-pb) papa) ;; now clim is so inherently broken .... (setf (para-box-output-record the-pb) - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-new-output-record (clim-user::*pane*) (funcall (para-box-genesis the-pb))))) (tata mode)) )) @@ -1272,8 +1273,7 @@ (defun format-block (item x1 x2 ss before-markers #||# pos-vertical-margin neg-vertical-margin yy) (let (res) (setf (block-box-output-record item) - (clim:with-new-output-record - (clim-user::*medium*) foo + (clim:with-new-output-record (clim-user::*pane*) foo (setf res (multiple-value-list (case (cooked-style-display (block-box-style item)) @@ -1313,7 +1313,7 @@ (yy0 nil) ;the inner top padding edge ; NIL initially to indicate that we do not know it for now. (bg-record - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-new-output-record (clim-user::*pane*) ))) ;; remember the output record of the decoration @@ -1427,7 +1427,7 @@ before-markers)))))) (setf (para-box-output-record item) - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-new-output-record (clim-user::*pane*) (setf (values pos-vertical-margin neg-vertical-margin x1 x2 yy ss block-style) (funcall (para-box-genesis item))))) @@ -1538,9 +1538,9 @@ (minf neg-vertical-margin bm))) ;; - (clim:with-output-recording-options (clim-user::*medium* :record t :draw nil) + (clim:with-output-recording-options (clim-user::*pane* :record t :draw nil) (let ((new-record - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-new-output-record (clim-user::*pane*) ;; (multiple-value-bind (x1 y1 x2 y2) (values (- x1 pl) (+ yy0 @@ -2112,7 +2112,7 @@ (values x1 (+ x1 actual-width)))))) - (let ((bg-record (clim:with-new-output-record (clim-user::*medium*)))) + (let ((bg-record (clim:with-new-output-record (clim-user::*pane*)))) (setf (table-decoration-output-record table) bg-record) (let ((yyy yy) (dangling-cells nil)) ;a list of (rowspan total-rowspan cell) pairs of cells whose row span @@ -2270,8 +2270,8 @@ (clim:clear-output-record bg-record) (multiple-value-bind (xx1 xx2) (table-column-coordinates table column-widths ci (table-cell-colspan cell)) (let ((new-record - (clim:with-output-recording-options (clim-user::*medium* :record t :draw nil) - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-output-recording-options (clim-user::*pane* :record t :draw nil) + (clim:with-new-output-record (clim-user::*pane*) (draw-box-decoration clim-user::*medium* (+ x1 xx1) y1 (+ x1 xx2) y2 (block-box-style (table-cell-content cell))))))) (clim:delete-output-record new-record (clim:output-record-parent new-record)) @@ -2284,8 +2284,8 @@ (x1 x1) (x2 x2)) (let ((new-record - (clim:with-output-recording-options (clim-user::*medium* :record t :draw nil) - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-output-recording-options (clim-user::*pane* :record t :draw nil) + (clim:with-new-output-record (clim-user::*pane*) (draw-box-decoration clim-user::*medium* x1 y1 x2 y2 (table-style table)))))) (clim:delete-output-record new-record (clim:output-record-parent new-record)) @@ -5061,6 +5061,10 @@ ;; $Log: renderer2.lisp,v $ +;; Revision 1.8 2005/07/10 11:18:35 emarsden +;; Distinguish between pane and medium in the CLIM GUI. This should +;; fix image display. +;; ;; Revision 1.7 2005/03/13 18:03:25 gbaumann ;; Gross license change ;;