[bknr-cvs] r2499 - in branches/trunk-reorg/projects/bos: m2 web
ksprotte at common-lisp.net
ksprotte at common-lisp.net
Fri Feb 15 11:51:11 UTC 2008
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))))))
More information about the Bknr-cvs
mailing list