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

Last change on this file since 35995 was 35995, checked in by Kon Lovett, 2 years ago

C5 initial

File size: 8.8 KB
Line 
1;;;; geopoint.scm
2;;;; Kon Lovett, May '17
3
4#|
5
6==== *earth-limits*
7
8<constant>*earth-limits* => geopoint-limits</constant>
9
10==== geopoint-limits
11
12<procedure>(geopoint-limits [LIMITS]) => geopoint-limits</procedure>
13
14==== geopoint-limits?
15
16<procedure>(geopoint-limits? OBJ) => boolean</procedure>
17
18==== check-geopoint-limits
19
20<procedure>(check-geopoint-limits LOC OBJ [NAME]) => geopoint-limits</procedure>
21
22==== error-geopoint-limits
23
24<procedure>(error-geopoint-limits LOC OBJ [NAME])</procedure>
25
26==== geopoint-limits-latitude
27
28<procedure>(geopoint-limits-latitude LIMITS) => geo-limit</procedure>
29
30==== geopoint-limits-longitude
31
32<procedure>(geopoint-limits-longitude LIMITS) => geo-limit</procedure>
33
34==== geo-limit-minimum
35
36<procedure>(geo-limit-minimum LIMITS) => real</procedure>
37
38==== geo-limit-maximum
39
40<procedure>(geo-limit-maximum LIMITS) => real</procedure>
41
42==== geopoint-limits-latitude-minimum
43
44<procedure>(geopoint-limits-latitude-minimum LIMITS) => real</procedure>
45
46==== geopoint-limits-latitude-maximum
47
48<procedure>(geopoint-limits-latitude-maximum LIMITS) => real</procedure>
49
50==== geopoint-limits-longitude-minimum
51
52<procedure>(geopoint-limits-longitude-minimum LIMITS) => real</procedure>
53
54==== geopoint-limits-longitude-maximum
55
56<procedure>(geopoint-limits-longitude-maximum LIMITS) => real</procedure>
57|#
58
59(module geopoint
60
61(;export
62  ;
63  *earth-limits*
64  geopoint-limits
65  geopoint-limits? check-geopoint-limits error-geopoint-limits
66  geopoint-limits-latitude geopoint-limits-longitude
67  geo-limit-minimum geo-limit-maximum
68  geopoint-limits-latitude-minimum geopoint-limits-latitude-maximum
69  geopoint-limits-longitude-minimum geopoint-limits-longitude-maximum
70  current-geopoint-limits-latitude-minimum current-geopoint-limits-latitude-maximum
71  current-geopoint-limits-longitude-minimum current-geopoint-limits-longitude-maximum
72  ;
73  make-geopoint
74  geopoint? check-geopoint error-geopoint
75  geopoint-latitude geopoint-longitude
76  ;
77  geopoint-strictly-above? geopoint-above? geopoint-strictly-below? geopoint-below?
78  geopoint-strictly-left? geopoint-left? geopoint-strictly-right? geopoint-right?
79  ;
80  geopoint= geopoint< geopoint> geopoint<= geopoint>=
81  ;
82  )
83
84(import scheme)
85
86(import chicken)
87
88(use numbers)
89(use moremacros type-checks type-errors)
90
91(include "geo-constants")
92
93;;;
94
95;;
96
97(define *earth-limits* `(
98  (,LATITUDE-MININUM . ,LATITUDE-MAXIMUM)
99  .
100  (,LONGITUDE-MININUM . ,LONGITUDE-MAXIMUM)))
101
102(define-type geo-limit pair)
103
104(: geo-limit-minimum (geo-limit --> number))
105(: geo-limit-maximum (geo-limit --> number))
106(define geo-limit-minimum car)
107(define geo-limit-maximum cdr)
108
109(: geo-limit? (* --> boolean))
110(define (geo-limit? obj)
111  (and
112    (pair? obj)
113    (let ((beg (geo-limit-minimum obj)) (end (geo-limit-maximum obj)))
114      (real? beg)
115      (real? end)
116      (<= beg end) ) ) )
117
118(define-type geopoint-limits pair)
119
120(: geopoint-limits-latitude (geopoint-limits --> geo-limit))
121(: geopoint-limits-longitude (geopoint-limits --> geo-limit))
122(define geopoint-limits-latitude car)
123(define geopoint-limits-longitude cdr)
124
125(: geopoint-limits? (* --> boolean))
126(define (geopoint-limits? obj)
127  (and
128    (pair? obj)
129    (geo-limit? (geopoint-limits-latitude obj))
130    (geo-limit? (geopoint-limits-longitude obj)) ) )
131
132(define-check+error-type geopoint-limits)
133
134(: geopoint-limits-latitude-minimum (geopoint-limits --> number))
135(: geopoint-limits-latitude-maximum (geopoint-limits --> number))
136(: geopoint-limits-longitude-minimum (geopoint-limits --> number))
137(: geopoint-limits-longitude-maximum (geopoint-limits --> number))
138(define  geopoint-limits-latitude-minimum (o geo-limit-minimum geopoint-limits-latitude))
139(define  geopoint-limits-latitude-maximum (o geo-limit-maximum geopoint-limits-latitude))
140(define  geopoint-limits-longitude-minimum (o geo-limit-minimum geopoint-limits-longitude))
141(define  geopoint-limits-longitude-maximum (o geo-limit-maximum geopoint-limits-longitude))
142
143(: geopoint-limits (#!optional geopoint-limits -> geopoint-limits))
144(define-warning-parameter geopoint-limits *earth-limits* geopoint-limits)
145
146(: current-geopoint-limits-latitude-minimum (geopoint-limits --> number))
147(: current-geopoint-limits-latitude-maximum (geopoint-limits --> number))
148(: current-geopoint-limits-longitude-minimum (geopoint-limits --> number))
149(: current-geopoint-limits-longitude-maximum (geopoint-limits --> number))
150(define  current-geopoint-limits-latitude-minimum (o geo-limit-minimum geopoint-limits-latitude geopoint-limits))
151(define  current-geopoint-limits-latitude-maximum (o geo-limit-maximum geopoint-limits-latitude geopoint-limits))
152(define  current-geopoint-limits-longitude-minimum (o geo-limit-minimum geopoint-limits-longitude geopoint-limits))
153(define  current-geopoint-limits-longitude-maximum (o geo-limit-maximum geopoint-limits-longitude geopoint-limits))
154
155;;
156
157(define-type geopoint (struct geopoint))
158
159(: *make-geopoint (number number --> geopoint))
160(: geopoint? (* --> boolean))
161(: *geopoint-latitude (geopoint --> number))
162(: *geopoint-longitude (geopoint --> number))
163(define-record-type geopoint
164  (*make-geopoint lat lon)
165  geopoint?
166  (lat *geopoint-latitude)
167  (lon *geopoint-longitude) )
168
169(: make-geopoint (number number --> geopoint))
170(define (make-geopoint lat lon)
171  (*make-geopoint
172    (check-real 'make-geopoint lat 'lat)
173    (check-real 'make-geopoint lon 'lon)) )
174
175(define-check+error-type geopoint)
176
177(: geopoint-latitude (geopoint --> number))
178(define (geopoint-latitude gp)
179  (*geopoint-latitude (check-geopoint 'geopoint-latitude gp)) )
180
181(: geopoint-longitude (geopoint --> number))
182(define (geopoint-longitude gp)
183  (*geopoint-longitude (check-geopoint 'geopoint-longitude gp)) )
184
185;;
186
187(: geopoint-strictly-above? (geopoint geopoint --> boolean))
188(define (geopoint-strictly-above? gp1 gp2)
189  (check-geopoint 'geopoint-strictly-above gp1)
190  (check-geopoint 'geopoint-strictly-above gp2)
191  (< (*geopoint-latitude gp1) (*geopoint-latitude gp2)) )
192
193(: geopoint-above? (geopoint geopoint --> boolean))
194(define (geopoint-above? gp1 gp2)
195  (check-geopoint 'geopoint-above gp1)
196  (check-geopoint 'geopoint-above gp2)
197  (<= (*geopoint-latitude gp1) (*geopoint-latitude gp2)) )
198
199(: geopoint-strictly-below? (geopoint geopoint --> boolean))
200(define (geopoint-strictly-below? gp1 gp2)
201  (check-geopoint 'geopoint-strictly-below gp1)
202  (check-geopoint 'geopoint-strictly-below gp2)
203  (> (*geopoint-latitude gp1) (*geopoint-latitude gp2)) )
204
205(: geopoint-below? (geopoint geopoint --> boolean))
206(define (geopoint-below? gp1 gp2)
207  (check-geopoint 'geopoint-below gp1)
208  (check-geopoint 'geopoint-below gp2)
209  (>= (*geopoint-latitude gp1) (*geopoint-latitude gp2)) )
210
211(: geopoint-strictly-left? (geopoint geopoint --> boolean))
212(define (geopoint-strictly-left? gp1 gp2)
213  (check-geopoint 'geopoint-strictly-left gp1)
214  (check-geopoint 'geopoint-strictly-left gp2)
215  (< (*geopoint-longitude gp1) (*geopoint-longitude gp2)) )
216
217(: geopoint-left? (geopoint geopoint --> boolean))
218(define (geopoint-left? gp1 gp2)
219  (check-geopoint 'geopoint-left gp1)
220  (check-geopoint 'geopoint-left gp2)
221  (<= (*geopoint-longitude gp1) (*geopoint-longitude gp2)) )
222
223(: geopoint-strictly-right? (geopoint geopoint --> boolean))
224(define (geopoint-strictly-right? gp1 gp2)
225  (check-geopoint 'geopoint-strictly-right gp1)
226  (check-geopoint 'geopoint-strictly-right gp2)
227  (> (*geopoint-longitude gp1) (*geopoint-longitude gp2)) )
228
229(: geopoint-right? (geopoint geopoint --> boolean))
230(define (geopoint-right? gp1 gp2)
231  (check-geopoint 'geopoint-right gp1)
232  (check-geopoint 'geopoint-right gp2)
233  (>= (*geopoint-longitude gp1) (*geopoint-longitude gp2)) )
234
235;;
236
237(: geopoint= (geopoint geopoint --> boolean))
238(define (geopoint= gp1 gp2)
239  (check-geopoint 'geopoint= gp1)
240  (check-geopoint 'geopoint= gp2)
241  (and
242    (= (*geopoint-latitude gp1) (*geopoint-latitude gp2))
243    (= (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
244
245(: geopoint< (geopoint geopoint --> boolean))
246(define (geopoint< gp1 gp2)
247  (check-geopoint 'geopoint< gp1)
248  (check-geopoint 'geopoint< gp2)
249  (and
250    (< (*geopoint-latitude gp1) (*geopoint-latitude gp2))
251    (< (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
252
253(: geopoint> (geopoint geopoint --> boolean))
254(define (geopoint> gp1 gp2)
255  (check-geopoint 'geopoint> gp1)
256  (check-geopoint 'geopoint> gp2)
257  (and
258    (> (*geopoint-latitude gp1) (*geopoint-latitude gp2))
259    (> (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
260
261(: geopoint<= (geopoint geopoint --> boolean))
262(define (geopoint<= gp1 gp2)
263  (check-geopoint 'geopoint<= gp1)
264  (check-geopoint 'geopoint<= gp2)
265  (and
266    (<= (*geopoint-latitude gp1) (*geopoint-latitude gp2))
267    (<= (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
268
269(: geopoint>= (geopoint geopoint --> boolean))
270(define (geopoint>= gp1 gp2)
271  (check-geopoint 'geopoint>= gp1)
272  (check-geopoint 'geopoint>= gp2)
273  (and
274    (>= (*geopoint-latitude gp1) (*geopoint-latitude gp2))
275    (>= (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
276
277) ;geopoint
Note: See TracBrowser for help on using the repository browser.