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