;*********************************************************************
; Módulo: WFS
; Uso:    
; 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
; Nota: Se ha preferido utilizar reglas convenientes propias de colocación de paréntesis, 
; por simplicidad, en lugar de seguir los estándares que realmente utilizan las personas
; más acostumbradas al uso del lenguaje Lisp. 
;---------------------------------------------------------------------
;*********************************************************************

; +++++++++++++++++++++
; + Utility functions +
; +++++++++++++++++++++

;;
;; Receives as an argument an element list and returns a string
;; corresponding to the concatenation of each element in the list.
;; The first letter of each list element (except the corresponding to
;; the first element in the list) will be in uppercase. The rest
;; of the letters will be in downcase.
;;
;; 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))
     )
   )
)



;;
;; Receives as an argument a Lisp atom and returns a string 
;; corresponding to such an atom. The returned string is in downcase.
;;
;; E.g.: (to-downcase-string 'PoLice) -> "police"
;;
(defun to-downcase-string (atom)
   (string-downcase (atom-to-string atom)))

;;
;; Receives as an argument a Lisp atom and returns a string 
;; corresponding to such an atom. The returned string is in uppercase.
;;
;; E.g.: (to-upcase-string 'PoLice) -> "POLICE"
;;
(defun to-upcase-string (atom)
   (string-upcase (atom-to-string atom)))

;;
;; Receives as an argument a Lisp atom and returns a string 
;; corresponding to such an atom. The returned string is in capitalized.
;;
;; E.g.: (to-capitalized-string 'police) -> "Police"
;;
(defun to-capitalized-string (atom)
   (string-capitalize (atom-to-string atom)))

;;
;; Receives as an argument a Lisp atom and returns a string 
;; corresponding to such an atom. The case of the given atom is not
;; relevant at all.
;;
;; E.g.: (atom-to-string 'police) -> "POLICE"
;;
(defun atom-to-string (atom)
   (format nil "~a" atom))

;;
;; Gets the symbol corresponding to the given string.
;;
(defun string-to-symbol (string)
   (intern (to-upcase-string string))
)


(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)          
         )
      )
   )
)

;;
;; Converts the given word from plural to singular.
;; Regular plural is assumed.
;; 
;; Ending "ies" is replaced by "y".
;; Ending "ches", "oes", "shes", "sses" and "xes" are removed the "es". 
;: If the above cases do not apply and ending is "s", "s" is removed.
;;
;; Although the above are general rules, some exceptions can arise:
;; shoes -> shoe (not sho).
;;
;; (to-singular "berries") -> "berry".
;; (to-singular "BERRIES") -> "BERRY".
;; (to-singular "cars") -> "car".
;; (to-singular "CARS") -> "CAR".
;; (to-singular "bunches") -> "bunch".
;; (to-singular "BUNCHES") -> "BUNCH".
;; (to-singular "car") -> "car".
;;
(defun to-singular(word)
   (let
      ((indexLastChar (length word))
       (ending nil))
      (cond 
         ((is-substring-list '("ies") 0 word)
             (progn
                (setq ending (is-substring-list '("ies") 0 word))
                (concatenate 'string (string-right-trim-case-insensitive ending word)
                   (if (is-lowercase word) "y" "Y"))
             )          
         )
         ((is-substring-list '("ches" "oes" "shes" "xes") 0 word)
            (progn
               (setq ending (is-substring-list '("ches" "oes" "shes" "xes") 0 word))
               (string-right-trim-case-insensitive "es" word)
            )
         )
         ((is-substring-list '("s") 0 word)
             (progn
                (setq ending (is-substring-list '("s") 0 word))
                (string-right-trim-case-insensitive ending word)
             )
         )
         (t word) ; Word already in singular.
      )
   )            
)







; ****************************
; * Print features functions *
; ****************************


;;
;; Concatenates two filters
;;
;;
(defun filter-and (filter1 filter2)
  (concatenate 'string (concatenate 'string "<Filter><And>" (concatenate 'string filter1 filter2)) "</And></Filter>")
)


;;
;; Makes the query and register the results as frames
;;
;;
(defun register-gml (f)
  (setq filter (append '("FILTER") f))

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





(defun parser-gml (query)

;(setq filtro (format nil "<Filter><PropertyIsLike><PropertyName>name</PropertyName><Literal>~a</Literal></PropertyIsLike></Filter>" (list-to-single-word element)))
;(setq filt (append '("FILTER") filtro))

;(setq qur (list '("REQUEST" . "GETFEATURE")  '("TYPENAME" . "gns") filt '("OUTPUTFORMAT" . "GML2") '("MAXFEATURES" . 2) '("INITIALFEATURE" . 1)))


(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))))) 


;(setq properties (second (rest info)))


(pprint info)
(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)))	
	       )
	    )	    
	 )
   )
)
	
;(setq location (get-value (string-to-symbol (list-to-single-word element)) 'lat/long))

;(pprint (string location))

;(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 result2) (expt 10 (* -1.0 (length (atom-to-string (first result2)))))) (first result1)))
;(setq long (+ (* (first result4) (expt 10 (* -1.0 (length (atom-to-string (first result4)))))) (first result3)))

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

;(pprint lat)  
;(pprint long)  

)



(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 localizacion más específica
;(set-value (string-to-symbol name)  'latitud (make-symbol location))


;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))

)


(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)))

)



;;
;; 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)
)



(defun filter-near (latitud longitud)
  (setq degrees (get-value 'near '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))

)




(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)) 
)



;
;; Receives as an argument a element 
;; and return the corresponding features that are a certain 
;; distance from the element
;;
(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 (equal type 'near)
	 	(setq fdistance  (filter-near latitud longitud))
	 	(setq fdistance  (filter-far latitud longitud))
	 )
 
 
	 (concatenate 'string "<Filter>" (concatenate 'string fdistance "</Filter>"))
 
	 (register-gml fdistance)
   )
 )
	 
 
 
 ;(setq filt (append '("FILTER") fdistance))

 ;(setq bounding (list '("REQUEST" . "GETFEATURE")  '("TYPENAME" . "gns") filt '("OUTPUTFORMAT" . "GML2") '("MAXFEATURES" . 40) '("INITIALFEATURE" . 1)))

 ;(pprint (setq distance  
	;(net.aserve.client:do-http-request "http://artieda.cps.unizar.es/wfsGazetteerGns/servlets/GNS?VERSION=0.0.14" :query bounding))
)


;
;; Receives as an argument a element 
;; and return the corresponding features that are a certain 
;; distance from the element
;;
(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 (equal type 'near)
	 	(setq fdistance  (filter-near latitud longitud))
	 	(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)
   )
 )
)



(defun register-print-features-distance (dist element)
 (set-distance 'near dist) 
 (print-features-distance 'near element)
)


(defun register-print-types-distance (dist type element)
 (set-distance 'near dist) 
 (print-types-distance type 'near element)
)


;;
(defun print-features-country (country)

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



;;
(defun print-types-country (element country)

(setq filter1
	(format nil "<PropertyIsEqualTo>
			  	<PropertyName>country</PropertyName><Literal>~a</Literal>
			  </PropertyIsEqualTo>
		     " (get-value  country 'siglas))) 
(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)
)




(defun set-distance (type quantity)
   (form :name type :is-a 'distance)
   (set-value type 'degrees quantity)
   (pprint quantity)
)




(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))))))

 )



)




; ++++++++++++++++++++++++++
; + Initialize the grammar +
; ++++++++++++++++++++++++++

;;
;; Initializes the grammar with the given name (presence of the file extension
;; '.gra' is optional, since this extension is assumed for grammar files).
;; If the optional parameter is not given, the grammar corresponding to the
;; LQL language will be used.
;;
(defun initgra (&optional (nombreGra "wfs"))
   (erasegra)
   (loadgra nombreGra)
)