;;;; srfi-19-period.scm  -*- Scheme -*-
;;;; Chicken port, Kon Lovett, Apr '07

;;Issues
;;
;; - time-period-null handling is poor.
;;
;; - Use a half-closed interval - [begin end)? Currently [B E]!

(declare (bound-to-procedure ##sys#register-record-printer))

(module srfi-19-period

(;export
  time-period
  ;basic object
  make-time-period
  time-period-copy
  time-period? check-time-period error-time-period
  ;empty period
  make-time-period-null
  time-period-null?
  ;property accessors
  time-period-type
  time-period-begin
  time-period-end
  time-period-last
  time-period-duration
  ;interval algebra basic relations
  time-period-precedes?
  time-period-meets?
  time-period-overlaps?
  time-period-finished-by?
  time-period-contains?
  time-period-starts?
  time-period-equals?
  time-period-started-by?
  time-period-during?
  time-period-finishes?
  time-period-overlapped-by?
  time-period-met-by?
  time-period-preceded-by?
  ;contains utility
  time-period-contains/time?
  time-period-contains/date?
  time-period-within?
  time-period-intersects?
  ;"total" ordering
  time-period=?
  time-period<?
  time-period>?
  time-period<=?
  time-period>=?
  time-period-compare
  ;
  time-period-preceding
  time-period-succeeding
  time-period-intersection
  time-period-union
  time-period-span
  ;
  time-period-shift
  time-period-shift!)

(import scheme
  (chicken base)
  (chicken type)
  (only (chicken format) format)
  (only (chicken read-syntax) define-reader-ctor)
  (only record-variants define-record-type-variant)
  (only type-checks define-check+error-type)
  (only type-errors error-argument-type signal-type-error)
  (only srfi-19-core
    one-nanosecond-duration zero-time default-date-clock-type check-clock-type
    date? check-time error-clock-type check-date time? check-duration)
  srfi-19-tm)

;;;

(include-relative "srfi-19-common")

(include-relative "srfi-19-common.types")

(: make-time-period ((or real date time) (or real date time) #!optional clock-type --> time-period))
(: time-period-copy (time-period --> time-period))
(: time-period? (* -> boolean : time-period))
(: check-time-period (symbol * #!optional (or symbol string keyword) -> time-period))
(: error-time-period (symbol * #!optional (or symbol string keyword) -> void))
(: make-time-period-null (#!optional clock-type --> time-period))
(: time-period-null? (* -> boolean : time-period))

(: time-period-type (time-period --> clock-type ))
(: time-period-begin (time-period --> time))
(: time-period-end (time-period --> time))
(: time-period-last (time-period --> time))
(: time-period-duration (time-period --> time))

(: time-period-precedes? (time-period time-period --> boolean))
(: time-period-meets? (time-period time-period --> boolean))
(: time-period-overlaps? (time-period time-period --> boolean))
(: time-period-finished-by? (time-period time-period --> boolean))
(: time-period-contains? (time-period time-period --> boolean))
(: time-period-starts? (time-period time-period --> boolean))
(: time-period-equals? (time-period time-period --> boolean))
(: time-period-started-by? (time-period time-period --> boolean))
(: time-period-during? (time-period time-period --> boolean))
(: time-period-finishes? (time-period time-period --> boolean))
(: time-period-overlapped-by? (time-period time-period --> boolean))
(: time-period-met-by? (time-period time-period --> boolean))
(: time-period-preceded-by? (time-period time-period --> boolean))

(: time-period-contains/time? (time-period time --> boolean))
(: time-period-contains/date? (time-period date --> boolean))
(: time-period-within? (time-period (or time date time-period) --> boolean))

(: time-period-intersects? (time-period time-period --> boolean))

(: time-period=? (time-period time-period --> boolean))
(: time-period<? (time-period time-period --> boolean))
(: time-period>? (time-period time-period --> boolean))
(: time-period<=? (time-period time-period --> boolean))
(: time-period>=? (time-period time-period --> boolean))
(: time-period-compare (time-period time-period --> fixnum))

(: time-period-preceding (time-period time-period --> (or false time-period)))
(: time-period-succeeding (time-period time-period --> (or false time-period)))
(: time-period-intersection (time-period time-period --> (or false time-period)))
(: time-period-union (time-period time-period --> time-period))
(: time-period-span (time-period time-period --> (or false time-period)))

(: time-period-shift (time-period time --> time-period))
(: time-period-shift! (time-period time -> time-period))

;;

(include-relative "srfi-19-common")

;;;

(define ONE-NANOSECOND-DURATION (one-nanosecond-duration))

;;

(define (error-time-object loc obj)
  (error-argument-type loc obj "time object") )

(define (error-incompatible-clock-type loc obj)
  (signal-type-error loc "incompatible clock type" obj) )

(define (error-incompatible-clock-types loc obj1 obj2)
  (signal-type-error loc "incompatible clock types" obj1 obj2) )

;;

;
(define (tm:time-point-contains? b1 e1 b2 e2) (and (tm:time<? b1 b2) (tm:time<? e2 e1)))

;returns a false period when inverted
(define (tm:time-point-intersection b1 e1 b2 e2)
  (let ((b1 (tm:time-max b1 b2))
        (e1 (tm:time-min e1 e2)) )
    (if (tm:time>? b1 e1)
      (values #f #f)
      (values b1 e1) ) ) )

;cannot return an inverted period
(define (tm:time-point-union b1 e1 b2 e2)
  (values (tm:time-min b1 b2) (tm:time-max e1 e2)) )

;;; Time Period

(: %make-time-period (time time --> time-period))
(: %time-period? (* -> boolean : time-period))
(: %time-period-begin (time-period --> time))
(: %time-period-end (time-period --> time))

(define time-period 'time-period)
(define-record-type-variant time-period (unchecked inline unsafe)
  (%make-time-period beg end)
  %time-period?
  (beg %time-period-begin)
  (end %time-period-end) )

(define-check+error-type time-period (cut %time-period? <>))

(define (srfi-10-literal)
  ;
  (cond-expand
    (chicken-5.3
      (set! (record-printer time-period)
        (lambda (per out)
          (format out "#,(time-period ~A ~A)"
            (%time-period-begin per)
            (%time-period-end per)))) )
    (else
      (##sys#register-record-printer time-period
        (lambda (per out)
          (format out "#,(time-period ~A ~A)"
            (%time-period-begin per)
            (%time-period-end per)))) ) )
  ;
  (define-reader-ctor 'srfi-19-time-period
    (lambda (beg end)
      (%make-time-period beg end))) )

(define (check-time-period-binop loc obj1 obj2)
  (check-time-period loc obj1)
  (check-time-period loc obj2) )

(define (tm:time-period-type per)
  (tm:time-type (%time-period-begin per)))

(define (tm:time-period-null? per)
  (tm:time=? (%time-period-end per) (%time-period-begin per)) )

(define (tm:make-time-period-zero obj)
  (let ((tt (if (time-period? obj) (tm:time-period-type obj) obj)))
    (%make-time-period (zero-time tt) (zero-time tt)) ) )

(define (tm:ensure-compatible-time loc t1 t2)
  (define (errtt) (error-incompatible-clock-types loc t1 t2))
  (let ((tt1 (tm:time-type t1)) (tt2 (tm:time-type t2)))
    (if (eq? tt1 tt2)
      t2
      (let ((ntime (tm:any-time)))
        (case tt1
          ((tai)
            (case tt2
              ((utc)        (tm:time-utc->time-tai t2 ntime))
              ((monotonic)  (tm:time-monotonic->time-tai t2 ntime))
              (else
                (errtt))) )
          ((utc)
            (case tt2
              ((tai)        (tm:time-tai->time-utc t2 ntime))
              ((monotonic)  (tm:time-monotonic->time-utc t2 ntime))
              (else
                (errtt))) )
          ((monotonic)
            (case tt2
              ((utc)        (tm:time-utc->time-monotonic t2 ntime))
              ((tai)        (tm:time-tai->time-monotonic t2 ntime))
              (else
                (errtt))) )
          (else
            (errtt)) ) ) ) ) )

(define (tm:ensure-compatible-time-period-begin loc per1 per2)
  (tm:ensure-compatible-time loc (%time-period-begin per1) (%time-period-begin per2)) )

(define (tm:ensure-compatible-time-period-end loc per1 per2)
  (tm:ensure-compatible-time loc (%time-period-end per1) (%time-period-end per2)) )

(define (tm:ensure-compatible-date loc tim dat)
  (or (tm:date->time dat (tm:time-type tim))
      (error-incompatible-clock-type loc tim)) )

(define (tm:ensure-compatible-period loc per1 per2)
  (if (tm:time-period-type=? per1 per2)
    (values (%time-period-begin per2) (%time-period-end per2))
    (values
      (tm:ensure-compatible-time-period-begin loc per1 per2)
      (tm:ensure-compatible-time-period-end loc per1 per2)) ) )

(define (tm:compatible-times loc per1 per2)
  (let* ((b1 (%time-period-begin per1))
         (e1 (%time-period-end per1))
         (b2 (tm:ensure-compatible-time loc b1 (%time-period-begin per2)))
         (e2 (tm:ensure-compatible-time loc e1 (%time-period-end per2))) )
    (values b1 e1 b2 e2) ) )

(define (tm:checked-times loc per1 per2)
  (check-time-period loc per1)
  (check-time-period loc per2)
  (tm:compatible-times loc per1 per2) )

(define (tm:time-period-type=? per1 per2)
  (eq? (tm:time-period-type per1) (tm:time-period-type per2)) )

(define (tm:time-period-precedes? loc per1 per2)
  (let-values (((b1 e1 b2 e2) (tm:compatible-times loc per1 per2)))
    (tm:time<? e1 b2) ) )

(define (tm:time-period-meets? loc per1 per2)
  (let-values (((b1 e1 b2 e2) (tm:compatible-times loc per1 per2)))
    (tm:time=? e1 b2) ) )

(define (tm:time-period-overlaps? loc per1 per2)
  (let-values (((b1 e1 b2 e2) (tm:compatible-times loc per1 per2)))
    (and (tm:time<? b1 b2) (tm:time>? e1 b2)) ) )

(define (tm:time-period-finished-by? loc per1 per2)
  (let-values (((b1 e1 b2 e2) (tm:compatible-times loc per1 per2)))
    (and (tm:time=? e1 e2) (tm:time<? b1 b2)) ) )

(define (tm:time-period-contains? loc per1 per2)
  (let-values (((b1 e1 b2 e2) (tm:compatible-times loc per1 per2)))
    (tm:time-point-contains? b1 e1 b2 e2) ) )

(define (tm:time-period-starts? loc per1 per2)
  (let-values (((b1 e1 b2 e2) (tm:compatible-times loc per1 per2)))
    (and (tm:time=? b1 b2) (tm:time<? e1 e2)) ) )

(define (tm:time-period-equals? loc per1 per2)
  (let-values (((b1 e1 b2 e2) (tm:compatible-times loc per1 per2)))
    (and (tm:time=? b1 b2) (tm:time=? e1 e2)) ) )

(define (tm:time-period-contains/time? loc per tim)
  (let ((tpt (tm:ensure-compatible-time loc (%time-period-begin per) tim)))
    (tm:time-point-contains? (%time-period-begin per) (%time-period-end per) tpt tpt) ) )

(define (tm:time-period-contains/date? loc per dat)
  (let ((tpt (tm:ensure-compatible-date loc (%time-period-begin per) dat)))
    (tm:time-period-contains/time? loc per tpt) ) )

(define (tm:time-period-shift perin dur perout)
  (tm:add-duration (%time-period-begin perin) dur (%time-period-begin perout))
  (tm:add-duration (%time-period-end perin) dur (%time-period-end perout))
  perout )

(define (tm:time-period-union b1 e1 b2 e2)
  (let-values (((bu eu) (tm:time-point-union b1 e1 b2 e2)))
    (%make-time-period bu eu) ) )

;;

(define (make-time-period beg end #!optional (tt (default-date-clock-type)))
  (check-clock-type 'make-time-period tt)
  ;
  (cond
    ((real? beg)  (set! beg (tm:seconds->time beg tt)) )
    ((date? beg)  (set! beg (tm:date->time beg tt)) ) )
  (check-time 'make-time-period beg 'begin)
  (when (tm:time-has-type? (tm:time-type beg) 'duration)
    (error-clock-type 'make-time-period beg 'begin))
  ;
  (cond
    ((real? end)  (set! end (tm:seconds->time end 'duration)) )
    ((date? end)  (set! end (tm:ensure-compatible-date 'make-time-period beg end)) ) )
  (check-time 'make-time-period end 'end)
  (when (tm:time-has-type? (tm:time-type end) 'duration)
    (set! end (tm:add-duration beg end (tm:as-some-time beg))))
  ;
  (when (tm:time<? end beg)
    (signal-type-error 'make-time-period "inverted time period" beg end) )
  #; ;not until half-closed-right
  (when (tm:time=? end beg)
    (signal-type-error 'make-time-period "null time period" beg end) )
  ;
  (%make-time-period beg (tm:ensure-compatible-time 'make-time-period beg end)) )

(define (time-period? obj) (%time-period? obj))

(define (time-period-copy per)
  (check-time-period 'time-period-copy per)
  (%make-time-period
    (tm:copy-time (%time-period-begin per))
    (tm:copy-time (%time-period-end per))) )

(define (make-time-period-null #!optional (tt (default-date-clock-type)))
  (tm:make-time-period-zero tt) )

(define (time-period-null? per)
  (tm:time-period-null? (check-time-period 'time-period-null? per)) )

(define (time-period-type per)
  (tm:time-period-type (check-time-period 'time-period-type per)) )

(define (time-period-begin per)
  (%time-period-begin (check-time-period 'time-period-begin per)) )

(define (time-period-end per)
  (%time-period-end (check-time-period 'time-period-end per)) )

;umm, this doesn't make sense, unless half-closed
(define (time-period-last per)
  (let ((end (%time-period-end (check-time-period 'time-period-last per))))
    (tm:subtract-duration end ONE-NANOSECOND-DURATION (tm:as-some-time end)) ) )

(define (time-period-duration per)
  (check-time-period 'time-period-duration per)
  (let ((dur (zero-time 'duration)))
    (tm:time-difference (%time-period-begin per) (%time-period-end per) dur) ) )

;Allen’s Interval Algebra
;https://www.ics.uci.edu/~alspaugh/cls/shr/allen.html

(define (time-period-precedes? per1 per2)
  (check-time-period-binop 'time-period-precedes? per1 per2)
  (tm:time-period-precedes? 'time-period-precedes? per1 per2) )

(define (time-period-meets? per1 per2)
  (check-time-period-binop 'time-period-meets? per1 per2)
  (tm:time-period-meets? 'time-period-meets? per1 per2) )

(define (time-period-overlaps? per1 per2)
  (check-time-period-binop 'time-period-overlaps? per1 per2)
  (tm:time-period-overlaps? 'time-period-overlaps? per1 per2) )

(define (time-period-finished-by? per1 per2)
  (check-time-period-binop 'time-period-finished-by? per1 per2)
  (tm:time-period-finished-by? 'time-period-finished-by? per1 per2) )

(define (time-period-contains? per1 per2)
  (check-time-period-binop 'time-period-contains? per1 per2)
  (tm:time-period-contains? 'time-period-contains? per1 per2) )

(define (time-period-starts? per1 per2)
  (check-time-period-binop 'time-period-starts? per1 per2)
  (tm:time-period-starts? 'time-period-starts? per1 per2) )

(define (time-period-equals? per1 per2)
  (check-time-period-binop 'time-period-equals? per1 per2)
  (tm:time-period-equals? 'time-period-equals? per1 per2) )

(define (time-period-started-by? per1 per2)
  (check-time-period-binop 'time-period-started-by? per1 per2)
  (tm:time-period-starts? 'time-period-started-by? per2 per1) )

(define (time-period-during? per1 per2)
  (check-time-period-binop 'time-period-during? per1 per2)
  (tm:time-period-contains? 'time-period-during? per2 per1) )

(define (time-period-finishes? per1 per2)
  (check-time-period-binop 'time-period-finishes? per1 per2)
  (tm:time-period-finished-by? 'time-period-finishes? per2 per1) )

(define (time-period-overlapped-by? per1 per2)
  (check-time-period-binop 'time-period-overlapped-by? per1 per2)
  (tm:time-period-overlaps? 'time-period-overlapped-by? per2 per1) )

(define (time-period-met-by? per1 per2)
  (check-time-period-binop 'time-period-met-by? per1 per2)
  (tm:time-period-meets? 'time-period-met-by? per2 per1) )

(define (time-period-preceded-by? per1 per2)
  (check-time-period-binop 'time-period-preceded-by? per1 per2)
  (tm:time-period-precedes? 'time-period-preceded-by? per2 per1) )

(define (time-period=? per1 per2)
  (check-time-period-binop 'time-period=? per1 per2)
  (tm:time-period-equals? 'time-period=? per1 per2) )

(define (time-period<? per1 per2)
  (check-time-period-binop 'time-period<? per1 per2)
  (tm:time-period-precedes? 'time-period<? per1 per2) )

(define (time-period>? per1 per2)
  (check-time-period-binop 'time-period>? per1 per2)
  (tm:time-period-precedes? 'time-period>? per2 per1) )

(define (time-period<=? per1 per2)
  (check-time-period-binop 'time-period<=? per1 per2)
  (let-values (((b1 e1 b2 e2) (tm:compatible-times 'time-period<=? per1 per2)))
    (tm:time<=? e1 b2) ) )

(define (time-period>=? per1 per2)
  (check-time-period-binop 'time-period>=? per1 per2)
  (let-values (((b1 e1 b2 e2) (tm:compatible-times 'time-period>=? per1 per2)))
    (tm:time>=? b1 e2) ) )

;utility?
(define (time-period-compare per1 per2)
  (check-time-period-binop 'time-period-compare per1 per2)
  (let-values (((b1 e1 b2 e2) (tm:compatible-times 'time-period-compare per1 per2)))
    (let ((diff (let ((bd (- b1 b2))) (if (not (zero? bd)) bd (- e1 e2)))))
      (cond
        ((negative? diff) -1)
        ((zero? diff)     0)
        (else             1 ) ) ) ) )

(define (time-period-contains/time? per tim)
  (tm:time-period-contains/time? 'time-period-contains/time?
    (check-time-period 'time-period-contains/time? per)
    (check-time 'time-period-contains/time? tim)) )

(define (time-period-contains/date? per dat)
  (tm:time-period-contains/date? 'time-period-contains/date?
    (check-time-period 'time-period-contains/date? per)
    (check-date 'time-period-contains/date? dat)) )

(define (time-period-within? per obj)
  (check-time-period 'time-period-within? per)
  (cond
    ((time-period? obj)
      (tm:time-period-contains? 'time-period-within? per obj))
    ((time? obj)
      (tm:time-period-contains/time? 'time-period-within? per obj))
    ((date? obj)
      (tm:time-period-contains/date? 'time-period-within? per obj))
    (else
      (error-time-object 'time-period-within? obj))) )

;#f when no intersection (inverted period)
(define (time-period-intersects? per1 per2)
  (let*-values (((b1 e1 b2 e2) (tm:checked-times 'time-period-intersects? per1 per2))
                ((bi ei) (tm:time-point-intersection b1 e1 b2 e2)) )
      (and bi ei) ) )

;;

(define (time-period-preceding per1 per2)
  (check-time-period-binop 'time-period-preceding per1 per2)
  (and (tm:time<=? (%time-period-begin per1) (%time-period-begin per2))
       (make-time-period (%time-period-begin per1) (%time-period-begin per2)) ) )

(define (time-period-succeeding per1 per2)
  (check-time-period-binop 'time-period-succeeding per1 per2)
  (and (tm:time>=? (%time-period-end per1) (%time-period-end per2))
       (make-time-period (%time-period-end per2) (%time-period-end per1)) ) )

;#f when no overlap
(define (time-period-intersection per1 per2)
  (let*-values (((b1 e1 b2 e2) (tm:checked-times 'time-period-intersection per1 per2))
                ((bi ei) (tm:time-point-intersection b1 e1 b2 e2)) )
    (and bi ei (%make-time-period bi ei)) ) )

(define (time-period-union per1 per2)
  (let-values (((b1 e1 b2 e2) (tm:checked-times 'time-period-union per1 per2)))
    (tm:time-period-union b1 e1 b2 e2) ) )

;#f when no overlap
(define (time-period-span per1 per2)
  (let*-values (((b1 e1 b2 e2) (tm:checked-times 'time-period-span per1 per2))
                ((bi ei) (tm:time-point-intersection b1 e1 b2 e2)) )
      (and bi ei (tm:time-period-union b1 e1 b2 e2)) ) )

;;

(define (time-period-shift per dur)
  (check-time-period 'time-period-shift per)
  (check-duration 'time-period-shift dur)
  (tm:time-period-shift per dur (tm:make-time-period-zero per)) )

(define (time-period-shift! per dur)
  (check-time-period 'time-period-shift! per)
  (check-duration 'time-period-shift! dur)
  (tm:time-period-shift per dur per) )

;;; Initialize

(srfi-10-literal)

) ;srfi-19-period