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

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

add types, ? for preds

File size: 3.3 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
15(use type-checks)
16
17(use geopoint)
18
19;;;
20
21;;
22
23(: *make-geobox ((struct geopoint) (struct geopoint) --> (struct geobox)))
24(: geobox? (* --> boolean))
25(: *geobox-minimum ((struct geobox) --> (struct geopoint)))
26(: *geobox-maximum ((struct geobox) --> (struct geopoint)))
27(define-record-type geobox
28  (*make-geobox min max)
29  geobox?
30  (min *geobox-minimum)
31  (max *geobox-maximum) )
32
33;(: make-geobox (or ((struct geopoint) (struct geopoint) --> (struct geobox)) (number number number number --> (struct geobox))))
34(define make-geobox
35  (case-lambda
36    ((min-pnt max-pnt)
37      (make-geobox* 'make-geobox min-pnt max-pnt) )
38    ((minLat minLon maxLat maxLon)
39      (make-geobox* 'make-geobox
40        (make-geopoint minLat minLon) (make-geopoint maxLat maxLon)) ) ) )
41
42(: make-geobox* (symbol (struct geopoint) (struct geopoint) --> (struct geobox)))
43(define (make-geobox* loc min-pnt max-pnt)
44  (check-geopoint loc min-pnt)
45  (check-geopoint loc max-pnt)
46  (unless
47    (and
48      (geopoint-above? min-pnt max-pnt)
49      (geopoint-left? min-pnt max-pnt) )
50    (error loc "minimum-geopoint > maximum-geopoint" min-pnt max-pnt) )
51  (*make-geobox min-pnt max-pnt) )
52
53(define-check+error-type geobox)
54
55(: geobox-minimum ((struct geobox) --> (struct geopoint)))
56(define (geobox-minimum gb)
57  (*geobox-minimum (check-geobox 'geobox-minimum gb)) )
58
59(: geobox-maximum ((struct geobox) --> (struct geopoint)))
60(define (geobox-maximum gb)
61  (*geobox-maximum (check-geobox 'geobox-maximum gb)) )
62
63;;
64
65(: geobox= ((struct geobox) (struct geobox) --> boolean))
66(define (geobox= gb1 gb2)
67  (check-geobox 'geobox= gb1)
68  (check-geobox 'geobox= gb2)
69  (and
70    (geopoint= (*geobox-minimum gb1) (*geobox-minimum gb2))
71    (geopoint= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
72
73(: geobox< ((struct geobox) (struct geobox) --> boolean))
74(define (geobox< gb1 gb2)
75  (check-geobox 'geobox< gb1)
76  (check-geobox 'geobox< gb2)
77  (and
78    (geopoint< (*geobox-minimum gb1) (*geobox-minimum gb2))
79    (geopoint< (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
80
81(: geobox> ((struct geobox) (struct geobox) --> boolean))
82(define (geobox> gb1 gb2)
83  (check-geobox 'geobox> gb1)
84  (check-geobox 'geobox> gb2)
85  (and
86    (geopoint> (*geobox-minimum gb1) (*geobox-minimum gb2))
87    (geopoint> (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
88
89(: geobox<= ((struct geobox) (struct geobox) --> boolean))
90(define (geobox<= gb1 gb2)
91  (check-geobox 'geobox<= gb1)
92  (check-geobox 'geobox<= gb2)
93  (and
94    (geopoint<= (*geobox-minimum gb1) (*geobox-minimum gb2))
95    (geopoint<= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
96
97(: geobox>= ((struct geobox) (struct geobox) --> boolean))
98(define (geobox>= gb1 gb2)
99  (check-geobox 'geobox>= gb1)
100  (check-geobox 'geobox>= gb2)
101  (and
102    (geopoint>= (*geobox-minimum gb1) (*geobox-minimum gb2))
103    (geopoint>= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
104
105(: geopoint-within-box? ((struct geobox) (struct geobox) --> boolean))
106(define (geopoint-within-box? gp gb)
107  (and
108    (geopoint<= (*geobox-minimum gb) gp)
109    (geopoint>= (*geobox-maximum gb) gp) ) )
110
111) ;geobox
Note: See TracBrowser for help on using the repository browser.