source: project/release/4/geo-utils/trunk/geobox.scm

Last change on this file was 35762, checked in by kon, 6 weeks ago

idiom, shorter names

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