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

(defun leap-year-p (year)
  (declare (type integer year))
  ;; This is OK with our constraints of 2000-2099
  (zerop (rem year 4)))

(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)
     (loop for y from 2000 upto (1- year)
           sum (days-in-year y))))

(defun ymd (ordinal)
  (declare (type integer ordinal))
  (let ((remaining ordinal)
        (year 2000)
        (month 1))
    (loop for y from year
          for days = (days-in-year y)
          do (setf year y)
          until (<= remaining days)
          do (decf remaining days))
    (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 (<= 2000 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 2000 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
       (rem (date-ordinal date) 7)))

(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 eq 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 (rem (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 (rem (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)
  (declare (type string string))
  (let* ((tpos (position #\T string))
         (datestr (if tpos
                      (subseq string 0 tpos)
                      string))
         (parts (uiop:split-string datestr :separator "-")))
    (unless (eq (length parts) 3)
      (error "Invalid ISO date: ~A" string))
    (make-date
     (parse-integer (first parts))
     (parse-integer (second parts))
     (parse-integer (third parts)))))

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

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

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