Revision: 4136 Author: hans URL: http://bknr.net/trac/changeset/4136
Checkpoint
U trunk/projects/quickhoney/src/pixel-pdf.lisp
Modified: trunk/projects/quickhoney/src/pixel-pdf.lisp =================================================================== --- trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-14 23:17:22 UTC (rev 4135) +++ trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-15 17:10:09 UTC (rev 4136) @@ -7,21 +7,58 @@ (cl-gd:with-image-from-file* (pixel-pathname) (pdf:with-document () (pdf:with-page () - (pdf:translate 30.0 80.0) - (let ((scale (float (/ +paper-width+ (max (cl-gd:image-width) (cl-gd:image-height)))))) - (pdf:scale scale scale)) - (cl-gd:do-rows (y) - (cl-gd:do-pixels-in-row (x) - ;; XXX true-color-behandlung fehlt. - (let ((color (cl-gd:raw-pixel)) - (img (cl-gd::img cl-gd::*default-image*))) - (pdf:set-rgb-fill (float (/ (cl-gd::gd-image-get-red img color) 256)) - (float (/ (cl-gd::gd-image-get-green img color) 256)) - (float (/ (cl-gd::gd-image-get-blue img color) 256)))) - (let ((y (- (cl-gd:image-height) y))) - (pdf:move-to x y) - (pdf:line-to x (1+ y)) - (pdf:line-to (1+ x) (1+ y)) - (pdf:line-to (1+ x) y)) - (pdf:close-and-fill)))) + (let* ((width (cl-gd:image-width)) + (height (cl-gd:image-height)) + (scale (float (/ +paper-width+ (max width height)))) + (seen (make-array (list width height) + :element-type 'boolean :initial-element nil)) + (pixels (make-array (list width height))) + (img (cl-gd::img cl-gd::*default-image*)) + (dirs #1=(0 -1 1 0 0 1 -1 0 . #1#))) + (labels + ((fill-from (from-x from-y color) + (labels ((same-color (x y) + (format t "same-color ~A/~A~%" x y) + (unless (or (>= x width) + (>= y height) + (< x 0) + (< y 0)) + (eql color (aref pixels x y)))) + (next-step (x y) + (dotimes (i 4) + (let ((x (+ x (car dirs))) + (y (+ y (cadr dirs)))) + (format t "checking ~A/~A~%" x y) + (cond + ((and (= x from-x) + (= y from-y)) + (pdf:line-to x y) + (pdf:close-and-fill) + (return-from fill-from (values x y))) + ((same-color x y) + (setf (aref seen x y) t) + (pdf:line-to x y) + (format t "same here ~A/~A~%" x y) + (return-from next-step (values x y))) + (t + (setf dirs (cddr dirs)))))) + (error 'did-not-terminate))) + ;; XXX true-color-behandlung fehlt. + (pdf:set-rgb-fill (float (/ (cl-gd::gd-image-get-red img color) 256)) + (float (/ (cl-gd::gd-image-get-green img color) 256)) + (float (/ (cl-gd::gd-image-get-blue img color) 256))) + (format t "fill from ~A/~A~%" from-x from-y) + (pdf:move-to from-x from-y) + (loop (multiple-value-setq (from-x from-y) + (next-step from-x from-y)))))) + (cl-gd:do-rows (y) + (cl-gd:do-pixels-in-row (x) + (setf (aref pixels x y) (cl-gd:raw-pixel)))) + (pdf:translate 30.0 80.0) + (pdf:scale scale scale) + (dotimes (y height) + (dotimes (x width) + (unless (aref seen x y) + (fill-from x y (aref pixels x y)) + (format t "filled at ~A/~A~%" x y))))))) (pdf:write-document (make-pathname :type "pdf" :defaults pixel-pathname))))) \ No newline at end of file