;*********************************************************************
; Módulo: WFS
; Uso:    Interface de lenguaje natural para interrogar un Web Feature 
;	  Server. Fichero que contiene las funciones lisp utilizadas 
;         por el parser
; Autor:  María Navas Tapiador
; email:  mnavas@ebro.cps.unizar.es
;*********************************************************************
; Fichero: wfs.lsp      Fecha Creación: 19 de Junio de 2002
; Versión: 1.0          Fecha Modificación: 
; Estado:  Desarrollo   Autor: María Navas Tapiador
;---------------------------------------------------------------------
;*********************************************************************

; **********************************
; * Funciones de manejo de cadenas *
; **********************************

;;
;; Recibe ccomo argumento una lista de elementos y devuelve una
;; cadena en mayúsculas con los elementos de la lista concatenados.
;;
;; E.g.: (list-to-single-word '(police car)) -> "policeCar"
;;
(defun list-to-single-word (list)
   (let ((stringfied-list "")
         (string-to-append ""))
     (dolist (element list stringfied-list)
          (setq string-to-append (to-upcase-string element))
           (if (not (equal stringfied-list ""))
           	(setq stringfied-list
           	   (concatenate 'string stringfied-list " ")))
              
           (setq stringfied-list
              (concatenate 'string stringfied-list string-to-append))
     )
   )
)



;;
;; Recibe como argumento un atom y lo devuelve en minúsculas
;;
;; E.g.: (to-downcase-string 'PoLice) -> "police"
;;
(defun to-downcase-string (atom)
   (string-downcase (atom-to-string atom)))

;;
;; Recibe como argumento un atom y lo devuelve en mayúsculas
;;
;; E.g.: (to-upcase-string 'PoLice) -> "POLICE"
;;
(defun to-upcase-string (atom)
   (string-upcase (atom-to-string atom)))

;;
;; Recibe como argumento un atom y lo devuelve con la primera
;; letra en mayúsculas y el resto en minúsculas.
;;
;; E.g.: (to-capitalized-string 'police) -> "Police"
;;
(defun to-capitalized-string (atom)
   (string-capitalize (atom-to-string atom)))

;;
;; Recibe como argumento un atom y lo devuelve en una cadena
;; sin preocuparse de mayúsculas y minúsculas
;;
;; E.g.: (atom-to-string 'police) -> "POLICE"
;;
(defun atom-to-string (atom)
   (format nil "~a" atom))

;;
;; Obtiene el símbolo correspondiente a una cadena.
;;
(defun string-to-symbol (string)
   (intern (to-upcase-string string))
)


;;
;; Comprueba si una cadena contiene algunas de las subcadenas 
;; especificadas en una lista.
;;
(defun is-substring-list (list startIndex word)
   (let ((result nil))
      (dolist (word-list list result)
         (if (string= (subseq (string-downcase word) 
                      (- (length word) (length word-list))) 
                  (string-downcase word-list)
             )
            (setq result word-list)          
         )
      )
   )
)




; *******************************************************
; * Funciones de acceso al Web features Server del NIMA *
; *******************************************************


;;
;; Función que concatena dos filtros.
;;
;;
(defun filter-and (filter1 filter2)
  (concatenate 'string (concatenate 'string "<Filter><And>" (concatenate 'string filter1 filter2)) "</And></Filter>")
)


;;
;; Función que realiza una pregunta a partir de un filtro 
;; y registra sus resultados en frames.
;;
;;
(defun register-gml (f)
  (setq filter (append '("FILTER") f))

  (setq query (list '("REQUEST" . "GETFEATURE")  '("TYPENAME" . "gns") filter '("OUTPUTFORMAT" . "GML2") '("MAXFEATURES" . 5) '("INITIALFEATURE" . 1)))
  
  (setq qur (net.aserve.client:do-http-request "http://artieda.cps.unizar.es/wfsGazetteerGns/servlets/GNS?VERSION=0.0.14" :query query)) 
  
  (parser-gml qur) 
)




;;
;; Función que parsea el GML obtenido en una petición al Web Features Server, 
;; transformándolo en una lista, extrayendo cada uno de los features,
;; encontrados y almacenándolos como frames.
;;
;;
(defun parser-gml (query)

(setq query (net.xml.parser:parse-xml (remove  #\return query)))


;; quito el XML
;; quito el featureCollection
;; quito el BoundedBy
(setq info (rest (rest (first (rest query))))) 


(if (not (equal info nil)) 
  (progn 	
	(setq features-list (rest (rest info)))
	(setq l (list-length features-list))

	(let ((result nil))
	   (dotimes (count l result)
	       (if (eq (mod count 2) 0)
	       	 (register-feature (first (nthcdr count features-list)))	
	       )
	    )	    
	 )
   )
)
	
)



;;
;;
;; Función que a partir del GML parseado en forma de lista de cada feature, 
;; obtiene sus propiedades y las almacena en un frame sino lo está.
;;
;;
(defun register-feature (list)

;FeatureMember 
(setq feature (first (rest (rest list))))


;propiedad nombre
(setq name (second (first (nthcdr 4 feature))))

(if (equal (is-a? 'objeto (string-to-symbol name)) nil)
	(save-feature feature name)
)

(pprint name)
(pprint "Descripcion:")
(pprint (describe-form  (string-to-symbol name)))

)


;;
;; Función que guarda las propiedades del feature en un frame.
;;
;;
(defun save-feature (feature name)
;propiedad clase Feature más general

(setq generic (second (first (nthcdr 14 feature))))
(set-value (string-to-symbol name)  'fc (string-to-symbol generic)) 


(setq type 'feature)
(case (string-to-symbol generic) ('A (setq type 'Administrative))
				 ('H (setq type 'Hydrographic))
				 ('L (setq type 'Area))
				 ('P (setq type 'Place))
				 ('R (setq type 'Road))
				 ('S (setq type 'Spot))
				 ('T (setq type 'Hypsographic))
				 ('U (setq type 'Undersea))
				 ('V (setq type 'Vegetation))
)

(form :name (string-to-symbol name) :is-a type)

(setq location (second (first (nthcdr 2 (first (nthcdr 2 (first (nthcdr 6 feature))))))))

(setq result1 (multiple-value-bind (prefixlat point) 
     (parse-integer (string location) :junk-allowed t) (list prefixlat point))) 

(setq result2 (multiple-value-bind (suffixlat comma) 
     (parse-integer (string location) :start (+ (second result1) 1) :junk-allowed t) (list suffixlat comma))) 

(setq result3 (multiple-value-bind (preffixlong point) 
     (parse-integer (string location) :start (+ (second result2) 1) :junk-allowed t) (list preffixlong point))) 

(setq result4 (multiple-value-bind (suffixlong comma) 
     (parse-integer (string location) :start (+ (second result3) 1) :junk-allowed t) (list suffixlong comma))) 



(setq lat (+ (first result1) (* (first result2) (expt 10 (* -1.0 (length (atom-to-string (first result2))))))))
(setq long (+ (first result3) (* (first result4) (expt 10 (* -1.0 (length (atom-to-string (first result4)))))) ))


(if (equal (char (string location) 0)#\-)
	(setq lat (* -1.0 lat)))


(set-value (string-to-symbol name)  'latitud lat)
(set-value (string-to-symbol name)  'longitud long)


;propiedad clase  feature más específica
(setq especialized (second (first (nthcdr 8 feature))))
(set-value (string-to-symbol name)  'featureDesignation (string-to-symbol especialized))


;propiedad pais Feature
(setq country (second (first (nthcdr 16 feature))))
(set-value (string-to-symbol name)  'country (string-to-symbol country))


;propiedad tipo de nombre Feature
(setq name-type (second (first (nthcdr 20 feature))))
(set-value (string-to-symbol name)  'nameType (string-to-symbol name-type))

)





;;
;; Receives as an argument an element and a verb
;; and return the corresponding features that end/begin/contains 
;; (indicated by the verb) the element, querying the Web feature server
;;
;;
(defun print-features-contains (element verb)
       
  (if (is-substring-list '("end" "ends") 0 (atom-to-string verb))
	(setq filter1 
		(format nil "<Filter><PropertyIsLike><PropertyName>name</PropertyName><Literal>%~a</Literal></PropertyIsLike></Filter>" (list-to-single-word element))) 

	(if (is-substring-list '("contain" "contains") 0 (atom-to-string verb))
	    (setq filter1
		(format nil "<PropertyIsLike><PropertyName>name</PropertyName><Literal>%~a%</Literal></PropertyIsLike>" (list-to-single-word element))) 
	    (setq filter1 
		(format nil "<PropertyIsLike><PropertyName>name</PropertyName><Literal>~a%</Literal></PropertyIsLike>" (list-to-single-word element))))) 
	
  (register-gml filter1)

)

;;
;; Receives as an argument a feature type, an element and a verb
;; and return the corresponding features that end/begin/contains 
;; (indicated by the verb) the element, querying the Web feature server
;;
;;
(defun print-types-contains (type element verb)
  
  (if (is-substring-list '("end" "ends") 0 (atom-to-string verb))
	(setq filter1 
		(format nil "<PropertyIsLike><PropertyName>name</PropertyName><Literal>%~a</Literal></PropertyIsLike>" (list-to-single-word element))) 

	(if (is-substring-list '("contain" "contains") 0 (atom-to-string verb))
	    (setq filter1
		(format nil "<PropertyIsLike><PropertyName>name</PropertyName><Literal>%~a%</Literal></PropertyIsLike>" (list-to-single-word element))) 
	    (setq filter1 
		(format nil "<PropertyIsLike><PropertyName>name</PropertyName><Literal>~a%</Literal></PropertyIsLike>" (list-to-single-word element))))) 
	

  (setq filter2 (format nil "<PropertyIsEqualTo><PropertyName>fc</PropertyName><Literal>~a</Literal></PropertyIsEqualTo>" (get-value type 'fc)))			  


  (setq filtro (filter-and filter1 filter2))
  (register-gml filtro)
)



;;
;; Crea el filtro que permite preguntar por los elemntos que se encuentran como mucho a
;; la distancia especificada en near de la latitud y longitud que se pasa como parámetro.
;;
(defun filter-near (latitud longitud type)
  (setq degrees (get-value type 'degrees))

  (format nil "<BBOX><PropertyName>location</PropertyName><Polygon srsName='EPSG:4326'><outerBoundaryIs>
                        <LinearRing>
                              <coordinates>~a,~a ~a,~a ~a,~a ~a,~a ~a,~a</coordinates>
                        </LinearRing>
                  </outerBoundaryIs>
            </Polygon>
            </BBOX>" (- latitud degrees) (+ longitud degrees) (+ latitud degrees) (+ longitud degrees) (- latitud degrees) (- longitud degrees) (+ latitud degrees) (- longitud degrees) (- latitud degrees) (+ longitud degrees))

)



;;
;; Crea el filtro que permite preguntar por los elemntos que se encuentran como mínimo a
;; la distancia especificada en near de la latitud y longitud que se pasa como parámetro.
;;
(defun filter-far (latitud longitud)
  (setq degrees (get-value 'far 'degrees))

  (format nil "<Not><BBOX><PropertyName>location</PropertyName><Polygon srsName='EPSG:4326'><outerBoundaryIs>
                        <LinearRing>
                              <coordinates>~a,~a ~a,~a ~a,~a ~a,~a ~a,~a</coordinates>
                        </LinearRing>
                  </outerBoundaryIs>
            </Polygon>
            </BBOX></Not>" (- latitud degrees) (+ longitud degrees) (+ latitud degrees) (+ longitud degrees) (- latitud degrees) (- longitud degrees) (+ latitud degrees) (- longitud degrees) (- latitud degrees) (+ longitud degrees)) 
)



;;
;; Recibe como argumento un elemento y devuelve las features que están a
;; una cierta distancia (near o far) de ese elemento.
;;
(defun print-features-distance (type element)

 (setq filter (format nil "<Filter><PropertyIsLike><PropertyName>name</PropertyName><Literal>~a</Literal></PropertyIsLike></Filter>" (list-to-single-word element)))
 
 (if (equal (is-a? (string-to-symbol (list-to-single-word element)) 'objeto) nil)
  	(register-gml filter)
   	(progn (pprint (list-to-single-word element))
  	       (pprint "Descripcion:")
  	       (pprint (describe-form  (string-to-symbol (list-to-single-word element)))))
  
  )
	
 (if (not (equal (is-a? (string-to-symbol (list-to-single-word element)) 'objeto) nil))
   (progn 
 	(setq latitud (get-value (string-to-symbol (list-to-single-word element)) 'latitud))
 	(setq longitud (get-value (string-to-symbol (list-to-single-word element)) 'longitud))
	 (if (not (equal type 'far))
	 	(setq fdistance  (filter-near latitud longitud type))
	 	(setq fdistance  (filter-far latitud longitud))
	 )
 
 
	 
	 (register-gml (concatenate 'string "<Filter>" (concatenate 'string fdistance "</Filter>")))
   )
 )
	  
)




;;
;; Recibe como argumento un elemento y devuelve los tipos de features especificados como parámetro
;; que están a una cierta distancia (near o far) de ese elemento.
;;
(defun print-types-distance (type feature element)

 (setq filter (format nil "<Filter><PropertyIsLike><PropertyName>name</PropertyName><Literal>~a</Literal></PropertyIsLike></Filter>" (list-to-single-word element)))
 
 (if (equal (is-a? (string-to-symbol (list-to-single-word element)) 'objeto) nil)
  	(register-gml filter)
   	(progn (pprint (list-to-single-word element))
  	       (pprint "Descripcion:")
  	       (pprint (describe-form  (string-to-symbol (list-to-single-word element))))
   ))
  
 	
 (if (not (equal (is-a? (string-to-symbol (list-to-single-word element)) 'objeto) nil))
   (progn 
	 (setq latitud (get-value (string-to-symbol (list-to-single-word element)) 'latitud))
	 (setq longitud (get-value (string-to-symbol (list-to-single-word element)) 'longitud)) 
	 (if (not (equal type 'far))
	 	(setq fdistance  (filter-near latitud longitud type))
	 	(setq fdistance  (filter-far latitud longitud))
	 )

	 (setq filter2 (format nil "<PropertyIsEqualTo><PropertyName>fc</PropertyName><Literal>~a</Literal></PropertyIsEqualTo>" (get-value feature 'fc)))			  

	 (setq f (filter-and fdistance filter2))
 
 
	 (register-gml f)
   )
 )
)


;;
;; Permite obtener los elementos que se encuentran a una distancia en grados 
;; dist del elemento element 
;;
(defun register-print-features-distance (dist element)
 (set-distance 'distance-max dist) 
 (print-features-distance 'distance-max element)
)


;;
;; Permite obtener los features de un tipo que se encuentran a una distancia en grados 
;; dist del elemento element 
;;
(defun register-print-types-distance (dist type element)
 (set-distance 'distance-max dist) 
 (print-types-distance 'distance-max type element)
)


;;
;; Permite obtener los features de un determinado país que se le pasa como parámetro
;;
(defun print-features-country (country)

(if (equal (get-value  country 'siglas) nil)
	(setq count " ")
	(setq count (get-value  country 'siglas))
)

(setq filter
	(format nil "<Filter>
			  <PropertyIsEqualTo>
			  	<PropertyName>country</PropertyName><Literal>~a</Literal>
			  </PropertyIsEqualTo>
		      </Filter>" count)) 
	
  (register-gml filter)
)



;;
;; Permite obtener los features de un tipo de un determinado país que se le pasa como parámetro
;;
(defun print-types-country (element country)

(if (equal (get-value  country 'siglas) nil)
	(setq count " ")
	(setq count (get-value  country 'siglas))
)
(setq filter1
	(format nil "<PropertyIsEqualTo>
			  	<PropertyName>country</PropertyName><Literal>~a</Literal>
			  </PropertyIsEqualTo>
		     " count)) 
(setq filter2
	(format nil "<PropertyIsEqualTo>
			  	<PropertyName>fc</PropertyName><Literal>~a</Literal>
			  </PropertyIsEqualTo>" (get-value element 'fc))) 
	
(setq filter (filter-and filter1 filter2))	
(register-gml filter)
)



;;
;; Permite especificar un valor para los tipos de distancia (near-far)
;;
(defun set-distance (type quantity)
   (form :name type :is-a 'distance)
   (set-value type 'degrees quantity)
)



;;
;; Muestra la descripción del feature element que se le pasa como parámetro
;;
(defun describe-feature (element)
 (setq filter (format nil "<Filter><PropertyIsLike><PropertyName>name</PropertyName><Literal>~a</Literal></PropertyIsLike></Filter>" (list-to-single-word element)))
  (if (equal (is-a? (string-to-symbol (list-to-single-word element)) 'objeto) nil)
	(register-gml filter)
 	(progn (pprint (list-to-single-word element))
	       (pprint "Descripcion:")
	       (pprint (describe-form  (string-to-symbol (list-to-single-word element))))))

 )
)




; **********************
; * Inicia la gramática*
; **********************

;;
;; Inicializa la grámatica cuyo nombre se le pasa como parámetro,
;; (la extensión .gra es opcional) y en caso de que no se le
;; pase ninguna utiliza por defecto la de wfs
;;
(defun initgra (&optional (nombreGra "wfs"))
   (erasegra)
   (loadgra nombreGra)
)
