Changeset 35762 in project


Ignore:
Timestamp:
07/05/18 09:44:41 (5 months ago)
Author:
kon
Message:

idiom, shorter names

Location:
release/4/geo-utils/trunk
Files:
7 edited

Legend:

Unmodified
Added
Removed
  • release/4/geo-utils/trunk/geo-dms.scm

    r35004 r35762  
    66
    77(;export
    8   degree-minute-second-text
     8  degree-latitude? degree-longitude?
     9  degree? minute? second?
     10  w-dir? e-dir? n-dir? s-dir?
     11  ;
     12  dms-glyphs
    913  dms->degree degree->dms
    1014  dms->string dms->string*
    1115  string-dms->degree
    1216  ;
    13   degree->string string->degree )
     17  degree->string string->degree)
    1418
    1519(import scheme chicken)
     
    4246  (and (<= 0 s) (<= s 59)) )
    4347
     48;;
     49
     50(define (w-dir? dir)
     51  (case dir
     52    ((#\W #\w)  #t )
     53    (else       #f ) ) )
     54
     55(define (e-dir? dir)
     56  (case dir
     57    ((#\E #\e)  #t )
     58    (else       #f ) ) )
     59
     60(define (n-dir? dir)
     61  (case dir
     62    ((#\N #\n)  #t )
     63    (else       #f ) ) )
     64
     65(define (s-dir? dir)
     66  (case dir
     67    ((#\S #\s)  #t )
     68    (else       #f ) ) )
     69
     70(define (ns-dir? dir)
     71  (or (n-dir? dir) (s-dir? dir)) )
     72
     73(define (sw-dir? dir)
     74  (or (s-dir? dir) (w-dir? dir)) )
     75
    4476;DMS output tags
    4577;
    46 (define-constant DEGREE-TEXT "°")
    47 (define-constant MINUTE-TEXT "'")
    48 (define-constant SECOND-TEXT "\"")
     78(define-constant DEGREE-UNIT-GLYPH "°")
     79(define-constant MINUTE-UNIT-GLYPH "'")
     80(define-constant SECOND-UNIT-GLYPH "\"")
    4981
    5082;degree-minute-second text form
    51 ;
     83
    5284(define +dms-sre+
    5385  '(:
     
    6395    (? ($ ("NSEWnsew")))            ;direction maybe here; 0,0 has no dir
    6496    (* space)))
     97
    6598(define +dms-regex+ (sre->irregex +dms-sre+ 'utf8 'fast))
    6699
    67100;;
    68101
    69 (define-type dms-text (list string string string))
    70 
    71 (define (dms-text? x)
     102(define-type dms-glyphs (list string string string))
     103
     104(define (dms-glyphs? x)
    72105  (and (list? x) (= 3 (length x))) )
    73106
    74 (define-check+error-type dms-text)
    75 
    76 (: degree-minute-second-text (#!optional dms-text -> dms-text))
    77 (define-warning-parameter degree-minute-second-text
    78   `(,DEGREE-TEXT ,MINUTE-TEXT ,SECOND-TEXT)
    79   dms-text)
     107(define-check+error-type dms-glyphs)
     108
     109(: dms-glyphs (#!optional dms-glyphs -> dms-glyphs))
     110;
     111(define-warning-parameter dms-glyphs
     112  `(,DEGREE-UNIT-GLYPH ,MINUTE-UNIT-GLYPH ,SECOND-UNIT-GLYPH)
     113  dms-glyphs)
    80114
    81115;;
     
    84118; the degree argument maybe negative
    85119(: dms->string (fixnum fixnum fixnum #!optional boolean boolean string --> string))
     120;
    86121(define (dms->string d m s #!optional lat? leading-dir? (pad ""))
    87122  (if (and (fx= d 0) (fx= m 0) (fx= s 0))
    88123    ;so 0
    89     (dms0)
     124    (dms0 pad)
    90125    ;construct DMS N/S/E/W
    91126    (let* (
     
    104139;
    105140(: string-dms->degree (string #!optional boolean --> number))
     141;
    106142(define (string-dms->degree str #!optional lat?)
    107143  (let ((match (irregex-match +dms-regex+ str)))
     
    109145      (error 'string-dms->degree "improper DMS form" str) )
    110146    (let* (
    111       (leading-dir (irregex-match-substring match 1) )
    112       (leading-dir (and leading-dir (string-ref leading-dir 0)) )
    113       (d (string->number (irregex-match-substring match 2)) )
    114       (m (string->number (irregex-match-substring match 3)) )
    115       (s (string->number (irregex-match-substring match 4)) )
    116       (trailing-dir (irregex-match-substring match 5) )
    117       (trailing-dir (and trailing-dir (string-ref trailing-dir 0)) )
    118       (dir (or leading-dir trailing-dir) )
    119       ; input string overrides parameters
    120       (lat? (or (ns-dir? dir) lat?) )
    121       (neg? (sw-dir? dir) ) )
    122       ;
     147      (leading-dir (irregex-match-substring match 1))
     148      (leading-dir (and leading-dir (string-ref leading-dir 0)))
     149      (d (string->number (irregex-match-substring match 2)))
     150      (m (string->number (irregex-match-substring match 3)))
     151      (s (string->number (irregex-match-substring match 4)))
     152      (trailing-dir (irregex-match-substring match 5))
     153      (trailing-dir (and trailing-dir (string-ref trailing-dir 0)))
     154      (dir (or leading-dir trailing-dir))
     155      ;input string overrides parameters
     156      (lat? (or (ns-dir? dir) lat?))
     157      (neg? (sw-dir? dir)) )
    123158      (when (and dir (negative? d))
    124159        (error 'string-dms->degree "improper DMS sign with direction" str) )
     
    132167;
    133168(: degree->string (float #!optional boolean boolean string --> string))
     169;
    134170(define (degree->string deg #!optional lat? leading-dir? (pad ""))
    135171  (receive (d m s) (degree->dms deg)
     
    141177; the degree argument maybe negative
    142178(: dms->degree (fixnum fixnum fixnum --> float))
     179;
    143180(define (dms->degree d m s)
    144181  (let* (
    145     (neg? (fx< d 0) )
    146     (d (if neg? (fxneg d) d) )
     182    (neg? (fx< d 0))
     183    (d (if neg? (fxneg d) d))
    147184    (deg
    148185      (fp+
     
    150187        (fp+
    151188          (fp/ (exact->inexact m) 60.0)
    152           (fp/ (exact->inexact s) 3600.0))) ) )
    153     ;
     189          (fp/ (exact->inexact s) 3600.0)))) )
    154190    (if neg? (fpneg deg) deg) ) )
    155191
    156192; flonum -> fixnum fixnum fixnum
    157193(: degree->dms ((or float fixnum) --> fixnum fixnum fixnum))
     194;
    158195(define (degree->dms deg)
    159196  (let* (
     
    174211
    175212(: dms->string* (number number number #!optional string --> string))
     213;
    176214(define (dms->string* d m s #!optional (pad ""))
    177215  (string-append
     
    185223
    186224(define (degree-char)
    187   (car (degree-minute-second-text)) )
     225  (car (dms-glyphs)) )
    188226
    189227(define (minute-char)
    190   (cadr (degree-minute-second-text)) )
     228  (cadr (dms-glyphs)) )
    191229
    192230(define (second-char)
    193   (caddr (degree-minute-second-text)) )
    194 
    195 ;;
    196 
    197 (define (dms0)
    198   (string-append "0" (degree-char) "0" (minute-char) "0" (second-char)) )
    199 
    200 ;;
    201 
    202 (define (w-dir? dir)
    203   (case dir
    204     ((#\W #\w)  #t )
    205     (else       #f ) ) )
    206 
    207 (define (e-dir? dir)
    208   (case dir
    209     ((#\E #\e)  #t )
    210     (else       #f ) ) )
    211 
    212 (define (n-dir? dir)
    213   (case dir
    214     ((#\N #\n)  #t )
    215     (else       #f ) ) )
    216 
    217 (define (s-dir? dir)
    218   (case dir
    219     ((#\S #\s)  #t )
    220     (else       #f ) ) )
    221 
    222 (define (ns-dir? dir)
    223   (or (n-dir? dir) (s-dir? dir)) )
    224 
    225 (define (sw-dir? dir)
    226   (or (s-dir? dir) (w-dir? dir)) )
     231  (caddr (dms-glyphs)) )
     232
     233;;
     234
     235(define (dms0 #!optional (pad ""))
     236  (dms->string* 0 0 0 pad) )
    227237
    228238) ;module geo-dms
  • release/4/geo-utils/trunk/geo-globe.scm

    r35004 r35762  
    4141(: *globe-radius-kilometers (globe --> number))
    4242(: *globe-flattening-factor (globe --> number))
     43;
    4344(define-record-type globe
    4445  (*make-globe rad flt)
  • release/4/geo-utils/trunk/geo-utils.scm

    r35006 r35762  
    2828
    2929(: pythagorean-distance (number number number number --> number))
     30;
    3031(define (pythagorean-distance lat1 lon1 lat2 lon2)
    3132  (sqrt (pythagorean-distance* lat1 lon1 lat2 lon2)) )
    3233
    3334(: pythagorean-distance* (number number number number --> number))
     35;
    3436(define (pythagorean-distance* lat1 lon1 lat2 lon2)
    3537  (let (
    36     (a (- lat1 lat2) )
    37     (b (- lon1 lon2) ) )
    38     ;
     38    (a (- lat1 lat2))
     39    (b (- lon1 lon2)) )
    3940    (+ (* a a) (* b b)) ) )
    4041
     
    4243
    4344(: spherical-surface-distance (float float float float #!optional float --> float))
     45;
    4446(define (spherical-surface-distance lat1 lon1 lat2 lon2 #!optional (R EARTH-RADIUS-KILOMETERS))
    4547  ;haversine formula : https://en.wikipedia.org/wiki/Haversine_formula
    4648  (let (
    47     (dlat (fpdegree->radian (fpabs (fp- lat2 lat1))) )
    48     (dlon (fpdegree->radian (fpabs (fp- lon2 lon1))) )
    49     (lat1 (fpdegree->radian lat1) )
    50     (lat2 (fpdegree->radian lat2) ) )
    51     ;
     49    (dlat (fpdegree->radian (fpabs (fp- lat2 lat1))))
     50    (dlon (fpdegree->radian (fpabs (fp- lon2 lon1))))
     51    (lat1 (fpdegree->radian lat1))
     52    (lat2 (fpdegree->radian lat2)) )
    5253    (let* (
    5354      (a
     
    5657          (fp*
    5758            (fp* (fpcos lat1) (fpcos lat2))
    58             (fpsqr (fpsin (fp/ dlat 2.0))))) )
    59       (c (fp* 2.0 (fpasin (fpmin 1.0 (fpsqrt a)))) ) )
    60       ;
     59            (fpsqr (fpsin (fp/ dlat 2.0))))))
     60      (c
     61        (fp* 2.0 (fpasin (fpmin 1.0 (fpsqrt a))))) )
    6162      (fp* c R) ) ) )
    6263
     
    6465
    6566(: great-circle-distance (float float float float #!optional float --> float))
     67;
    6668(define (great-circle-distance lat1 lon1 lat2 lon2 #!optional (R EARTH-RADIUS-KILOMETERS))
    6769  (let (
    68     (lat1 (fpdegree->radian lat1) )
    69     (lon1 (fpdegree->radian lon1) )
    70     (lat2 (fpdegree->radian lat2) )
    71     (lon2 (fpdegree->radian lon2) ) )
    72     ;
     70    (lat1 (fpdegree->radian lat1))
     71    (lon1 (fpdegree->radian lon1))
     72    (lat2 (fpdegree->radian lat2))
     73    (lon2 (fpdegree->radian lon2)) )
    7374    (great-circle-distance-radians lat1 lon1 lat2 lon2 R) ) )
    7475
    7576; https://en.wikipedia.org/wiki/Great-circle_distance
    7677(: great-circle-distance-radians (float float float float #!optional float --> float))
     78;
    7779(define (great-circle-distance-radians lat1 lon1 lat2 lon2 #!optional (R EARTH-RADIUS-KILOMETERS))
    7880  (let (
     
    8385          (fp* (fpcos lat1) (fpcos lat2))
    8486          (fpcos (fp- lon1 lon2)))) ) )
    85     ;
    8687    (fp* (fpacos d) R) ) )
    8788
     
    9596
    9697(: straight-line-distance (float float float float float float #!optional float --> float))
     98;
    9799(define (straight-line-distance lat1 lon1 h1 lat2 lon2 h2 #!optional (R EARTH-RADIUS-KILOMETERS))
    98100  ;filler
     
    102104
    103105(: approximate-ellipsoid-distance (float float float float #!optional float float --> float))
     106;
    104107(define (approximate-ellipsoid-distance lat1 lon1 lat2 lon2
    105108          #!optional
     
    108111  (let (
    109112    (lat1 (fpdegree->radian lat1) )
    110     (lon1 (fpdegree->radian lon1) )
    111     (lat2 (fpdegree->radian lat2) )
    112     (lon2 (fpdegree->radian lon2) ) )
    113     ;
     113    (lon1 (fpdegree->radian lon1))
     114    (lat2 (fpdegree->radian lat2))
     115    (lon2 (fpdegree->radian lon2)) )
    114116    (let (
    115       (f (fp/ (fp+ lat1 lat2) 2.0) )
    116       (g (fp/ (fp- lat1 lat2) 2.0) )
    117       (l (fp/ (fp- lon1 lon2) 2.0) ) )
    118       ;
     117      (f (fp/ (fp+ lat1 lat2) 2.0))
     118      (g (fp/ (fp- lat1 lat2) 2.0))
     119      (l (fp/ (fp- lon1 lon2) 2.0)) )
    119120      (let (
    120         (sing (fpsin g) )
    121         (cosl (fpcos l) )
    122         (cosf (fpcos f) )
    123         (sinl (fpsin l) )
    124         (sinf (fpsin f) )
    125         (cosg (fpcos g) ) )
    126         ;
     121        (sing (fpsin g))
     122        (cosl (fpcos l))
     123        (cosf (fpcos f))
     124        (sinl (fpsin l))
     125        (sinf (fpsin f))
     126        (cosg (fpcos g)) )
    127127        (let (
    128           (sing2 (fpsqr sing) )
    129           (cosf2 (fpsqr cosf) )
    130           (cosg2 (fpsqr cosg) )
    131           (sinf2 (fpsqr sinf) ) )
    132           ;
     128          (sing2 (fpsqr sing))
     129          (cosf2 (fpsqr cosf))
     130          (cosg2 (fpsqr cosg))
     131          (sinf2 (fpsqr sinf)) )
    133132          (let* (
    134133            (s
    135134              (fp+
    136135                (fp* sing2 (fpsqr cosl))
    137                 (fp* cosf2 (fpsqr sinl))) )
     136                (fp* cosf2 (fpsqr sinl))))
    138137            (c
    139138              (fp+
    140139                (fp* cosg2 (fpsqr cosl))
    141                 (fp* sinf2 (fpsqr sinl))) )
    142             (w (fpatan2 (fpsqrt s) (fpsqrt c)) )
    143             (r (fpsqrt (fp/ (fp* s c) w)) )
    144             (h1 (fp/ (fp* 3.0 (fp- r 1.0)) (fp* 2.0 c)) )
    145             (h2 (fp/ (fp* 3.0 (fp+ r 1.0)) (fp* 2.0 s)) )
    146             (d (fp* 2.0 (fp* w R)) ) )
    147             ;
     140                (fp* sinf2 (fpsqr sinl))))
     141            (w
     142              (fpatan2 (fpsqrt s) (fpsqrt c)))
     143            (r
     144              (fpsqrt (fp/ (fp* s c) w)))
     145            (h1
     146              (fp/ (fp* 3.0 (fp- r 1.0)) (fp* 2.0 c)))
     147            (h2
     148              (fp/ (fp* 3.0 (fp+ r 1.0)) (fp* 2.0 s)))
     149            (d
     150              (fp* 2.0 (fp* w R))) )
    148151            (fp*
    149152              d
     
    161164
    162165(: great-circle-azimuth (float float float float #!optional (or fixnum float) --> float))
     166;
    163167(define (great-circle-azimuth lat1 lon1 lat2 lon2 #!optional (prec 5))
    164168  ;
     
    170174  ;
    171175  (let (
    172     (ilat1 (clamp lat1) )
    173     (ilon1 (clamp lon1) )
    174     (ilat2 (clamp lat2) )
    175     (ilon2 (clamp lon2) ) )
    176     ;
     176    (ilat1 (clamp lat1))
     177    (ilon1 (clamp lon1))
     178    (ilat2 (clamp lat2))
     179    (ilon2 (clamp lon2)) )
    177180    (cond
    178181      ((fx= ilon1 ilon2)
     
    184187      (else
    185188        (let (
    186           (lat1 (fpdegree->radian lat1) )
    187           (lon1 (fpdegree->radian lon1) )
    188           (lat2 (fpdegree->radian lat2) )
    189           (lon2 (fpdegree->radian lon2) ) )
    190           ;
     189          (lat1 (fpdegree->radian lat1))
     190          (lon1 (fpdegree->radian lon1))
     191          (lat2 (fpdegree->radian lat2))
     192          (lon2 (fpdegree->radian lon2)) )
    191193          (let* (
    192             (c (great-circle-distance-radians lat1 lon1 lat2 lon2) )
     194            (c
     195              (great-circle-distance-radians lat1 lon1 lat2 lon2))
    193196            (a
    194197              (fpasin
    195198                (fp/
    196199                  (fp* (fpcos lat2) (fpsin (fp- lon2 lon1)))
    197                   (fpsin c))) )
    198             (r (fpradian->degree a) ) )
    199             ;
     200                  (fpsin c))))
     201            (r
     202              (fpradian->degree a)) )
    200203            (cond
    201204              ((fx> ilat2 ilat1)
     
    222225
    223226(: great-circle-position (float float float float #!optional float --> float float))
     227;
    224228(define (great-circle-position lat lon dis azi #!optional (R EARTH-RADIUS-KILOMETERS))
    225229  (let (
    226     (dlat (fpdegree->radian (fp- 90.0 lat)) )
    227     (lat (fpdegree->radian lat) )
    228     (lon (fpdegree->radian lon) )
     230    (dlat (fpdegree->radian (fp- 90.0 lat)))
     231    (lat (fpdegree->radian lat))
     232    (lon (fpdegree->radian lon))
    229233    (azi (fpdegree->radian azi)) )
    230     ;
    231234    (let* (
    232       (b (fp/ dis R) )
    233       (sinb (fpsin b) )
     235      (b
     236        (fp/ dis R))
     237      (sinb
     238        (fpsin b))
    234239      (a
    235240        (fpacos
    236241          (fp+
    237242            (fp* (fpcos b) (fpcos dlat))
    238             (fp* sinb (fp* (fpsin dlat) (fpcos azi))))) )
    239       (b (fpasin (fp/ (fp* sinb (fpsin azi)) (fpsin a))) ) )
     243            (fp* sinb (fp* (fpsin dlat) (fpcos azi))))))
     244      (b
     245        (fpasin (fp/ (fp* sinb (fpsin azi)) (fpsin a)))) )
    240246      ;
    241247      (values (fp- 90.0 (fpradian->degree a)) (fpradian->degree (fp+ b lon))) ) ) )
  • release/4/geo-utils/trunk/geobox.scm

    r35004 r35762  
    3535(: *geobox-minimum (geobox --> geopoint))
    3636(: *geobox-maximum (geobox --> geopoint))
     37;
    3738(define-record-type geobox
    3839  (*make-geobox min max)
     
    6263
    6364(: geobox-minimum (geobox --> geopoint))
     65;
    6466(define (geobox-minimum gb)
    6567  (*geobox-minimum (check-geobox 'geobox-minimum gb)) )
    6668
    6769(: geobox-maximum (geobox --> geopoint))
     70;
    6871(define (geobox-maximum gb)
    6972  (*geobox-maximum (check-geobox 'geobox-maximum gb)) )
     
    7275
    7376(: geobox= (geobox geobox --> boolean))
     77;
    7478(define (geobox= gb1 gb2)
    7579  (check-geobox 'geobox= gb1)
     
    8084
    8185(: geobox< (geobox geobox --> boolean))
     86;
    8287(define (geobox< gb1 gb2)
    8388  (check-geobox 'geobox< gb1)
     
    8893
    8994(: geobox> (geobox geobox --> boolean))
     95;
    9096(define (geobox> gb1 gb2)
    9197  (check-geobox 'geobox> gb1)
     
    96102
    97103(: geobox<= (geobox geobox --> boolean))
     104;
    98105(define (geobox<= gb1 gb2)
    99106  (check-geobox 'geobox<= gb1)
     
    104111
    105112(: geobox>= (geobox geobox --> boolean))
     113;
    106114(define (geobox>= gb1 gb2)
    107115  (check-geobox 'geobox>= gb1)
     
    112120
    113121(: geopoint-within-box? (geobox geobox --> boolean))
     122;
    114123(define (geopoint-within-box? gp gb)
    115124  (and
  • release/4/geo-utils/trunk/geopoint-utils.scm

    r35004 r35762  
    2727;(: geopoint-in-closed-polygon? ((struct geopoint) geopolygon #!optional ((struct geopoint) (struct geopoint) number number --> boolean) --> boolean))
    2828(: geopoint-in-closed-polygon? ((struct geopoint) geopolygon #!optional procedure --> boolean))
     29;
    2930(define (geopoint-in-closed-polygon? gp gpoly #!optional (intersects? intersects?-pnp))
    3031        ;test for intersection of ray with every segment of the polygon
     
    3334          (check-geopoint 'geopoint-in-closed-polygon? gp)
    3435    (let (
    35       (len (vector-length (check-geopolygon 'geopoint-in-closed-polygon? gpoly)) )
    36       (lat (geopoint-latitude gp) )
    37       (lon (geopoint-longitude gp) ) )
     36      (len (vector-length (check-geopolygon 'geopoint-in-closed-polygon? gpoly)))
     37      (lat (geopoint-latitude gp))
     38      (lon (geopoint-longitude gp)) )
    3839      ;assumes an open-poly is "closed" so a closed-poly must be treated as "open"
    3940      (let ((len (if (geopolygon-closed? gpoly) (fx- len 1) len)))
    40         (let loop (
    41           (i 0)
    42           (j (fx- len 1))
    43           (poly? #f) )
    44           ;
     41        (let loop ((i 0) (j (fx- len 1)) (poly? #f))
    4542          (if (fx= i len)
    4643            poly?
    47             (loop
    48               (fx+ i 1)
    49               i
    50               (if (intersects? (vector-ref gpoly i) (vector-ref gpoly j) lat lon)
    51                 (not poly?)
    52                 poly? ) ) ) ) ) ) ) )
     44            (let (
     45              (new-poly
     46                (if (intersects? (vector-ref gpoly i) (vector-ref gpoly j) lat lon)
     47                  (not poly?)
     48                  poly?)) )
     49            (loop (fx+ i 1) i new-poly) ) ) ) ) ) ) )
    5350
    5451;;
     
    5754;; (https://github.com/substack/point-in-polygon)
    5855(: intersects?-pnp ((struct geopoint) (struct geopoint) number number --> boolean))
     56;
    5957(define (intersects?-pnp pi pj lat lon)
    6058  (let (
     
    6361    (latj (geopoint-latitude pj))
    6462    (lonj (geopoint-longitude pj)) )
    65     ;
    6663    (and
    6764      (not (eq? (> loni lon) (> lonj lon)))
     
    7168;; (http://alienryderflex.com/polygon/)
    7269(: intersects?-pip ((struct geopoint) (struct geopoint) number number --> boolean))
     70;
    7371(define (intersects?-pip pi pj lat lon)
    7472  (let (
     
    7775    (latj (geopoint-latitude pj))
    7876    (lonj (geopoint-longitude pj)) )
    79     ;
    8077    (and
    8178      (or (and (< lati lat) (<= lat latj ) ) (and (< latj lat) (<= lat lati)))
  • release/4/geo-utils/trunk/geopoint.scm

    r35004 r35762  
    1313  geopoint-strictly-left? geopoint-left? geopoint-strictly-right? geopoint-right?
    1414  ;
    15   geopoint= geopoint< geopoint> geopoint<= geopoint>=
    16   ;
    17   )
     15  geopoint= geopoint< geopoint> geopoint<= geopoint>=)
    1816
    1917(import scheme chicken)
     
    3432(: *geopoint-latitude (geopoint --> number))
    3533(: *geopoint-longitude (geopoint --> number))
     34;
    3635(define-record-type geopoint
    3736  (*make-geopoint lat lon)
     
    4140
    4241(: make-geopoint (number number --> geopoint))
     42;
    4343(define (make-geopoint lat lon)
    4444  (*make-geopoint
     
    4949
    5050(: geopoint-latitude (geopoint --> number))
     51;
    5152(define (geopoint-latitude gp)
    5253  (*geopoint-latitude (check-geopoint 'geopoint-latitude gp)) )
    5354
    5455(: geopoint-longitude (geopoint --> number))
     56;
    5557(define (geopoint-longitude gp)
    5658  (*geopoint-longitude (check-geopoint 'geopoint-longitude gp)) )
     
    6668
    6769(: geopoint-strictly-above? (geopoint geopoint --> boolean))
     70;
    6871(define (geopoint-strictly-above? gp1 gp2)
    6972  (<
     
    7275
    7376(: geopoint-above? (geopoint geopoint --> boolean))
     77;
    7478(define (geopoint-above? gp1 gp2)
    7579  (<=
     
    7882
    7983(: geopoint-strictly-below? (geopoint geopoint --> boolean))
     84;
    8085(define (geopoint-strictly-below? gp1 gp2)
    8186  (>
     
    8489
    8590(: geopoint-below? (geopoint geopoint --> boolean))
     91;
    8692(define (geopoint-below? gp1 gp2)
    8793  (>=
     
    9096
    9197(: geopoint-strictly-left? (geopoint geopoint --> boolean))
     98;
    9299(define (geopoint-strictly-left? gp1 gp2)
    93100  (<
     
    96103
    97104(: geopoint-left? (geopoint geopoint --> boolean))
     105;
    98106(define (geopoint-left? gp1 gp2)
    99107  (<=
     
    102110
    103111(: geopoint-strictly-right? (geopoint geopoint --> boolean))
     112;
    104113(define (geopoint-strictly-right? gp1 gp2)
    105114  (>
     
    108117
    109118(: geopoint-right? (geopoint geopoint --> boolean))
     119;
    110120(define (geopoint-right? gp1 gp2)
    111121  (>=
     
    116126
    117127(: geopoint= (geopoint geopoint --> boolean))
     128;
    118129(define (geopoint= gp1 gp2)
    119130  (check-geopoint 'geopoint= gp1)
     
    124135
    125136(: geopoint< (geopoint geopoint --> boolean))
     137;
    126138(define (geopoint< gp1 gp2)
    127139  (check-geopoint 'geopoint< gp1)
     
    132144
    133145(: geopoint> (geopoint geopoint --> boolean))
     146;
    134147(define (geopoint> gp1 gp2)
    135148  (check-geopoint 'geopoint> gp1)
     
    140153
    141154(: geopoint<= (geopoint geopoint --> boolean))
     155;
    142156(define (geopoint<= gp1 gp2)
    143157  (check-geopoint 'geopoint<= gp1)
     
    148162
    149163(: geopoint>= (geopoint geopoint --> boolean))
     164;
    150165(define (geopoint>= gp1 gp2)
    151166  (check-geopoint 'geopoint>= gp1)
  • release/4/geo-utils/trunk/geopolygon.scm

    r35004 r35762  
    5252
    5353(: geopolygon? (* --> boolean))
     54;
    5455(define (geopolygon? obj)
    5556  (and
     
    6061
    6162(: geopolygon (#!rest --> geopolygon))
     63;
    6264(define (geopolygon . gps)
    6365  (make-geopolygon gps) )
     
    6567; explicitly closed means [0] = [n-1]
    6668(: geopolygon-closed? (geopolygon --> boolean))
     69;
    6770(define (geopolygon-closed? gpoly)
    6871        (let* (
    69           (gpoly (ensure-vector gpoly) )
    70     (len (vector-length gpoly) ) )
     72          (gpoly (ensure-vector gpoly))
     73    (len (vector-length gpoly)) )
    7174    ;
    7275          (and
     
    7679; explicitly open means [0] != [n-1]
    7780(: geopolygon-open? (geopolygon --> boolean))
     81;
    7882(define (geopolygon-open? gpoly)
    7983        (not (geopolygon-closed? gpoly)) )
     
    8286
    8387(: geopolygon-bounding-box (geopolygon --> (struct geobox)))
     88;
    8489(define (geopolygon-bounding-box gpoly)
    8590        (let* (
    86           (gpoly (ensure-vector gpoly) )
    87     (len (vector-length (check-geopolygon 'geopolygon-bounding-box gpoly)) ) )
    88     ;
    89     (let loop (
    90       (i 0)
    91       (minLat 90.0) (maxLat -90.0)
    92       (minLon 180.0) (maxLon -180.0) )
     91          (gpoly (ensure-vector gpoly))
     92    (len (vector-length (check-geopolygon 'geopolygon-bounding-box gpoly))) )
     93    (let loop ((i 0) (minLat 90.0) (maxLat -90.0) (minLon 180.0) (maxLon -180.0))
    9394      ;traced polygon?
    9495      (if (fx= i len)
     
    9899        (let* (
    99100          (pnt (vector-ref gpoly i))
    100           (lat (geopoint-latitude pnt) )
    101           (lon (geopoint-longitude pnt) ) )
    102           ;
    103           (loop
    104             (fx+ i 1)
    105             (min lat minLat) (max lat maxLat)
    106             (min lon minLon) (max lon maxLon)) ) ) ) ) )
     101          (lat (geopoint-latitude pnt))
     102          (lon (geopoint-longitude pnt)) )
     103          (loop (fx+ i 1) (min lat minLat) (max lat maxLat) (min lon minLon) (max lon maxLon)) ) ) ) ) )
    107104
    108105) ;geopolygon
Note: See TracChangeset for help on using the changeset viewer.