;; Copyright (c) 2003-2005 Edward Marco Baringer
;; All rights reserved. 
;; 
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;; 
;;  - Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 
;;  - Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 
;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
;;    of its contributors may be used to endorse or promote products
;;    derived from this software without specific prior written permission.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


(in-package :org.unknownlamer.ucw-im)

(defvar *time-months*
  '(("January" "Jan")
    ("February" "Feb")
    ("March" "Mar")
    ("April" "Apr")
    ("May" "May")
    ("June" "Jun")
    ("July" "Jul")
    ("August" "Aug")
    ("September" "Sep")
    ("October" "Oct")
    ("November" "Nov")
    ("December" "Dec")))

(defvar *time-zones*
  (iter
    (for i from -12 to 12 by 1/2)
    (collect i)))

(defvar *time-ampm*
  '(am pm))

(defun time-months (&optional abbrevp)
  (let ((idx 0))
    (mapcar #'(lambda (m)
                (cons (incf idx) (funcall (if abbrevp #'second #'first) m)))
            *time-months*)))

(defvar *time-element-fns*
  (flet ((init-year (time
                     &key (year-min 1960) (year-max 2010) &allow-other-keys)
           (setf (min-value (slot-value time 'year)) year-min
                 (max-value (slot-value time 'year)) year-max))
         (init-zone (time &key (zone 0) &allow-other-keys)
           (setf (lisp-value (slot-value time 'zone)) zone))
         (mkinit-hour (part)
           #'(lambda (time &rest args)
               (declare (ignore args))
               (destructuring-bind (h24 minv maxv)
                   (if (= 24 part) '(t 0 23) '(nil 0 12))
                 (let ((hour (lisp-value (slot-value time 'hour)))) 
                   (setf (slot-value time 'hour24p) h24
                         (max-value (slot-value time 'hour)) maxv
                         (min-value (slot-value time 'hour)) minv)
                   (if (not h24)
                     (setf (lisp-value (slot-value time 'hour)) (mod hour 12) ))))))
         (set-component (slot-name &rest component-decl)
           #'(lambda (time &rest args)
               (let ((month (lisp-value (slot-value time 'month))))
                 (setf (slot-value time slot-name)
                       (apply #'make-instance (append component-decl args))
                       (lisp-value (slot-value time 'month)) month)))))
    (let ((ht (make-hash-table :test #'equal)))
      ;; four-digit year
      (setf (gethash "%Y" ht) (cons 'year #'init-year)
            ;; full month name
            (gethash "%b"ht)  (cons 'month (set-component 'month
                                                          'select-element
                                                          :options (time-months)
                                                          :key #'car
                                                          :output-format #'(lambda (v e) (declare (ignore e)) (cdr v))
                                                          :default-value 1))
            ;; abbreviated month name
            (gethash "%B" ht) (cons 'month (set-component 'month
                                                          'select-element
                                                          :options (time-months t)
                                                          :key #'car
                                                          :output-format #'(lambda (v e) (declare (ignore e)) (cdr v))
                                                          :default-value 1))
            ;; two-digit month number
            (gethash "%m" ht) (cons 'month (constantly t))
            ;; two-digit day of the month
            (gethash "%d" ht) (cons 'day (constantly t))
            ;; two-digit 24-hour
            (gethash "%H" ht) (cons 'hour (mkinit-hour 24))
            ;; two-digit 12-hour
            (gethash "%I" ht) (cons 'hour (mkinit-hour 12))
            ;; two-digit minute
            (gethash "%M" ht) (cons 'minute (constantly t))
            ;; two-digit seconds
            (gethash "%S" ht) (cons 'second (constantly t))
            ;; AM or PM
            (gethash "%p" ht) (cons 'ampm (constantly t))
            ;; numeric time zone
            (gethash "%Z" ht) (cons 'zone #'init-zone))
      ht)))

(defun parse-time-format (fmt)
  (with-input-from-string (strm fmt)
      (labels ((next-char () (read-char strm nil nil))
               (la-char () (peek-char nil strm nil nil))
               (next-token (chr acc)
                 (unless chr
                   (return-from next-token (nreverse acc)))
                 (push
                  (case chr
                    (#\% (funcall
                          (case (la-char)
                            ((nil) (error "badly ending time format ~s" fmt))
                            (#\% #'read-literal)
                            (otherwise #'read-term))
                          (next-char)))
                    (otherwise (read-literal chr)))
                  acc)
                 (next-token (next-char) acc))
               (read-term (chr)
                 (let ((term (coerce (list #\% chr) 'string)))
                   (if (gethash term *time-element-fns*)
                       term
                       (error "bad time format option ~s in ~s" term fmt))))
               (read-literal (chr &optional acc)
                 (push chr acc)
                 (case (la-char)
                   ((nil #\%) (coerce (nreverse acc) 'string))
                   (otherwise (read-literal (next-char) acc)))))
        (next-token (next-char) '()))))

(define-ie-type (time time-element) ((ie-type interface-element))
  ((second :component (integer-range-element
                       :min-value 0
                       :max-value 59
                       :default-value 0
                       :output-format "~2,'0d")
           :documentation "Time seconds.")
   (minute :component (integer-range-element
                       :min-value 0
                       :max-value 59
                       :default-value 0
                       :output-format "~2,'0d")
           :documentation "Time minutes.")
   (hour :component (integer-range-element
                     :min-value 0
                     :max-value 23
                     :default-value 0
                     :output-format "~2,'0d")
         :documentation "Time hours.")
   (day :component (integer-range-element
                    :min-value 1
                    :max-value 31
                    :default-value 1
                    :output-format "~2,'0d")
        :documentation "Time day of the month.")
   (month :component (integer-range-element
                      :min-value 1
                      :max-value 12
                      :default-value 1
                      :output-format "~2,'0d")
          :documentation "Time month.")
   (year :component (integer-range-element
                     :min-value 1960
                     :max-value 2010
                     :default-value 1900
                     :output-format "~4d")
         :documentation "Time year.")
   (zone :component (select-element
                     :options *time-zones*
                     :default-value 0
                     :output-format
                     #'(lambda (v e)
                         (declare (ignore e))
                         (multiple-value-bind (q r)
                             (truncate v)
                           (format nil "~3@d:~2,'0d" q (abs (* r 60))))))
         :documentation "Time zone.")
   (ampm :component (select-element
                     :options *time-ampm*
                     :default-value nil
                     :output-format "~a")
         :documentation "AM/PM flag.")
   (active-slots :accessor active-slots
                 :initarg :active-slots
                 :initform nil
                 :documentation "List of active slot names.")
   (render-format :reader render-format
                  :initform nil
                  :documentation
                  "List of slots and boilerplate strings for presentation.")
   (hour24p :reader hour24p
            :initform t
            :documentation "Is hour in literal format."))
  (:default-initargs
      :output-format "%Y-%m-%d T %H:%M:%S %Z")
  (:metaclass interface-element-class)
  (:documentation "Time representation element.
It accepts POSIX-style format control string as OUTPUT-FORMAT.
Supported options:
%Y - 4-digit year
%B - abbreviated month name
%b - full month name
%m - two-digit month number
%d -two-digit day of the month
%H - two-digit 24-hour
%I - two-digit 12-hour
%M - two-digit minute
%S - two-digit second
%Z - time zone
%p - AM/PM indicator."))

(defmethod shared-initialize :after ((e time-element) slot-names
                                     &key
                                     (year-min 1960)
                                     (year-max 2010)
                                     (zone 0))
  (declare (ignore slot-names))
  (init-from-format e (slot-value e 'output-format) :year-max year-max :year-min year-min :zone zone))

(defmethod init-from-format ((e time-element) (fmt string) &rest args)
  (apply #'init-from-format e (parse-time-format fmt) args))

(defmethod init-from-format ((e time-element) (fmt list) &rest args)
  (with-slots (active-slots render-format)
      e
    (setf active-slots nil
          render-format nil)
    (iter
      (for part in fmt)
      (aif (gethash part *time-element-fns*)
           (destructuring-bind (slot-name . init-fun)
               it
             (when (member slot-name (active-slots e))
               (error "format part ~s for ~a doubled by one of previous parts" part slot-name))
             (progn (apply init-fun e args)
                    (push slot-name active-slots)
                    (push (slot-value e slot-name) render-format)))
           (push part render-format)))
    (setf render-format (nreverse render-format))))

(defmethod accept ((e time-element) (view ieview))
  (render-time-parts view e))

(defmethod present ((e time-element) (view ieview))
  (when (lisp-value e)
    (render-time-parts view e)))

(defmethod render-time-parts ((view ieview) (e time-element))
  (iter
    (with element-class = (find-class 'interface-element))
    (for part in (render-format e))
    (if (subtypep (class-of part) element-class)
        (progn
          (setf (editablep part) (editablep e))
          (render part))
        (<:as-html part))))

(defvar *time-element-slots*
  '(ampm second minute hour day month year zone))

(defun normalize-hour (value time ampm dir)

  (when (hour24p time)
    (return-from normalize-hour value))

  (ecase dir
    (:to-lisp
     (ecase ampm
       ((nil am) value)
       (pm (mod (+ value 12) 24))))
    (:to-client (mod value 12))))

(defmethod client-value ((e time-element))
  (mapcar #'(lambda (sn) (read-client-value (slot-value e sn)))
          *time-element-slots*))

(defmethod coerce-client-value ((e time-element) (value list))
  (setf (nth 2 value) (normalize-hour (nth 2 value) e (car value) :to-lisp))
  (apply #'encode-universal-time (cdr value)))

(defmethod format-lisp-value ((e time-element) value)
  (multiple-value-bind (second minute hour day month year d dlp zone)
      (decode-universal-time (or value 0)
                             (or (lisp-value (slot-value e 'zone))
                                 (default-value (slot-value e 'zone))))
    (declare (ignore d dlp))
    (let ((ampm (if (> hour 12) 'pm 'am)))
      (list ampm second minute hour day month year zone))))

(defmethod (setf client-value) (new (e time-element))
  (mapc #'(lambda (sn v)
            (setf (lisp-value (slot-value e sn)) v))
        *time-element-slots*
        new))