Update of /project/closure/cvsroot/closure/src/renderer In directory clnet:/tmp/cvs-serv18168/src/renderer

Modified Files: clim-device.lisp images.lisp x11.lisp Log Message:

Moved AIMAGE drawing routines into McCLIM.

--- /project/closure/cvsroot/closure/src/renderer/clim-device.lisp 2007/01/02 12:08:44 1.14 +++ /project/closure/cvsroot/closure/src/renderer/clim-device.lisp 2007/01/07 19:33:03 1.15 @@ -190,8 +190,9 @@ ;;; (values (r2::background-%pixmap bg) ;;; (r2::background-%mask bg)))))

-(defmethod update-lazy-object (document (self null)) - nil) +;; apparently unused --dfl +;;;(defmethod update-lazy-object (document (self null)) +;;; nil)

(defun map-region-rectangles (fun region) (clim:map-over-region-set-regions @@ -221,27 +222,29 @@ (+ (second q) (fourth q)))))) res))

-(defun background-pixmap+mask (document drawable bg) - (cond ((r2::background-%pixmap bg) - ;; already there - (values (r2::background-%pixmap bg) - (r2::background-%mask bg))) - (t - (let ((aimage #+NIL(r2::document-fetch-image document nil (r2::background-image bg)) - (r2::url->aimage document (r2::background-image bg) nil) - )) - ;; arg, jetzt haben wir wieder broken images - (cond ((eql nil aimage) - (values :none)) - (t - (cond ((eq aimage :error) - (setf (r2::background-%pixmap bg) :none) ) - (t - (let ((pm (ws/x11::aimage->pixmap+mask drawable aimage))) - (setf (r2::background-%pixmap bg) (car pm) - (r2::background-%mask bg) (cadr pm))))) - (values (r2::background-%pixmap bg) - (r2::background-%mask bg)))))) )) +;; apparently unused --dfl + +;;;(defun background-pixmap+mask (document drawable bg) +;;; (cond ((r2::background-%pixmap bg) +;;; ;; already there +;;; (values (r2::background-%pixmap bg) +;;; (r2::background-%mask bg))) +;;; (t +;;; (let ((aimage #+NIL(r2::document-fetch-image document nil (r2::background-image bg)) +;;; (r2::url->aimage document (r2::background-image bg) nil) +;;; )) +;;; ;; arg, jetzt haben wir wieder broken images +;;; (cond ((eql nil aimage) +;;; (values :none)) +;;; (t +;;; (cond ((eq aimage :error) +;;; (setf (r2::background-%pixmap bg) :none) ) +;;; (t +;;; (let ((pm (ws/x11::aimage->pixmap+mask drawable aimage))) +;;; (setf (r2::background-%pixmap bg) (car pm) +;;; (r2::background-%mask bg) (cadr pm))))) +;;; (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 @@ -357,43 +360,45 @@ ;; and xlib:with-gcontext also is broken! (setf (xlib:gcontext-clip-mask ggc) old-clip-mask))))))

-(defun x11-draw-background (document medium bg x y width height - &optional (bix x) (biy y) (biwidth width) (biheight height)) - (when bg - ;; #+NIL - ;; (unless (eql (background-color bg) :transparent) - ;; (ws/x11::fill-rectangle* drawable gcontext - ;; (round x) (round y) - ;; (max 0 (round width)) - ;; (max 0 (round height)) - ;; (background-color bg)) ) - (unless (eql (r2::background-image bg) :none) - (multiple-value-bind (pixmap mask) - (background-pixmap+mask document (sheet-direct-mirror (medium-sheet medium)) bg) - #+emarsden2005-07-15 - (print (list 'x11-draw-background pixmap mask)) - (unless (eql pixmap :none) - (let* ((iw (xlib:drawable-width pixmap)) - (ih (xlib:drawable-height pixmap)) - (w (ecase (r2::background-repeat bg) - ((:repeat :repeat-x) width) - ((:no-repeat :repeat-y) iw))) - (h (ecase (r2::background-repeat bg) - ((:repeat :repeat-y) height) - ((:no-repeat :repeat-x) ih))) ) - (let ((hp (car (r2::background-position bg))) - (vp (cdr (r2::background-position bg)))) - (let ((xo (+ bix (resolve-background-position hp iw biwidth))) - (yo (+ biy (resolve-background-position vp ih biheight)))) - (medium-draw-pm3-tiled* medium pixmap mask - (round (ecase (r2::background-repeat bg) - ((:repeat :repeat-x) x) - ((:no-repeat :repeat-y) (+ xo)))) - (round (ecase (r2::background-repeat bg) - ((:repeat :repeat-y) y) - ((:no-repeat :repeat-x) (+ yo)))) - (round w) (round h) - (round (+ xo)) (round (+ yo)))))) ))) )) +;; apparently unused --dfl + +;;;(defun x11-draw-background (document medium bg x y width height +;;; &optional (bix x) (biy y) (biwidth width) (biheight height)) +;;; (when bg +;;; ;; #+NIL +;;; ;; (unless (eql (background-color bg) :transparent) +;;; ;; (ws/x11::fill-rectangle* drawable gcontext +;;; ;; (round x) (round y) +;;; ;; (max 0 (round width)) +;;; ;; (max 0 (round height)) +;;; ;; (background-color bg)) ) +;;; (unless (eql (r2::background-image bg) :none) +;;; (multiple-value-bind (pixmap mask) +;;; (background-pixmap+mask document (sheet-direct-mirror (medium-sheet medium)) bg) +;;; #+emarsden2005-07-15 +;;; (print (list 'x11-draw-background pixmap mask)) +;;; (unless (eql pixmap :none) +;;; (let* ((iw (xlib:drawable-width pixmap)) +;;; (ih (xlib:drawable-height pixmap)) +;;; (w (ecase (r2::background-repeat bg) +;;; ((:repeat :repeat-x) width) +;;; ((:no-repeat :repeat-y) iw))) +;;; (h (ecase (r2::background-repeat bg) +;;; ((:repeat :repeat-y) height) +;;; ((:no-repeat :repeat-x) ih))) ) +;;; (let ((hp (car (r2::background-position bg))) +;;; (vp (cdr (r2::background-position bg)))) +;;; (let ((xo (+ bix (resolve-background-position hp iw biwidth))) +;;; (yo (+ biy (resolve-background-position vp ih biheight)))) +;;; (medium-draw-pm3-tiled* medium pixmap mask +;;; (round (ecase (r2::background-repeat bg) +;;; ((:repeat :repeat-x) x) +;;; ((:no-repeat :repeat-y) (+ xo)))) +;;; (round (ecase (r2::background-repeat bg) +;;; ((:repeat :repeat-y) y) +;;; ((:no-repeat :repeat-x) (+ yo)))) +;;; (round w) (round h) +;;; (round (+ xo)) (round (+ yo)))))) ))) ))

;;;; --------------------------------------------------------------------------------

@@ -406,8 +411,7 @@ (actual-height :initarg :actual-height :initform nil :documentation "The actual (scaled) height of this image.") - (pixmap :initform nil) - (mask :initform nil))) + (design :initform nil)))

(defmethod gui::deconstruct-robj ((self ro/img)) ;; no deconstructor for now ... @@ -459,60 +463,41 @@

(defmethod medium-draw-ro* ((medium clim:medium) (self ro/img) x y) - (progn ;; ignore-errors ;xxx - (progn - (assert (realp x)) - (assert (realp y)) - (with-slots (aim pixmap mask actual-width actual-height) self - (when aim ;only draw something, if the image is already there. - ;; xxx - (let ((da (sheet-direct-mirror (medium-sheet medium)))) - (when (and aim actual-width actual-height) ;xxx - (unless pixmap - (let ((r (clue-gui2::make-pixmap-from-aimage da aim - (max 1 (round actual-width)) - (max 1 (round actual-height))))) - (setf pixmap (car r) - mask (cadr r))))) - (when aim - (multiple-value-bind (x y) (transform-position - (sheet-device-transformation (medium-sheet medium)) - x y) - (setf x (round x)) - (setf y (round y)) - (let ((gcontext (xlib:create-gcontext :drawable da))) - (cond ((not (null mask)) - (xlib:with-gcontext (gcontext - :clip-mask mask - :clip-x x - :clip-y (- y actual-height)) - (xlib:copy-area pixmap gcontext 0 0 actual-width actual-height - da x (- y actual-height))) ) - (t - (xlib:copy-area pixmap gcontext 0 0 actual-width actual-height - da x (- y actual-height) )))))))))))) - -#+NIL -(climi::def-grecording draw-pm3-tiled (() pixmap mask x1 y1 w h x0 y0) - (values x1 y1 (+ x1 w) (+ y1 h))) - -(defmethod medium-draw-pm3-tiled* (medium pixmap mask x1 y1 w h x0 y0) - (let* ((da (sheet-direct-mirror (medium-sheet medium))) - #+NIL - (pixmap+mask (clue-gui2::make-pixmap-from-aimage da aim - (r2::aimage-width aim) - (r2::aimage-height aim))) - #+NIL - (pixmap (first pixmap+mask)) - #+NIL - (mask (second pixmap+mask))) - (multiple-value-bind (x1 y1) (transform-position (sheet-device-transformation (medium-sheet medium)) - x1 y1) - (setf x1 (round x1)) - (setf y1 (round y1)) - ;;; - (let ((gcontext (xlib:create-gcontext :drawable da))) - (ws/x11::x11-put-pixmap-tiled da gcontext pixmap mask x1 y1 w h x0 y0) )))) + (assert (realp x)) + (assert (realp y)) + (with-slots (aim design actual-width actual-height) self + (when aim ;only draw something, if the image is already there. + ;; xxx + (when (and actual-width actual-height (not design)) ;xxx + (setf design + (clue-gui2::make-design-from-aimage medium + aim + (max 1 (round actual-width)) + (max 1 (round actual-height))))) + (climi::medium-draw-image-design* medium design x y)))) + +;; apparently unused --dfl +;;;#+NIL +;;;(climi::def-grecording draw-pm3-tiled (() pixmap mask x1 y1 w h x0 y0) +;;; (values x1 y1 (+ x1 w) (+ y1 h))) +;;; +;;;(defmethod medium-draw-pm3-tiled* (medium pixmap mask x1 y1 w h x0 y0) +;;; (let* ((da (sheet-direct-mirror (medium-sheet medium))) +;;; #+NIL +;;; (pixmap+mask (clue-gui2::make-pixmap-from-aimage da aim +;;; (r2::aimage-width aim) +;;; (r2::aimage-height aim))) +;;; #+NIL +;;; (pixmap (first pixmap+mask)) +;;; #+NIL +;;; (mask (second pixmap+mask))) +;;; (multiple-value-bind (x1 y1) (transform-position (sheet-device-transformation (medium-sheet medium)) +;;; x1 y1) +;;; (setf x1 (round x1)) +;;; (setf y1 (round y1)) +;;; ;;; +;;; (let ((gcontext (xlib:create-gcontext :drawable da))) +;;; (ws/x11::x11-put-pixmap-tiled da gcontext pixmap mask x1 y1 w h x0 y0) ))))

#+NIL --- /project/closure/cvsroot/closure/src/renderer/images.lisp 2007/01/03 15:39:29 1.4 +++ /project/closure/cvsroot/closure/src/renderer/images.lisp 2007/01/07 19:33:03 1.5 @@ -55,7 +55,7 @@ (unless (url:url-p url) (setq url (url:parse-url url))) (multiple-value-bind (aimage condition) - (ignore-errors + (progn ;ignore-errors (netlib:with-open-document ((input mime-type) url nil ;reload-p t ;binary-p --- /project/closure/cvsroot/closure/src/renderer/x11.lisp 2006/12/30 15:13:55 1.10 +++ /project/closure/cvsroot/closure/src/renderer/x11.lisp 2007/01/07 19:33:03 1.11 @@ -480,31 +480,6 @@

;;;; ==========================================================================================

-(defun make-ximage-for-aimage (aimage depth translator) - #+EXCL (declare (:explain :calls)) - (let* ((width (imagelib:aimage-width aimage)) - (height (imagelib:aimage-height aimage)) - (idata (imagelib:aimage-data aimage)) - ;; FIXME: this (and the :BITS-PER-PIXEL, below) is a hack on - ;; top of a hack. At some point in the past, XFree86 and/or - ;; X.org decided that they would no longer support pixmaps - ;; with 24 bpp, which seems to be what most AIMAGEs want to - ;; be. For now, force everything to a 32-bit pixmap. - (xdata (make-array (list height width) :element-type '(unsigned-byte 32))) - (ximage (xlib:create-image :width width - :height height - :depth depth - :bits-per-pixel 32 - :data xdata))) - (declare (type (simple-array (unsigned-byte 32) (* *)) idata) - #+NIL(type (simple-array (unsigned-byte 8) (* *)) xdata) - ) - (loop for x fixnum from 0 below width do - (loop for y fixnum from 0 below height do - (setf (aref xdata y x) - (funcall translator x y (ldb (byte 24 0) (aref idata y x)))))) - ximage)) - (defun ximage-translator** (window) (ximage-translator* (pixel-translator-code (xlib:window-colormap window)) (xlib:drawable-depth window))) @@ -570,40 +545,6 @@ (setf (getf (colormap-plist (xlib:window-colormap window)) 'ximage-translator) (compile nil (ximage-translator** window)))))

-#+NIL ;; not yet trusted -(defun aimage->ximage (drawable aimage) - (funcall (ximage-translator drawable) aimage)) - -(defun aimage->ximage (drawable aimage) - (make-ximage-for-aimage aimage - (xlib:drawable-depth drawable) - (pixel-translator (xlib:window-colormap drawable)))) - -(defun make-mask-from-aimage (drawable aim) - (let* ((width (imagelib:aimage-width aim)) - (height (imagelib:aimage-height aim)) - (bitmap (xlib:create-pixmap :drawable drawable - :width width - :height height - :depth 1)) - (gc (xlib:create-gcontext :drawable bitmap :foreground 1 :background 0)) - (idata (imagelib:aimage-data aim)) - (xdata (make-array (list height width) :element-type '(unsigned-byte 1))) - (im (xlib:create-image :width width - :height height - :depth 1 - :data xdata)) ) - (dotimes (y width) - (dotimes (x height) - (if (> (aref idata x y) #x80000000) - (setf (aref xdata x y) 0) - (setf (aref xdata x y) 1)))) - (unless (or (>= width 2048) (>= height 2048)) ;### CLX breaks here - (xlib:put-image bitmap gc im :src-x 0 :src-y 0 :x 0 :y 0 :width width :height height - :bitmap-p nil)) - (xlib:free-gcontext gc) - bitmap)) - ;;;; -------------------------------------------------------------------------- ;;;; colours ;;;;