source: project/release/4/geo-utils/tags/0.3.0/geo-dms.scm @ 34507

Last change on this file since 34507 was 34507, checked in by kon, 9 months ago

rel 0.3.0

File size: 5.5 KB
Line 
1;;;; geo-dms.scm
2;;;; Kon Lovett, May '17
3;;;; Kon Lovett, Sep '17
4
5(module geo-dms
6
7(;export
8  degree-minute-second-text
9  dms->degree degree->dms
10  dms->string dms->string*
11  string-dms->degree
12  ;
13  degree->string string->degree )
14
15(import scheme)
16
17(import chicken)
18
19(use irregex mathh fp-utils)
20
21;;;
22
23(define-constant DEGREE-TEXT "°")
24(define-constant MINUTE-TEXT "'")
25(define-constant SECOND-TEXT "\"")
26
27(define +dms-regex+
28  (sre->irregex
29    '(:
30      (* space)
31      (? ($ ("NSEWnsew")))            ;Direction maybe here
32      (* space)
33      ($ (? #\-) (+ num)) (~ num)     ;shouldn't be neg, should be °
34      (* space)
35      ($ (+ num)) (~ num)             ;should be a '
36      (* space)
37      ($ (+ (or num #\.))) (~ num)    ;should be "
38      (* space)
39      (? ($ ("NSEWnsew")))            ;Direction maybe here; 0,0 has no dir
40      (* space))
41    'utf8 'fast))
42
43;;
44
45(: degree-minute-second-text (#!optional (list string string string) -> (list string string string)))
46(define degree-minute-second-text
47  (make-parameter
48    `(,DEGREE-TEXT ,MINUTE-TEXT ,SECOND-TEXT)
49    (lambda (x)
50      (if (and (list? x) (= 3 (length x)))
51        x
52        (begin
53          (warning 'degree-minute-second-text "improper DMS text" x)
54          (degree-minute-second-text))))))
55
56;;
57
58; fixnum fixnum fixnum #!optional boolean boolean string -> string
59; the degree argument maybe negative
60(: dms->string (fixnum fixnum fixnum #!optional boolean boolean string --> string))
61(define (dms->string d m s #!optional lat? leading-dir? (pad ""))
62  (if (and (fx= d 0) (fx= m 0) (fx= s 0))
63    ;so 0
64    (dms0)
65    ;construct DMS N/S/E/W
66    (let* ((neg? (fx< d 0))
67           (d (if neg? (fxneg d) d))
68           (str (dms->string* d m s pad))
69           (dir  (if lat? (if neg? "S" "N") (if neg? "W" "E")) ) )
70      (if leading-dir?
71        (string-append dir pad str)
72        (string-append str pad dir) ) ) ) )
73
74; string #!optional boolean -> flonum
75; -122°45'10"E => -122.752777777778 even though E
76; -122°45'10"W => 122.752777777778 even though W
77;
78(: string-dms->degree (string #!optional boolean --> number))
79(define (string-dms->degree str #!optional lat?)
80  (let ((match (irregex-match +dms-regex+ str)))
81    (unless match
82      (error 'string-dms->degree "improper DMS form" str) )
83    (let* (
84        (leading-dir (irregex-match-substring match 1) )
85        (leading-dir (and leading-dir (string-ref leading-dir 0)) )
86        (d (string->number (irregex-match-substring match 2)) )
87        (m (string->number (irregex-match-substring match 3)) )
88        (s (string->number (irregex-match-substring match 4)) )
89        (trailing-dir (irregex-match-substring match 5) )
90        (trailing-dir (and trailing-dir (string-ref trailing-dir 0)) )
91        (dir (or leading-dir trailing-dir) )
92        ; input string overrides parameters
93        (lat? (or (ns-dir? dir) lat?) )
94        (neg? (sw-dir? dir) ) )
95      (when (and dir (negative? d))
96        (error 'string-dms->degree "improper DMS sign with direction" str) )
97      (let ((d (if neg? (- d) d)))
98        (unless (and
99                  (if lat?
100                    (and (<= -90 d) (<= d 90))
101                    (and (<= -180 d) (<= d 180)))
102                  (and (<= 0 m) (<= m 59))
103                  (and (<= 0 s) (<= s 59)) )
104          (error 'string-dms->degree "improper DMS value" str) )
105        (dms->degree d m s) ) ) ) )
106
107;
108(define string->degree string-dms->degree)
109
110;
111(: degree->string (float #!optional boolean boolean string --> string))
112(define (degree->string deg #!optional lat? leading-dir? (pad ""))
113  (receive (d m s) (degree->dms deg)
114    (dms->string d m s lat? leading-dir? pad) ) )
115
116;;
117
118; fixnum fixnum fixnum -> flonum
119; the degree argument maybe negative
120(: dms->degree (fixnum fixnum fixnum --> float))
121(define (dms->degree d m s)
122  (let* (
123      (neg? (fx< d 0) )
124      (d (if neg? (fxneg d) d) )
125      (deg
126        (fp+
127          (exact->inexact d)
128          (fp+
129            (fp/ (exact->inexact m) 60.0)
130            (fp/ (exact->inexact s) 3600.0))) ) )
131    (if neg? (fpneg deg) deg) ) )
132
133; flonum -> fixnum fixnum fixnum
134(: degree->dms ((or float fixnum) --> fixnum fixnum fixnum))
135(define (degree->dms deg)
136  (let* ((deg (exact->inexact deg))
137         (neg? (fp< deg 0.0)) )
138    (let*-values (((sint sflt) (modf (fpabs deg)))
139                  ((dint dflt) (modf (fp* sflt 60.0)))
140                  ((mint mflt) (modf (fp* dflt 60.0))) )
141      (let ((ideg (inexact->exact dint))
142            (isec (inexact->exact (fpround (fp+ sint (fp* mflt 60.0)))))
143            (imin (inexact->exact mint)) )
144        (values (if neg? (fxneg ideg) ideg) imin isec) ) ) ) )
145
146(: dms->string* (number number number #!optional string --> string))
147(define (dms->string* d m s #!optional (pad ""))
148  (string-append
149    (number->string d) (degree-char)
150    pad
151    (number->string m) (minute-char)
152    pad
153    (number->string s) (second-char)) )
154
155;;
156
157(define (dms0)
158  (string-append "0" (degree-char) "0" (minute-char) "0" (second-char)) )
159
160(define (degree-char)
161  (car (degree-minute-second-text)) )
162
163(define (minute-char)
164  (cadr (degree-minute-second-text)) )
165
166(define (second-char)
167  (caddr (degree-minute-second-text)) )
168
169;;
170
171(define (ns-dir? dir)
172  (or (n-dir? dir) (s-dir? dir)) )
173
174(define (sw-dir? dir)
175  (or (s-dir? dir) (w-dir? dir)) )
176
177(define (w-dir? dir)
178  (case dir
179    ((#\W #\w)  #t )
180    (else       #f ) ) )
181
182(define (e-dir? dir)
183  (case dir
184    ((#\E #\e)  #t )
185    (else       #f ) ) )
186
187(define (n-dir? dir)
188  (case dir
189    ((#\N #\n)  #t )
190    (else       #f ) ) )
191
192(define (s-dir? dir)
193  (case dir
194    ((#\S #\s)  #t )
195    (else       #f ) ) )
196
197) ;module geo-dms
Note: See TracBrowser for help on using the repository browser.