Update of /project/closure/cvsroot/closure/src/gui In directory clnet:/tmp/cvs-serv18168/src/gui Modified Files: dce-and-pce.lisp gui.lisp Log Message: Moved AIMAGE drawing routines into McCLIM. --- /project/closure/cvsroot/closure/src/gui/dce-and-pce.lisp 2006/12/31 15:42:40 1.4 +++ /project/closure/cvsroot/closure/src/gui/dce-and-pce.lisp 2007/01/07 19:33:02 1.5 @@ -116,13 +116,13 @@ aimage width height - pixmap + design refcount) -(defun make-pixmap-from-aimage (drawable aimage width height) +(defun make-design-from-aimage (medium aimage width height) (dolist (k *pixmap-cache* - (let ((res (really-make-pixmap-from-aimage - drawable aimage width height))) + (let ((res (really-make-design-from-aimage + medium aimage width height))) (when *debug-pixmap-cache-p* (format T "~&;; ++ [init] ~A ~Dx~D " (getf (imagelib:aimage-plist aimage) :url) @@ -131,7 +131,7 @@ (push (make-pce :aimage aimage :width width :height height - :pixmap res + :design res :refcount 1) *pixmap-cache*) res)) @@ -144,21 +144,22 @@ width height)) (incf (pce-refcount k)) - (return (pce-pixmap k))))) + (return (pce-design k))))) -(defun really-make-pixmap-from-aimage (drawable aimage width height) - (multiple-value-list - (gui::aimage->pixmap+mask/raw drawable - (imagelib:scale-aimage aimage width height)))) +(defun really-make-design-from-aimage (medium aimage width height) + (climi::make-rgb-image-design medium + (imagelib::aimage-rgb-image + (imagelib:scale-aimage aimage width height)))) (defun reset-caches () (setf *dcache* nil *pixmap-cache* nil)) -(defun ws/x11::aimage->pixmap+mask (drawable aimage) - (make-pixmap-from-aimage drawable aimage - (imagelib:aimage-width aimage) - (imagelib:aimage-height aimage))) +;; apparently unused --dfl +;;;(defun ws/x11::aimage->pixmap+mask (drawable aimage) +;;; (make-design-from-aimage drawable aimage +;;; (imagelib:aimage-width aimage) +;;; (imagelib:aimage-height aimage))) (defclass r2::ro/img () ((url :initarg :url) @@ -166,8 +167,7 @@ (aim :initform nil) (width :initform nil) (height :initform nil) - (pixmap :initform nil) - (mask :initform nil))) + (design :initform nil))) (defmethod print-object ((self r2::ro/img) sink) (format sink "#<~S url=~S>" (type-of self) @@ -176,15 +176,14 @@ :unbound))) (defmethod deconstruct-robj ((self r2::ro/img)) - (with-slots ((aim-orig aim-orig) (pixmap pixmap) (mask mask)) self - (when pixmap - (deref-aimage-pixmap aim-orig (list pixmap mask)) - (setf pixmap nil - mask nil)))) + (with-slots ((aim-orig aim-orig) (design design)) self + (when design + (deref-aimage-design aim-orig design) + (setf design nil)))) -(defun deref-aimage-pixmap (aimage pixmap) +(defun deref-aimage-design (aimage design) (declare (ignore aimage)) - (let ((pce (find pixmap *pixmap-cache* :key #'pce-pixmap :test #'equal))) + (let ((pce (find design *design-cache* :key #'pce-design :test #'equal))) (assert (not (null pce))) (assert (> (pce-refcount pce) 0)) (when *debug-pixmap-cache-p* @@ -198,19 +197,13 @@ (let ((n 0)) (setf *pixmap-cache* (mapcan (lambda (pce) - (cond ((eql (pce-refcount pce) 0) - (and (car (pce-pixmap pce)) - (incf n (* (xlib:drawable-width (car (pce-pixmap pce))) - (xlib:drawable-height (car (pce-pixmap pce))))) - (xlib:free-pixmap (car (pce-pixmap pce)))) - (and (cadr (pce-pixmap pce)) - (incf n (* (xlib:drawable-width (cadr (pce-pixmap pce))) - (xlib:drawable-height (cadr (pce-pixmap pce))))) - (xlib:free-pixmap (cadr (pce-pixmap pce)))) - - nil) - (t - (list pce)))) + (cond + ((and (eql (pce-refcount pce) 0) (pce-design pce)) + (incf n (* (pce-width pce) (pce-height pce))) + (climi::free-image-design (pce-design pce)) + nil) + (t + (list pce)))) *pixmap-cache*)) n)) @@ -226,7 +219,7 @@ (values width height 0))) (defmethod r2::ro/resize ((self r2::ro/img) new-width new-height) - (with-slots (width height aim aim-orig pixmap mask) self + (with-slots (width height aim aim-orig design) self (cond ((and new-width new-height) (setf width (round new-width) height (round new-height)) ) @@ -247,36 +240,34 @@ (unless (and (eql new-width width) (eql new-height height)) (setf width new-width height new-height - pixmap nil mask nil + design nil aim nil #+(OR) (if aim (imagelib:scale-aimage aim-orig new-width new-height) nil) ))))) )) -(defun ensure-ro/img-pixmap (drawable self) - (with-slots (aim-orig width height pixmap mask) self - (when aim-orig - (unless pixmap - (let ((r (make-pixmap-from-aimage drawable aim-orig width height))) - (setf pixmap (car r) - mask (cadr r))))))) - -(defmethod r2::x11-draw-robj (drawable gcontext (self r2::ro/img) box x y) - (declare (ignore box)) - (setq x (round x)) - (setq y (round y)) - (with-slots ((aim-orig aim-orig) (width width) (height height) - (pixmap pixmap) - (mask mask)) - self - (ensure-ro/img-pixmap drawable self) - (when aim-orig - (cond ((not (null mask)) - (xlib:with-gcontext (gcontext :clip-mask mask - :clip-x x - :clip-y (- y height)) - (xlib:copy-area pixmap gcontext 0 0 width height - drawable x (- y height))) ) - (t - (xlib:copy-area pixmap gcontext 0 0 width height - drawable x (- y height) )))))) +;; apparently unused --dfl +;;;(defun ensure-ro/img-pixmap (drawable self) +;;; (with-slots (aim-orig width height design mask) self +;;; (when (and aim-orig (not design)) +;;; (setf design (make-design-from-aimage drawable aim-orig width height))))) + +;; apparently unused --dfl +;;;(defmethod r2::x11-draw-robj (drawable gcontext (self r2::ro/img) box x y) +;;; (declare (ignore box)) +;;; (setq x (round x)) +;;; (setq y (round y)) +;;; (with-slots ((aim-orig aim-orig) (width width) (height height) +;;; (design design)) +;;; self +;;; (ensure-ro/img-pixmap drawable self) +;;; (when aim-orig +;;; (cond ((not (null mask)) +;;; (xlib:with-gcontext (gcontext :clip-mask mask +;;; :clip-x x +;;; :clip-y (- y height)) +;;; (xlib:copy-area pixmap gcontext 0 0 width height +;;; drawable x (- y height))) ) +;;; (t +;;; (xlib:copy-area pixmap gcontext 0 0 width height +;;; drawable x (- y height) )))))) ;;; ---------------------------------------------------------------------------------------------------- --- /project/closure/cvsroot/closure/src/gui/gui.lisp 2006/12/30 15:08:09 1.8 +++ /project/closure/cvsroot/closure/src/gui/gui.lisp 2007/01/07 19:33:02 1.9 @@ -403,29 +403,6 @@ (defvar cl-user::*html-dtd* nil) -(defun aimage->pixmap+mask/raw (drawable aim) - (let* ((width (r2::aimage-width aim)) - (height (r2::aimage-height aim)) - (depth (xlib:drawable-depth drawable)) - (im (ws/x11::aimage->ximage drawable aim))) - (setf width (max width 1)) - (setf height (max height 1)) - (values - (let* ((pixmap (xlib:create-pixmap :drawable drawable - :width width - :height height - :depth depth)) - (gc (xlib:create-gcontext :drawable pixmap))) - (unless (or (>= width 2048) (>= height 2048)) ;### CLX bug - (xlib:put-image pixmap gc im - :src-x 0 :src-y 0 - :x 0 :y 0 - :width width :height height)) - (xlib:free-gcontext gc) - pixmap) - (when (imagelib:aimage-alpha-p aim) - (ws/x11::make-mask-from-aimage drawable aim))))) - (defun init-closure () ;; Init general closure stuff #||