;;;; -*-  Mode: LISP; Syntax: Common-Lisp; Base: 10                          -*-
;;;; ---------------------------------------------------------------------------
;;;; File name: utils.lsp
;;;;    System: fIRE
;;;;   Version: 1.0
;;;;    Author: Leo C. Ureel II
;;;;   Created: November 18, 2003 15:54:12
;;;;   Purpose: general utilities
;;;; ---------------------------------------------------------------------------
;;;;  Modified: Monday, June 7, 2004 at 10:01:30 by hinrichs
;;;; ---------------------------------------------------------------------------
(in-package :fire)

;;;; MapArray - 20040109 ureel
;;;; ---------------------------------------------------------------------------
;;;; Should this be a macro?
(defun map-array (a fn &aux (dim (array-dimensions a)))
  "Iterates fn over an array."
  (map-subarray a fn nil dim))

(defun map-subarray (a fn indices dim)
  (if dim
    (dotimes (i (first dim))
      (map-subarray a fn (append indices (list i)) (rest dim)))
    (apply fn (list (apply #'aref (cons a indices)) a indices))))

;;;; Date Stuff
;;;; ---------------------------------------------------------------------------
(defun list-day-names ()
  '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))

(defun day-name (day &optional abbreviate-p)
  (if abbreviate-p
    (subseq (nth day (list-day-names)) 0 3)
    (nth day (list-day-names))))

(defun list-month-names ()
  '("January" "February" "March" "April" "May" "June"
    "July" "August" "September" "October" "November" "December"))

(defun month-name (month &optional abbreviate-p)
  (if abbreviate-p
    (subseq (nth (- month 1) (list-month-names)) 0 3)
    (nth (- month 1) (list-month-names))))

(defmethod date* (stream (universal-time integer) 
                         colon-modifier atsign-modifier 
                         &optional (separator #\/) &rest args)
  (multiple-value-bind 
        (seconds minutes hour day month year 
                 day-of-week daylight-saving-time-p time-zone)
      (decode-universal-time universal-time)
    (declare (ignore seconds minutes hour daylight-saving-time-p
                     time-zone))
    (cond ((and colon-modifier atsign-modifier) 
           (format stream "~A, ~A ~D, ~D" 
             (day-name day-of-week) (month-name month) day year))
          (colon-modifier 
           (format stream "~A ~D, ~D" 
             (month-name month) day year))
          (atsign-modifier 
           (format stream "~2,'0D~C~A~C~D" 
             day separator (month-name month t) separator year))
          (t 
           (format stream "~2,'0D~C~2,'0D~C~D" 
             month separator day separator year))))
  nil)

(defun concise-date-string ()
  (multiple-value-bind (second minute hour day month year)
      (get-decoded-time)
    (declare (ignore second minute hour))
    (format nil "~A/~A/~A" month day year)))

;;;; Time Stuff
;;;; ---------------------------------------------------------------------------

(defun list-timezone-names ()
  '("GMT-12" "GMT-11" "GMT-10" "GMT-9" "GMT-8" "GMT-7"
    "GMT-6" "GMT-5" "GMT-4" "GMT-3" "GMT-2" "GMT-1"
    "GMT" "GMT+1" "GMT+2" "GMT+3" "Atlantic" "Eastern" "Central" 
    "Mountain" "Pacific" "Alaska" "Hawaii" "GMT+11" "GMT+12"))

(defun timezone-name (timezone)
  (nth (+ timezone 12) (list-timezone-names)))

(defun post-meridian-p (hour)
  (> hour 11))

(defmethod time* (stream (universal-time integer) 
                         colon-modifier atsign-modifier 
                         &optional (separator #\:) &rest args)
  (multiple-value-bind 
        (seconds minutes hour day month year 
                 day-of-week daylight-saving-time-p time-zone)
      (decode-universal-time universal-time)
    (declare (ignore day month year day-of-week daylight-saving-time-p))
    (let ((am/pm (if (post-meridian-p hour) "pm" "am"))
          (twelve-hour (if (> hour 12) (- hour 12) hour)))
      (cond ((and colon-modifier atsign-modifier) 
             (format stream "~2,'0D~C~2,'0D~C~2,'0D ~A" 
               hour separator minutes separator seconds 
               (timezone-name time-zone)))
            (colon-modifier 
             (format stream "~2,'0D~C~2,'0D~C~2,'0D ~A ~A" 
               twelve-hour separator minutes separator seconds am/pm 
               (timezone-name time-zone)))
            (atsign-modifier
             (format stream "~2,'0D~C~2,'0D~C~2,'0D ~A" 
               twelve-hour separator minutes separator seconds am/pm))
            (t 
             (format stream "~2,'0D~C~2,'0D~C~2,'0D" 
               hour separator minutes separator seconds)))))
  nil)

;;;; Time Examples:
;;;;
;;;; (format t "~&DATE: ~/DATE*/" (get-universal-time))
;;;; (format t "~&DATE: ~@/DATE*/" (get-universal-time))
;;;; (format t "~&DATE: ~:/DATE*/" (get-universal-time))
;;;; (format t "~&DATE: ~:@/DATE*/" (get-universal-time))
;;;; (format t "~&TIME: ~/TIME*/" (get-universal-time))
;;;; (format t "~&TIME: ~:/TIME*/" (get-universal-time))
;;;; (format t "~&TIME: ~@/TIME*/" (get-universal-time))
;;;; (format t "~&TIME: ~:@/TIME*/" (get-universal-time))

(defun concise-time-string ()
   "Return the time in the format HH:MM:SS."
   (multiple-value-bind (second minute hour)
       (get-decoded-time)
      (format nil "~A:~A:~A" hour minute second)))

;; Slightly tricky to avoid capture of values with nested timings
;; [Which will be thrown off by printing times, but just in case.]
(defmacro with-recorded-real-time (operation-name form)
   (let ((op-name-start-var (intern (format nil "~A-START" operation-name)
                              (find-package :cl-user)))
         (op-name-end-var (intern  (format nil "~A-END" operation-name)
                              (find-package :cl-user)))
         (op-name-value (intern  (format nil "~A-VALUE" operation-name)
                                (find-package :cl-user))))
         `(let ((,op-name-end-var 0)
                (,op-name-start-var 0)
                (,op-name-value nil))
             (format *debug-io* "~%~A started ~A." ,operation-name (concise-time-string))
             (setq ,op-name-start-var (get-internal-real-time))
             (setq ,op-name-value ,form)
             (setq ,op-name-end-var (get-internal-real-time))
             (format *debug-io* "~%~A ended ~A (~A seconds)."
               ,operation-name (concise-time-string)
               (/ (- ,op-name-end-var ,op-name-start-var)
                  (float internal-time-units-per-second)))
             (format *debug-io* "~%~A ~A Results" ,operation-name
               (if (listp ,op-name-value) (length ,op-name-value)
                  ,op-name-value))
            ,op-name-value)))


;;;;
;;;; Time Functions from knowledge-entry-api
;;;; These are used in all the logging and metadata capture routines.

(defun universal-time->cyc-seconds ()
  (multiple-value-bind 
        (seconds minutes hour day month year 
                 day-of-week daylight-saving-time-p time-zone)
      (get-decoded-time)
    (declare (ignore day month year day-of-week daylight-saving-time-p time-zone))
    (+ seconds (* 100 minutes) (* 10000 hour))))

(defun universal-time->cyc-time ()
  (multiple-value-bind 
        (seconds minutes hour day month year 
                 day-of-week daylight-saving-time-p time-zone)
      (get-decoded-time)
    (declare (ignore seconds minutes hour day-of-week daylight-saving-time-p time-zone))
    (+ day (* 100 month) (* 10000 year))))


;;;; ---------------------------------------------------------------------------
;;;; End of Code