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

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

(include "chicken-primitive-object-inlines")

(module srfi-19-period

  (;export
    time-period?
    check-time-period
    error-time-period
    ;time-period-null?
    time-period-compare
    time-period=?
    time-period<?
    time-period>?
    time-period<=?
    time-period>=?
    time-period-type
    time-period-begin
    time-period-end
    time-period-last
    time-period-length
    ;make-null-time-period
    make-time-period
    copy-time-period
    time-period-contains/period?
    time-period-contains/time?
    time-period-contains/date?
    time-period-contains?
    time-period-intersects?
    time-period-intersection
    time-period-union
    time-period-span
    time-period-shift
    time-period-shift!
    time-period-preceding
    time-period-succeeding)

  (import
    scheme
    chicken
    (only extras format)
    record-variants
    type-checks
    type-errors
    srfi-19-time
    srfi-19-date
    srfi-19-support)

  (require-library
    record-variants type-checks type-errors
    srfi-19-time srfi-19-date srfi-19-support)

;;;

(include "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-within? b1 e1 b2 e2)
  (and (tm:time<=? b1 b2) (tm:time<=? e2 e1)) )

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

;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

(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 %time-period?)

(define-record-printer (time-period per out)
  (format out
    "#,(time-period ~A ~A)"
    (%time-period-begin per)
    (%time-period-end per)) )

(define-reader-ctor '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)))

#; ;BAD IDEA
(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)
  (let ((tt1 (tm:time-type t1))
        (tt2 (tm:time-type t2)))
    (define (errtt) (error-incompatible-clock-types loc t1 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:time-period-type=? per1 per2)
  (eq? (tm:time-period-type per1) (tm:time-period-type per2)) )

(define (tm:time-period=? per1 per2)
  (and (tm:time=? (%time-period-begin per1) (%time-period-begin per2))
       (tm:time=? (%time-period-end per1) (%time-period-end per2))) )

(define (tm:time-period-contains/period? loc per1 per2)
  (let ((tper (if (tm:time-period-type=? per1 per2) per2
                (%make-time-period
                  (tm:ensure-compatible-time-period-begin loc per1 per2)
                  (tm:ensure-compatible-time-period-end loc per1 per2)) ) ) )
    (tm:time-point-within?
     (%time-period-begin per1) (%time-period-end per1)
     (%time-period-begin tper) (%time-period-end tper)) ) )

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

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

(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 )

#; ;FIXME - should take into account span
(define (tm:time-period-subtract per1 per2)
  (let ((diff (- (%time-period-begin per1) (%time-period-begin per2))))
    (if (zero? diff) (- (%time-period-end per1) (%time-period-end per2))
        diff ) ) )

;;

#; ;BAD IDEA
(define (make-null-time-period . args)
  (let-optionals args ((tt (default-date-clock-type)))
    (tm:make-time-period-zero tt) ) )

#; ;BAD IDEA
(define (time-period-null? per)
  (check-time-period 'time-period-null? per)
  (tm:time-period-null? per) )

(define (make-time-period beg end . args)
  (let-optionals args ((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) )
    ;
    (%make-time-period beg (tm:ensure-compatible-time 'make-time-period beg end)) ) )

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

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

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

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

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

(define (time-period-compare per1 per2)
  (check-time-period-binop 'time-period-compare per1 per2)
  (cond
    ((tm:time<? (%time-period-end per1) (%time-period-begin per2))
      -1)
    ((tm:time-period=? per1 per2)
      0)
    (else
      1) )
  #;
  (let ((diff (tm:time-period-subtract per1 per2)))
    (cond ((negative? diff) -1)
          ((zero? diff)     0)
          (else             1 ) ) ) )

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

(define (time-period<? per1 per2)
  (check-time-period-binop 'time-period<? per1 per2)
  (tm:time<? (%time-period-end per1) (%time-period-begin per2)) )

(define (time-period>? per1 per2)
  (check-time-period-binop 'time-period>? per1 per2)
  (tm:time>? (%time-period-begin per1) (%time-period-end per2)) )

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

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

(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)) ) )

(define (time-period-last per)
  (check-time-period 'time-period-last per)
  (let ((end (%time-period-end per)))
    (tm:subtract-duration end ONE-NANOSECOND-DURATION (tm:as-some-time end)) ) )

(define (time-period-length per)
  (check-time-period 'time-period-length per)
  (let ((dur (zero-time 'duration)))
    (tm:time-difference (%time-period-begin per) (%time-period-end per) dur)
    #; ;BAD IDEA
    (if (tm:time-period-null? per) dur
      (tm:time-difference (%time-period-begin per) (%time-period-end per) dur)) ) )

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

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

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

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

;#f when no intersection (inverted period)
(define (time-period-intersects? per1 per2)
  (and (time-period-intersection per1 per2)
       #t) )

;#f when no overlap
(define (time-period-intersection per1 per2)
  (check-time-period 'time-period-intersection per1)
  (check-time-period 'time-period-intersection per2)
  (let ((b1 (%time-period-begin per1))
        (e1 (%time-period-end per1)))
    (let ((b2 (tm:ensure-compatible-time 'time-period-intersection
                b1 (%time-period-begin per2)))
          (e2 (tm:ensure-compatible-time 'time-period-intersection
                e1 (%time-period-end per2))))
      (receive (bi ei) (tm:time-point-intersection b1 e1 b2 e2)
        (and (tm:time<=? bi ei)
             (%make-time-period bi ei)) ) ) ) )

;#f when no overlap
(define (time-period-union per1 per2)
  (check-time-period 'time-period-union per1)
  (check-time-period 'time-period-union per2)
  (let ((b1 (%time-period-begin per1))
        (e1 (%time-period-end per1)))
    (let ((b2 (tm:ensure-compatible-time 'time-period-union b1 (time-period-begin per2)))
          (e2 (tm:ensure-compatible-time 'time-period-union e1 (time-period-end per2))))
      (receive (bi ei) (tm:time-point-intersection b1 e1 b2 e2)
        (and (tm:time<=? bi ei)
             (receive (bu eu) (tm:time-point-union b1 e1 b2 e2)
               (%make-time-period bu eu) ) ) ) ) ) )

(define (time-period-span per1 per2)
  (check-time-period 'time-period-span per1)
  (check-time-period 'time-period-span per2)
  (let ((b1 (%time-period-begin per1))
        (e1 (%time-period-end per1)))
    (let ((b2 (tm:ensure-compatible-time 'time-period-span b1 (%time-period-begin per2)))
          (e2 (tm:ensure-compatible-time 'time-period-span e1 (%time-period-end per2))))
    (receive (bu eu) (tm:time-point-union b1 e1 b2 e2)
      (%make-time-period bu eu) ) ) ) )

(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) )

) ;srfi-19-period