\begin{code}
module SetB (module SetB,module CollectionB) where
import CollectionB 
import MapG
import FranCore
import FM
import Identify
import List
import BVar

newtype Set a = Set (FiniteMap Ident a)
{-
  eltsSet,applySetOp,
  fromSet,toSet,keysSet,eltsSet,listToSet,setToList
-}
listToSet :: [(Ident,a)] -> Set a
listToSet = toSet . listToFM

setToList :: Set a -> [(Ident,a)]
setToList = fmToList . fromSet

keysSet :: Set a -> [Ident]
keysSet = keysFM . fromSet

eltsSet :: Set a -> [a]
eltsSet = eltsFM . fromSet

fromSet :: Set a -> FiniteMap Ident a
fromSet (Set a) = a

toSet :: FiniteMap Ident a -> Set a
toSet a = Set a

type SetB a = CollectionB SetOp Set a 

setBehavior :: SetB a -> Behavior [a]
setBehavior = lift1 eltsSet . behaviorC 

newSetB :: Set a -> Event (SetOp a) -> IO (SetB a)
newSetB s e = newCollectionB e s

emptySetB :: SetB a
emptySetB = CollectionB neverE (lift0 $ toSet emptyFM)

data SetOp a = InsertSet ! Ident ! a | DeleteSet ! Ident | ResetSet ! (Set a)

applySetOp :: SetOp a -> Set a -> Set a
applySetOp (InsertSet x a) s = toSet $ addToFM (fromSet s) x a
applySetOp (DeleteSet x) s = toSet $ delFromFM (fromSet s) x
applySetOp (ResetSet xs) _ = xs

instance Functor SetOp where
 fmap f (InsertSet x a) = InsertSet x (f a)
 fmap f (DeleteSet x) = DeleteSet x
 fmap f (ResetSet xs) = ResetSet (fmap f xs)

instance Functor Set where
 fmap f xs = toSet $ mapFM (\_ -> f) $ fromSet xs

instance Monad g => MapG Set a b g where
 mapG f xs = mapG f (eltsSet xs) >>= return . listToSet . zip (keysSet xs)

instance Monad g => MapG SetOp a b g where
 mapG f (InsertSet x a) = do a <- f a;return $ InsertSet x a
 mapG f (DeleteSet x) = return $ DeleteSet x
 mapG f (ResetSet xs) = mapG f xs >>= return . ResetSet 

instance CollectionOp SetOp Set where 
 applyOp = applySetOp
 resetOp = ResetSet

unionSetB :: Eq a => SetB a -> SetB a -> SetB a
unionSetB (c1 :: SetB a) c2 = mergeCB c1 c2 mergeE unionSets
  where
    unionSets :: Set a -> Set a -> Set a
    unionSets s1 s2 = 
       let l1 = setToList s1
	   l2 = map (\(k,e) -> (identify $ show k,e)) $ setToList s2

	   compare :: (Ident,a) -> (Ident,a) -> Bool
	   compare (i1,a1) (i2,a2) = a1 == a2
       in
	listToSet $ unionBy compare l1 l2 


    mergeE :: Event (SetOp a)
    mergeE = 
     mapMaybeE   (unOp True) 
	 (eventC c1 `snapshotE` pairB (behaviorC c1) (behaviorC c2)) 
	   
     .|. 
     mapMaybeE  (unOp False)
	(eventC c2 `snapshotE` pairB (behaviorC c2) (behaviorC c1)) 
	    

    unOp :: Bool -> (SetOp a,(Set a,Set a)) -> Maybe (SetOp a)
    unOp over (op@(InsertSet x a),(as,bs)) =
       if x `elemFM` fromSet as then 
         Nothing
       else
	 if not over && a `elem` (eltsSet bs) then 
            Nothing
         else 
	   Just $ if over then op
		  else InsertSet (identify $ show x) a

    unOp over (op@(DeleteSet x),(as,bs)) =
       if x `elemFM` fromSet as then
         if over then Just op
         else Just $ DeleteSet (identify $ show x)
       else
         Nothing

    unOp over (ResetSet rs,(_,bs)) = 
        Just $ ResetSet $ if over then unionSets rs bs else unionSets bs rs

