;;; Las siguientes funciones son las utilizadas dentro de la gram tica de
;;; fechas para las transformaciones necesarias de la fecha , el tratamiento
;;; de las fechas ambiguas y dem s.

(in-package 'dypar)
(defvar *fecha-loaded* t)





;;; las siguientes funciones nos devuelven una lista formada por tres numeros,
;;; en el caso de que sea una fecha fija : (dia1 mes1 a¤o1), o por seis 
;;; numeros en el caso de que sea un periodo de tiempo : (dia1 mes1 a¥o1
;;; dia2 mes2 a¥o2)


;; Devuelve una fecha fija

(defun time1 (dia mes a¤o)
       (list dia mes a¤o))


;; Devuelve un mes completo o un a¤o completo
;;    "en el mes de enero"     "en el a¤o 86"

;; Time2 nos devuelve la fecha final

(defun time2 (mes a¤o)
       (if (eql mes 'todos )
           (append (list 1 1 a¤o) (if (eql a¤o (a¤o-actual))
                                     (fecha-actual)
                                     (list 30 12 a¤o)))
           (list 1 mes (if (> mes (mes-actual))
                           (setf a¤o (- a¤o 1))
                           a¤o)   (if (eql mes (mes-actual))
                                       (dia-actual)
                                        30)  mes  a¤o )))


;; Calcula un per¡odo de tiempo. "tiempo" nos dice si el usuario habla de
;; dias, meses, a¤os....
;; "cifra2" indica la "clase" de dias (semana,quincena..) o meses 
;; (semestre,trimestre.....)
;; y "cifra1"  es el n£mero de dias,quincenas,estc.
;; Se aplica a frases como "los tres ultimos semestres" o "los anteriores
;; diez dias"


(defun time4 (cifra1 cifra2 tiempo)
   (let* ((dia2 (if (or (eql 7 cifra2) (eql 15 cifra2))
                    (domingo-anterior)
                    (dia-actual)))  
          (mes2 (mes-actual))
          (a¤o2 (a¤o-actual))
          (dia1 dia2) (mes1 mes2) (a¤o1 a¤o2))
    (case tiempo
      (a¤o
        (setf mes1 1 mes2 12)
        (setf dia1 1 dia2 30)
        (setf a¤o1 (- a¤o2 (* cifra1 cifra2)) a¤o2 (- a¤o2 1)))
      (dia
        (setf dia1 (- dia2 (* cifra1 cifra2))))
      (mes
        (setf dia1 1 dia2 30)     
        (case cifra2
           (1 (setf mes2 (- mes2 1)))
           (3 (cond ((and(< 0 mes2) (> 4 mes2)) (setf mes2 0))
                    ((and(< 3 mes2) (> 7 mes2)) (setf mes2 3))
                    ((and(< 6 mes2) (> 10 mes2)) (setf mes2 6))
                    ((and(< 9 mes2) (> 13 mes2)) (setf mes2 9))))
           (4 (cond ((and(< 0 mes2) (> 5 mes2)) (setf mes2 0))
                    ((and(< 4 mes2) (> 9 mes2)) (setf mes2 4))
                    ((and(< 8 mes2) (> 13 mes2)) (setf mes2 8))))
           (6 (cond ((and(< 0 mes2) (> 7 mes2)) (setf mes2 0))
                    ((and(< 6 mes2) (> 13 mes2)) (setf mes2 6)))))
       (setf mes1 (+ 1 (- mes2 (* cifra1 cifra2))))))
    (if  (<= dia1 0)
         (do (( dia dia1 (+ 30 dia)) 
              ( mes mes1 (- mes 1)))
              ((> dia 0) (setf dia1 dia
                               mes1 mes))))
    (if (<= mes1 0)
        (do (( mes mes1 (+ 12 mes))
             ( a¤o a¤o1 (- a¤o 1)))
              ((> mes 0) (setf mes1 mes
                               a¤o1 a¤o))))

    (if (<=  mes2 0) 
        (do (( mes mes2 (+ 12 mes)) 
             ( a¤o a¤o2 (- a¤o 1)))
              ((> mes 0) (setf mes2 mes
                               a¤o2 a¤o))))
(list dia1 mes1 a¤o1 dia2 mes2 a¤o2)))



(defun time6 (cifra1 cifra2 a¤o)
   (let*  ((mes2 (mes-actual))
           (mes1 mes2))
         (case cifra2
           (3 (cond ((equal cifra1 'primero) (setf mes1 1 mes2 3))
                    ((equal cifra1 'segundo) (setf mes1 4 mes2 6))
                    ((equal cifra1 'tercero) (setf mes1 7 mes2 9))
                    ((equal cifra1 'ultimo) (setf mes1 10 mes2 12))))
           (4 (cond ((equal cifra1 'primero) (setf mes1 1 mes2 4))
                    ((equal cifra1 'segundo) (setf mes1 5 mes2 8))
                    ((or (equal cifra1 'ultimo)
                         (equal cifra1 'tercero)) (setf mes1 9 mes2 12))))
           (6 (cond ((equal cifra1 'primero) (setf mes1 1 mes2 6))
                    ((or (equal cifra1 'ultimo)
                         (equal cifra1 'segundo)) (setf mes1 7 mes2 12)))))
         (list 1 mes1 a¤o 30 mes2 a¤o)))



;; calcula periodos de tiempo definidos por "desde hace 13 dias" y similar
;;
;; Si inicio es 1 devuelve la fecha inicial
;; Si inicio es 2 devuelve la fecha final
;;
(defun time0  (cifra1 cifra2 tiempo)
    (let* ((dia2 (dia-actual))
            (mes2 (mes-actual))
            (a¤o2 (a¤o-actual))
            (dia1 dia2) (mes1 mes2) (a¤o1 a¤o2))
    (case tiempo
      (dia (setf dia1 (- dia2 (* cifra1 cifra2))))
      (mes (setf mes1 (- mes2 (* cifra1 cifra2))))
      (a¤o (setf a¤o1 (- a¤o2 (* cifra1 cifra2)))))
    (if  (<= dia1 0) 
         (do (( dia dia1 (+ 30 dia)) 
              ( mes mes1 (- mes 1)))
              ((> dia 0) (setf dia1 dia
                               mes1 mes))))
    (if (<= mes1 0) 
        (do (( mes mes1 (+ 12 mes)) 
             ( a¤o a¤o1 (- a¤o1 1)))
            ((> mes 0) (setf mes1 mes
                             a¤o1 a¤o))))
    (list dia1 mes1 a¤o1)))


;; "desde enero a junio del 87" etc
;;
(defun time3 (fecha1 fecha2)
   (let ((dia1 (car fecha1))
         (mes1 (second fecha1))
         (a¤o1 (third fecha1))
         (dia2 (car fecha2))
         (mes2 (second fecha2))
         (a¤o2 (third fecha2)))
    (cond ((and (< mes2 mes1) (equal a¤o1 a¤o2)) (setf a¤o1 (- a¤o1 1)))  
          ((and (< (mes-actual) mes2)
                   (eql a¤o2  (a¤o-actual))
                   (eql a¤o1 a¤o2))
                                    (setf a¤o1 (- a¤o1 1) a¤o2 (- a¤o2 1))))
        (list dia1 mes1
                        (if (< a¤o2 a¤o1) a¤o2 a¤o1) dia2 mes2 a¤o2)))


;; fecha actual
;;
(defun fecha-actual ()
    (multiple-value-bind (s d f dia mes a¤o)
         (get-decoded-time)
        (list dia mes a¤o)))

      
;; dia actual
(defun dia-actual ()
      (multiple-value-bind (s d f dia)
           (get-decoded-time)
         dia))

;; mes actual
(defun mes-actual ()
      (multiple-value-bind (s d f dia mes)
           (get-decoded-time)
         mes))

;; mes pasado
(defun mes-pasado ()
      (multiple-value-bind (s d f dia mes)
           (get-decoded-time)
        (- mes 1)))

;; a¤o actual
(defun a¤o-actual ()
      (multiple-value-bind (s d f dia mes a¤o)
           (get-decoded-time)
          a¤o))

;; a¤o pasado
(defun a¤o-pasado ()  
      (multiple-value-bind (s d f dia mes a¤o)
           (get-decoded-time)
          (- a¤o 1)))

;; fecha-inicial
(defun fecha-inicial ()
       (list 1 1 (a¤o-actual)))


;; domingo anterior
(defun domingo-anterior() 
       (multiple-value-bind (s d f dia mes a¤o do-anterior)
           (get-decoded-time)
     (- dia (+ 1 do-anterior))))   

;;lee n£meros entre 1 y 31
(def-op $leer-dia $n () (inp)
       (and (numberp (car inp))
            (< (car inp) 32)
            (> (car inp) 0)))

;; lee n£meros entre 1 y 12
(def-op $leer-mes $n () (inp)
       (and (numberp (car inp))
            (< (car inp) 13)
            (> (car inp) 0)))

;; lee n£meros entre 1980 y el a¤o actual 
(def-op $leer-a¤o $n () (inp)
       (or
         (and (numberp (car inp))
            (<= (car inp) (a¤o-actual))
            (>= (car inp) 1980))
          (and (numberp (car inp))
            (<= (car inp) 99)
            (>= (car inp) 80))))



;; "esta semana" "este mes"......
(defun time5 (tiempo)
     (let ((dia1) (dia2) (mes1) (mes2) (a¤o1) (a¤o1))
        (case tiempo
         (trimestre
           (setf dia1 1
                 mes1 (cond ((< (mes-actual) 4) 1)
                            ((< (mes-actual) 7) 3)
                            ((< (mes-actual) 10) 6)
                            ((< (mes-actual) 13) 9))
                 a¤o1 (a¤o-actual)))   
         (mes
           (setf  dia1 1 
                  mes1 (mes-actual)
                  a¤o1 (a¤o-actual)))
         (a¤o
           (setf  dia1 1
                  mes1 1
                  a¤o1 (a¤o-actual)))
          (semana
            (setf  dia1 (+ 1 (domingo-anterior)) 
                   mes1 (mes-actual)
                   a¤o1 (a¤o-actual))))
          (append (list dia1 mes1 a¤o1) (fecha-actual))))



;;;  La siguiente funcion convierte la fecha que nos ha devuelto la gramatica 
;;;  de fechas en el formato en el que la base de datos la contiene


(defun fec-string (date)
               (let ((dia nil)
                     (mes nil)
                     (a¥o nil)) 
               (setf dia (princ-to-string (car date)))                
               (setf mes (princ-to-string (second date)))                
               (setf a¥o (princ-to-string (third date)))
               (if (equal (length dia) 1) 
                   (setf dia (string-append "0" dia)))
               (if (equal (length mes) 1) 
                   (setf mes (string-append "0" mes)))
               (if (equal (length a¥o) 2) 
                   (setf a¥o (string-append "19" a¥o)))
               (string-append  a¥o mes dia )))

;;; la siguiente funcion, haciendo uso de la anterior, deja preparada para
;;; la select  la condicion que describe la fecha ; es decir, si tenemos dos
;;; fechas eso quiere decir que la condicion es que entre ambas se encuentre
;;; dicho campo de la base, si tenemos solo una puede ser que exijamos fecha
;;; posterior o anterior a esa, etc.


(defun fecha (!fecha1 !fecha2 !fecha !fecha-ini !fecha-fin)
             (let ((fecha1 !fecha1)
                   (fecha2 !fecha2)
                   (fecha !fecha)
                   (fecha-ini !fecha-ini)
                   (fecha-fin !fecha-fin)
                   (fecha-string))
               (if fecha1
                 (setf fecha-string
                  (if (equal fecha1 fecha2)
                      (string-append 
                             "   slc_pefecsol = " (fec-string fecha1)) 
                      (string-append 
                       "   slc_pefecsol  between  " 
                        (fec-string fecha1)
                         "  and  "
                        (fec-string  fecha2)))))
                (if (and fecha
                         (not (stringp fecha))
                         (not (equal fecha 'trimestre))
                         (not (equal fecha 'ultimamente)))
                 (setf fecha-string
                      (string-append 
                       "  slc_pefecsol  between  " 
                        (fec-string
                          (list (car fecha) (second fecha) (third fecha)))
                        "  and  "
                        (fec-string  (nthcdr 3 fecha)))))
                     (if (and fecha (stringp fecha))
                        (setf fecha-string  fecha))
                (if (or  (equal fecha 'trimestre)
                         (equal fecha 'ultimamente))
                     (setf fecha-string fecha))
                 (if fecha-ini
                 (setf fecha-string
                     (string-append 
                       "   slc_pefecsol  between  " 
                        (fec-string
               (list (car fecha-ini) (second fecha-ini) (third fecha-ini)))
                       "  and  "
                        (fec-string  (nthcdr 3 fecha-fin)))))
                    fecha-string))



;; defino una estructura que tiene como atributos
;;     usuario           frase usuario
;;     frase             frase del menu de posibles interpretaciones
;;     interpretacion    interpretacion de la frase
;; la lista lista-interpretaciones contiene todas las estructuras creadas
  
    (defstruct interpretaciones usuario frase interpretacion)

    (setf lista_interpretaciones
        (list (make-interpretaciones
                  :usuario (quote trimestre)
                  :frase "Los ultimos noventa dias"
                  :interpretacion (time4 90 1 'dia))
              (make-interpretaciones
                  :usuario  (quote trimestre) 
                  :frase "Los dias que llevamos de este trimestre natural."
                  :interpretacion (time5 'trimestre))
              (make-interpretaciones
                  :usuario  (quote ultimamente) 
                  :frase "Los ultimos diez dias."
                  :interpretacion (time4 10 1 'dia))
              (make-interpretaciones
                  :usuario (quote ultimamente) 
                  :frase "De un mes a esta parte."
                  :interpretacion (time4 30 1 'dia))
              (make-interpretaciones
                  :usuario (quote ultimamente) 
                  :frase "Los ultimos tres dias."
                  :interpretacion (time4 3 1 'dia))))




;; obtenemos la interpretacion de la frase elegida
(defun elige (frase)
    (dolist (var lista_interpretaciones salida)
         (if (equal frase (interpretaciones-frase var))
             (setf salida (interpretaciones-interpretacion var)))))






;; esta funcion hace que aparezca en pantalla el menu correspondiente
;; a las posibles interpretaciones de una entrada ambigua (cadena)
(defun resolver-ambiguedad (cadena)
    (let ((frase cadena)
          (lista lista_interpretaciones)
          (nueva-cadena nil)
          (i 1)
	  (opcion))
          (dolist (var lista nueva-cadena)
              (cond ((equal frase  (interpretaciones-usuario var))
                          (setf nueva-cadena 
                                  (append nueva-cadena 
                                      (list (interpretaciones-frase var))))))) 
         (escribe-mensaje 
         (format *query-io*  "~2& Delimite el periodo con mas exactitud.~
		 Teclee el numero de la opcion elegida.~2%")
          (dolist (var nueva-cadena lista)
                (format *query-io* "~&      ~a-.   ~@(~a~) "   i  var )
                (setf lista (append lista (list i var)))
                (setf i (+ 1 i)))
          (format *query-io*  "~2&                Opci¢n: ")
          (setq opcion 
		(do ((leido (read *query-io*)
			    (read *query-io*)))
		    ((and (numberp leido)
			  (> leido 0)
			  (< leido i)) leido)
		  (format *query-io*  "~&                Opci¢n(1..~d): " 
			  (- i 1)))))
          (setf nuevo (car (cdr (member opcion lista))))
          (elige nuevo)))




;;;;;;;;;;;;;;;;;;;;;;;;;;  FIN  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;