December 2008 - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[bknr-cvs] hans changed trunk/projects/quickhoney/src/pixel-pdf.lisp
by BKNR Commits 21 Dec '08

21 Dec '08

Revision: 4150 Author: hans URL: http://bknr.net/trac/changeset/4150 Remove functions that are called only once. U trunk/projects/quickhoney/src/pixel-pdf.lisp Modified: trunk/projects/quickhoney/src/pixel-pdf.lisp =================================================================== --- trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-21 21:04:33 UTC (rev 4149) +++ trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-21 22:03:07 UTC (rev 4150) @@ -104,12 +104,6 @@ (:right (funcall fn (1+ x) (1+ y)))))))) -(defun can-turn-right () - (look :right #'same-color)) - -(defun can-go-forward () - (look :forward #'same-color)) - (defun turn (direction) (turtle:turn direction) (setf (looking-in-direction *converter*) @@ -171,9 +165,9 @@ ((and (eql from-x (turtle:x)) (eql from-y (turtle:y)))) (cond - ((can-go-forward) + ((look :forward #'same-color) (cond - ((can-turn-right) + ((look :right #'same-color) (look :right #'move-to-pixel) (turn :right) (turtle:forward))

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/
by BKNR Commits 21 Dec '08

21 Dec '08

Revision: 4149 Author: hans URL: http://bknr.net/trac/changeset/4149 Interface to store images, add function to convert all pixel images. U trunk/projects/quickhoney/src/image.lisp U trunk/projects/quickhoney/src/packages.lisp U trunk/projects/quickhoney/src/pixel-pdf.lisp Modified: trunk/projects/quickhoney/src/image.lisp =================================================================== --- trunk/projects/quickhoney/src/image.lisp 2008-12-21 14:07:37 UTC (rev 4148) +++ trunk/projects/quickhoney/src/image.lisp 2008-12-21 21:04:33 UTC (rev 4149) @@ -57,3 +57,14 @@ (defmethod destroy-object :before ((image quickhoney-animation-image)) (delete-object (quickhoney-animation-image-animation image))) +(defun convert-all-pixel-images (directory) + (dolist (category (remove :pixel (quickhoney::all-categories) :test-not #'eql :key #'car)) + (dolist (image (quickhoney:images-in-category category)) + (format t "; image ~A~%" image) + (handler-case + (pixel-pdf:convert-store-image-to-pdf image + (make-pathname :name (store-image-name image) + :type "pdf" + :defaults directory)) + (error (e) + (format t "; error ~A~%" e)))))) \ No newline at end of file Modified: trunk/projects/quickhoney/src/packages.lisp =================================================================== --- trunk/projects/quickhoney/src/packages.lisp 2008-12-21 14:07:37 UTC (rev 4148) +++ trunk/projects/quickhoney/src/packages.lisp 2008-12-21 21:04:33 UTC (rev 4149) @@ -91,7 +91,8 @@ (defpackage :pixel-pdf (:use :cl) - (:export #:convert)) + (:export #:convert-image-file-to-pdf + #:convert-store-image-to-pdf)) (defpackage :turtle (:use :cl) Modified: trunk/projects/quickhoney/src/pixel-pdf.lisp =================================================================== --- trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-21 14:07:37 UTC (rev 4148) +++ trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-21 21:04:33 UTC (rev 4149) @@ -17,6 +17,10 @@ (looking-in-direction :initform :east :accessor looking-in-direction))) +(defmacro with-converter ((&rest args) &body body) + `(let ((*converter* (apply #'make-instance 'converter ,args))) + ,@body)) + (defun width (converter) (array-dimension (pixels converter) 0)) @@ -43,17 +47,17 @@ (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) - (let ((width (cl-gd:image-width)) - (height (cl-gd:image-height))) - (with-slots (seen pixels) converter - (setf seen (make-array (list width height) - :element-type 'boolean :initial-element nil) - 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 converter (cl-gd:raw-pixel))))))))) +(defmethod initialize-instance :after ((converter converter) &key) + (let ((width (cl-gd:image-width)) + (height (cl-gd:image-height))) + (with-slots (seen pixels) converter + (setf seen (make-array (list width height) + :element-type 'boolean :initial-element nil) + 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 converter (cl-gd:raw-pixel))))))) + (turtle:reset)) (defun in-range (x y) (and (< -1 x (width *converter*)) @@ -135,6 +139,8 @@ (y *converter*) y)) (defun flood-fill () + ;; This function certainly is stack hungry. If needed, increase the + ;; stack size of the Lisp runtime (SBCL: --control-stack-size 64) (labels ((maybe-descend (x y) (when (and (same-color x y) @@ -179,9 +185,8 @@ (turtle:forward)))) (turtle:pen-up)) -(defun pixels-pdf (image-pathname) - (let ((*converter* (make-instance 'converter :image-pathname image-pathname))) - (turtle:reset) +(defun convert-pixels-to-pdf (pdf-pathname) + (with-converter () (pdf:with-document () (let ((bounds (if (> (width *converter*) (height *converter*)) @@ -209,15 +214,25 @@ (pdf:set-font (pdf:get-font "Helvetica") 7.0) (pdf:set-rgb-fill 0.5 0.5 0.5) (pdf:translate (+ border x-offset 3 (* scale (width *converter*))) - 125.5) + (+ y-offset 125.5)) (pdf:rotate -90.0) - (pdf:show-text (format nil "~C Nana Rausch QuickHoney" #\Copyright_Sign))))))) - (pdf:write-document (make-pathname :type "pdf" :defaults image-pathname))))) + (pdf:show-text (format nil "~C Nana Rausch QuickHoney" #\Copyright_Sign)))))) + (pdf:write-document pdf-pathname))))) +(defun convert-image-file-to-pdf (image-pathname + &optional (pdf-pathname (make-pathname :type "pdf" :defaults image-pathname))) + (cl-gd:with-image-from-file* (image-pathname) + (convert-pixels-to-pdf pdf-pathname))) + +(defun convert-store-image-to-pdf (store-image pdf-pathname) + (bknr.images:with-store-image* (store-image) + (convert-pixels-to-pdf pdf-pathname))) + (defun print-seen () (dotimes (y (height *converter*)) (dotimes (x (width *converter*)) (write-char (if (seen x (- (height *converter*) y 1)) #\* #\.) *error-output*)) - (terpri *error-output*))) \ No newline at end of file + (terpri *error-output*))) +

1 0

[bknr-cvs] hans changed trunk/thirdparty/cl-pdf/pdf
by BKNR Commits 21 Dec '08

21 Dec '08

Revision: 4148 Author: hans URL: http://bknr.net/trac/changeset/4148 Fix some small bugs. U trunk/thirdparty/cl-pdf/pdf-base.lisp U trunk/thirdparty/cl-pdf/pdf-parser.lisp U trunk/thirdparty/cl-pdf/pdf.lisp Modified: trunk/thirdparty/cl-pdf/pdf-base.lisp =================================================================== --- trunk/thirdparty/cl-pdf/pdf-base.lisp 2008-12-21 11:21:37 UTC (rev 4147) +++ trunk/thirdparty/cl-pdf/pdf-base.lisp 2008-12-21 14:07:37 UTC (rev 4148) @@ -155,6 +155,7 @@ (write-char #\) *page-stream*)) (defmethod write-to-page ((char character) (encoding unicode-encoding) &optional escape) + (declare (ignore escape)) (write-char #\< *page-stream*) (format *page-stream* "~4,'0x" (char-code char)) (write-char #\> *page-stream*)) Modified: trunk/thirdparty/cl-pdf/pdf-parser.lisp =================================================================== --- trunk/thirdparty/cl-pdf/pdf-parser.lisp 2008-12-21 11:21:37 UTC (rev 4147) +++ trunk/thirdparty/cl-pdf/pdf-parser.lisp 2008-12-21 14:07:37 UTC (rev 4148) @@ -495,8 +495,7 @@ (*root-page* (root-page *document*)) (*outlines-stack* (list (outline-root *document*))) (*page* nil) - (*page-number* 0) - (*name-counter* 100)) + (*page-number* 0)) (add-doc-info *document* :creator ,creator :author ,author :title ,title :subject ,subject :keywords ,keywords) ,@body)) Modified: trunk/thirdparty/cl-pdf/pdf.lisp =================================================================== --- trunk/thirdparty/cl-pdf/pdf.lisp 2008-12-21 11:21:37 UTC (rev 4147) +++ trunk/thirdparty/cl-pdf/pdf.lisp 2008-12-21 14:07:37 UTC (rev 4148) @@ -16,7 +16,7 @@ (defvar *page-stream*) (defvar *pdf-stream*) (defvar *xrefs*) -(defvar *name-counter*) +(defvar *name-counter* 100) (defun gen-name (prefix) (format nil "~a~d" prefix (incf *name-counter*)))

