Revision: 4138 Author: hans URL: http://bknr.net/trac/changeset/4138
checkpoint U trunk/projects/quickhoney/src/pixel-pdf.lisp U trunk/projects/quickhoney/src/quickhoney.asd
Modified: trunk/projects/quickhoney/src/pixel-pdf.lisp =================================================================== --- trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-17 20:36:21 UTC (rev 4137) +++ trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-17 23:46:09 UTC (rev 4138) @@ -3,88 +3,155 @@ (defvar *colors* nil) (defconstant +paper-width+ 800)
+(defclass converter () + ((x :initform 0 + :accessor x) + (y :initform 0 + :accessor y) + (pixels :reader pixels) + (seen :reader seen) + (color :accessor color) + (looking-in-direction :initform :east + :accessor looking-in-direction))) + +(defun width (converter) + (array-dimension (pixels converter) 0)) + +(defun height (converter) + (array-dimension (pixels converter) 1)) + +(defmethod initialize-instance :after ((converter converter) &key image-pathname) + (cl-gd:with-image-from-file* (image-pathname) + (let ((width (cl-gd:image-width)) + (height (cl-gd:image-height))) + (with-slots (seen pixels) converter + (setf seen (make-array (list width height) + :element-type 'boolean :initial-element nil) + pixels (make-array (list width height))) + (cl-gd:do-rows (y) + (cl-gd:do-pixels-in-row (x) + (setf (aref pixels x y) (cl-gd:raw-pixel)))))))) + +(defvar *converter*) + +(defun in-range (x y) + (and (< -1 x (width *converter*)) + (< -1 y (height *converter*)))) + (defun 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)))) + (when (and (in-range x y) + (not (aref (seen *converter*) x y))) + (eql (color *converter*) (aref (pixels *converter*) x y))))
-(defun can-turn-left (x y) - (same-color (+ x (car dirs)) - (+ y (cadr dirs)))) +(defun look (direction fn) + (let ((x (x *converter*)) + (y (y *converter*))) + (ecase (looking-in-direction *converter*) + (:east + (ecase direction + (:left + (funcall fn (1+ x) (1+ y))) + (:forward + (funcall fn (1+ x) y)) + (:right + (funcall fn (1+ x) (1- y))))) + (:south + (ecase direction + (:left + (funcall fn (1+ x) (1- y))) + (:forward + (funcall fn x (1- y))) + (:right + (funcall fn (1- x) (1- y))))) + (:west + (ecase direction + (:left + (funcall fn (1- x) (1- y))) + (:forward + (funcall fn (1- x) y)) + (:right + (funcall fn (1- x) (1+ y))))) + (:north + (ecase direction + (:left + (funcall fn (1- x) (1+ y))) + (:forward + (funcall fn x (1+ y))) + (:right + (funcall fn (1+ x) (1+ y))))))))
-(defun next-step (x y) - (dotimes (i 3) - (let ((x (+ x (car dirs))) - (y (+ y (cadr dirs)))) - (format t "checking ~A/~A~%" x y) - (cond - ((and (= x from-x) - (= y from-y)) - (turtle:pen-up) - (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))))))) +(defun can-turn-right () + (look :right #'same-color))
+(defun can-go-forward () + (look :forward #'same-color)) + (defun turn (direction) (turtle:turn direction) - (setf dirs - (ecase direction - (:left (cdddr dirs)) - (:right (cdr dirs))))) + (setf (looking-in-direction *converter*) + (ecase (looking-in-direction *converter*) + (:east + (ecase direction + (:left :north) + (:right :south))) + (:south + (ecase direction + (:left :east) + (:right :west))) + (:west + (ecase direction + (:left :south) + (:right :north))) + (:north + (ecase direction + (:left :west) + (:right :east))))))
(defun forward () - (mark-right-ahead) - (turtle:forward)) + (turtle:forward) + (setf (aref (seen *converter*) (x *converter*) (y *converter*)) t) + (look :forward (lambda (x y) + (setf (x *converter*) x + (y *converter*) y))))
-(defun fill-from (from-x from-y color) +(defun set-color (color) + (setf (color *converter*) color) + (format t "can't set PDF color ~A yet~%" color)) + +(defun fill-from (from-x from-y) ;; 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 "filling at ~A/~A~%" from-x from-y) + (setf (aref (seen *converter*) from-x from-y) t) + (set-color (aref (pixels *converter*) from-x from-y)) (turtle:move-to from-x from-y) (turtle:pen-down) - (turtle:forward) - (do ((x 0) - (y 0)) - ((and (eql from-x (turtle:x)) - (eql from-y (turlle:y)))) + (do ((moved nil t)) + ((and moved + (eql from-x (turtle:x)) + (eql from-y (turtle:y)))) (cond - ((can-turn-left) - (turn :left)) - ((can-go-straight)) - ((can-go-right) - (turn :right))) - (forward)) + ((can-turn-right) + (turn :right) + (forward)) + ((can-go-forward) + (forward)) + (t + (turn :left) + (turtle:forward))) + (princ turtle::*turtle*)) (turtle:pen-up))
-(defun pixels-pdf (pixel-pathname) - (cl-gd:with-image-from-file* (pixel-pathname) +(defun pixels-pdf (image-pathname) + (let ((*converter* (make-instance 'converter :image-pathname image-pathname))) + (turtle:reset) (pdf:with-document () (pdf:with-page () - (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*))) - (labels - (cl-gd:do-rows (y) - (cl-gd:do-pixels-in-row (x) - (setf (aref pixels x y) (cl-gd:raw-pixel)))) + (let ((scale (float (/ +paper-width+ (max (width *converter*) + (height *converter*)))))) (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 + (dotimes (y (height *converter*)) + (dotimes (x (width *converter*)) + (unless (aref (seen *converter*) x y) + (fill-from x y)))))) + (pdf:write-document (make-pathname :type "pdf" :defaults image-pathname))))) \ No newline at end of file
Modified: trunk/projects/quickhoney/src/quickhoney.asd =================================================================== --- trunk/projects/quickhoney/src/quickhoney.asd 2008-12-17 20:36:21 UTC (rev 4137) +++ trunk/projects/quickhoney/src/quickhoney.asd 2008-12-17 23:46:09 UTC (rev 4138) @@ -41,7 +41,8 @@ (:file "webserver" :depends-on ("handlers")) (:file "daily" :depends-on ("config"))
- (:file "pixel-pdf" :depends-on ("packages")) + (:file "turtle" :depends-on ("packages")) + (:file "pixel-pdf" :depends-on ("turtle"))
(:file "money" :depends-on ("packages")) (:file "shop" :depends-on ("money"))