intersectSetB :: Eq a => SetB a -> SetB a -> SetB a
intersectSetB c1 c2 = newSet 
  where
    newSet = mergeCB c1 c2 (mergeE c1 c2 newSet) intersectSets

    intersectSets :: Eq a => Set a -> Set a -> Set a
    intersectSets s1 s2 = 
       let l1 = setToList s1
	   l2 = map (\(k,e) -> (identify $ show k,e)) $ setToList s2

	   compare :: Eq a => (Ident,a) -> (Ident,a) -> Bool
	   compare (i1,a1) (i2,a2) = a1 == a2
       in
	listToSet $ intersectBy compare l1 l2 


    mergeE :: Eq a => SetB a -> SetB a -> SetB a -> Event (SetOp a)
    mergeE c1 c2 newSet = 
     mapMaybeE  (unOp True) (eventC c1 `snapshotE` 
		pairB (behaviorC newSet) (pairB (behaviorC c1) (behaviorC c2))) 
	    
     .|. 
     mapMaybeE  (unOp False) (eventC c2 `snapshotE` 
		pairB (behaviorC newSet) (pairB (behaviorC c2) (behaviorC c1))) 
	    

    unOp :: Eq a => Bool -> (SetOp a,(Set a,(Set a,Set a))) -> Maybe (SetOp a)
    unOp over (op@(InsertSet x a),(_,(as,bs))) =
       if x `elemFM` fromSet as then 
         Nothing
       else
	 if a `elem` eltsSet bs then
	   Just $ if over then op 
		  else InsertSet (identify $ show x) a
	 else 
	   Nothing


    unOp over (op@(DeleteSet x),(new,_)) = 
       let key = if over then x else (identify $ show x)
       in
       if key `elemFM` fromSet new then
         if over then Just op
         else Just $ DeleteSet key
       else
         Nothing

    unOp over (ResetSet rs,(_,(_,bs))) = 
        Just $ ResetSet $ if over then intersectSets rs bs 
			  else intersectSets bs rs

minusSetB :: Eq a => SetB a -> SetB a -> SetB a
minusSetB (c1 :: SetB a) c2 =  mergeCB c1 c2 mergeE minusSets
 where
    minusSets :: Set a -> Set a -> Set a
    minusSets s1 s2 = 
       let l1 = setToList s1
	   l2 = setToList s2

	   compare :: (Ident,a) -> (Ident,a) -> Bool
	   compare (i1,a1) (i2,a2) = a1 == a2
       in
	listToSet $ deleteFirstsBy compare l1 l2 


    mergeE :: Event (SetOp a)
    mergeE = 
     mapMaybeE (unOp True) 
	 (eventC c1 `snapshotE` (pairB (behaviorC c1) (behaviorC c2))) 
	     
     .|. 
     mapMaybeE (unOp False)
	(eventC c2 `snapshotE` (pairB (behaviorC c2) (behaviorC c1))) 
	     

    unOp :: Bool -> (SetOp a,(Set a,Set a)) -> Maybe (SetOp a)
    unOp this (op@(InsertSet x a),(as,bs)) =
      if not this then 
	case find (\(_,a') -> a == a') $ setToList bs of
            Nothing ->	Nothing
	    Just (k,_) -> Just $ DeleteSet k
      else
        if not (x `elemFM` fromSet as) && (a `elem` eltsSet bs) then
          Just op
        else
          Nothing

    unOp this (op@(DeleteSet x),(as,bs)) = 
        case lookupFM (fromSet as) x of
         Nothing -> Nothing
         Just a ->
          case find (\(_,a') -> a == a') $ setToList bs of
            Nothing | this -> Just op
            Just (k,a) | not this -> Just $ InsertSet k a 
	    _ -> Nothing

    unOp this (ResetSet rs,(_,bs)) = 
        Just $ ResetSet $ if this then minusSets rs bs 
			  else minusSets bs rs
\end{code}