Revision: 4142 Author: hans URL: http://bknr.net/trac/changeset/4142
now it actually displays something! U trunk/projects/quickhoney/src/pixel-pdf.lisp U trunk/projects/quickhoney/src/turtle.lisp
Modified: trunk/projects/quickhoney/src/pixel-pdf.lisp =================================================================== --- trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-18 08:04:11 UTC (rev 4141) +++ trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-18 11:38:27 UTC (rev 4142) @@ -2,18 +2,16 @@
(defvar *colors* nil) (defconstant +paper-width+ 800) +(defvar *converter*)
(defclass converter () ((x :initform 0 - :accessor x - :type fixnum) + :accessor x) (y :initform 0 - :accessor y - :type fixnum) + :accessor y) (pixels :reader pixels) (seen :reader %seen) - (color :accessor color - :type fixnum) + (color :accessor color) (looking-in-direction :initform :east :accessor looking-in-direction)))
@@ -29,6 +27,18 @@ (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)))) + (defmethod initialize-instance :after ((converter converter) &key image-pathname) (cl-gd:with-image-from-file* (image-pathname) (let ((width (cl-gd:image-width)) @@ -36,14 +46,11 @@ (with-slots (seen pixels) converter (setf seen (make-array (list width height) :element-type 'boolean :initial-element nil) - pixels (make-array (list width height) - :element-type 'fixnum)) + 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)))))))) + (setf (aref pixels x y) (convert-color (cl-gd:raw-pixel)))))))))
-(defvar *converter*) - (defun in-range (x y) (and (< -1 x (width *converter*)) (< -1 y (height *converter*)))) @@ -120,7 +127,9 @@ (turtle:forward))
(defun set-color (color) - #+(or) (format t "can't set PDF color ~A yet~%" color)) + (pdf:set-rgb-fill (/ (float (ldb (byte 8 0) color)) 256.0) + (/ (float (ldb (byte 8 8) color)) 256.0) + (/ (float (ldb (byte 8 16) color)) 256.0)))
(defun move-to-pixel (x y) (setf (x *converter*) x @@ -148,9 +157,9 @@ (y *converter*) from-y (color *converter*) (aref (pixels *converter*) from-x from-y)) (flood-fill) - (set-color (color *converter*)) (turtle:reset) (turtle:move-to from-x from-y) + (set-color (color *converter*)) (turtle:pen-down) (turtle:forward) (do () @@ -185,7 +194,8 @@ (pdf:with-document () (pdf:with-page () (let ((scale (float (/ +paper-width+ (max (width *converter*) - (height *converter*)))))) + (height *converter*))))) + (*print-pretty* nil)) (pdf:translate 30.0 80.0) (pdf:scale scale scale) (dotimes (y (height *converter*))
Modified: trunk/projects/quickhoney/src/turtle.lisp =================================================================== --- trunk/projects/quickhoney/src/turtle.lisp 2008-12-18 08:04:11 UTC (rev 4141) +++ trunk/projects/quickhoney/src/turtle.lisp 2008-12-18 11:38:27 UTC (rev 4142) @@ -2,11 +2,9 @@
(defclass turtle () ((x :initform 0 - :accessor turtle-x - :type fixnum) + :accessor turtle-x) (y :initform 0 - :accessor turtle-y - :type fixnum) + :accessor turtle-y) (directions :initform '#1=(:east :south :west :north . #1#) :accessor turtle-directions) (drawing :accessor turtle-drawing @@ -23,6 +21,16 @@ (turtle-drawing turtle) (turtle-turned turtle))))
+(defun line-to (x y) + ;; optimized pdf:line-to + (let ((*standard-output* pdf::*page-stream*)) + (princ (float x)) + (princ #\space) + (princ (float y)) + (princ #\space) + (princ #\l) + (terpri))) + (defvar *turtle* (make-instance 'turtle))
(defun turtle-direction (turtle) @@ -35,7 +43,7 @@ (turtle-y *turtle*))
(defun pen-up () - (pdf:line-to (turtle-x *turtle*) (turtle-y *turtle*)) + (line-to (turtle-x *turtle*) (turtle-y *turtle*)) (pdf:close-and-fill) (setf (turtle-drawing *turtle*) nil (turtle-turned *turtle*) nil) @@ -43,6 +51,7 @@
(defun pen-down () (setf (turtle-drawing *turtle*) t) + (pdf:move-to (turtle-x *turtle*) (turtle-y *turtle*)) *turtle*)
(defun move-to (x y) @@ -54,7 +63,7 @@
(defun forward () (when (turtle-turned *turtle*) - (pdf:line-to (turtle-x *turtle*) (turtle-y *turtle*)) + (line-to (turtle-x *turtle*) (turtle-y *turtle*)) (setf (turtle-turned *turtle*) nil)) (ecase (turtle-direction *turtle*) (:east