;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: kira; Coding: utf-8 -*-
;;;; Copyright © 2024 David Mullen. All Rights Reserved. Origin: <https://cl-pdx.com/kira/>

(in-package :kira)

(defstruct local-time
  ;; The following quotes directly from <http://naggum.no/lugm-time.html>
  ;; The LOCAL-TIME concept represents time as three disjoint fixnums.
  ;; All numbers have origin 0. Only the number of days may be negative.
  (day  0 :type fixnum) ; 1. the number of days since (or until, when negative) 2000-03-01
  (sec  0 :type fixnum) ; 2. the number of seconds since the start of the day in UTC
  (msec 0 :type fixnum) ; 3. the number of milliseconds since the start of the second.
  (zone nil))

(defconstant +cycle+   146097 "The number of days in a 400-year cycle.")
(defconstant +century+  36524 "The number of days in a single century.")
(defconstant +c-hours+  43200 "The number of seconds in 12 hours.")

(defstatic +decoded-days+ (make-array +century+ :element-type '(unsigned-byte 16)))
(defstatic +decoded-secs+ (make-array +c-hours+ :element-type '(unsigned-byte 16)))

(declaim (type (simple-array (unsigned-byte 16) (*)) +decoded-days+))
(declaim (type (simple-array (unsigned-byte 16) (*)) +decoded-secs+))

(defun encode-date (year month day)
  (declare (type (unsigned-byte 7) year))
  (declare (type (unsigned-byte 4) month))
  (declare (type (unsigned-byte 5) day))
  (let ((year-byte (ash year 9)) (month-byte (ash month 5)))
    (declare (type (unsigned-byte 16) year-byte month-byte))
    (logior year-byte (the fixnum (logior month-byte day)))))

(defun days-in-month (month year)
  (check-type year (integer 0 100))
  (cond ((and (= month 2) (/= year 100) (= (rem year 4) 0)) 29)
        ((svref #(31 28 31 30 31 30 31 31 30 31 30 31) (1- month)))))

;;; Initialize lookup table +DECODED-DAYS+.
(let ((year 0) (month 3) (day 1) (days-in-month 31))
  (declare (type fixnum year month day days-in-month))
  (loop for index of-type fixnum from 0 below +century+
        do (let ((entry (encode-date year month day)))
             (declare (type (unsigned-byte 16) entry))
             (setf (aref +decoded-days+ index) entry)
             (cond ((< day days-in-month) (incf day))
                   (t (unless (<= (incf month) 12) (setq month 1) (incf year))
                      (setq days-in-month (days-in-month month year) day 1))))))

;;; Initialize lookup table +DECODED-SECS+.
(loop with index fixnum = 0 and entries = +decoded-secs+
      for hour below 12 as entry fixnum = (ash hour 12)
      do (loop for minute of-type fixnum below 60
               do (setf (ldb (byte 6 6) entry) minute)
                  (loop for sec of-type fixnum below 60
                        do (setf (ldb (byte 6 0) entry) sec)
                           (setf (aref entries index) entry)
                           (incf index))))

(defmacro normalize-time-slot
    (var constant-limit carry)
  (with-gensyms (old again)
    `(prog ((,old ,var))
       (declare (type fixnum ,old))
       ,again (when (minusp ,var)
                (incf ,var ,constant-limit)
                (decf ,carry) (go ,again))
              (when (>= ,var ,constant-limit)
                (decf ,var ,constant-limit)
                (incf ,carry) (go ,again))
              (return (/= ,old ,var)))))

(eval-always
  (defconstant +day+ (* 2 +c-hours+))
  (defconstant +1970-01-01+ -11017)
  (defconstant +1900-01-01+ -36584))

(defun normalize-local-time (local-time)
  (require-type local-time 'local-time)
  (let ((day (local-time-day local-time))
        (sec (local-time-sec local-time))
        (msec (local-time-msec local-time)))
    (declare (type fixnum day sec msec))
    (declare (optimize (safety 0) (speed 3)))
    (when (normalize-time-slot msec 1000 sec)
      (setf (local-time-msec local-time) msec)
      (setf (local-time-sec local-time) sec))
    (when (normalize-time-slot sec +day+ day)
      (setf (local-time-day local-time) day)
      (setf (local-time-sec local-time) sec))
    local-time))

(defun decode-local-time (local-time)
  (normalize-local-time local-time)
  (multiple-value-bind (year month day)
      (day-to-date (local-time-day local-time))
    (multiple-value-bind (hour minute sec)
        (sec-to-time (local-time-sec local-time))
      (values (local-time-msec local-time)
              sec minute hour
              day month year))))

(defun day-to-date (day)
  (check-type day fixnum)
  (locally (declare (fixnum day))
    (let ((cycle 0) (century 0) (year 2000))
      (declare (type fixnum cycle century year))
      (when (or (minusp day) (>= day +century+))
        (multiple-value-setq (cycle day)
          (floor day +cycle+))
        (let ((cycle-years (* 400 cycle)))
          (declare (type fixnum cycle-years))
          (incf year cycle-years))
        (when (= day (1- +cycle+))
          (return-from day-to-date (values (+ year 400) 2 29)))
        (multiple-value-setq (century day) (floor day +century+))
        (incf year (the fixnum (* 100 century))))
      ;; DAY is now within the table bounds.
      (let ((entry (aref +decoded-days+ day)))
        (declare (type (unsigned-byte 16) entry))
        (let ((year-offset (ldb (byte 7 9) entry)))
          (declare (type fixnum year-offset))
          (values (the fixnum (+ year year-offset))
                  (ldb (byte 4 5) entry)
                  (ldb (byte 5 0) entry)))))))

(defun sec-to-time (sec)
  (check-type sec fixnum)
  (let* ((shifted-hour-p
          (when (>= sec +c-hours+)
            (decf sec +c-hours+)))
         (entry (aref +decoded-secs+ sec)))
    (declare (type (unsigned-byte 16) entry))
    (let ((hour-offset (ldb (byte 4 12) entry)))
      (declare (type (unsigned-byte 4) hour-offset))
      (let ((hour (if shifted-hour-p (+ 12 hour-offset) hour-offset)))
        (values hour (ldb (byte 6 6) entry) (ldb (byte 6 0) entry))))))

(defmacro time-to-sec (hour minute sec)
  `(+ ,sec (* 60 (+ ,minute (* 60 ,hour)))))

(defun encode-local-time (msec sec minute hour day month year &optional zone)
  (let ((day (date-to-day year month day)) (sec (time-to-sec hour minute sec)))
    (make-local-time :day day :sec sec :msec msec :zone zone)))

(defun date-to-day (year month day)
  (check-type day (unsigned-byte 5))
  (check-type year (integer -99999 99999))
  (locally (declare (type (unsigned-byte 5) month))
    (let* ((year-rotation (sbit #*110000000000 (1- month)))
           (day-offset 0) (mar-based-year (- year 2000 year-rotation)))
      (declare (type fixnum year-rotation day-offset mar-based-year))
      (when (or (minusp mar-based-year) (>= mar-based-year 100))
        (let ((cycle 0) (century 0))
          (declare (type fixnum cycle century))
          (multiple-value-setq (cycle mar-based-year)
            (floor mar-based-year 400))
          (let ((cycle-days (* +cycle+ cycle)))
            (declare (type fixnum cycle-days))
            (incf day-offset cycle-days))
          (when (and (= mar-based-year 399) (= month 2) (= day 29))
            ;; This is the leap day at the end of the 400-year cycle.
            (return-from date-to-day (the fixnum (+ day-offset (1- +cycle+)))))
          (setf (values century mar-based-year) (floor mar-based-year 100))
          (incf day-offset (the fixnum (* +century+ century)))))
      ;; Since entries have January-based years, Y adjusts for it.
      (loop with y of-type fixnum = (+ mar-based-year year-rotation)
            with start of-type fixnum = 0 with end of-type fixnum = +century+
            with key of-type (unsigned-byte 16) = (encode-date y month day)
            for index of-type fixnum = (ash (the fixnum (+ start end)) -1)
            for entry of-type (unsigned-byte 16) = (aref +decoded-days+ index)
            when (= entry key) do (return-from date-to-day (+ day-offset index))
            if (> entry key) do (setq end index) else do (setq start (1+ index))
            when (= start end) do (error "Invalid date.")))))

(defun local-time (&key universal unix (msec 0) (zone 0))
  (when (and universal unix) (error "Specify either ~S or ~S time." :universal :unix))
  (multiple-value-bind (day-relative-to-epoch sec) (floor (or universal unix) +day+)
    (let ((day (+ day-relative-to-epoch (the fixnum (if unix +1970-01-01+ +1900-01-01+)))))
      (make-local-time :day day :sec sec :msec msec :zone zone))))

(defun unix-time (local-time)
  (let ((day (local-time-day (normalize-local-time local-time))))
    (+ (* (- day +1970-01-01+) +day+) (local-time-sec local-time))))

(defun universal-time (local-time)
  (let ((day (local-time-day (normalize-local-time local-time))))
    (+ (* (- day +1900-01-01+) +day+) (local-time-sec local-time))))

(defmethod print-object ((local-time local-time) stream &aux (zone (local-time-zone local-time)))
  (multiple-value-bind (msec sec minute hour day month year) (decode-local-time local-time)
    (declare (type fixnum msec sec minute hour day month year))
    (unless (typep year '(integer -99999 99999))
      (return-from print-object (call-next-method)))
    (when (or *print-escape* *print-readably*)
      (write-char #\@ stream))
    (multiple-value-bind (year-sign year-digits)
        (if (typep year ' (integer 0 9999)) (values nil 4) (values (if (minusp year) #\- #\+) 5))
      (format stream "~@[~C~]~V,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D.~3,'0D~:@/kira:print-zone/"
              year-sign year-digits (abs year) month day hour minute sec msec zone))))

(defun print-zone (stream zone &optional colon-p at-sign-p)
  (cond ((not zone) (unless at-sign-p (write-string "-0000" stream)))
        ((and (eql zone 0) colon-p) (write-string (if at-sign-p "Z" "GMT") stream))
        (t (let ((zone-sign-marker (if (minusp zone) (prog1 #\- (absf zone)) #\+)))
             (multiple-value-bind (hour-offset minute-offset) (sec-to-time zone)
               (let ((control (if at-sign-p "~C~2,'0D:~2,'0D" "~C~2,'0D~2,'0D")))
                 (format stream control zone-sign-marker hour-offset minute-offset)))))))

(defmethod make-load-form ((local-time local-time) &optional environment)
  (make-load-form-saving-slots local-time :environment environment))

(defun get-local-time ()
  (rlet ((timeofday :timeval))
    (gettimeofday timeofday)
    (let* ((sec (pref timeofday :timeval.tv_sec))
           (usec (pref timeofday :timeval.tv_usec))
           (msec (floor usec 1000)))
      (declare (type (unsigned-byte 40) sec))
      (declare (type (unsigned-byte 20) usec))
      (declare (type (unsigned-byte 10) msec))
      (multiple-value-bind (day sec) (floor sec +day+)
        (setq day (the fixnum (+ (the fixnum day) +1970-01-01+)))
        (make-local-time :day day :sec sec :msec msec :zone 0)))))

(defun local-time= (local-time-1 local-time-2)
  (normalize-local-time local-time-1) (normalize-local-time local-time-2)
  (and (= (local-time-day local-time-1) (local-time-day local-time-2))
       (= (local-time-sec local-time-1) (local-time-sec local-time-2))
       (= (local-time-msec local-time-1) (local-time-msec local-time-2))
       (eql (local-time-zone local-time-1) (local-time-zone local-time-2))))

(defun local-time/= (local-time-1 local-time-2)
  (not (local-time= local-time-1 local-time-2)))

(defun local-time< (local-time-1 local-time-2)
  (progn (normalize-local-time local-time-1) (normalize-local-time local-time-2))
  (assert (eql (local-time-zone local-time-1) (local-time-zone local-time-2)))
  (or (< (local-time-day local-time-1) (local-time-day local-time-2))
      (when (= (local-time-day local-time-1) (local-time-day local-time-2))
        (or (< (local-time-sec local-time-1) (local-time-sec local-time-2))
            (when (= (local-time-sec local-time-1) (local-time-sec local-time-2))
              (< (local-time-msec local-time-1) (local-time-msec local-time-2)))))))

(defun local-time<= (local-time-1 local-time-2)
  (or (local-time= local-time-1 local-time-2)
      (local-time< local-time-1 local-time-2)))

(defun local-time> (local-time-1 local-time-2)
  (unless (local-time= local-time-1 local-time-2)
    (local-time< local-time-2 local-time-1)))

(defun local-time>= (local-time-1 local-time-2)
  (or (local-time= local-time-1 local-time-2)
      (local-time> local-time-1 local-time-2)))

(defmacro get-digit (&aux (base (char-code #\0)))
  (let ((place-value `(- (char-code digit-char) ,base)))
    `(the (integer 0 9) (or (lexer-case (digit-char (lexer-error))
                              (digit (the (integer 0 9) ,place-value)))
                            (lexer-error)))))

(defmacro get-field (digits)
  (with-gensyms (field-value)
    (let ((digits-left (1- digits)))
      (when (= digits 1) (return-from get-field '(get-digit)))
      (let ((field-typespec `(integer 0 ,(1- (expt 10 digits)))))
        `(the ,field-typespec
           (let* ((,field-value (get-field ,digits-left))
                  (,field-value (* 10 ,field-value))
                  (,field-value (+ ,field-value (get-digit))))
             (declare (type ,field-typespec ,field-value))
             ,field-value))))))

(defmacro %parse-zone ()
  `(lexer-case (operator)
     (#\Z (setq zone 0))
     ("-+" (let* ((hour-offset (get-field 2))
                  (minute-offset (progn (lexer-match #\:) (get-field 2)))
                  (computed-offset (time-to-sec hour-offset minute-offset 0)))
             (declare (type (signed-byte 24) hour-offset minute-offset computed-offset))
             (when (eql operator #\-) (setq computed-offset (- computed-offset)))
             (setq zone computed-offset)))))

(defun parse-zone (string &key (start 0) end junk-allowed)
  "Accept a zone offset (like -08:00) or the letter Z."
  (with-lexer (string start end)
    (with-lexer-error ("zone" junk-allowed)
      (let (zone) (%parse-zone) zone))))

(defun parse-timestring (string &key (start 0) end junk-allowed)
  (let ((month 1) (day 1) (hour 0) (minute 0) (sec 0) (msec 0))
    (declare (type fixnum month day hour minute sec msec))
    (with-lexer (string start end)
      (let (operator year allow-zone-p zone)
        (with-lexer-error ("timestring" junk-allowed)
          (if (setq operator (lexer-match "-+"))
              (setq year (get-field 5))
              (setq year (get-field 4)))
          (locally (declare (type (signed-byte 24) year))
            (when (eql operator #\-) (setq year (- year))))
          (block fixed-fields
            (unless (lexer-match #\-)
              (return-from fixed-fields))
            (setq month (get-field 2))
            (unless (lexer-match #\-)
              (return-from fixed-fields))
            (setq day (get-field 2))
            (unless (lexer-match " T")
              (return-from fixed-fields))
            (setq hour (get-field 2))
            (setq allow-zone-p t)
            (unless (lexer-match #\:)
              (return-from fixed-fields))
            (setq minute (get-field 2))
            (unless (lexer-match #\:)
              (return-from fixed-fields))
            (setq sec (get-field 2))
            (unless (lexer-match #\.)
              (return-from fixed-fields))
            (setq msec (get-field 3)))
          (when allow-zone-p (%parse-zone))
          (unless (= lexer-position lexer-end)
            (lexer-error)))
        (values (and year (encode-local-time msec sec minute hour day month year zone))
                (the array-index (+ (the array-index start) (lexer-relative-position))))))))

(set-macro-character
 #\@ #'(lambda (stream character)
         (declare (ignore character))
         (loop with char of-type character = #\@
               with string = (make-buffer 32 'character)
               do (setq char (peek-char nil stream nil #\@ nil))
               while (char-of-class-p char '(or "-:.+" alphanumeric))
               do (vector-push-extend (read-char stream) string)
               finally (return (parse-timestring string)))))

(defun local-time-day-of-week (local-time)
  (let ((day (local-time-day (normalize-local-time local-time))))
    (declare (fixnum day)) (mod (the fixnum (+ 3 day)) 7)))

(defun day-name (day-of-week)
  (svref #("Sunday" "Monday"
           "Tuesday" "Wednesday"
           "Thursday" "Friday"
           "Saturday") day-of-week))

(defun %print-date-part (stream name &optional colon-p at-sign-p)
  (declare (ignore at-sign-p) (optimize (safety 0) (speed 3)))
  (write-simple-string name stream 0 (if colon-p 3 nil)))

(defun print-day-name (stream day-of-week &optional colon-p at-sign-p)
  (%print-date-part stream (day-name day-of-week) colon-p at-sign-p))

(defun month-name (month-number)
  (svref #("Invalid-Month"
           "January"
           "February"
           "March"
           "April"
           "May"
           "June"
           "July"
           "August"
           "September"
           "October"
           "November"
           "December")
           month-number))

(defun print-month-name (stream month-number &optional colon-p at-sign-p)
  (%print-date-part stream (month-name month-number) colon-p at-sign-p))

(defun 822-time (stream local-time &optional colon-p at-sign-p)
  (multiple-value-bind (msec sec minute hour day month year)
      (decode-local-time local-time)
    (declare (ignore msec))
    (let ((date-separator (if colon-p #\- #\Space)))
      (format stream "~:/kira:print-day-name/, ~
                      ~2,'0D~C~:/kira:print-month-name/~
                      ~C~D ~2,'0D:~2,'0D:~2,'0D "
              (local-time-day-of-week local-time)
              day date-separator month date-separator
              year hour minute sec))
    ;; AT-SIGN-P disables "GMT" notation.
    (let ((zone (local-time-zone local-time)))
      (print-zone stream zone (not at-sign-p)))))

(defun get-localized-time (&optional (local-time (get-local-time)))
  (setq local-time (copy-local-time (normalize-local-time local-time)))
  (locally (declare (optimize (safety 0) (speed 3)) (type local-time local-time))
    (let ((sec (local-time-sec local-time)) (zone (local-time-zone local-time)))
      (cond ((not (require-type zone '(or null (signed-byte 24)))) local-time)
            (t (let* ((minutes-west (get-timezone (unix-time local-time)))
                      (new-zone (- (the fixnum (* 60 minutes-west))))
                      (new-sec (+ (the fixnum (- sec zone)) new-zone)))
                 (declare (type fixnum minutes-west new-sec new-zone))
                 (setf (local-time-zone local-time) new-zone)
                 (setf (local-time-sec local-time) new-sec)
                 (normalize-local-time local-time)))))))

(defun print-local-time (local-time &optional stream)
  (multiple-value-bind (msec sec minute hour day month year) (decode-local-time local-time)
    (declare (ignore msec) (type (integer 0 #.most-positive-fixnum) sec minute hour day month year))
    (format stream "~D-~:@(~:/kira:print-month-name/~)-~D ~2,'0D:~2,'0D:~2,'0D" day month year hour
            minute sec)))