timecalc/logic.lisp

(defpackage :timecalc-logic
  (:use :cl)
  (:local-nicknames (:jzon :com.inuoe.jzon))
  (:import-from :cl-ppcre
                :regex-replace-all)
  (:export

   :agetf
   :load-models
   :convert
   :save-model
   :reload-models))

(in-package :timecalc-logic)

(defparameter *models* (make-hash-table :test 'equal)
  "hash-table holding our loaded models")
(defvar *default-model* nil
  "dummy model used for default values in other models")
(defvar *load-dir* nil)

(defun agetf (key alist &optional default)
  (or (cdr (assoc key alist :test #'equal))
      default))

(defun opts-ensure-directory (dir)
  "ensures that DIR ends with a slash -- used in our unix-opts definition"
  (if (str:ends-with-p "/" dir)
      dir
      (concatenate 'string dir "/")))

(defun reload-models (&optional directory)
  "reloads system definitions from *LOAD-DIR* (directory passed into binary with -l option)

if DIRECTORY is non-nil we wipe out *LOAD-DIR* and set it to DIRECTORY"
  (when directory
    (setf *load-dir* directory))
  
  (load-models (uiop:directory-files *load-dir*)
               :clear-before-load t))

(defun load-models (files &key clear-before-load)
  "loads model FILES into memory"
  (when clear-before-load
    (setf *models* (make-hash-table :test 'equal)))
  
  (loop :for f :in files
        :for model := (jzon:parse f)

        :if (gethash "useAsDefault" model)
          :do
             (setf *default-model* model)
             
        :else
          :do
             (setf (gethash (gethash "key" model) *models*)
                   model)))

(defun save-model (new-model)
  (let ((filename (concatenate 'string
                               (namestring *load-dir*) "/"
                               (gethash "key" new-model)
                               ".system")))
    (with-open-file (out filename
                         :direction :output
                         :if-does-not-exist :create
                         :if-exists :supersede)
      (jzon:stringify new-model :stream out :pretty t))))

(defun get-model (key-or-name)
  (let ((model-key (gethash key-or-name *models*))
        (name-key (loop :for m :being :the :hash-value :of *models*
                        :when (string= (gethash "name" m "") key-or-name)
                          :return m)))
    (or model-key name-key)))

(defun get-model-value (key model)
  (gethash key model (gethash key *default-model*)))

(defun convert (time from to)
  (let ((from-model (get-model from))
        (to-model (get-model to)))
    (unless from-model
      (error "FROM system doesn't exist"))
    (unless to-model
      (error "TO system doesn't exist"))
    
    (when (equal from to)
      (return-from convert time))

    (let ((gts-secs (coerce (floor (rationalize (to-gts (timestring-to-seconds time from-model)
                                                        from-model to-model)))
                            'integer)))
      (create-timestring from-model to-model gts-secs))))

;; gts orbital cycle is 100 years
;; round fractional seconds
;; if not usesGalacticSecond then divide by 1.4
(defun timestring-to-seconds (timestring system)
  (let* ((parts (str:split #\: (regex-replace-all "[a-z]" (string-downcase timestring) "")))
         (cycles (if (get-model-value "usesCycles" system)
                     (parse-integer (pop parts)) 0)))
    (destructuring-bind (years days hours minutes seconds) (mapcar #'parse-integer parts)
      (let ((seconds-conversion (get-model-value "secondsInMinute" system)))
        (+ seconds
           (* minutes seconds-conversion)
           (* (* hours (get-model-value "minutesInHour" system))
              seconds-conversion)
           (* seconds-conversion
              (* (get-model-value "minutesInHour" system)
                 (* (get-model-value "hoursInDay" system)
                    (1- days))))
           (* (+ (1- years) (* 100 cycles))
              (get-model-value "secondsInYear" system)))))))


(defun create-timestring (from-system to-system seconds)
  (apply #'format
         `(nil "y~A:d~A:~A:~A:~A" ;; ,(if (get-model-value "usesCycles" to-system) ;;
                                  ;;      "c~A:y~A:d~A:~A:~A:~A"                   ;;
                                  ;;      "y~A:d~A:~A:~A:~A")                      ;;
               ,@(apply #'funky
                        `(,(to-target seconds from-system to-system)
                          ,@(loop :for key :in '("secondsInYear" "daysInYear" "hoursInDay"
                                                 "minutesInHour" "secondsInMinute")
                                  :collect (get-model-value key to-system)))))))

(labels ((uses-galactic-second-p (system)
           (get-model-value "usesGalacticSecond" system))
         (needs-conversion-p (from to)
           (not (and (uses-galactic-second-p to)
                     (uses-galactic-second-p from)))))
  
  (defun to-target (gts-secs from-system to-system)
    (let ((secs gts-secs))
      (+ (- secs (gethash-nested to-system "yearZero" "galactic"))
         (gethash-nested to-system "yearZero" "local"))))

  (defun to-gts (local-secs from-system to-system)
    "Converts the local seconds to GTS seconds"
    (let ((secs (if (needs-conversion-p from-system to-system)
                    (if (uses-galactic-second-p from-system)
                        (/ local-secs 1.4)
                        (* local-secs 1.4))
                    local-secs)))
      (+ (- secs (gethash-nested from-system "yearZero" "local"))
         (gethash-nested from-system "yearZero" "galactic")))))

(defun funky (seconds &rest divisors)
  (let ((secs (coerce (floor seconds) 'integer)))
    (when divisors
      (multiple-value-bind (ipart fpart) (truncate (/ secs (car divisors)))
        (cons ipart (apply #'funky `(,fpart ,@(cdr divisors))))))))

(defun gethash-nested (hash-table &rest keys)
  (if (cdr keys)
      (apply #'gethash-nested
               `(,(gethash (car keys) hash-table)
                 ,@(cdr keys)))
      (gethash (car keys) hash-table)))