Changeset 40420 in project


Ignore:
Timestamp:
09/03/21 23:06:46 (3 weeks ago)
Author:
Kon Lovett
Message:

float -> real, use exact, reflow, ensure inexact result when testing float, use test gloss, new test runner

Location:
release/5/geo-utils/trunk
Files:
11 edited

Legend:

Unmodified
Added
Removed
  • release/5/geo-utils/trunk/geo-constants.scm

    r35995 r40420  
    33
    44;1.0/298.257223563 (WGS '84)
    5 (define-constant EARTH-FLATTENING 0.00335281066474748)
     5(define-constant EARTH-FLATTENING (inexact->exact 0.00335281066474748))
    66
    7 (define-constant EARTH-RADIUS-MILES 3963.188)
    8 (define-constant EARTH-RADIUS-KILOMETERS 6378.137)
     7(define-constant EARTH-RADIUS-MILES       (inexact->exact 3963.188))
     8(define-constant EARTH-RADIUS-KILOMETERS  (inexact->exact 6378.137))
  • release/5/geo-utils/trunk/geo-dms.scm

    r38967 r40420  
    2121  set-compass-rose!)
    2222
    23 (import scheme)
    24 (import (chicken base))
    25 (import (chicken irregex))
    26 (import (chicken type))
    27 (import (chicken fixnum))
    28 (import (chicken flonum))
    29 (import (only mathh modf))
    30 (import type-checks)
    31 (import type-errors)
    32 (import geopoint)
    33 
    34 ;;
     23(import scheme
     24  (chicken base)
     25  (chicken irregex)
     26  (chicken type)
     27  (chicken fixnum)
     28  (chicken flonum)
     29  (only mathh modf)
     30  type-checks
     31  type-errors
     32  geopoint)
     33
     34;;
     35
     36(define-type real (or integer ratnum float))
    3537
    3638(define-type dms-glyphs (list string string string))
     
    4042(: string-dms->degree (string #!optional boolean --> number))
    4143(: string->degree (string #!optional boolean --> number))
    42 (: degree->string (float #!optional boolean boolean string --> string))
    43 (: dms->degree (fixnum fixnum fixnum --> float))
    44 (: degree->dms ((or float fixnum) --> fixnum fixnum fixnum))
     44(: degree->string (real #!optional boolean boolean string --> string))
     45(: dms->degree (fixnum fixnum fixnum --> real))
     46(: degree->dms (real --> fixnum fixnum fixnum))
    4547(: dms->string* (number number number #!optional string --> string))
    4648(: set-compass-rose! (vector -> void))
     
    5052
    5153(define (degree-latitude? d)
    52   (and (<= -90.0 d) (<= d 90.0)) )
     54  (and (<= -90 d) (<= d 90)) )
    5355
    5456(define (degree-longitude? d)
    55   (and (<= -180.0 d) (<= d 180.0)) )
     57  (and (<= -180 d) (<= d 180)) )
    5658
    5759(define (degree? d #!optional lat?)
     
    145147    ;construct DMS N/S/E/W
    146148    (let* (
    147       (neg? (< d 0))
    148       (d (if neg? (fxneg d) d))
     149      (neg? (negative? d))
     150      (d (if neg? (- d) d))
    149151      (str (dms->string* d m s pad))
    150152      (dir  (if lat? (if neg? "S" "N") (if neg? "W" "E")) ) )
     
    193195(define (dms->degree d m s)
    194196  (let* (
    195     (neg? (< d 0))
    196     (d (if neg? (fxneg d) d))
    197     (deg
    198       (+
    199         (exact->inexact d)
    200         (+
    201           (/ (exact->inexact m) 60.0)
    202           (/ (exact->inexact s) 3600.0)))) )
    203     (if neg? (fpneg deg) deg) ) )
     197    (neg? (negative? d))
     198    (d    (if neg? (- d) d))
     199    (deg  (+ d (+ (/ m 60) (/ s 3600)))) )
     200    (if neg? (- deg) deg) ) )
    204201
    205202; flonum -> fixnum fixnum fixnum
    206203;
    207204(define (degree->dms deg)
    208   (let* (
    209     (deg (exact->inexact deg))
    210     (neg? (< deg 0.0)) )
     205  (let (
     206    (neg? (negative? deg)) )
    211207    ;
    212208    (let*-values (
    213209      ((sint sflt) (modf (abs deg)))
    214       ((dint dflt) (modf (* sflt 60.0)))
    215       ((mint mflt) (modf (* dflt 60.0))) )
     210      ((dint dflt) (modf (* sflt 60)))
     211      ((mint mflt) (modf (* dflt 60))) )
    216212      ;
    217213      (let (
    218214        (ideg (inexact->exact dint))
    219         (isec (inexact->exact (round (+ sint (* mflt 60.0)))))
     215        (isec (inexact->exact (round (+ sint (* mflt 60)))))
    220216        (imin (inexact->exact mint)) )
    221217        ;
    222         (values (if neg? (fxneg ideg) ideg) imin isec) ) ) ) )
     218        (values (if neg? (- ideg) ideg) imin isec) ) ) ) )
    223219
    224220(define (dms->string* d m s #!optional (pad ""))
     
    257253  ;
    258254  (define (compass-rose-slice deg)
    259     (inexact->exact (floor (/ (+ (exact->inexact deg) +rose-slice/2+) +rose-slice+))) )
     255    (inexact->exact (floor (/ (+ deg +rose-slice/2+) +rose-slice+))) )
    260256  ;
    261257  (set! set-compass-rose! (lambda (vec)
    262258    (set! +rose+ (check-vector 'set-compass-rose! vec))
    263259    (set! +rose-count+ (vector-length +rose+))
    264     (set! +rose-slice+ (/ 360.0 (exact->inexact +rose-count+)))
    265     (set! +rose-slice/2+ (/ +rose-slice+ 2.0)) ) )
     260    (set! +rose-slice+ (/ 360 +rose-count+))
     261    (set! +rose-slice/2+ (/ +rose-slice+ 2)) ) )
    266262  ;
    267263  (set! degree->compass-rose (lambda (deg)
  • release/5/geo-utils/trunk/geo-earth.scm

    r38475 r40420  
    1212  make-earth)
    1313
    14 (import scheme)
    15 (import (chicken base))
    16 (import (chicken type))
    17 (import geo-globe)
     14(import scheme
     15  (chicken base)
     16  (chicken type)
     17  geo-globe)
    1818
    1919(include "geo-constants")
     
    3232(define-type globe (struct globe))
    3333
     34(: make-earth (--> globe))
     35
    3436;;
    3537
    36 (: make-earth (--> globe))
    37 ;
    38 (define (make-earth)
    39   (make-globe EARTH-RADIUS-KILOMETERS EARTH-FLATTENING) )
     38(define (make-earth) (make-globe EARTH-RADIUS-KILOMETERS EARTH-FLATTENING))
    4039
    4140) ;module geo-earth
  • release/5/geo-utils/trunk/geo-globe.scm

    r38967 r40420  
    2020  great-circle-position)
    2121
    22 (import scheme)
    23 (import (chicken base))
    24 (import (chicken type))
    25 (import type-checks)
    26 (import geopoint)
    27 (import (prefix geo-utils utility-))
     22(import scheme
     23  (chicken base)
     24  (chicken type)
     25  type-checks
     26  geopoint
     27  (prefix geo-utils utility-))
    2828
    2929;;
     30
     31(define-type real (or integer ratnum float))
    3032
    3133(define-type geopoint (struct geopoint))
     
    3335(define-type globe (struct globe))
    3436
    35 (: *make-globe (number number --> globe))
     37(: *make-globe (real real --> globe))
    3638(: globe? (* -> boolean : globe))
    37 (: *globe-radius-kilometers (globe --> number))
    38 (: *globe-flattening-factor (globe --> number))
    39 (: make-globe (number number --> globe))
    40 (: globe-radius-kilometers (globe --> number))
    41 (: globe-flattening-factor (globe --> number))
    42 (: spherical-surface-distance (globe geopoint geopoint --> number))
    43 (: approximate-ellipsoid-distance (globe geopoint geopoint --> number))
    44 (: great-circle-distance (globe geopoint geopoint --> number))
    45 (: great-circle-distance-radians (globe geopoint geopoint --> number))
    46 (: great-circle-azimuth (geopoint geopoint #!rest (list (or fixnum float)) --> number))
    47 (: great-circle-position (globe geopoint number number --> geopoint))
     39(: *globe-radius-kilometers (globe --> real))
     40(: *globe-flattening-factor (globe --> real))
     41(: make-globe (real real --> globe))
     42(: globe-radius-kilometers (globe --> real))
     43(: globe-flattening-factor (globe --> real))
     44(: spherical-surface-distance (globe geopoint geopoint --> real))
     45(: approximate-ellipsoid-distance (globe geopoint geopoint --> real))
     46(: great-circle-distance (globe geopoint geopoint --> real))
     47(: great-circle-distance-radians (globe geopoint geopoint --> real))
     48(: great-circle-azimuth (geopoint geopoint #!rest (list real) --> real))
     49(: great-circle-position (globe geopoint real real --> geopoint))
    4850
    4951;;
  • release/5/geo-utils/trunk/geo-utils.egg

    r39900 r40420  
    33
    44((synopsis "Geographic Utilities")
    5  (version "1.0.3")
     5 (version "1.0.4")
    66 (category math)
    77 (author "Kon Lovett")
  • release/5/geo-utils/trunk/geo-utils.scm

    r38967 r40420  
    1818  great-circle-position)
    1919
    20 (import scheme)
    21 (import (chicken base))
    22 (import (chicken type))
    23 (import (chicken flonum))
    24 ;g-utils
    25 (import geopoint)
    26 
    27 ;;
     20(import scheme
     21  (chicken base)
     22  (chicken type)
     23  (chicken flonum)
     24  geopoint)
     25
     26;;
     27
     28(define-type real (or integer ratnum float))
    2829
    2930(: pythagorean-distance (number number number number --> number))
    3031(: pythagorean-distance* (number number number number --> number))
    31 (: spherical-surface-distance (float float float float #!optional float --> float))
    32 (: great-circle-distance (float float float float #!optional float --> float))
    33 (: great-circle-distance-radians (float float float float #!optional float --> float))
    34 (: straight-line-distance (float float float float float float #!optional float --> float))
    35 (: approximate-ellipsoid-distance (float float float float #!optional float float --> float))
    36 (: great-circle-azimuth (float float float float #!optional (or fixnum float) --> float))
    37 (: great-circle-position (float float float float #!optional float --> float float))
     32
     33(: spherical-surface-distance (real real real real #!optional real --> real))
     34(: great-circle-distance (real real real real #!optional real --> real))
     35(: great-circle-distance-radians (real real real real #!optional real --> real))
     36(: straight-line-distance (real real real real real real #!optional real --> real))
     37(: approximate-ellipsoid-distance (real real real real #!optional real real --> real))
     38(: great-circle-azimuth (real real real real #!optional real --> real))
     39(: great-circle-position (real real real real #!optional real --> real real))
    3840
    3941;;(fp-tils)
    4042
    41 (: sqr (float --> float))
    42 (: degree->radian (float --> float))
    43 (: radian->degree (float --> float))
    44 (: precision-factor ((or float fixnum) #!optional float --> float))
     43(: sqr (number --> number))
     44(: precision-factor (fixnum #!optional fixnum --> integer))
     45
     46(: degree->radian (real --> float))
     47(: radian->degree (real --> float))
    4548
    4649(define (sqr n) (* n n))
    47 
    48 (define-constant DEGREE 0.0174532925199432957692369076848861271344) ;pi/180
    49 
    50 (define (degree->radian deg) (* deg DEGREE))
    51 (define (radian->degree rad) (/ rad DEGREE))
    52 
    53 (define (precision-factor p #!optional (base 10.0)) (expt base (exact->inexact p)))
     50(define (precision-factor p #!optional (base 10)) (expt base p))
     51
     52(define-constant DEG/RAD 0.0174532925199432957692369076848861271344) ;pi/180
     53
     54(define (degree->radian deg) (* deg DEG/RAD))
     55(define (radian->degree rad) (/ rad DEG/RAD))
     56
    5457
    5558;;
     
    5861
    5962;;
     63
     64(define (pythagorean-distance* lat1 lon1 lat2 lon2)
     65  (+ (sqr (- lat1 lat2)) (sqr (- lon1 lon2))) )
    6066
    6167(define (pythagorean-distance lat1 lon1 lat2 lon2)
    6268  (sqrt (pythagorean-distance* lat1 lon1 lat2 lon2)) )
    63 
    64 (define (pythagorean-distance* lat1 lon1 lat2 lon2)
    65   (let (
    66     (a (- lat1 lat2))
    67     (b (- lon1 lon2)) )
    68     (+ (* a a) (* b b)) ) )
    6969
    7070;;
     
    8080      (a
    8181        (+
    82           (sqr (sin (/ dlon 2.0)))
     82          (sqr (sin (/ dlon 2)))
    8383          (*
    8484            (* (cos lat1) (cos lat2))
    85             (sqr (sin (/ dlat 2.0))))))
     85            (sqr (sin (/ dlat 2))))))
    8686      (c
    87         (* 2.0 (asin (min 1.0 (sqrt a))))) )
     87        (* 2 (asin (min 1 (sqrt a))))) )
    8888      (* c R) ) ) )
    8989
     
    134134    (lon2 (degree->radian lon2)) )
    135135    (let (
    136       (f (/ (+ lat1 lat2) 2.0))
    137       (g (/ (- lat1 lat2) 2.0))
    138       (l (/ (- lon1 lon2) 2.0)) )
     136      (f (/ (+ lat1 lat2) 2))
     137      (g (/ (- lat1 lat2) 2))
     138      (l (/ (- lon1 lon2) 2)) )
    139139      (let (
    140140        (sing (sin g))
     
    150150          (sinf2 (sqr sinf)) )
    151151          (let* (
    152             (s
    153               (+
    154                 (* sing2 (sqr cosl))
    155                 (* cosf2 (sqr sinl))))
    156             (c
    157               (+
    158                 (* cosg2 (sqr cosl))
    159                 (* sinf2 (sqr sinl))))
    160             (w
    161               (fpatan2 (sqrt s) (sqrt c)))
    162             (r
    163               (sqrt (/ (* s c) w)))
    164             (h1
    165               (/ (* 3.0 (- r 1.0)) (* 2.0 c)))
    166             (h2
    167               (/ (* 3.0 (+ r 1.0)) (* 2.0 s)))
    168             (d
    169               (* 2.0 (* w R))) )
    170             (*
    171               d
    172               (+
    173                 1.0
    174                 (-
    175                   (*
    176                     (* h1 F)
    177                     (* sinf2 cosg2))
    178                   (*
    179                     (* h2 F)
    180                     (* cosf2 sing2))))) ) ) ) ) ) )
     152            (s  (+ (* sing2 (sqr cosl)) (* cosf2 (sqr sinl))))
     153            (c  (+ (* cosg2 (sqr cosl)) (* sinf2 (sqr sinl))))
     154            (w  (fpatan2 (sqrt s) (sqrt c)))
     155            (r  (sqrt (/ (* s c) w)))
     156            (h1 (/ (* 3 (- r 1)) (* 2 c)))
     157            (h2 (/ (* 3 (+ r 1)) (* 2 s)))
     158            (d  (* 2 (* w R))) )
     159            (*  d
     160                (+  1
     161                    (-  (* (* h1 F) (* sinf2 cosg2))
     162                        (* (* h2 F) (* cosf2 sing2))))) ) ) ) ) ) )
    181163
    182164;;
     
    184166(define (great-circle-azimuth lat1 lon1 lat2 lon2 #!optional (prec 5))
    185167  ;
    186   (define precfact
    187     (* 360.0 (precision-factor prec)) )
    188   ;
    189   (define (clamp n)
    190     (inexact->exact (round (* n precfact))) )
     168  (define precfact (* 360 (precision-factor prec)))
     169  ;
     170  (define (clamp n) (inexact->exact (round (* n precfact))))
    191171  ;
    192172  (let (
     
    199179        ; going up?
    200180        (if (> ilat1 ilat2)
    201           180.0
     181          180
    202182          ; going down or nowhere
    203           0.0 ) )
     183          0 ) )
    204184      (else
    205185        (let (
     
    209189          (lon2 (degree->radian lon2)) )
    210190          (let* (
    211             (c
    212               (great-circle-distance-radians lat1 lon1 lat2 lon2))
    213             (a
    214               (asin
    215                 (/
    216                   (* (cos lat2) (sin (- lon2 lon1)))
    217                   (sin c))))
    218             (r
    219               (radian->degree a)) )
     191            (c  (great-circle-distance-radians lat1 lon1 lat2 lon2))
     192            (a  (asin (/  (* (cos lat2) (sin (- lon2 lon1)))
     193                          (sin c))))
     194            (r  (radian->degree a)) )
    220195            (cond
    221196              ((> ilat2 ilat1)
     
    225200                    r )
    226201                  ((< ilon2 ilon1)
    227                     (+ r 360.0) )
     202                    (+ r 360) )
    228203                  (else
    229204                    r ) ) )
     
    231206                (cond
    232207                  ((< ilon2 ilon1)
    233                     (- 180.0 r) )
     208                    (- 180 r) )
    234209                  ((> ilon2 ilon1)
    235                     (- 180.0 r) )
     210                    (- 180 r) )
    236211                  (else
    237212                    r ) ) )
     
    243218(define (great-circle-position lat lon dis azi #!optional (R EARTH-RADIUS-KILOMETERS))
    244219  (let (
    245     (dlat (degree->radian (- 90.0 lat)))
     220    (dlat (degree->radian (- 90 lat)))
    246221    (lat (degree->radian lat))
    247222    (lon (degree->radian lon))
    248223    (azi (degree->radian azi)) )
    249224    (let* (
    250       (b
    251         (/ dis R))
    252       (sinb
    253         (sin b))
    254       (a
    255         (acos
    256           (+
    257             (* (cos b) (cos dlat))
    258             (* sinb (* (sin dlat) (cos azi))))))
    259       (b
    260         (asin (/ (* sinb (sin azi)) (sin a)))) )
     225      (b  (/ dis R))
     226      (sinb (sin b))
     227      (a  (acos (+  (* (cos b) (cos dlat))
     228                    (* sinb (* (sin dlat) (cos azi))))))
     229      (b  (asin (/ (* sinb (sin azi)) (sin a)))) )
    261230      ;
    262       (values (- 90.0 (radian->degree a)) (radian->degree (+ b lon))) ) ) )
     231      (values (- 90 (radian->degree a)) (radian->degree (+ b lon))) ) ) )
    263232
    264233) ;geo-utils
  • release/5/geo-utils/trunk/geobox.scm

    r38967 r40420  
    1212  geopoint-within-box? )
    1313
    14 (import scheme)
    15 (import (chicken base))
    16 (import (chicken type))
    17 (import type-checks)
    18 (import geopoint)
     14(import scheme
     15  (chicken base)
     16  (chicken type)
     17  type-checks
     18  geopoint)
    1919
    2020;;;
     
    8484  (check-geobox 'geobox= gb1)
    8585  (check-geobox 'geobox= gb2)
    86   (and
    87     (geopoint= (*geobox-minimum gb1) (*geobox-minimum gb2))
    88     (geopoint= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
     86  (and  (geopoint= (*geobox-minimum gb1) (*geobox-minimum gb2))
     87        (geopoint= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
    8988
    9089(define (geobox< gb1 gb2)
    9190  (check-geobox 'geobox< gb1)
    9291  (check-geobox 'geobox< gb2)
    93   (and
    94     (geopoint< (*geobox-minimum gb1) (*geobox-minimum gb2))
    95     (geopoint< (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
     92  (and  (geopoint< (*geobox-minimum gb1) (*geobox-minimum gb2))
     93        (geopoint< (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
    9694
    9795(define (geobox> gb1 gb2)
    9896  (check-geobox 'geobox> gb1)
    9997  (check-geobox 'geobox> gb2)
    100   (and
    101     (geopoint> (*geobox-minimum gb1) (*geobox-minimum gb2))
    102     (geopoint> (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
     98  (and  (geopoint> (*geobox-minimum gb1) (*geobox-minimum gb2))
     99        (geopoint> (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
    103100
    104101(define (geobox<= gb1 gb2)
    105102  (check-geobox 'geobox<= gb1)
    106103  (check-geobox 'geobox<= gb2)
    107   (and
    108     (geopoint<= (*geobox-minimum gb1) (*geobox-minimum gb2))
    109     (geopoint<= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
     104  (and  (geopoint<= (*geobox-minimum gb1) (*geobox-minimum gb2))
     105        (geopoint<= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
    110106
    111107(define (geobox>= gb1 gb2)
    112108  (check-geobox 'geobox>= gb1)
    113109  (check-geobox 'geobox>= gb2)
    114   (and
    115     (geopoint>= (*geobox-minimum gb1) (*geobox-minimum gb2))
    116     (geopoint>= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
     110  (and  (geopoint>= (*geobox-minimum gb1) (*geobox-minimum gb2))
     111        (geopoint>= (*geobox-maximum gb1) (*geobox-maximum gb2)) ) )
    117112
    118113(define (geopoint-within-box? gp gb)
    119   (and
    120     (geopoint<= (*geobox-minimum gb) gp)
    121     (geopoint>= (*geobox-maximum gb) gp) ) )
     114  (and  (geopoint<= (*geobox-minimum gb) gp)
     115        (geopoint>= (*geobox-maximum gb) gp) ) )
    122116
    123117) ;geobox
  • release/5/geo-utils/trunk/geopoint.scm

    r38967 r40420  
    1616  geopoint= geopoint< geopoint> geopoint<= geopoint>=)
    1717
    18 (import scheme)
    19 (import (srfi 9))
    20 (import (chicken base))
    21 (import (chicken type))
    22 (import type-checks)
     18(import scheme
     19  (srfi 9)
     20  (chicken base)
     21  (chicken type)
     22  type-checks)
    2323
    2424(include "geo-constants")
     
    8080
    8181(define (geopoint-strictly-above? gp1 gp2)
    82   (<
    83     (*geopoint-latitude (check-geopoint 'geopoint-strictly-above gp1))
    84     (*geopoint-latitude (check-geopoint 'geopoint-strictly-above gp2))) )
     82  (<  (*geopoint-latitude (check-geopoint 'geopoint-strictly-above gp1))
     83      (*geopoint-latitude (check-geopoint 'geopoint-strictly-above gp2))) )
    8584
    8685(define (geopoint-above? gp1 gp2)
    87   (<=
    88     (*geopoint-latitude (check-geopoint 'geopoint-above gp1))
    89     (*geopoint-latitude (check-geopoint 'geopoint-above gp2))) )
     86  (<= (*geopoint-latitude (check-geopoint 'geopoint-above gp1))
     87      (*geopoint-latitude (check-geopoint 'geopoint-above gp2))) )
    9088
    9189(define (geopoint-strictly-below? gp1 gp2)
    92   (>
    93     (*geopoint-latitude (check-geopoint 'geopoint-strictly-below gp1))
    94     (*geopoint-latitude (check-geopoint 'geopoint-strictly-below gp2))) )
     90  (>  (*geopoint-latitude (check-geopoint 'geopoint-strictly-below gp1))
     91      (*geopoint-latitude (check-geopoint 'geopoint-strictly-below gp2))) )
    9592
    9693(define (geopoint-below? gp1 gp2)
    97   (>=
    98     (*geopoint-latitude (check-geopoint 'geopoint-below gp1))
    99     (*geopoint-latitude (check-geopoint 'geopoint-below gp2))) )
     94  (>= (*geopoint-latitude (check-geopoint 'geopoint-below gp1))
     95      (*geopoint-latitude (check-geopoint 'geopoint-below gp2))) )
    10096
    10197(define (geopoint-strictly-left? gp1 gp2)
    102   (<
    103     (*geopoint-longitude (check-geopoint 'geopoint-strictly-left gp1))
    104     (*geopoint-longitude (check-geopoint 'geopoint-strictly-left gp2))) )
     98  (<  (*geopoint-longitude (check-geopoint 'geopoint-strictly-left gp1))
     99      (*geopoint-longitude (check-geopoint 'geopoint-strictly-left gp2))) )
    105100
    106101(define (geopoint-left? gp1 gp2)
    107   (<=
    108     (*geopoint-longitude (check-geopoint 'geopoint-left gp1))
    109     (*geopoint-longitude (check-geopoint 'geopoint-left gp2))) )
     102  (<= (*geopoint-longitude (check-geopoint 'geopoint-left gp1))
     103      (*geopoint-longitude (check-geopoint 'geopoint-left gp2))) )
    110104
    111105(define (geopoint-strictly-right? gp1 gp2)
    112   (>
    113     (*geopoint-longitude (check-geopoint 'geopoint-strictly-right gp1))
    114     (*geopoint-longitude (check-geopoint 'geopoint-strictly-right gp2))) )
     106  (>  (*geopoint-longitude (check-geopoint 'geopoint-strictly-right gp1))
     107      (*geopoint-longitude (check-geopoint 'geopoint-strictly-right gp2))) )
    115108
    116109(define (geopoint-right? gp1 gp2)
    117   (>=
    118     (*geopoint-longitude (check-geopoint 'geopoint-right gp1))
    119     (*geopoint-longitude (check-geopoint 'geopoint-right gp2))) )
     110  (>= (*geopoint-longitude (check-geopoint 'geopoint-right gp1))
     111      (*geopoint-longitude (check-geopoint 'geopoint-right gp2))) )
    120112
    121113;;
     
    124116  (check-geopoint 'geopoint= gp1)
    125117  (check-geopoint 'geopoint= gp2)
    126   (and
    127     (= (*geopoint-latitude gp1) (*geopoint-latitude gp2))
    128     (= (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
     118  (and  (= (*geopoint-latitude gp1) (*geopoint-latitude gp2))
     119        (= (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
    129120
    130121(define (geopoint< gp1 gp2)
    131122  (check-geopoint 'geopoint< gp1)
    132123  (check-geopoint 'geopoint< gp2)
    133   (and
    134     (< (*geopoint-latitude gp1) (*geopoint-latitude gp2))
    135     (< (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
     124  (and  (< (*geopoint-latitude gp1) (*geopoint-latitude gp2))
     125        (< (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
    136126
    137127(define (geopoint> gp1 gp2)
    138128  (check-geopoint 'geopoint> gp1)
    139129  (check-geopoint 'geopoint> gp2)
    140   (and
    141     (> (*geopoint-latitude gp1) (*geopoint-latitude gp2))
    142     (> (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
     130  (and  (> (*geopoint-latitude gp1) (*geopoint-latitude gp2))
     131        (> (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
    143132
    144133(define (geopoint<= gp1 gp2)
    145134  (check-geopoint 'geopoint<= gp1)
    146135  (check-geopoint 'geopoint<= gp2)
    147   (and
    148     (<= (*geopoint-latitude gp1) (*geopoint-latitude gp2))
    149     (<= (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
     136  (and  (<= (*geopoint-latitude gp1) (*geopoint-latitude gp2))
     137        (<= (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
    150138
    151139(define (geopoint>= gp1 gp2)
    152140  (check-geopoint 'geopoint>= gp1)
    153141  (check-geopoint 'geopoint>= gp2)
    154   (and
    155     (>= (*geopoint-latitude gp1) (*geopoint-latitude gp2))
    156     (>= (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
     142  (and  (>= (*geopoint-latitude gp1) (*geopoint-latitude gp2))
     143        (>= (*geopoint-longitude gp1) (*geopoint-longitude gp2)) ) )
    157144
    158145) ;geopoint
  • release/5/geo-utils/trunk/geopolygon.scm

    r38967 r40420  
    1313  geopolygon-bounding-box )
    1414
    15 (import scheme)
    16 (import (chicken base))
    17 (import (chicken type))
    18 (import vector-lib)
    19 (import type-checks)
    20 (import geopoint geobox)
     15(import scheme
     16  (chicken base)
     17  (chicken type)
     18  vector-lib
     19  type-checks
     20  geopoint geobox)
    2121
    2222(include "geo-constants")
     
    4545      (cond
    4646        ((vector? gps)
    47           (and
    48             (vector-every geopoint? gps)
    49             gps ) )
     47          (and (vector-every geopoint? gps) gps) )
    5048        ((list? gps)
    5149          (make-geopolygon (ensure-vector gps)) )
     
    5553      (make-geopolygon rest) ) ) )
    5654
    57 (define (geopolygon? obj)
    58   (and
    59     (vector? obj)
    60     (vector-every geopoint? obj)) )
     55(define (geopolygon? obj) (and (vector? obj) (vector-every geopoint? obj)))
    6156
    6257(define-check+error-type geopolygon)
    6358
    64 (define (geopolygon . gps)
    65   (make-geopolygon gps) )
     59(define (geopolygon . gps) (make-geopolygon gps))
    6660
    6761; explicitly closed means [0] = [n-1]
     
    7266    (len (vector-length gpoly)) )
    7367    ;
    74           (and
    75             (<= 2 len)
    76             (geopoint= (vector-ref gpoly 0) (vector-ref gpoly (- len 1))) ) ) )
     68          (and  (<= 2 len)
     69                (geopoint= (vector-ref gpoly 0) (vector-ref gpoly (- len 1))) ) ) )
    7770
    7871; explicitly open means [0] != [n-1]
    7972;
    80 (define (geopolygon-open? gpoly)
    81         (not (geopolygon-closed? gpoly)) )
     73(define (geopolygon-open? gpoly) (not (geopolygon-closed? gpoly)))
    8274
    8375;;
     
    8779          (gpoly (ensure-vector gpoly))
    8880    (len (vector-length (check-geopolygon 'geopolygon-bounding-box gpoly))) )
    89     (let loop ((i 0) (minLat 90.0) (maxLat -90.0) (minLon 180.0) (maxLon -180.0))
     81    (let loop ((i 0) (minLat 90) (maxLat -90) (minLon 180) (maxLon -180))
    9082      ;traced polygon?
    9183      (if (= i len)
  • release/5/geo-utils/trunk/tests/geo-utils-test.scm

    r36728 r40420  
    44
    55(import test)
     6
     7(import (only (chicken format) format))
     8(include-relative "test-gloss.incl")
    69
    710(test-begin "Geo Utils")
     
    1821;
    1922(define (fp~= x y #!optional (eps flonum-epsilon))
    20   (let (
    21     (diff (fp- x y)) )
    22     (or
    23       ;(fpzero? diff) ;really, how often is this true?
    24       (fp<= (fpabs diff) eps) ) ) )
     23  (let ((diff (fp- x y)))
     24    (or ;(fpzero? diff) ;really, how often is this true?
     25        (fp<= (fpabs diff) eps) ) ) )
    2526
    2627;;;
     
    2829(import geo-utils)
    2930
    30 (define lat1 33.54187)
    31 (define lon1 -117.78392)
     31(define-constant flLAT1 33.54187)
     32(define-constant flLON1 -117.78392)
    3233
    33 (define lat2 33.54444)
    34 (define lon2 -117.78521)
     34(define-constant flLAT2 33.54444)
     35(define-constant flLON2 -117.78521)
    3536
    3637;33.54444 -117.78124 33.54692 -117.78438
     
    3839(test-group "geo-utils"
    3940  (let (
    40     (dis (great-circle-distance lat1 lon1 lat2 lon2) )
    41     (azi (great-circle-azimuth lat1 lon1 lat2 lon2) )
    42     (dea (approximate-ellipsoid-distance lat1 lon1 lat2 lon2) )
    43     (sds (spherical-surface-distance lat1 lon1 lat2 lon2) ) )
     41    (dis (great-circle-distance flLAT1 flLON1 flLAT2 flLON2) )
     42    (azi (great-circle-azimuth flLAT1 flLON1 flLAT2 flLON2) )
     43    (dea (approximate-ellipsoid-distance flLAT1 flLON1 flLAT2 flLON2) )
     44    (sds (spherical-surface-distance flLAT1 flLON1 flLAT2 flLON2) ) )
    4445    ;
    45     (print "great-circle-distance: " dis)
    46     (print "   spherical-distance: " sds)
    47     (print "   ellipsoid-distance: " dea)
    48     (print "              azimuth: " azi)
    49     (receive (lat lon) (great-circle-position lat1 lon1 dis azi)
    50       (print "        geopoint test: " lat ", " lon)
    51       (print "        geopoint base: " lat2 ", " lon2)
    52       (test-assert (fp~= lat2 lat 0.009))
    53       (test-assert (fp~= lon2 lon 0.009)) ) )
     46    (glossf "            GP1 - GP2: ~A, ~A : ~A, ~A" flLAT1 flLON1 flLAT2 flLON2)
     47    (glossf "great-circle-distance: ~A" dis)
     48    (glossf "   spherical-distance: ~A" sds)
     49    (glossf "   ellipsoid-distance: ~A" dea)
     50    (glossf "              azimuth: ~A" azi)
     51    (test 0.310118259985894 dis)
     52    (test 0.278350802526047 sds)
     53    (test 0.308717805933004 dea)
     54    (test 359.996476863012 azi)
     55    (receive (lat lon) (great-circle-position flLAT1 flLON1 dis azi)
     56      (glossf "        geopoint test: ~A, ~A" lat lon)
     57      (glossf "        geopoint base: ~A, ~A" flLAT2 flLON2)
     58      (test-assert (fp~= flLAT2 lat 0.009))
     59      (test-assert (fp~= flLON2 lon 0.009)) ) )
    5460)
    5561
     
    6470  (test "N 10° 20' 30\"" (dms->string 10 20 30 #t #t " "))
    6571
    66   (test -10.3416666666667 (string-dms->degree "W 10° 20' 30\"" #f))
    67   (test -10.3416666666667 (string-dms->degree "10° 20' 30\" W" #f))
    68   (test -10.3416666666667 (string-dms->degree "W10° 20'30\"" #t))
     72  (test -10.3416666666667 (* 1.0 (string-dms->degree "W 10° 20' 30\"" #f)))
     73  (test -10.3416666666667 (* 1.0 (string-dms->degree "10° 20' 30\" W" #f)))
     74  (test -10.3416666666667 (* 1.0 (string-dms->degree "W10° 20'30\"" #t)))
    6975
    7076  (test 'N (degree->compass-rose 10.3416666666667))
     
    7783
    7884(test-group "geopoint"
    79   (test-assert (geopoint? (make-geopoint lat1 lon1)))
     85  (test-assert (geopoint? (make-geopoint flLAT1 flLON1)))
    8086  (let (
    81     (gp1 (make-geopoint lat1 lon1) )
    82     (gp2 (make-geopoint lat2 lon2) ) )
     87    (gp1 (make-geopoint flLAT1 flLON1) )
     88    (gp2 (make-geopoint flLAT2 flLON2) ) )
    8389    ;
    84     (test lat1 (geopoint-latitude gp1))
    85     (test lon1 (geopoint-longitude gp1))
     90    (test flLAT1 (geopoint-latitude gp1))
     91    (test flLON1 (geopoint-longitude gp1))
    8692    ;
    8793    (test-assert (not (geopoint-left? gp1 gp2)))
     
    118124(test-group "geobox"
    119125  (let (
    120     (gp1 (make-geopoint lat1 lon2) )
    121     (gp2 (make-geopoint lat2 lon1) ) )
     126    (gp1 (make-geopoint flLAT1 flLON2) )
     127    (gp2 (make-geopoint flLAT2 flLON1) ) )
    122128    ;
    123129    (test-assert (geobox? (make-geobox gp1 gp2)))
     
    139145(test-group "geo-globe"
    140146  (let (
    141     (dis (great-circle-distance lat1 lon1 lat2 lon2) )
    142     (azi (great-circle-azimuth lat1 lon1 lat2 lon2) )
     147    (dis (great-circle-distance flLAT1 flLON1 flLAT2 flLON2) )
     148    (azi (great-circle-azimuth flLAT1 flLON1 flLAT2 flLON2) )
    143149    ;
    144150    (earth (make-earth) )
    145     (gp1 (make-geopoint lat1 lon1) )
    146     (gp2 (make-geopoint lat2 lon2) ) )
     151    (gp1 (make-geopoint flLAT1 flLON1) )
     152    (gp2 (make-geopoint flLAT2 flLON2) ) )
    147153    ;
    148154    (test dis (globe:great-circle-distance earth gp1 gp2))
    149155    (test azi (globe:great-circle-azimuth gp1 gp2))
    150156    (test
    151       (approximate-ellipsoid-distance lat1 lon1 lat2 lon2)
     157      (approximate-ellipsoid-distance flLAT1 flLON1 flLAT2 flLON2)
    152158      (globe:approximate-ellipsoid-distance earth gp1 gp2))
    153159    (test
    154       (spherical-surface-distance lat1 lon1 lat2 lon2)
     160      (spherical-surface-distance flLAT1 flLON1 flLAT2 flLON2)
    155161      (globe:spherical-surface-distance earth gp1 gp2))
    156     (let-values (((ulat ulon) (great-circle-position lat1 lon1 dis azi)))
     162    (let-values (((ulat ulon) (great-circle-position flLAT1 flLON1 dis azi)))
    157163      (let ((pos (globe:great-circle-position earth gp1 dis azi)))
    158164        (test "great-circle-position latitude" ulat (geopoint-latitude pos))
  • release/5/geo-utils/trunk/tests/run.scm

    r39795 r40420  
    77    make-pathname pathname-file pathname-replace-directory pathname-strip-extension)
    88  (only (chicken process) system)
    9   (only (chicken process-context) command-line-arguments)
     9  (only (chicken process-context) command-line-arguments get-environment-variable)
    1010  (only (chicken format) format)
    1111  (only (chicken file) file-exists? find-files)
     
    1313
    1414;; Globals
     15
     16(define *csi* (or (get-environment-variable "CHICKEN_CSI") "csi"))
     17(define *csc* (or (get-environment-variable "CHICKEN_CSC") "csc"))
    1518
    1619(define *csc-init-options* '(
     
    7982
    8083(define (run-test-evaluated source)
    81   (format #t "*** csi ~A ***~%" (pathname-file source))
    82   (system-must (string-append "csi -s " source)) )
     84  (format #t "*** ~A ~A ***~%" *csi* (pathname-file source))
     85  (system-must (string-append *csi* " -s " source)) )
    8386
    8487(define (run-test-compiled source csc-options)
    8588  (let ((optstr (apply string-append (intersperse csc-options " "))))
    86     (format #t "*** csc ~A ~A ***~%" (pathname-file source) optstr)
     89    (format #t "*** ~A ~A ~A ***~%" *csc* (pathname-file source) optstr)
    8790    ;csc output is in current directory
    88     (system-must (string-append "csc" " " optstr " " source)) )
     91    (system-must (string-append *csc* " " optstr " " source)) )
    8992  (system-must (pathname-replace-directory (pathname-strip-extension source) *test-directory*)) )
    9093
Note: See TracChangeset for help on using the changeset viewer.