Revision: 4145 Author: hans URL: http://bknr.net/trac/changeset/4145 working version, some precision problems left U trunk/projects/quickhoney/src/packages.lisp U trunk/projects/quickhoney/src/pixel-pdf.lisp U trunk/projects/quickhoney/src/turtle.lisp Modified: trunk/projects/quickhoney/src/packages.lisp =================================================================== --- trunk/projects/quickhoney/src/packages.lisp 2008-12-19 12:51:09 UTC (rev 4144) +++ trunk/projects/quickhoney/src/packages.lisp 2008-12-20 16:39:51 UTC (rev 4145) @@ -102,4 +102,5 @@ #:forward #:reset #:x - #:y)) \ No newline at end of file + #:y + #:line-to #:set-rgb-fill)) \ No newline at end of file Modified: trunk/projects/quickhoney/src/pixel-pdf.lisp =================================================================== --- trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-19 12:51:09 UTC (rev 4144) +++ trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-20 16:39:51 UTC (rev 4145) @@ -12,6 +12,8 @@ (pixels :reader pixels) (seen :reader %seen) (color :accessor color) + (color-map :reader color-map + :initform (make-hash-table :test #'eql)) (looking-in-direction :initform :east :accessor looking-in-direction))) @@ -27,17 +29,19 @@ (defun (setf seen) (new-value x y) (setf (aref (%seen *converter*) x y) new-value)) -(defun convert-color (raw-pixel) - (cond - ((cl-gd:true-color-p) - (ldb (byte 24 0) raw-pixel)) - (t - (let ((retval 0) - (img (cl-gd::img cl-gd:*default-image*))) - (setf (ldb (byte 8 0) retval) (cl-gd::gd-image-get-red img raw-pixel) - (ldb (byte 8 8) retval) (cl-gd::gd-image-get-green img raw-pixel) - (ldb (byte 8 16) retval) (cl-gd::gd-image-get-blue img raw-pixel)) - retval)))) +(defun convert-color (converter raw-pixel) + (or (gethash raw-pixel (color-map converter)) + (setf (gethash raw-pixel (color-map converter)) + (cond + ((cl-gd:true-color-p) + (ldb (byte 24 0) raw-pixel)) + (t + (let ((retval 0) + (img (cl-gd::img cl-gd:*default-image*))) + (setf (ldb (byte 8 16) retval) (cl-gd::gd-image-get-red img raw-pixel) + (ldb (byte 8 8) retval) (cl-gd::gd-image-get-green img raw-pixel) + (ldb (byte 8 0) retval) (cl-gd::gd-image-get-blue img raw-pixel)) + retval)))))) (defmethod initialize-instance :after ((converter converter) &key image-pathname) (cl-gd:with-image-from-file* (image-pathname) @@ -49,7 +53,7 @@ pixels (make-array (list width height))) (cl-gd:do-rows (y) (cl-gd:do-pixels-in-row (x) - (setf (aref pixels x y) (convert-color (cl-gd:raw-pixel))))))))) + (setf (aref pixels x y) (convert-color converter (cl-gd:raw-pixel))))))))) (defun in-range (x y) (and (< -1 x (width *converter*)) @@ -152,20 +156,24 @@ (flood-fill) (turtle:reset) (turtle:move-to from-x from-y) - (pdf:set-color-fill (color *converter*)) + (turtle:set-rgb-fill (ldb (byte 8 16) (color *converter*)) + (ldb (byte 8 8) (color *converter*)) + (ldb (byte 8 0) (color *converter*))) (turtle:pen-down) (turtle:forward) (do () ((and (eql from-x (turtle:x)) (eql from-y (turtle:y)))) (cond - ((can-turn-right) - (look :right #'move-to-pixel) - (turn :right) - (turtle:forward)) ((can-go-forward) - (look :forward #'move-to-pixel) - (turtle:forward)) + (cond + ((can-turn-right) + (look :right #'move-to-pixel) + (turn :right) + (turtle:forward)) + (t + (look :forward #'move-to-pixel) + (turtle:forward)))) (t (turn :left) (turtle:forward)))) @@ -180,12 +188,13 @@ (height *converter*))))) (*print-pretty* nil)) (pdf:set-transform-matrix 1.0 0.0 0.0 -1.0 80.0 800.0) - (pdf:scale scale scale) +; (pdf:scale scale scale) (dotimes (y (height *converter*)) (dotimes (x (width *converter*)) (unless (seen x y) (fill-from x y)))))) - (pdf:write-document (make-pathname :type "pdf" :defaults image-pathname))))) + (pdf:write-document (make-pathname :type "pdf" :defaults image-pathname))) + (print (color-map *converter*)))) (defun print-seen () (dotimes (y (height *converter*)) Modified: trunk/projects/quickhoney/src/turtle.lisp =================================================================== --- trunk/projects/quickhoney/src/turtle.lisp 2008-12-19 12:51:09 UTC (rev 4144) +++ trunk/projects/quickhoney/src/turtle.lisp 2008-12-20 16:39:51 UTC (rev 4145) @@ -14,7 +14,7 @@ (defmethod print-object ((turtle turtle) stream) (print-unreadable-object (turtle stream :type t) - (format stream "at ~A/~A looking ~A pen ~:[UP~;DOWN~]~:[~;TURNED~]" + (format stream "at ~A/~A looking ~A pen ~:[UP~;DOWN~]~:[~; TURNED~]" (turtle-x turtle) (turtle-y turtle) (turtle-direction turtle) @@ -31,6 +31,20 @@ (princ #\l) (terpri))) +(defun set-rgb-fill (r g b) + ;; optimized pdf:set-rgb-fill + (let ((*standard-output* pdf::*page-stream*)) + (labels + ((print-color-float (component) + (princ (/ (floor (* 1000.0 (/ (float component) 256.0))) 1000.0)))) + (print-color-float r) + (princ #\Space) + (print-color-float g) + (princ #\Space) + (print-color-float b) + (princ " rg") + (terpri)))) + (defvar *turtle* (make-instance 'turtle)) (defun turtle-direction (turtle) @@ -52,7 +66,7 @@ (defun pen-down () (setf (turtle-drawing *turtle*) t) (pdf:move-to (turtle-x *turtle*) (turtle-y *turtle*)) - (pdf:set-line-width 0.1) + (pdf:set-line-width 0.0) *turtle*) (defun move-to (x y)