keep track of satisfied requests, and summarize
This commit is contained in:
parent
4a99d835ba
commit
6abc6fe9d6
2 changed files with 33 additions and 13 deletions
|
@ -90,6 +90,11 @@ For a node that only transfers files between the immobile nodes:
|
||||||
|
|
||||||
requestedby=1
|
requestedby=1
|
||||||
|
|
||||||
|
For an immobile node that only accumulates files it requests, but never
|
||||||
|
stores files requested by other nodes:
|
||||||
|
|
||||||
|
present or requested
|
||||||
|
|
||||||
TODO: Would be nice to be able to prioritize files that more nodes are
|
TODO: Would be nice to be able to prioritize files that more nodes are
|
||||||
requesting, or that have some urgent flag set. But currently there is no
|
requesting, or that have some urgent flag set. But currently there is no
|
||||||
way to do that; content is either preferred or not preferred.
|
way to do that; content is either preferred or not preferred.
|
||||||
|
|
|
@ -87,6 +87,7 @@ data TransferNode = TransferNode
|
||||||
data NodeRepo = NodeRepo
|
data NodeRepo = NodeRepo
|
||||||
{ wantFiles :: [Request]
|
{ wantFiles :: [Request]
|
||||||
, haveFiles :: S.Set File
|
, haveFiles :: S.Set File
|
||||||
|
, satisfiedRequests :: S.Set Request
|
||||||
}
|
}
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
@ -97,7 +98,7 @@ randomFile :: (RandomGen g) => Rand g File
|
||||||
randomFile = File <$> getRandomR (0, totalFiles)
|
randomFile = File <$> getRandomR (0, totalFiles)
|
||||||
|
|
||||||
data Request = Request File TTL
|
data Request = Request File TTL
|
||||||
deriving (Show)
|
deriving (Show, Ord)
|
||||||
|
|
||||||
-- compare ignoring TTL
|
-- compare ignoring TTL
|
||||||
instance Eq Request where
|
instance Eq Request where
|
||||||
|
@ -164,30 +165,42 @@ step (Network immobiles transfers) = go immobiles [] transfers
|
||||||
then case M.lookup (currentlocation t) is of
|
then case M.lookup (currentlocation t) is of
|
||||||
Nothing -> go is (c ++ [t]) ts
|
Nothing -> go is (c ++ [t]) ts
|
||||||
Just currentloc -> do
|
Just currentloc -> do
|
||||||
let (currentloc', t') = exchangeRequestsFiles currentloc t
|
let (currentloc', t') = merge currentloc t
|
||||||
t'' <- move t'
|
t'' <- move t'
|
||||||
go (M.insert (currentlocation t) currentloc' is) (c ++ [t'']) ts
|
go (M.insert (currentlocation t) currentloc' is) (c ++ [t'']) ts
|
||||||
else go is (c ++ [t]) ts
|
else go is (c ++ [t]) ts
|
||||||
|
|
||||||
type Exchanger = ImmobileNode -> TransferNode -> (ImmobileNode, TransferNode)
|
merge :: ImmobileNode -> TransferNode -> (ImmobileNode, TransferNode)
|
||||||
|
merge (ImmobileNode ir) t@(TransferNode { transferrepo = tr }) =
|
||||||
exchangeRequestsFiles :: Exchanger
|
|
||||||
exchangeRequestsFiles (ImmobileNode ir) t@(TransferNode { transferrepo = tr }) =
|
|
||||||
( ImmobileNode (go ir tr)
|
( ImmobileNode (go ir tr)
|
||||||
, t { transferrepo = go tr ir }
|
, t { transferrepo = go tr ir }
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
go r1 r2 = r1
|
go r1 r2 = r1
|
||||||
{ wantFiles = foldr addRequest (wantFiles r1) (wantFiles r2)
|
{ wantFiles = wantFiles'
|
||||||
, haveFiles = S.foldr (addFile (wantFiles r1)) (haveFiles r1) (haveFiles r2)
|
, haveFiles = haveFiles'
|
||||||
|
, satisfiedRequests = satisfiedRequests' `S.union` checkSatisfied wantFiles' haveFiles'
|
||||||
}
|
}
|
||||||
|
where
|
||||||
|
wantFiles' = foldr addRequest (wantFiles r1) (wantFiles r2)
|
||||||
|
haveFiles' = S.foldr (addFile wantFiles' satisfiedRequests') (haveFiles r1) (haveFiles r2)
|
||||||
|
satisfiedRequests' = satisfiedRequests r1 `S.union` satisfiedRequests r2
|
||||||
|
|
||||||
-- Adds a file to the set, when there's a request for it.
|
-- Adds a file to the set, when there's a request for it, and the request
|
||||||
addFile :: [Request] -> File -> S.Set File -> S.Set File
|
-- has not already been satisfied.
|
||||||
addFile rs f fs
|
addFile :: [Request] -> S.Set Request -> File -> S.Set File -> S.Set File
|
||||||
|
addFile rs srs f fs
|
||||||
|
| any (\sr -> f == requestedFile sr) (S.toList srs) = fs
|
||||||
| any (\r -> f == requestedFile r) rs = S.insert f fs
|
| any (\r -> f == requestedFile r) rs = S.insert f fs
|
||||||
| otherwise = fs
|
| otherwise = fs
|
||||||
|
|
||||||
|
-- Checks if any requests have been satisfied, and returns them,
|
||||||
|
-- to be added to satisfidRequests
|
||||||
|
checkSatisfied :: [Request] -> S.Set File -> S.Set Request
|
||||||
|
checkSatisfied want have = S.fromList (filter satisfied want)
|
||||||
|
where
|
||||||
|
satisfied r = requestTTL r == originTTL && S.member (requestedFile r) have
|
||||||
|
|
||||||
-- Decrements TTL, and avoids adding request with a stale TTL, or a
|
-- Decrements TTL, and avoids adding request with a stale TTL, or a
|
||||||
-- request for an already added file with the same or a lower TTL.
|
-- request for an already added file with the same or a lower TTL.
|
||||||
addRequest :: Request -> [Request] -> [Request]
|
addRequest :: Request -> [Request] -> [Request]
|
||||||
|
@ -212,7 +225,7 @@ genNetwork = do
|
||||||
return $ Network immobiles transfers
|
return $ Network immobiles transfers
|
||||||
|
|
||||||
emptyImmobile :: ImmobileNode
|
emptyImmobile :: ImmobileNode
|
||||||
emptyImmobile = ImmobileNode (NodeRepo [] S.empty)
|
emptyImmobile = ImmobileNode (NodeRepo [] S.empty S.empty)
|
||||||
|
|
||||||
mkTransfer :: (RandomGen g) => [NodeName] -> Rand g TransferNode
|
mkTransfer :: (RandomGen g) => [NodeName] -> Rand g TransferNode
|
||||||
mkTransfer immobiles = do
|
mkTransfer immobiles = do
|
||||||
|
@ -227,7 +240,7 @@ mkTransferBetween possiblelocs = do
|
||||||
currentloc <- randomfrom possiblelocs
|
currentloc <- randomfrom possiblelocs
|
||||||
movefreq <- getRandomR transferMoveFrequencyRange
|
movefreq <- getRandomR transferMoveFrequencyRange
|
||||||
-- transfer nodes start out with no files or requests in their repo
|
-- transfer nodes start out with no files or requests in their repo
|
||||||
let repo = (NodeRepo [] S.empty)
|
let repo = (NodeRepo [] S.empty S.empty)
|
||||||
return $ TransferNode currentloc possiblelocs movefreq repo
|
return $ TransferNode currentloc possiblelocs movefreq repo
|
||||||
|
|
||||||
randomfrom :: (RandomGen g) => [a] -> Rand g a
|
randomfrom :: (RandomGen g) => [a] -> Rand g a
|
||||||
|
@ -265,6 +278,8 @@ summarize _initial@(Network origis _) _final@(Network is _ts) = format
|
||||||
, ("Nodes that failed to get files",
|
, ("Nodes that failed to get files",
|
||||||
show (map withinitiallocs $ filter (not . S.null . snd)
|
show (map withinitiallocs $ filter (not . S.null . snd)
|
||||||
(M.toList $ M.map (findunsatisfied . repo) is)))
|
(M.toList $ M.map (findunsatisfied . repo) is)))
|
||||||
|
, ("Total number of files on immobile nodes at end",
|
||||||
|
show (overis (S.size . haveFiles . repo)))
|
||||||
--, ("Immobile nodes at end", show is)
|
--, ("Immobile nodes at end", show is)
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue