[bknr-cvs] hans changed trunk/projects/quickhoney/src/
BKNR Commits
bknr at bknr.net
Wed Dec 17 23:46:09 UTC 2008
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"))
More information about the Bknr-cvs
mailing list