;;;; geopoint.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, May '17

(module geopoint

(;export
  ;
  make-geopoint
  geopoint? check-geopoint error-geopoint
  geopoint-latitude geopoint-longitude
  ;
  geopoint-strictly-above? geopoint-above? geopoint-strictly-below? geopoint-below?
  geopoint-strictly-left? geopoint-left? geopoint-strictly-right? geopoint-right?
  ;
  geopoint~=
  geopoint= geopoint< geopoint> geopoint<= geopoint>=)

(import scheme
  (srfi 9)
  (chicken base)
  (chicken type)
  (chicken flonum)
  (chicken format)
  (only type-checks-basic define-check+error-type)
  (only (type-checks-numbers scheme) check-real))

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

(: *make-geopoint (real real --> geopoint))
(: geopoint? (* -> boolean : geopoint))
(: *geopoint-latitude (geopoint --> real))
(: *geopoint-longitude (geopoint --> real))

(: make-geopoint (real real --> geopoint))
(: geopoint-latitude (geopoint --> real))
(: geopoint-longitude (geopoint --> real))

(: geopoint-strictly-above? (geopoint geopoint --> boolean))
(: geopoint-above? (geopoint geopoint --> boolean))
(: geopoint-strictly-below? (geopoint geopoint --> boolean))
(: geopoint-below? (geopoint geopoint --> boolean))
(: geopoint-strictly-left? (geopoint geopoint --> boolean))
(: geopoint-left? (geopoint geopoint --> boolean))
(: geopoint-strictly-right? (geopoint geopoint --> boolean))
(: geopoint-right? (geopoint geopoint --> boolean))

(: geopoint~= (geopoint geopoint #!optional real --> boolean))

(: geopoint= (geopoint geopoint --> boolean))
(: geopoint< (geopoint geopoint --> boolean))
(: geopoint> (geopoint geopoint --> boolean))
(: geopoint<= (geopoint geopoint --> boolean))
(: geopoint>= (geopoint geopoint --> boolean))

;;; FP Utils

(define (fp~= x y #!optional (eps flonum-epsilon))
  (fp<= (fpabs (fp- x y)) eps) )

;;

(include "geo-constants")

;;

(define-record-type geopoint
  (*make-geopoint lat lon)
  geopoint?
  (lat *geopoint-latitude)
  (lon *geopoint-longitude) )

#; ;NOTE SRFI-10 is problematic w/ R6/R7
(define (print-geopoint/srfi-10 gp out)
  (format out "#,(geopoint ~A ~A)"
              (*geopoint-longitude gp) (*geopoint-latitude gp)) )

(define (print-geopoint/unrec gp out)
  (format out "#<geopoint ~A ~A>"
              (*geopoint-longitude gp) (*geopoint-latitude gp)) )

(define-record-printer (geopoint gp out) (print-geopoint/unrec gp out))

;;

(define (make-geopoint lat lon)
  (*make-geopoint
    (check-real 'make-geopoint lat 'lat)
    (check-real 'make-geopoint lon 'lon)) )

(define-check+error-type geopoint)

(define (geopoint-latitude gp)
  (*geopoint-latitude (check-geopoint 'geopoint-latitude gp)) )

(define (geopoint-longitude gp)
  (*geopoint-longitude (check-geopoint 'geopoint-longitude gp)) )

;;

(define (geopoint-strictly-above? gp1 gp2)
  (<  (*geopoint-latitude (check-geopoint 'geopoint-strictly-above gp1))
      (*geopoint-latitude (check-geopoint 'geopoint-strictly-above gp2))) )

(define (geopoint-above? gp1 gp2)
  (<= (*geopoint-latitude (check-geopoint 'geopoint-above gp1))
      (*geopoint-latitude (check-geopoint 'geopoint-above gp2))) )

(define (geopoint-strictly-below? gp1 gp2)
  (>  (*geopoint-latitude (check-geopoint 'geopoint-strictly-below gp1))
      (*geopoint-latitude (check-geopoint 'geopoint-strictly-below gp2))) )

(define (geopoint-below? gp1 gp2)
  (>= (*geopoint-latitude (check-geopoint 'geopoint-below gp1))
      (*geopoint-latitude (check-geopoint 'geopoint-below gp2))) )

(define (geopoint-strictly-left? gp1 gp2)
  (<  (*geopoint-longitude (check-geopoint 'geopoint-strictly-left gp1))
      (*geopoint-longitude (check-geopoint 'geopoint-strictly-left gp2))) )

(define (geopoint-left? gp1 gp2)
  (<= (*geopoint-longitude (check-geopoint 'geopoint-left gp1))
      (*geopoint-longitude (check-geopoint 'geopoint-left gp2))) )

(define (geopoint-strictly-right? gp1 gp2)
  (>  (*geopoint-longitude (check-geopoint 'geopoint-strictly-right gp1))
      (*geopoint-longitude (check-geopoint 'geopoint-strictly-right gp2))) )

(define (geopoint-right? gp1 gp2)
  (>= (*geopoint-longitude (check-geopoint 'geopoint-right gp1))
      (*geopoint-longitude (check-geopoint 'geopoint-right gp2))) )

;;

(define (~= x y eps)
  (cond ((and (flonum? x) (flonum? y)) (fp~= x y eps))
        (else
          (let ((diff (- x y)))
            (or (zero? diff)
                (<= (abs diff) eps)))) ) )

(define (geopoint~= gp1 gp2 #!optional (eps flonum-epsilon))
  (check-geopoint 'geopoint~= gp1)
  (check-geopoint 'geopoint~= gp2)
  (and (~= (*geopoint-latitude gp1) (*geopoint-latitude gp2) eps)
       (~= (*geopoint-longitude gp1) (*geopoint-longitude gp2) eps)) )

(define (geopoint= gp1 gp2)
  (check-geopoint 'geopoint= gp1)
  (check-geopoint 'geopoint= gp2)
  (and (= (*geopoint-latitude gp1) (*geopoint-latitude gp2))
       (= (*geopoint-longitude gp1) (*geopoint-longitude gp2))) )

(define (geopoint< gp1 gp2)
  (check-geopoint 'geopoint< gp1)
  (check-geopoint 'geopoint< gp2)
  (and (< (*geopoint-latitude gp1) (*geopoint-latitude gp2))
       (< (*geopoint-longitude gp1) (*geopoint-longitude gp2))) )

(define (geopoint> gp1 gp2)
  (check-geopoint 'geopoint> gp1)
  (check-geopoint 'geopoint> gp2)
  (and (> (*geopoint-latitude gp1) (*geopoint-latitude gp2))
       (> (*geopoint-longitude gp1) (*geopoint-longitude gp2))) )

(define (geopoint<= gp1 gp2)
  (check-geopoint 'geopoint<= gp1)
  (check-geopoint 'geopoint<= gp2)
  (and (<= (*geopoint-latitude gp1) (*geopoint-latitude gp2))
       (<= (*geopoint-longitude gp1) (*geopoint-longitude gp2))) )

(define (geopoint>= gp1 gp2)
  (check-geopoint 'geopoint>= gp1)
  (check-geopoint 'geopoint>= gp2)
  (and (>= (*geopoint-latitude gp1) (*geopoint-latitude gp2))
       (>= (*geopoint-longitude gp1) (*geopoint-longitude gp2))) )

) ;geopoint