\begin{code}

module CollectionBVar where
import SetB
import ListB
import BVar
import FM
import IOExts
import FranCore
import CollectionB
import Identify
import List
import MapG

data CollectionBVar b c a = CollectionBVar {
	listenerOp :: Listener (CBVarOp a (b a)),
	collection :: CollectionB b c a 
	}

behaviorCV :: CollectionBVar b c a -> Behavior (c a)
behaviorCV = behaviorC . collection 

type CBVarOp a b =  (a -> IO (Maybe Ident))  
	         -> (a -> IO Ident) 
	         -> (a -> IO (Maybe Ident)) 
		 -> ([a] -> IO [(Ident,a)])
	         -> IO (Maybe b)

newCollectionBVar :: (CollectionOp b c,Eq a) =>
		    [a] -> ([(Ident,a)] -> c a)
		 -> IO (CollectionBVar b c a)
newCollectionBVar = newCollectionBVar' (==)

newCollectionBVar' :: (CollectionOp b c) =>
		    (a -> a -> Bool) -> 
		    [a] -> ([(Ident,a)] -> c a)
		 -> IO (CollectionBVar b c a)
newCollectionBVar' eq as newfm = do
 (Wire l e) <- newWire
 ref <- newIORef (0,[])
 let reset vs = do
        let ls = zipWith (\x a -> (a,identify x)) [(1 :: Int) ..] vs
        writeIORef ref (length ls + 1,ls)
        return $ map (\(a,b) -> (b,a)) ls
 let add v = do (x,fm) <- readIORef ref
		let id = identify x
	        writeIORef ref (x + 1,  (v,id):fm)
	        return id
 let delete v = do (x,fm) <- readIORef ref
		   case partition ((eq v) . fst) fm of
		     ((_,k):xs,ks) -> do writeIORef ref (x,ks ++ xs) 
				         return $ Just k
		     _ -> return Nothing
 let findItem v = do xs <- readIORef ref
		     return $ fmap snd $ find (eq v . fst) $ snd xs
 let e' = isJustE $ e `withIOE` (\f -> f findItem add delete reset) 
 as' <- reset as
 c <- newCollectionB e' $ newfm as'
 return $ CollectionBVar l c

newCollectionBVarI :: (CollectionOp b c) =>
		     (a -> Ident) ->
		     c a -> IO (CollectionBVar b c a)
newCollectionBVarI identify as = do
 (Wire l e) <- newWire
 let e' = isJustE $ e `withIOE` 
		(\f -> f (return . Just . identify) 
			 (return . identify) 
			 (return . Just . identify)
			 (return . map (\a -> (identify a,a))))
 c <- newCollectionB e' as
 return $ CollectionBVar l c

type SetBVar a = CollectionBVar SetOp Set a

newSetBVar' :: (a -> Ident) -> [a] -> IO (SetBVar a)
newSetBVar' identify as = newCollectionBVarI identify $ listToSet $ map (\a -> (identify a,a)) as

newSetBVar :: (Eq a) => [a] -> IO (SetBVar a)
newSetBVar as = newCollectionBVar as listToSet

insertSetB :: Eq a => SetBVar a -> Listener a
insertSetB (s :: SetBVar a) = comapL op $ listenerOp s
 where
   op :: a -> CBVarOp a (SetOp a)
   op v = \lookup add delete reset -> 
		do x <- add v;return $! Just $! InsertSet x v

deleteSetB :: Eq a => SetBVar a -> Listener a
deleteSetB s = comapL op $ listenerOp s
 where
   op v = \_ _ delete _ -> do
	     fmap (fmap DeleteSet) $ delete v  

resetSetB :: Eq a => SetBVar a -> Listener [a]
resetSetB s = comapL op $ listenerOp s
 where
   op v = \lookup add delete reset -> do
		reset v >>= return . Just . ResetSet . listToSet


setVBehavior :: SetBVar a -> Behavior [a]
setVBehavior s = setBehavior $ collection s

listVBehavior :: ListBVar a -> Behavior [a]
listVBehavior s = listBehavior $ collection s

type ListBVar a = CollectionBVar ListOp List a

newListBVar' :: (a -> Ident) -> [a] -> IO (ListBVar a)
newListBVar' identify as = newCollectionBVarI identify $ toList $ map (\a -> (identify a,a)) as

newListBVar :: (Eq a) => [a] -> IO (ListBVar a)
newListBVar as = newCollectionBVar as toList

insertListB :: ListBVar a -> Listener (a,PlacePos a)
insertListB l = comapL op $ listenerOp l
 where
  op (v,p) = \lookup insert _ _ -> do
		pos <- maybePlace lookup p
		k <- insert v
	        return $ Just $ InsertList k v pos

  maybePlace look PlaceTop = return PlaceTop
  maybePlace look PlaceBottom = return PlaceBottom
  maybePlace look (PlaceBefore x) =
        fmap (maybe PlaceBottom PlaceBefore) $ look x
  maybePlace look (PlaceAfter x) = 
        fmap (maybe PlaceBottom PlaceAfter) $ look x

deleteListB :: ListBVar a -> Listener a
deleteListB l = comapL op $ listenerOp l
 where
  op v = \ _ _ delete _ -> fmap (fmap DeleteList) $ delete v

resetListB :: ListBVar a -> Listener [a]
resetListB l = comapL op $ listenerOp l
 where
  op v = \_ _ _ reset -> reset v >>= return . Just . ResetList . toList

moveListB :: ListBVar a -> Listener (a,PlacePos a)
moveListB l = comapL op $ listenerOp l
 where
  op (v,pos) = \ find _ _ _ -> do
		 x <- find v
		 case x of
		  Nothing -> return Nothing
		  Just v -> do 
		   p <- case pos of
		         PlaceBefore p -> fmap (maybe PlaceTop PlaceBefore) 
					  $ find p
 		         PlaceAfter p -> fmap (maybe PlaceBottom PlaceAfter) 
					  $ find p
			 PlaceTop -> return PlaceTop
			 PlaceBottom -> return PlaceBottom
		   return $ Just $ MoveList v p	


appendListB :: ListBVar a -> Listener a
appendListB l = comapL (\v -> (v,PlaceBottom)) $ insertListB l

consListB :: ListBVar a -> Listener a
consListB l = comapL (\v -> (v,PlaceTop)) $ insertListB l
\end{code}