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

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

C5 initial

File size: 2.4 KB
Line 
1;;;; geopolygon.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3;;;; Kon Lovett, Aug '17
4;;;; Kon Lovett, May '17
5
6(module geopolygon
7
8(;export
9  make-geopolygon
10  geopolygon? check-geopolygon error-geopolygon
11  geopolygon
12  geopolygon-closed? geopolygon-open?
13  geopolygon-bounding-box )
14
15(import scheme
16  (chicken fixnum)
17  (chicken type)
18  vector-lib
19  type-checks
20  geopoint geobox)
21
22(include "geo-constants")
23
24;;;
25
26(define (ensure-vector gps)
27  (if (list? gps) (list->vector gps) gps) )
28
29;;;
30
31(define-type geopolygon
32  (or
33    (vector-of (struct geopoint))
34    (list-of (struct geopoint))))
35
36;;
37
38;not strict
39(define make-geopolygon
40  (case-lambda
41    ((gps)
42      (cond
43        ((vector? gps)
44          (and
45            (vector-every geopoint? gps)
46            gps ) )
47        ((list? gps)
48          (make-geopolygon (ensure-vector gps)) )
49        (else
50          (error 'make-geopolygon "unrecognized as geopolygon" gps) ) ) )
51    (rest
52      (make-geopolygon rest) ) ) )
53
54(: geopolygon? (* --> boolean))
55;
56(define (geopolygon? obj)
57  (and
58    (vector? obj)
59    (vector-every geopoint? obj)) )
60
61(define-check+error-type geopolygon)
62
63(: geopolygon (#!rest --> geopolygon))
64;
65(define (geopolygon . gps)
66  (make-geopolygon gps) )
67
68; explicitly closed means [0] = [n-1]
69(: geopolygon-closed? (geopolygon --> boolean))
70;
71(define (geopolygon-closed? gpoly)
72        (let* (
73          (gpoly (ensure-vector gpoly))
74    (len (vector-length gpoly)) )
75    ;
76          (and
77            (fx<= 2 len)
78            (geopoint= (vector-ref gpoly 0) (vector-ref gpoly (fx- len 1))) ) ) )
79
80; explicitly open means [0] != [n-1]
81(: geopolygon-open? (geopolygon --> boolean))
82;
83(define (geopolygon-open? gpoly)
84        (not (geopolygon-closed? gpoly)) )
85
86;;
87
88(: geopolygon-bounding-box (geopolygon --> (struct geobox)))
89;
90(define (geopolygon-bounding-box gpoly)
91        (let* (
92          (gpoly (ensure-vector gpoly))
93    (len (vector-length (check-geopolygon 'geopolygon-bounding-box gpoly))) )
94    (let loop ((i 0) (minLat 90.0) (maxLat -90.0) (minLon 180.0) (maxLon -180.0))
95      ;traced polygon?
96      (if (fx= i len)
97        ;then report
98        (make-geobox minLat minLon maxLat maxLon)
99        ;else next point in poly
100        (let* (
101          (pnt (vector-ref gpoly i))
102          (lat (geopoint-latitude pnt))
103          (lon (geopoint-longitude pnt)) )
104          (loop (fx+ i 1) (min lat minLat) (max lat maxLat) (min lon minLon) (max lon maxLon)) ) ) ) ) )
105
106) ;geopolygon
Note: See TracBrowser for help on using the repository browser.