;;;; 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>=)

(import scheme
  (srfi 9)
  (chicken base)
  (chicken type)
  type-checks)

(include "geo-constants")

;;;

;;

(define-type geopoint (struct geopoint))

(: *make-geopoint (number number --> geopoint))
(: geopoint? (* --> boolean))
(: *geopoint-latitude (geopoint --> number))
(: *geopoint-longitude (geopoint --> number))
;
(define-record-type geopoint
  (*make-geopoint lat lon)
  geopoint?
  (lat *geopoint-latitude)
  (lon *geopoint-longitude) )

(: make-geopoint (number number --> geopoint))
;
(define (make-geopoint lat lon)
  (*make-geopoint
    (check-real 'make-geopoint lat 'lat)
    (check-real 'make-geopoint lon 'lon)) )

(define-check+error-type geopoint)

(: geopoint-latitude (geopoint --> number))
;
(define (geopoint-latitude gp)
  (*geopoint-latitude (check-geopoint 'geopoint-latitude gp)) )

(: geopoint-longitude (geopoint --> number))
;
(define (geopoint-longitude gp)
  (*geopoint-longitude (check-geopoint 'geopoint-longitude gp)) )

(define-record-printer (geopoint gp out)
  (display "#,(geopoint " out)
  (display (*geopoint-longitude gp) out)
  (display #\space out)
  (display (*geopoint-latitude gp) out)
  (display #\) out) )

;;

(: geopoint-strictly-above? (geopoint geopoint --> boolean))
;
(define (geopoint-strictly-above? gp1 gp2)
  (<
    (*geopoint-latitude (check-geopoint 'geopoint-strictly-above gp1))
    (*geopoint-latitude (check-geopoint 'geopoint-strictly-above gp2))) )

(: geopoint-above? (geopoint geopoint --> boolean))
;
(define (geopoint-above? gp1 gp2)
  (<=
    (*geopoint-latitude (check-geopoint 'geopoint-above gp1))
    (*geopoint-latitude (check-geopoint 'geopoint-above gp2))) )

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

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

(: geopoint-strictly-left? (geopoint geopoint --> boolean))
;
(define (geopoint-strictly-left? gp1 gp2)
  (<
    (*geopoint-longitude (check-geopoint 'geopoint-strictly-left gp1))
    (*geopoint-longitude (check-geopoint 'geopoint-strictly-left gp2))) )

(: geopoint-left? (geopoint geopoint --> boolean))
;
(define (geopoint-left? gp1 gp2)
  (<=
    (*geopoint-longitude (check-geopoint 'geopoint-left gp1))
    (*geopoint-longitude (check-geopoint 'geopoint-left gp2))) )

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

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

;;

(: geopoint= (geopoint geopoint --> boolean))
;
(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< (geopoint geopoint --> boolean))
;
(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> (geopoint geopoint --> boolean))
;
(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<= (geopoint geopoint --> boolean))
;
(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>= (geopoint geopoint --> boolean))
;
(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