Commit 970b84c0 authored by ecrombag's avatar ecrombag

Updated the 'Incident Report (Map)'-example

git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/trunk@703 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent 7f3c974b
......@@ -3,6 +3,9 @@ implementation module AmbulanceDispatchMap
import iTasks
import CommonDomain
import GeoDomain
import RPCStubs
import Base64
import JSONTree
derive gPrint Incident, IncidentType
derive gParse Incident, IncidentType
......@@ -16,10 +19,11 @@ where
flows = [ workflow "Examples/Crisis response/Report incident (Map)" reportIncident ]
:: Incident =
{ location :: Coordinate
{ address :: Note
, type :: IncidentType
, time :: Time
, nrInjured :: Int
, location :: Coordinate
, description :: Note
}
......@@ -36,13 +40,28 @@ markLocations =
enterInformation "Mark all locations where incidents have occurred"
specifiyIncidents :: Map -> Task [Incident]
specifiyIncidents map = sequence "Specify individual incident details" [ (specifyIncident m) \\ m <- map.Map.markers ]
specifiyIncidents map = sequence "Specify individual incident details" [ (addressLookup m) >>= \addr -> (specifyIncident addr m) \\ m <- (reverse map.Map.markers) ]
specifyIncident :: MapMarker -> Task Incident
specifyIncident marker
addressLookup :: MapMarker -> Task String
addressLookup marker
# (lat,lng) = marker.position
= showStickyMessage ("Address is being retrieved for coordinates: ("+++toString lat+++", "+++toString lng+++")")
||- reverse_geocoding (toString lat+++","+++toString lng) "json" False GOOGLE_API_KEY parseJSON
where
parseJSON info
= case toJSONTree (base64Decode info) of
(Just tree)
= case queryJSONTree "Placemark\\1\\address" tree of
(Just addr) = addr
_ = "Address Unknown"
_ = "Address Unknown"
specifyIncident :: String MapMarker -> Task Incident
specifyIncident addr marker
# smap = convertToStaticMap {Map | mkMap & center = marker.position, width = 200, height = 200, zoom = 15, markers = [marker]}
# incident = { Incident
| location = marker.position
, address = Note addr
, type = Accident
, time = {Time | hour = 0, min = 0, sec = 0}
, nrInjured = 0
......
......@@ -10,8 +10,21 @@ definition module JSON
import StdGeneric, StdMaybe
//Abstract token type which is the intermediary representation during JSON parsing
:: Token
//Token type which is the intermediary representation during JSON parsing
:: Token = TokenInt Int
| TokenReal Real
| TokenString String
| TokenBool Bool
| TokenNull
| TokenBracketOpen
| TokenBracketClose
| TokenBraceOpen
| TokenBraceClose
| TokenName String
| TokenColon
| TokenComma
| TokenWhitespace String
| TokenFail
:: JSON = JSON String //String which is already in JSON encoding
......@@ -37,6 +50,12 @@ fromJSON :: String -> Maybe a | JSONDecode{|*|} a
* @return A properly escaped string
*/
jsonEscape :: String -> String
/**
* Lexer for Json-Strings. This function is used by the JSONTree-module.
**/
lex :: String Int [Token] -> (Int, [Token])
/**
* Generic encoding function. This function should not be used
* directly but always through the toJSON function. It must be derived
......
......@@ -102,21 +102,6 @@ intersperse i [x:xs] = [x,i:intersperse i xs]
fromJSON :: String -> Maybe a | JSONDecode{|*|} a
fromJSON input = fst (JSONDecode{|*|} (removeWhitespace (snd (lex input 0 []))))
:: Token = TokenInt Int
| TokenReal Real
| TokenString String
| TokenBool Bool
| TokenNull
| TokenBracketOpen
| TokenBracketClose
| TokenBraceOpen
| TokenBraceClose
| TokenName String
| TokenColon
| TokenComma
| TokenWhitespace String
| TokenFail
removeWhitespace :: [Token] -> [Token]
removeWhitespace l = filter (not o isWhitespaceToken) l
......
definition module JSONTree
/*
* This module provides functions to encode and decode JSON-data without having any prior
* knowledge about the structure of the JSON-data. The data is parsed and a tree of type
* 'JsonNode' is build, which can then be used for further processing. The 'queryJsonNode'
* -function allows for querying the tree structure.
*
* This module depends on the JSON-module for lexing the string input.
*/
import StdMaybe
class getValue a :: JsonNode -> Maybe a
instance getValue Int
instance getValue Real
instance getValue Bool
instance getValue String
instance getValue JsonNode
instance getValue [JsonNode]
//The JsonNode type definition
:: JsonNode = JsonInt String Int
| JsonReal String Real
| JsonString String String
| JsonBool String Bool
| JsonNull String
| JsonObject String [JsonNode]
| JsonArray String [JsonNode]
| JsonEmpty String
/*
* Encode a JsonNode-tree into it's string representation
*
* @param The JsonNode-tree
* @return The String representation in JSON-format
*/
fromJSONTree :: JsonNode -> String
/*
* Convert a JSON-string into a JsonNode-tree
*
* @param The Json-string
* @return The JsonNode-tree
*/
toJSONTree :: String -> Maybe JsonNode
/*
* Seek a specific value in the tree.
*
* @param The query string, consisting of node names (excluding, the 'root' node)
* seperated by \\ (e.g. 'node 1\\node 2'). Array have integer indexes
* assigned to them, e.g. 'node1\\2\\node 2' is a valid expression.
* @return The value of the node
*/
queryJSONTree :: String JsonNode -> Maybe a | getValue a
\ No newline at end of file
implementation module JSONTree
import StdEnv, StdMaybe
import JSON
//--- Decode ----------------------------------
toJSONTree :: String -> Maybe JsonNode
toJSONTree input
# p = (removeWhitespace (snd (lex input 0 [])))
= (parser p)
where
toArray t = {i \\ i <- t}
removeWhitespace l = filter (not o isWhitespaceToken) l
isWhitespaceToken (TokenWhitespace _) = True
isWhitespaceToken _ = False
parser :: [Token] -> Maybe JsonNode
parser [] = Nothing
parser [t:ts]
| isBracketOpen t = buildArrayNode ts "root"
| isBraceOpen t = buildObjectNode ts "root"
| otherwise = Nothing
where
isBracketOpen TokenBracketOpen = True
isBracketOpen _ = False
isBraceOpen TokenBraceOpen = True
isBraceClose _ = False
buildObjectNode :: [Token] String -> Maybe JsonNode
buildObjectNode [TokenBraceClose] name = Just (JsonEmpty name)
buildObjectNode [t] name = Nothing
buildObjectNode input name
= case last input of
TokenBraceClose
# split = splitContents ( init input )
# cont = [ buildNamedNode t \\ t <- split]
| check cont = Just (JsonObject name [(fromJust t) \\ t <- cont])
| otherwise = Nothing
_ = Nothing
where
check [] = True
check [Nothing : ts] = False
check [(Just obj) : ts] = check ts
buildArrayNode :: [Token] String -> Maybe JsonNode
buildArrayNode [TokenBracketClose] name = Just (JsonEmpty name)
buildArrayNode [t] name = Nothing
buildArrayNode input name
= case last input of
TokenBracketClose
# split = splitContents ( init input )
# cont = [ buildAnonNode t i \\ t <- split & i <- [1..] ]
| check cont = Just (JsonArray name [(fromJust t) \\ t <- cont])
| otherwise = Nothing
_ = Nothing
where
check [] = True
check [Nothing : ts] = False
check [(Just obj) : ts] = check ts
buildNamedNode :: [Token] -> Maybe JsonNode
buildNamedNode [(TokenString name):TokenColon:rest] = buildNode rest name
buildNamedNode input = Nothing
buildAnonNode :: [Token] Int -> Maybe JsonNode
buildAnonNode input number = buildNode input (toString number)
buildNode :: [Token] String -> Maybe JsonNode
buildNode [(TokenInt v):r] name = Just (JsonInt name v)
buildNode [(TokenReal v):r] name = Just (JsonReal name v)
buildNode [(TokenString v):r] name = Just (JsonString name v)
buildNode [(TokenBool v):r] name = Just (JsonBool name v)
buildNode [(TokenNull):r] name = Just (JsonNull name)
buildNode [(TokenBracketOpen):r] name = buildArrayNode r name
buildNode [(TokenBraceOpen):r] name = buildObjectNode r name
buildNode r name = Nothing
splitContents :: [Token] -> [[Token]]
splitContents [] = []
splitContents input
# (c,r) = findComma input [] 0
= [c : splitContents r]
where
findComma :: [Token] [Token] Int -> ([Token],[Token])
findComma [] acc lvl = (acc,[])
findComma [t:ts] acc lvl
# lvl = adjustLvl t lvl
| isTokenComma t && lvl == 0 = (acc,ts)
| otherwise = findComma ts (acc++[t]) lvl
isTokenComma TokenComma = True
isTokenComma _ = False
adjustLvl TokenBraceOpen lvl = (lvl+1)
adjustLvl TokenBracketOpen lvl = (lvl+1)
adjustLvl TokenBraceClose lvl = (lvl-1)
adjustLvl TokenBracketClose lvl = (lvl-1)
adjustLvl _ lvl = lvl
//--- Encode ----------------------------------
fromJSONTree :: JsonNode -> String
fromJSONTree (JsonObject name val) = "{"+++jsonTreeToString val+++"}"
fromJSONTree (JsonArray name val) = "["+++jsonTreeToStringAnon val+++"]"
fromJSONTree node = "{"+++jsonTreeToString node+++"}"
class jsonTreeToString a :: a -> String
instance jsonTreeToString JsonNode
where
jsonTreeToString :: JsonNode -> String
jsonTreeToString (JsonInt name val) = "\""+++name+++"\" : "+++(toString val)
jsonTreeToString (JsonReal name val) = "\""+++name+++"\" : "+++(toString val)
jsonTreeToString (JsonBool name val) = "\""+++name+++"\" : "+++(toString val)
jsonTreeToString (JsonString name val) = "\""+++name+++"\" : \""+++(toString val)+++"\""
jsonTreeToString (JsonNull name) = "\""+++name+++"\" : null"
jsonTreeToString (JsonEmpty name ) = "\""+++name+++"\" : null"
jsonTreeToString (JsonObject name val) = "\""+++name+++"\" : {"+++jsonTreeToString val+++"}"
jsonTreeToString (JsonArray name val) = "\""+++name+++"\" : ["+++jsonTreeToStringAnon val+++"]"
instance jsonTreeToString [JsonNode]
where
jsonTreeToString :: [JsonNode] -> String
jsonTreeToString [] = ""
jsonTreeToString [n] = jsonTreeToString n
jsonTreeToString [n:ns] = jsonTreeToString n +++ "," +++ jsonTreeToString ns
class jsonTreeToStringAnon a :: a -> String
instance jsonTreeToStringAnon JsonNode
where
jsonTreeToStringAnon :: JsonNode -> String
jsonTreeToStringAnon (JsonInt name val) = (toString val)
jsonTreeToStringAnon (JsonReal name val) = (toString val)
jsonTreeToStringAnon (JsonBool name val) = (toString val)
jsonTreeToStringAnon (JsonString name val) = "\""+++(toString val)+++"\""
jsonTreeToStringAnon (JsonNull name) = "null"
jsonTreeToStringAnon (JsonEmpty name ) = "null"
jsonTreeToStringAnon (JsonObject name val) = "{"+++jsonTreeToString val+++"}"
jsonTreeToStringAnon (JsonArray name val) = "["+++jsonTreeToStringAnon val+++"]"
instance jsonTreeToStringAnon [JsonNode]
where
jsonTreeToStringAnon :: [JsonNode] -> String
jsonTreeToStringAnon [] = ""
jsonTreeToStringAnon [n] = jsonTreeToStringAnon n
jsonTreeToStringAnon [n:ns] = jsonTreeToStringAnon n +++ "," +++ jsonTreeToStringAnon ns
//--- Query -----------------------------------
queryJSONTree :: String JsonNode -> Maybe a | getValue a
queryJSONTree query tree
# path = splitQuery query
= seekJsonTree path tree
where
splitQuery :: {#Char} -> [String]
splitQuery "" = []
splitQuery query
# (c,r) = findSlash query ""
= [c : splitQuery r]
findSlash :: {#Char} {#Char} -> ({#Char},{#Char})
findSlash "" acc = (acc,"")
findSlash query acc
| query.[0] == '\\' = (acc,{query.[i] \\ i <- [1..((size query)-1)]})
| otherwise = findSlash {query.[i] \\ i <- [1..((size query)-1)]} (acc+++(toString query.[0]))
seekJsonTree :: [String] JsonNode -> Maybe a | getValue a
seekJsonTree [] node = Nothing
seekJsonTree [t] node =
case seekChild t node of
(Just child) = getValue child
Nothing = Nothing
seekJsonTree [t:ts] node =
case seekChild t node of
(Just child) = seekJsonTree ts child
Nothing = Nothing
seekChild :: String JsonNode -> Maybe JsonNode
seekChild query (JsonObject name children) = seekChild` query children
seekChild query (JsonArray name children) = seekChild` query children
seekChild query _ = Nothing
seekChild` :: String [JsonNode] -> Maybe JsonNode
seekChild` query children
# result = [ child \\ child <- children | (matchName child query) ]
| length result > 0 = Just (hd result)
= Nothing
where
matchName (JsonInt name val) query
| (query == name) = True
= False
matchName (JsonReal name val) query
| (query == name) = True
= False
matchName (JsonString name val) query
| (query == name) = True
= False
matchName (JsonBool name val) query
| (query == name) = True
= False
matchName (JsonNull name) query
| (query == name) = True
= False
matchName (JsonObject name val) query
| (query == name) = True
= False
matchName (JsonArray name val) query
| (query == name) = True
= False
matchName (JsonEmpty name) query
| (query == name) = True
= False
instance getValue Int
where
getValue :: JsonNode -> Maybe Int
getValue (JsonInt name val) = Just val
getValue _ = Nothing
instance getValue Real
where
getValue :: JsonNode -> Maybe Real
getValue (JsonReal name val) = Just val
getValue _ = Nothing
instance getValue Bool
where
getValue :: JsonNode -> Maybe Bool
getValue (JsonBool name val) = Just val
getValue _ = Nothing
instance getValue String
where
getValue :: JsonNode -> Maybe String
getValue (JsonString name val) = Just val
getValue _ = Nothing
instance getValue JsonNode
where
getValue :: JsonNode -> Maybe JsonNode
getValue node = Just node
instance getValue [JsonNode]
where
getValue :: JsonNode -> Maybe [JsonNode]
getValue (JsonObject name val) = Just val
getValue (JsonArray name val) = Just val
getValue _ = Nothing
\ No newline at end of file
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment