Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv5242

Modified Files: bezier.lisp fontview.lisp Log Message: Cleaned up the bezier rendering a bit, and modified the font viewer accordingly.

--- /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/02 21:49:10 1.6 +++ /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/06 20:51:36 1.7 @@ -659,25 +659,41 @@ repeat (nb-lines lines) do (render-scan-lines array pixel-value i (crossings lines i) min-x min-y))))

-(defun render-to-array (positive-areas negative-areas) - (multiple-value-bind (min-x min-y max-x max-y) - (bounding-rectangle-of-areas positive-areas) - (setf min-x (* 4 (floor min-x)) - min-y (* 4 (floor min-y)) - max-x (* 4 (ceiling max-x)) - max-y (* 4 (ceiling max-y))) - (let ((result (make-array (list (- max-y min-y) (- max-x min-x)) - :element-type 'bit :initial-element 1)) - (transformation (make-scaling-transformation* 4 4))) - (loop for area in positive-areas - do (let* ((transformed-area (transform-region transformation area)) - (polygon (polygonalize transformed-area))) - (render-polygon result polygon 0 min-x min-y))) - (loop for area in negative-areas - do (let* ((transformed-area (transform-region transformation area)) - (polygon (polygonalize transformed-area))) - (render-polygon result polygon 1 min-x min-y))) - result))) +(defgeneric positive-negative-areas (design)) + +(defmethod positive-negative-areas ((design bezier-area)) + (values (list design) '())) + +(defmethod positive-negative-areas ((design bezier-union)) + (values (areas design) '())) + +(defmethod positive-negative-areas ((design bezier-difference)) + (values (positive-areas design) (negative-areas design))) + +(defmethod positive-negative-areas ((design translated-bezier-design)) + (positive-negative-areas (original-region design))) + +(defun render-to-array (design) + (multiple-value-bind (positive-areas negative-areas) + (positive-negative-areas design) + (multiple-value-bind (min-x min-y max-x max-y) + (bounding-rectangle-of-areas positive-areas) + (setf min-x (* 4 (floor min-x)) + min-y (* 4 (floor min-y)) + max-x (* 4 (ceiling max-x)) + max-y (* 4 (ceiling max-y))) + (let ((result (make-array (list (- max-y min-y) (- max-x min-x)) + :element-type 'bit :initial-element 1)) + (transformation (make-scaling-transformation* 4 4))) + (loop for area in positive-areas + do (let* ((transformed-area (transform-region transformation area)) + (polygon (polygonalize transformed-area))) + (render-polygon result polygon 0 min-x min-y))) + (loop for area in negative-areas + do (let* ((transformed-area (transform-region transformation area)) + (polygon (polygonalize transformed-area))) + (render-polygon result polygon 1 min-x min-y))) + result))))

(defparameter *x* 0) (defparameter *y* 0) @@ -697,52 +713,48 @@ (+ (* a 1.0) (* 1-a g)) (+ (* a 1.0) (* 1-a b))))))

