[bknr-cvs] hans changed trunk/projects/quickhoney/src/
BKNR Commits
bknr at bknr.net
Wed Dec 17 20:36:22 UTC 2008
Revision: 4137
Author: hans
URL: http://bknr.net/trac/changeset/4137
checkpoint vectorizer work
U trunk/projects/quickhoney/src/packages.lisp
U trunk/projects/quickhoney/src/pixel-pdf.lisp
U trunk/projects/quickhoney/src/quickhoney.asd
A trunk/projects/quickhoney/src/turtle.lisp
Modified: trunk/projects/quickhoney/src/packages.lisp
===================================================================
--- trunk/projects/quickhoney/src/packages.lisp 2008-12-15 17:10:09 UTC (rev 4136)
+++ trunk/projects/quickhoney/src/packages.lisp 2008-12-17 20:36:21 UTC (rev 4137)
@@ -89,3 +89,17 @@
(:use :cl :bknr.datastore)
(:export #:update-status))
+(defpackage :pixel-pdf
+ (:use :cl)
+ (:export #:convert))
+
+(defpackage :turtle
+ (:use :cl)
+ (:export #:pen-down
+ #:pen-up
+ #:move-to
+ #:turn
+ #:forward
+ #:reset
+ #:x
+ #:y))
\ No newline at end of file
Modified: trunk/projects/quickhoney/src/pixel-pdf.lisp
===================================================================
--- trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-15 17:10:09 UTC (rev 4136)
+++ trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-17 20:36:21 UTC (rev 4137)
@@ -1,8 +1,70 @@
-(in-package :quickhoney)
+(in-package :pixel-pdf)
(defvar *colors* nil)
(defconstant +paper-width+ 800)
+(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))))
+
+(defun can-turn-left (x y)
+ (same-color (+ x (car dirs))
+ (+ y (cadr dirs))))
+
+(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 turn (direction)
+ (turtle:turn direction)
+ (setf dirs
+ (ecase direction
+ (:left (cdddr dirs))
+ (:right (cdr dirs)))))
+
+(defun forward ()
+ (mark-right-ahead)
+ (turtle:forward))
+
+(defun fill-from (from-x from-y color)
+ ;; 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)))
+ (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))))
+ (cond
+ ((can-turn-left)
+ (turn :left))
+ ((can-go-straight))
+ ((can-go-right)
+ (turn :right)))
+ (forward))
+ (turtle:pen-up))
+
(defun pixels-pdf (pixel-pathname)
(cl-gd:with-image-from-file* (pixel-pathname)
(pdf:with-document ()
@@ -13,44 +75,8 @@
(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#)))
+ (img (cl-gd::img cl-gd::*default-image*)))
(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))))
Modified: trunk/projects/quickhoney/src/quickhoney.asd
===================================================================
--- trunk/projects/quickhoney/src/quickhoney.asd 2008-12-15 17:10:09 UTC (rev 4136)
+++ trunk/projects/quickhoney/src/quickhoney.asd 2008-12-17 20:36:21 UTC (rev 4137)
@@ -26,7 +26,8 @@
:bknr.modules
:cl-gd
:unit-test
- :yason)
+ :yason
+ :cl-pdf)
:components ((:file "packages")
(:file "config" :depends-on ("packages"))
@@ -40,6 +41,8 @@
(:file "webserver" :depends-on ("handlers"))
(:file "daily" :depends-on ("config"))
+ (:file "pixel-pdf" :depends-on ("packages"))
+
(:file "money" :depends-on ("packages"))
(:file "shop" :depends-on ("money"))
(:file "quickhoney-shop" :depends-on ("shop"))
Added: trunk/projects/quickhoney/src/turtle.lisp
===================================================================
--- trunk/projects/quickhoney/src/turtle.lisp (rev 0)
+++ trunk/projects/quickhoney/src/turtle.lisp 2008-12-17 20:36:21 UTC (rev 4137)
@@ -0,0 +1,79 @@
+(in-package :turtle)
+
+(defclass turtle ()
+ ((x :initform 0
+ :accessor turtle-x)
+ (y :initform 0
+ :accessor turtle-y)
+ (directions :initform '#1=(:east :south :west :north . #1#)
+ :accessor turtle-directions)
+ (drawing :accessor turtle-drawing
+ :initform nil)
+ (turned :accessor turtle-turned
+ :initform nil)))
+
+(defmethod print-object ((turtle turtle) stream)
+ (print-unreadable-object (turtle stream :type t)
+ (format stream "at ~A/~A looking ~A pen ~:[UP~;DOWN~]~:[~;TURNED~]"
+ (turtle-x turtle)
+ (turtle-y turtle)
+ (turtle-direction turtle)
+ (turtle-drawing turtle)
+ (turtle-turned turtle))))
+
+(defvar *turtle* (make-instance 'turtle))
+
+(defun turtle-direction (turtle)
+ (car (turtle-directions turtle)))
+
+(defun x ()
+ (turtle-x *turtle*))
+
+(defun y ()
+ (turtle-y *turtle*))
+
+(defun pen-up ()
+ (pdf:line-to (turtle-x *turtle*) (turtle-y *turtle*))
+ (pdf:close-and-fill)
+ (setf (turtle-drawing *turtle*) nil
+ (turtle-turned *turtle*) nil)
+ *turtle*)
+
+(defun pen-down ()
+ (setf (turtle-drawing *turtle*) t)
+ *turtle*)
+
+(defun move-to (x y)
+ (when (turtle-drawing *turtle*)
+ (error "turtle can't move while drawing"))
+ (setf (turtle-x *turtle*) x
+ (turtle-y *turtle*) y)
+ *turtle*)
+
+(defun forward ()
+ (when (turtle-turned *turtle*)
+ (pdf:line-to (turtle-x *turtle*) (turtle-y *turtle*))
+ (setf (turtle-turned *turtle*) nil))
+ (ecase (turtle-direction *turtle*)
+ (:east
+ (incf (turtle-x *turtle*)))
+ (:south
+ (decf (turtle-y *turtle*)))
+ (:west
+ (decf (turtle-x *turtle*)))
+ (:north
+ (incf (turtle-y *turtle*))))
+ *turtle*)
+
+(defun turn (direction)
+ (ecase direction
+ (:left
+ (setf (turtle-directions *turtle*) (cdddr (turtle-directions *turtle*))))
+ (:right
+ (setf (turtle-directions *turtle*) (cdr (turtle-directions *turtle*)))))
+ (setf (turtle-turned *turtle*) t)
+ *turtle*)
+
+(defun reset ()
+ (setf *turtle* (make-instance 'turtle))
+ *turtle*)
More information about the Bknr-cvs
mailing list