[bknr-cvs] hans changed trunk/projects/quickhoney/src/
BKNR Commits
bknr at bknr.net
Sat Dec 20 16:39:52 UTC 2008
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)
More information about the Bknr-cvs
mailing list