source: project/release/5/geo-utils/trunk/geo-globe.scm @ 35995

Last change on this file since 35995 was 35995, checked in by Kon Lovett, 21 months ago

C5 initial

File size: 4.2 KB
Line 
1;;;; geo-globe.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3;;;; Kon Lovett, Oct '17
4
5(module geo-globe
6
7(;export
8  ;
9  make-globe
10  globe? check-globe error-globe
11  globe-radius-kilometers
12  globe-flattening-factor
13  ;
14  spherical-surface-distance
15  great-circle-distance great-circle-distance-radians
16  approximate-ellipsoid-distance
17  ;
18  great-circle-azimuth
19  ;
20  great-circle-position)
21
22(import scheme
23  (chicken type)
24  type-checks
25  geopoint
26  (prefix geo-utils utility-))
27
28;;
29
30(define-type geopoint (struct geopoint))
31
32;;
33
34(define-type globe (struct globe))
35
36;FIXME define:-record-type
37
38(: *make-globe (number number --> globe))
39(: globe? (* -> boolean : globe))
40(: *globe-radius-kilometers (globe --> number))
41(: *globe-flattening-factor (globe --> number))
42;
43(define-record-type globe
44  (*make-globe rad flt)
45  globe?
46  (rad *globe-radius-kilometers)
47  (flt *globe-flattening-factor) )
48
49(define-check+error-type globe)
50
51(: make-globe (number number --> globe))
52;
53(define (make-globe rad flt)
54  (*make-globe
55    (check-real 'make-globe rad 'radius)
56    (check-real 'make-globe flt 'falttening)) )
57
58(: globe-radius-kilometers (globe --> number))
59;
60(define (globe-radius-kilometers glob)
61  (*globe-radius-kilometers (check-globe 'globe-radius-kilometers glob 'globe)))
62
63(: globe-flattening-factor (globe --> number))
64;
65(define (globe-flattening-factor glob)
66  (*globe-flattening-factor (check-globe 'globe-flattening-factor glob 'globe)))
67
68;;
69
70(: spherical-surface-distance (globe geopoint geopoint --> number))
71;
72(define (spherical-surface-distance glob gp1 gp2)
73  (check-geopoint 'spherical-surface-distance gp1)
74  (check-geopoint 'spherical-surface-distance gp2)
75  (utility-spherical-surface-distance
76    (geopoint-latitude gp1) (geopoint-longitude gp1)
77    (geopoint-latitude gp2) (geopoint-longitude gp2)
78    (*globe-radius-kilometers (check-globe 'spherical-surface-distance glob 'globe))) )
79
80(: approximate-ellipsoid-distance (globe geopoint geopoint --> number))
81;
82(define (approximate-ellipsoid-distance glob gp1 gp2)
83  (check-globe 'approximate-ellipsoid-distance glob 'globe)
84  (check-geopoint 'approximate-ellipsoid-distance gp1)
85  (check-geopoint 'approximate-ellipsoid-distance gp2)
86  (utility-approximate-ellipsoid-distance
87    (geopoint-latitude gp1) (geopoint-longitude gp1)
88    (geopoint-latitude gp2) (geopoint-longitude gp2)
89    (*globe-radius-kilometers glob)
90    (*globe-flattening-factor glob)) )
91
92(: great-circle-distance (globe geopoint geopoint --> number))
93;
94(define (great-circle-distance glob gp1 gp2)
95  (check-geopoint 'great-circle-distance gp1)
96  (check-geopoint 'great-circle-distance gp2)
97  (utility-great-circle-distance
98    (geopoint-latitude gp1) (geopoint-longitude gp1)
99    (geopoint-latitude gp2) (geopoint-longitude gp2)
100    (*globe-radius-kilometers (check-globe 'great-circle-distance glob 'globe))) )
101
102(: great-circle-distance-radians (globe geopoint geopoint --> number))
103;
104(define (great-circle-distance-radians glob gp1 gp2)
105  (check-geopoint 'great-circle-distance-radians gp1)
106  (check-geopoint 'great-circle-distance-radians gp2)
107  (utility-great-circle-distance-radians
108    (geopoint-latitude gp1) (geopoint-longitude gp1)
109    (geopoint-latitude gp2) (geopoint-longitude gp2)
110    (*globe-radius-kilometers (check-globe 'great-circle-distance-radians glob 'globe))) )
111
112(: great-circle-azimuth (geopoint geopoint #!rest (list (or fixnum float)) --> number))
113;
114(define (great-circle-azimuth gp1 gp2 . args)
115  (check-geopoint 'great-circle-azimuth gp1)
116  (check-geopoint 'great-circle-azimuth gp2)
117  (let ((prec (optional args 5)))
118    (utility-great-circle-azimuth
119      (geopoint-latitude gp1) (geopoint-longitude gp1)
120      (geopoint-latitude gp2) (geopoint-longitude gp2)
121      (check-real 'great-circle-azimuth prec 'precision)) ) )
122
123(: great-circle-position (globe geopoint number number --> geopoint))
124;
125(define (great-circle-position glob gp dis azi)
126  (check-geopoint 'great-circle-position gp)
127  (apply
128    make-geopoint
129    (receive
130      (utility-great-circle-position
131        (geopoint-latitude gp) (geopoint-longitude gp)
132        (check-real 'great-circle-position dis 'distance)
133        (check-real 'great-circle-position azi 'azimuth)
134        (*globe-radius-kilometers (check-globe 'great-circle-distance-radians glob 'globe))))) )
135
136) ;module geo-globe
Note: See TracBrowser for help on using the repository browser.