[bknr-cvs] hans changed trunk/projects/quickhoney/src/

[BKNR Commits]

Revision: 4141
Author: hans
URL: http://bknr.net/trac/changeset/4141

it is slow, but it works!
U   trunk/projects/quickhoney/src/pixel-pdf.lisp
U   trunk/projects/quickhoney/src/turtle.lisp

Modified: trunk/projects/quickhoney/src/pixel-pdf.lisp
===================================================================
--- trunk/projects/quickhoney/src/pixel-pdf.lisp	2008-12-18 06:39:24 UTC (rev 4140)
+++ trunk/projects/quickhoney/src/pixel-pdf.lisp	2008-12-18 08:04:11 UTC (rev 4141)
@@ -5,12 +5,15 @@
 
 (defclass converter ()
   ((x :initform 0
-      :accessor x)
+      :accessor x
+      :type fixnum)
    (y :initform 0
-      :accessor y)
+      :accessor y
+      :type fixnum)
    (pixels :reader pixels)
-   (seen :reader seen)
-   (color :accessor color)
+   (seen :reader %seen)
+   (color :accessor color
+          :type fixnum)
    (looking-in-direction :initform :east
                          :accessor looking-in-direction)))
 
@@ -20,6 +23,12 @@
 (defun height (converter)
   (array-dimension (pixels converter) 1))
 
+(defun seen (x y)
+  (aref (%seen *converter*) x y))
+
+(defun (setf seen) (new-value x y)
+  (setf (aref (%seen *converter*) x y) new-value))
+
 (defmethod initialize-instance :after ((converter converter) &key image-pathname)
   (cl-gd:with-image-from-file* (image-pathname)
     (let ((width (cl-gd:image-width))
@@ -27,7 +36,8 @@
       (with-slots (seen pixels) converter
         (setf seen (make-array (list width height)
                                :element-type 'boolean :initial-element nil)
-              pixels (make-array (list width height)))
+              pixels (make-array (list width height)
+                                 :element-type 'fixnum))
         (cl-gd:do-rows (y)
           (cl-gd:do-pixels-in-row (x)
             (setf (aref pixels x y) (cl-gd:raw-pixel))))))))
@@ -110,29 +120,41 @@
   (turtle:forward))
 
 (defun set-color (color)
-  (format t "can't set PDF color ~A yet~%" color))
+  #+(or) (format t "can't set PDF color ~A yet~%" color))
 
 (defun move-to-pixel (x y)
   (setf (x *converter*) x
-        (y *converter*) y
-        (aref (seen *converter*) x y) t))
+        (y *converter*) y))
 
+(defun flood-fill ()
+  (labels
+      ((maybe-descend (x y)
+         (when (and (same-color x y)
+                    (not (seen x y)))
+           (recurse x y)))
+       (recurse (x y)
+         (setf (seen x y) t)
+         (maybe-descend (1- x) y)
+         (maybe-descend (1+ x) y)
+         (maybe-descend x (1- y))
+         (maybe-descend x (1+ y))))
+    (recurse (x *converter*) (y *converter*))))
+
 (defun fill-from (from-x from-y)
   ;; XXX true-color-behandlung fehlt.
-  (format t "filling at ~A/~A~%" from-x from-y)
-  (setf (aref (seen *converter*) from-x from-y) t
-        (looking-in-direction *converter*) :east
+  #+(or) (format t "filling at ~A/~A~%" from-x from-y)
+  (setf (looking-in-direction *converter*) :east
         (x *converter*) from-x
         (y *converter*) from-y
         (color *converter*) (aref (pixels *converter*) from-x from-y))
+  (flood-fill)
   (set-color (color *converter*))
   (turtle:reset)
   (turtle:move-to from-x from-y)
   (turtle:pen-down)
   (turtle:forward)
-  (do ((moved nil t))
-      ((and moved
-            (eql from-x (turtle:x))
+  (do ()
+      ((and (eql from-x (turtle:x))
             (eql from-y (turtle:y))))
     (cond
       ((can-turn-right)
@@ -152,10 +174,10 @@
             (x *converter*) (y *converter*)
             (looking-in-direction *converter*)
             turtle::*turtle*)
-    (assert (and (<= (abs (- (x *converter*) (turtle:x))) 1)
-                 (<= (abs (- (y *converter*) (turtle:y))) 1))))
+    #+(or) (assert (and (<= (abs (- (x *converter*) (turtle:x))) 1)
+                        (<= (abs (- (y *converter*) (turtle:y))) 1))))
   (turtle:pen-up)
-  (print-seen))
+  #+(or) (print-seen))
 
 (defun pixels-pdf (image-pathname)
   (let ((*converter* (make-instance 'converter :image-pathname image-pathname)))
@@ -168,14 +190,14 @@
           (pdf:scale scale scale)
           (dotimes (y (height *converter*))
             (dotimes (x (width *converter*))
-              (unless (aref (seen *converter*) x y)
+              (unless (seen x y)
                 (fill-from x y))))))
       (pdf:write-document (make-pathname :type "pdf" :defaults image-pathname)))))
 
 (defun print-seen ()
   (dotimes (y (height *converter*))
     (dotimes (x (width *converter*))
-      (write-char (if (aref (seen *converter*) x (- (height *converter*) y 1))
+      (write-char (if (seen x (- (height *converter*) y 1))
                       #\* #\.)
                   *error-output*))
     (terpri *error-output*)))
\ No newline at end of file

Modified: trunk/projects/quickhoney/src/turtle.lisp
===================================================================
--- trunk/projects/quickhoney/src/turtle.lisp	2008-12-18 06:39:24 UTC (rev 4140)
+++ trunk/projects/quickhoney/src/turtle.lisp	2008-12-18 08:04:11 UTC (rev 4141)
@@ -2,9 +2,11 @@
 
 (defclass turtle ()
   ((x :initform 0
-      :accessor turtle-x)
+      :accessor turtle-x
+      :type fixnum)
    (y :initform 0
-      :accessor turtle-y)
+      :accessor turtle-y
+      :type fixnum)
    (directions :initform '#1=(:east :south :west :north . #1#)
                :accessor turtle-directions)
    (drawing :accessor turtle-drawing