-
Notifications
You must be signed in to change notification settings - Fork 1
/
Node.hs
175 lines (139 loc) · 7.57 KB
/
Node.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
module Node where
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Vector as Vec
import qualified Agent as A
import Mixture (MixtureId, ComponentId)
import Injection
import qualified Env as E
import Signature
import Misc
type NodeId = Int
type NodeSet = Set.Set NodeId
type Lift = (MixtureId, ComponentId, InjectionId)
type LiftSet = Set.Set Lift
type Dep = (LiftSet, LiftSet) -- (lifts for int, lifts for lnk)
type PortId = Int -- same as A.SiteId
type PortStatus = (Maybe A.InternalStateId, Ptr) -- (internal state, link state)
data Port = Port { status :: PortStatus
, dep :: Dep
}
deriving (Show, Eq)
type Interface = Vec.Vector Port
data Node = Node { nameId :: A.AgentNameId
, interface :: Interface
, nodeAddress :: Maybe NodeId
}
deriving (Show, Eq)
data Ptr = Null
| Ptr NodeId Int -- we use NodeId instead of Node, because in a functional language you should only keep references
| FPtr Int Int
deriving (Show, Eq)
data IntOrLnk = Int | Lnk
deriving (Show, Eq, Ord)
type ModifiedSite = (PortId, IntOrLnk)
type PortList = [ModifiedSite]
-- exported types
type PortMap = Map.Map NodeId PortList
type NodeMap = Map.Map NodeId Node
getLifts :: Node -> PortId -> Maybe (LiftSet, LiftSet)
getLifts node portId = do port <- interface node Vec.!? portId
return $ dep port
setLifts :: Node -> PortId -> (LiftSet, LiftSet) -> Node
setLifts node portId value = node{ interface = updateVec intf [(portId, port{ dep = value })] "Node.setLifts" }
where intf = interface node
port = intf Vec.!? portId ? "Node.setLifts: port " ++ show portId ++ " not found in node's interface"
getLift :: IntOrLnk -> Node -> PortId -> Maybe LiftSet
getLift Int node portId = do port <- interface node Vec.!? portId
return . fst $ dep port
getLift Lnk node portId = do port <- interface node Vec.!? portId
return . snd $ dep port
setLift :: IntOrLnk -> Node -> PortId -> LiftSet -> Node
setLift int_lnk node portId liftset' = node{ interface = updateVec intf [(portId, port{ dep = liftsets })] "Node.setLift" }
where intf = interface node
port = intf Vec.!? portId ? "Node.setLift: port " ++ show portId ++ " not found in node's interface"
(liftsetInt, liftsetLnk) = dep port
liftsets = case int_lnk of
Int -> (liftset', liftsetLnk)
Lnk -> (liftsetInt, liftset')
foldStatus :: (a -> PortId -> PortStatus -> a) -> a -> Node -> a
foldStatus f seed node = Vec.ifoldl' g seed (interface node)
where g acc portId port = f acc portId (status port)
{-
foldDep :: (PortId -> (LiftSet, LiftSet) -> a -> a) -> a -> Node -> a
foldDep f seed node = Vec.ifoldr (\portId port a -> f portId (dep port) a) seed (interface node)
foldInterface :: (PortId -> Port -> a -> a) -> a -> Node -> a
foldInterface f seed node = Vec.ifoldr f seed (interface node)
-}
getStatus :: Node -> PortId -> Maybe PortStatus
getStatus node portId = do port <- interface node Vec.!? portId
return $ status port
getPtr :: Node -> PortId -> Maybe Ptr
getPtr node portId = liftM snd $ getStatus node portId
getInt :: Node -> PortId -> Maybe (Maybe A.InternalStateId)
getInt node portId = liftM fst $ getStatus node portId
internalState :: Node -> PortId -> Maybe A.InternalStateId
internalState node portId = do port <- interface node Vec.!? portId
fst $ status port
isBound :: Node -> PortId -> Bool
isBound node portId =
case status (interface node Vec.!? portId ? "Node.isBound: port not found") of
(_, FPtr _ _) -> error "Node.isBound: invalid argument"
(_, Null) -> False
(_, Ptr u j) -> True
setPtr :: Node -> PortId -> Ptr -> Node
setPtr node portId value = node{ interface = updateVec intf [(portId, port{ status = (intState, value) })] "Node.setPtr" }
where intf = interface node
port = intf Vec.!? portId ? "Node.setPtr: port " ++ show portId ++ " not found in node's interface"
(intState, _) = status port
setInt :: Node -> PortId -> Maybe A.InternalStateId -> Node
setInt node portId value = node{ interface = updateVec intf [(portId, port{ status = (value, lnkState) })] "Node.setInt" }
where intf = interface node
port = intf Vec.!? portId ? "Node.setInt: port " ++ show portId ++ " not found in node's interface"
(_, lnkState) = status port
createNode :: A.AgentNameId -> Maybe A.Interface -> E.Env -> Node
createNode nameId intf env = Node{ nameId = nameId, interface = interface, nodeAddress = Nothing }
where sign = E.getSig nameId env ? "Node.createNode: signature not found"
interface = Vec.generate (arity sign) addSite
addSite siteId = Port{ status = (intState, Null), dep = (Set.empty, Set.empty) }
where intState = case intf >>= Map.lookup siteId of
Just (state, _) -> state
Nothing -> Just 0 -- TODO why is this? existential site?
addDep :: Node -> PortId -> IntOrLnk -> Lift -> Node
addDep node portId int_lnk lift = node{ interface = updateVec intf [(portId, port{ dep = dep' })] "Node.addDep" }
where intf = interface node
port = intf Vec.!? portId ? "Node.addDep: port " ++ show portId ++ " not found in node's interface"
dep' = add lift int_lnk (dep port)
add :: Lift -> IntOrLnk -> Dep -> Dep
add lift Int (ints, lnks) = (Set.insert lift ints, lnks)
add lift Lnk (ints, lnks) = (ints, Set.insert lift lnks)
addDeps :: Node -> Lift -> PortList -> Node
addDeps node lift = foldr addPort node
where addPort :: ModifiedSite -> Node -> Node
addPort (portId, int_lnk) node = addDep node portId int_lnk lift
allocate :: Node -> NodeId -> Node
allocate node nodeId = node{ nodeAddress = Just nodeId }
-- Tests whether status of port portId of node nodeId is compatible with (int, lnk)
-- If it's not compatible returns Nothing
-- If it is then we return (Int, portId) if the port is int-tested and (Lnk, portId) if it's lnk-tested
test :: (Node, PortId) -> A.Site -> PortList -> Maybe PortList
test (node, portId) (int, lnk) portList =
do portList' <- case int of
Nothing -> return portList -- wildcard in pattern is compatible with anything in the node
s -> do guard $ s == state
return $ (portId, Int):portList
testLink lnk link portList'
where (state, link) = status (interface node Vec.!? portId ? "Node.test: port " ++ show portId ++ " not found in node's interface")
testLink :: A.BindingState -> Ptr -> PortList -> Maybe PortList
testLink A.Unspecified _ portList' = return portList' -- wildcard in pattern is compatible with anything in the node
testLink A.Bound (FPtr _ _) _ = error $ "Node.test: invalid status for bound node " ++ show node ++ " and site " ++ show portId
testLink A.Bound (Ptr _ _) portList' = return $ (portId, Lnk):portList'
testLink A.Bound Null _ = Nothing
testLink A.Free (FPtr _ _) _ = error $ "Node.test: invalid status for free node " ++ show node ++ " and site " ++ show portId
testLink A.Free (Ptr _ _) _ = Nothing
testLink A.Free Null portList' = return $ (portId, Lnk):portList'
testLink A.SemiLink _ _ = error "Node.test: a node should not have semilinks"
follow :: Node -> PortId -> Maybe (NodeId, PortId)
follow node portId = case getPtr node portId ? "Node.follow: node " ++ show node ++ " have no site " ++ show portId of
Ptr v j -> Just (v, j)
_ -> Nothing