module Util.VariableSet(
HasKey(..),
Keyed(..),
VariableSetUpdate(..),
VariableSet(..),
newEmptyVariableSet,
newVariableSet,
updateSet,
setVariableSet,
VariableSetSource,
emptyVariableSetSource,
mapVariableSetSourceIO',
concatVariableSetSource,
mapVariableSetSource,
singletonSetSource,
listToSetSource,
) where
import Data.Maybe
import qualified Data.List as List
import qualified Data.Set as Set
import Util.Dynamics
import Util.Sources
import Util.Broadcaster
class Ord key => HasKey x key | x -> key where
toKey :: x -> key
newtype Keyed x = Keyed x
unKey :: Keyed x -> x
unKey (Keyed x) = x
lift :: (HasKey x1 key1,HasKey x2 key2)
=> (key1 -> key2 -> a) -> (Keyed x1 -> Keyed x2 -> a)
lift f x1 x2 = f (toKey . unKey $ x1) (toKey . unKey $ x2)
instance HasKey x key => Eq (Keyed x) where
(==) = lift (==)
(/=) = lift (/=)
instance HasKey x key => Ord (Keyed x) where
compare = lift compare
(<=) = lift (<=)
(>=) = lift (>=)
(<) = lift (<)
(>) = lift (>)
newtype VariableSetData x = VariableSetData (Set.Set (Keyed x))
data VariableSetUpdate x =
AddElement x
| DelElement x
| BeginGroup
| EndGroup
update :: HasKey x key
=> VariableSetUpdate x -> VariableSetData x
-> (VariableSetData x,[VariableSetUpdate x])
update setUpdate (variableSet @ (VariableSetData set)) =
let
noop = (variableSet,[])
grouper = (variableSet,[setUpdate])
oneop newSet = (VariableSetData newSet,[setUpdate])
in
case setUpdate of
AddElement x ->
let
kx = Keyed x
isElement = Set.member kx set
in
if isElement then noop else oneop (Set.insert kx set)
DelElement x ->
let
kx = Keyed x
isElement = Set.member kx set
in
if isElement then oneop (Set.delete kx set)
else noop
BeginGroup -> grouper
EndGroup -> grouper
newtype VariableSet x
= VariableSet (Broadcaster (VariableSetData x) (VariableSetUpdate x))
deriving (Typeable)
newEmptyVariableSet :: HasKey x key => IO (VariableSet x)
newEmptyVariableSet =
do
broadcaster <- newBroadcaster (VariableSetData Set.empty)
return (VariableSet broadcaster)
newVariableSet :: HasKey x key => [x] -> IO (VariableSet x)
newVariableSet contents =
do
broadcaster
<- newBroadcaster (VariableSetData (Set.fromList (fmap Keyed contents)))
return (VariableSet broadcaster)
updateSet :: HasKey x key => VariableSet x -> VariableSetUpdate x -> IO ()
updateSet (VariableSet broadcaster) setUpdate
= applyUpdate broadcaster (update setUpdate)
setVariableSet :: HasKey x key => VariableSet x -> [x] -> IO ()
setVariableSet (VariableSet broadcaster) newList =
do
let
newSet = Set.fromList (fmap Keyed newList)
updateFn (VariableSetData oldSet) =
let
toAddList
= List.filter
(\ el -> not (Set.member (Keyed el) oldSet)) newList
toDeleteList = fmap unKey (Set.toList (Set.difference oldSet newSet))
updates =
[BeginGroup] ++ (fmap AddElement toAddList)
++ (fmap DelElement toDeleteList) ++ [EndGroup]
in
(VariableSetData newSet,updates)
applyUpdate broadcaster updateFn
instance HasKey x key => HasSource (VariableSet x) [x] (VariableSetUpdate x)
where
toSource (VariableSet broadcaster) =
map1
(\ (VariableSetData set) -> fmap unKey (Set.toList set))
(toSource broadcaster)
type VariableSetSource x = Source [x] (VariableSetUpdate x)
emptyVariableSetSource :: VariableSetSource x
emptyVariableSetSource = staticSource []
mapVariableSetSourceIO' :: (x -> IO (Maybe y)) -> VariableSetSource x
-> VariableSetSource y
mapVariableSetSourceIO' mapFn=
(map1IO
(\ currentEls ->
do
newEls <- mapM mapFn currentEls
return (catMaybes newEls)
)
)
.
(filter2IO
(\ change ->
case change of
AddElement x ->
do
yOpt <- mapFn x
case yOpt of
Nothing -> return Nothing
Just y -> return (Just (AddElement y))
DelElement x ->
do
yOpt <- mapFn x
case yOpt of
Nothing -> return Nothing
Just y -> return (Just (DelElement y))
BeginGroup -> return (Just BeginGroup)
EndGroup -> return (Just EndGroup)
)
)
concatVariableSetSource :: VariableSetSource x -> VariableSetSource x
-> VariableSetSource x
concatVariableSetSource (source1 :: VariableSetSource x) source2 =
let
pair :: Source ([x],[x])
(Either (VariableSetUpdate x) (VariableSetUpdate x))
pair = choose source1 source2
res :: Source [x] (VariableSetUpdate x)
res =
(map1 (\ (x1,x2) -> x1 ++ x2))
.
(map2
(\ xlr -> case xlr of
Left x -> x
Right x -> x
)
)
$
pair
in
res
instance Functor VariableSetUpdate where
fmap fn (AddElement x) = AddElement (fn x)
fmap fn (DelElement x) = DelElement (fn x)
fmap fn BeginGroup = BeginGroup
fmap fn EndGroup = EndGroup
mapVariableSetSource :: (x -> y) -> VariableSetSource x -> VariableSetSource y
mapVariableSetSource fn source =
(map1 (fmap fn)) .
(map2 (fmap fn)) $
source
singletonSetSource :: SimpleSource x -> VariableSetSource x
singletonSetSource (source0 :: SimpleSource x) =
let
(source1 :: Source x x) = toSource source0
(source2 :: Source x (x,x)) = mkHistorySource id source1
(source3 :: Source [x] [VariableSetUpdate x]) =
(map1
(\ x -> [x])
)
.
(map2
(\ (x1,x2) -> [BeginGroup,AddElement x2,DelElement x1,EndGroup])
)
$
source2
(source4 :: VariableSetSource x) = flattenSource source3
in
source4
listToSetSource :: Ord x => SimpleSource [x] -> VariableSetSource x
listToSetSource (simpleSource :: SimpleSource [x]) =
let
source1 :: Source [x] [x]
source1 = toSource simpleSource
source2 :: Source (Set.Set x,[x]) [VariableSetUpdate x]
source2 = foldSource
(\ list -> Set.fromList list)
(\ oldSet newList ->
let
newSet = Set.fromList newList
toAdd = Set.difference newSet oldSet
adds = fmap AddElement (Set.toList toAdd)
toDelete = Set.difference oldSet newSet
deletes = fmap DelElement (Set.toList toDelete)
in
(newSet,adds ++ deletes)
)
source1
source3 :: Source [x] [VariableSetUpdate x]
source3 = map1 snd source2
source4 :: Source [x] (VariableSetUpdate x)
source4 = flattenSource source3
in
source4