-(defun render-through-pixmap (design medium positive-areas negative-areas) +(defgeneric ensure-pixmap (medium design)) + +(defmethod ensure-pixmap (medium design) + (let ((pixmap (gethash (list (medium-sheet medium) (resolve-ink medium) design) + *pixmaps*))) + (when (null pixmap) + (let* ((picture (render-to-array design)) + (height (array-dimension picture 0)) + (width (array-dimension picture 1)) + (reduced-picture (make-array (list (/ height 4) (/ width 4)) :initial-element 16))) + (loop for l from 0 below height + do (loop for c from 0 below width + do (when (zerop (aref picture l c)) + (decf (aref reduced-picture (floor l 4) (floor c 4)))))) + (setf pixmap + (with-output-to-pixmap (pixmap-medium + (medium-sheet medium) + :width (/ width 4) :height (/ height 4)) + (loop for l from 0 below (/ height 4) + do (loop for c from 0 below (/ width 4) + do (draw-point* + pixmap-medium c l + :ink (make-ink + medium + (aref reduced-picture l c))))))) + (setf (gethash (list (medium-sheet medium) (resolve-ink medium) design) + *pixmaps*) + pixmap))) + pixmap)) + +(defmethod ensure-pixmap (medium (design translated-bezier-design)) + (ensure-pixmap medium (original-region design))) + +(defun render-through-pixmap (design medium) (multiple-value-bind (min-x min-y) (bounding-rectangle* design) (setf min-x (floor min-x) min-y (floor min-y)) - (let ((pixmap (gethash (list (medium-sheet medium) (resolve-ink medium) design) - *pixmaps*))) - (when (null pixmap) - (let* ((picture (render-to-array positive-areas negative-areas)) - (height (array-dimension picture 0)) - (width (array-dimension picture 1)) - (reduced-picture (make-array (list (/ height 4) (/ width 4)) :initial-element 16))) - (loop for l from 0 below height - do (loop for c from 0 below width - do (when (zerop (aref picture l c)) - (decf (aref reduced-picture (floor l 4) (floor c 4)))))) - (let ((new-pixmap (with-output-to-pixmap (pixmap-medium - (medium-sheet medium) - :width (/ width 4) :height (/ height 4)) - (loop for l from 0 below (/ height 4) - do (loop for c from 0 below (/ width 4) - do (draw-point* - pixmap-medium c l - :ink (make-ink - medium - (aref reduced-picture l c)))))))) - (setf (gethash (list (medium-sheet medium) (resolve-ink medium) design) - *pixmaps*) new-pixmap - pixmap new-pixmap)))) + (let ((pixmap (ensure-pixmap medium design))) (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap) (medium-sheet medium) (+ *x* min-x) (+ *y* min-y)))))

-(defgeneric render-design-to-array (design)) - -(defmethod render-design-to-array ((design bezier-area)) - (render-to-array (list design) '())) - -(defmethod render-design-to-array ((design bezier-union)) - (render-to-array (areas design) '())) - -(defmethod render-design-to-array ((design bezier-difference)) - (render-to-array (positive-areas design) (negative-areas design))) - -(defmethod render-design-to-array ((design translated-bezier-design)) - (render-design-to-array (original-region design))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Generic drawing @@ -759,16 +771,9 @@ ;;; Drawing bezier designs to screen

-;;; Fallback methods (suitable for CLX) -(defmethod medium-draw-bezier-design* (medium (design bezier-area)) - (render-through-pixmap design medium (list design) '())) -(defmethod medium-draw-bezier-design* (medium (design bezier-union)) - (render-through-pixmap design medium (areas design) '())) -(defmethod medium-draw-bezier-design* (medium (design bezier-difference)) - (render-through-pixmap design medium (positive-areas design) (negative-areas design))) -(defmethod medium-draw-bezier-design* (medium (design translated-bezier-design)) - (multiple-value-bind (*x* *y*) (transform-position (translation design) 0 0) - (medium-draw-bezier-design* medium (original-region design)))) +;;; Fallback method (suitable for CLX) +(defmethod medium-draw-bezier-design* (medium design) + (render-through-pixmap design medium))

;;; Postscript methods (defmethod medium-draw-bezier-design* --- /project/gsharp/cvsroot/gsharp/fontview.lisp 2006/06/02 21:49:10 1.4 +++ /project/gsharp/cvsroot/gsharp/fontview.lisp 2006/06/06 20:51:36 1.5 @@ -49,7 +49,7 @@ min-y (* 4 (floor min-y)) max-x (* 4 (ceiling max-x)) max-y (* 4 (ceiling max-y))) - (let ((array (climi::render-design-to-array design))) + (let ((array (climi::render-to-array design))) (loop for y from min-y below max-y for y-index from 0 do (loop with x0 = nil