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
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
|
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveFunctor #-}
--------------------------------------------------------------------------------
module Xanthous.Data.EntityMap
( EntityMap
, _EntityMap
, EntityID
, emptyEntityMap
, insertAt
, insertAtReturningID
, fromEIDsAndPositioned
, toEIDsAndPositioned
, atPosition
, atPositionWithIDs
, positions
, lookup
, lookupWithPosition
-- , positionedEntities
, neighbors
, Deduplicate(..)
-- * debug
, byID
, byPosition
, lastID
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (lookup)
import Xanthous.Data
( Position
, Positioned(..)
, positioned
, Neighbors(..)
, neighborPositions
)
import Xanthous.Orphans ()
import Xanthous.Util (EqEqProp(..))
--------------------------------------------------------------------------------
import Data.Monoid (Endo(..))
import Test.QuickCheck (Arbitrary(..), CoArbitrary, Function)
import Test.QuickCheck.Checkers (EqProp)
import Test.QuickCheck.Instances.UnorderedContainers ()
import Test.QuickCheck.Instances.Vector ()
import Text.Show (showString, showParen)
import Data.Aeson
--------------------------------------------------------------------------------
type EntityID = Word32
type NonNullSet a = NonNull (Set a)
data EntityMap a where
EntityMap ::
{ _byPosition :: Map Position (NonNullSet EntityID)
, _byID :: HashMap EntityID (Positioned a)
, _lastID :: EntityID
} -> EntityMap a
deriving stock (Functor, Foldable, Traversable, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving via (EqEqProp (EntityMap a)) instance (Eq a, Ord a) => EqProp (EntityMap a)
makeLenses ''EntityMap
instance ToJSON a => ToJSON (EntityMap a) where
toJSON = toJSON . toEIDsAndPositioned
instance FromJSON a => FromJSON (EntityMap a) where
parseJSON = fmap (fromEIDsAndPositioned @[_]) . parseJSON
byIDInvariantError :: forall a. a
byIDInvariantError = error $ "Invariant violation: All EntityIDs in byPosition "
<> "must point to entityIDs in byID"
instance (Ord a, Eq a) => Eq (EntityMap a) where
-- em₁ == em₂ = em₁ ^. _EntityMap == em₂ ^. _EntityMap
(==) = (==) `on` view (_EntityMap . to sort)
deriving stock instance (Ord a) => Ord (EntityMap a)
instance Show a => Show (EntityMap a) where
showsPrec pr em
= showParen (pr > 10)
$ showString
. ("fromEIDsAndPositioned " <>)
. show
. toEIDsAndPositioned
$ em
instance Arbitrary a => Arbitrary (EntityMap a) where
arbitrary = review _EntityMap <$> arbitrary
shrink em = review _EntityMap <$> shrink (em ^. _EntityMap)
type instance Index (EntityMap a) = EntityID
type instance IxValue (EntityMap a) = (Positioned a)
instance Ixed (EntityMap a) where ix eid = at eid . traverse
instance At (EntityMap a) where
at eid = lens (view $ byID . at eid) setter
where
setter :: EntityMap a -> Maybe (Positioned a) -> EntityMap a
setter m Nothing = fromMaybe m $ do
Positioned pos _ <- m ^. byID . at eid
pure $ m
& removeEIDAtPos pos
& byID . at eid .~ Nothing
setter m (Just pe@(Positioned pos _)) = m
& (case lookupWithPosition eid m of
Nothing -> id
Just (Positioned origPos _) -> removeEIDAtPos origPos
)
& byID . at eid ?~ pe
& byPosition . at pos %~ \case
Nothing -> Just $ opoint eid
Just es -> Just $ ninsertSet eid es
removeEIDAtPos pos =
byPosition . at pos %~ (>>= fromNullable . ndeleteSet eid)
instance Semigroup (EntityMap a) where
em₁ <> em₂ = alaf Endo foldMap (uncurry insertAt) (em₂ ^. _EntityMap) em₁
instance Monoid (EntityMap a) where
mempty = emptyEntityMap
instance FunctorWithIndex EntityID EntityMap
instance FoldableWithIndex EntityID EntityMap
instance TraversableWithIndex EntityID EntityMap where
itraversed = byID . itraversed . rmap sequenceA . distrib
itraverse = itraverseOf itraversed
type instance Element (EntityMap a) = a
instance MonoFoldable (EntityMap a)
emptyEntityMap :: EntityMap a
emptyEntityMap = EntityMap mempty mempty 0
newtype Deduplicate a = Deduplicate (EntityMap a)
deriving stock (Show, Traversable, Generic)
deriving newtype (Eq, Functor, Foldable, EqProp, Arbitrary)
instance Semigroup (Deduplicate a) where
(Deduplicate em₁) <> (Deduplicate em₂) =
let _byID = em₁ ^. byID <> em₂ ^. byID
_byPosition = mempty &~ do
ifor_ _byID $ \eid (Positioned pos _) ->
at pos %= \case
Just eids -> Just $ ninsertSet eid eids
Nothing -> Just $ opoint eid
_lastID = fromMaybe 1 $ maximumOf (ifolded . asIndex) _byID
in Deduplicate EntityMap{..}
--------------------------------------------------------------------------------
_EntityMap :: Iso' (EntityMap a) [(Position, a)]
_EntityMap = iso hither yon
where
hither :: EntityMap a -> [(Position, a)]
hither em = do
(pos, eids) <- em ^. byPosition . _Wrapped
eid <- toList eids
ent <- em ^.. byID . at eid . folded . positioned
pure (pos, ent)
yon :: [(Position, a)] -> EntityMap a
yon poses = alaf Endo foldMap (uncurry insertAt) poses emptyEntityMap
insertAtReturningID :: forall a. Position -> a -> EntityMap a -> (EntityID, EntityMap a)
insertAtReturningID pos e em =
let (eid, em') = em & lastID <+~ 1
in em'
& byID . at eid ?~ Positioned pos e
& byPosition . at pos %~ \case
Nothing -> Just $ opoint eid
Just es -> Just $ ninsertSet eid es
& (eid, )
insertAt :: forall a. Position -> a -> EntityMap a -> EntityMap a
insertAt pos e = snd . insertAtReturningID pos e
atPosition :: forall a. Position -> Lens' (EntityMap a) (Vector a)
atPosition pos = lens getter setter
where
getter em =
let eids :: Vector EntityID
eids = maybe mempty (toVector . toNullable)
$ em ^. byPosition . at pos
in getEIDAssume em <$> eids
setter em Empty = em & byPosition . at pos .~ Nothing
setter em entities = alaf Endo foldMap (insertAt pos) entities em
getEIDAssume :: EntityMap a -> EntityID -> a
getEIDAssume em eid = fromMaybe byIDInvariantError
$ em ^? byID . ix eid . positioned
atPositionWithIDs :: Position -> EntityMap a -> Vector (EntityID, Positioned a)
atPositionWithIDs pos em =
let eids = maybe mempty (toVector . toNullable)
$ em ^. byPosition . at pos
in (id &&& Positioned pos . getEIDAssume em) <$> eids
fromEIDsAndPositioned
:: forall mono a. (MonoFoldable mono, Element mono ~ (EntityID, Positioned a))
=> mono
-> EntityMap a
fromEIDsAndPositioned eps = newLastID $ alaf Endo foldMap insert' eps mempty
where
insert' (eid, pe@(Positioned pos _))
= (byID . at eid ?~ pe)
. (byPosition . at pos %~ \case
Just eids -> Just $ ninsertSet eid eids
Nothing -> Just $ opoint eid
)
newLastID em = em & lastID
.~ fromMaybe 1
(maximumOf (ifolded . asIndex) (em ^. byID))
toEIDsAndPositioned :: EntityMap a -> [(EntityID, Positioned a)]
toEIDsAndPositioned = itoListOf $ byID . ifolded
positions :: EntityMap a -> [Position]
positions = toListOf $ byPosition . to keys . folded
lookupWithPosition :: EntityID -> EntityMap a -> Maybe (Positioned a)
lookupWithPosition eid = view $ byID . at eid
lookup :: EntityID -> EntityMap a -> Maybe a
lookup eid = fmap (view positioned) . lookupWithPosition eid
-- unlawful :(
-- positionedEntities :: IndexedTraversal EntityID (EntityMap a) (EntityMap b) (Positioned a) (Positioned b)
-- positionedEntities = byID . itraversed
neighbors :: Position -> EntityMap a -> Neighbors (Vector a)
neighbors pos em = (\p -> view (atPosition p) em) <$> neighborPositions pos
--------------------------------------------------------------------------------
makeWrapped ''Deduplicate
|
