;; SPDX-FileCopyrightText: 2026 Andrew Oberstar <andrew@ajoberstar.org>
;; SPDX-License-Identifier: AGPL-3.0-only

(in-package #:org.ajoberstar.quixote.dates)

;; 2000-01-01 was a Saturday so with ordinal 1 being that day, this is easiest when we calculate remainders
(defparameter days-of-week (vector :friday :saturday :sunday :monday :tuesday :wednesday :thursday))

(defparameter month-names (vector "" "January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December"))

(defun month-name (month)
  (elt month-names month))

(defun day-name (day)
  (format nil "~D~A" day
          (if (<= 11 (mod day 100) 19)
              "th"
              (case (mod day 10)
                (1 "st")
                (2 "nd")
                (3 "rd")
                (t "th")))))

(defun leap-year-p (year)
  (declare (type integer year))
  (and (zerop (rem year 4))
       (or (not (zerop (rem year 100)))
           (zerop (rem year 400)))))

(defun days-in-year (year)
  (if (leap-year-p year)
      366
      365))

(defun days-in-month (year month)
  (declare (type integer month))
  (case month
    ((1 3 5 7 8 10 12) 31)
    ((4 6 9 11) 30)
    (2 (if (leap-year-p year) 29 28))
    (t (error "Invalid month: ~d" month))))

(defun day-of-year (year month day)
  (declare (type integer year month day))
  (+ day
     (loop for m from 1 upto (1- month)
           sum (days-in-month year m))))

(defun ordinal (year month day)
  (declare (type integer year month day))
  (+ (day-of-year year month day)
     (cond
       ((> year 2000)
        (loop for y from 2000 upto (1- year)
              sum (days-in-year y)))
       ((< year 2000)
        (- (loop for y from year upto 1999
                 sum (days-in-year y))))
       (t 0))))

(defun ymd (ordinal)
  (declare (type integer ordinal))
  (let ((remaining ordinal)
        (year 2000)
        (month 1))
    (if (plusp remaining)
        (loop for y from year
              for days = (days-in-year y)
              until (<= remaining days)
              do (decf remaining days)
              finally (setf year y))
        (loop for y downfrom (1- year)
              for days = (days-in-year y)
              until (plusp remaining)
              do (incf remaining days)
              finally (setf year (1+ y))))
    (loop for m from month
          for days = (days-in-month year m)
          do (setf month m)
          until (<= remaining days)
          do (decf remaining days))
    (list year month remaining)))

(defclass date ()
  ((ordinal :initarg :ordinal :type integer :reader date-ordinal)
   (year :initarg :year :type integer :reader date-year)
   (month :initarg :month :type integer :reader date-month)
   (day :initarg :day :type integer :reader date-day)))

(defun make-date (year month day)
  ;; not dealing with anything weird
  (unless (<= -10000 year 2099)
    (error "Invalid year: ~d" year))
  (unless (<= 1 month 12)
    (error "Invalid month: ~d" month))
  (unless (<= 1 day (days-in-month year month))
    (error "Invalid day: ~d" day))
  (make-instance 'date :ordinal (ordinal year month day) :year year :month month :day day))

(defparameter minimum-date (make-date -10000 1 1))

(defparameter maximum-date (make-date 2099 12 31))

(defparameter minimum-ordinal (date-ordinal minimum-date))

(defparameter maximum-ordinal (date-ordinal maximum-date))

(defun make-date-ordinal (ordinal)
  (unless (<= minimum-ordinal ordinal maximum-ordinal)
    (error "Invalid ordinal: ~d" ordinal))
  (let ((ymd (ymd ordinal)))
    (make-instance 'date :ordinal ordinal
                         :year (first ymd)
                         :month (second ymd)
                         :day (third ymd))))

(defmethod print-object ((obj date) stream)
  (print-unreadable-object (obj stream :type t)
    (write-iso-date stream obj)))

(defun date-leap-year-p (date)
  (declare (type date date))
  (leap-year-p (date-year date)))

(defun date-day-of-year (date)
  (declare (type date date))
  (day-of-year (date-year date)
               (date-month date)
               (date-day date)))

(defun date-dow (date)
  (declare (type date date))
  (elt days-of-week
       (mod (date-ordinal date) 7)))

(defun date-month-name (date)
  (declare (type date date))
  (month-name (date-month date)))

(defun date-day-name (date)
  (declare (type date date))
  (day-name (date-day date)))

(defun date-diff (date1 date2)
  (declare (type date date1 date2))
  (- (date-ordinal date1)
     (date-ordinal date2)))

(defmacro date-op (op date1 date2)
  `(,op
     (date-ordinal ,date1)
     (date-ordinal ,date2)))

(defun date< (date1 date2)
  (declare (type date date1 date2))
  (date-op < date1 date2))

(defun date<= (date1 date2)
  (declare (type date date1 date2))
  (date-op <= date1 date2))

(defun date= (date1 date2)
  (declare (type date date1 date2))
  (date-op = date1 date2))

(defun date> (date1 date2)
  (declare (type date date1 date2))
  (date-op > date1 date2))

(defun date>= (date1 date2)
  (declare (type date date1 date2))
  (date-op >= date1 date2))

(defun date-1+ (date)
  (declare (type date date))
  (cond
    ((< (date-day date) (days-in-month (date-year date)
                                       (date-month date)))
     (make-date (date-year date)
                 (date-month date)
                 (1+ (date-day date))))
    ((< (date-month date) 12)
     (make-date (date-year date) (1+ (date-month date)) 1))
    (t
     (make-date (1+ (date-year date)) 1 1))))

(defun date-1- (date)
  (declare (type date date))
  (cond
    ((< 1 (date-day date))
     (make-date (date-year date)
                 (date-month date)
                 (1- (date-day date))))
    ((< 1 (date-month date))
     (make-date (date-year date)
                (1- (date-month date))
                (days-in-month (date-year date)
                               (1- (date-month date)))))
    (t
     (make-date (1- (date-year date)) 12 31))))


(defun date+ (date days)
  (declare (type date date))
  (declare (type integer days))
  (make-date-ordinal (+ (date-ordinal date) days)))

(defun date- (date days)
  (make-date-ordinal (- (date-ordinal date) days)))

(defun date-next (date dow &optional (n 1))
  (declare (type date date))
  (declare (type keyword dow))
  (declare (type integer n))
  (let* ((dest-pos (position dow days-of-week))
         (curr-pos (mod (date-ordinal date) 7))
         (delta (if (< curr-pos dest-pos)
                    (- dest-pos curr-pos)
                    (+ (- 7 curr-pos) dest-pos))))
    (date+ date (+ delta (* (1- n) 7)))))

(defun date-prev (date dow &optional (n 1))
  (declare (type date date))
  (declare (type keyword dow))
  (declare (type integer n))
  (let* ((dest-pos (position dow days-of-week))
         (curr-pos (mod (date-ordinal date) 7))
         (delta (if (<= dest-pos curr-pos)
                    (- curr-pos dest-pos)
                    (+ (- 7 dest-pos) curr-pos))))
    (date- date (+ delta (* (1- n) 7)))))

(defun date-start-of-year (date)
  (make-date (date-year date) 1 1))

(defun date-quarter-month (date)
  (1+ (* 3 (1- (ceiling (/ (date-month date) 3))))))

(defun date-start-of-quarter (date)
  (make-date (date-year date) (date-quarter-month date) 1))

(defun date-start-of-month (date)
  (make-date (date-year date) (date-month date) 1))

(defun parse-iso-date (string)
  (when string
    (let* ((tpos (position #\T string))
           (datestr (if tpos
                        (subseq string 0 tpos)
                        string))
           (parts (uiop:split-string datestr :separator "-"))
           (bce nil))
      (when (and (or (= (length parts) 4)
                     (= (length parts) 2))
                 (zerop (length (first parts))))
        (pop parts)
        (setf bce t))

      (cond
        ((zerop (length string))
         nil)
        ((= (length parts) 1)
         (make-date (let ((year (parse-integer (first parts))))
                      (if bce (- year) year))
                    1
                    1))
        (t
         (unless (= (length parts) 3)
           (error "Invalid ISO date: ~A" string))
         (make-date
          (let ((year (parse-integer (first parts))))
            (if bce (- year)  year))
          (parse-integer (second parts))
          (parse-integer (third parts))))))))

(defun parse-us-date (string)
  (when string
    (let ((parts (uiop:split-string string :separator "/")))
      (unless (= (length parts) 3)
        (error "Invalid US date: ~A" string))
      (make-date
       (parse-integer (third parts))
       (parse-integer (first parts))
       (parse-integer (second parts))))))

(defun parse-dmy-date (string)
  (when string
    (let ((parts (reverse (uiop:split-string string :separator '(#\Space #\/)))))
      (if (or (< (length parts) 1) (< 3 (length parts)))
        (error "Invalid DMY date"))

      (make-date
       (parse-integer (pop parts))
       (let ((month-part (pop parts)))
         (or (and (null month-part) 1)
             (position month-part month-names :test #'equalp)
             (parse-integer month-part)))
       (let ((day-part (pop parts)))
         (or (and (null day-part) 1)
             (parse-integer day-part)))))))

(defun parse-mdy-date (string)
  (when string
    (let ((parts (uiop:split-string string :separator '(#\Space #\/))))
      (unless (= 3 (length parts))
        (error "Invalid MDY date"))

      (make-date
       (parse-integer (third parts))
       (let ((month-part (first parts)))
         (or (position month-part month-names :test #'equalp)
             (parse-integer month-part)))
       (parse-integer (second parts) :junk-allowed t)))))

(defun parse-lax-date (string)
  (loop for parser in (list #'parse-iso-date #'parse-dmy-date #'parse-mdy-date)
        for date = (handler-case (funcall parser string)
                     (error () nil))
        when date
          return date))

(defun write-iso-date (stream date)
  (declare (type date date))
  (format stream "~A~4,'0d-~2,'0d-~2,'0d"
          (if (minusp (date-year date)) "-" "")
          (abs (date-year date))
          (date-month date)
          (date-day date)))

(defun write-us-date (stream date)
  (declare (type date date))
  (format stream "~2,'0d/~2,'0d/~4,'0d~A"
          (date-month date)
          (date-day date)
          (if (plusp (date-year date))
              (date-year date)
              (1+ (abs (date-year date))))
          (if (plusp (date-year date))
              ""
              " BC")))

(defun write-human-date (stream date)
  (declare (type date date))
  (format stream "~A ~D, ~D~A"
          (month-name (date-month date))
          (date-day date)
          (if (plusp (date-year date))
              (date-year date)
              (1+ (abs (date-year date))))
          (if (plusp (date-year date))
              ""
              " BC")))

(defun today ()
  (multiple-value-bind (second minute hour day month year)
      (get-decoded-time)
    (declare (ignore second minute hour))
    (make-date year month day)))
