[bknr-cvs] r2454 - branches/bos/projects/bos/m2

[ksprotte at common-lisp.net]

Author: ksprotte
Date: Fri Feb  8 10:36:04 2008
New Revision: 2454

Modified:
   branches/bos/projects/bos/m2/geometry.lisp
   branches/bos/projects/bos/m2/make-certificate.lisp
   branches/bos/projects/bos/m2/packages.lisp
Log:
Geo-Koordinaten im PDF anzeigen #5 done
(Template still needs to be changed in Acrobat for larger font)


Modified: branches/bos/projects/bos/m2/geometry.lisp
==============================================================================
--- branches/bos/projects/bos/m2/geometry.lisp	(original)
+++ branches/bos/projects/bos/m2/geometry.lisp	Fri Feb  8 10:36:04 2008
@@ -258,10 +258,10 @@
 
 
 (defun format-decimal-degree (degree)
-  (format-mixed-radix-number nil (* 60 degree) '(60 360) '("~,2F´" "~D°")))
+  (format-mixed-radix-number nil (* 60 60 degree) '(60 60 360) '(" ~,2F´´" " ~D´" "~D°")))
 
-(defun format-lon-lat (lon lat)
-  (format nil "~A ~:[S~;N~], ~A~:[W~;E~]"
+(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))

Modified: branches/bos/projects/bos/m2/make-certificate.lisp
==============================================================================
--- branches/bos/projects/bos/m2/make-certificate.lisp	(original)
+++ branches/bos/projects/bos/m2/make-certificate.lisp	Fri Feb  8 10:36:04 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/bos/projects/bos/m2/packages.lisp
==============================================================================
--- branches/bos/projects/bos/m2/packages.lisp	(original)
+++ branches/bos/projects/bos/m2/packages.lisp	Fri Feb  8 10:36:04 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)