module Algebras.Functor.GeoModel where import TerraHS.TerraLib import TerraHS.TerraLib.TeSTInstance import Algebras.Base import Algebras.Base.Model import TerraHS.Misc import Algebras.Base.GeoObjects import Algebras.Functor.Category import TerraHS.TerraLib.TeDatabase type SpatialValue = (Fun TeGeometry Value) type Layer = Fun String SpatialValue instance Funct (Fun TeGeometry) where lift1 g ( Fun ( f, e, d ) ) = ( Fun ( (g.f) , e , [] ) ) lift2 f f1 f2 = ( Fun ( nf, (dom f1), [] ) ) where nf i = (f ( (arrow f1) i) ((arrow f2) i ) ) instance ModelConvert Layer where toGeoObjects f = toGeoObjects' geos vals ids where geos = (dom (head (cod f))) vals = (lift1 (\x -> (lift1 (\at -> (Attr ( at, (fun (fun f at)) x ) )) (dom f) )) (dom (head (cod f)))) ids = lift1 (ObjectId . show) ([0..((length geos)-1)]) toGeoObjects' [] _ _ = [] toGeoObjects' (g:gs) (at:ats) (i:is) = (TeGeoObject i ( ([ (Attr ("object_id_hs", (StValue (id2string i) ) ) ) ] ) ++ at) [g] ) : (toGeoObjects' gs ats is) fromGeoObjects os = (new_fun (toFun' os) (attnames) ) where attnames = getAttributesName (head os) toFun' os attname = (new_fun (retrieve1 m) (lift1 fst m) ) where m = ( lift1 (toPairRegValue attname) os ) instance ModelPersistence Layer where ---------------------------- ------- auxiliary functions --------------------------- concatLayerFun :: Layer -> Layer -> Layer concatLayerFun f1 f2 = new_fun1 ((dom f1) ++ (dom f2) ) ((cod f1) ++ (cod f2) ) toLayer :: String -> SpatialValue -> Layer toLayer attrname f = new_fun1 [attrname] [f] -- transforma um dado geo-objeto em uma tupla região valor toPairRegValue :: String -> TeGeoObject -> (TeGeometry , Value) toPairRegValue str teobs = ( (head (getGeometries teobs)), ( getValuebyName (getAttributes teobs) str ) ) -- função que retorna um valor a partir da tupla de geometria e valor retrieve1 :: [(TeGeometry, Value)] -> TeGeometry -> Value retrieve1 obs o = snd (head (filter (\par -> ((fst par ) == o ) ) obs) ) -- função que retorna uma lista de nomes de atributos de um tegeoobject getAttributesName :: TeGeoObject -> [String] getAttributesName geo = lift1 getName attlist where attlist :: [Attribute] attlist = (getAttributes geo)