Author: ksprotte Date: Fri Feb 15 06:51:09 2008 New Revision: 2499 Modified: branches/trunk-reorg/projects/bos/m2/geometry.lisp branches/trunk-reorg/projects/bos/m2/make-certificate.lisp branches/trunk-reorg/projects/bos/m2/packages.lisp branches/trunk-reorg/projects/bos/web/tags.lisp Log: manually merged over some chs from bos branch Modified: branches/trunk-reorg/projects/bos/m2/geometry.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/m2/geometry.lisp (original) +++ branches/trunk-reorg/projects/bos/m2/geometry.lisp Fri Feb 15 06:51:09 2008 @@ -214,3 +214,56 @@ (traverse boundary-point initial-direction) (nreverse polygon)))) + +;;; formatting +;; proposed by Michael Weber on alexandria-devel +(defun format-mixed-radix-number (stream number radix-list format-list + &key lsb-first leading-zeros + (trailing-zeros t)) + "Prints NUMBER to STREAM in mixed-radix RADIX. +representation-LIST is a list of radixes, least-significant first. +FORMAT-LIST is a list of format directives, one for each digit. +When LSB-FIRST is nil (default), print most-significant digit first, +otherwise least-significant digit first. +When LEADING-ZEROS and TRAILING-ZEROS are nil, leading and +trailing zero digits are not printed, respectively. \(default: remove +leading zeros, keep trailing zeros)" + (let ((format-pairs + (loop with digit and fraction + initially (setf (values number fraction) + (truncate number)) + for f-list on format-list + and r-list = radix-list then (rest r-list) + collect (list (first f-list) + (cond ((endp r-list) + (shiftf number 0)) + ((rest f-list) + (setf (values number digit) + (truncate number (first r-list))) + digit) + (t number))) + into list + finally (progn + (incf (cadar list) fraction) + (return (nreverse list)))))) + (unless trailing-zeros + (setf format-pairs (member-if #'plusp format-pairs :key + #'second))) + (when lsb-first + (setf format-pairs (nreverse format-pairs))) + (unless leading-zeros + (setf format-pairs (member-if #'plusp format-pairs :key + #'second))) + (format stream "~{~{~@?~}~}" format-pairs))) + + +(defun format-decimal-degree (degree) + (format-mixed-radix-number nil (* 60 60 degree) '(60 60 360) '(" ~,2F´´" " ~D´" "~D°"))) + +(defun format-lon-lat (stream lon lat) + (format stream "~A ~:[S~;N~], ~A ~:[W~;E~]" + (format-decimal-degree (abs lat)) + (plusp lat) + (format-decimal-degree (abs lon)) + (plusp lon))) + Modified: branches/trunk-reorg/projects/bos/m2/make-certificate.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/m2/make-certificate.lisp (original) +++ branches/trunk-reorg/projects/bos/m2/make-certificate.lisp Fri Feb 15 06:51:09 2008 @@ -42,8 +42,19 @@ :sponsor-id (sponsor-id sponsor) :master-code (sponsor-master-code sponsor) :sqm-count (length (contract-m2s contract)) - :sqm-ids (with-output-to-string (s) - (loop for group in (group-by (mapcar #'m2-num-string (contract-m2s contract)) *num-coords-per-line*) - do (loop for nums on group - do (princ (car nums) s) - do (princ (if (cdr nums) #\Tab #\Newline) s))))))) + ;; :sqm-ids (with-output-to-string (s) + ;; (loop for group in (group-by (mapcar #'m2-num-string (contract-m2s contract)) *num-coords-per-line*) + ;; do (loop for nums on group + ;; do (princ (car nums) s) + ;; do (princ (if (cdr nums) #\Tab #\Newline) s)))) + ;; should later be called :sqm-coordinates + :sqm-ids + (flet ((format-point (stream x y) + (apply #'geometry:format-lon-lat stream + (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ x) + (- +nw-utm-y+ y) +utm-zone+ t)))) + (destructuring-bind (left top width height) + (contract-bounding-box contract) + (with-output-to-string (out) + (format-point out left top) (terpri out) + (format-point out (+ left width) (+ top height)) (terpri out))))))) Modified: branches/trunk-reorg/projects/bos/m2/packages.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/m2/packages.lisp (original) +++ branches/trunk-reorg/projects/bos/m2/packages.lisp Fri Feb 15 06:51:09 2008 @@ -9,7 +9,8 @@ #:point-in-polygon-p #:point-in-circle-p #:find-boundary-point - #:region-to-polygon)) + #:region-to-polygon + #:format-lon-lat)) (defpackage :geo-utm (:use :cl) Modified: branches/trunk-reorg/projects/bos/web/tags.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/tags.lisp (original) +++ branches/trunk-reorg/projects/bos/web/tags.lisp Fri Feb 15 06:51:09 2008 @@ -167,8 +167,14 @@ (setf (get-template-var :country) (sponsor-country sponsor)) (setf (get-template-var :infotext) (sponsor-info-text sponsor)) (setf (get-template-var :name) (user-full-name sponsor)) - (setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s contract))))) - (setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s contract))))) + (setf (get-template-var :sqm-x) (format nil "~,3f" (m2-utm-x (first (contract-m2s contract))))) + (setf (get-template-var :sqm-y) (format nil "~,3f" (m2-utm-y (first (contract-m2s contract))))) + (setf (get-template-var :geo-coord) (destructuring-bind (left top . ignore) + (contract-bounding-box contract) + (declare (ignore ignore)) + (apply #'geometry:format-lon-lat nil + (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ left) + (- +nw-utm-y+ top) +utm-zone+ t)))) (setf (get-template-var :numsqm) (format nil "~D" (apply #'+ (mapcar #'(lambda (contract) (length (contract-m2s contract))) (sponsor-contracts sponsor))))))