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*)