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

Last change on this file since 34496 was 34496, checked in by kon, 10 months ago

add chk

File size: 2.4 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(define *make-geobox cons)
24(define *geobox-minimum car)
25(define *geobox-maximum cdr)
26
27;;;
28
29;;
30
31(define make-geobox
32  (case-lambda
33    ((min-pnt max-pnt)
34      (make-geobox* 'make-geobox min-pnt max-pnt) )
35    ((minLat minLon maxLat maxLon)
36      (make-geobox* 'make-geobox
37        (make-geopoint minLat minLon) (make-geopoint maxLat maxLon)) ) ) )
38
39(define (make-geobox* loc min-pnt max-pnt)
40  (check-geopoint loc min-pnt)
41  (check-geopoint loc max-pnt)
42  (unless
43    (and
44      (geopoint-above min-pnt max-pnt)
45      (geopoint-left min-pnt max-pnt) )
46    (error loc "minimum-geopoint > maximum-geopoint" min-pnt max-pnt) )
47  (*make-geobox min-pnt max-pnt) )
48
49(define (geobox? obj)
50  (and
51    (pair? obj)
52    (geopoint? (car obj))
53    (geopoint? (cdr obj))) )
54
55(define-check+error-type geobox)
56
57(define (geobox-minimum gb)
58  (*geobox-minimum (check-geobox 'geobox-minimum gb)) )
59
60(define (geobox-maximum gb)
61  (*geobox-maximum (check-geobox 'geobox-maximum gb)) )
62
63;;
64
65(define (geobox= gb1 gb2)
66  (check-geobox 'geobox= gb1)
67  (check-geobox 'geobox= gb2)
68  (and
69    (geopoint= (*geobox-minimum gb1) (*geobox-minimum gb2))
70    (geopoint= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
71
72(define (geobox< gb1 gb2)
73  (check-geobox 'geobox< gb1)
74  (check-geobox 'geobox< gb2)
75  (and
76    (geopoint< (*geobox-minimum gb1) (*geobox-minimum gb2))
77    (geopoint< (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
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(define (geobox<= gb1 gb2)
87  (check-geobox 'geobox<= gb1)
88  (check-geobox 'geobox<= gb2)
89  (and
90    (geopoint<= (*geobox-minimum gb1) (*geobox-minimum gb2))
91    (geopoint<= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
92
93(define (geobox>= gb1 gb2)
94  (check-geobox 'geobox>= gb1)
95  (check-geobox 'geobox>= gb2)
96  (and
97    (geopoint>= (*geobox-minimum gb1) (*geobox-minimum gb2))
98    (geopoint>= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
99
100(define (geopoint-within-box gp gb)
101  (and
102    (geopoint<= (*geobox-minimum gb) gp)
103    (geopoint>= (*geobox-maximum gb) gp) ) )
104
105) ;geobox
Note: See TracBrowser for help on using the repository browser.