Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 302 lines (257 sloc) 18.753 kB
3e00ef3 @rhz first commit
authored
1 module Dynamics where
2
3 import qualified Data.Set as Set
4 import qualified Data.Map as Map
5 import Data.Maybe (isJust, fromJust)
6 import Data.Foldable (foldlM)
7
8 import Agent
9 import qualified Mixture as M
10 import qualified Node as N
11 import Signature
12 import Env
13 import Misc
14
15 data Id = Fresh AgentId | Kept AgentId -- binding or modifying a port that has been added or kept from the lhs
16 deriving (Show, Eq, Ord)
17
18 type Port = (Id, SiteId)
19 data Action = Bnd Port Port
20 | Brk Port Bool -- Brk p b with b = True if Brk is side-effect free -- break link
21 | Mod Port InternalStateId
22 | Del N.NodeId
23 | Add AgentId AgentNameId -- (id in mixture, agentId)
24 deriving (Show, Eq)
25
26 type Balance = (Int, Int, Int) -- (#deleted, #preserved, #removed)
27
28 type ModifiedSiteSet = Set.Set N.ModifiedSite
29 type ModifiedSiteMap = Map.Map Id ModifiedSiteSet
30
31 data Rule = Rule{ k :: Double, -- AE -- standard kinetic constant
32 -- kUnary :: Maybe Double, -- Maybe AE -- possible unary kinetic rate -- what's this?
33 oversampling :: Maybe Double, -- boosted kinetic rate for Bologna technique
34 lhs :: M.Expr,
35 rhs :: M.Expr,
36 ruleId :: RuleId,
37 script :: [Action],
38 balance :: Balance,
39 added :: M.AgentIdSet,
40 sideEffects :: Bool,
41 modifiedSites :: ModifiedSiteMap }
42 deriving (Show, Eq)
43
44 -- Simply put, Glueings and Matchings are between two Exprs (normally lhs -> rhs) and
45 -- InjectionMaps and Embeddings are between a Expr and a SiteGraph (eg lhs -> mixture)
46 type Glueing = Map.Map AgentId AgentId
47 type Matching = (AgentId, AgentId)
48 type MatchingSet = Set.Set Matching
49
50
51 -- Analyze the differences between the left-hand side and right-hand side of a rule
52 diff :: M.Expr -> M.Expr -> Env -> ([Action], Balance, M.AgentIdSet, ModifiedSiteMap, Bool)
53 diff m1 m2 env =
54 (insts', balance, Set.fromList added, modifiedSites', sideEffects')
55 where
56 (prefix, deleted, added) = pairExprs m1 m2
57 balance = (length deleted, length prefix, length added)
58 deleteInst = map Del deleted -- insts are instructions
59 createInst = map add added
60 add id = Add id (nameId $ M.agentOfId id m2 ? "Dynamics.diff: agent not found in rhs")
61 sideEffects = not $ null deleteInst
62 (insts, modifiedSites) = foldr addConnections (deleteInst ++ createInst, Map.empty) added
63 (insts', modifiedSites', sideEffects') = foldr addModifications (insts, modifiedSites, sideEffects) prefix
64
65 addMap :: Id -> N.ModifiedSite -> ModifiedSiteMap -> ModifiedSiteMap
66 addMap id siteType map = Map.insert id (Set.insert siteType set) map
67 where set = Map.findWithDefault Set.empty id map
68
69 -- Adding connections of new agents if partner has a lower id
70 addConnections :: AgentId -> ([Action], ModifiedSiteMap) -> ([Action], ModifiedSiteMap)
71 addConnections id (insts, modifiedSites) = (insts', modifiedSites')
72 where (Agent nameId intf) = M.agentOfId id m2 ? "Dynamics.diff: agent not found in rhs"
73 sign@(Sig _ (_, siteMap) _) = getSig nameId env ? "Dynamics.diff: signature not found"
74
75 modifiedSites' = foldr addSite modifiedSites (Map.elems siteMap)
76 addSite :: SiteId -> ModifiedSiteMap -> ModifiedSiteMap
77 addSite siteId idMap = addMap (Fresh id) (siteId, N.Int) (addMap (Fresh id) (siteId, N.Lnk) idMap)
78
79 insts' = Map.foldrWithKey addInst insts intf
80 msg = "Dynamics.diff: adding an agent that is not "
81
82 defaultState :: SiteId -> Maybe InternalState
83 defaultState siteId = internalStateOfNum siteId 0 sign
84
85 addModInst :: Maybe InternalStateId -> Maybe InternalState -> SiteId -> [Action] -> [Action]
86 addModInst Nothing Nothing _ insts = insts
87 addModInst (Just _) Nothing _ insts = insts -- DCDW: default will be assumed
88 addModInst (Just stateId) (Just _) siteId insts = Mod (Fresh id, siteId) stateId : insts
89 addModInst Nothing (Just _) _ _ = error $ msg ++ "supposed to have an internal state"
90
91 addInst :: SiteId -> (Maybe InternalStateId, BindingState) -> [Action] -> [Action]
92 addInst _ (_, Unspecified) _ = error $ msg ++ "fully described (unspecified binding state)"
93 addInst siteId (internalStateId, Free) insts = addModInst internalStateId (defaultState siteId) siteId insts
94 addInst siteId (internalStateId, Bound) insts = if i < id || i == id && x < siteId
95 then Bnd (bndi, x) (Fresh id, siteId) : insts'
96 else insts'
97 where insts' = addModInst internalStateId (defaultState siteId) siteId insts
98 (i, x) = M.follow (id, siteId) m1 ? msg ++ "fully described (semi link)"
99 bndi = if i `elem` added
100 then Fresh i
101 else Kept i
102
103 -- Adding link and internal state modifications for agents conserved by the rule
104 addModifications :: AgentId -> ([Action], ModifiedSiteMap, Bool) -> ([Action], ModifiedSiteMap, Bool)
105 addModifications id (insts, modifiedSites, sideEffects) =
106 Map.foldrWithKey addSite (insts, modifiedSites, sideEffects) intf1
107 where
108 (Agent _ intf1) = M.agentOfId id m1 ? "Dynamics.diff: agent not found in lhs"
109 (Agent _ intf2) = M.agentOfId id m2 ? "Dynamics.diff: agent not found in rhs"
110
111 addSite :: SiteId -> (Maybe InternalStateId, BindingState) -> ([Action], ModifiedSiteMap, Bool) -> ([Action], ModifiedSiteMap, Bool)
112 addSite siteId (intStateId1, lnkState1) (insts, modifiedSites, sideEffects) =
113 addLnkStates lnkState1 lnkState2 (insts', modifiedSites', sideEffects)
114 where
115 (insts', modifiedSites') = addIntStates intStateId1 intStateId2 (insts, modifiedSites)
116 (intStateId2, lnkState2) = Map.lookup siteId intf2 ? "Dynamics.diff: invariant violation"
117
118 addIntStates :: Maybe InternalStateId -> Maybe InternalStateId -> ([Action], ModifiedSiteMap) -> ([Action], ModifiedSiteMap)
119 addIntStates (Just i) (Just j) (insts, idmap) =
120 if i == j
121 then (insts, idmap)
122 else (insts', idmap')
123 where insts' = Mod (Kept id, siteId) j : insts
124 idmap' = addMap (Kept id) (siteId, N.Int) idmap
125 addIntStates (Just i) Nothing (insts, idmap) =
126 error "Dynamics.diff: agent not instanciated on the right"
127 addIntStates Nothing (Just j) (insts, idmap) = (insts', idmap')
128 where insts' = Mod (Kept id, siteId) j : insts
129 idmap' = addMap (Kept id) (siteId, N.Int) idmap
130 addIntStates Nothing Nothing (insts, idmap) = (insts, idmap)
131
132 addLnkStates :: BindingState -> BindingState -> ([Action], ModifiedSiteMap, Bool) -> ([Action], ModifiedSiteMap, Bool)
133 addLnkStates Bound Free (insts, idmap, sideEffects) = -- connected -> disconnected
134 case M.follow (id, siteId) m1 of
135 Just (id', siteId') -> -- generating a Brk instruction only for the smallest port
136 let kept = id' `elem` prefix
137 idmap' = if kept
138 then addMap (Kept id) (siteId, N.Lnk) (addMap (Kept id') (siteId', N.Lnk) idmap)
139 else addMap (Kept id) (siteId, N.Lnk) idmap
140 insts' = if id' < id || (id' == id && siteId' < siteId)
141 then Brk (Kept id, siteId) True : insts
142 else insts
143 in (insts', idmap', sideEffects)
144 Nothing -> -- breaking a semi link so generate a Brk instruction
145 let idmap' = addMap (Kept id) (siteId, N.Lnk) idmap
146 insts' = Brk (Kept id, siteId) False : insts
147 in (insts', idmap', True)
148
149 addLnkStates Bound Bound (insts, idmap, sideEffects) = -- connected -> connected
150 case (M.follow (id, siteId) m1, M.follow (id, siteId) m2) of
151 (Nothing, Just (id2, i2)) -> -- sub-case: semi-link -> connected
152 if id2 < id || (id2 == id && i2 < siteId)
153 then let insts' = Bnd (Kept id, siteId) (Kept id2, i2) : insts
154 idmap' = addMap (Kept id) (siteId, N.Lnk) (addMap (Kept id2) (i2, N.Lnk) idmap)
155 in (insts', idmap', True)
156 else (insts, idmap, sideEffects)
157 (Just (id1, i1), Just (id2, i2)) -> -- sub-case: connected -> connected
158 if id2 < id || (id2 == id && i2 < siteId)
159 then let insts' = Bnd (Kept id, siteId) (Kept id2, i2) : insts
160 idmap' = if id1 `elem` prefix
161 then addMap (Kept id1) (i1, N.Lnk) idmap
162 else idmap
163 idmap'' = addMap (Kept id2) (i2, N.Lnk) idmap'
164 idmap''' = addMap (Kept id) (siteId, N.Lnk) idmap''
165 in (insts', idmap''', sideEffects)
166 else (insts, idmap, sideEffects)
167 (Just (id1, i1), Nothing) -> -- sub-case: connected -> semi-link
168 error "Dynamics.diff: rhs has partial link state"
169 (Nothing, Nothing) -> (insts, idmap, sideEffects) -- sub-case: semi-link -> semi-link
170
171 addLnkStates Free Bound (insts, idmap, sideEffects) = -- free -> connected
172 case M.follow (id, siteId) m2 of
173 Nothing -> error "Dynamics.diff: rhs creates a semi-link" -- sub-case: free -> semi-link
174 Just (id', siteId') -> -- sub-case: free -> connected
175 if (id' < id) || (id' == id && siteId' < siteId)
176 then let insts' = Bnd (Kept id, siteId) (Kept id', siteId') : insts
177 idmap' = addMap (Kept id) (siteId, N.Lnk) (addMap (Kept id') (siteId', N.Lnk) idmap)
178 in (insts', idmap', sideEffects)
179 else (insts, idmap, sideEffects)
180
181 addLnkStates Free Free (insts, idmap, sideEffects) = (insts, idmap, sideEffects) -- free -> free
182 addLnkStates SemiLink SemiLink (insts, idmap, sideEffects) = (insts, idmap, sideEffects) -- semilink -> semilink
183 addLnkStates Unspecified Unspecified (insts, idmap, sideEffects) = (insts, idmap, sideEffects) -- wildcard -> wildcard
184
185 addLnkStates Unspecified Free (insts, idmap, sideEffects) = (insts', idmap', True) -- wildcard -> free
186 where insts' = Brk (Kept id, siteId) False : insts
187 idmap' = addMap (Kept id) (siteId, N.Lnk) idmap
188
189 addLnkStates Unspecified Bound (insts, idmap, sideEffects) = -- wildcard -> connected
190 case M.follow (id, siteId) m2 of
191 Nothing -> error "Dynamics.diff: rhs turns a wildcard into a semi link"
192 Just (id', siteId') -> if (id' < id) || (id' == id && siteId' < siteId)
193 then let insts' = Bnd (Kept id, siteId) (Kept id', siteId') : insts
194 idmap' = addMap (Kept id) (siteId, N.Lnk)
195 (addMap (Kept id') (siteId', N.Lnk) idmap)
196 in (insts', idmap', True)
197 else (insts, idmap, sideEffects)
198
199 addLnkStates lnk1 lnk2 _ = error $ "Dynamics.diff: rhs creates a wildcard (" ++ show lnk1 ++ " -> " ++ show lnk2 ++ ")" -- connected or free -> wildcard
200
201
202 -- Find the largest common prefix between the lhs and rhs.
203 -- Find also the agents that are created and deleted by the rule.
204 pairExprs :: M.Expr -> M.Expr -> ([AgentId], [AgentId], [AgentId])
205 pairExprs (M.Expr {M.agents = as1}) (M.Expr {M.agents = as2}) = (prefix, deleted, added)
206 where
207 (prefix, deleted, addIndex) = Map.foldrWithKey addAgent ([], [], Map.size as1) as1
208 added = foldr (\id added -> if id < addIndex then added else id:added) [] (Map.keys as2)
209
210 addAgent id a1 (prefix, [], addIndex) = case Map.lookup id as2 of
211 Just a2 -> if idPreserving a1 a2
212 then (id:prefix, [], addIndex)
213 else (prefix, [id], min id addIndex)
214 Nothing -> (prefix, [id], addIndex)
215 addAgent id _ (prefix, deleted, addIndex) = (prefix, id:deleted, addIndex)
216
217 -- Check whether a2 can be the residual of a1 for (same name, same sites)
218 idPreserving :: Agent -> Agent -> Bool
219 idPreserving (Agent id1 intf1) (Agent id2 intf2) =
220 id1 == id2 && Set.null (Map.keysSet intf1 Set.\\ Map.keysSet intf2) -- `Set.union` (siteNames2 Set.\\ siteNames1))?
221
222
223 superpose :: [Matching] -> M.Expr -> M.Expr -> M.AgentIdSet -> Env -> Maybe Glueing
224 superpose todo lhs rhs added env = superpose' Map.empty Set.empty todo
225 where superpose' :: Glueing -> MatchingSet -> [Matching] -> Maybe Glueing
226 superpose' m alreadyDone [] = Just m
227 superpose' m alreadyDone ((lhsId, rhsId):todo) =
228 do guard $ nameLhs == nameRhs
229 (todo', alreadyDone') <- foldM addSite (todo, alreadyDone) (Map.toList intfLhs)
230 superpose' (Map.insert lhsId rhsId m) alreadyDone' todo'
231 where lhsAgent@(Agent nameLhs intfLhs) = M.agentOfId lhsId lhs ? "Dynamics.superpose: agent id " ++ show lhsId ++ " not found in lhs (" ++ show lhs ++ ", " ++ show rhs ++ ")\n" ++ show env
232 rhsAgent@(Agent nameRhs _) = M.agentOfId rhsId rhs ? "Dynamics.superpose: agent id " ++ show rhsId ++ " not found in rhs"
233
234 addSite :: ([Matching], MatchingSet) -> (SiteId, Site) -> Maybe ([Matching], MatchingSet)
235 addSite (todo, alreadyDone) (siteId, (int, lnk)) =
236 case M.siteDefined siteId rhsAgent of
237 Nothing -> Just (todo, alreadyDone) -- siteId is not in the agent in the rhs
238 Just (int', lnk') -> case (int, int') of
239 (Just i, Just i') -> do guard $ i == i'
240 checkBindingState lnk lnk'
241 _ -> checkBindingState lnk lnk'
242 where
243 checkBindingState Bound Bound = checkNbs lhsNb rhsNb -- nb = neighbour
244 where lhsNb = M.follow (lhsId, siteId) lhs
245 rhsNb = M.follow (rhsId, siteId) rhs
246
247 checkNbs (Just (lhsId', siteId')) (Just (rhsId', siteId''))
248 | siteId' /= siteId'' = Nothing
249 | Set.member (lhsId', rhsId') alreadyDone = Just (todo, alreadyDone)
250 | otherwise = Just ((lhsId', rhsId') : todo, Set.insert (lhsId', rhsId') alreadyDone)
251 checkNbs _ _ = Just (todo, alreadyDone)
252
253 checkBindingState Free Free = Just (todo, alreadyDone)
254 checkBindingState Unspecified Unspecified = Just (todo, alreadyDone)
255 checkBindingState _ _ = Nothing
256
257
258 enable :: Rule -> M.Expr -> Env -> [Glueing]
259 enable (Rule{ modifiedSites = idmap, rhs = rhs, added = added }) lhs env =
260 fst $ Map.foldrWithKey (unify . extractId) ([], Set.empty) idmap
261 where
262 extractId (Fresh agentId) = agentId -- id of the agent to which a modified site belongs
263 extractId (Kept agentId) = agentId
264
265 -- agentId1 is the agent id of a site which is modified by the rule
266 -- It'll be used as an anchor agent to try to glue the rhs of the rule with lhs
267 unify :: AgentId -> ModifiedSiteSet -> ([Glueing], MatchingSet) -> ([Glueing], MatchingSet)
268 unify agentId1 modifiedSites (glueings, alreadyDone) =
269 Set.fold addGlueings (glueings, alreadyDone) candidates
270 where candidates = foldr addCandidates Set.empty ccIds -- agent ids in lhs that have the name as agentId1
271 nameId1 = nameId (M.agentOfId agentId1 rhs ? "Dynamics.enable: agent " ++ show agentId1 ++ " not found in rhs")
272
273 ccIds = [0..arityLhs - 1]
274 arityLhs = M.arity lhs ? "Dynamics.enable: arity of lhs has not been computed"
275
276 addCandidates :: M.ComponentId -> M.AgentIdSet -> M.AgentIdSet
277 addCandidates ccId = Set.union (M.idsOfName (nameId1, ccId) lhs)
278
279 -- agentId2 is the agent id of a agent in lhs with the same name as agentId1
280 -- Thus, it's a possible candidate for a glueing
281 addGlueings :: AgentId -> ([Glueing], MatchingSet) -> ([Glueing], MatchingSet)
282 addGlueings agentId2 (glueings, alreadyDone) = fromMaybe (glueings, alreadyDone) $
283 do agent2 <- M.agentOfId agentId2 lhs
284 guard $ any (inLhs agent2) (Set.toList modifiedSites) -- check that lhs contains -ie tests- a site that is modified by the rule
285 m <- superpose [(agentId2, agentId1)] lhs rhs added env -- m: mixId -> ruleId
286 let (i, j) = Map.findMin m -- Jean uses Map.root here, but according to the OCaml Batteries Included sources Map.root is implemented as Map.findMin
287 guard $ Set.notMember (i, j) alreadyDone
288 return (m : glueings, Map.foldrWithKey (curry Set.insert) alreadyDone m)
289 where
290 inLhs :: Agent -> N.ModifiedSite -> Bool
291 inLhs agent (siteId, int_lnk) = case M.siteDefined siteId agent of
292 Nothing -> False -- site not defined
293 Just (intState, lnkState) -> case int_lnk of
294 N.Int -> case intState of
295 Nothing -> False -- site can't be modified
296 Just _ -> True
297 N.Lnk -> case lnkState of
298 Unspecified -> False
299 _ -> True
300
301
Something went wrong with that request. Please try again.