;;; SPDX-FileCopyrightText: 2026 Matthew Fennell <matthew@fennell.dev>
;;;
;;; SPDX-License-Identifier: AGPL-3.0-or-later

;;; General

(define (cartesian-product . lists)
  (fold-right
   (lambda (xs ys)
     (append-map
      (lambda (x) (map (lambda (y) (cons x y)) ys)) xs)) '(()) lists))

(define (days-after base-date min-lookahead-days)
  (unfold (cut = <> min-lookahead-days) (cut date+ base-date <>) 1+ 0))

(define* (api-request #:key method path (query #f) (request #f) (transformer identity) (token #f))
  (let*-values
      (((record-name)
	(delay
	  (string-filter
           (lambda (c) (or (char-alphabetic? c) (eq? c #\-)))
           (symbol->string (record-type-name (record-type-descriptor request))))))
       ((json)
	(delay
	  (local-eval
           `(,(string->symbol
               (string-append (force record-name) "->json")) request)
           (the-environment))))
       ((base-headers) '((content-type . (application/json))
			 (origin . "https://myaccount.better.org.uk")))
       ((auth-header) (delay `(Authorization . ,(string-append "Bearer " token))))
       ((request-headers) (if token (cons (force auth-header) base-headers) base-headers))
       ((request-body) (if request (force json) #f))
       ((host) "better-admin.org.uk")
       ((response-header response-body-utf8)
	(http-request
	 (build-uri
          'https
          #:host host
          #:path path
          #:query query)
	 #:method method
	 #:body request-body
	 #:headers request-headers))
       ((response-body) (utf8->string response-body-utf8))
       ((response-error-message) (delay (error-response-message (json->error-response response-body))))
       ((exception)
	(make-exception (make-external-error)
			(make-exception-with-origin request-body)
			(make-exception-with-irritants
                         `(,response-header ,response-body)))))
    (log-msg 'REQUEST method " " "https://" host path "/" (or query ""))
    (log-msg 'DEBUG "Headers: " response-header)
    (log-msg 'SENSITIVE "Response: " response-body)
    (case (response-code response-header)
      ((200) (let ((result (transformer response-body)))
               (log-msg 'SENSITIVE "Result: " result)
               result))
      ((422) (cond ((string-contains (force response-error-message) "The date should be within the valid days") #f)
                   ((string-contains (force response-error-message) "You have already booked a session for this time") #t)
                   (else (raise-exception exception))))
      (else (raise-exception exception)))))

(define fake-score
  (let* ((fake-date (make-date 0 0 0 0 0 0 0 0))
         (fake-booking (make-booking 'fake-venue 'fake-activity fake-date fake-date)))
    `(,fake-booking ,(-(inf)))))

;;; Dates

(define dates #(sun mon tue wed thu fri sat))

(define (date->day-name date)
  ((compose week-day->day-name date-week-day) date))

(define (week-day->day-name index)
  (vector-ref dates index))

(define (day-name->week-day name)
  (list-index (lambda (d) (eq? d name)) (vector->list dates)))

(define (date-date date)
  (make-date 0 0 0 0
             (date-day date)
             (date-month date)
             (date-year date)
             (date-zone-offset date)))

(define (date-time date)
  (make-date 0 0
             (date-minute date)
             (date-hour date)
             0 0 0 0))

(define (10pm-adjusted-date date)
  (let ((date-offset (if (> (date-hour date) 22) 1 0)))
    (date+ (current-date) date-offset)))

(define (this day-name)
  (log-msg 'DEBUG "Calculating next " day-name)
  (let* ((current-date (10pm-adjusted-date (current-date)))
         (current-week-day (date-week-day current-date))
         (target-week-day (day-name->week-day day-name))
         (days-ahead (mod (- target-week-day current-week-day) 7))
         (target-date (date+ current-date days-ahead)))
    (log-msg 'DEBUG "Including 10pm offset, current date is " (date->api-string current-date) ", which is " (week-day->day-name current-week-day))
    (log-msg 'DEBUG "Target date " day-name " is " days-ahead " days ahead of " (week-day->day-name current-week-day))
    (log-msg 'DEBUG "Therefore " (date->api-string current-date) " + " days-ahead " days = " ((compose date->api-string date-date) target-date))
    (date-date target-date)))

(define (date->api-string date)
  (date->string date "~1"))

(define (time->api-string date)
  (date->string date "~H:~M"))

(define (api-string->date date-str)
  (string->date date-str "~Y-~m-~d"))

(define (api-string->time time-str)
  (string->date (string-append "1970-01-01 " time-str) "~Y-~m-~d ~H:~M"))

(define (date<? date1 date2)
  (time<? (date->time-utc date1) (date->time-utc date2)))

(define (date<=? date1 date2)
  (time<=? (date->time-utc date1) (date->time-utc date2)))

(define (date>=? date1 date2)
  (time>=? (date->time-utc date1) (date->time-utc date2)))

(define (date+ date days)
  (let ((duration-to-add (make-time time-duration 0 (* days 24 60 60)))
        (date-time (date->time-utc (date-date date))))
    ((compose date-date time-utc->date) (add-duration date-time duration-to-add))))

(define (score>? score1 score2)
  (> (second score1) (second score2)))

(define (max-score score1 score2)
  (if (score>? score1 score2) score1 score2))

;;; Scorer helpers

(define (between-hours? booking between-start-str between-end-str)
  (let ((booking-start ((compose date-time booking-start) booking))
        (booking-end ((compose date-time booking-end) booking))
        (between-start ((compose date-time api-string->time) between-start-str))
        (between-end ((compose date-time api-string->time) between-end-str)))
    (and (date>=? booking-start between-start) (date<=? booking-end between-end))))

(define (booking-end<? booking1 booking2)
  (date<? (booking-end booking1) (booking-end booking2)))

(define (badminton-60min? booking)
  (eq? (booking-activity booking) 'badminton-60min))

(define (sat? booking)
  (eq? ((compose date->day-name booking-start) booking) 'sat))