module FRP.Grapefruit.Signal.Incremental.Set (
Diff (Diff),
insertion,
deletion,
elementInsertion,
elementDeletion,
empty,
singleton,
toSeqs,
toAscSeqs,
union,
difference,
intersection,
null,
size,
member,
staticMember,
notMember,
staticNotMember,
) where
import Prelude hiding (null, filter, map)
import Control.Applicative as Applicative ((<$>), (<*>))
import Data.Semigroup as Semigroup
import Data.Monoid as Monoid
import qualified Data.List as List
import Data.Set as Set (Set)
import qualified Data.Set as Set
import Data.Sequence as Seq (Seq)
import qualified Data.Sequence as Seq
import Data.Map as Map (Map)
import qualified Data.Map as Map
import FRP.Grapefruit.Signal.Segmented as SSignal
import FRP.Grapefruit.Signal.Incremental as ISignal hiding (combine, map)
import qualified FRP.Grapefruit.Signal.Incremental as ISignal
import qualified FRP.Grapefruit.Signal.Incremental.Sequence as SeqISignal hiding (Diff)
instance (Ord el) => Incremental (Set el) where
data Diff (Set el) = Diff (Map el Bool)
patch set diff = (set `Set.difference` revDiffMap False) `Set.union` revDiffMap True where
revDiffMap = reverseDiffMap diff
type ValidationState (Set el) = ()
validationInit _ = ()
validationStep _ _ = Just ()
instance (Ord el) => Semigroup (Diff (Set el)) where
(<>) = mappend
instance (Ord el) => Monoid (Diff (Set el)) where
mempty = Diff Map.empty
Diff diffMap1 `mappend` Diff diffMap2 = Diff (diffMap2 `Map.union` diffMap1)
insertion :: (Ord el) => Set el -> Diff (Set el)
insertion = containednessChange True
deletion :: (Ord el) => Set el -> Diff (Set el)
deletion = containednessChange False
containednessChange :: (Ord el) => Bool -> Set el -> Diff (Set el)
containednessChange containedness set = Diff $
Map.fromList [(el,containedness) | el <- Set.toList set]
elementInsertion :: el -> Diff (Set el)
elementInsertion el = Diff $ Map.singleton el True
elementDeletion :: el -> Diff (Set el)
elementDeletion el = Diff $ Map.singleton el False
reverseDiffMap :: (Ord el) => Diff (Set el) -> (Bool -> Set el)
reverseDiffMap (Diff diffMap) = \containedness -> if containedness then insertionSet
else deletionSet where
(insertionMap,deletionMap) = Map.partition id diffMap
insertionSet = Map.keysSet insertionMap
deletionSet = Map.keysSet deletionMap
empty :: (Ord el) => ISignal era (Set el)
empty = ISignal.const Set.empty
singleton :: (Ord el) => SSignal era el -> ISignal era (Set el)
singleton = ISignal.map start step . ISignal.monolithicFromSSignal where
start (Monolithic init) = (Set.singleton init,init)
step (Replacement el') el = (Diff (Map.fromList [(el,False),(el',True)]),el')
toSeqs :: (Ord el) => ISignal era (Set el) -> ISignal era (Seq el)
toSeqs = toAscSeqs
toAscSeqs :: (Ord el) => ISignal era (Set el) -> ISignal era (Seq el)
toAscSeqs = ISignal.map start step where
start init = ((Seq.fromList . Set.toAscList) init,init)
step = toAscSeqsStep
toAscSeqsStep :: (Ord el) => Diff (Set el) -> Set el -> (Diff (Seq el),Set el)
toAscSeqsStep (Diff diffMap) set = (mconcat seqDiffs,last sets) where
(seqDiffs,nextSets) = unzip $ zipWith atomicStep (Map.toList diffMap) sets
sets = set : nextSets
atomicStep (el,False) set = case Set.splitMember el set of
(_,False,_) -> (mempty,set)
(ltSet,True,_) -> (,) (SeqISignal.elementDeletion $
Set.size ltSet)
(Set.delete el set)
atomicStep (el,True) set = case Set.splitMember el set of
(ltSet,False,_) -> (,) (SeqISignal.elementInsertion
(Set.size ltSet)
el)
(Set.insert el set)
(_,True,_) -> (mempty,set)
union :: (Ord el) => ISignal era (Set el) -> ISignal era (Set el) -> ISignal era (Set el)
union = combine True True True Set.union
difference :: (Ord el) => ISignal era (Set el) -> ISignal era (Set el) -> ISignal era (Set el)
difference = combine False True False Set.difference
intersection :: (Ord el) => ISignal era (Set el) -> ISignal era (Set el) -> ISignal era (Set el)
intersection = combine False False False Set.intersection
combine :: (Ord el)
=> Bool
-> Bool
-> Bool
-> (Set el -> Set el -> Set el)
-> (ISignal era (Set el) -> ISignal era (Set el) -> ISignal era (Set el))
combine mod1 mod2 mod' setComb = ISignal.combine start step1 step2 where
start init1 init2 = (setComb init1 init2,(init1,init2))
step1 diff1 (set1,set2) = (,) (combinationDiff mod1 mod2 mod' diff1 set1 set2)
(patch set1 diff1,set2)
step2 diff2 (set1,set2) = (,) (combinationDiff mod2 mod1 mod' diff2 set2 set1)
(set1,patch set2 diff2)
combinationDiff :: (Ord el)
=> Bool -> Bool -> Bool -> Diff (Set el) -> Set el -> Set el -> Diff (Set el)
combinationDiff diffMod otherMod mod' diff diffSet otherSet = Diff diffMap' where
diffMap' = Map.unions [consMap containedness (revDiffMap' containedness) |
containedness <- [False,True]]
revDiffMap' = flip reduce otherSet . reverseDiffMap diff . (/= diffMod) . (/= mod')
reduce = if otherMod then Set.difference else Set.intersection
consMap val = Map.fromAscList . List.map (flip (,) val) . Set.toAscList
null :: (Ord el) => ISignal era (Set el) -> SSignal era Bool
null = fmap (== 0) . size
size :: (Ord el) => ISignal era (Set el) -> SSignal era Int
size = fmap Set.size . ISignal.toSSignal
member :: (Ord el) => SSignal era el -> ISignal era (Set el) -> SSignal era Bool
member els sets = Set.member <$> els <*> ISignal.toSSignal sets
staticMember :: (Ord el) => el -> ISignal era (Set el) -> SSignal era Bool
staticMember el = monolithicToSSignal . ISignal.map start step where
start init = let
contained = Set.member el init
in (Monolithic contained,contained)
step (Diff diffMap) contained = let
contained' = case Map.lookup el diffMap of
Nothing -> contained
Just containedness -> containedness
in (Replacement contained',contained')
notMember :: (Ord el) => SSignal era el -> ISignal era (Set el) -> SSignal era Bool
notMember = (fmap not .) . member
staticNotMember :: (Ord el) => el -> ISignal era (Set el) -> SSignal era Bool
staticNotMember = (fmap not .) . staticMember