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

Last change on this file since 36728 was 36728, checked in by kon, 6 months ago

add cr

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