1 0

[bknr-cvs] hans changed trunk/thirdparty/cl-pdf/
by BKNR Commits 21 Dec '08

21 Dec '08

Revision: 4147 Author: hans URL: http://bknr.net/trac/changeset/4147 use babel for string-octet conversion, specify latin-1 character set explicitly U trunk/thirdparty/cl-pdf/cl-pdf.asd U trunk/thirdparty/cl-pdf/zlib.lisp Modified: trunk/thirdparty/cl-pdf/cl-pdf.asd =================================================================== --- trunk/thirdparty/cl-pdf/cl-pdf.asd 2008-12-21 11:09:32 UTC (rev 4146) +++ trunk/thirdparty/cl-pdf/cl-pdf.asd 2008-12-21 11:21:37 UTC (rev 4147) @@ -60,4 +60,4 @@ (:file "text" :depends-on ("pdf-base")) (:file "bar-codes" :depends-on ("pdf-geom")) (:file "chart" :depends-on ("text" "pdf-geom"))) - :depends-on (:iterate #+use-salza-zlib :salza)) + :depends-on (:iterate #+use-salza-zlib :salza #+use-salza-zlib :babel)) Modified: trunk/thirdparty/cl-pdf/zlib.lisp =================================================================== --- trunk/thirdparty/cl-pdf/zlib.lisp 2008-12-21 11:09:32 UTC (rev 4146) +++ trunk/thirdparty/cl-pdf/zlib.lisp 2008-12-21 11:21:37 UTC (rev 4147) @@ -88,7 +88,7 @@ #+use-salza-zlib (defun compress-string (string) (let* ((input (if (stringp string) - (deflate::string-to-octets string 0 (length string)) + (babel::string-to-octets string :encoding :iso-8859-1) string)) (buffer-size (min 8192 (* 2 (length string)))) (zlib-buffer (make-array buffer-size :element-type 'salza::octet))

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/pixel-pdf.lisp
by BKNR Commits 21 Dec '08

21 Dec '08

Revision: 4146 Author: hans URL: http://bknr.net/trac/changeset/4146 Scale to letter paper size, add credit line. U trunk/projects/quickhoney/src/pixel-pdf.lisp Modified: trunk/projects/quickhoney/src/pixel-pdf.lisp =================================================================== --- trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-20 16:39:51 UTC (rev 4145) +++ trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-21 11:09:32 UTC (rev 4146) @@ -183,18 +183,36 @@ (let ((*converter* (make-instance 'converter :image-pathname image-pathname))) (turtle:reset) (pdf:with-document () - (pdf:with-page () - (let ((scale (float (/ +paper-width+ (max (width *converter*) - (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) - (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))) - (print (color-map *converter*)))) + (let ((bounds (if (> (width *converter*) + (height *converter*)) + pdf:*letter-landscape-page-bounds* + pdf:*letter-portrait-page-bounds*))) + (pdf:with-page (:bounds bounds) + (let* ((*print-pretty* nil) + (border 36) + (page-width (- (aref bounds 2) (* border 2))) + (page-height (- (aref bounds 3) (* border 2))) + (scale (/ 1 (max (/ (width *converter*) page-width) + (/ (height *converter*) page-height)))) + (x-offset (/ (- page-width (* (width *converter*) scale)) 2)) + (y-offset (/ (- page-height (* (height *converter*) scale)) 2))) + (pdf:with-saved-state + (pdf:set-transform-matrix scale 0.0 0.0 (- scale) + (+ border x-offset) + (+ border y-offset (* scale (height *converter*)))) + (dotimes (y (height *converter*)) + (dotimes (x (width *converter*)) + (unless (seen x y) + (fill-from x y))))) + (pdf:with-saved-state + (pdf:in-text-mode + (pdf:set-font (pdf:get-font "Helvetica") 7.0) + (pdf:set-rgb-fill 0.5 0.5 0.5) + (pdf:translate (+ border x-offset 3 (* scale (width *converter*))) + 125.5) + (pdf:rotate -90.0) + (pdf:show-text (format nil "~C Nana Rausch QuickHoney" #\Copyright_Sign))))))) + (pdf:write-document (make-pathname :type "pdf" :defaults image-pathname))))) (defun print-seen () (dotimes (y (height *converter*))

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/
by BKNR Commits 20 Dec '08

20 Dec '08

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)

1 0

[bknr-cvs] hans changed trunk/thirdparty/slime/
by BKNR Commits 19 Dec '08

19 Dec '08

Revision: 4144 Author: hans URL: http://bknr.net/trac/changeset/4144 update from upstream to support current sbcl U trunk/thirdparty/slime/CVS/Entries U trunk/thirdparty/slime/ChangeLog U trunk/thirdparty/slime/contrib/CVS/Entries U trunk/thirdparty/slime/contrib/ChangeLog U trunk/thirdparty/slime/contrib/slime-editing-commands.el U trunk/thirdparty/slime/contrib/slime-package-fu.el U trunk/thirdparty/slime/contrib/slime-scratch.el U trunk/thirdparty/slime/contrib/swank-asdf.lisp U trunk/thirdparty/slime/contrib/swank-c-p-c.lisp U trunk/thirdparty/slime/contrib/swank-goo.goo A trunk/thirdparty/slime/contrib/swank-jolt.k U trunk/thirdparty/slime/contrib/swank-kawa.scm U trunk/thirdparty/slime/contrib/swank-listener-hooks.lisp U trunk/thirdparty/slime/contrib/swank-mit-scheme.scm U trunk/thirdparty/slime/contrib/swank-presentation-streams.lisp U trunk/thirdparty/slime/doc/CVS/Entries U trunk/thirdparty/slime/doc/slime.texi U trunk/thirdparty/slime/slime.el U trunk/thirdparty/slime/swank-abcl.lisp U trunk/thirdparty/slime/swank-allegro.lisp U trunk/thirdparty/slime/swank-backend.lisp U trunk/thirdparty/slime/swank-clisp.lisp U trunk/thirdparty/slime/swank-cmucl.lisp U trunk/thirdparty/slime/swank-corman.lisp U trunk/thirdparty/slime/swank-ecl.lisp U trunk/thirdparty/slime/swank-lispworks.lisp U trunk/thirdparty/slime/swank-openmcl.lisp U trunk/thirdparty/slime/swank-sbcl.lisp U trunk/thirdparty/slime/swank-scl.lisp U trunk/thirdparty/slime/swank.lisp U trunk/thirdparty/slime/test.sh Change set too large, please see URL above

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/
by BKNR Commits 18 Dec '08

18 Dec '08

Revision: 4143 Author: hans URL: http://bknr.net/trac/changeset/4143 checkpoint 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 11:38:27 UTC (rev 4142) +++ trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-18 17:32:05 UTC (rev 4143) @@ -1,7 +1,7 @@ (in-package :pixel-pdf) (defvar *colors* nil) -(defconstant +paper-width+ 800) +(defconstant +paper-width+ 600) (defvar *converter*) (defclass converter () @@ -126,11 +126,6 @@ (defun forward () (turtle:forward)) -(defun set-color (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 (y *converter*) y)) @@ -150,8 +145,6 @@ (recurse (x *converter*) (y *converter*)))) (defun fill-from (from-x from-y) - ;; XXX true-color-behandlung fehlt. - #+(or) (format t "filling at ~A/~A~%" from-x from-y) (setf (looking-in-direction *converter*) :east (x *converter*) from-x (y *converter*) from-y @@ -159,7 +152,7 @@ (flood-fill) (turtle:reset) (turtle:move-to from-x from-y) - (set-color (color *converter*)) + (pdf:set-color-fill (color *converter*)) (turtle:pen-down) (turtle:forward) (do () @@ -167,26 +160,16 @@ (eql from-y (turtle:y)))) (cond ((can-turn-right) - #+(or) (format t " RIGHT~%") (look :right #'move-to-pixel) (turn :right) (turtle:forward)) ((can-go-forward) - #+(or) (format t " FORWARD~%") (look :forward #'move-to-pixel) (turtle:forward)) (t - #+(or) (format t " LEFT~%") (turn :left) - (turtle:forward))) - #+(or) (format t "at ~A/~A looking ~A ~A~%" - (x *converter*) (y *converter*) - (looking-in-direction *converter*) - turtle::*turtle*) - #+(or) (assert (and (<= (abs (- (x *converter*) (turtle:x))) 1) - (<= (abs (- (y *converter*) (turtle:y))) 1)))) - (turtle:pen-up) - #+(or) (print-seen)) + (turtle:forward)))) + (turtle:pen-up)) (defun pixels-pdf (image-pathname) (let ((*converter* (make-instance 'converter :image-pathname image-pathname))) @@ -196,7 +179,7 @@ (let ((scale (float (/ +paper-width+ (max (width *converter*) (height *converter*))))) (*print-pretty* nil)) - (pdf:translate 30.0 80.0) + (pdf:set-transform-matrix 1.0 0.0 0.0 -1.0 80.0 800.0) (pdf:scale scale scale) (dotimes (y (height *converter*)) (dotimes (x (width *converter*)) Modified: trunk/projects/quickhoney/src/turtle.lisp =================================================================== --- trunk/projects/quickhoney/src/turtle.lisp 2008-12-18 11:38:27 UTC (rev 4142) +++ trunk/projects/quickhoney/src/turtle.lisp 2008-12-18 17:32:05 UTC (rev 4143) @@ -52,6 +52,7 @@ (defun pen-down () (setf (turtle-drawing *turtle*) t) (pdf:move-to (turtle-x *turtle*) (turtle-y *turtle*)) + (pdf:set-line-width 0.1) *turtle*) (defun move-to (x y)

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/
by BKNR Commits 18 Dec '08

