[closure-cvs] CVS update: closure/src/renderer/clim-device.lisp closure/src/renderer/renderer2.lisp
Eric Marsden
emarsden at common-lisp.net
Sun Jul 10 11:18:36 UTC 2005
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 at 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
;;
More information about the Closure-cvs
mailing list