;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: src/components.lisp $

;;; Copyright (c) 2008, Andrea Chiumenti.  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.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; 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 AUTHOR 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 :claw)

(defgeneric local-time-add (local-time field value)
  (:documentation "Adds the specified amount of VALUE to the LOCAL_TIME.
FIELD may be any of: 
* 'NSEC nano-seconds
* 'MSEC milli-seconds
* 'SEC seconds
* 'MIN minutes
* 'HR hours
* 'DAY days
* 'MONTH monthes
* 'YEARS years.
And other FIELD value will produce an error condition."))


(defvar *locales* (make-hash-table :test 'equal) 
  "A hash table of locale key strings and lists of locale directives. 
You should use locale access functions to get its internal values.")

(defun number-format-grouping-separator (&optional (locale (user-locale)))
  "Returns the character used as thousands grouping separator for numbers"
  (getf (getf (gethash locale *locales*) :number-format) :grouping-separator))
  
(defun number-format-decimal-separator (&optional (locale (user-locale)))
  "Returns the character used as decimals separator for numbers"
  (getf (getf (gethash locale *locales*) :number-format) :decimal-separator))
  
(defun ampm (&optional (locale (user-locale)))
  "Returns a list with the localized version of AM and PM for time"
  (getf (gethash locale *locales*) :ampm))

(defun months (&optional (locale (user-locale)))
  "Returns a localized list of monthes in long form"
  (getf (gethash locale *locales*) :months))

(defun short-months (&optional (locale (user-locale)))
  "Returns a localized list of monthes in short form"
  (getf (gethash locale *locales*) :short-months))

(defun first-day-of-the-week (&optional (locale (user-locale)))
  "Returns the first day position of the week for the given locale, being sunday on position 0 and saturday on position 6"
  (1- (getf (gethash locale *locales*) :first-day-of-the-week)))

(defun weekdays (&optional (locale (user-locale)))
  "Returns a localized list of days of the week in long form"
  (getf (gethash locale *locales*) :weekdays))

(defun short-weekdays (&optional (locale (user-locale)))
  "Returns a localized list of days of the week in short form"
  (getf (gethash locale *locales*) :short-weekdays))

(defun eras (&optional (locale (user-locale)))
  "Returns a list with the localized version of BC and AD eras"
  (getf (gethash locale *locales*) :eras))


(defun local-time-add-year (local-time value)
  "Add or remove years, expressed by the value parameter, to a local-time instance"
  (multiple-value-bind (ns ss mm hh day month year)
      (decode-local-time local-time)
    (encode-local-time ns ss mm hh day month (+ year value))))

(defun local-time-add-month (local-time value)  
  "Add or remove monthes, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
  (multiple-value-bind (d-month d-year)
      (floor (abs value) 12)
    (when (< value 0)
      (setf d-month (- d-month)
	    d-year (- d-year))	     
      (multiple-value-bind (ns ss mm hh day month year)
	  (decode-local-time local-time)
	(multiple-value-bind (ns ss mm hh day month-ignore year)
	    (decode-local-time (encode-local-time ns ss mm hh day 1 (+ year d-year)))     
	    (encode-local-time ns ss mm hh day month year))))))

(defun local-time-add-day (local-time value)
  "Add or remove days, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
  (let* ((curr-day (day-of local-time))
	 (local-time-result (make-instance 'local-time
					  :day curr-day
					  :sec (sec-of local-time)
					  :nsec (nsec-of local-time)
					  :time-zone (timezone-of local-time))))
    (setf (day-of local-time-result) (+ curr-day value))
    local-time-result))

(defun local-time-add-hour (local-time value)
  "Add or remove hours, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
  (multiple-value-bind (ns ss mm hh day month year)
	  (decode-local-time local-time)
    (multiple-value-bind (d-hour d-day)
	(floor (abs value) 24)
      (when (< value 0)
	(setf d-hour (- d-hour)
	      d-day (- d-day)))
      (let ((local-time-result (local-time-add-day local-time d-day)))
	(multiple-value-bind (ns2 ss2 mm2 hh2 day2 month2 year2)
	    (decode-local-time local-time-result)
	  (encode-local-time ns2 ss2 mm2 (+ hh d-hour) day2 month2 year2))))))

(defun local-time-add-min (local-time value)
  "Add or remove minutes, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
  (multiple-value-bind (ns ss mm hh day month year)
	  (decode-local-time local-time)
    (multiple-value-bind (d-min d-hour)
	(floor (abs value) 60)
      (when (< value 0)
	(setf d-min (- d-min)
	      d-hour (- d-hour)))
      (let ((local-time-result (local-time-add-hour local-time d-hour)))
	(multiple-value-bind (ns2 ss2 mm2 hh2 day2 month2 year2)
	    (decode-local-time local-time-result)
	  (encode-local-time ns2 ss2 (+ mm d-min) hh2 day2 month2 year2))))))

(defun local-time-add-sec (local-time value)
  "Add or remove seconds, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
  (multiple-value-bind (ns ss mm hh day month year)
	  (decode-local-time local-time)
    (multiple-value-bind (d-sec d-min)
	(floor (abs value) 60)
      (when (< value 0)
	(setf d-sec (- d-sec)
	      d-min (- d-min)))
      (let ((local-time-result (local-time-add-min local-time d-min)))
	(multiple-value-bind (ns2 ss2 mm2 hh2 day2 month2 year2)
	    (decode-local-time local-time-result)
	  (encode-local-time ns2 (+ ss d-sec) mm2 hh2 day2 month2 year2))))))

(defun local-time-add-nsec (local-time value)
  "Add or remove nanoseconds, expressed by the value parameter, to a local-time instance. Correction on other local-time fields is performed if needed"
  (multiple-value-bind (ns ss mm hh day month year)
	  (decode-local-time local-time)
    (multiple-value-bind (d-nsec d-sec)
	(floor (abs value) 10000000)
      (when (< value 0)
	(setf d-nsec (- d-nsec)
	      d-sec (- d-sec)))
      (let ((local-time-result (local-time-add-sec local-time d-sec)))
	(multiple-value-bind (ns2 ss2 mm2 hh2 day2 month2 year2)
	    (decode-local-time local-time-result)
	  (encode-local-time (+ ns d-nsec) ss2 mm2 hh2 day2 month2 year2))))))
	  	
(defmethod local-time-add ((local-time local-time) field value)
  (ccase field 
    (NSEC (local-time-add-nsec local-time value))
    (SEC (local-time-add-sec local-time value))
    (MIN (local-time-add-min local-time value))
    (HR (local-time-add-hour local-time value))
    (DAY (local-time-add-day local-time value))
    (MONTH (local-time-add-month local-time value))
    (YEAR (local-time-add-year local-time value))))