French Republican Calender and 20-hour clock in Scheme

fr-cal.scm

#!/usr/bin/env -S guile -q -s
!#

(define (fr-date equinox timestamp)
  (define +fr-epoch+ -5594234524)

  (define +months+
    '(Vendemiaire Brumaire Frimaire
      Nivose Pluviose Ventose
      Germinal Floreal Prairial
      Messidor Thermidor Fructidor))

  (define +culottides+
    '("de la Vertu" "du Génie" "du Travail"
      "de l'Opinion" "des Récompenses" "de la Revolution"))

  ;; TODO: when equinox in past year, error
  (when (< timestamp equinox)
    (error "Autumnal equinox set in the future!"))

  (let ((year  (+ (inexact->exact (floor (/ (- equinox +fr-epoch+)
                                            (* 60 60 24 365.24)))) 1))
        (year-day (inexact->exact (floor (/ (- timestamp equinox)
                                            (* 60 60 24))))))
    (if (< year-day 360)
        (let ((day   (+ 1 (modulo year-day 30)))
              (month (inexact->exact (floor (/ year-day 30)))))
          (list day (list-ref +months+ month) year))
        (string-append "La Fête "
          (list-ref +culottides+
                    (- year-day 360))))))

(define (fr-date* timestamp)
  (let* ((year (+ (inexact->exact (floor (/ timestamp
                                            (* 365.24 24 60 60))))
                  1970))
         (equinox-this-year (autumnal-equinox year))
         (equinox (if (< timestamp equinox-this-year)
                      (autumnal-equinox (- year 1))
                      equinox-this-year)))
    (fr-date (midnight equinox) timestamp)))

(define (midnight equinox)
  (* 86400 (floor (/ equinox 86400))))

(define (autumnal-equinox year)
  "Meeus, page 177, table 27.B: years 1000 to 3000"
  ;; TODO: Adjust for Paris long
  (let*
    ((Y    (/ (- year 2000) 1000))
     (JDE0 (+ 2451810.21715
              (* 365242.01767 Y)
              (* -0.11575  (expt Y 2))
              (* +0.00337  (expt Y 3))
              (* +0.00078  (expt Y 4)))))
    (floor (+ (* (- JDE0 2440587.5) 86400)))))

(define (bidecimal-time timestamp)
    "1d = 2×10h = 100m = 100s"
    (let* ((day-secs  (modulo timestamp (* 24 60 60)))
           (day-frac  (/ day-secs (* 24 60 60)))
           (20h-clock (* day-frac 20))
           (10h-clock (if (< 20h-clock 10)
                          (cons 20h-clock 'DM)
                          (cons (- 20h-clock 10) 'DE)))
           (hour (floor (car 10h-clock)))
           (mins (floor (* (- (car 10h-clock) hour) 100))))
      (list hour mins (cdr 10h-clock))))




(use-modules (ice-9 format)
             (ice-9 string-fun))

(define (pad2 n)
      (let* ((r (remainder n 100))
             (s (number->string (+ r 100))))
        (substring s 1 3)))
            
(define (format-date ts)
  (string-join
    (map (lambda (x) (format #f "~a" x))
         (fr-date* ts))
    " "))

(define (format-time ts)
  (let ((time (bidecimal-time ts)))
    (string-join (map (lambda (x) (format #f "~a" x))
                      (list (car time) "." (pad2 (cadr time))
                            " " (caddr time))) "")))

(define (format-datetime ts)
  (string-join (list (format-date ts)
                     (format-time ts))
               "—"))

(display (format-datetime (current-time)))
(newline)