;;;; geo-globe.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Oct '17

(module geo-globe

(;export
  ;
  make-globe
  globe? check-globe error-globe
  globe-radius-kilometers
  globe-flattening-factor
  ;
  spherical-surface-distance
  great-circle-distance great-circle-distance-radians
  approximate-ellipsoid-distance
  ;
  great-circle-azimuth
  ;
  great-circle-position)

(import scheme
  (chicken base)
  (chicken type)
  type-checks
  geopoint
  (prefix geo-utils utility-))

;;

(define-type geopoint (struct geopoint))

;;

(define-type globe (struct globe))

;FIXME define:-record-type

(: *make-globe (number number --> globe))
(: globe? (* -> boolean : globe))
(: *globe-radius-kilometers (globe --> number))
(: *globe-flattening-factor (globe --> number))
;
(define-record-type globe
  (*make-globe rad flt)
  globe?
  (rad *globe-radius-kilometers)
  (flt *globe-flattening-factor) )

(define-check+error-type globe)

(: make-globe (number number --> globe))
;
(define (make-globe rad flt)
  (*make-globe
    (check-real 'make-globe rad 'radius)
    (check-real 'make-globe flt 'falttening)) )

(: globe-radius-kilometers (globe --> number))
;
(define (globe-radius-kilometers glob)
  (*globe-radius-kilometers (check-globe 'globe-radius-kilometers glob 'globe)))

(: globe-flattening-factor (globe --> number))
;
(define (globe-flattening-factor glob)
  (*globe-flattening-factor (check-globe 'globe-flattening-factor glob 'globe)))

;;

(: spherical-surface-distance (globe geopoint geopoint --> number))
;
(define (spherical-surface-distance glob gp1 gp2)
  (check-geopoint 'spherical-surface-distance gp1)
  (check-geopoint 'spherical-surface-distance gp2)
  (utility-spherical-surface-distance
    (geopoint-latitude gp1) (geopoint-longitude gp1)
    (geopoint-latitude gp2) (geopoint-longitude gp2)
    (*globe-radius-kilometers (check-globe 'spherical-surface-distance glob 'globe))) )

(: approximate-ellipsoid-distance (globe geopoint geopoint --> number))
;
(define (approximate-ellipsoid-distance glob gp1 gp2)
  (check-globe 'approximate-ellipsoid-distance glob 'globe)
  (check-geopoint 'approximate-ellipsoid-distance gp1)
  (check-geopoint 'approximate-ellipsoid-distance gp2)
  (utility-approximate-ellipsoid-distance
    (geopoint-latitude gp1) (geopoint-longitude gp1)
    (geopoint-latitude gp2) (geopoint-longitude gp2)
    (*globe-radius-kilometers glob)
    (*globe-flattening-factor glob)) )

(: great-circle-distance (globe geopoint geopoint --> number))
;
(define (great-circle-distance glob gp1 gp2)
  (check-geopoint 'great-circle-distance gp1)
  (check-geopoint 'great-circle-distance gp2)
  (utility-great-circle-distance
    (geopoint-latitude gp1) (geopoint-longitude gp1)
    (geopoint-latitude gp2) (geopoint-longitude gp2)
    (*globe-radius-kilometers (check-globe 'great-circle-distance glob 'globe))) )

(: great-circle-distance-radians (globe geopoint geopoint --> number))
;
(define (great-circle-distance-radians glob gp1 gp2)
  (check-geopoint 'great-circle-distance-radians gp1)
  (check-geopoint 'great-circle-distance-radians gp2)
  (utility-great-circle-distance-radians
    (geopoint-latitude gp1) (geopoint-longitude gp1)
    (geopoint-latitude gp2) (geopoint-longitude gp2)
    (*globe-radius-kilometers (check-globe 'great-circle-distance-radians glob 'globe))) )

(: great-circle-azimuth (geopoint geopoint #!rest (list (or fixnum float)) --> number))
;
(define (great-circle-azimuth gp1 gp2 . args)
  (check-geopoint 'great-circle-azimuth gp1)
  (check-geopoint 'great-circle-azimuth gp2)
  (let ((prec (optional args 5)))
    (utility-great-circle-azimuth
      (geopoint-latitude gp1) (geopoint-longitude gp1)
      (geopoint-latitude gp2) (geopoint-longitude gp2)
      (check-real 'great-circle-azimuth prec 'precision)) ) )

(: great-circle-position (globe geopoint number number --> geopoint))
;
(define (great-circle-position glob gp dis azi)
  (check-geopoint 'great-circle-position gp)
  (apply
    make-geopoint
    (receive
      (utility-great-circle-position
        (geopoint-latitude gp) (geopoint-longitude gp)
        (check-real 'great-circle-position dis 'distance)
        (check-real 'great-circle-position azi 'azimuth)
        (*globe-radius-kilometers (check-globe 'great-circle-distance-radians glob 'globe))))) )

) ;module geo-globe