18 Dec '08

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

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/
by BKNR Commits 18 Dec '08

18 Dec '08

Revision: 4141 Author: hans URL: http://bknr.net/trac/changeset/4141 it is slow, but it works! 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 06:39:24 UTC (rev 4140) +++ trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-18 08:04:11 UTC (rev 4141) @@ -5,12 +5,15 @@ (defclass converter () ((x :initform 0 - :accessor x) + :accessor x + :type fixnum) (y :initform 0 - :accessor y) + :accessor y + :type fixnum) (pixels :reader pixels) - (seen :reader seen) - (color :accessor color) + (seen :reader %seen) + (color :accessor color + :type fixnum) (looking-in-direction :initform :east :accessor looking-in-direction))) @@ -20,6 +23,12 @@ (defun height (converter) (array-dimension (pixels converter) 1)) +(defun seen (x y) + (aref (%seen *converter*) x y)) + +(defun (setf seen) (new-value x y) + (setf (aref (%seen *converter*) x y) new-value)) + (defmethod initialize-instance :after ((converter converter) &key image-pathname) (cl-gd:with-image-from-file* (image-pathname) (let ((width (cl-gd:image-width)) @@ -27,7 +36,8 @@ (with-slots (seen pixels) converter (setf seen (make-array (list width height) :element-type 'boolean :initial-element nil) - pixels (make-array (list width height))) + pixels (make-array (list width height) + :element-type 'fixnum)) (cl-gd:do-rows (y) (cl-gd:do-pixels-in-row (x) (setf (aref pixels x y) (cl-gd:raw-pixel)))))))) @@ -110,29 +120,41 @@ (turtle:forward)) (defun set-color (color) - (format t "can't set PDF color ~A yet~%" color)) + #+(or) (format t "can't set PDF color ~A yet~%" color)) (defun move-to-pixel (x y) (setf (x *converter*) x - (y *converter*) y - (aref (seen *converter*) x y) t)) + (y *converter*) y)) +(defun flood-fill () + (labels + ((maybe-descend (x y) + (when (and (same-color x y) + (not (seen x y))) + (recurse x y))) + (recurse (x y) + (setf (seen x y) t) + (maybe-descend (1- x) y) + (maybe-descend (1+ x) y) + (maybe-descend x (1- y)) + (maybe-descend x (1+ y)))) + (recurse (x *converter*) (y *converter*)))) + (defun fill-from (from-x from-y) ;; XXX true-color-behandlung fehlt. - (format t "filling at ~A/~A~%" from-x from-y) - (setf (aref (seen *converter*) from-x from-y) t - (looking-in-direction *converter*) :east + #+(or) (format t "filling at ~A/~A~%" from-x from-y) + (setf (looking-in-direction *converter*) :east (x *converter*) from-x (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) (turtle:pen-down) (turtle:forward) - (do ((moved nil t)) - ((and moved - (eql from-x (turtle:x)) + (do () + ((and (eql from-x (turtle:x)) (eql from-y (turtle:y)))) (cond ((can-turn-right) @@ -152,10 +174,10 @@ (x *converter*) (y *converter*) (looking-in-direction *converter*) turtle::*turtle*) - (assert (and (<= (abs (- (x *converter*) (turtle:x))) 1) - (<= (abs (- (y *converter*) (turtle:y))) 1)))) + #+(or) (assert (and (<= (abs (- (x *converter*) (turtle:x))) 1) + (<= (abs (- (y *converter*) (turtle:y))) 1)))) (turtle:pen-up) - (print-seen)) + #+(or) (print-seen)) (defun pixels-pdf (image-pathname) (let ((*converter* (make-instance 'converter :image-pathname image-pathname))) @@ -168,14 +190,14 @@ (pdf:scale scale scale) (dotimes (y (height *converter*)) (dotimes (x (width *converter*)) - (unless (aref (seen *converter*) x y) + (unless (seen x y) (fill-from x y)))))) (pdf:write-document (make-pathname :type "pdf" :defaults image-pathname))))) (defun print-seen () (dotimes (y (height *converter*)) (dotimes (x (width *converter*)) - (write-char (if (aref (seen *converter*) x (- (height *converter*) y 1)) + (write-char (if (seen x (- (height *converter*) y 1)) #\* #\.) *error-output*)) (terpri *error-output*))) \ No newline at end of file Modified: trunk/projects/quickhoney/src/turtle.lisp =================================================================== --- trunk/projects/quickhoney/src/turtle.lisp 2008-12-18 06:39:24 UTC (rev 4140) +++ trunk/projects/quickhoney/src/turtle.lisp 2008-12-18 08:04:11 UTC (rev 4141) @@ -2,9 +2,11 @@ (defclass turtle () ((x :initform 0 - :accessor turtle-x) + :accessor turtle-x + :type fixnum) (y :initform 0 - :accessor turtle-y) + :accessor turtle-y + :type fixnum) (directions :initform '#1=(:east :south :west :north . #1#) :accessor turtle-directions) (drawing :accessor turtle-drawing

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/pixel-pdf.lisp
by BKNR Commits 18 Dec '08

18 Dec '08

Revision: 4140 Author: hans URL: http://bknr.net/trac/changeset/4140 progress! U trunk/projects/quickhoney/src/pixel-pdf.lisp Modified: trunk/projects/quickhoney/src/pixel-pdf.lisp =================================================================== --- trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-18 00:09:18 UTC (rev 4139) +++ trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-18 06:39:24 UTC (rev 4140) @@ -107,16 +107,16 @@ (:right :east)))))) (defun forward () - (turtle:forward) - - (look :forward (lambda (x y) - (setf (x *converter*) x - (y *converter*) y - (aref (seen *converter*) x y) t)))) + (turtle:forward)) (defun set-color (color) (format t "can't set PDF color ~A yet~%" color)) +(defun move-to-pixel (x y) + (setf (x *converter*) x + (y *converter*) y + (aref (seen *converter*) x y) t)) + (defun fill-from (from-x from-y) ;; XXX true-color-behandlung fehlt. (format t "filling at ~A/~A~%" from-x from-y) @@ -126,6 +126,7 @@ (y *converter*) from-y (color *converter*) (aref (pixels *converter*) from-x from-y)) (set-color (color *converter*)) + (turtle:reset) (turtle:move-to from-x from-y) (turtle:pen-down) (turtle:forward) @@ -135,19 +136,26 @@ (eql from-y (turtle:y)))) (cond ((can-turn-right) - (format t " RIGHT~%") + #+(or) (format t " RIGHT~%") + (look :right #'move-to-pixel) (turn :right) - (forward)) + (turtle:forward)) ((can-go-forward) - (format t " FORWARD~%") - (forward)) + #+(or) (format t " FORWARD~%") + (look :forward #'move-to-pixel) + (turtle:forward)) (t - (format t " LEFT~%") + #+(or) (format t " LEFT~%") (turn :left) (turtle:forward))) - (princ turtle::*turtle*) - (terpri)) - (turtle:pen-up)) + #+(or) (format t "at ~A/~A looking ~A ~A~%" + (x *converter*) (y *converter*) + (looking-in-direction *converter*) + turtle::*turtle*) + (assert (and (<= (abs (- (x *converter*) (turtle:x))) 1) + (<= (abs (- (y *converter*) (turtle:y))) 1)))) + (turtle:pen-up) + (print-seen)) (defun pixels-pdf (image-pathname) (let ((*converter* (make-instance 'converter :image-pathname image-pathname))) @@ -162,4 +170,12 @@ (dotimes (x (width *converter*)) (unless (aref (seen *converter*) x y) (fill-from x y)))))) - (pdf:write-document (make-pathname :type "pdf" :defaults image-pathname))))) \ No newline at end of file + (pdf:write-document (make-pathname :type "pdf" :defaults image-pathname))))) + +(defun print-seen () + (dotimes (y (height *converter*)) + (dotimes (x (width *converter*)) + (write-char (if (aref (seen *converter*) x (- (height *converter*) y 1)) + #\* #\.) + *error-output*)) + (terpri *error-output*))) \ No newline at end of file

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/pixel-pdf.lisp
by BKNR Commits 18 Dec '08

