[closure-cvs] CVS closure/src/renderer

dlichteblau dlichteblau at common-lisp.net
Sun Jan 7 19:33:03 UTC 2007


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
 ;;;;




More information about the Closure-cvs mailing list