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

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

C5 initial

File size: 3.2 KB
Line 
1;;;; geobox.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3;;;; Kon Lovett, May '17
4
5(module geobox
6
7(;export
8  make-geobox
9  geobox? check-geobox error-geobox
10  geobox-minimum geobox-maximum
11  geobox= geobox< geobox> geobox<= geobox>=
12  geopoint-within-box? )
13
14(import scheme
15  (chicken type)
16  type-checks
17  geopoint)
18
19;;;
20
21(define-type geopoint (struct geopoint))
22
23(define-type geobox (struct geobox))
24
25;;
26
27(define (check-geopoint-above-left? loc a b)
28  (check-geopoint loc a 'min)
29  (check-geopoint loc b 'max)
30  (and (geopoint-above? a b) (geopoint-left? a b)) )
31
32;;
33
34(: *make-geobox (geopoint geopoint --> geobox))
35(: geobox? (* --> boolean))
36(: *geobox-minimum (geobox --> geopoint))
37(: *geobox-maximum (geobox --> geopoint))
38;
39(define-record-type geobox
40  (*make-geobox min max)
41  geobox?
42  (min *geobox-minimum)
43  (max *geobox-maximum) )
44
45;(: make-geobox (or (geopoint geopoint --> geobox) (number number number number --> geobox)))
46(define make-geobox
47  (case-lambda
48    ;
49    ((min-pnt max-pnt)
50      (unless (check-geopoint-above-left? 'make-geobox min-pnt max-pnt)
51        (error 'make-geobox "min geopoint > max geopoint" min-pnt max-pnt) )
52      (*make-geobox min-pnt max-pnt) )
53    ;
54    ((min-lat min-lon max-lat max-lon)
55      (make-geobox
56        (make-geopoint
57          (check-real 'make-geobox min-lat)
58          (check-real 'make-geobox min-lon))
59        (make-geopoint
60          (check-real 'make-geobox max-lat)
61          (check-real 'make-geobox max-lon))) ) ) )
62
63(define-check+error-type geobox)
64
65(: geobox-minimum (geobox --> geopoint))
66;
67(define (geobox-minimum gb)
68  (*geobox-minimum (check-geobox 'geobox-minimum gb)) )
69
70(: geobox-maximum (geobox --> geopoint))
71;
72(define (geobox-maximum gb)
73  (*geobox-maximum (check-geobox 'geobox-maximum gb)) )
74
75;;
76
77(: geobox= (geobox geobox --> boolean))
78;
79(define (geobox= gb1 gb2)
80  (check-geobox 'geobox= gb1)
81  (check-geobox 'geobox= gb2)
82  (and
83    (geopoint= (*geobox-minimum gb1) (*geobox-minimum gb2))
84    (geopoint= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
85
86(: geobox< (geobox geobox --> boolean))
87;
88(define (geobox< gb1 gb2)
89  (check-geobox 'geobox< gb1)
90  (check-geobox 'geobox< gb2)
91  (and
92    (geopoint< (*geobox-minimum gb1) (*geobox-minimum gb2))
93    (geopoint< (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
94
95(: geobox> (geobox geobox --> boolean))
96;
97(define (geobox> gb1 gb2)
98  (check-geobox 'geobox> gb1)
99  (check-geobox 'geobox> gb2)
100  (and
101    (geopoint> (*geobox-minimum gb1) (*geobox-minimum gb2))
102    (geopoint> (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
103
104(: geobox<= (geobox geobox --> boolean))
105;
106(define (geobox<= gb1 gb2)
107  (check-geobox 'geobox<= gb1)
108  (check-geobox 'geobox<= gb2)
109  (and
110    (geopoint<= (*geobox-minimum gb1) (*geobox-minimum gb2))
111    (geopoint<= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
112
113(: geobox>= (geobox geobox --> boolean))
114;
115(define (geobox>= gb1 gb2)
116  (check-geobox 'geobox>= gb1)
117  (check-geobox 'geobox>= gb2)
118  (and
119    (geopoint>= (*geobox-minimum gb1) (*geobox-minimum gb2))
120    (geopoint>= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
121
122(: geopoint-within-box? (geobox geobox --> boolean))
123;
124(define (geopoint-within-box? gp gb)
125  (and
126    (geopoint<= (*geobox-minimum gb) gp)
127    (geopoint>= (*geobox-maximum gb) gp) ) )
128
129) ;geobox
Note: See TracBrowser for help on using the repository browser.