18 Dec '08

Revision: 4139 Author: hans URL: http://bknr.net/trac/changeset/4139 checkpoint again. will i ever make this work? U trunk/projects/quickhoney/src/pixel-pdf.lisp Modified: trunk/projects/quickhoney/src/pixel-pdf.lisp =================================================================== --- trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-17 23:46:09 UTC (rev 4138) +++ trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-18 00:09:18 UTC (rev 4139) @@ -39,8 +39,7 @@ (< -1 y (height *converter*)))) (defun same-color (x y) - (when (and (in-range x y) - (not (aref (seen *converter*) x y))) + (when (in-range x y) (eql (color *converter*) (aref (pixels *converter*) x y)))) (defun look (direction fn) @@ -109,36 +108,45 @@ (defun forward () (turtle:forward) - (setf (aref (seen *converter*) (x *converter*) (y *converter*)) t) + (look :forward (lambda (x y) (setf (x *converter*) x - (y *converter*) y)))) + (y *converter*) y + (aref (seen *converter*) x y) t)))) (defun set-color (color) - (setf (color *converter*) color) (format t "can't set PDF color ~A yet~%" color)) (defun fill-from (from-x from-y) ;; XXX true-color-behandlung fehlt. (format t "filling at ~A/~A~%" from-x from-y) - (setf (aref (seen *converter*) from-x from-y) t) - (set-color (aref (pixels *converter*) from-x from-y)) + (setf (aref (seen *converter*) from-x from-y) t + (looking-in-direction *converter*) :east + (x *converter*) from-x + (y *converter*) from-y + (color *converter*) (aref (pixels *converter*) from-x from-y)) + (set-color (color *converter*)) (turtle:move-to from-x from-y) (turtle:pen-down) + (turtle:forward) (do ((moved nil t)) ((and moved (eql from-x (turtle:x)) (eql from-y (turtle:y)))) (cond ((can-turn-right) + (format t " RIGHT~%") (turn :right) (forward)) ((can-go-forward) + (format t " FORWARD~%") (forward)) (t + (format t " LEFT~%") (turn :left) (turtle:forward))) - (princ turtle::*turtle*)) + (princ turtle::*turtle*) + (terpri)) (turtle:pen-up)) (defun pixels-pdf (image-pathname)

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/
by BKNR Commits 17 Dec '08

17 Dec '08

Revision: 4138 Author: hans URL: http://bknr.net/trac/changeset/4138 checkpoint U trunk/projects/quickhoney/src/pixel-pdf.lisp U trunk/projects/quickhoney/src/quickhoney.asd Modified: trunk/projects/quickhoney/src/pixel-pdf.lisp =================================================================== --- trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-17 20:36:21 UTC (rev 4137) +++ trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-17 23:46:09 UTC (rev 4138) @@ -3,88 +3,155 @@ (defvar *colors* nil) (defconstant +paper-width+ 800) +(defclass converter () + ((x :initform 0 + :accessor x) + (y :initform 0 + :accessor y) + (pixels :reader pixels) + (seen :reader seen) + (color :accessor color) + (looking-in-direction :initform :east + :accessor looking-in-direction))) + +(defun width (converter) + (array-dimension (pixels converter) 0)) + +(defun height (converter) + (array-dimension (pixels converter) 1)) + +(defmethod initialize-instance :after ((converter converter) &key image-pathname) + (cl-gd:with-image-from-file* (image-pathname) + (let ((width (cl-gd:image-width)) + (height (cl-gd:image-height))) + (with-slots (seen pixels) converter + (setf seen (make-array (list width height) + :element-type 'boolean :initial-element nil) + 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)))))))) + +(defvar *converter*) + +(defun in-range (x y) + (and (< -1 x (width *converter*)) + (< -1 y (height *converter*)))) + (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)))) + (when (and (in-range x y) + (not (aref (seen *converter*) x y))) + (eql (color *converter*) (aref (pixels *converter*) x y)))) -(defun can-turn-left (x y) - (same-color (+ x (car dirs)) - (+ y (cadr dirs)))) +(defun look (direction fn) + (let ((x (x *converter*)) + (y (y *converter*))) + (ecase (looking-in-direction *converter*) + (:east + (ecase direction + (:left + (funcall fn (1+ x) (1+ y))) + (:forward + (funcall fn (1+ x) y)) + (:right + (funcall fn (1+ x) (1- y))))) + (:south + (ecase direction + (:left + (funcall fn (1+ x) (1- y))) + (:forward + (funcall fn x (1- y))) + (:right + (funcall fn (1- x) (1- y))))) + (:west + (ecase direction + (:left + (funcall fn (1- x) (1- y))) + (:forward + (funcall fn (1- x) y)) + (:right + (funcall fn (1- x) (1+ y))))) + (:north + (ecase direction + (:left + (funcall fn (1- x) (1+ y))) + (:forward + (funcall fn x (1+ y))) + (:right + (funcall fn (1+ x) (1+ y)))))))) -(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 can-turn-right () + (look :right #'same-color)) +(defun can-go-forward () + (look :forward #'same-color)) + (defun turn (direction) (turtle:turn direction) - (setf dirs - (ecase direction - (:left (cdddr dirs)) - (:right (cdr dirs))))) + (setf (looking-in-direction *converter*) + (ecase (looking-in-direction *converter*) + (:east + (ecase direction + (:left :north) + (:right :south))) + (:south + (ecase direction + (:left :east) + (:right :west))) + (:west + (ecase direction + (:left :south) + (:right :north))) + (:north + (ecase direction + (:left :west) + (:right :east)))))) (defun forward () - (mark-right-ahead) - (turtle:forward)) + (turtle:forward) + (setf (aref (seen *converter*) (x *converter*) (y *converter*)) t) + (look :forward (lambda (x y) + (setf (x *converter*) x + (y *converter*) y)))) -(defun fill-from (from-x from-y color) +(defun set-color (color) + (setf (color *converter*) color) + (format t "can't set PDF color ~A yet~%" color)) + +(defun fill-from (from-x from-y) ;; 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 "filling at ~A/~A~%" from-x from-y) + (setf (aref (seen *converter*) from-x from-y) t) + (set-color (aref (pixels *converter*) from-x from-y)) (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)))) + (do ((moved nil t)) + ((and moved + (eql from-x (turtle:x)) + (eql from-y (turtle:y)))) (cond - ((can-turn-left) - (turn :left)) - ((can-go-straight)) - ((can-go-right) - (turn :right))) - (forward)) + ((can-turn-right) + (turn :right) + (forward)) + ((can-go-forward) + (forward)) + (t + (turn :left) + (turtle:forward))) + (princ turtle::*turtle*)) (turtle:pen-up)) -(defun pixels-pdf (pixel-pathname) - (cl-gd:with-image-from-file* (pixel-pathname) +(defun pixels-pdf (image-pathname) + (let ((*converter* (make-instance 'converter :image-pathname image-pathname))) + (turtle:reset) (pdf:with-document () (pdf:with-page () - (let* ((width (cl-gd:image-width)) - (height (cl-gd:image-height)) - (scale (float (/ +paper-width+ (max width height)))) - (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*))) - (labels - (cl-gd:do-rows (y) - (cl-gd:do-pixels-in-row (x) - (setf (aref pixels x y) (cl-gd:raw-pixel)))) + (let ((scale (float (/ +paper-width+ (max (width *converter*) + (height *converter*)))))) (pdf:translate 30.0 80.0) (pdf:scale scale scale) - (dotimes (y height) - (dotimes (x width) - (unless (aref seen x y) - (fill-from x y (aref pixels x y)) - (format t "filled at ~A/~A~%" x y))))))) - (pdf:write-document (make-pathname :type "pdf" :defaults pixel-pathname))))) \ No newline at end of file + (dotimes (y (height *converter*)) + (dotimes (x (width *converter*)) + (unless (aref (seen *converter*) x y) + (fill-from x y)))))) + (pdf:write-document (make-pathname :type "pdf" :defaults image-pathname))))) \ No newline at end of file Modified: trunk/projects/quickhoney/src/quickhoney.asd =================================================================== --- trunk/projects/quickhoney/src/quickhoney.asd 2008-12-17 20:36:21 UTC (rev 4137) +++ trunk/projects/quickhoney/src/quickhoney.asd 2008-12-17 23:46:09 UTC (rev 4138) @@ -41,7 +41,8 @@ (:file "webserver" :depends-on ("handlers")) (:file "daily" :depends-on ("config")) - (:file "pixel-pdf" :depends-on ("packages")) + (:file "turtle" :depends-on ("packages")) + (:file "pixel-pdf" :depends-on ("turtle")) (:file "money" :depends-on ("packages")) (:file "shop" :depends-on ("money"))

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/
by BKNR Commits 17 Dec '08

