source: project/release/5/geo-utils/trunk/geo-dms.scm @ 36188

Last change on this file since 36188 was 36188, checked in by kon, 8 months ago

C5 port work

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