module GeoExample import StdEnv, PView, Derived import Data.Void, Data.Error, Data.Func, Data.Either, Text.JSON from Data.List import splitWith //GEOGRAPHIC EXAMPLE // In local memory share :: GeoPerspective = { center :: (Int,Int) , bounds :: Maybe (Int,Int,Int,Int) } // Used in a task :: GeoMap = { perspective :: GeoPerspective , markers :: [(String,(Int,Int))] } // Lists in database :: Contact = { name :: String , type :: String , position :: (Int,Int) } inBounds :: (Int,Int,Int,Int) Contact -> Bool inBounds (minx,miny,maxx,maxy) {position=(x,y)} = x >= minx && x <= maxx && y >= miny && y <= maxy contactMarker :: Contact -> (String,(Int,Int)) contactMarker {Contact|name,type,position} = (name+++" ("+++type+++")",position) derive JSONEncode GeoPerspective,GeoMap,Contact derive JSONDecode GeoPerspective,GeoMap,Contact allShips :: PView Void [Contact] [Contact] MyWorld allShips = createStoreView "allShips" ships where ships = [{name = "SA",type = "Ship", position = (1,1)} ,{name = "SB",type = "Ship", position = (2,3)} ,{name = "SC",type = "Ship", position = (3,2)} ] shipView :: PView (Either String (Int,Int,Int,Int)) [Contact] [Contact] MyWorld shipView = union shipsByName shipsByBounds (\_ is ws bounds -> let (ds,_) = splitWith (inBounds bounds) is in any (inBounds bounds) (ds ++ ws)) (\_ is ws name -> let (ds,_) = splitWith (\p->p.Contact.name == name) is in any (\p->p.Contact.name == name) (ds ++ ws)) shipsByName :: PView String [Contact] [Contact] MyWorld shipsByName = applySplit allShips (listFilterSplit \name s -> s.Contact.name == name) tr1 shipsByBounds :: PView (Int,Int,Int,Int) [Contact] [Contact] MyWorld shipsByBounds = applySplit allShips (listFilterSplit \bounds -> inBounds bounds) tr1 allPlanes :: PView Void [Contact] [Contact] MyWorld allPlanes = createStoreView "allPlanes" planes where planes = [{name = "PA",type = "Plane", position = (2,5)} ,{name = "PB",type = "Plane", position = (2,2)} ,{name = "PC",type = "Plane", position = (6,6)} ] planeView :: PView (Either String (Int,Int,Int,Int)) [Contact] [Contact] MyWorld planeView = union planesByName planesByBounds (\_ is ws bounds -> let (ds,_) = splitWith (inBounds bounds) is in any (inBounds bounds) (ds ++ ws)) (\_ is ws name -> let (ds,_) = splitWith (\p->p.Contact.name == name) is in any (\p->p.Contact.name == name) (ds ++ ws)) planesByName :: PView String [Contact] [Contact] MyWorld planesByName = applySplit allPlanes (listFilterSplit \name s -> s.Contact.name == name) tr1 planesByBounds :: PView (Int,Int,Int,Int) [Contact] [Contact] MyWorld planesByBounds = applySplit allPlanes (listFilterSplit \bounds -> inBounds bounds) tr1 contactView :: PView (Either String (Int,Int,Int,Int)) [Contact] [Contact] MyWorld contactView = joinLists shipView planeView splitter where splitter c=:{Contact|type} = (type == "Ship") makeMapView :: (PView Void GeoPerspective GeoPerspective MyWorld) -> (PView Void GeoMap GeoPerspective MyWorld) makeMapView perspective = pseq perspective contacts paramF writeF readF where paramF {GeoPerspective|bounds} = fmap Right bounds writeF perspective = (perspective,Void) readF perspective contacts = {GeoMap|perspective=perspective,markers=map contactMarker contacts} contacts = applyLens (maybeParam [] contactView) readOnlyLens Start world # myworld = createMyWorld world /* OK # (val, myworld) = get (fixP planeView (Left "PB")) myworld # (val, myworld) = get (fixP planeView (Right (2,3,3,6))) myworld */ /* OK # myworld = registerForNotification planeView (Right (2,3,3,6)) "PC" myworld # (_,myworld) = put (fixP planeView (Left "PC")) [{name = "PC",type = "Plane", position = (2,5)}] myworld # (val, myworld) = get (fixP planeView (Right (2,3,3,6))) myworld */ # (p1,myworld) = createMemoryView {center=(3,3),bounds=Just (2,3,3,6)} myworld # myworld = registerForNotification (makeMapView p1) Void "p1" myworld // OK // # (_,myworld) = put p1 {center=(3,3),bounds=Just (2,3,3,6)} myworld // OK // # (_,myworld) = put (makeMapView p1) {center=(3,3),bounds=Just (2,3,3,6)} myworld // OK // # (_,myworld) = put (fixP planeView (Left "PA")) [{name = "PA",type = "Plane", position = (3,5)}] myworld // OK // # (_,myworld) = put (fixP planeView (Left "PA")) [{name = "PA",type = "Plane", position = (7,7)}] myworld // OK // # (_,myworld) = put (fixP planeView (Left "PB")) [{name = "PB",type = "Plane", position = (7,7)}] myworld # (val, myworld) = get (makeMapView p1) myworld = (val, getWorld myworld)