17 Dec '08

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

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/pixel-pdf.lisp
by BKNR Commits 15 Dec '08

15 Dec '08

Revision: 4136 Author: hans URL: http://bknr.net/trac/changeset/4136 Checkpoint U trunk/projects/quickhoney/src/pixel-pdf.lisp Modified: trunk/projects/quickhoney/src/pixel-pdf.lisp =================================================================== --- trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-14 23:17:22 UTC (rev 4135) +++ trunk/projects/quickhoney/src/pixel-pdf.lisp 2008-12-15 17:10:09 UTC (rev 4136) @@ -7,21 +7,58 @@ (cl-gd:with-image-from-file* (pixel-pathname) (pdf:with-document () (pdf:with-page () - (pdf:translate 30.0 80.0) - (let ((scale (float (/ +paper-width+ (max (cl-gd:image-width) (cl-gd:image-height)))))) - (pdf:scale scale scale)) - (cl-gd:do-rows (y) - (cl-gd:do-pixels-in-row (x) - ;; XXX true-color-behandlung fehlt. - (let ((color (cl-gd:raw-pixel)) - (img (cl-gd::img cl-gd::*default-image*))) - (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)))) - (let ((y (- (cl-gd:image-height) y))) - (pdf:move-to x y) - (pdf:line-to x (1+ y)) - (pdf:line-to (1+ x) (1+ y)) - (pdf:line-to (1+ x) y)) - (pdf:close-and-fill)))) + (let* ((width (cl-gd:image-width)) + (height (cl-gd:image-height)) + (scale (float (/ +paper-width+ (max width height)))) + (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#))) + (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)))) + (pdf:translate 30.0 80.0) + (pdf:scale scale scale) + (dotimes (y height) + (dotimes (x width) + (unless (aref seen x y) + (fill-from x y (aref pixels x y)) + (format t "filled at ~A/~A~%" x y))))))) (pdf:write-document (make-pathname :type "pdf" :defaults pixel-pathname))))) \ No newline at end of file

1 0

[bknr-cvs] hans changed trunk/projects/bos/
by BKNR Commits 14 Dec '08

14 Dec '08

Revision: 4135 Author: hans URL: http://bknr.net/trac/changeset/4135 Better sponsor placemark loading, add "Sponsors" pseudo POI. U trunk/projects/bos/payment-website/static/poi-ms/poi-ms.html U trunk/projects/bos/payment-website/static/poi-ms/poi-ms.js U trunk/projects/bos/web/sponsor-handlers.lisp Modified: trunk/projects/bos/payment-website/static/poi-ms/poi-ms.html =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms/poi-ms.html 2008-12-14 13:58:07 UTC (rev 4134) +++ trunk/projects/bos/payment-website/static/poi-ms/poi-ms.html 2008-12-14 23:17:22 UTC (rev 4135) @@ -24,7 +24,7 @@ </div> <div id="content"> <h1 id="title"></h1> - <div id="map"><img src="fake-map.jpg" width="505" height="505"/></div> + <div id="map" class="large"><img src="fake-map.jpg" width="505" height="505"/></div> <div id="content-body"> </div> </div> Modified: trunk/projects/bos/payment-website/static/poi-ms/poi-ms.js =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms/poi-ms.js 2008-12-14 13:58:07 UTC (rev 4134) +++ trunk/projects/bos/payment-website/static/poi-ms/poi-ms.js 2008-12-14 23:17:22 UTC (rev 4135) @@ -178,6 +178,7 @@ } function showOverview() { + log('showOverview'); $('#back').css('visibility', 'hidden'); $('#title').text(NLS('Übersicht')); @@ -189,6 +190,13 @@ .empty() .append(UL({ id: 'poi-list' })); + $('#poi-list') + .append($(LI(null, + A({ href: '#' }, + IMG({ src: "http://www.google.com/mapfiles/marker.png" }), + B(NLS("Sponsoren"))))) + .bind('click', showSponsors)); + for (var i in pois) { var poi = pois[i]; $('#poi-list') @@ -269,8 +277,8 @@ } } -// this.map.enableContinuousZoom(); -// this.map.enableScrollWheelZoom(); + this.map.enableContinuousZoom(); + this.map.enableScrollWheelZoom(); this.mapClicked = function (overlay, latlng, overlaylatlng) { log('map clicked, overlay: ' + overlay + ' latlng: ' + latlng + ' overlaylatlng: ' + overlaylatlng); @@ -284,7 +292,7 @@ var bounds = this.map.getBounds(); var sw = latLngToPoint(bounds.getSouthWest()); var ne = latLngToPoint(bounds.getNorthEast()); - log('map has moved: ' + sw.x + ',' + ne.y + ',' + ne.x + ',' + sw.y); +// log('map has moved: ' + sw.x + ',' + ne.y + ',' + ne.x + ',' + sw.y); this.sponsorQuery = sw.x + ',' + ne.y + ',' + ne.x + ',' + sw.y; } @@ -292,10 +300,28 @@ GEvent.addListener(this.map, "click", bind(this.mapClicked, this)); GEvent.addListener(this.map, "moveend", bind(this.moveEnd, this)); + this.sponsorMarkers = []; + + this.removeSponsorMarkers = function (all) { + log('remove sponsor markers'); + var markers = []; + var gmap = this.map; + map(function(marker) { + if (!all && marker.opened) { + markers.push(marker); + } else { + gmap.removeOverlay(marker); + } + }, this.sponsorMarkers); + this.sponsorMarkers = markers; + log('done'); + } + this.overview = function () { this.show(); $('#map').removeClass('small'); $('#map').addClass('large'); + this.removeSponsorMarkers(true); this.addControls(); this.map.checkResize(); this.map.setCenter(projection.fromPixelToLatLng(new GPoint(6500, 6350), 6), 2, customMap); @@ -304,6 +330,7 @@ this.poiDetail = function (x, y) { $('#map').removeClass('large'); $('#map').addClass('small'); + this.removeSponsorMarkers(true); this.removeControls(); this.map.checkResize(); this.map.setCenter(projection.fromPixelToLatLng(new GPoint(x, y), 6), 6); @@ -349,8 +376,6 @@ this.map.addOverlay(marker); } - this.sponsorMarkers = []; - function makeTable(rows) { return TABLE({ 'class': 'sponsor-info-popup' }, TBODY(null, @@ -364,7 +389,6 @@ this.setSponsorMarker = function (sponsor) { var position = pointToLatLng(sponsor.contracts[0].centerX, sponsor.contracts[0].centerY); var sponsorMarker = new GMarker(position); - log('sponsor: ' + serializeJSON(sponsor)); var info = [ [ "Name", sponsor.name || NLS("[anonym]") ], [ "Country", sponsor.country ], @@ -374,20 +398,28 @@ info.push([ "Info", sponsor.infoText ]); } sponsorMarker.bindInfoWindow(makeTable(info)); + + function setMarkerOpened(marker, state) { + marker.opened = state; + } + + GEvent.addListener(this.map, "infowindowopen", partial(setMarkerOpened, sponsorMarker, true)); + GEvent.addListener(this.map, "infowindowclose", partial(setMarkerOpened, sponsorMarker, false)); + this.map.addOverlay(sponsorMarker); this.sponsorMarkers.push(sponsorMarker); } - this.removeSponsorMarkers = function () { - map(bind(this.map.removeOverlay, this.map), this.sponsorMarkers); - this.sponsorMarkers = []; - } - this.putSponsorPlacemarks = function(data) { - log('got ' + data.sponsors.length + ' sponsors to display'); - this.removeSponsorMarkers(); - map(bind(this.setSponsorMarker, this), data.sponsors); - this.checkMapMoved(); + try { + log('got ' + data.sponsors.length + ' sponsors to display'); + this.removeSponsorMarkers(); + map(bind(this.setSponsorMarker, this), data.sponsors); + this.checkMapMoved(); + } + catch (e) { + log('error ' + e + ' putting sponsor placemarks'); + } } this.checkMapMoved = function() { @@ -399,8 +431,6 @@ callLater(0.5, bind(this.checkMapMoved, this)); } } - - this.checkMapMoved(); } var pages = { @@ -427,17 +457,17 @@ mainMap.zoomTo(contract.left, contract.top, 8); mainMap.setSponsorMarker(sponsor); - - // Math.max(contract.width, contract.height) } function showSponsors() { $('#left-bar') .empty() - .append(H3(NLS("Letzte Sponsoren")), - UL({ id: 'sponsor-list' })); +// .append(H3(NLS("Letzte Sponsoren")), +// UL({ id: 'sponsor-list' })) + ; + $('#title').text(NLS('Sponsoren')); map(function (sponsor) { $('#sponsor-list') .append($(LI(null, @@ -451,15 +481,19 @@ }, sponsors.slice(0, 10)); mainMap.overview(); + mainMap.zoomTo(7100, 5400, 5); + mainMap.checkMapMoved(); } -function loadSponsors(data) { +function loadPOIs(data) { try { - for (var i in data.sponsors) { - var sponsor = data.sponsors[i]; - sponsors.push(sponsor); + for (var i in data.pois) { + var poi = data.pois[i]; + pois[poi.id] = poi; } + mainMap = new Map(); + var poi_id = document.location.hash.replace(/#/, ""); if (poi_id) { showPOI(pois[poi_id]); @@ -472,22 +506,6 @@ } } -function loadPOIs(data) { - try { - for (var i in data.pois) { - var poi = data.pois[i]; - pois[poi.id] = poi; - } - - mainMap = new Map(); - - loadJSONDoc('/sponsors-json').addCallback(loadSponsors); - } - catch (e) { - alert(e); - } -} - function init() { $('#small-map a').bind('click', showOverview); Modified: trunk/projects/bos/web/sponsor-handlers.lisp =================================================================== --- trunk/projects/bos/web/sponsor-handlers.lisp 2008-12-14 13:58:07 UTC (rev 4134) +++ trunk/projects/bos/web/sponsor-handlers.lisp 2008-12-14 23:17:22 UTC (rev 4135) @@ -361,8 +361,8 @@ (defun sponsors-at (query) (when (cl-ppcre:scan "^[0-9,]+$" query) (destructuring-bind (east north west south) (mapcar #'parse-integer (cl-ppcre:split "," query)) - (when (and (< (- west east) 1000) - (< (- south north) 1000)) + (when (and (< (- west east) 1500) + (< (- south north) 1500)) (labels ((x-y-to-lon-lat (x y) (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) (- +nw-utm-y+ y) +utm-zone+ t)))

1 0

[bknr-cvs] hans changed trunk/projects/bos/payment-website/static/poi-ms/poi-ms.
by BKNR Commits 14 Dec '08

14 Dec '08

Revision: 4134 Author: hans URL: http://bknr.net/trac/changeset/4134 Popups for sponsor markers. U trunk/projects/bos/payment-website/static/poi-ms/poi-ms.css U trunk/projects/bos/payment-website/static/poi-ms/poi-ms.js Modified: trunk/projects/bos/payment-website/static/poi-ms/poi-ms.css =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms/poi-ms.css 2008-12-14 09:09:05 UTC (rev 4133) +++ trunk/projects/bos/payment-website/static/poi-ms/poi-ms.css 2008-12-14 13:58:07 UTC (rev 4134) @@ -146,3 +146,6 @@ width: 505px; height: 200px; } + +table.sponsor-info-popup th { text-align: left } +table.sponsor-info-popup td { max-width: 15em } \ No newline at end of file Modified: trunk/projects/bos/payment-website/static/poi-ms/poi-ms.js =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms/poi-ms.js 2008-12-14 09:09:05 UTC (rev 4133) +++ trunk/projects/bos/payment-website/static/poi-ms/poi-ms.js 2008-12-14 13:58:07 UTC (rev 4134) @@ -351,36 +351,43 @@ this.sponsorMarkers = []; + function makeTable(rows) { + return TABLE({ 'class': 'sponsor-info-popup' }, + TBODY(null, + map(function (row) { + return TR(null, + TH(null, NLS(row[0])), + TD(null, row[1])); + }, rows))); + } + this.setSponsorMarker = function (sponsor) { var position = pointToLatLng(sponsor.contracts[0].centerX, sponsor.contracts[0].centerY); var sponsorMarker = new GMarker(position); + log('sponsor: ' + serializeJSON(sponsor)); + var info = [ + [ "Name", sponsor.name || NLS("[anonym]") ], + [ "Country", sponsor.country ], + [ "Anzahl m²", sponsor.contracts[0].count ] + ]; + if (sponsor.infoText && !sponsor.infoText.match(/^ *$/)) { + info.push([ "Info", sponsor.infoText ]); + } + sponsorMarker.bindInfoWindow(makeTable(info)); this.map.addOverlay(sponsorMarker); this.sponsorMarkers.push(sponsorMarker); } this.removeSponsorMarkers = function () { - try { - map(bind(this.map.removeOverlay, this.map), this.sponsorMarkers); - this.sponsorMarkers = []; - } - catch (e) { - log('error removing sponsor markers: ' + e); - } + map(bind(this.map.removeOverlay, this.map), this.sponsorMarkers); + this.sponsorMarkers = []; } - this.startMapMovedChecker = function () { - } - this.putSponsorPlacemarks = function(data) { log('got ' + data.sponsors.length + ' sponsors to display'); this.removeSponsorMarkers(); - try { - map(bind(this.setSponsorMarker, this), data.sponsors); - this.checkMapMoved(); - } - catch (e) { - log('error removing sponsor markers: ' + e); - } + map(bind(this.setSponsorMarker, this), data.sponsors); + this.checkMapMoved(); } this.checkMapMoved = function() {

1 0

[bknr-cvs] hans changed trunk/projects/bos/
by BKNR Commits 14 Dec '08

14 Dec '08

Revision: 4133 Author: hans URL: http://bknr.net/trac/changeset/4133 Display sponsors in map. U trunk/projects/bos/payment-website/static/poi-ms/poi-ms.js U trunk/projects/bos/web/contract-tree.lisp U trunk/projects/bos/web/sponsor-handlers.lisp Modified: trunk/projects/bos/payment-website/static/poi-ms/poi-ms.js =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms/poi-ms.js 2008-12-13 21:04:38 UTC (rev 4132) +++ trunk/projects/bos/payment-website/static/poi-ms/poi-ms.js 2008-12-14 09:09:05 UTC (rev 4133) @@ -276,8 +276,17 @@ log('map clicked, overlay: ' + overlay + ' latlng: ' + latlng + ' overlaylatlng: ' + overlaylatlng); } + function latLngToPoint(latLng) { + return projection.fromLatLngToPixel(latLng, 6); + } + this.moveEnd = function () { - log('map has moved'); + var bounds = this.map.getBounds(); + var sw = latLngToPoint(bounds.getSouthWest()); + var ne = latLngToPoint(bounds.getNorthEast()); + log('map has moved: ' + sw.x + ',' + ne.y + ',' + ne.x + ',' + sw.y); + + this.sponsorQuery = sw.x + ',' + ne.y + ',' + ne.x + ',' + sw.y; } GEvent.addListener(this.map, "click", bind(this.mapClicked, this)); @@ -340,15 +349,51 @@ this.map.addOverlay(marker); } + this.sponsorMarkers = []; + this.setSponsorMarker = function (sponsor) { var position = pointToLatLng(sponsor.contracts[0].centerX, sponsor.contracts[0].centerY); - if (this.sponsorMarker) { - this.sponsorMarker.setLatLng(position); + var sponsorMarker = new GMarker(position); + this.map.addOverlay(sponsorMarker); + this.sponsorMarkers.push(sponsorMarker); + } + + this.removeSponsorMarkers = function () { + try { + map(bind(this.map.removeOverlay, this.map), this.sponsorMarkers); + this.sponsorMarkers = []; + } + catch (e) { + log('error removing sponsor markers: ' + e); + } + } + + this.startMapMovedChecker = function () { + } + + this.putSponsorPlacemarks = function(data) { + log('got ' + data.sponsors.length + ' sponsors to display'); + this.removeSponsorMarkers(); + try { + map(bind(this.setSponsorMarker, this), data.sponsors); + this.checkMapMoved(); + } + catch (e) { + log('error removing sponsor markers: ' + e); + } + } + + this.checkMapMoved = function() { + if (this.sponsorQuery) { + loadJSONDoc('/sponsors-json?at=' + this.sponsorQuery) + .addCallback(bind(this.putSponsorPlacemarks, this)); + this.sponsorQuery = null; } else { - this.sponsorMarker = new GMarker(position); - this.map.addOverlay(this.sponsorMarker); + callLater(0.5, bind(this.checkMapMoved, this)); } } + + this.checkMapMoved(); } var pages = { Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-12-13 21:04:38 UTC (rev 4132) +++ trunk/projects/bos/web/contract-tree.lisp 2008-12-14 09:09:05 UTC (rev 4133) @@ -443,18 +443,23 @@ #'contract-tree-changed)) (defun contract-size (contract) - (length (contract-m2s contract))) + (apply #'max (cddr (contract-bounding-box contract)))) +(defun geo-box-size (geo-box) + (apply #'max (multiple-value-list (width-height (geo-box-rectangle geo-box))))) + (defun contracts-in-geo-box (geo-box &key limit) "Return all contracts that intersect the given GEO-BOX. If LIMIT is specified, the LIMIT largest contracts are returned." (let ((return-count 0) - (contracts (list nil))) + (contracts (list nil)) + (min-size (floor (/ (geo-box-size geo-box) 10)))) (ensure-intersecting-children *contract-tree* geo-box (lambda (node) (dolist (contract (placemark-contracts node)) - (when (geo-box-encloses-p geo-box (contract-geo-box contract)) + (when (and (geo-box-encloses-p geo-box (contract-geo-box contract)) + (>= (geo-box-size (contract-geo-box contract)) min-size)) (when (and limit (>= return-count limit)) (if (<= (contract-size contract) @@ -468,11 +473,11 @@ (contract-size (cadr point)))) (setf (cdr point) (cons contract (cdr point)))))))) (lambda (node) - (or (and limit + (or (and nil limit (>= return-count limit)) (leaf-node-p node)))) (cdr contracts))) -y(register-transient-init-function 'make-contract-tree-from-m2 +(register-transient-init-function 'make-contract-tree-from-m2 'make-quad-tree 'geometry:make-rect-publisher) Modified: trunk/projects/bos/web/sponsor-handlers.lisp =================================================================== --- trunk/projects/bos/web/sponsor-handlers.lisp 2008-12-13 21:04:38 UTC (rev 4132) +++ trunk/projects/bos/web/sponsor-handlers.lisp 2008-12-14 09:09:05 UTC (rev 4133) @@ -361,14 +361,16 @@ (defun sponsors-at (query) (when (cl-ppcre:scan "^[0-9,]+$" query) (destructuring-bind (east north west south) (mapcar #'parse-integer (cl-ppcre:split "," query)) - (labels - ((x-y-to-lon-lat (x y) - (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) (- +nw-utm-y+ y) +utm-zone+ t))) - (mapcar #'contract-sponsor - (contracts-in-geo-box (coerce (append (x-y-to-lon-lat east north) - (x-y-to-lon-lat west south)) - '(vector double-float)) - :limit 10)))))) + (when (and (< (- west east) 1000) + (< (- south north) 1000)) + (labels + ((x-y-to-lon-lat (x y) + (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) (- +nw-utm-y+ y) +utm-zone+ t))) + (mapcar #'contract-sponsor + (contracts-in-geo-box (coerce (append (x-y-to-lon-lat east north) + (x-y-to-lon-lat west south)) + '(vector double-float)) + :limit 20))))))) (defun largest-sponsors () (mapcar #'contract-sponsor

1 0

[bknr-cvs] hans changed trunk/projects/bos/web/
by BKNR Commits 13 Dec '08

13 Dec '08

Revision: 4132 Author: hans URL: http://bknr.net/trac/changeset/4132 Query sponsors by geo rectangle. U trunk/projects/bos/web/contract-tree.lisp U trunk/projects/bos/web/sponsor-handlers.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-12-10 14:15:39 UTC (rev 4131) +++ trunk/projects/bos/web/contract-tree.lisp 2008-12-13 21:04:38 UTC (rev 4132) @@ -126,10 +126,10 @@ (insert-contract contract-tree contract) (remove-contract contract-tree contract))))) -(defmacro handle-if-node-modified (&body body) +(defmacro handle-if-node-modified ((node) &body body) `(let* ((path (parse-path path)) - (node (find-node-with-path *contract-tree* path))) - (hunchentoot:handle-if-modified-since (timestamp node)) + (,node (find-node-with-path *contract-tree* path))) + (hunchentoot:handle-if-modified-since (timestamp ,node)) ,@body)) ;;; contract-placemark-handler @@ -218,7 +218,7 @@ :root-element "kml") (with-query-params ((lang "en") (path) (rmcpath) (rmcid)) - (handle-if-node-modified + (handle-if-node-modified (node) (setf (hunchentoot:header-out :last-modified) (hunchentoot:rfc-1123-date (timestamp node))) (let* ((lod (node-lod node)) @@ -442,6 +442,37 @@ (list 0 0 +width+ +width+) #'contract-tree-changed)) -(register-transient-init-function 'make-contract-tree-from-m2 +(defun contract-size (contract) + (length (contract-m2s contract))) + +(defun contracts-in-geo-box (geo-box &key limit) + "Return all contracts that intersect the given GEO-BOX. If LIMIT is +specified, the LIMIT largest contracts are returned." + (let ((return-count 0) + (contracts (list nil))) + (ensure-intersecting-children *contract-tree* + geo-box + (lambda (node) + (dolist (contract (placemark-contracts node)) + (when (geo-box-encloses-p geo-box (contract-geo-box contract)) + (when (and limit + (>= return-count limit)) + (if (<= (contract-size contract) + (contract-size (cadr contracts))) + (return) + (setf contracts (cons nil (cddr contracts))))) + (incf return-count) + (do ((point contracts (cdr point))) + ((or (null (cddr point)) + (< (contract-size contract) + (contract-size (cadr point)))) + (setf (cdr point) (cons contract (cdr point)))))))) + (lambda (node) + (or (and limit + (>= return-count limit)) + (leaf-node-p node)))) + (cdr contracts))) + +y(register-transient-init-function 'make-contract-tree-from-m2 'make-quad-tree 'geometry:make-rect-publisher) Modified: trunk/projects/bos/web/sponsor-handlers.lisp =================================================================== --- trunk/projects/bos/web/sponsor-handlers.lisp 2008-12-10 14:15:39 UTC (rev 4131) +++ trunk/projects/bos/web/sponsor-handlers.lisp 2008-12-13 21:04:38 UTC (rev 4132) @@ -358,6 +358,18 @@ (class-instances 'sponsor) :key (compose #'string-downcase #'user-full-name)))) +(defun sponsors-at (query) + (when (cl-ppcre:scan "^[0-9,]+$" query) + (destructuring-bind (east north west south) (mapcar #'parse-integer (cl-ppcre:split "," query)) + (labels + ((x-y-to-lon-lat (x y) + (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) (- +nw-utm-y+ y) +utm-zone+ t))) + (mapcar #'contract-sponsor + (contracts-in-geo-box (coerce (append (x-y-to-lon-lat east north) + (x-y-to-lon-lat west south)) + '(vector double-float)) + :limit 10)))))) + (defun largest-sponsors () (mapcar #'contract-sponsor (subseq (sort (copy-list (class-instances 'contract)) @@ -373,6 +385,8 @@ (cond ((query-param "q") (sponsors-matching (query-param "q"))) + ((query-param "at") + (sponsors-at (query-param "at"))) ((query-param "largest") (largest-sponsors)) (t

1 0

[bknr-cvs] hans changed deployed/bos/projects/bos/m2/m2-pdf.lisp
by BKNR Commits 10 Dec '08

10 Dec '08

