B:BD[
3.3105] → [
3.3105:3192]
B:BD[
3.3884] → [
3.3885:4158]
B:BD[
10.5128] → [
3.3884:3884]
∅:D[
3.3882] → [
10.5078:5128]
B:BD[
10.5078] → [
10.5078:5128]
B:BD[
10.4796] → [
3.3608:3882]
B:BD[
7.1528] → [
10.4703:4796]
∅:D[
9.2451] → [
7.1527:1528]
∅:D[
10.4702] → [
7.1527:1528]
B:BD[
7.1527] → [
7.1527:1528]
∅:D[
3.3607] → [
10.4375:4702]
B:BD[
10.4375] → [
10.4375:4702]
B:BD[
10.4328] → [
3.3553:3607]
∅:D[
3.3552] → [
10.4252:4328]
B:BD[
10.4252] → [
10.4252:4328]
B:BD[
10.4189] → [
3.3489:3552]
∅:D[
3.3488] → [
10.4054:4189]
B:BD[
10.4054] → [
10.4054:4189]
B:BD[
10.3978] → [
3.3402:3488]
∅:D[
3.3401] → [
10.3898:3978]
B:BD[
10.3898] → [
10.3898:3978]
B:BD[
5.12171] → [
3.3285:3401]
∅:D[
9.2343] → [
5.12170:12171]
B:BD[
5.12170] → [
5.12170:12171]
B:BD[
5.11371] → [
9.2270:2343]
∅:D[
9.2269] → [
5.11370:11371]
∅:D[
10.3796] → [
5.11370:11371]
B:BD[
5.11370] → [
5.11370:11371]
B:BD[
5.10628] → [
10.3697:3796]
∅:D[
9.2102] → [
5.10618:10628]
∅:D[
3.3284] → [
5.10618:10628]
∅:D[
10.3696] → [
5.10618:10628]
∅:D[
16.4039] → [
5.10618:10628]
∅:D[
8.11676] → [
5.10618:10628]
B:BD[
5.10618] → [
5.10618:10628]
B:BD[
8.11614] → [
3.3193:3284]
B:BD[
5.10514] → [
8.11541:11614]
B:BD[
5.10489] → [
5.10489:10514]
∅:D[
10.3634] → [
5.10426:10427]
B:BD[
5.10426] → [
5.10426:10427]
B:BD[
5.10426] → [
10.3565:3634]
∅:D[
7.626] → [
5.10394:10426]
∅:D[
9.2069] → [
5.10394:10426]
∅:D[
10.3564] → [
5.10394:10426]
∅:D[
12.3986] → [
5.10394:10426]
B:BD[
5.10394] → [
5.10394:10426]
∅:D[
3.3192] → [
10.3516:3564]
B:BD[
9.2069] → [
10.3516:3564]
∅:D[
3.4158] → [
9.1912:1913]
B:BD[
5.10238] → [
9.1912:1913]
import Data.IntMap.Strict as IntMap ( IntMap, (!), foldrWithKey, fromDistinctAscList )
n' :: Node a
| free , [dir] <- push = n { atom = get v $ neighbour n dir } -- move in
| free , null push = n { atom = void } -- clear
| not free , d : _ <- dest , free' $ memo ! d = n { atom = void } -- move out
| otherwise = n
| otherwise = True
-- update atom
| Just ni <- loop , i /= ni = False -- ρ tail
| Just ni <- loop , i == ni = dest !! 1 /= i && not (any (lock' . (memo !)) $ takeWhile (/= i) dest) -- closed loop
| ni : _ <- dest = free' $ memo ! ni -- linear (loops ruled out, recurse freely)
-- neighbours are free to move in
free :: Bool
| lock = False -- block
| not . null $ drop 1 push = True -- stall on dispute
| otherwise = False
-- find loop at element x
loop :: Maybe Int
loop = λ mempty (i : dest)
where
λ _ [] = Nothing
λ s (x:xs)
| member x s = Just x
| otherwise = λ (insert x s) xs
| mass $ atom n , null dest = True -- block
| otherwise = False
-- stops movement
lock :: Bool
| d : _ <- dest' $ memo ! neighbour n dir = d == i
| otherwise = []
-- want to move here
push :: [Dir]
push = filter π total
where
π dir
| Just dir <- move $ atom n , ni <- neighbour n dir = ni : dest' (memo ! ni)
where
-- chain of destinations (memory shared)
dest :: [Int]
φ :: Int -> Node a -> ([Memo], [Node a]) -> ([Memo], [Node a])
φ i n = bimap (Memo dest lock free :) (n' :)
intmap :: [v] -> IntMap v
intmap = fromDistinctAscList . zip [0..]
-- fold with future
(,) memo nodes' = bimap intmap intmap $ foldrWithKey φ mempty $ nodes v
where
step f !v = v { nodes = (\n -> n { atom = f (get v . neighbour n) $ atom n }) <$> nodes' }
step :: forall a. Atom a => ((Dir -> a) -> a -> a) -> Verse a -> Verse a
-- | Step in simulation
data Memo = Memo { dest' :: [Int] , lock' :: Bool , free' :: Bool }
import Data.Bifunctor ( bimap )
import Data.IntSet as IntSet ( member, insert )
import Data.Vector as V ( Vector, generate, unsafeIndex, length, map )
import Data.IntSet as IntSet ( member, insert )
data Memo = Memo { mdest :: [Int] , mlock :: Bool , mfree :: Bool }
-- | Step in simulation
step :: forall a. Atom a => (Memo -> (Dir -> a) -> a -> a) -> Verse a -> Verse a
step f v = v { nodes = V.map (\(m,n) -> n { atom = f m (get v . neighbour n) $ atom n }) result }
where
result :: V.Vector (Memo,Node a)
result = V.generate (V.length $ nodes v) φ
memo :: Int -> Memo
memo = fst . V.unsafeIndex result
φ :: Int -> (Memo,Node a)
φ i = (Memo dest lock free , n')
where
n = V.unsafeIndex (nodes v) i
-- chain of destinations (memory shared)
dest :: [Int]
| Just dir <- move $ atom n , ni <- neighbour n dir = ni : mdest (memo ni)
| otherwise = []
-- want to move here
push :: [Dir]
push = filter π total
where
π dir
| d : _ <- mdest $ memo $ neighbour n dir = d == i
| otherwise = False
-- stops movement
lock :: Bool
| mass $ atom n , null dest = True -- block
| not . null $ drop 1 push = True -- stall on dispute
| otherwise = False
-- find loop at element x
loop :: Maybe Int
loop = λ mempty (i : dest)
where
λ _ [] = Nothing
λ s (x:xs)
| member x s = Just x
| otherwise = λ (insert x s) xs
-- neighbours are free to move in
free :: Bool
| lock = False -- block
| Just ni <- loop , i /= ni = False -- ρ tail
| Just ni <- loop , i == ni = dest !! 1 /= i && not (any (mlock . memo) $ takeWhile (/= i) dest) -- closed loop
| ni : _ <- dest = mfree $ memo ni -- linear (loops ruled out, recurse freely)
| otherwise = True
-- update atom
n' :: Node a
| free , [dir] <- push = n { atom = get v $ neighbour n dir } -- move in
| free , null push = n { atom = void } -- clear
| not free , d : _ <- dest , mfree $ memo d = n { atom = void } -- move out
| otherwise = n