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

Modified Files: html-style.lisp Log Message:

Moved AIMAGE drawing routines into McCLIM.

--- /project/closure/cvsroot/closure/src/html/html-style.lisp 2007/01/02 14:00:54 1.11 +++ /project/closure/cvsroot/closure/src/html/html-style.lisp 2007/01/07 19:33:02 1.12 @@ -1128,64 +1128,66 @@ (t (values 20 20 0)))))

-(defmethod update-lazy-object (document (self ro/image)) - (with-slots (url fixed-size-p) self - (let ((aim (document-fetch-image document self url))) - (with-slots (iwidth iheight (self.aimage aimage) awidth aheight) self - (setf iwidth (aimage-width aim) - iheight (aimage-height aim) - self.aimage aim) - (unless awidth (setf awidth (aimage-width aim))) - (unless aheight (setf aheight (aimage-height aim))) - )) - (cond (fixed-size-p - ;; **hack** - (with-slots (aimage awidth aheight) self - (let ((drawable (xlib:screen-root (xlib:display-default-screen clue-gui2::*dpy*)))) - (with-slots (pixmap mask) self - (unless pixmap - (let ((q (clue-gui2::make-pixmap-from-aimage drawable aimage awidth aheight))) - (setf pixmap (car q) - mask (cadr q))))))) - ;; return - nil) - (t - ;; return - t)))) - -(defmethod x11-draw-robj (drawable gcontext (self ro/image) box x y) - (setf x (floor x)) - (setf y (floor y)) - (with-slots (alt awidth aheight aimage url) self - (cond (aimage - (unless awidth (setf awidth (aimage-width aimage))) - (unless aheight (setf aheight (aimage-height aimage))) - (with-slots (pixmap mask) self - (unless pixmap - (warn "Rendering pixmap while redisplay (~S)" - url) - (let ((q (clue-gui2::make-pixmap-from-aimage drawable aimage awidth aheight))) - (setf pixmap (car q) - mask (cadr q)))) - (cond ((not (null mask)) - (xlib:with-gcontext (gcontext :clip-mask mask - :clip-x x - :clip-y (- y aheight)) - (xlib:copy-area pixmap gcontext 0 0 awidth aheight - drawable x (- y aheight))) ) - (t - (xlib:copy-area pixmap gcontext 0 0 awidth aheight - drawable x (- y aheight) ))))) - - (t - (multiple-value-bind (w h) (ro/size self) - (setf w (floor w)) - (setf h (floor h)) - (xlib:with-gcontext (gcontext - :foreground (ws/x11::x11-find-color drawable :black) - ) - (xlib:draw-glyphs drawable gcontext x y (rod-string alt)) - (xlib:draw-rectangle drawable gcontext x (- y h) w h)))) ))) +;; apparently unused --dfl +;;;(defmethod update-lazy-object (document (self ro/image)) +;;; (with-slots (url fixed-size-p) self +;;; (let ((aim (document-fetch-image document self url))) +;;; (with-slots (iwidth iheight (self.aimage aimage) awidth aheight) self +;;; (setf iwidth (aimage-width aim) +;;; iheight (aimage-height aim) +;;; self.aimage aim) +;;; (unless awidth (setf awidth (aimage-width aim))) +;;; (unless aheight (setf aheight (aimage-height aim))) +;;; )) +;;; (cond (fixed-size-p +;;; ;; **hack** +;;; (with-slots (aimage awidth aheight) self +;;; (let ((drawable (xlib:screen-root (xlib:display-default-screen clue-gui2::*dpy*)))) +;;; (with-slots (pixmap mask) self +;;; (unless pixmap +;;; (let ((q (clue-gui2::make-design-from-aimage drawable aimage awidth aheight))) +;;; (setf pixmap (car q) +;;; mask (cadr q))))))) +;;; ;; return +;;; nil) +;;; (t +;;; ;; return +;;; t)))) + +;; apparently unused --dfl +;;;(defmethod x11-draw-robj (drawable gcontext (self ro/image) box x y) +;;; (setf x (floor x)) +;;; (setf y (floor y)) +;;; (with-slots (alt awidth aheight aimage url) self +;;; (cond (aimage +;;; (unless awidth (setf awidth (aimage-width aimage))) +;;; (unless aheight (setf aheight (aimage-height aimage))) +;;; (with-slots (pixmap mask) self +;;; (unless pixmap +;;; (warn "Rendering pixmap while redisplay (~S)" +;;; url) +;;; (let ((q (clue-gui2::make-design-from-aimage drawable aimage awidth aheight))) +;;; (setf pixmap (car q) +;;; mask (cadr q)))) +;;; (cond ((not (null mask)) +;;; (xlib:with-gcontext (gcontext :clip-mask mask +;;; :clip-x x +;;; :clip-y (- y aheight)) +;;; (xlib:copy-area pixmap gcontext 0 0 awidth aheight +;;; drawable x (- y aheight))) ) +;;; (t +;;; (xlib:copy-area pixmap gcontext 0 0 awidth aheight +;;; drawable x (- y aheight) ))))) +;;; +;;; (t +;;; (multiple-value-bind (w h) (ro/size self) +;;; (setf w (floor w)) +;;; (setf h (floor h)) +;;; (xlib:with-gcontext (gcontext +;;; :foreground (ws/x11::x11-find-color drawable :black) +;;; ) +;;; (xlib:draw-glyphs drawable gcontext x y (rod-string alt)) +;;; (xlib:draw-rectangle drawable gcontext x (- y h) w h)))) )))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;