Revision: 4131 Author: hans URL: http://bknr.net/trac/changeset/4131 merge from trunk: new cert positioning U deployed/bos/projects/bos/m2/m2-pdf.lisp Modified: deployed/bos/projects/bos/m2/m2-pdf.lisp =================================================================== --- deployed/bos/projects/bos/m2/m2-pdf.lisp 2008-12-10 12:27:59 UTC (rev 4130) +++ deployed/bos/projects/bos/m2/m2-pdf.lisp 2008-12-10 14:15:39 UTC (rev 4131) @@ -21,14 +21,14 @@ (last-m2 (first (last m2s))) (scale (/ 80 (max bb-width bb-height)))) - (draw-coordinate 110 160 (m2-lon-lat first-m2)) + (draw-coordinate 140 240 (m2-lon-lat first-m2)) (unless (eq first-m2 last-m2) - (draw-coordinate 190 40 (m2-lon-lat last-m2))) + (draw-coordinate 220 120 (m2-lon-lat last-m2))) - (pdf:translate (+ 65.0 (if (>= bb-width bb-height) 0 + (pdf:translate (+ 95.0 (if (>= bb-width bb-height) 0 (* 0.5 (abs (- bb-width bb-height)) scale))) - (+ 65.0 (if (>= bb-height bb-width) 0 + (+ 145.0 (if (>= bb-height bb-width) 0 (* 0.5 (abs (- bb-width bb-height)) scale)))) (pdf:scale scale scale)

1 0

[bknr-cvs] hans changed trunk/projects/bos/m2/m2-pdf.lisp
by BKNR Commits 10 Dec '08

10 Dec '08

Revision: 4130 Author: hans URL: http://bknr.net/trac/changeset/4130 Move m2 graphics to correct place on new certificate. U trunk/projects/bos/m2/m2-pdf.lisp Modified: trunk/projects/bos/m2/m2-pdf.lisp =================================================================== --- trunk/projects/bos/m2/m2-pdf.lisp 2008-12-10 10:56:53 UTC (rev 4129) +++ trunk/projects/bos/m2/m2-pdf.lisp 2008-12-10 12:27:59 UTC (rev 4130) @@ -21,14 +21,14 @@ (last-m2 (first (last m2s))) (scale (/ 80 (max bb-width bb-height)))) - (draw-coordinate 110 160 (m2-lon-lat first-m2)) + (draw-coordinate 140 240 (m2-lon-lat first-m2)) (unless (eq first-m2 last-m2) - (draw-coordinate 190 40 (m2-lon-lat last-m2))) + (draw-coordinate 220 120 (m2-lon-lat last-m2))) - (pdf:translate (+ 65.0 (if (>= bb-width bb-height) 0 + (pdf:translate (+ 95.0 (if (>= bb-width bb-height) 0 (* 0.5 (abs (- bb-width bb-height)) scale))) - (+ 65.0 (if (>= bb-height bb-width) 0 + (+ 145.0 (if (>= bb-height bb-width) 0 (* 0.5 (abs (- bb-width bb-height)) scale)))) (pdf:scale scale scale)

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/server.lisp
by BKNR Commits 10 Dec '08

10 Dec '08

Revision: 4129 Author: hans URL: http://bknr.net/trac/changeset/4129 Ignore ECONNABORTED errors while accepting incoming connections. U trunk/thirdparty/hunchentoot/server.lisp Modified: trunk/thirdparty/hunchentoot/server.lisp =================================================================== --- trunk/thirdparty/hunchentoot/server.lisp 2008-12-10 10:54:45 UTC (rev 4128) +++ trunk/thirdparty/hunchentoot/server.lisp 2008-12-10 10:56:53 UTC (rev 4129) @@ -399,13 +399,17 @@ (usocket:wait-for-input listener :timeout +new-connection-wait-time+))) ((server-shutdown-p server)) (when new-connection-p - (let ((client-connection (usocket:socket-accept listener))) - (when client-connection - (set-timeouts client-connection - (server-read-timeout server) - (server-write-timeout server)) - (handle-incoming-connection (server-connection-manager server) - client-connection)))))))) + (handler-case + (let ((client-connection (usocket:socket-accept listener))) + (when client-connection + (set-timeouts client-connection + (server-read-timeout server) + (server-write-timeout server)) + (handle-incoming-connection (server-connection-manager server) + client-connection))) + (usocket:connection-aborted-error () + ;; ignore condition + ))))))) (defgeneric initialize-connection-stream (server stream) (:documentation "Wraps the given STREAM with all the additional

1 0

[bknr-cvs] hans changed trunk/thirdparty/usocket/
by BKNR Commits 10 Dec '08

10 Dec '08

Revision: 4128 Author: hans URL: http://bknr.net/trac/changeset/4128 update from upstream svn _U trunk/thirdparty/usocket/ U trunk/thirdparty/usocket/condition.lisp Property changes on: trunk/thirdparty/usocket ___________________________________________________________________ Name: piston:local-revision - 4126 + 4127 Name: piston:remote-revision - 480 + 481 Modified: trunk/thirdparty/usocket/condition.lisp =================================================================== --- trunk/thirdparty/usocket/condition.lisp 2008-12-10 10:51:55 UTC (rev 4127) +++ trunk/thirdparty/usocket/condition.lisp 2008-12-10 10:54:45 UTC (rev 4128) @@ -1,4 +1,4 @@ -;;;; $Id: condition.lisp 451 2008-10-22 01:11:56Z ctian $ +;;;; $Id: condition.lisp 481 2008-12-10 10:52:01Z hhubner $ ;;;; $URL: svn://common-lisp.net/project/usocket/svn/usocket/trunk/condition.lisp $ ;;;; See LICENSE for licensing information. @@ -184,7 +184,7 @@ ((9) . bad-file-descriptor-error) ((61 111) . connection-refused-error) ((64 131) . connection-reset-error) - ((130) . connection-aborted-error) + ((53 103) . connection-aborted-error) ((22) . invalid-argument-error) ((55 105) . no-buffers-error) ((12) . out-of-memory-error)

1 0

[bknr-cvs] hans changed trunk/thirdparty/usocket/
by BKNR Commits 10 Dec '08

10 Dec '08

Revision: 4127 Author: hans URL: http://bknr.net/trac/changeset/4127 move to usocket trunk A trunk/thirdparty/usocket/ A trunk/thirdparty/usocket/LICENSE A trunk/thirdparty/usocket/Makefile A trunk/thirdparty/usocket/README A trunk/thirdparty/usocket/TODO A trunk/thirdparty/usocket/backend/ A trunk/thirdparty/usocket/backend/allegro.lisp A trunk/thirdparty/usocket/backend/armedbear.lisp A trunk/thirdparty/usocket/backend/clisp.lisp A trunk/thirdparty/usocket/backend/cmucl.lisp A trunk/thirdparty/usocket/backend/lispworks.lisp A trunk/thirdparty/usocket/backend/openmcl.lisp A trunk/thirdparty/usocket/backend/sbcl.lisp A trunk/thirdparty/usocket/backend/scl.lisp A trunk/thirdparty/usocket/condition.lisp A trunk/thirdparty/usocket/doc/ A trunk/thirdparty/usocket/doc/backends.txt A trunk/thirdparty/usocket/doc/design.txt A trunk/thirdparty/usocket/notes/ A trunk/thirdparty/usocket/notes/abcl-socket.txt A trunk/thirdparty/usocket/notes/active-sockets-apis.txt A trunk/thirdparty/usocket/notes/address-apis.txt A trunk/thirdparty/usocket/notes/allegro-socket.txt A trunk/thirdparty/usocket/notes/clisp-sockets.txt A trunk/thirdparty/usocket/notes/cmucl-sockets.txt A trunk/thirdparty/usocket/notes/errors.txt A trunk/thirdparty/usocket/notes/lw-sockets.txt A trunk/thirdparty/usocket/notes/openmcl-sockets.txt A trunk/thirdparty/usocket/notes/sb-bsd-sockets.txt A trunk/thirdparty/usocket/notes/usock-sockets.txt A trunk/thirdparty/usocket/package.lisp A trunk/thirdparty/usocket/run-usocket-tests.sh A trunk/thirdparty/usocket/test/ A trunk/thirdparty/usocket/test/abcl.conf.in A trunk/thirdparty/usocket/test/allegro.conf.in A trunk/thirdparty/usocket/test/clisp.conf.in A trunk/thirdparty/usocket/test/cmucl.conf.in A trunk/thirdparty/usocket/test/package.lisp A trunk/thirdparty/usocket/test/sbcl.conf.in A trunk/thirdparty/usocket/test/test-usocket.lisp A trunk/thirdparty/usocket/test/usocket-test.asd A trunk/thirdparty/usocket/test/your-lisp.conf.in A trunk/thirdparty/usocket/usocket.asd A trunk/thirdparty/usocket/usocket.lisp Change set too large, please see URL above

1 0

[bknr-cvs] hans changed trunk/thirdparty/usocket/
by BKNR Commits 10 Dec '08

10 Dec '08

Revision: 4126 Author: hans URL: http://bknr.net/trac/changeset/4126 moving to usocket trunk D trunk/thirdparty/usocket/

1 0