;;;; "time.scm" Posix time conversion routines
;;; Copyright (C) 1994 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, and to use it
;for any purpose is granted, subject to the following restrictions and
;understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warrantee or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

(define time:daylight 0)
(define *timezone* 0)
(define time:tzname #("GMT" "GDT"))

(define (time:tzset)
  (set! time:daylight 1)
  (set! *timezone* (* 5 60 60))
  (set! time:tzname #("EST" "EDT")))

;;; No, it doesn't do leap seconds.  If you want to add it, go ahead.

;;; Returns the `struct tm' representation of T,
;;; offset TM_GMTOFF seconds east of UCT.
(define (time:split t tm_isdst tm_gmtoff tm_zone)
  (set! t (difftime t tm_gmtoff))
  (let* ((days-in-year (lambda (year)
			 (if (and (zero? (remainder year 4))
				  (or (not (zero? (remainder year 100)))
				      (zero? (remainder year 400))))
			     366 365)))
	 (days/month #(#(31 28 31 30 31 30 31 31 30 31 30 31) ; Normal years.
		       #(31 29 31 30 31 30 31 31 30 31 30 31))) ; Leap years.
	 (SECS/HOUR (* 60 60))
	 (SECS/DAY (* SECS/HOUR 24))
	 (secs (modulo t SECS/DAY))
	 (days (+ (quotient t SECS/DAY)
		  (if (and (negative? t) (positive? secs)) -1 0))))
    (let ((tm_hour (quotient secs SECS/HOUR))
	  (secs (remainder secs SECS/HOUR))
	  (tm_wday (modulo (+ 4 days) 7))) ; January 1, 1970 was a Thursday.
      (let loop ((tm_year 1970)
		 (tm_yday days))
	(let ((diy (days-in-year tm_year)))
	  (cond
	   ((negative? tm_yday) (loop (+ -1 tm_year) (+ tm_yday diy)))
	   ((>= tm_yday diy) (loop (+ 1 tm_year) (- tm_yday diy)))
	   (else
	    (let* ((mv (vector-ref days/month (- diy 365))))
	      (do ((tm_mon 0 (+ 1 tm_mon))
		   (tm_mday tm_yday (- tm_mday (vector-ref mv tm_mon))))
		  ((< tm_mday (vector-ref mv tm_mon))
		   (vector
		    (remainder secs 60)	; Seconds.	[0-61] (2 leap seconds)
		    (quotient secs 60)	; Minutes.	[0-59]
		    tm_hour		; Hours.	[0-23]
		    (+ tm_mday 1)	; Day.		[1-31]
		    tm_mon		; Month.	[0-11]
		    (- tm_year 1900)	; Year	- 1900.
		    tm_wday		; Day of week.	[0-6]
		    tm_yday		; Days in year. [0-365]
		    tm_isdst		; DST.		[-1/0/1]
		    tm_gmtoff		; Seconds west of UTC.
		    tm_zone		; Timezone abbreviation.
		    )))))))))))

(define (time:gmtime t)
  (time:split t 0 0 "GMT"))

(define (time:localtime t)
  (time:tzset)
  (time:split t time:daylight *timezone*
	      (vector-ref time:tzname time:daylight)))

(define time:year-70
  (let* ((t (current-time)))
    (offset-time (offset-time t (- (difftime t 0))) (* -70 32140800))))

(define (time:invert decoder target)
  (let* ((times #(1 60 3600 86400 2678400 32140800))
	 (trough			; rough time for target
	  (do ((i 5 (+ i -1))
	       (trough time:year-70
		       (offset-time trough (* (vector-ref target i)
					      (vector-ref times i)))))
	      ((negative? i) trough))))
;;;    (print 'trough trough 'target target)
    (let loop ((guess trough)
	       (j 0)
	       (guess-tm (decoder trough)))
;;;      (print 'guess guess 'guess-tm guess-tm)
      (do ((i 5 (+ i -1))
	   (rough time:year-70
		  (offset-time rough (* (vector-ref guess-tm i)
					(vector-ref times i))))
	   (sign (let ((d (- (vector-ref target 5)
			     (vector-ref guess-tm 5))))
		   (and (not (zero? d)) d))
		 (or sign
		     (let ((d (- (vector-ref target i)
				 (vector-ref guess-tm i))))
		       (and (not (zero? d)) d)))))
	  ((negative? i)
	   (let* ((distance (abs (- trough rough))))
	     (cond ((and (zero? distance) sign)
;;;		    (print "trying to jump")
		    (set! distance (if (negative? sign) -86400 86400)))
		   ((and sign (negative? sign)) (set! distance (- distance))))
	     (set! guess (offset-time guess distance))
;;;	     (print 'distance distance 'sign sign)
	     (cond ((zero? distance) guess)
		   ((> j 5) #f)		;to prevent inf loops.
		   (else
		    (loop guess
			  (+ 1 j)
			  (decoder guess))))))))))

(define (time:mktime time)
  (time:tzset)
  (time:invert localtime time))

(define (time:asctime decoded)
  (let ((days   #("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
	(months #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
			"Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
	(number->2digits
	 (lambda (n ch)
	   (set! n (number->string n))
	   (if (= 1 (string-length n))
	       (string-append ch n)
	       n))))
    (string-append
     (vector-ref days (vector-ref decoded 6)) " "
     (vector-ref months (vector-ref decoded 4)) " "
     (number->2digits (vector-ref decoded 3) " ") " "
     (number->2digits (vector-ref decoded 2) "0") ":"
     (number->2digits (vector-ref decoded 1) "0") ":"
     (number->2digits (vector-ref decoded 0) "0") " "
     (number->string (+ 1900 (vector-ref decoded 5))))))

(define (time:ctime time)
  (time:asctime (time:localtime time)))

(define tzset time:tzset)
(define gmtime time:gmtime)
(define localtime time:localtime)
(define mktime time:mktime)
(define asctime time:asctime)
(define ctime time:ctime)
