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
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]
toPairRegValue :: String -> TeGeoObject -> (TeGeometry , Value)
toPairRegValue str teobs = ( (head (getGeometries teobs)), ( getValuebyName (getAttributes teobs) str ) )
retrieve1 :: [(TeGeometry, Value)] -> TeGeometry -> Value
retrieve1 obs o = snd (head (filter (\par -> ((fst par ) == o ) ) obs) )
getAttributesName :: TeGeoObject -> [String]
getAttributesName geo = lift1 getName attlist
where
attlist :: [Attribute]
attlist = (getAttributes geo)