;;;; 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
  globe-name
  ;
  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)
  (chicken format)
  (only type-checks-basic define-check+error-type)
  (only (type-checks-numbers scheme) check-real) ;uses argument-name argument
  (only (check-errors sys) check-symbol)
  (symbol-utils gen)
  geopoint
  (prefix geopoint-utils gp:))

(include-relative "geo-utils.types")

(: make-globe (real real --> geoglobe))
(: globe? (* -> boolean : geoglobe))
(: globe-radius-kilometers (geoglobe --> real))
(: globe-flattening-factor (geoglobe --> real))
(: globe-name (geoglobe --> symbol))

(: globe-radius-kilometers (geoglobe --> real))
(: globe-flattening-factor (geoglobe --> real))
(: globe-name (geoglobe --> symbol))

(: spherical-surface-distance (geoglobe geopoint geopoint --> real))
(: approximate-ellipsoid-distance (geoglobe geopoint geopoint --> real))
(: great-circle-distance (geoglobe geopoint geopoint --> real))
(: great-circle-distance-radians (geoglobe geopoint geopoint --> real))

(: great-circle-azimuth (geopoint geopoint #!rest (list real) --> real))
(: great-circle-position (geoglobe geopoint real real --> geopoint))

;;

(define-record-type geoglobe
  (make-geoglobe rad flt nam)
  geoglobe?
  (rad geoglobe-radius-kilometers)
  (flt geoglobe-flattening-factor)
  (nam geoglobe-name) )

(define (print-globe/unrec gb out)
  (format out "#<geoglobe ~A ~A ~A>"
              (geoglobe-name gb)
              (geoglobe-radius-kilometers gb) (geoglobe-flattening-factor gb)) )

(define-record-printer (geoglobe gb out) (print-globe/unrec gb out))

(define-check+error-type globe geoglobe?)

(define globe-gensym (make-gensym 'geoglobe))

(define (make-globe rad flt #!optional (nam (globe-gensym)))
  (make-geoglobe
    (check-real 'make-globe rad 'radius)
    (check-real 'make-globe flt 'falttening)
    (check-symbol 'make-globe nam)) )

(define (globe? obj) (geoglobe? obj))

(define (globe-radius-kilometers glob)
  (geoglobe-radius-kilometers (check-globe 'globe-radius-kilometers glob)))

(define (globe-flattening-factor glob)
  (geoglobe-flattening-factor (check-globe 'globe-flattening-factor glob)))

(define (globe-name glob)
  (geoglobe-name (check-globe 'globe-name glob)))

;;

(define (spherical-surface-distance glob gp1 gp2)
  (gp:spherical-surface-distance
    gp1 gp2
    (geoglobe-radius-kilometers (check-globe 'spherical-surface-distance glob 'globe))) )

(define (approximate-ellipsoid-distance glob gp1 gp2)
  (check-globe 'approximate-ellipsoid-distance glob 'globe)
  (gp:approximate-ellipsoid-distance
    gp1 gp2
    (geoglobe-radius-kilometers glob)
    (geoglobe-flattening-factor glob)) )

(define (great-circle-distance glob gp1 gp2)
  (gp:great-circle-distance
    gp1 gp2
    (geoglobe-radius-kilometers (check-globe 'great-circle-distance glob 'globe))) )

(define (great-circle-distance-radians glob gp1 gp2)
  (gp:great-circle-distance-radians
    gp1 gp2
    (geoglobe-radius-kilometers (check-globe 'great-circle-distance-radians glob 'globe))) )

(define (great-circle-azimuth gp1 gp2 . args)
  (let ((prec (optional args 5)))
    (gp:great-circle-azimuth
      gp1 gp2
      (check-real 'great-circle-azimuth prec 'precision)) ) )

(define (great-circle-position glob gp dis azi)
  (apply
    make-geopoint
    (receive
      (gp:great-circle-position
        gp dis azi
        (geoglobe-radius-kilometers (check-globe 'great-circle-distance-radians glob 'globe))))) )

) ;module geo-globe