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

[ksprotte at common-lisp.net]

Author: ksprotte
Date: Fri Feb  8 09:45:54 2008
New Revision: 2453

Modified:
   branches/bos/projects/bos/m2/geometry.lisp
Log:
added new function: FORMAT-LON-LAT


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 09:45:54 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 degree) '(60 360) '("~,2F´" "~D°")))
+
+(defun format-lon-lat (lon lat)
+  (format nil "~A ~:[S~;N~], ~A~:[W~;E~]"
+	  (format-decimal-degree (abs lat))
+	  (plusp lat)
+	  (format-decimal-degree (abs lon))
+	  (plusp lon)))
+