[bknr-cvs] hans changed trunk/projects/quickhoney/src/

[BKNR Commits]

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