From bknr at bknr.net Mon Dec 1 12:23:47 2008 From: bknr at bknr.net (BKNR Commits) Date: Mon, 01 Dec 2008 13:23:47 +0100 Subject: [bknr-cvs] hans changed trunk/libraries/yason/ Message-ID: Revision: 4103 Author: hans URL: http://bknr.net/trac/changeset/4103 Add methods to serialize objects and slots, moved here from application code. U trunk/libraries/yason/encode.lisp U trunk/libraries/yason/package.lisp Modified: trunk/libraries/yason/encode.lisp =================================================================== --- trunk/libraries/yason/encode.lisp 2008-11-30 10:29:40 UTC (rev 4102) +++ trunk/libraries/yason/encode.lisp 2008-12-01 12:23:46 UTC (rev 4103) @@ -47,6 +47,14 @@ (encode (float object) stream) object) +(defmethod encode ((object double-float) &optional (stream *standard-output*)) + (encode (coerce object 'single-float) stream) + object) + +(defmethod encode ((object float) &optional (stream *standard-output*)) + (princ object stream) + object) + (defmethod encode ((object integer) &optional (stream *standard-output*)) (princ object stream)) @@ -212,3 +220,19 @@ (progn , at body) (setf (car (stack *json-output*)) #\,)))) +(defgeneric encode-slots (object) + (:method-combination progn) + (:documentation + "Generic function to encode objects. Every class in a hierarchy + implements a method for ENCODE-OBJECT that serializes its slots. + It is a PROGN generic function so that for a given instance, all + slots are serialized by invoking the ENCODE-OBJECT method for all + classes that it inherits from.")) + +(defgeneric encode-object (object) + (:documentation + "Encode OBJECT, presumably a CLOS object as a JSON object, invoking + the ENCODE-SLOTS method as appropriate.") + (:method (object) + (with-object () + (json:encode-slots object)))) \ No newline at end of file Modified: trunk/libraries/yason/package.lisp =================================================================== --- trunk/libraries/yason/package.lisp 2008-11-30 10:29:40 UTC (rev 4102) +++ trunk/libraries/yason/package.lisp 2008-12-01 12:23:46 UTC (rev 4103) @@ -23,6 +23,8 @@ ;; Basic encoder interface #:encode + #:encode-slots + #:encode-object ;; Streaming encoder interface #:with-output From bknr at bknr.net Mon Dec 1 12:33:59 2008 From: bknr at bknr.net (BKNR Commits) Date: Mon, 01 Dec 2008 13:33:59 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/ Message-ID: Revision: 4104 Author: hans URL: http://bknr.net/trac/changeset/4104 Refactor sat-tree handler. Move to new JSON object serialization API. Experiment with satellite image in JS. U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/m2/poi.lisp U trunk/projects/bos/payment-website/static/poi-ms.html U trunk/projects/bos/payment-website/static/poi-ms.js U trunk/projects/bos/web/poi-handlers.lisp U trunk/projects/bos/web/sat-tree.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-12-01 12:23:46 UTC (rev 4103) +++ trunk/projects/bos/m2/m2.lisp 2008-12-01 12:33:59 UTC (rev 4104) @@ -698,7 +698,7 @@ left top width height (format-date-time (contract-date contract) :show-time nil)))))) -(defmethod json-encode progn ((contract contract)) +(defmethod json:encode-slots progn ((contract contract)) (destructuring-bind (left top width height) (contract-bounding-box contract) (json:encode-object-elements "timestamp" (format-date-time (contract-date contract) :mail-style t) @@ -708,7 +708,7 @@ "width" width "height" height))) -(defmethod json-encode progn ((sponsor sponsor)) +(defmethod json:encode-slots progn ((sponsor sponsor)) (json:encode-object-elements "name" (user-full-name sponsor) "country" (or (sponsor-country sponsor) "sponsor-country-unknown") @@ -718,15 +718,13 @@ (json:with-object-element ("contracts") (json:with-array () (dolist (contract (sponsor-paid-contracts sponsor)) - (json:with-object () - (json-encode contract)))))) + (json:encode-object contract))))) (defun sponsors-as-json (sponsors) "Render the SPONSORS as JSON" (json:with-array () (dolist (sponsor sponsors) - (json:with-object () - (json-encode sponsor))))) + (json:encode-object sponsor)))) (defun delete-directory (pathname) (cl-fad:delete-directory-and-files pathname :if-does-not-exist :ignore)) Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-12-01 12:23:46 UTC (rev 4103) +++ trunk/projects/bos/m2/poi.lisp 2008-12-01 12:33:59 UTC (rev 4104) @@ -303,55 +303,50 @@ (defmethod json:encode ((object symbol) &optional stream) (json:encode (string-downcase (symbol-name object)) stream)) -(defgeneric json-encode (object) - (:method-combination progn)) - -(defmethod json-encode progn ((object store-object)) +(defmethod json:encode-slots progn ((object store-object)) (json:encode-object-element "id" (store-object-id object))) -(defmethod json-encode progn ((poi poi)) +(defmethod json:encode-slots progn ((poi poi)) (json:encode-object-elements "name" (poi-name poi) "icon" (poi-icon poi) "x" (poi-center-x poi) - "y" (poi-center-y poi))) + "y" (poi-center-y poi)) + (json:with-object-element ("media") + (json:with-array () + (dolist (medium (poi-media poi)) + (json:encode-object medium))))) -(defmethod json-encode progn ((blob blob)) +(defmethod json:encode-slots progn ((blob blob)) (json:encode-object-elements "type" (blob-type blob) "timestamp" (format-date-time (blob-timestamp blob) :mail-style t))) -(defmethod json-encode progn ((image store-image)) +(defmethod json:encode-slots progn ((image store-image)) (json:encode-object-elements "name" (store-image-name image) "width" (store-image-width image) "height" (store-image-height image))) -(defmethod json-encode progn ((object bos.m2::textual-attributes-mixin)) +(defmethod json:encode-slots progn ((object bos.m2::textual-attributes-mixin)) (dolist (field '(title subtitle description)) (let ((string (slot-string object field *language*))) (unless (equal "" string) (json:encode-object-element field string))))) -(defmethod json-encode progn ((medium poi-medium)) +(defmethod json:encode-slots progn ((medium poi-medium)) (json:encode-object-element "mediumType" (cl-ppcre:regex-replace "^poi-" (string-downcase (class-name (class-of medium))) ""))) -(defmethod json-encode progn ((movie poi-movie)) +(defmethod json:encode-slots progn ((movie poi-movie)) (json:encode-object-elements "url" (poi-movie-url movie) "timestamp" (format-date-time (poi-medium-creation-time movie) :mail-style t))) (defun poi-as-json (poi language) (let ((*language* language)) - (json:with-object () - (json-encode poi) - (json:with-object-element ("media") - (json:with-array () - (dolist (medium (poi-media poi)) - (json:with-object () - (json-encode medium)))))))) + (json:encode-object poi))) (defun pois-as-json (language) (json:with-array () Modified: trunk/projects/bos/payment-website/static/poi-ms.html =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-01 12:23:46 UTC (rev 4103) +++ trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-01 12:33:59 UTC (rev 4104) @@ -26,7 +26,8 @@
Modified: trunk/projects/bos/payment-website/static/poi-ms.js =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-01 12:23:46 UTC (rev 4103) +++ trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-01 12:33:59 UTC (rev 4104) @@ -13,6 +13,10 @@ return key; // for now } +function log2(x) { + return Math.log(x) / Math.LN2; +} + var B = createDOMFunc('b', null); var OBJECT = createDOMFunc('object'); var PARAM = createDOMFunc('param'); @@ -89,6 +93,30 @@ P(null, medium.description)); } +var SAT_MAP_SIZE = 28800; + +function makePath(size, x, y) { + var depth = log2(SAT_MAP_SIZE / size); + var path = ''; + var xPos = 0; + var yPos = 0; + var currentSize = SAT_MAP_SIZE; + for (var i = 0; i < Math.min(depth, 6); i++) { + currentSize /= 2; + var index + = ((x > (xPos + currentSize)) ? 1 : 0) + + ((y > (yPos + currentSize)) ? 2 : 0); + if (index & 1) { + xPos += currentSize; + } + if (index & 2) { + yPos += currentSize; + } + path += index; + } + return path; +} + function makeMap(centerX, centerY) { var rows = []; @@ -198,6 +226,12 @@ DIV({ 'class': 'map' }, elements)); $('#left-bar') + .empty(); +} + +function showSponsors() { + + $('#left-bar') .empty() .append(H3(NLS("Letzte Sponsoren")), UL({ id: 'sponsor-list' })); Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-12-01 12:23:46 UTC (rev 4103) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-12-01 12:33:59 UTC (rev 4104) @@ -696,4 +696,4 @@ (poi-handle-if-modified-since) (with-json-response () (json:with-object-element ("pois") - (bos.m2:pois-as-json (request-language))))) \ No newline at end of file + (bos.m2:pois-as-json (request-language))))) Modified: trunk/projects/bos/web/sat-tree.lisp =================================================================== --- trunk/projects/bos/web/sat-tree.lisp 2008-12-01 12:23:46 UTC (rev 4103) +++ trunk/projects/bos/web/sat-tree.lisp 2008-12-01 12:33:59 UTC (rev 4104) @@ -3,6 +3,16 @@ (defclass sat-node (node-extension) ((image :accessor image :initarg :image))) +(defmethod json:encode-slots progn ((sat-node sat-node)) + (json:with-object-element ("satImage") + (json:encode-object (image sat-node))) + (json:with-object-element ("children") + (json:with-array () + (dotimes (i 4) + (json:encode-array-element + (when (child sat-node i) + (store-object-id (image (child sat-node i))))))))) + (defpersistent-class sat-layer () ((name :reader name :initarg :name :index-type unique-index @@ -66,6 +76,16 @@ :type geo-box :documentation "can be different from base-node's geo-box"))) +(defmethod json:encode-slots progn ((sat-image sat-image)) + (json:encode-object-element "path" (path sat-image)) + (json:with-object-element ("geoBox") + (json:with-array () + (json:encode-array-elements + (aref (image-geo-box sat-image) 0) + (aref (image-geo-box sat-image) 1) + (aref (image-geo-box sat-image) 2) + (aref (image-geo-box sat-image) 3))))) + (defmethod print-object ((obj sat-image) stream) (print-unreadable-object (obj stream :type t :identity t) (format stream "~s of layer ~s" (path obj) (name (layer obj))))) @@ -202,50 +222,64 @@ ;;; handlers -(defclass sat-tree-kml-handler (page-handler) +(defclass sat-node-handler (object-handler) ()) -(defmethod handle ((handler sat-tree-kml-handler)) - (with-query-params ((path) (name)) - (let ((path (parse-path path)) - (layer (find-sat-layer (intern (string-upcase name) #.(find-package "KEYWORD"))))) - (assert layer nil "Cannnot find layer of name ~s." name) - (let* ((quad-node (find-node-with-path *quad-tree* path)) - (sat-node (find-if (lambda (e) (and (eql (name e) (name layer)) - (typep e 'sat-node))) - (extensions quad-node)))) - (assert sat-node nil "There is no sat-node of name ~s at path ~s." name path) - (let ((sat-image (image sat-node))) - (hunchentoot:handle-if-modified-since (blob-timestamp sat-image)) - (with-xml-response (:content-type "text/xml" #+nil"application/vnd.google-earth.kml+xml" - :root-element "kml") - (setf (hunchentoot:header-out :last-modified) - (hunchentoot:rfc-1123-date (blob-timestamp sat-image))) - (let ((lod (node-lod sat-node)) - (rect (geo-box-rectangle (geo-box sat-node)))) - (with-element "Document" - (kml-region rect lod) - (kml-overlay (format nil "http://~a/image/~d" (website-host) (store-object-id sat-image)) - (geo-box-rectangle (image-geo-box sat-image)) - :draw-order (compute-draw-order sat-node (local-draw-order layer)) - ;; :absolute 0 - ) - (let ((*print-case* :downcase)) - (dotimes (i 4) - (let ((child (child sat-node i))) - (when child - (kml-network-link (format nil "http://~A/sat-tree-kml?name=~A&path=~{~D~}" - (website-host) (name layer) (append path (list i))) - :rect (geo-box-rectangle (geo-box child)) - :lod (node-lod child)))))))))))))) +(defmethod object-handler-get-object ((handler sat-node-handler)) + (with-query-params (path name) + (let* ((path (parse-path path)) + (layer (or (find-sat-layer (make-keyword-from-string name)) + (error "Cannnot find layer of name ~s." name))) + (quad-node (find-node-with-path *quad-tree* path)) + (sat-node (find-if (lambda (e) + (and (eql (name e) (name layer)) + (typep e 'sat-node))) + (extensions quad-node)))) + (assert sat-node nil "There is no sat-node of name ~s at path ~s." name path) + sat-node))) +(defmethod handle-object :before ((handler sat-node-handler) sat-node) + (hunchentoot:handle-if-modified-since (blob-timestamp (image sat-node))) + (setf (hunchentoot:header-out :last-modified) + (hunchentoot:rfc-1123-date (blob-timestamp (image sat-node))))) + +(defclass sat-tree-kml-handler (sat-node-handler) + ()) + +(defmethod handle-object ((handler sat-tree-kml-handler) sat-node) + (with-query-params (path name) + (with-xml-response (:content-type "text/xml" #+nil"application/vnd.google-earth.kml+xml" + :root-element "kml") + (with-element "Document" + (kml-region (geo-box-rectangle (geo-box sat-node)) (node-lod sat-node)) + (kml-overlay (format nil "http://~a/image/~d" (website-host) (store-object-id (image sat-node))) + (geo-box-rectangle (image-geo-box (image sat-node))) + :draw-order (compute-draw-order sat-node + (local-draw-order (find-sat-layer (make-keyword-from-string name)))) + ;; :absolute 0 + ) + (dotimes (i 4) + (when-let (child (child sat-node i)) + (kml-network-link (format nil "~(http://~A/sat-tree-kml?name=~A&path=~A~A~)" + (website-host) name path i) + :rect (geo-box-rectangle (geo-box child)) + :lod (node-lod child)))))))) + +(defclass sat-tree-json-handler (sat-node-handler) + ()) + +(defmethod handle-object ((handler sat-tree-json-handler) sat-node) + (with-json-response () + (json:with-object-element ("satNode") + (json:encode-object sat-node)))) + (defclass sat-root-kml-handler (page-handler) ()) (defmethod handle ((handler sat-root-kml-handler)) (with-query-params ((name)) (let ((*print-case* :downcase) - (layer (find-sat-layer (intern (string-upcase name) #.(find-package "KEYWORD"))))) + (layer (find-sat-layer (make-keyword-from-string name)))) (assert layer nil "Cannnot find layer of name ~s." name) (let ((top-level-nodes (sat-layer-top-level-nodes layer))) (assert top-level-nodes) Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-12-01 12:23:46 UTC (rev 4103) +++ trunk/projects/bos/web/webserver.lisp 2008-12-01 12:33:59 UTC (rev 4104) @@ -170,6 +170,7 @@ ("/contract-image" contract-image-handler) ("/contract" contract-handler) ("/sat-tree-kml" sat-tree-kml-handler) + ("/sat-tree-json" sat-tree-json-handler) ("/sat-root-kml" sat-root-kml-handler) ("/look-at-allocation-area" look-at-allocation-area-handler) ("/reports-xml" reports-xml-handler) From bknr at bknr.net Mon Dec 1 23:37:14 2008 From: bknr at bknr.net (BKNR Commits) Date: Tue, 02 Dec 2008 00:37:14 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/m2/ Message-ID: Revision: 4105 Author: hans URL: http://bknr.net/trac/changeset/4105 Add simple satellite map quadtree U trunk/projects/bos/m2/packages.lisp A trunk/projects/bos/m2/simple-sat-map.lisp Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-12-01 12:33:59 UTC (rev 4104) +++ trunk/projects/bos/m2/packages.lisp 2008-12-01 23:37:14 UTC (rev 4105) @@ -294,3 +294,12 @@ #:count-cache-entries #:pprint-cache #:allocation-cache-subsystem)) + +(defpackage :simple-sat-map + (:use :cl + :bknr.indices + :bknr.datastore + :alexandria) + (:shadowing-import-from :alexandria #:array-index) + (:nicknames :ssm) + ) \ No newline at end of file Added: trunk/projects/bos/m2/simple-sat-map.lisp =================================================================== --- trunk/projects/bos/m2/simple-sat-map.lisp (rev 0) +++ trunk/projects/bos/m2/simple-sat-map.lisp 2008-12-01 23:37:14 UTC (rev 4105) @@ -0,0 +1,61 @@ +(in-package :ssm) + +;; Simple Sat Map + +;; This satellite map interface works with square tiles of 256 pixels. +;; The original image is extended so that the number of pixels is a +;; power of two. The same dimensions are assumed in x and y +;; directions. It is then stored in a quad tree, with each node +;; having one image and four children. + +(define-persistent-class tree () + ((name :read) + (root :read))) + +(defun tree-with-name (name) + (find name (class-instances 'tree) + :key #'tree-name + :test #'string-equal)) + +(define-persistent-class node () + ((image :read) + (children :read :initform nil))) + +(defun import-image (image-filename &key (tile-size 256)) + (assert (= (log tile-size 2) (round (log tile-size 2))) + () "TILE-SIZE needs to be power of two") + (cl-gd:with-image-from-file (map-image image-filename) + (format t "~&; read image ~A, width ~A height ~A~%" + image-filename (cl-gd:image-width map-image) (cl-gd:image-height map-image)) + (let* ((basename (pathname-name image-filename)) + (pow (ceiling (log (max (cl-gd:image-height map-image) + (cl-gd:image-width map-image)) 2))) + (size (expt 2 pow)) + (levels (floor (- pow (log tile-size 2))))) + (format t "~&; pow ~A size ~A levels ~A~%" pow size levels) + (labels + ((write-quad (x y level) + (format t "; ~A ~A ~A~%" x y level) + (cl-gd:with-image (tile tile-size tile-size t) + (let ((tile-source-size (/ size (expt 2 level)))) + (cl-gd:copy-image map-image tile + (* x tile-source-size) (* y tile-source-size) + 0 0 + tile-source-size tile-source-size + :dest-width tile-size :dest-height tile-size + :resample t :resize t) + (apply #'make-instance 'node + :image (bknr.images:make-store-image :image tile + :name (format nil "~A-~A-~A-~A" + basename level x y)) + (when (< level levels) + (let ((next-tile-source-size (/ tile-source-size 2)) + (next-level (1+ level))) + (list :children + (list (write-quad x y next-level) + (write-quad (+ x next-tile-source-size) y next-level) + (write-quad x (+ y next-tile-source-size) next-level) + (write-quad (+ x next-tile-source-size) (+ y next-tile-source-size) next-level)))))))))) + (make-instance 'tree + :name basename + :root (write-quad 0 0 0)))))) \ No newline at end of file From bknr at bknr.net Tue Dec 2 22:00:37 2008 From: bknr at bknr.net (BKNR Commits) Date: Tue, 02 Dec 2008 23:00:37 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/ Message-ID: Revision: 4106 Author: hans URL: http://bknr.net/trac/changeset/4106 Add satellite map browser using Google Maps. U trunk/projects/bos/m2/simple-sat-map.lisp U trunk/projects/bos/payment-website/static/poi-ms.css U trunk/projects/bos/payment-website/static/poi-ms.html U trunk/projects/bos/payment-website/static/poi-ms.js U trunk/projects/bos/web/map-handlers.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/m2/simple-sat-map.lisp =================================================================== --- trunk/projects/bos/m2/simple-sat-map.lisp 2008-12-01 23:37:14 UTC (rev 4105) +++ trunk/projects/bos/m2/simple-sat-map.lisp 2008-12-02 22:00:36 UTC (rev 4106) @@ -39,7 +39,7 @@ (cl-gd:with-image (tile tile-size tile-size t) (let ((tile-source-size (/ size (expt 2 level)))) (cl-gd:copy-image map-image tile - (* x tile-source-size) (* y tile-source-size) + x y 0 0 tile-source-size tile-source-size :dest-width tile-size :dest-height tile-size @@ -58,4 +58,15 @@ (write-quad (+ x next-tile-source-size) (+ y next-tile-source-size) next-level)))))))))) (make-instance 'tree :name basename - :root (write-quad 0 0 0)))))) \ No newline at end of file + :root (write-quad 0 0 0)))))) + +(defclass simple-map-handler (bknr.images::imageproc-handler) + ()) + +(defmethod bknr.web:object-handler-get-object ((handler simple-map-handler)) + (let ((node (tree-root (tree-with-name (bknr.web:parse-url)))) + (path (or (bknr.web:query-param "path") ""))) + (dotimes (i (length path)) + (setf node (nth (parse-integer path :start i :end (1+ i)) + (node-children node)))) + (node-image node))) Modified: trunk/projects/bos/payment-website/static/poi-ms.css =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.css 2008-12-01 23:37:14 UTC (rev 4105) +++ trunk/projects/bos/payment-website/static/poi-ms.css 2008-12-02 22:00:36 UTC (rev 4106) @@ -34,3 +34,8 @@ .map .icon, .map .contract { position: absolute; } + +#google-map { + width: 400px; + height: 300px; +} \ No newline at end of file Modified: trunk/projects/bos/payment-website/static/poi-ms.html =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-01 23:37:14 UTC (rev 4105) +++ trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-02 22:00:36 UTC (rev 4106) @@ -1,4 +1,4 @@ - + POI Microsite @@ -7,6 +7,7 @@ + @@ -28,6 +29,7 @@
Modified: trunk/projects/bos/payment-website/static/poi-ms.js =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-01 23:37:14 UTC (rev 4105) +++ trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-02 22:00:36 UTC (rev 4106) @@ -2,6 +2,7 @@ $(document).ready(init); +var googleMapKey = "ABQIAAAA5meUSZ1F7u46UjJHEXSlJhQkkdysj0TmG3bX_n9aMEXHvIwNeRQLmdjbjYpAetJRis7naMxi-fqMRQ"; var pois = {}; var sponsors = []; @@ -163,29 +164,90 @@ $('#left-bar') .empty() .append(UL({ id: 'media-list' })); - if (!poi) { - showOverview(); - } else { - $('#poi-selector').val(poi.id); + $('#poi-selector').val(poi.id); - document.title = poi.title; - $('.yui-b h1').html(poi.title); - loadMainInfo(poi); - map(function (medium) { - if (mediaHandlers[medium.mediumType]) { - $('#media-list') - .append($(A({ href: '#' }, - LI(null, - mediaHandlers[medium.mediumType].icon(medium), - (new Date(medium.timestamp)).renderDate(), - BR(), - B(null, medium.title || medium.name)))) - .bind('click', medium, showMedium)); - } - }, poi.media); + document.title = poi.title; + $('.yui-b h1').html(poi.title); + loadMainInfo(poi); + map(function (medium) { + if (mediaHandlers[medium.mediumType]) { + $('#media-list') + .append($(A({ href: '#' }, + LI(null, + mediaHandlers[medium.mediumType].icon(medium), + (new Date(medium.timestamp)).renderDate(), + BR(), + B(null, medium.title || medium.name)))) + .bind('click', medium, showMedium)); + } + }, poi.media); +} + +function pointToPath(point, level) { + var x = point.x; + var y = point.y; + var path = ''; + for (var i = 0; i < level; i++) { + path = ((x & 1) + ((y & 1) << 1)) + path; + x >>= 1; + y >>= 1; } + return path; } +function showGoogleMap() { + var mapDiv = DIV({ id: 'google-map' }); + $('#content') + + .empty() + .append(H2(null, NLS('Google Map')), + mapDiv); + + $('#left-bar') + .empty(); + + var map = new GMap2(mapDiv); + + var copyright + = new GCopyright(1, + new GLatLngBounds(new GLatLng(-90, -180), new GLatLng(90, 180)), + 3, + "Copyright BOS Deutschland e.V."); + var copyrightCollection = new GCopyrightCollection('Map'); + copyrightCollection.addCopyright(copyright); + var tileLayers = [new GTileLayer(copyrightCollection, 0, 7)]; + var projection = new GMercatorProjection(7); + tileLayers[0].getTileUrl = function(point, level) { + if (level < 7) { + var path = pointToPath(point, level); + log('getTileUrl: x:' + point.x + ' y:' + point.y + ' level:' + level + ' path: ' + path); + return '/simple-map/sl_utm50s-0?path=' + path; + } else { + return null; + } + } + var customMap = new GMapType(tileLayers, projection, 'Map', { errorMessage: NLS("Keine Daten in dieser Zoomstufe") }); + map.addMapType(customMap); + map.addControl(new GLargeMapControl()); + + map.setCenter(new GLatLng(0, 0), 1, customMap); +} + +var pages = { + overview: showOverview, + map: showGoogleMap +} + +function selectPage(e) { + var value = e.target.value; + + if (value.match(/^\d+/)) { + showPOI(e); + } else if (pages[value]) { + pages[value](e); + } +} + function showSponsor(e) { var sponsor = e.data; var contract = sponsor.contracts[0]; @@ -275,7 +337,7 @@ pois[poi.id] = poi; $('#poi-selector').append(OPTION({ value: poi.id }, poi.title)); } - $('#poi-selector').bind('change', null, showPOI); + $('#poi-selector').bind('change', null, selectPage); loadJSONDoc('/sponsors-json').addCallback(loadSponsors); } Modified: trunk/projects/bos/web/map-handlers.lisp =================================================================== --- trunk/projects/bos/web/map-handlers.lisp 2008-12-01 23:37:14 UTC (rev 4105) +++ trunk/projects/bos/web/map-handlers.lisp 2008-12-02 22:00:36 UTC (rev 4106) @@ -4,7 +4,8 @@ (defun map-navigator (x y base-url &key formcheck) (labels ((pfeil-image (name) - (html ((:img :border "0" :width "16" :height "16" :src (format nil "/images/~:[trans.gif~;~:*pfeil-~A.gif~]" name))))) + (html ((:img :border "0" :width "16" :height "16" + :src (format nil "/images/~:[trans.gif~;~:*pfeil-~A.gif~]" name))))) (td-link-to (x y name &optional (link-format (concatenate 'string base-url "~D/~D"))) (html (:td (if (or (minusp x) (minusp y) Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-12-01 23:37:14 UTC (rev 4105) +++ trunk/projects/bos/web/webserver.lisp 2008-12-02 22:00:36 UTC (rev 4106) @@ -183,6 +183,7 @@ ("/poi-kml-look-at" poi-kml-look-at-handler) ("/poi-kml" poi-kml-handler) ("/map-browser" map-browser-handler) + ("/simple-map" ssm::simple-map-handler) ("/poi-javascript" poi-javascript-handler) ("/m2-javascript" m2-javascript-handler) ("/poi-json" poi-json-handler) From bknr at bknr.net Tue Dec 2 22:16:07 2008 From: bknr at bknr.net (BKNR Commits) Date: Tue, 02 Dec 2008 23:16:07 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/ Message-ID: Revision: 4107 Author: hans URL: http://bknr.net/trac/changeset/4107 fix compilation problems U trunk/projects/bos/m2/bos.m2.asd U trunk/projects/bos/m2/packages.lisp D trunk/projects/bos/m2/simple-sat-map.lisp U trunk/projects/bos/web/bos.web.asd U trunk/projects/bos/web/packages.lisp A trunk/projects/bos/web/simple-sat-map.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/m2/bos.m2.asd =================================================================== --- trunk/projects/bos/m2/bos.m2.asd 2008-12-02 22:00:36 UTC (rev 4106) +++ trunk/projects/bos/m2/bos.m2.asd 2008-12-02 22:16:07 UTC (rev 4107) @@ -3,10 +3,18 @@ (in-package :cl-user) (asdf:defsystem :bos.m2 - :depends-on (:bknr.datastore :bknr.modules :cl-smtp :cl-mime - :kmrcl :iterate :arnesi - :cl-pdf :cl-pdf-parser :screamer :cl-fad - :yason) + :depends-on (:bknr.datastore + :bknr.modules + :cl-smtp + :cl-mime + :kmrcl + :iterate + :arnesi + :cl-pdf + :cl-pdf-parser + :screamer + :cl-fad + :yason) :components ((:file "packages") (:file "geo-utm" :depends-on ("packages")) (:file "geometry" :depends-on ("packages")) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-12-02 22:00:36 UTC (rev 4106) +++ trunk/projects/bos/m2/packages.lisp 2008-12-02 22:16:07 UTC (rev 4107) @@ -293,13 +293,4 @@ #:add-area #:count-cache-entries #:pprint-cache - #:allocation-cache-subsystem)) - -(defpackage :simple-sat-map - (:use :cl - :bknr.indices - :bknr.datastore - :alexandria) - (:shadowing-import-from :alexandria #:array-index) - (:nicknames :ssm) - ) \ No newline at end of file + #:allocation-cache-subsystem)) \ No newline at end of file Deleted: trunk/projects/bos/m2/simple-sat-map.lisp =================================================================== --- trunk/projects/bos/m2/simple-sat-map.lisp 2008-12-02 22:00:36 UTC (rev 4106) +++ trunk/projects/bos/m2/simple-sat-map.lisp 2008-12-02 22:16:07 UTC (rev 4107) @@ -1,72 +0,0 @@ -(in-package :ssm) - -;; Simple Sat Map - -;; This satellite map interface works with square tiles of 256 pixels. -;; The original image is extended so that the number of pixels is a -;; power of two. The same dimensions are assumed in x and y -;; directions. It is then stored in a quad tree, with each node -;; having one image and four children. - -(define-persistent-class tree () - ((name :read) - (root :read))) - -(defun tree-with-name (name) - (find name (class-instances 'tree) - :key #'tree-name - :test #'string-equal)) - -(define-persistent-class node () - ((image :read) - (children :read :initform nil))) - -(defun import-image (image-filename &key (tile-size 256)) - (assert (= (log tile-size 2) (round (log tile-size 2))) - () "TILE-SIZE needs to be power of two") - (cl-gd:with-image-from-file (map-image image-filename) - (format t "~&; read image ~A, width ~A height ~A~%" - image-filename (cl-gd:image-width map-image) (cl-gd:image-height map-image)) - (let* ((basename (pathname-name image-filename)) - (pow (ceiling (log (max (cl-gd:image-height map-image) - (cl-gd:image-width map-image)) 2))) - (size (expt 2 pow)) - (levels (floor (- pow (log tile-size 2))))) - (format t "~&; pow ~A size ~A levels ~A~%" pow size levels) - (labels - ((write-quad (x y level) - (format t "; ~A ~A ~A~%" x y level) - (cl-gd:with-image (tile tile-size tile-size t) - (let ((tile-source-size (/ size (expt 2 level)))) - (cl-gd:copy-image map-image tile - x y - 0 0 - tile-source-size tile-source-size - :dest-width tile-size :dest-height tile-size - :resample t :resize t) - (apply #'make-instance 'node - :image (bknr.images:make-store-image :image tile - :name (format nil "~A-~A-~A-~A" - basename level x y)) - (when (< level levels) - (let ((next-tile-source-size (/ tile-source-size 2)) - (next-level (1+ level))) - (list :children - (list (write-quad x y next-level) - (write-quad (+ x next-tile-source-size) y next-level) - (write-quad x (+ y next-tile-source-size) next-level) - (write-quad (+ x next-tile-source-size) (+ y next-tile-source-size) next-level)))))))))) - (make-instance 'tree - :name basename - :root (write-quad 0 0 0)))))) - -(defclass simple-map-handler (bknr.images::imageproc-handler) - ()) - -(defmethod bknr.web:object-handler-get-object ((handler simple-map-handler)) - (let ((node (tree-root (tree-with-name (bknr.web:parse-url)))) - (path (or (bknr.web:query-param "path") ""))) - (dotimes (i (length path)) - (setf node (nth (parse-integer path :start i :end (1+ i)) - (node-children node)))) - (node-image node))) Modified: trunk/projects/bos/web/bos.web.asd =================================================================== --- trunk/projects/bos/web/bos.web.asd 2008-12-02 22:00:36 UTC (rev 4106) +++ trunk/projects/bos/web/bos.web.asd 2008-12-02 22:16:07 UTC (rev 4107) @@ -16,7 +16,10 @@ :description "worldpay test web server" :long-description "" - :depends-on (:bknr.web :bknr.modules :bos.m2 :cxml) + :depends-on (:bknr.web + :bknr.modules + :bos.m2 + :cxml) :components ((:file "packages") (:file "utf-8" :depends-on ("packages")) @@ -25,6 +28,7 @@ (:file "web-macros" :depends-on ("packages")) (:file "web-utils" :depends-on ("packages")) (:file "cms-links" :depends-on ("packages")) + (:file "simple-sat-map" :depends-on ("packages")) (:file "map-handlers" :depends-on ("packages" "web-macros")) (:file "map-browser-handler" :depends-on ("packages" "web-macros")) (:file "poi-handlers" :depends-on ("dictionary" "packages" "web-macros")) Modified: trunk/projects/bos/web/packages.lisp =================================================================== --- trunk/projects/bos/web/packages.lisp 2008-12-02 22:00:36 UTC (rev 4106) +++ trunk/projects/bos/web/packages.lisp 2008-12-02 22:16:07 UTC (rev 4107) @@ -25,3 +25,13 @@ (:shadowing-import-from :cl-interpol #:quote-meta-chars) (:shadowing-import-from :alexandria #:array-index) (:export)) + +(defpackage :simple-sat-map + (:use :cl + :bknr.indices + :bknr.datastore + :alexandria) + (:shadowing-import-from :alexandria #:array-index) + (:nicknames :ssm) + (:export #:simple-map-handler + #:import)) \ No newline at end of file Copied: trunk/projects/bos/web/simple-sat-map.lisp (from rev 4106, trunk/projects/bos/m2/simple-sat-map.lisp) =================================================================== --- trunk/projects/bos/web/simple-sat-map.lisp (rev 0) +++ trunk/projects/bos/web/simple-sat-map.lisp 2008-12-02 22:16:07 UTC (rev 4107) @@ -0,0 +1,72 @@ +(in-package :ssm) + +;; Simple Sat Map + +;; This satellite map interface works with square tiles of 256 pixels. +;; The original image is extended so that the number of pixels is a +;; power of two. The same dimensions are assumed in x and y +;; directions. It is then stored in a quad tree, with each node +;; having one image and four children. + +(define-persistent-class tree () + ((name :read) + (root :read))) + +(defun tree-with-name (name) + (find name (class-instances 'tree) + :key #'tree-name + :test #'string-equal)) + +(define-persistent-class node () + ((image :read) + (children :read :initform nil))) + +(defun import-image (image-filename &key (tile-size 256)) + (assert (= (log tile-size 2) (round (log tile-size 2))) + () "TILE-SIZE needs to be power of two") + (cl-gd:with-image-from-file (map-image image-filename) + (format t "~&; read image ~A, width ~A height ~A~%" + image-filename (cl-gd:image-width map-image) (cl-gd:image-height map-image)) + (let* ((basename (pathname-name image-filename)) + (pow (ceiling (log (max (cl-gd:image-height map-image) + (cl-gd:image-width map-image)) 2))) + (size (expt 2 pow)) + (levels (floor (- pow (log tile-size 2))))) + (format t "~&; pow ~A size ~A levels ~A~%" pow size levels) + (labels + ((write-quad (x y level) + (format t "; ~A ~A ~A~%" x y level) + (cl-gd:with-image (tile tile-size tile-size t) + (let ((tile-source-size (/ size (expt 2 level)))) + (cl-gd:copy-image map-image tile + x y + 0 0 + tile-source-size tile-source-size + :dest-width tile-size :dest-height tile-size + :resample t :resize t) + (apply #'make-instance 'node + :image (bknr.images:make-store-image :image tile + :name (format nil "~A-~A-~A-~A" + basename level x y)) + (when (< level levels) + (let ((next-tile-source-size (/ tile-source-size 2)) + (next-level (1+ level))) + (list :children + (list (write-quad x y next-level) + (write-quad (+ x next-tile-source-size) y next-level) + (write-quad x (+ y next-tile-source-size) next-level) + (write-quad (+ x next-tile-source-size) (+ y next-tile-source-size) next-level)))))))))) + (make-instance 'tree + :name basename + :root (write-quad 0 0 0)))))) + +(defclass simple-map-handler (bknr.images::imageproc-handler) + ()) + +(defmethod bknr.web:object-handler-get-object ((handler simple-map-handler)) + (let ((node (tree-root (tree-with-name (bknr.web:parse-url)))) + (path (or (bknr.web:query-param "path") ""))) + (dotimes (i (length path)) + (setf node (nth (parse-integer path :start i :end (1+ i)) + (node-children node)))) + (node-image node))) Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-12-02 22:00:36 UTC (rev 4106) +++ trunk/projects/bos/web/webserver.lisp 2008-12-02 22:16:07 UTC (rev 4107) @@ -183,7 +183,7 @@ ("/poi-kml-look-at" poi-kml-look-at-handler) ("/poi-kml" poi-kml-handler) ("/map-browser" map-browser-handler) - ("/simple-map" ssm::simple-map-handler) + ("/simple-map" ssm:simple-map-handler) ("/poi-javascript" poi-javascript-handler) ("/m2-javascript" m2-javascript-handler) ("/poi-json" poi-json-handler) From bknr at bknr.net Wed Dec 3 21:16:33 2008 From: bknr at bknr.net (BKNR Commits) Date: Wed, 03 Dec 2008 22:16:33 +0100 Subject: [bknr-cvs] hans changed trunk/projects/quickhoney/src/handlers.lisp Message-ID: Revision: 4108 Author: hans URL: http://bknr.net/trac/changeset/4108 adapt to current yason api U trunk/projects/quickhoney/src/handlers.lisp Modified: trunk/projects/quickhoney/src/handlers.lisp =================================================================== --- trunk/projects/quickhoney/src/handlers.lisp 2008-12-02 22:16:07 UTC (rev 4107) +++ trunk/projects/quickhoney/src/handlers.lisp 2008-12-03 21:16:32 UTC (rev 4108) @@ -45,7 +45,7 @@ () (:default-initargs :query-function #'store-image-with-name)) -(defmethod json:encode ((object symbol) stream) +(defmethod json:encode ((object symbol) &optional stream) (json:encode (string-downcase (symbol-name object)) stream)) @@ -598,4 +598,4 @@ (defmethod handle ((handler shutdown-handler)) (hunchentoot:stop-server hunchentoot:*server*) - "Shutting down HTTP server") \ No newline at end of file + "Shutting down HTTP server") From bknr at bknr.net Wed Dec 3 21:17:12 2008 From: bknr at bknr.net (BKNR Commits) Date: Wed, 03 Dec 2008 22:17:12 +0100 Subject: [bknr-cvs] hans changed trunk/bknr/datastore/src/ Message-ID: Revision: 4109 Author: hans URL: http://bknr.net/trac/changeset/4109 add print-store-object macro, fix dependencies U trunk/bknr/datastore/src/bknr.datastore.asd U trunk/bknr/datastore/src/data/object.lisp U trunk/bknr/datastore/src/data/package.lisp Modified: trunk/bknr/datastore/src/bknr.datastore.asd =================================================================== --- trunk/bknr/datastore/src/bknr.datastore.asd 2008-12-03 21:16:32 UTC (rev 4108) +++ trunk/bknr/datastore/src/bknr.datastore.asd 2008-12-03 21:17:12 UTC (rev 4109) @@ -22,6 +22,7 @@ :unit-test :bknr.utils :bknr.indices + :yason :trivial-utf-8) :components ((:module "data" :components ((:file "package") Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-12-03 21:16:32 UTC (rev 4108) +++ trunk/bknr/datastore/src/data/object.lisp 2008-12-03 21:17:12 UTC (rev 4109) @@ -282,6 +282,12 @@ ;; running the transaction log. (initialize-transient-instance object)) +(defmacro print-store-object ((object stream &key type) &body body) + ;; variable capture accepted here. + `(print-unreadable-object (,object ,stream :type ,type) + (format stream "ID: ~D " (store-object-id ,object)) + , at body)) + (defmethod print-object ((object store-object) stream) (print-unreadable-object (object stream :type t) (format stream "ID: ~D" (store-object-id object)))) Modified: trunk/bknr/datastore/src/data/package.lisp =================================================================== --- trunk/bknr/datastore/src/data/package.lisp 2008-12-03 21:16:32 UTC (rev 4108) +++ trunk/bknr/datastore/src/data/package.lisp 2008-12-03 21:17:12 UTC (rev 4109) @@ -56,6 +56,7 @@ #:store-object-id #:store-object-last-change #:store-object-touch + #:print-store-object #:delete-object #:delete-objects From bknr at bknr.net Wed Dec 3 21:19:43 2008 From: bknr at bknr.net (BKNR Commits) Date: Wed, 03 Dec 2008 22:19:43 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/ Message-ID: Revision: 4110 Author: hans URL: http://bknr.net/trac/changeset/4110 more google maps goodness U trunk/projects/bos/payment-website/static/poi-ms.css U trunk/projects/bos/payment-website/static/poi-ms.html U trunk/projects/bos/payment-website/static/poi-ms.js U trunk/projects/bos/web/simple-sat-map.lisp Modified: trunk/projects/bos/payment-website/static/poi-ms.css =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.css 2008-12-03 21:17:12 UTC (rev 4109) +++ trunk/projects/bos/payment-website/static/poi-ms.css 2008-12-03 21:19:43 UTC (rev 4110) @@ -35,7 +35,15 @@ position: absolute; } -#google-map { +#map { +} + +#map.large { + width: 600px; + height: 600px; +} + +#map.small { width: 400px; - height: 300px; -} \ No newline at end of file + height: 150px; +} Modified: trunk/projects/bos/payment-website/static/poi-ms.html =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-03 21:17:12 UTC (rev 4109) +++ trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-03 21:19:43 UTC (rev 4110) @@ -18,6 +18,10 @@
+
+
+
+
@@ -29,7 +33,6 @@
Modified: trunk/projects/bos/payment-website/static/poi-ms.js =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-03 21:17:12 UTC (rev 4109) +++ trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-03 21:19:43 UTC (rev 4110) @@ -5,6 +5,7 @@ var googleMapKey = "ABQIAAAA5meUSZ1F7u46UjJHEXSlJhQkkdysj0TmG3bX_n9aMEXHvIwNeRQLmdjbjYpAetJRis7naMxi-fqMRQ"; var pois = {}; var sponsors = []; +var mainMap; Date.prototype.renderDate = function() { return this.getDate() + '.' + this.getMonth() + '.' + (this.getYear() > 2000 ? this.getYear() : (1900 + this.getYear())); @@ -86,7 +87,7 @@ $('#media-list *').removeClass('active'); $(e.target).addClass('active'); - $('#content') + $('#content-body') .empty() .append(H2(null, medium.title), mediaHandlers[medium.mediumType].makeViewer(medium), @@ -118,49 +119,16 @@ return path; } -function makeMap(centerX, centerY) { - var rows = []; - - for (var y = -1; y < 3; y++) { - var tiles = []; - for (var x = -1; x < 3; x++) { - tiles.push(IMG({ 'class': 'map-tile', - src: '/overview/' - + (Math.floor(centerX / 90) + x) * 90 - + '/' - + (Math.floor(centerY / 90) + y) * 90, - width: 90, height: 90 })); - } - rows.push(DIV(null, tiles)); - } - - return DIV(null, rows); -} - -function positionMapIcon(img, x, y) { - img.style.left = (x - (Math.floor(x / 90) - 1) * 90) + 'px'; - img.style.top = (y - (Math.floor(y / 90) - 1) * 90) + 'px'; - return img; -} - function loadMainInfo(poi) { - $('#content') + $('#content-body') .empty() .append(H2(null, poi.subtitle), - DIV({ 'class': 'map' }, - makeMap(poi.x, poi.y), - positionMapIcon(IMG({ 'class': 'icon', - src: '/images/' + poi.icon + '.gif', - width: 16, height: 16}), - poi.x - 8, poi.y - 8)), P(null, poi.description)); } -function showPOI(e) { - var poi = pois[(e.target && e.target.value) || e.data]; +function showPOI(poi) { - $('#left-bar') .empty() .append(UL({ id: 'media-list' })); @@ -181,6 +149,8 @@ .bind('click', medium, showMedium)); } }, poi.media); + + mainMap.zoomTo(poi.x, poi.y); } function pointToPath(point, level) { @@ -195,19 +165,20 @@ return path; } -function showGoogleMap() { - var mapDiv = DIV({ id: 'google-map' }); - $('#content') - +function showOverview() { + $('#content-body') .empty() - .append(H2(null, NLS('Google Map')), - mapDiv); + .append(H2(null, NLS('Google Map'))); $('#left-bar') .empty(); - var map = new GMap2(mapDiv); + mainMap.overview(); +} +function Map() { + this.map = new GMap2($('#map')[0]); + var copyright = new GCopyright(1, new GLatLngBounds(new GLatLng(-90, -180), new GLatLng(90, 180)), @@ -215,10 +186,10 @@ "Copyright BOS Deutschland e.V."); var copyrightCollection = new GCopyrightCollection('Map'); copyrightCollection.addCopyright(copyright); - var tileLayers = [new GTileLayer(copyrightCollection, 0, 7)]; - var projection = new GMercatorProjection(7); + var tileLayers = [new GTileLayer(copyrightCollection, 0, 12)]; + var projection = new GMercatorProjection(12); tileLayers[0].getTileUrl = function(point, level) { - if (level < 7) { + if (level < 15) { var path = pointToPath(point, level); log('getTileUrl: x:' + point.x + ' y:' + point.y + ' level:' + level + ' path: ' + path); return '/simple-map/sl_utm50s-0?path=' + path; @@ -227,22 +198,63 @@ } } var customMap = new GMapType(tileLayers, projection, 'Map', { errorMessage: NLS("Keine Daten in dieser Zoomstufe") }); - map.addMapType(customMap); - map.addControl(new GLargeMapControl()); - map.setCenter(new GLatLng(0, 0), 1, customMap); + this.map.addMapType(customMap); + + this.controls = [ new GLargeMapControl() ]; + + this.addControls = function() { + for (var i in this.controls) { + this.map.addControl(this.controls[i]); + } + } + this.removeControls = function() { + for (var i in this.controls) { + this.map.removeControl(this.controls[i]); + } + } + + this.map.enableContinuousZoom(); + this.map.enableScrollWheelZoom(); + + this.overview = function() { + $('#map').removeClass('small'); + $('#map').addClass('large'); + this.addControls(); + this.map.setCenter(projection.fromPixelToLatLng(new GPoint(7000, 6350), 6), 2, customMap); + this.map.checkResize(); + } + + this.zoomTo = function (x, y) { + $('#map').removeClass('large'); + $('#map').addClass('small'); + this.removeControls(); + this.map.setCenter(projection.fromPixelToLatLng(new GPoint(x, y), 6), 6); + this.map.checkResize(); + } + + this.overview(); + + function pointToLatLng(x, y) { + return projection.fromPixelToLatLng(new GPoint(x, y), 6); + } + + for (var i in pois) { + var marker = new GMarker(pointToLatLng(pois[i].x, pois[i].y)); + GEvent.addListener(marker, "click", partial(showPOI, pois[i])); + this.map.addOverlay(marker); + } } var pages = { overview: showOverview, - map: showGoogleMap } function selectPage(e) { var value = e.target.value; if (value.match(/^\d+/)) { - showPOI(e); + showPOI(pois[value]); } else if (pages[value]) { pages[value](e); } @@ -251,46 +263,11 @@ function showSponsor(e) { var sponsor = e.data; var contract = sponsor.contracts[0]; - $('#content') + $('#content-body') .empty() - .append(H2(null, sponsor.name), - DIV({ 'class': 'map' }, - makeMap(contract.left, contract.top), - positionMapIcon(IMG({ 'class': 'contract', - src: '/contract-image/' + contract.id, - width: contract.width, height: contract.height}), - contract.left, contract.top)) - ); + .append(H2(null, sponsor.name)); } -function showOverview() { - - $('#poi-selector').val('overview'); - - var elements = []; - elements.push(IMG({ src: '/infosystem/bilder/karte_uebersicht.jpg', width: 360, height: 360 })); - for (var i in pois) { - var poi = pois[i]; - var link = A({ href: '#' }, - IMG({ 'class': 'icon', - src: '/images/' + poi.icon + '.gif', - width: 16, height: 16, - title: poi.title, - style: 'left: ' + (Math.round(poi.x / 30) - 8) + 'px; ' - + 'top: ' + (Math.round(poi.y / 30) - 8) + 'px' })); - $(link).bind('click', poi.id, showPOI); - elements.push(link); - } - - $('#content') - .empty() - .append(H2(null, NLS('??bersicht')), - DIV({ 'class': 'map' }, elements)); - - $('#left-bar') - .empty(); -} - function showSponsors() { $('#left-bar') @@ -320,7 +297,7 @@ var poi_id = document.location.hash.replace(/#/, ""); if (poi_id) { - showPOI({ data: poi_id }); + showPOI(pois[poi_id]); } else { showOverview(); } @@ -339,6 +316,8 @@ } $('#poi-selector').bind('change', null, selectPage); + mainMap = new Map(); + loadJSONDoc('/sponsors-json').addCallback(loadSponsors); } catch (e) { @@ -347,7 +326,7 @@ } function init() { - $('#small-map a').bind('click', showPOI); + $('#small-map a').bind('click', showOverview); loadJSONDoc('/poi-json').addCallback(loadPOIs); } \ No newline at end of file Modified: trunk/projects/bos/web/simple-sat-map.lisp =================================================================== --- trunk/projects/bos/web/simple-sat-map.lisp 2008-12-03 21:17:12 UTC (rev 4109) +++ trunk/projects/bos/web/simple-sat-map.lisp 2008-12-03 21:19:43 UTC (rev 4110) @@ -10,6 +10,7 @@ (define-persistent-class tree () ((name :read) + (size :read) (root :read))) (defun tree-with-name (name) @@ -17,6 +18,13 @@ :key #'tree-name :test #'string-equal)) +(defun tree-depth (tree) + (values (- (ceiling (log (tree-size tree) 2)) 8))) + +(defmethod print-object ((tree tree) stream) + (print-store-object (tree stream :type t) + (format stream "name ~S size ~D" (tree-name tree) (tree-size tree)))) + (define-persistent-class node () ((image :read) (children :read :initform nil))) @@ -64,9 +72,41 @@ ()) (defmethod bknr.web:object-handler-get-object ((handler simple-map-handler)) - (let ((node (tree-root (tree-with-name (bknr.web:parse-url)))) - (path (or (bknr.web:query-param "path") ""))) - (dotimes (i (length path)) + (let* ((tree (tree-with-name (bknr.web:parse-url))) + (node (tree-root tree)) + (path (or (bknr.web:query-param "path") ""))) + (dotimes (i (min (length path) + (tree-depth tree))) (setf node (nth (parse-integer path :start i :end (1+ i)) (node-children node)))) - (node-image node))) + (when (> (length path) (tree-depth tree)) + (setf (hunchentoot:aux-request-value 'zoom-path) + (subseq path (tree-depth tree)))) + (node-image node))) + +(defun zoom-image (store-image zoom-path) + (let ((source-size (expt 2 (- 8 (length zoom-path)))) + (x 0) + (y 0) + (bit 128)) + (dotimes (i (length zoom-path)) + (let ((path-bits (- (char-code (aref zoom-path i)) #.(char-code #\0)))) + (when (plusp (logand 1 path-bits)) + (incf x bit)) + (when (plusp (logand 2 path-bits)) + (incf y bit)) + (setf bit (/ bit 2)))) + (bknr.images:with-store-image (source-image store-image) + (cl-gd:with-image (zoomed-image 256 256 t) + (cl-gd:copy-image source-image zoomed-image + x y + 0 0 + source-size source-size + :resize t + :dest-width 256 :dest-height 256) + (bknr.images:emit-image-to-browser zoomed-image :png))))) + +(defmethod bknr.web:handle-object ((handler simple-map-handler) image) + (if-let (zoom-path (hunchentoot:aux-request-value 'zoom-path)) + (zoom-image image zoom-path) + (call-next-method))) \ No newline at end of file From bknr at bknr.net Wed Dec 3 22:48:32 2008 From: bknr at bknr.net (BKNR Commits) Date: Wed, 03 Dec 2008 23:48:32 +0100 Subject: [bknr-cvs] hans changed trunk/libraries/ccl-profiler/ Message-ID: Revision: 4111 Author: hans URL: http://bknr.net/trac/changeset/4111 This lives in the CCL svn D trunk/libraries/ccl-profiler/ From bknr at bknr.net Thu Dec 4 15:02:58 2008 From: bknr at bknr.net (BKNR Commits) Date: Thu, 04 Dec 2008 16:02:58 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/ Message-ID: Revision: 4112 Author: hans URL: http://bknr.net/trac/changeset/4112 Support multiple layers in simple map tree. Hide map when displaying POI U trunk/projects/bos/payment-website/static/poi-ms.js U trunk/projects/bos/web/simple-sat-map.lisp Modified: trunk/projects/bos/payment-website/static/poi-ms.js =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-03 22:48:32 UTC (rev 4111) +++ trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-04 15:02:57 UTC (rev 4112) @@ -150,7 +150,8 @@ } }, poi.media); - mainMap.zoomTo(poi.x, poi.y); + mainMap.hide(); +// mainMap.zoomTo(poi.x, poi.y); } function pointToPath(point, level) { @@ -192,7 +193,7 @@ if (level < 15) { var path = pointToPath(point, level); log('getTileUrl: x:' + point.x + ' y:' + point.y + ' level:' + level + ' path: ' + path); - return '/simple-map/sl_utm50s-0?path=' + path; + return '/simple-map/sat-2002?path=' + path; } else { return null; } @@ -217,7 +218,8 @@ this.map.enableContinuousZoom(); this.map.enableScrollWheelZoom(); - this.overview = function() { + this.overview = function () { + this.show(); $('#map').removeClass('small'); $('#map').addClass('large'); this.addControls(); @@ -233,6 +235,14 @@ this.map.checkResize(); } + this.hide = function () { + $('#map').css('display', 'none'); + } + + this.show = function () { + $('#map').css('display', 'block'); + } + this.overview(); function pointToLatLng(x, y) { Modified: trunk/projects/bos/web/simple-sat-map.lisp =================================================================== --- trunk/projects/bos/web/simple-sat-map.lisp 2008-12-03 22:48:32 UTC (rev 4111) +++ trunk/projects/bos/web/simple-sat-map.lisp 2008-12-04 15:02:57 UTC (rev 4112) @@ -9,83 +9,114 @@ ;; having one image and four children. (define-persistent-class tree () - ((name :read) - (size :read) - (root :read))) + ((root :read))) -(defun tree-with-name (name) - (find name (class-instances 'tree) - :key #'tree-name - :test #'string-equal)) +(defmethod destroy-object :before ((tree tree)) + (labels + ((descend (node) + (when (node-children node) + (dolist (child (node-children node)) + (descend child))) + (delete-object node))) + (descend (tree-root tree)))) -(defun tree-depth (tree) - (values (- (ceiling (log (tree-size tree) 2)) 8))) +(defparameter *levels* 6) +(defparameter *tree-size* 16384) +(defparameter *tile-size* 256) -(defmethod print-object ((tree tree) stream) - (print-store-object (tree stream :type t) - (format stream "name ~S size ~D" (tree-name tree) (tree-size tree)))) +(defun make-tree () + (labels + ((make-quad (level) + (apply #'make-instance 'node + (when (< level *levels*) + (let ((next-level (1+ level))) + (list :children + (list (make-quad next-level) + (make-quad next-level) + (make-quad next-level) + (make-quad next-level)))))))) + (make-instance 'tree + :root (make-quad 0)))) +(defun get-tree () + (or (first (class-instances 'tree)) + (make-tree))) + (define-persistent-class node () - ((image :read) + ((images :read :initform (make-hash-table :test #'equal)) (children :read :initform nil))) -(defun import-image (image-filename &key (tile-size 256)) - (assert (= (log tile-size 2) (round (log tile-size 2))) - () "TILE-SIZE needs to be power of two") +(defmethod destroy-object :before ((node node)) + (loop + for image being the hash-values of (node-images node) + do (unless (object-destroyed-p image) + (delete-object image)))) + +(defun node-image (node layer-name) + (gethash layer-name (node-images node))) + +(defun (setf node-image) (new-image node layer-name) + (setf (gethash layer-name (node-images node)) new-image)) + +(defun import-image (image-filename layer-name) (cl-gd:with-image-from-file (map-image image-filename) (format t "~&; read image ~A, width ~A height ~A~%" image-filename (cl-gd:image-width map-image) (cl-gd:image-height map-image)) - (let* ((basename (pathname-name image-filename)) - (pow (ceiling (log (max (cl-gd:image-height map-image) - (cl-gd:image-width map-image)) 2))) - (size (expt 2 pow)) - (levels (floor (- pow (log tile-size 2))))) - (format t "~&; pow ~A size ~A levels ~A~%" pow size levels) + (let* ((basename (pathname-name image-filename))) (labels - ((write-quad (x y level) + ((make-image (node x y level) (format t "; ~A ~A ~A~%" x y level) - (cl-gd:with-image (tile tile-size tile-size t) - (let ((tile-source-size (/ size (expt 2 level)))) + (cl-gd:with-image (tile *tile-size* *tile-size* t) + (let ((tile-source-size (/ *tree-size* (expt 2 level))) + (image-name (format nil "~A-~A-~A-~A" basename level x y))) (cl-gd:copy-image map-image tile x y 0 0 tile-source-size tile-source-size - :dest-width tile-size :dest-height tile-size + :dest-width *tile-size* :dest-height *tile-size* :resample t :resize t) - (apply #'make-instance 'node - :image (bknr.images:make-store-image :image tile - :name (format nil "~A-~A-~A-~A" - basename level x y)) - (when (< level levels) - (let ((next-tile-source-size (/ tile-source-size 2)) - (next-level (1+ level))) - (list :children - (list (write-quad x y next-level) - (write-quad (+ x next-tile-source-size) y next-level) - (write-quad x (+ y next-tile-source-size) next-level) - (write-quad (+ x next-tile-source-size) (+ y next-tile-source-size) next-level)))))))))) - (make-instance 'tree - :name basename - :root (write-quad 0 0 0)))))) + (when-let (old-image (bknr.images:store-image-with-name image-name)) + (delete-object old-image)) + (setf (node-image node layer-name) + (bknr.images:make-store-image :image tile + :name image-name)) + (when (< level *levels*) + (let ((next-tile-source-size (/ tile-source-size 2)) + (next-level (1+ level))) + (destructuring-bind (one two three four) (node-children node) + (make-image one x y next-level) + (make-image two (+ x next-tile-source-size) y next-level) + (make-image three x (+ y next-tile-source-size) next-level) + (make-image four (+ x next-tile-source-size) (+ y next-tile-source-size) next-level)))))))) + (make-image (tree-root (get-tree)) 0 0 0))))) +(defun transparent-image () + (or (bknr.images:store-image-with-name "transparent") + (cl-gd:with-image* (*tile-size* *tile-size* nil) + (setf (cl-gd:transparent-color) + (cl-gd:allocate-color 0 0 0 :alpha 127)) + (bknr.images:make-store-image :name "transparent" :type :gif)))) + (defclass simple-map-handler (bknr.images::imageproc-handler) ()) (defmethod bknr.web:object-handler-get-object ((handler simple-map-handler)) - (let* ((tree (tree-with-name (bknr.web:parse-url))) + (let* ((layer (bknr.web:parse-url)) + (tree (get-tree)) (node (tree-root tree)) (path (or (bknr.web:query-param "path") ""))) - (dotimes (i (min (length path) - (tree-depth tree))) - (setf node (nth (parse-integer path :start i :end (1+ i)) - (node-children node)))) - (when (> (length path) (tree-depth tree)) - (setf (hunchentoot:aux-request-value 'zoom-path) - (subseq path (tree-depth tree)))) - (node-image node))) + (dotimes (i (min (length path) + *levels*)) + (setf node (nth (parse-integer path :start i :end (1+ i)) + (node-children node)))) + (when (> (length path) *levels*) + (setf (hunchentoot:aux-request-value 'zoom-path) + (subseq path *levels*))) + (or (node-image node layer) + (transparent-image)))) (defun zoom-image (store-image zoom-path) - (let ((source-size (expt 2 (- 8 (length zoom-path)))) + (let ((source-size (floor (expt 2 (- (log *tile-size* 2) (length zoom-path))))) (x 0) (y 0) (bit 128)) @@ -97,16 +128,17 @@ (incf y bit)) (setf bit (/ bit 2)))) (bknr.images:with-store-image (source-image store-image) - (cl-gd:with-image (zoomed-image 256 256 t) + (cl-gd:with-image (zoomed-image *tile-size* *tile-size* t) (cl-gd:copy-image source-image zoomed-image x y 0 0 source-size source-size :resize t - :dest-width 256 :dest-height 256) + :dest-width *tile-size* :dest-height *tile-size*) (bknr.images:emit-image-to-browser zoomed-image :png))))) -(defmethod bknr.web:handle-object ((handler simple-map-handler) image) +(defmethod bknr.web:handle-object ((handler simple-map-handler) (image bknr.images:store-image)) (if-let (zoom-path (hunchentoot:aux-request-value 'zoom-path)) (zoom-image image zoom-path) - (call-next-method))) \ No newline at end of file + (call-next-method))) + From bknr at bknr.net Fri Dec 5 09:49:45 2008 From: bknr at bknr.net (BKNR Commits) Date: Fri, 05 Dec 2008 10:49:45 +0100 Subject: [bknr-cvs] hans changed trunk/bknr/web/src/images/image.lisp Message-ID: Revision: 4113 Author: hans URL: http://bknr.net/trac/changeset/4113 Add new :IF-EXISTS keyword argument to MAKE-STORE-IMAGE that can be set to control whether an existing image of the same name should be overwritten. U trunk/bknr/web/src/images/image.lisp Modified: trunk/bknr/web/src/images/image.lisp =================================================================== --- trunk/bknr/web/src/images/image.lisp 2008-12-04 15:02:57 UTC (rev 4112) +++ trunk/bknr/web/src/images/image.lisp 2008-12-05 09:49:44 UTC (rev 4113) @@ -65,12 +65,20 @@ name (type :png) directory keywords + (if-exists :error) (class-name 'store-image) initargs) (unless (scan #?r"\D" name) (error "invalid image name ~A, needs to contain at least one non-digit character" name)) - (when (store-image-with-name name) - (error "can't make image with name ~A, an image with this name already exists in the datastore" name)) + (when-let (existing-image (store-image-with-name name)) + (ecase if-exists + (:error + (error "can't make image with name ~A, an image with this name already exists in the datastore" name)) + (:supersede + (delete-object existing-image)) + (:kill + (delete-file (blob-pathname existing-image)) + (delete-object existing-image)))) (let ((store-image (apply #'make-instance class-name :name name From bknr at bknr.net Fri Dec 5 11:27:44 2008 From: bknr at bknr.net (BKNR Commits) Date: Fri, 05 Dec 2008 12:27:44 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/ Message-ID: Revision: 4114 Author: hans URL: http://bknr.net/trac/changeset/4114 Contract rendering works now. U trunk/projects/bos/payment-website/static/poi-ms.js U trunk/projects/bos/web/simple-sat-map.lisp Modified: trunk/projects/bos/payment-website/static/poi-ms.js =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-05 09:49:44 UTC (rev 4113) +++ trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-05 11:27:44 UTC (rev 4114) @@ -193,7 +193,7 @@ if (level < 15) { var path = pointToPath(point, level); log('getTileUrl: x:' + point.x + ' y:' + point.y + ' level:' + level + ' path: ' + path); - return '/simple-map/sat-2002?path=' + path; + return '/simple-map/contracts?path=' + path; } else { return null; } @@ -223,7 +223,7 @@ $('#map').removeClass('small'); $('#map').addClass('large'); this.addControls(); - this.map.setCenter(projection.fromPixelToLatLng(new GPoint(7000, 6350), 6), 2, customMap); + this.map.setCenter(projection.fromPixelToLatLng(new GPoint(7000, 6350), 6), 3, customMap); this.map.checkResize(); } Modified: trunk/projects/bos/web/simple-sat-map.lisp =================================================================== --- trunk/projects/bos/web/simple-sat-map.lisp 2008-12-05 09:49:44 UTC (rev 4113) +++ trunk/projects/bos/web/simple-sat-map.lisp 2008-12-05 11:27:44 UTC (rev 4114) @@ -8,9 +8,19 @@ ;; directions. It is then stored in a quad tree, with each node ;; having one image and four children. +(defparameter *levels* 6) +(defparameter *tree-size* 16384) +(defparameter *tile-size* 256) +(defparameter *tile-pow* (floor (log *tile-size* 2))) + (define-persistent-class tree () - ((root :read))) + ((root :read) + (layers :read :initform nil))) +(defmethod print-object ((tree tree) stream) + (print-store-object (tree stream :type t) + (format stream "LAYERS: ~S" (tree-layers tree)))) + (defmethod destroy-object :before ((tree tree)) (labels ((descend (node) @@ -20,43 +30,91 @@ (delete-object node))) (descend (tree-root tree)))) -(defparameter *levels* 6) -(defparameter *tree-size* 16384) -(defparameter *tile-size* 256) - (defun make-tree () (labels - ((make-quad (level) + ((make-quad (x y level) (apply #'make-instance 'node + :x x :y y :level level (when (< level *levels*) - (let ((next-level (1+ level))) + (let* ((next-level (1+ level)) + (next-tile-size (/ *tree-size* (expt 2 next-level)))) (list :children - (list (make-quad next-level) - (make-quad next-level) - (make-quad next-level) - (make-quad next-level)))))))) + (list (make-quad x y next-level) + (make-quad (+ x next-tile-size) y next-level) + (make-quad x (+ y next-tile-size) next-level) + (make-quad (+ x next-tile-size) (+ y next-tile-size) next-level)))))))) (make-instance 'tree - :root (make-quad 0)))) + :root (make-quad 0 0 0)))) (defun get-tree () (or (first (class-instances 'tree)) (make-tree))) (define-persistent-class node () - ((images :read :initform (make-hash-table :test #'equal)) + ((x :read) + (y :read) + (level :read) + (images :read :initform (make-hash-table)) (children :read :initform nil))) +(defun node-pixel-size (node) + (/ *tree-size* (expt 2 (node-level node)) 256)) + +(defun node-size (node) + (/ *tree-size* (expt 2 (node-level node)))) + +(defmethod print-object ((node node) stream) + (print-store-object (node stream :type t) + (format stream "X: ~A Y: ~A LEVEL: ~A IMAGES: ~A CHILDREN: ~:[NO~;YES~]" + (node-x node) (node-y node) (node-level node) + (loop for layer being the hash-keys of (node-images node) + collect layer) + (node-children node)))) + (defmethod destroy-object :before ((node node)) (loop for image being the hash-values of (node-images node) do (unless (object-destroyed-p image) (delete-object image)))) -(defun node-image (node layer-name) - (gethash layer-name (node-images node))) +(defun find-m2 (x y) + (when (and (< x bos.m2.config:+width+) + (< y bos.m2.config:+width+)) + (bos.m2:get-m2 x y))) +(defun generate-contract-image (node) + (cl-gd:with-image* (256 256 t) + (setf (cl-gd:save-alpha-p) t) + (let ((transparent (cl-gd:find-color 255 255 255 :alpha 127)) + (factor (expt 2 (- *levels* (node-level node))))) + (cl-gd:do-rows (y) + (cl-gd:do-pixels-in-row (x) + (let ((m2 (find-m2 (+ (node-x node) + (* x factor)) + (+ (node-y node) + (* y factor))))) + (setf (cl-gd:raw-pixel) + (if (and m2 (bos.m2:m2-contract m2)) + (apply #'cl-gd:find-color (bos.m2:contract-color (bos.m2:m2-contract m2))) + transparent)))))) + (with-transaction (:generate-contract-image) + (setf (node-image node :contracts) + (bknr.images:make-store-image :name (format nil "contracts-~A-~A-~A" + (node-level node) + (node-x node) + (node-y node)) + :if-exists :kill))))) + +(defgeneric node-image (node layer-name) + (:method (node layer-name) + (gethash (find-keyword layer-name) (node-images node))) + (:method (node (layer-name (eql :contracts))) + (or (call-next-method) + (generate-contract-image node)))) + (defun (setf node-image) (new-image node layer-name) - (setf (gethash layer-name (node-images node)) new-image)) + (pushnew layer-name (slot-value (get-tree) 'layers)) + (setf (gethash (find-keyword layer-name) (node-images node)) new-image)) (defun import-image (image-filename layer-name) (cl-gd:with-image-from-file (map-image image-filename) @@ -75,11 +133,11 @@ tile-source-size tile-source-size :dest-width *tile-size* :dest-height *tile-size* :resample t :resize t) - (when-let (old-image (bknr.images:store-image-with-name image-name)) - (delete-object old-image)) - (setf (node-image node layer-name) - (bknr.images:make-store-image :image tile - :name image-name)) + (with-transaction (:make-tile) + (setf (node-image node layer-name) + (bknr.images:make-store-image :image tile + :name image-name + :if-exists :kill))) (when (< level *levels*) (let ((next-tile-source-size (/ tile-source-size 2)) (next-level (1+ level))) @@ -100,8 +158,11 @@ (defclass simple-map-handler (bknr.images::imageproc-handler) ()) +(defun find-keyword (name) + (find-symbol (string-upcase (string name)) :keyword)) + (defmethod bknr.web:object-handler-get-object ((handler simple-map-handler)) - (let* ((layer (bknr.web:parse-url)) + (let* ((layer (find-keyword (bknr.web:parse-url))) (tree (get-tree)) (node (tree-root tree)) (path (or (bknr.web:query-param "path") ""))) @@ -113,7 +174,8 @@ (setf (hunchentoot:aux-request-value 'zoom-path) (subseq path *levels*))) (or (node-image node layer) - (transparent-image)))) + (when (find layer (tree-layers tree)) + (transparent-image))))) (defun zoom-image (store-image zoom-path) (let ((source-size (floor (expt 2 (- (log *tile-size* 2) (length zoom-path))))) @@ -128,17 +190,47 @@ (incf y bit)) (setf bit (/ bit 2)))) (bknr.images:with-store-image (source-image store-image) - (cl-gd:with-image (zoomed-image *tile-size* *tile-size* t) - (cl-gd:copy-image source-image zoomed-image + (cl-gd:with-image* (*tile-size* *tile-size* t) + (setf (cl-gd:save-alpha-p) t) + (cl-gd:fill-image 0 0 :color (cl-gd:find-color 255 255 255 :alpha 127)) + (cl-gd:copy-image source-image cl-gd:*default-image* x y 0 0 source-size source-size :resize t :dest-width *tile-size* :dest-height *tile-size*) - (bknr.images:emit-image-to-browser zoomed-image :png))))) + (bknr.images:emit-image-to-browser cl-gd:*default-image* :png))))) (defmethod bknr.web:handle-object ((handler simple-map-handler) (image bknr.images:store-image)) (if-let (zoom-path (hunchentoot:aux-request-value 'zoom-path)) (zoom-image image zoom-path) (call-next-method))) +(defun contracts-changed (tree contract &key type) + (declare (ignore type tree)) + (destructuring-bind (width height) (cddr (bos.m2:contract-bounding-box contract)) + (let ((contract-size (max width height))) + (labels + ((recur (node) + (when (>= contract-size (node-pixel-size node)) + ;; contract is likely to be visible at this resolution, remove tile images so that they are regenerated + (when-let (image (gethash :contracts (node-images node))) + (format t "; contract image of ~A deleted~%" node) + (delete-file (blob-pathname image)) + (delete-object image) + (setf (node-image node :contracts) nil))) + (dolist (child (node-children node)) + (when (geometry:rectangle-intersects-p (bos.m2:contract-bounding-box contract) + (list (node-x child) (node-y child) + (node-size child) (node-size child))) + (recur child))))) + (recur (tree-root (get-tree))))))) + +(defun init-simple-sat-map () + (geometry:register-rect-subscriber geometry:*rect-publisher* + 'tree + (list 0 0 bos.m2.config:+width+ bos.m2.config:+width+) + 'contracts-changed)) + +(bos.m2:register-transient-init-function 'init-simple-sat-map + 'geometry:make-rect-publisher) \ No newline at end of file From bknr at bknr.net Fri Dec 5 12:08:08 2008 From: bknr at bknr.net (BKNR Commits) Date: Fri, 05 Dec 2008 13:08:08 +0100 Subject: [bknr-cvs] hans changed trunk/bknr/web/src/images/image.lisp Message-ID: Revision: 4115 Author: hans URL: http://bknr.net/trac/changeset/4115 Only try to delete old blob file if it exists. U trunk/bknr/web/src/images/image.lisp Modified: trunk/bknr/web/src/images/image.lisp =================================================================== --- trunk/bknr/web/src/images/image.lisp 2008-12-05 11:27:44 UTC (rev 4114) +++ trunk/bknr/web/src/images/image.lisp 2008-12-05 12:08:08 UTC (rev 4115) @@ -77,7 +77,8 @@ (:supersede (delete-object existing-image)) (:kill - (delete-file (blob-pathname existing-image)) + (when (probe-file (blob-pathname existing-image)) + (delete-file (blob-pathname existing-image))) (delete-object existing-image)))) (let ((store-image (apply #'make-instance class-name From bknr at bknr.net Fri Dec 5 13:37:32 2008 From: bknr at bknr.net (BKNR Commits) Date: Fri, 05 Dec 2008 14:37:32 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/ Message-ID: Revision: 4116 Author: hans URL: http://bknr.net/trac/changeset/4116 placemark for contract U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/payment-website/static/poi-ms.js Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-12-05 12:08:08 UTC (rev 4115) +++ trunk/projects/bos/m2/m2.lisp 2008-12-05 13:37:32 UTC (rev 4116) @@ -700,13 +700,16 @@ (defmethod json:encode-slots progn ((contract contract)) (destructuring-bind (left top width height) (contract-bounding-box contract) - (json:encode-object-elements - "timestamp" (format-date-time (contract-date contract) :mail-style t) - "count" (length (contract-m2s contract)) - "top" top - "left" left - "width" width - "height" height))) + (destructuring-bind (center-x center-y) (contract-center contract) + (json:encode-object-elements + "timestamp" (format-date-time (contract-date contract) :mail-style t) + "count" (length (contract-m2s contract)) + "top" top + "left" left + "width" width + "height" height + "centerX" center-x + "centerY" center-y)))) (defmethod json:encode-slots progn ((sponsor sponsor)) (json:encode-object-elements Modified: trunk/projects/bos/payment-website/static/poi-ms.js =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-05 12:08:08 UTC (rev 4115) +++ trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-05 13:37:32 UTC (rev 4116) @@ -151,7 +151,6 @@ }, poi.media); mainMap.hide(); -// mainMap.zoomTo(poi.x, poi.y); } function pointToPath(point, level) { @@ -180,26 +179,35 @@ function Map() { this.map = new GMap2($('#map')[0]); - var copyright - = new GCopyright(1, - new GLatLngBounds(new GLatLng(-90, -180), new GLatLng(90, 180)), - 3, - "Copyright BOS Deutschland e.V."); var copyrightCollection = new GCopyrightCollection('Map'); - copyrightCollection.addCopyright(copyright); - var tileLayers = [new GTileLayer(copyrightCollection, 0, 12)]; - var projection = new GMercatorProjection(12); - tileLayers[0].getTileUrl = function(point, level) { - if (level < 15) { - var path = pointToPath(point, level); - log('getTileUrl: x:' + point.x + ' y:' + point.y + ' level:' + level + ' path: ' + path); - return '/simple-map/contracts?path=' + path; - } else { - return null; + copyrightCollection.addCopyright(new GCopyright(1, + new GLatLngBounds(new GLatLng(-90, -180), new GLatLng(90, 180)), + 3, + "Copyright BOS Deutschland e.V.")); + + this.layers = {}; + + this.makeLayer = function (name) { + var tileLayer = new GTileLayer(copyrightCollection, 0, 12); + tileLayer.getTileUrl = function(point, level) { + if (level < 15) { + var path = pointToPath(point, level); +// log('getTileUrl: x:' + point.x + ' y:' + point.y + ' level:' + level + ' path: ' + path); + return '/simple-map/' + name + '?path=' + path; + } else { + return null; + } } + this.layers[name] = tileLayer; + return tileLayer; } - var customMap = new GMapType(tileLayers, projection, 'Map', { errorMessage: NLS("Keine Daten in dieser Zoomstufe") }); + var projection = new GMercatorProjection(12); + var customMap = new GMapType( + [ this.makeLayer('sat-2002'), + this.makeLayer('contracts') ], + projection, 'Map', { errorMessage: NLS("Keine Daten in dieser Zoomstufe") }); + this.map.addMapType(customMap); this.controls = [ new GLargeMapControl() ]; @@ -218,6 +226,17 @@ this.map.enableContinuousZoom(); this.map.enableScrollWheelZoom(); + this.mapClicked = function (overlay, latlng, overlaylatlng) { + log('map clicked, overlay: ' + overlay + ' latlng: ' + latlng + ' overlaylatlng: ' + overlaylatlng); + } + + this.moveEnd = function () { + log('map has moved'); + } + + GEvent.addListener(this.map, "click", bind(this.mapClicked, this)); + GEvent.addListener(this.map, "moveend", bind(this.moveEnd, this)); + this.overview = function () { this.show(); $('#map').removeClass('small'); @@ -227,7 +246,7 @@ this.map.checkResize(); } - this.zoomTo = function (x, y) { + this.poiDetail = function (x, y) { $('#map').removeClass('large'); $('#map').addClass('small'); this.removeControls(); @@ -235,6 +254,10 @@ this.map.checkResize(); } + this.zoomTo = function (x, y, level) { + this.map.setCenter(projection.fromPixelToLatLng(new GPoint(x, y), 6), level); + } + this.hide = function () { $('#map').css('display', 'none'); } @@ -254,10 +277,21 @@ GEvent.addListener(marker, "click", partial(showPOI, pois[i])); this.map.addOverlay(marker); } + + this.setSponsorMarker = function (sponsor) { + var position = pointToLatLng(sponsor.contracts[0].centerX, sponsor.contracts[0].centerY); + if (this.sponsorMarker) { + this.sponsorMarker.setLatLng(position); + } else { + this.sponsorMarker = new GMarker(position); + this.map.addOverlay(this.sponsorMarker); + } + } } var pages = { overview: showOverview, + sponsors: showSponsors } function selectPage(e) { @@ -276,6 +310,11 @@ $('#content-body') .empty() .append(H2(null, sponsor.name)); + + mainMap.zoomTo(contract.left, contract.top, 8); + mainMap.setSponsorMarker(sponsor); + + // Math.max(contract.width, contract.height) } function showSponsors() { @@ -296,6 +335,8 @@ " ", sponsor.contracts[0].count, " m??"))) .bind('click', sponsor, showSponsor)); }, sponsors.slice(0, 10)); + + mainMap.overview(); } function loadSponsors(data) { From bknr at bknr.net Mon Dec 8 15:15:25 2008 From: bknr at bknr.net (BKNR Commits) Date: Mon, 08 Dec 2008 16:15:25 +0100 Subject: [bknr-cvs] hans changed trunk/thirdparty/hunchentoot/misc.lisp Message-ID: Revision: 4117 Author: hans URL: http://bknr.net/trac/changeset/4117 Handle wildcarded filenames properly. Requests for files containing wildcard characters will be responded to with a 404 response code instead of an error. U trunk/thirdparty/hunchentoot/misc.lisp Modified: trunk/thirdparty/hunchentoot/misc.lisp =================================================================== --- trunk/thirdparty/hunchentoot/misc.lisp 2008-12-05 13:37:32 UTC (rev 4116) +++ trunk/thirdparty/hunchentoot/misc.lisp 2008-12-08 15:15:24 UTC (rev 4117) @@ -129,8 +129,9 @@ denoted by PATH. Send a content type header corresponding to CONTENT-TYPE or \(if that is NIL) tries to determine the content type via the file's suffix." - (unless (and (fad:file-exists-p path) - (not (fad:directory-exists-p path))) + (when (or (wild-pathname-p path) + (not (fad:file-exists-p path)) + (fad:directory-exists-p path)) ;; does not exist (setf (return-code) +http-not-found+) (throw 'handler-done nil)) From bknr at bknr.net Mon Dec 8 22:05:57 2008 From: bknr at bknr.net (BKNR Commits) Date: Mon, 08 Dec 2008 23:05:57 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/ Message-ID: Revision: 4118 Author: hans URL: http://bknr.net/trac/changeset/4118 Snapshot before designer gets the work. U trunk/projects/bos/payment-website/static/poi-ms.css U trunk/projects/bos/payment-website/static/poi-ms.html U trunk/projects/bos/payment-website/static/poi-ms.js U trunk/projects/bos/web/simple-sat-map.lisp Modified: trunk/projects/bos/payment-website/static/poi-ms.css =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.css 2008-12-08 15:15:24 UTC (rev 4117) +++ trunk/projects/bos/payment-website/static/poi-ms.css 2008-12-08 22:05:57 UTC (rev 4118) @@ -4,17 +4,29 @@ ul#media-list li { position: relative; + height: 64px; + margin-left: 62px; +} + +ul#media-list li img { + position: absolute; + left: -62px; + top: 2px; +} + +ul#poi-list li { + position: relative; height: 44px; margin-left: 42px; } -ul#media-list li img { +ul#poi-list li img { position: absolute; left: -42px; top: 2px; } -ul#media-list .active { +ul#media-list .active, ul#poi-list .active { background-color: #0f0; } Modified: trunk/projects/bos/payment-website/static/poi-ms.html =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-08 15:15:24 UTC (rev 4117) +++ trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-08 22:05:57 UTC (rev 4118) @@ -30,10 +30,6 @@
-
Modified: trunk/projects/bos/payment-website/static/poi-ms.js =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-08 15:15:24 UTC (rev 4117) +++ trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-08 22:05:57 UTC (rev 4118) @@ -28,7 +28,7 @@ var mediaHandlers = { image: { icon: function (medium) { - return IMG({ src: '/image/' + medium.id + '/thumbnail,,40,40', width: 40, height: 40 }) + return IMG({ src: '/image/' + medium.id + '/thumbnail,,60,60', width: 60, height: 60 }) }, makeViewer: function (medium) { return IMG({ src: '/image/' + medium.id, @@ -38,7 +38,7 @@ }, panorama: { icon: function (medium) { - return IMG({ src: '/static/panorama-icon.gif', width: 40, height: 40 }) + return IMG({ src: '/static/panorama-icon.gif', width: 60, height: 60 }) }, makeViewer: function (medium) { return APPLET({ id: 'applet', @@ -52,7 +52,7 @@ }, movie: { icon: function (medium) { - return IMG({ src: '/static/movie-icon.gif', width: 40, height: 40 }) + return IMG({ src: '/static/movie-icon.gif', width: 60, height: 60 }) }, makeViewer: function (medium) { /* can't use DOM objects like below because IE does not grok it @@ -128,6 +128,9 @@ } function showPOI(poi) { + if (poi.data) { + poi = poi.data; + } $('#left-bar') .empty() @@ -140,11 +143,9 @@ map(function (medium) { if (mediaHandlers[medium.mediumType]) { $('#media-list') - .append($(A({ href: '#' }, - LI(null, + .append($(LI(null, + A({ href: '#' }, mediaHandlers[medium.mediumType].icon(medium), - (new Date(medium.timestamp)).renderDate(), - BR(), B(null, medium.title || medium.name)))) .bind('click', medium, showMedium)); } @@ -168,11 +169,22 @@ function showOverview() { $('#content-body') .empty() - .append(H2(null, NLS('Google Map'))); + .append(H2(null, NLS('??bersicht'))); $('#left-bar') - .empty(); + .empty() + .append(UL({ id: 'poi-list' })); + for (var i in pois) { + var poi = pois[i]; + $('#poi-list') + .append($(LI(null, + A({ href: '#' }, + IMG({ src: poi.mapIcon }), + B(poi.title)))) + .bind('click', poi, showPOI)); + } + mainMap.overview(); } @@ -188,7 +200,7 @@ this.layers = {}; this.makeLayer = function (name) { - var tileLayer = new GTileLayer(copyrightCollection, 0, 12); + var tileLayer = new GTileLayer(copyrightCollection, 0, 14); tileLayer.getTileUrl = function(point, level) { if (level < 15) { var path = pointToPath(point, level); @@ -202,7 +214,7 @@ return tileLayer; } - var projection = new GMercatorProjection(12); + var projection = new GMercatorProjection(14); var customMap = new GMapType( [ this.makeLayer('sat-2002'), this.makeLayer('contracts') ], @@ -223,8 +235,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); @@ -241,7 +253,7 @@ this.show(); $('#map').removeClass('small'); $('#map').addClass('large'); - this.addControls(); +// this.addControls(); this.map.setCenter(projection.fromPixelToLatLng(new GPoint(7000, 6350), 6), 3, customMap); this.map.checkResize(); } @@ -272,9 +284,25 @@ return projection.fromPixelToLatLng(new GPoint(x, y), 6); } + var poiBaseIcon = new GIcon(G_DEFAULT_ICON); + + poiBaseIcon.shadow = "http://www.google.com/mapfiles/shadow50.png"; + poiBaseIcon.iconSize = new GSize(20, 34); + poiBaseIcon.shadowSize = new GSize(37, 34); + poiBaseIcon.iconAnchor = new GPoint(9, 34); + poiBaseIcon.infoWindowAnchor = new GPoint(9, 2); + + var index = 0; for (var i in pois) { - var marker = new GMarker(pointToLatLng(pois[i].x, pois[i].y)); - GEvent.addListener(marker, "click", partial(showPOI, pois[i])); + var poi = pois[i]; + var letter = String.fromCharCode("A".charCodeAt(0) + index++); + var letteredIcon = new GIcon(poiBaseIcon); + + poi.mapIcon = + letteredIcon.image = "http://www.google.com/mapfiles/marker" + letter + ".png"; + + var marker = new GMarker(pointToLatLng(poi.x, poi.y), { icon: letteredIcon }); + GEvent.addListener(marker, "click", partial(showPOI, poi)); this.map.addOverlay(marker); } @@ -326,8 +354,8 @@ map(function (sponsor) { $('#sponsor-list') - .append($(A({ href: '#' }, - LI(null, + .append($(LI(null, + A({ href: '#' }, IMG({ src: '/images/flags/' + sponsor.country.toLowerCase() + '.gif'}), (new Date(sponsor.contracts[0].timestamp)).renderDate(), BR(), @@ -363,9 +391,7 @@ for (var i in data.pois) { var poi = data.pois[i]; pois[poi.id] = poi; - $('#poi-selector').append(OPTION({ value: poi.id }, poi.title)); } - $('#poi-selector').bind('change', null, selectPage); mainMap = new Map(); Modified: trunk/projects/bos/web/simple-sat-map.lisp =================================================================== --- trunk/projects/bos/web/simple-sat-map.lisp 2008-12-08 15:15:24 UTC (rev 4117) +++ trunk/projects/bos/web/simple-sat-map.lisp 2008-12-08 22:05:57 UTC (rev 4118) @@ -8,9 +8,18 @@ ;; directions. It is then stored in a quad tree, with each node ;; having one image and four children. -(defparameter *levels* 6) -(defparameter *tree-size* 16384) -(defparameter *tile-size* 256) +(defparameter *tree-levels* 12 + "Total number of levels in the tree.") + +(defparameter *tree-size* 16384 + "Width and height of the tree's base image.") + +(defparameter *tile-size* 256 + "Width and height of the tiles in the tree.") + +(defvar *image-levels* (floor (- (log *tree-size* 2) (log *tile-size* 2))) + "Number of levels in the tree with images attached. Below that, images are zoomed.") + (defparameter *tile-pow* (floor (log *tile-size* 2))) (define-persistent-class tree () @@ -35,7 +44,7 @@ ((make-quad (x y level) (apply #'make-instance 'node :x x :y y :level level - (when (< level *levels*) + (when (< level *image-levels*) (let* ((next-level (1+ level)) (next-tile-size (/ *tree-size* (expt 2 next-level)))) (list :children @@ -55,6 +64,7 @@ (y :read) (level :read) (images :read :initform (make-hash-table)) + (contracts :read :initform nil) (children :read :initform nil))) (defun node-pixel-size (node) @@ -86,7 +96,7 @@ (cl-gd:with-image* (256 256 t) (setf (cl-gd:save-alpha-p) t) (let ((transparent (cl-gd:find-color 255 255 255 :alpha 127)) - (factor (expt 2 (- *levels* (node-level node))))) + (factor (expt 2 (- *image-levels* (node-level node))))) (cl-gd:do-rows (y) (cl-gd:do-pixels-in-row (x) (let ((m2 (find-m2 (+ (node-x node) @@ -138,7 +148,7 @@ (bknr.images:make-store-image :image tile :name image-name :if-exists :kill))) - (when (< level *levels*) + (when (< level *image-levels*) (let ((next-tile-source-size (/ tile-source-size 2)) (next-level (1+ level))) (destructuring-bind (one two three four) (node-children node) @@ -167,12 +177,12 @@ (node (tree-root tree)) (path (or (bknr.web:query-param "path") ""))) (dotimes (i (min (length path) - *levels*)) + *image-levels*)) (setf node (nth (parse-integer path :start i :end (1+ i)) (node-children node)))) - (when (> (length path) *levels*) + (when (> (length path) *image-levels*) (setf (hunchentoot:aux-request-value 'zoom-path) - (subseq path *levels*))) + (subseq path *image-levels*))) (or (node-image node layer) (when (find layer (tree-layers tree)) (transparent-image))))) From bknr at bknr.net Tue Dec 9 05:50:49 2008 From: bknr at bknr.net (BKNR Commits) Date: Tue, 09 Dec 2008 06:50:49 +0100 Subject: [bknr-cvs] hans changed trunk/thirdparty/hunchentoot/util.lisp Message-ID: Revision: 4119 Author: hans URL: http://bknr.net/trac/changeset/4119 Fix from Anton Vodonosov to ensure that MD5:MD5SUM-SEQUENCE is always passed a simple string. U trunk/thirdparty/hunchentoot/util.lisp Modified: trunk/thirdparty/hunchentoot/util.lisp =================================================================== --- trunk/thirdparty/hunchentoot/util.lisp 2008-12-08 22:05:57 UTC (rev 4118) +++ trunk/thirdparty/hunchentoot/util.lisp 2008-12-09 05:50:48 UTC (rev 4119) @@ -144,7 +144,7 @@ (defun md5-hex (string) "Calculates the md5 sum of the string STRING and returns it as a hex string." (with-output-to-string (s) - (loop for code across (md5:md5sum-sequence string) + (loop for code across (md5:md5sum-sequence (coerce string 'simple-string)) do (format s "~2,'0x" code)))) (defun escape-for-html (string) From bknr at bknr.net Tue Dec 9 06:41:00 2008 From: bknr at bknr.net (BKNR Commits) Date: Tue, 09 Dec 2008 07:41:00 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/payment-website/static/ Message-ID: Revision: 4120 Author: hans URL: http://bknr.net/trac/changeset/4120 Add fake map for easier deployment. A trunk/projects/bos/payment-website/static/fake-map.jpg U trunk/projects/bos/payment-website/static/poi-ms.html U trunk/projects/bos/payment-website/static/poi-ms.js Added: trunk/projects/bos/payment-website/static/fake-map.jpg =================================================================== (Binary files differ) Property changes on: trunk/projects/bos/payment-website/static/fake-map.jpg ___________________________________________________________________ Name: svn:mime-type + application/octet-stream Modified: trunk/projects/bos/payment-website/static/poi-ms.html =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-09 05:50:48 UTC (rev 4119) +++ trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-09 06:41:00 UTC (rev 4120) @@ -19,6 +19,7 @@
+
Modified: trunk/projects/bos/payment-website/static/poi-ms.js =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-09 05:50:48 UTC (rev 4119) +++ trunk/projects/bos/payment-website/static/poi-ms.js 2008-12-09 06:41:00 UTC (rev 4120) @@ -188,6 +188,25 @@ mainMap.overview(); } +function FakeMap() { + + this.hide = function () { + $('#map').css('display', 'none'); + } + + this.overview = function () { + $('#map').css('display', 'block'); + } + + var index = 0; + for (var i in pois) { + var poi = pois[i]; + var letter = String.fromCharCode("A".charCodeAt(0) + index++); + + poi.mapIcon = "http://www.google.com/mapfiles/marker" + letter + ".png"; + } +} + function Map() { this.map = new GMap2($('#map')[0]); @@ -393,7 +412,7 @@ pois[poi.id] = poi; } - mainMap = new Map(); + mainMap = new FakeMap(); loadJSONDoc('/sponsors-json').addCallback(loadSponsors); } From bknr at bknr.net Tue Dec 9 06:58:11 2008 From: bknr at bknr.net (BKNR Commits) Date: Tue, 09 Dec 2008 07:58:11 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/payment-website/static/poi-ms.html Message-ID: Revision: 4121 Author: hans URL: http://bknr.net/trac/changeset/4121 disable google maps for the moment U trunk/projects/bos/payment-website/static/poi-ms.html Modified: trunk/projects/bos/payment-website/static/poi-ms.html =================================================================== --- trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-09 06:41:00 UTC (rev 4120) +++ trunk/projects/bos/payment-website/static/poi-ms.html 2008-12-09 06:58:11 UTC (rev 4121) @@ -7,7 +7,7 @@ - + From bknr at bknr.net Tue Dec 9 16:25:20 2008 From: bknr at bknr.net (BKNR Commits) Date: Tue, 09 Dec 2008 17:25:20 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/payment-website/static/poi-ms Message-ID: Revision: 4122 Author: hans URL: http://bknr.net/trac/changeset/4122 Add new POI microsite with design by Sven Springer A trunk/projects/bos/payment-website/static/poi-ms/ A trunk/projects/bos/payment-website/static/poi-ms/bg.gif A trunk/projects/bos/payment-website/static/poi-ms/fake-map.jpg A trunk/projects/bos/payment-website/static/poi-ms/film-icon.jpg A trunk/projects/bos/payment-website/static/poi-ms/panorama-icon.jpg A trunk/projects/bos/payment-website/static/poi-ms/poi-ms.css A trunk/projects/bos/payment-website/static/poi-ms/poi-ms.html A trunk/projects/bos/payment-website/static/poi-ms/poi-ms.js A trunk/projects/bos/payment-website/static/poi-ms/site_header-de.jpg A trunk/projects/bos/payment-website/static/poi-ms/site_header-en.jpg A trunk/projects/bos/payment-website/static/poi-ms/uebersichtskarte_klein.gif D trunk/projects/bos/payment-website/static/poi-ms.css D trunk/projects/bos/payment-website/static/poi-ms.html D trunk/projects/bos/payment-website/static/poi-ms.js Change set too large, please see URL above From bknr at bknr.net Tue Dec 9 17:01:00 2008 From: bknr at bknr.net (BKNR Commits) Date: Tue, 09 Dec 2008 18:01:00 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/payment-website/static/poi-ms/poi-ms. Message-ID: Revision: 4123 Author: hans URL: http://bknr.net/trac/changeset/4123 Cleanup. Sort POI media by type, date. U trunk/projects/bos/payment-website/static/poi-ms/poi-ms.css U trunk/projects/bos/payment-website/static/poi-ms/poi-ms.html 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-09 16:25:20 UTC (rev 4122) +++ trunk/projects/bos/payment-website/static/poi-ms/poi-ms.css 2008-12-09 17:01:00 UTC (rev 4123) @@ -7,6 +7,7 @@ background-image: url(bg.gif); background-repeat: repeat-y; } + h1 { font-size: 19px; font-weight: bold; @@ -14,37 +15,41 @@ height:62px; margin:0px; } + h2 { font-size:15px; margin:0px; font-weight: bold; } + h3 { font-size:12px; font-weight:bold; margin:0px; } -.yui-t3 { +#doc { float:left; width:740px; } + #left-bar { background-color:#B2B774; padding-top:10px; height:500px; } -.yui-b { + +.navigation { float:left; width:190px; margin-right:20px; } - -.yui-main { +#content { float:left; width:506px; } + #content-body { width:506px; float:left; @@ -55,6 +60,7 @@ #content-body img { padding-top:15px; } + a#back { color:#AFAFAF; text-decoration: none; @@ -90,6 +96,7 @@ height:37px; background-color:#FFFFFF } + ul#poi-list li { position: relative; height: 44px; 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-09 16:25:20 UTC (rev 4122) +++ trunk/projects/bos/payment-website/static/poi-ms/poi-ms.html 2008-12-09 17:01:00 UTC (rev 4123) @@ -10,29 +10,22 @@ -
+
- -
+
- - -
-
-
-
+
+
+
-
-
-
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-09 16:25:20 UTC (rev 4122) +++ trunk/projects/bos/payment-website/static/poi-ms/poi-ms.js 2008-12-09 17:01:00 UTC (rev 4123) @@ -121,6 +121,14 @@ return path; } +function compareMedia (a, b) { + if (a.mediumType == b.mediumType) { + return (b.timestamp < a.timestamp) ? -1 : 1; + } else { + return (a.mediumType < b.mediumType) ? -1 : 1; + } +} + function showPOI(poi) { if (poi.data) { poi = poi.data; @@ -148,7 +156,7 @@ B(null, medium.title || medium.name)))) .bind('click', [ poi, medium ], showMedium)); } - }, poi.media); + }, poi.media.sort(compareMedia)); mainMap.hide(); } From bknr at bknr.net Tue Dec 9 20:04:01 2008 From: bknr at bknr.net (BKNR Commits) Date: Tue, 09 Dec 2008 21:04:01 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/payment-website/static/poi-ms/poi-ms. Message-ID: Revision: 4124 Author: hans URL: http://bknr.net/trac/changeset/4124 Re-enable Google Maps U trunk/projects/bos/payment-website/static/poi-ms/poi-ms.css U trunk/projects/bos/payment-website/static/poi-ms/poi-ms.html 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-09 17:01:00 UTC (rev 4123) +++ trunk/projects/bos/payment-website/static/poi-ms/poi-ms.css 2008-12-09 20:04:01 UTC (rev 4124) @@ -139,8 +139,8 @@ float:left; } #map.large { - width: 600px; - height: 600px; + width: 505px; + height: 505px; } #map.small { width: 400px; 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-09 17:01:00 UTC (rev 4123) +++ trunk/projects/bos/payment-website/static/poi-ms/poi-ms.html 2008-12-09 20:04:01 UTC (rev 4124) @@ -6,7 +6,7 @@ - + @@ -16,7 +16,7 @@
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-09 17:01:00 UTC (rev 4123) +++ trunk/projects/bos/payment-website/static/poi-ms/poi-ms.js 2008-12-09 20:04:01 UTC (rev 4124) @@ -219,10 +219,11 @@ this.map = new GMap2($('#map')[0]); var copyrightCollection = new GCopyrightCollection('Map'); - copyrightCollection.addCopyright(new GCopyright(1, - new GLatLngBounds(new GLatLng(-90, -180), new GLatLng(90, 180)), - 3, - "Copyright BOS Deutschland e.V.")); + copyrightCollection + .addCopyright(new GCopyright(1, + new GLatLngBounds(new GLatLng(-90, -180), new GLatLng(90, 180)), + 3, + "Copyright BOS Deutschland e.V.")); this.layers = {}; @@ -280,8 +281,8 @@ this.show(); $('#map').removeClass('small'); $('#map').addClass('large'); -// this.addControls(); - this.map.setCenter(projection.fromPixelToLatLng(new GPoint(7000, 6350), 6), 3, customMap); + this.addControls(); + this.map.setCenter(projection.fromPixelToLatLng(new GPoint(6500, 6350), 6), 2, customMap); this.map.checkResize(); } @@ -420,7 +421,7 @@ pois[poi.id] = poi; } - mainMap = new FakeMap(); + mainMap = new Map(); loadJSONDoc('/sponsors-json').addCallback(loadSponsors); } From bknr at bknr.net Tue Dec 9 21:47:02 2008 From: bknr at bknr.net (BKNR Commits) Date: Tue, 09 Dec 2008 22:47:02 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/payment-website/static/poi-ms/poi-ms. Message-ID: Revision: 4125 Author: hans URL: http://bknr.net/trac/changeset/4125 Maps tweaks U trunk/projects/bos/payment-website/static/poi-ms/poi-ms.css U trunk/projects/bos/payment-website/static/poi-ms/poi-ms.html 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-09 20:04:01 UTC (rev 4124) +++ trunk/projects/bos/payment-website/static/poi-ms/poi-ms.css 2008-12-09 21:47:02 UTC (rev 4125) @@ -143,6 +143,6 @@ height: 505px; } #map.small { - width: 400px; - height: 150px; + width: 505px; + height: 200px; } 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-09 20:04:01 UTC (rev 4124) +++ trunk/projects/bos/payment-website/static/poi-ms/poi-ms.html 2008-12-09 21:47:02 UTC (rev 4125) @@ -23,9 +23,10 @@
+

+
-
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-09 20:04:01 UTC (rev 4124) +++ trunk/projects/bos/payment-website/static/poi-ms/poi-ms.js 2008-12-09 21:47:02 UTC (rev 4125) @@ -79,6 +79,8 @@ var poi = e.data[0]; var medium = e.data[1]; + mainMap.hide(); + /* Work around jQuery bug when trying to remove applet from DOM with IE. */ var applet = $("#applet")[0]; if (applet) { @@ -88,10 +90,10 @@ $('#media-list *').removeClass('active'); $(e.target).addClass('active'); + $('#title').text(poi.title); $('#content-body') .empty() - .append(H1(null, poi.title), - H2(null, medium.title), + .append(H2(null, medium.title), mediaHandlers[medium.mediumType].makeViewer(medium), H3(null, medium.subtitle), P(null, medium.description)); @@ -134,6 +136,8 @@ poi = poi.data; } + mainMap.poiDetail(poi.x, poi.y); + $('#back').css('visibility', 'inherit'); $('#left-bar') .empty() @@ -142,10 +146,11 @@ document.title = poi.title; + $('#title').text(poi.title); + $('#content-body') .empty() - .append(H1(null, poi.title), - H2(null, poi.subtitle), + .append(H2(null, poi.subtitle), P(null, poi.description)); map(function (medium) { if (mediaHandlers[medium.mediumType]) { @@ -158,7 +163,6 @@ } }, poi.media.sort(compareMedia)); - mainMap.hide(); } function pointToPath(point, level) { @@ -175,9 +179,11 @@ function showOverview() { $('#back').css('visibility', 'hidden'); + + $('#title').text(NLS('??bersicht')); + $('#content-body') - .empty() - .append(H1(null, NLS('??bersicht'))); + .empty(); $('#left-bar') .empty() @@ -282,16 +288,16 @@ $('#map').removeClass('small'); $('#map').addClass('large'); this.addControls(); + this.map.checkResize(); this.map.setCenter(projection.fromPixelToLatLng(new GPoint(6500, 6350), 6), 2, customMap); - this.map.checkResize(); } this.poiDetail = function (x, y) { $('#map').removeClass('large'); $('#map').addClass('small'); this.removeControls(); + this.map.checkResize(); this.map.setCenter(projection.fromPixelToLatLng(new GPoint(x, y), 6), 6); - this.map.checkResize(); } this.zoomTo = function (x, y, level) { From bknr at bknr.net Wed Dec 10 10:48:54 2008 From: bknr at bknr.net (BKNR Commits) Date: Wed, 10 Dec 2008 11:48:54 +0100 Subject: [bknr-cvs] hans changed trunk/thirdparty/usocket/ Message-ID: Revision: 4126 Author: hans URL: http://bknr.net/trac/changeset/4126 moving to usocket trunk D trunk/thirdparty/usocket/ From bknr at bknr.net Wed Dec 10 10:51:55 2008 From: bknr at bknr.net (BKNR Commits) Date: Wed, 10 Dec 2008 11:51:55 +0100 Subject: [bknr-cvs] hans changed trunk/thirdparty/usocket/ Message-ID: 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 From bknr at bknr.net Wed Dec 10 10:54:45 2008 From: bknr at bknr.net (BKNR Commits) Date: Wed, 10 Dec 2008 11:54:45 +0100 Subject: [bknr-cvs] hans changed trunk/thirdparty/usocket/ Message-ID: 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) From bknr at bknr.net Wed Dec 10 10:56:53 2008 From: bknr at bknr.net (BKNR Commits) Date: Wed, 10 Dec 2008 11:56:53 +0100 Subject: [bknr-cvs] hans changed trunk/thirdparty/hunchentoot/server.lisp Message-ID: 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 From bknr at bknr.net Wed Dec 10 12:27:59 2008 From: bknr at bknr.net (BKNR Commits) Date: Wed, 10 Dec 2008 13:27:59 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/m2/m2-pdf.lisp Message-ID: 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) From bknr at bknr.net Wed Dec 10 14:15:39 2008 From: bknr at bknr.net (BKNR Commits) Date: Wed, 10 Dec 2008 15:15:39 +0100 Subject: [bknr-cvs] hans changed deployed/bos/projects/bos/m2/m2-pdf.lisp Message-ID: 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) From bknr at bknr.net Sat Dec 13 21:04:39 2008 From: bknr at bknr.net (BKNR Commits) Date: Sat, 13 Dec 2008 22:04:39 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/web/ Message-ID: 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)) , at 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 From bknr at bknr.net Sun Dec 14 09:09:06 2008 From: bknr at bknr.net (BKNR Commits) Date: Sun, 14 Dec 2008 10:09:06 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/ Message-ID: 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 From bknr at bknr.net Sun Dec 14 13:58:07 2008 From: bknr at bknr.net (BKNR Commits) Date: Sun, 14 Dec 2008 14:58:07 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/payment-website/static/poi-ms/poi-ms. Message-ID: 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() { From bknr at bknr.net Sun Dec 14 23:17:22 2008 From: bknr at bknr.net (BKNR Commits) Date: Mon, 15 Dec 2008 00:17:22 +0100 Subject: [bknr-cvs] hans changed trunk/projects/bos/ Message-ID: 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 @@

-
+
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))) From bknr at bknr.net Mon Dec 15 17:10:10 2008 From: bknr at bknr.net (BKNR Commits) Date: Mon, 15 Dec 2008 18:10:10 +0100 Subject: [bknr-cvs] hans changed trunk/projects/quickhoney/src/pixel-pdf.lisp Message-ID: 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 From bknr at bknr.net Wed Dec 17 20:36:22 2008 From: bknr at bknr.net (BKNR Commits) Date: Wed, 17 Dec 2008 21:36:22 +0100 Subject: [bknr-cvs] hans changed trunk/projects/quickhoney/src/ Message-ID: 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*) From bknr at bknr.net Wed Dec 17 23:46:09 2008 From: bknr at bknr.net (BKNR Commits) Date: Thu, 18 Dec 2008 00:46:09 +0100 Subject: [bknr-cvs] hans changed trunk/projects/quickhoney/src/ Message-ID: 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")) From bknr at bknr.net Thu Dec 18 00:09:24 2008 From: bknr at bknr.net (BKNR Commits) Date: Thu, 18 Dec 2008 01:09:24 +0100 Subject: [bknr-cvs] hans changed trunk/projects/quickhoney/src/pixel-pdf.lisp Message-ID: 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) From bknr at bknr.net Thu Dec 18 06:39:24 2008 From: bknr at bknr.net (BKNR Commits) Date: Thu, 18 Dec 2008 07:39:24 +0100 Subject: [bknr-cvs] hans changed trunk/projects/quickhoney/src/pixel-pdf.lisp Message-ID: 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 From bknr at bknr.net Thu Dec 18 08:04:11 2008 From: bknr at bknr.net (BKNR Commits) Date: Thu, 18 Dec 2008 09:04:11 +0100 Subject: [bknr-cvs] hans changed trunk/projects/quickhoney/src/ Message-ID: 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 From bknr at bknr.net Thu Dec 18 11:38:27 2008 From: bknr at bknr.net (BKNR Commits) Date: Thu, 18 Dec 2008 12:38:27 +0100 Subject: [bknr-cvs] hans changed trunk/projects/quickhoney/src/ Message-ID: 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 From bknr at bknr.net Thu Dec 18 17:32:05 2008 From: bknr at bknr.net (BKNR Commits) Date: Thu, 18 Dec 2008 18:32:05 +0100 Subject: [bknr-cvs] hans changed trunk/projects/quickhoney/src/ Message-ID: 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) From bknr at bknr.net Fri Dec 19 12:51:10 2008 From: bknr at bknr.net (BKNR Commits) Date: Fri, 19 Dec 2008 13:51:10 +0100 Subject: [bknr-cvs] hans changed trunk/thirdparty/slime/ Message-ID: 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 From bknr at bknr.net Sat Dec 20 16:39:52 2008 From: bknr at bknr.net (BKNR Commits) Date: Sat, 20 Dec 2008 17:39:52 +0100 Subject: [bknr-cvs] hans changed trunk/projects/quickhoney/src/ Message-ID: 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) From bknr at bknr.net Sun Dec 21 11:09:33 2008 From: bknr at bknr.net (BKNR Commits) Date: Sun, 21 Dec 2008 12:09:33 +0100 Subject: [bknr-cvs] hans changed trunk/projects/quickhoney/src/pixel-pdf.lisp Message-ID: 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*)) From bknr at bknr.net Sun Dec 21 11:21:37 2008 From: bknr at bknr.net (BKNR Commits) Date: Sun, 21 Dec 2008 12:21:37 +0100 Subject: [bknr-cvs] hans changed trunk/thirdparty/cl-pdf/ Message-ID: 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)) From bknr at bknr.net Sun Dec 21 14:07:37 2008 From: bknr at bknr.net (BKNR Commits) Date: Sun, 21 Dec 2008 15:07:37 +0100 Subject: [bknr-cvs] hans changed trunk/thirdparty/cl-pdf/pdf Message-ID: 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) , at 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*))) From bknr at bknr.net Sun Dec 21 21:04:33 2008 From: bknr at bknr.net (BKNR Commits) Date: Sun, 21 Dec 2008 22:04:33 +0100 Subject: [bknr-cvs] hans changed trunk/projects/quickhoney/src/ Message-ID: 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))) + , at 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*))) + From bknr at bknr.net Sun Dec 21 22:03:07 2008 From: bknr at bknr.net (BKNR Commits) Date: Sun, 21 Dec 2008 23:03:07 +0100 Subject: [bknr-cvs] hans changed trunk/projects/quickhoney/src/pixel-pdf.lisp Message-ID: 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))