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

Last change on this file was 35004, checked in by kon, 5 months ago

earth on it's own , ocd

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(define-record-type geobox
38  (*make-geobox min max)
39  geobox?
40  (min *geobox-minimum)
41  (max *geobox-maximum) )
42
43;(: make-geobox (or (geopoint geopoint --> geobox) (number number number number --> geobox)))
44(define make-geobox
45  (case-lambda
46    ;
47    ((min-pnt max-pnt)
48      (unless (check-geopoint-above-left? 'make-geobox min-pnt max-pnt)
49        (error 'make-geobox "min geopoint > max geopoint" min-pnt max-pnt) )
50      (*make-geobox min-pnt max-pnt) )
51    ;
52    ((min-lat min-lon max-lat max-lon)
53      (make-geobox
54        (make-geopoint
55          (check-real 'make-geobox min-lat)
56          (check-real 'make-geobox min-lon))
57        (make-geopoint
58          (check-real 'make-geobox max-lat)
59          (check-real 'make-geobox max-lon))) ) ) )
60
61(define-check+error-type geobox)
62
63(: geobox-minimum (geobox --> geopoint))
64(define (geobox-minimum gb)
65  (*geobox-minimum (check-geobox 'geobox-minimum gb)) )
66
67(: geobox-maximum (geobox --> geopoint))
68(define (geobox-maximum gb)
69  (*geobox-maximum (check-geobox 'geobox-maximum gb)) )
70
71;;
72
73(: geobox= (geobox 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< (geobox 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> (geobox 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<= (geobox 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(: geobox>= (geobox geobox --> boolean))
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(: geopoint-within-box? (geobox geobox --> boolean))
114(define (geopoint-within-box? gp gb)
115  (and
116    (geopoint<= (*geobox-minimum gb) gp)
117    (geopoint>= (*geobox-maximum gb) gp) ) )
118
119) ;geobox
Note: See TracBrowser for help on using the repository browser.