bknr-cvs

bknr-cvs@common-lisp.net

1964 discussions

[bknr-cvs] r2402 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 24 Jan '08

24 Jan '08

Author: ksprotte Date: Thu Jan 24 11:36:56 2008 New Revision: 2402 Modified: branches/bos/projects/bos/m2/geometry.lisp branches/bos/projects/bos/m2/m2.lisp branches/bos/projects/bos/m2/packages.lisp Log: working on geometry... (backup commit) Modified: branches/bos/projects/bos/m2/geometry.lisp ============================================================================== --- branches/bos/projects/bos/m2/geometry.lisp (original) +++ branches/bos/projects/bos/m2/geometry.lisp Thu Jan 24 11:36:56 2008 @@ -1,19 +1,177 @@ (in-package :geometry) +;; a point in this package is represented +;; as a list (x y) + +;; maybe change this function to take a +;; point as an argument? (defun point-in-polygon-p (x y polygon) (let (result (py y)) (loop with (pjx . pjy) = (aref polygon (1- (length polygon))) - for (pix . piy) across polygon - when (and (or (and (<= piy py) (< py pjy)) - (and (<= pjy py) (< py piy))) - (< x - (+ (/ (* (- pjx pix) (- py piy)) - (- pjy piy)) - pix))) - do (setf result (not result)) - do (setf pjx pix - pjy piy)) + for (pix . piy) across polygon + when (and (or (and (<= piy py) (< py pjy)) + (and (<= pjy py) (< py piy))) + (< x + (+ (/ (* (- pjx pix) (- py piy)) + (- pjy piy)) + pix))) + do (setf result (not result)) + do (setf pjx pix + pjy piy)) result)) +;;; directions + +;; A direction can be represented either +;; as one of the symbols: +;; :down, :left, :right, :up +;; +;; or as a list of dx and dy +;; which can be used to move from one +;; point to another in that direction +;; +;; the mapping is as follows: +;; +;; dx dy symbol +;; -- -- ----- +;; 0 1 :down +;; -1 0 :left +;; 1 0 :right +;; 0 -1 :up +;; + +(defmethod turn-right ((direction symbol)) + (case direction + (:down :left) + (:left :up) + (:up :right) + (:right :down))) + +(defmethod turn-right ((direction list)) + (direction-as-list (turn-right (direction-as-symbol direction)))) + +(defmethod turn-left ((direction symbol)) + (case direction + (:down :right) + (:right :up) + (:up :left) + (:left :down))) + +(defmethod turn-left ((direction list)) + (direction-as-list (turn-left (direction-as-symbol direction)))) + +(defmethod direction-as-symbol ((direction symbol)) + direction) + +(defmethod direction-as-symbol ((direction list)) + (arnesi:switch (direction :test #'equal) + (((0 1)) :down) + (((-1 0)) :left) + (((1 0)) :right) + (((0 -1)) :up))) + +(defmethod direction-as-list ((direction list)) + direction) + +(defmethod direction-as-list ((direction symbol)) + (case direction + (:down '(0 1)) + (:left '(-1 0)) + (:right '(1 0)) + (:up '(0 -1)))) + +(defmethod move ((point list) direction) + (destructuring-bind (x y) + point + (destructuring-bind (dx dy) + (direction-as-list direction) + (list (+ x dx) + (+ y dy))))) + +;;; polygon-from-m2s +;; (defun find-m2-by-min-x-y (m2s) +;; (iter +;; (for m2 in m2s) +;; (for x = (m2-x m2)) +;; (for y = (m2-y m2)) +;; (minimizing x into min-x) +;; (minimizing y into min-y) +;; (finally (return (get-m2 min-x min-y))))) + +(defun find-boundary-point (point in-region-p &optional (direction :up)) + (let* ((direction (direction-as-list direction)) + (next (move point direction))) + (if (funcall in-region-p next) + (find-boundary-point next in-region-p) + point))) + + +;;; region-to-polygon +(defun region-to-polygon (point in-region-p) + "Will return a closed path of points in mathematical order. +IN-REGION-P is a predicate that takes a point as an argument. +It defines the region whose bounding polygon is to be found." + (let (polygon (count 0)) + (labels ((neighbour (point direction) + "Validate the NEIGHBOUR of POINT in DIRECTION, + if it is part of the region, returns (NEIGHBOUR DIRECTION), + otherwise return NIL." + (let ((neighbour (move point direction))) + (when (funcall in-region-p neighbour) + (list neighbour direction)))) + (choose-next (point direction) + (acond + ((neighbour point (turn-right direction)) it) + ((neighbour point direction) it) + ((neighbour point (turn-left direction)) it) + ((neighbour point (turn-left (turn-left direction))) it))) + (terminate (point end-point) + (when (equal point end-point) + (incf count) + (= 2 count))) + (left-down-p (direction) + (member (direction-as-symbol direction) '(:left :down))) + (category-change-p (direction new-direction) + (arnesi:xor (left-down-p direction) + (left-down-p new-direction))) + (traverse (point direction end-point) + (unless (terminate point end-point) + (destructuring-bind (x y) + point + (destructuring-bind (next-point next-direction) + (choose-next point direction) + ;; push + (if (left-down-p direction) + (push point polygon) + (push (list (1+ x) (1+ y)) polygon)) + (when (and (category-change-p direction next-direction) + (left-down-p direction)) + (push (list x (1+ y)) polygon) + (push (list (1+ x) (1+ y)) polygon)) + (when (and (category-change-p direction next-direction) + (not (left-down-p direction))) + (push (list (1+ x) y) polygon) + (push (list x y) polygon)) + ;; print + (print (list point (direction-as-symbol direction))) + ;; traverse + (traverse next-point next-direction end-point)))))) + (let ((boundary-point (find-boundary-point point in-region-p :up))) + (destructuring-bind (&optional next-point next-direction) + (choose-next boundary-point (direction-as-list :left)) + (declare (ignore next-direction)) + (cond + ((null next-point) + ;; single m2 case + (destructuring-bind (x y) + point + (list (list x y) + (list x (1+ y)) + (list (1+ x) (1+ y)) + (list (1+ x) y) + (list x y)))) + (t (traverse boundary-point (direction-as-list :up) next-point) + (nreverse polygon)))))))) + Modified: branches/bos/projects/bos/m2/m2.lisp ============================================================================== --- branches/bos/projects/bos/m2/m2.lisp (original) +++ branches/bos/projects/bos/m2/m2.lisp Thu Jan 24 11:36:56 2008 @@ -105,6 +105,14 @@ (find-if #'(lambda (allocation-area) (point-in-polygon-p (m2-x m2) (m2-y m2) (allocation-area-vertices allocation-area))) (class-instances 'allocation-area))) +(defun m2s-polygon (m2s) + (let* ((m2 (first m2s)) + (contract (m2-contract m2))) + (region-to-polygon (list (m2-x m2) (m2-y m2)) + (lambda (p) + (let ((m2 (apply #'get-m2 p))) + (and m2 (eql contract (m2-contract m2)))))))) + ;;;; SPONSOR ;;; Exportierte Funktionen: @@ -483,4 +491,48 @@ (random-elt (cons (1+ (random 300)) '(1 1 1 1 1 5 5 10 10 10 10 10 10 10 10 10 10 10 10 10 30 30 30))) - :paidp t)))) \ No newline at end of file + :paidp t)))) + + +;;; for quick visualization +#+ltk +(defun show-m2s-polygon (m2s &aux (points (m2s-polygon m2s))) + (labels ((compute-bounding-box (m2s) + (let* ((left (m2-x (elt m2s 0))) + (top (m2-y (elt m2s 0))) + (right left) + (bottom top)) + (loop for i from 1 below (length m2s) do + (let* ((v (elt m2s i)) + (x (m2-x v)) + (y (m2-y v))) + (setf left (min left x) + right (max right x) + top (min top y) + bottom (max bottom y)))) + (values left top (- right left) (- bottom top))))) + (multiple-value-bind (LEFT TOP WIDTH HEIGHT) + (compute-bounding-box m2s) + (finish-output) + (flet ((transform-x (x) + (+ 30 (* 30 (- x left)))) + (transform-y (y) + (+ 30 (* 30 (- y top))))) + (ltk:with-ltk () + (let ((canvas (make-instance 'ltk:canvas :width 700 :height 700))) + ;; draw m2s + (loop for m2 in m2s + for x = (transform-x (m2-x m2)) + for y = (transform-y (m2-y m2)) + do (ltk:create-text canvas (+ 10 x) (+ 10 y) "X")) + ;; draw polygon + (loop for a in points + for b in (cdr points) + while (and a b) + do (ltk:create-line* canvas + (transform-x (first a)) (transform-y (second a)) + (transform-x (first b)) (transform-y (second b)))) + (let ((a (first points))) + (ltk:create-text canvas (transform-x (first a)) (transform-y (second a)) "o")) + (ltk:pack canvas))))))) + Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Thu Jan 24 11:36:56 2008 @@ -1,8 +1,10 @@ (in-package :cl-user) (defpackage :geometry - (:use :cl) - (:export #:point-in-polygon-p)) + (:use :cl :iterate :arnesi) + (:export #:point-in-polygon-p + #:find-boundary-point + #:region-to-polygon)) (defpackage :geo-utm (:use :cl)

1 0

[bknr-cvs] r2401 - branches/bos/projects/bos/web
by hhubner＠common-lisp.net 23 Jan '08

23 Jan '08

Author: hhubner Date: Wed Jan 23 16:09:55 2008 New Revision: 2401 Modified: branches/bos/projects/bos/web/allocation-area-handlers.lisp Log: Correct scaling for coordinates of imported polygon. Y values decrease from the NW corner, X values increase. Modified: branches/bos/projects/bos/web/allocation-area-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/allocation-area-handlers.lisp (original) +++ branches/bos/projects/bos/web/allocation-area-handlers.lisp Wed Jan 23 16:09:55 2008 @@ -230,7 +230,7 @@ (defun parse-point (line) (destructuring-bind (x y) (read-from-string (format nil "(~A)" line)) (cons (scale-coordinate 'x +nw-utm-x+ x) - (scale-coordinate 'y +nw-utm-y+ (- y +width+))))) + (scale-coordinate 'y (- +nw-utm-y+ +width+) y)))) (defun polygon-from-text-file (filename) (coerce (with-open-file (input-file filename)

1 0

[bknr-cvs] r2400 - branches/bos/projects/bos/web
by hhubner＠common-lisp.net 23 Jan '08

23 Jan '08

Author: hhubner Date: Wed Jan 23 13:29:30 2008 New Revision: 2400 Modified: branches/bos/projects/bos/web/boi-handlers.lisp branches/bos/projects/bos/web/bos.web.asd branches/bos/projects/bos/web/web-macros.lisp Log: Move WITH-XML-RESPONSE and WITH-XML-ERROR-HANDLER macros to web-macros.lisp Modified: branches/bos/projects/bos/web/boi-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/boi-handlers.lisp (original) +++ branches/bos/projects/bos/web/boi-handlers.lisp Wed Jan 23 13:29:30 2008 @@ -3,30 +3,6 @@ (enable-interpol-syntax) -(defvar *xml-sink*) - -(defmacro with-xml-response ((&key (content-type "text/xml") (root-element "response")) &body body) - `(with-http-response (*req* *ent* :content-type ,content-type) - (with-query-params (*req* download) - (when download - (setf (reply-header-slot-value *req* :content-disposition) - (format nil "attachment; filename=~A" download)))) - (with-http-body (*req* *ent*) - (let ((*xml-sink* (make-character-stream-sink net.html.generator:*html-stream* :canonical nil))) - (with-xml-output *xml-sink* - (with-element ,root-element - ,@body)))))) - -(defmacro with-xml-error-handler (req &body body) - (declare (ignore req)) - `(handler-case - (progn ,@body) - (error (e) - (with-xml-response () - (with-element "status" - (attribute "failure" 1) - (text (princ-to-string e))))))) - (defclass boi-handler (page-handler) ()) Modified: branches/bos/projects/bos/web/bos.web.asd ============================================================================== --- branches/bos/projects/bos/web/bos.web.asd (original) +++ branches/bos/projects/bos/web/bos.web.asd Wed Jan 23 13:29:30 2008 @@ -30,7 +30,7 @@ (:file "contract-handlers" :depends-on ("web-utils")) (:file "contract-image-handler" :depends-on ("web-utils")) (:file "reports-xml-handler" :depends-on ("boi-handlers")) - (:file "kml-handlers" :depends-on ("boi-handlers")) + (:file "kml-handlers" :depends-on ("packages" "web-macros")) (:file "sponsor-handlers" :depends-on ("web-utils")) (:file "news-handlers" :depends-on ("web-utils")) (:file "allocation-area-handlers" :depends-on ("web-utils")) Modified: branches/bos/projects/bos/web/web-macros.lisp ============================================================================== --- branches/bos/projects/bos/web/web-macros.lisp (original) +++ branches/bos/projects/bos/web/web-macros.lisp Wed Jan 23 13:29:30 2008 @@ -5,3 +5,27 @@ (defmacro with-bos-cms-page ((req &key title response) &rest body) `(with-bknr-page (,req :title ,title :response ,response) ,@body)) + +(defvar *xml-sink*) + +(defmacro with-xml-response ((&key (content-type "text/xml") (root-element "response")) &body body) + `(with-http-response (*req* *ent* :content-type ,content-type) + (with-query-params (*req* download) + (when download + (setf (reply-header-slot-value *req* :content-disposition) + (format nil "attachment; filename=~A" download)))) + (with-http-body (*req* *ent*) + (let ((*xml-sink* (make-character-stream-sink net.html.generator:*html-stream* :canonical nil))) + (with-xml-output *xml-sink* + (with-element ,root-element + ,@body)))))) + +(defmacro with-xml-error-handler (req &body body) + (declare (ignore req)) + `(handler-case + (progn ,@body) + (error (e) + (with-xml-response () + (with-element "status" + (attribute "failure" 1) + (text (princ-to-string e)))))))

1 0

[bknr-cvs] r2399 - branches/bos/projects/bos/web
by ksprotte＠common-lisp.net 23 Jan '08

23 Jan '08

Author: ksprotte Date: Wed Jan 23 13:27:15 2008 New Revision: 2399 Modified: branches/bos/projects/bos/web/bos.web.asd Log: oops, "kml-handlers" needs to depend on "boi-handlers" Modified: branches/bos/projects/bos/web/bos.web.asd ============================================================================== --- branches/bos/projects/bos/web/bos.web.asd (original) +++ branches/bos/projects/bos/web/bos.web.asd Wed Jan 23 13:27:15 2008 @@ -30,7 +30,7 @@ (:file "contract-handlers" :depends-on ("web-utils")) (:file "contract-image-handler" :depends-on ("web-utils")) (:file "reports-xml-handler" :depends-on ("boi-handlers")) - (:file "kml-handlers" :depends-on ("packages")) + (:file "kml-handlers" :depends-on ("boi-handlers")) (:file "sponsor-handlers" :depends-on ("web-utils")) (:file "news-handlers" :depends-on ("web-utils")) (:file "allocation-area-handlers" :depends-on ("web-utils"))

1 0

[bknr-cvs] r2398 - branches/bos/projects/bos/web
by ksprotte＠common-lisp.net 23 Jan '08

23 Jan '08

Author: ksprotte Date: Wed Jan 23 13:09:12 2008 New Revision: 2398 Added: branches/bos/projects/bos/web/kml-handlers.lisp Modified: branches/bos/projects/bos/web/bos.web.asd branches/bos/projects/bos/web/sponsor-handlers.lisp branches/bos/projects/bos/web/webserver.lisp Log: added new handler: ("/contract-kml" contract-kml-handler) there is also a new link to it in "Edit Sponsor" it basically works, but needs to be improved... there is a gap in Google Earth between adjacent contracts -- probably, we need to add 1 (in our coordinate system) before the conversion this should represent the width of one square concerning the "right and bottom points" Modified: branches/bos/projects/bos/web/bos.web.asd ============================================================================== --- branches/bos/projects/bos/web/bos.web.asd (original) +++ branches/bos/projects/bos/web/bos.web.asd Wed Jan 23 13:09:12 2008 @@ -30,6 +30,7 @@ (:file "contract-handlers" :depends-on ("web-utils")) (:file "contract-image-handler" :depends-on ("web-utils")) (:file "reports-xml-handler" :depends-on ("boi-handlers")) + (:file "kml-handlers" :depends-on ("packages")) (:file "sponsor-handlers" :depends-on ("web-utils")) (:file "news-handlers" :depends-on ("web-utils")) (:file "allocation-area-handlers" :depends-on ("web-utils")) Added: branches/bos/projects/bos/web/kml-handlers.lisp ============================================================================== --- (empty file) +++ branches/bos/projects/bos/web/kml-handlers.lisp Wed Jan 23 13:09:12 2008 @@ -0,0 +1,40 @@ +(in-package :bos.web) + +(defun contract-utm-bounding-box (contract) + "Returns LEFT, TOP, RIGHT, BOTTOM." + (let (min-x min-y max-x max-y) + (dolist (m2 (contract-m2s contract)) + (setf min-x (min (m2-utm-x m2) (or min-x (m2-utm-x m2)))) + (setf min-y (min (m2-utm-y m2) (or min-y (m2-utm-y m2)))) + (setf max-x (max (m2-utm-x m2) (or max-x (m2-utm-x m2)))) + (setf max-y (max (m2-utm-y m2) (or max-y (m2-utm-y m2))))) + (list min-x max-y max-x min-y))) + +(defun points2string (points) + (format nil "~:{~F,~F,0 ~}" points)) + +(defclass contract-kml-handler (object-handler) + ()) + +(defmethod handle-object ((handler contract-kml-handler) (contract contract) req) + (with-xml-response (:content-type "application/vnd.google-earth.kml+xml" :root-element "kml") + ;; when name is xmlns, the attribute does not show up - why (?) + ;; (attribute "xmlns" "http://earth.google.com/kml/2.2") + (destructuring-bind (left top right bottom) (contract-utm-bounding-box contract) + (with-element "Document" + (with-element "Placemark" + (with-element "name" (format nil "contract~a" (store-object-id contract))) + (with-element "description" "a description") + (with-element "Polygon" + (with-element "tessellate" (text "1")) + (with-element "outerBoundaryIs" + (with-element "LinearRing" + (with-element "coordinates" + (text (points2string (list (geo-utm:utm-x-y-to-lon-lat left bottom +utm-zone+ t) + (geo-utm:utm-x-y-to-lon-lat right bottom +utm-zone+ t) + (geo-utm:utm-x-y-to-lon-lat right top +utm-zone+ t) + (geo-utm:utm-x-y-to-lon-lat left top +utm-zone+ t))))))))))))) + +(defmethod handle-object ((handle-object contract-kml-handler) (object null) req) + (error "Contract not found.")) + Modified: branches/bos/projects/bos/web/sponsor-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/sponsor-handlers.lisp (original) +++ branches/bos/projects/bos/web/sponsor-handlers.lisp Wed Jan 23 13:09:12 2008 @@ -160,7 +160,9 @@ (m2-utm-x (first (contract-m2s (first (sponsor-contracts sponsor))))) (m2-utm-y (first (contract-m2s (first (sponsor-contracts sponsor)))))))) (:td (:princ-safe (if (contract-paidp contract) "paid" "not paid"))) - (:td (cmslink (format nil "cert-regen/~A" (store-object-id contract)) "Regenerate Certificate") + (:td (cmslink (format nil "contract-kml/~A" (store-object-id contract)) "Google Earth") + :br + (cmslink (format nil "cert-regen/~A" (store-object-id contract)) "Regenerate Certificate") (when (probe-file (contract-pdf-pathname contract)) (html :br (cmslink (contract-pdf-url contract) "Show Certificate"))) (when (contract-worldpay-trans-id contract) Modified: branches/bos/projects/bos/web/webserver.lisp ============================================================================== --- branches/bos/projects/bos/web/webserver.lisp (original) +++ branches/bos/projects/bos/web/webserver.lisp Wed Jan 23 13:09:12 2008 @@ -198,7 +198,7 @@ ("/edit-poi-image" edit-poi-image-handler) ("/edit-sponsor" edit-sponsor-handler) ("/contract" contract-handler) - ("/reports-xml" reports-xml-handler) + ("/reports-xml" reports-xml-handler) ("/complete-transfer" complete-transfer-handler) ("/edit-news" edit-news-handler) ("/make-poi" make-poi-handler) @@ -224,6 +224,7 @@ ("/cancel-contract" cancel-contract-handler) ("/statistics" statistics-handler) ("/rss" rss-handler) + ("/contract-kml" contract-kml-handler) #+(or) ("/" redirect-handler :to "/index")

1 0

[bknr-cvs] r2397 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 23 Jan '08

23 Jan '08

Author: ksprotte Date: Wed Jan 23 12:59:59 2008 New Revision: 2397 Modified: branches/bos/projects/bos/m2/geo-utm.lisp Log: changed the API functions of geo-utm to work with lon lat (in that order) Modified: branches/bos/projects/bos/m2/geo-utm.lisp ============================================================================== --- branches/bos/projects/bos/m2/geo-utm.lisp (original) +++ branches/bos/projects/bos/m2/geo-utm.lisp Wed Jan 23 12:59:59 2008 @@ -204,7 +204,7 @@ (* (* x5frac x5poly) (expt x 5.0))) (* (* x7frac x7poly) (expt x 7.0)))))))) -(defun lat-lon-to-utm-x-y (lat lon) +(defun lon-lat-to-utm-x-y (lon lat) "Returns four values X, Y, ZONE and SOUTHHEMI-P." (let* ((lat (float lat 0d0)) (lon (float lon 0d0)) @@ -214,10 +214,10 @@ (setq x (+ (* x utmscale-factor) 500000.0)) (setq y (* y utmscale-factor)) (if (< y 0.0) (block nil (setq y (+ y 1.e7))) nil) - (values x y zone (minusp lat))))) + (list x y zone (minusp lat))))) -(defun utm-x-y-to-lat-lon (x y zone southhemi-p) - "Returns two values LAT and LON." +(defun utm-x-y-to-lon-lat (x y zone southhemi-p) + "Returns two values LON and LAT." (let ((x (float x 0d0)) (y (float y 0d0)) cmeridian) @@ -228,6 +228,6 @@ (setq cmeridian (utmcentral-meridian zone)) (multiple-value-bind (lat lon) (map-xyto-lat-lon x y cmeridian) - (values (rad-to-deg lat) (rad-to-deg lon))))) + (list (rad-to-deg lon) (rad-to-deg lat)))))

1 0

[bknr-cvs] r2396 - branches/bos/projects/bos/m2
by ksprotte＠common-lisp.net 23 Jan '08

23 Jan '08

Author: ksprotte Date: Wed Jan 23 12:57:22 2008 New Revision: 2396 Modified: branches/bos/projects/bos/m2/config.lisp branches/bos/projects/bos/m2/m2.lisp branches/bos/projects/bos/m2/packages.lisp Log: new constant +utm-zone+ (50) new functions: m2-utm, m2-lon-lat Modified: branches/bos/projects/bos/m2/config.lisp ============================================================================== --- branches/bos/projects/bos/m2/config.lisp (original) +++ branches/bos/projects/bos/m2/config.lisp Wed Jan 23 12:57:22 2008 @@ -6,6 +6,7 @@ (defconstant +width+ 10800) ;; Die UTM-Koordinaten der Nord-West-Ecke des Gebiets (Zone 50) +(defconstant +utm-zone+ 50) (defconstant +nw-utm-x+ 491698.366d0) (defconstant +nw-utm-y+ 9890100.289d0) Modified: branches/bos/projects/bos/m2/m2.lisp ============================================================================== --- branches/bos/projects/bos/m2/m2.lisp (original) +++ branches/bos/projects/bos/m2/m2.lisp Wed Jan 23 12:57:22 2008 @@ -88,6 +88,10 @@ ;; UTM laeuft von links nach rechts und von UNTEN NACH OBEN. (defun m2-utm-x (m2) (+ +nw-utm-x+ (m2-x m2))) (defun m2-utm-y (m2) (- +nw-utm-y+ (m2-y m2))) +(defun m2-utm (m2) (list (m2-utm-x m2) (m2-utm-y m2))) + +(defun m2-lon-lat (m2) + (geo-utm:utm-x-y-to-lon-lat (m2-utm-x m2) (m2-utm-y m2) +utm-zone+ t)) (defmethod m2-num-to-utm ((num integer)) (multiple-value-bind (y x) (truncate num +width+) Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Wed Jan 23 12:57:22 2008 @@ -6,13 +6,14 @@ (defpackage :geo-utm (:use :cl) - (:export #:lat-lon-to-utm-x-y - #:utm-x-y-to-lat-lon)) + (:export #:lon-lat-to-utm-x-y + #:utm-x-y-to-lon-lat)) (defpackage :bos.m2.config (:export #:+width+ #:+nw-utm-x+ #:+nw-utm-y+ + #:+utm-zone+ #:+m2tile-width+ #:+price-per-m2+ @@ -86,6 +87,8 @@ #:m2-y #:m2-utm-x #:m2-utm-y + #:m2-utm + #:m2-lon-lat #:escape-nl #:return-m2s

1 0

[bknr-cvs] r2395 - branches/bos/projects/bos/web
by hhubner＠common-lisp.net 23 Jan '08

23 Jan '08

Author: hhubner Date: Wed Jan 23 11:46:10 2008 New Revision: 2395 Modified: branches/bos/projects/bos/web/webserver.lisp Log: Ooops! handle-sale was never checked properly, which made sqm sales fail. Modified: branches/bos/projects/bos/web/webserver.lisp ============================================================================== --- branches/bos/projects/bos/web/webserver.lisp (original) +++ branches/bos/projects/bos/web/webserver.lisp Wed Jan 23 11:46:10 2008 @@ -24,13 +24,6 @@ (defmethod find-template-pathname ((handler worldpay-template-handler) template-name &key request) (cond - ((and (not (scan "/" template-name)) - (not (probe-file (merge-pathnames (make-pathname :name template-name :type "xml") - (template-handler-destination handler))))) - (setf template-name (format nil "~A/~A" (or (find-browser-prefered-language request) - *default-language*) - (if (equal "" template-name) - "index" template-name)))) ((scan #?r"(^|.*/)handle-sale" template-name) (with-query-params (request cartId name address country transStatus lang MC_gift) (unless (website-supports-language lang) @@ -50,7 +43,14 @@ (t (when (<= *mail-fiscal-certificate-threshold* (contract-price contract)) (mail-fiscal-certificate-to-office contract name address country)) - (setf template-name (if (and MC_gift (equal MC_gift "1")) #?"/$(lang)/versand_geschenk" #?"/$(lang)/versand_info")))))))) + (setf template-name (if (and MC_gift (equal MC_gift "1")) #?"/$(lang)/versand_geschenk" #?"/$(lang)/versand_info"))))))) + ((and (not (scan "/" template-name)) + (not (probe-file (merge-pathnames (make-pathname :name template-name :type "xml") + (template-handler-destination handler))))) + (setf template-name (format nil "~A/~A" (or (find-browser-prefered-language request) + *default-language*) + (if (equal "" template-name) + "index" template-name))))) (call-next-method handler template-name)) (defmethod initial-template-environment ((expander worldpay-template-handler) req)

1 0

[bknr-cvs] r2394 - branches/bos/projects/bos/web
by hhubner＠common-lisp.net 23 Jan '08

23 Jan '08

Author: hhubner Date: Wed Jan 23 09:58:40 2008 New Revision: 2394 Modified: branches/bos/projects/bos/web/boi-handlers.lisp Log: Add root-element keyword argument to WITH-XML-RESPONSE macro. Modified: branches/bos/projects/bos/web/boi-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/boi-handlers.lisp (original) +++ branches/bos/projects/bos/web/boi-handlers.lisp Wed Jan 23 09:58:40 2008 @@ -5,7 +5,7 @@ (defvar *xml-sink*) -(defmacro with-xml-response ((&key (content-type "text/xml")) &body body) +(defmacro with-xml-response ((&key (content-type "text/xml") (root-element "response")) &body body) `(with-http-response (*req* *ent* :content-type ,content-type) (with-query-params (*req* download) (when download @@ -14,7 +14,7 @@ (with-http-body (*req* *ent*) (let ((*xml-sink* (make-character-stream-sink net.html.generator:*html-stream* :canonical nil))) (with-xml-output *xml-sink* - (with-element "response" + (with-element ,root-element ,@body)))))) (defmacro with-xml-error-handler (req &body body)

1 0

[bknr-cvs] r2393 - in branches/bos/projects/bos: m2 web
by hhubner＠common-lisp.net 23 Jan '08

23 Jan '08

Author: hhubner Date: Wed Jan 23 09:33:58 2008 New Revision: 2393 Modified: branches/bos/projects/bos/m2/config.lisp branches/bos/projects/bos/web/boi-handlers.lisp branches/bos/projects/bos/web/reports-xml-handler.lisp Log: Accept :content-type keyword argument in WITH-XML-RESPONSE. Should this macro be moved to another file? Modified: branches/bos/projects/bos/m2/config.lisp ============================================================================== --- branches/bos/projects/bos/m2/config.lisp (original) +++ branches/bos/projects/bos/m2/config.lisp Wed Jan 23 09:33:58 2008 @@ -5,7 +5,7 @@ ;; Die Gesamtbreite des Gebiets in Quadratmetern. (defconstant +width+ 10800) -;; Die UTM-Koordinaten der Nord-West-Ecke des Gebiets. +;; Die UTM-Koordinaten der Nord-West-Ecke des Gebiets (Zone 50) (defconstant +nw-utm-x+ 491698.366d0) (defconstant +nw-utm-y+ 9890100.289d0) Modified: branches/bos/projects/bos/web/boi-handlers.lisp ============================================================================== --- branches/bos/projects/bos/web/boi-handlers.lisp (original) +++ branches/bos/projects/bos/web/boi-handlers.lisp Wed Jan 23 09:33:58 2008 @@ -5,13 +5,13 @@ (defvar *xml-sink*) -(defmacro with-xml-response (req &body body) - `(with-http-response (,req *ent* :content-type "text/xml") - (with-query-params (,req download) +(defmacro with-xml-response ((&key (content-type "text/xml")) &body body) + `(with-http-response (*req* *ent* :content-type ,content-type) + (with-query-params (*req* download) (when download - (setf (reply-header-slot-value ,req :content-disposition) + (setf (reply-header-slot-value *req* :content-disposition) (format nil "attachment; filename=~A" download)))) - (with-http-body (,req *ent*) + (with-http-body (*req* *ent*) (let ((*xml-sink* (make-character-stream-sink net.html.generator:*html-stream* :canonical nil))) (with-xml-output *xml-sink* (with-element "response" Modified: branches/bos/projects/bos/web/reports-xml-handler.lisp ============================================================================== --- branches/bos/projects/bos/web/reports-xml-handler.lisp (original) +++ branches/bos/projects/bos/web/reports-xml-handler.lisp Wed Jan 23 09:33:58 2008 @@ -20,7 +20,7 @@ year)) (defmethod handle ((handler reports-xml-handler) req) - (with-xml-response req + (with-xml-response () (destructuring-bind (name &optional *year* &rest arguments) (decoded-handler-path handler req) (setf *year* (and *year* (parse-integer *year*))) (let ((*contracts-to-process* (sort (remove-if (lambda (contract)

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs