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


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



;;
;; Receives as an argument a 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") 0 (atom-to-string verb))
	(setq filtro 
		(format nil "<Filter><PropertyIsLike><PropertyName>name</PropertyName><Literal>%~a</Literal></PropertyIsLike></Filter>" (list-to-single-word element))) 

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

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

)

;;
;; Receives as an argument a 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") 0 (atom-to-string verb))
	(setq filtro 
		(format nil "<Filter><PropertyIsLike><PropertyName>name</PropertyName><Literal>%~a</Literal></PropertyIsLike></Filter>" (list-to-single-word element))) 

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

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

)



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


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

(setq filtro 
	(format nil "<Filter>
			<And>
			  <PropertyIsEqualTo>
			  	<PropertyName>country</PropertyName><Literal>~a</Literal>
			  </PropertyIsEqualTo>
			  <PropertyIsEqualTo>
			  	<PropertyName>fc</PropertyName><Literal>~a</Literal>
			  </PropertyIsEqualTo>			  
			</And>
		      </Filter>" (get-value  country 'siglas) (get-value element 'abrev))) 
	
(setq filt (append '("FILTER") filtro))

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

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

)




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


;
;; Receives as an argument a element 
;; and return the corresponding features that are a certain 
;; distance from the element
;;
(defun print-features-near (element)

(parser-gml element)
	
(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))
(setq degrees (get-value 'near 'degrees))


(setq fdistance 
	(format nil "<Filter><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></Filter>" (- latitud degrees) (+ longitud degrees) (+ latitud degrees) (+ longitud degrees) (- latitud degrees) (- longitud degrees) (+ latitud degrees) (- longitud degrees) (- latitud degrees) (+ longitud degrees))) 

(pprint 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-features-far (element)

(parser-gml element)
	
(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))
(setq degrees (get-value 'far 'degrees))

(setq fdistance 
	(format nil "<Filter><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></Filter>" (- latitud degrees) (+ longitud degrees) (+ latitud degrees) (+ longitud degrees) (- latitud degrees) (- longitud degrees) (+ latitud degrees) (- longitud degrees) (- latitud degrees) (+ longitud degrees))) 


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




(defun query-location (name)

(setq query (net.xml.parser:parse-xml (remove  #\return
	(net.aserve.client:do-http-request "http://artieda.cps.unizar.es/wfsGazetteerGns/servlets/GNS?VERSION=0.0.14" :query '(("REQUEST" . "GETFEATURE")("TYPENAME" . "gns")("FILTER" . "<Filter><PropertyIsLike><PropertyName>name</PropertyName><Literal>Juslibol</Literal></PropertyIsLike></Filter>") ("OUTPUTFORMAT" . "GML2") ("MAXFEATURES" . 50) ("INITIALFEATURE" . 1)) :protocol :http/1.0))))

)





(defun parser-gml (element)

(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
	(net.aserve.client:do-http-request "http://artieda.cps.unizar.es/wfsGazetteerGns/servlets/GNS?VERSION=0.0.14" :query qur))))


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

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

(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 register-feature (list)

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


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

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


(pprint (is-a? 'jfsfd 'objeto))
(pprint (is-a? (string-to-symbol name) 'objeto))
(pprint name)
(pprint "Descripcion:")
(pprint (describe-form  (string-to-symbol name)))

)





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




; +++++++++++++++++++++++++++++++++
; + Functions dealing with frames +
; +++++++++++++++++++++++++++++++++

;;
;; Checks if the given object exists (as a frame).
;; It identifies an existing frame as a frame with an 'is-a' property.
;;
(defun exists-frame (frame)
   (if (member 'is-a frame) t nil)
)


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