[bknr-cvs] hans changed trunk/projects/quickhoney/src/pixel-pdf.lisp

[BKNR Commits]

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