ListB - a list behavioral collection

\begin{code}
module ListB (PlacePos(..),module ListB,module CollectionB) where
import CollectionB
import BVar
import FranCore
import Identify
import Utils
import List
import MapG
import PlacePos
import Maybe
import IOExts
\end{code}

A list behavior collection is a behavioral collection using list operation
updates, and the abstract List type.

\begin{code}
type ListB a = CollectionB ListOp List a
\end{code}

The abstract list type, is a list where each element has a unique Identifier,
and a value. This implementation looks a bit odd. But is important to allow
rendering of ListB. The render implementation in Display.lhs relies on 
elements having a unique Id. This also allows us to delete elements based on 
their unique identifier. Helps with definition of fmap and mapG (see ListOp
below).

\begin{code}
newtype List a = List [(Ident,a)] 
-- toList,fromList,applyListOp,keysList,eltsList

instance Show a => Show (List a) where
 show l = show $ fromList l

toList :: [(Ident,a)] -> List a
toList xs = List xs

fromList :: List a -> [(Ident,a)]
fromList (List xs) = xs

keysList :: List a -> [Ident]
keysList = map fst . fromList

eltsList :: List a -> [a]  
eltsList = map snd . fromList

instance Functor List where
 fmap f xs = toList $ map (\(x,a) -> (x,f a)) $ fromList xs

instance Monad g => MapG List a b g where
 mapG f xs = mapG f (eltsList xs) >>= return . toList . zip (keysList xs)

\end{code}

The update operations on a list are defined with ListOp. 
We can insert, delete, move elements in a list, and reset the list with
a new set of values. Note that this means when mapping functions over a 
ListOp, we don't need to apply map to delete or move operations. This saves
some work. It also guarantees that mapG will not produce funny results.
Given an IO function f, and a value a. If we assumed the simpler data type,
data ListOp = InsertList a | DeleteList a,
and (f a) were to be applied to (InsertList a) and (DeleteList a)
at different times and produced two different unequal values, then
the delete would fail!

\begin{code}
data ListOp a = InsertList ! Ident ! a ! (PlacePos Ident)
	      | DeleteList ! Ident 
	      | MoveList ! Ident ! (PlacePos Ident)
	      | ResetList ! (List a)
 deriving Show

instance Functor ListOp where
 fmap f (InsertList x a pos) = InsertList x (f a) pos
 fmap f (DeleteList x) = DeleteList x
 fmap f (ResetList xs) = ResetList (fmap f xs)
 fmap f (MoveList x pos) = MoveList x pos

instance Monad g => MapG ListOp a b g where
 mapG f (InsertList x a pos) = do a <- f a;return $! InsertList x a pos
 mapG f (DeleteList x) = return $ DeleteList x
 mapG f (ResetList xs) = mapG f xs >>= return . ResetList
 mapG f (MoveList x pos) = return $ MoveList x pos
\end{code}

We need ListOp, List to be a member of the CollectionOp class.
Note that if the unique identifier is not unique, delete and move, 
affect every element with that identifier.

\begin{code}
instance CollectionOp ListOp List where
 applyOp = applyListOp
 resetOp = ResetList

applyListOp :: ListOp a -> List a -> List a
applyListOp (InsertList n a pos) lst = 
   toList $ insertWith (n,a) pos $ fromList lst
applyListOp (DeleteList n) lst = 
   toList $ filter (\ (n',_) -> n' /= n) $ fromList lst
applyListOp (MoveList n pos) lst = toList $
  case partition ((== n) . fst) (fromList lst) of
   ([],as) -> as
   (xs,as) -> foldl' (\as x -> insertWith x pos as) as xs
applyListOp (ResetList ls) _ = ls

insertWith :: (Ident, a) -> PlacePos Ident -> [(Ident,a)] -> [(Ident,a)]
insertWith p PlaceTop xs = p:xs
insertWith p PlaceBottom xs = xs ++ [p]
insertWith p (PlaceBefore x) xs = before x p xs
 where
  before x p [] = [p]
  before x p (a@(id, _):as) = if id == x then p:a:as else a:before x p as
insertWith p (PlaceAfter x) xs = after x p xs
 where
  after x p [] = [p]
  after x p (a@(id, _):as) = if id == x then a:p:as 
			     else a:after x p as

\end{code}

Some basic functions on listB.

To get a behavior from a list, we get the behavior from the collection,
and return only the values (not the identifiers).

\begin{code}
listBehavior :: ListB a -> Behavior [a]
listBehavior = lift1 eltsList . behaviorC
\end{code}

Making a ListB we make a new collection.

\begin{code}
newListB :: List a -> Event (ListOp a) -> IO (ListB a)
newListB s e = newCollectionB  e s
\end{code}

A constant listB is a collection with a never event and a constant
behavior. 

\begin{code}
constantListB :: [a] -> ListB a 
constantListB as = 
  CollectionB neverE 
              (lift0 $ toList $ 
		       zipWith (\x a -> (identify x,a)) [(1 :: Int)..] as)

emptyListB :: ListB a
emptyListB = constantListB []
\end{code}

filter on ListB.

filtering using a static function. We filter the list in the behavior.
When filtering the ListOp, we need to calculate new PlacePos locations,
as the elements we are moving before or after may have vanished.
We do this by snapshotting the list and then calculating the new value.

\begin{code}
filterLB :: (a-> Bool) -> ListB a -> ListB a
filterLB (p :: a -> Bool) l@(CollectionB ev b) = 
 CollectionB (mapMaybeE handle (ev `snapshotE` b)) 
	     (lift1 (toList . filter (p . snd) . fromList) b)
   where
    handle :: (ListOp a,List a) -> Maybe (ListOp a)
    handle (op@(InsertList n a pos),bs) | p a = 
	Just $! InsertList n a (realLoc p (fromList bs) pos)
    handle (op@(DeleteList n),bs) | maybe False p $ lookup n $ fromList bs = 
	Just $! op
    handle (ResetList as,_) = 
	Just $! ResetList $! toList $ filter (p . snd) $ fromList as
    handle (MoveList x pos,bs) = 
       let bs' = fromList bs in
       case lookup x bs' of
         Just v | p v -> Just $ MoveList x (realLoc p bs' pos) 
	 _ -> Nothing
    handle _ = Nothing  
\end{code}


list helper functions for filter
Calculate the new place pos for an element based on the old one,
when filtering a list.

\begin{code}
realLoc :: (a -> Bool) 
	-> [(Ident,a)]
	-> PlacePos Ident 
	-> PlacePos Ident
realLoc p xs (PlaceBefore n) = nextVal False p xs n
realLoc p xs (PlaceAfter n) = nextVal True p xs n
realLoc p _ v = v
\end{code}

Find the real next value. We drop all the items until we find the list we are
interested in. If we're placing after an element and the same element is still
in the list then place after it, otherwise we're on to a later element in this list so just place before it.

\begin{code}
nextVal :: Bool -> (a -> Bool) -> [(Ident,a)] -> Ident -> PlacePos Ident
nextVal isafter p xs i =
 findNextVis p (\i' -> isafter && i == i') $ dropWhile ((/= i) . fst) xs 
\end{code}

to find the next visible item we filter all remaining elements with a boolean
function, and then place it at the bottom if none left, or before or after the
next element depending on predicate.

\begin{code} 
findNextVis :: (a -> Bool) -> (Ident -> Bool) -> [(Ident,a)] -> PlacePos Ident
findNextVis p isafter xs = 
 case filter (p . snd) xs of
  [] -> PlaceBottom
  ((i',x):xs) -> if isafter i' then PlaceAfter i'
                 else PlaceBefore i' 
\end{code}

filter using a function to extract a behavior from list elements, 
and a boolean function valued behavior to filter with.

\begin{code}
filterListB :: (Show a,Show b) => (a -> Behavior b) -> Behavior (b -> Bool) -> ListB a 
	    -> IO (ListB a)
\end{code}

It's all a bit hairy at the moment, but the basic idea is that we build an
accumulating event, containing the current boolean filter function;
a list of elements, one for each dynamic list entry, with an
identifier, list value, current behavioral value, and whether the object is 
visible,identifiers with value of the item; and the last list update 
operations. Every time the filter function changes, a list operation occurs,
or a value changes then we update this ListInfo data. 

\begin{code}
type ListInfo a b = Triple (b -> Bool) [FListItem a b] [ListOp a]
type FListItem a b = (Ident,Triple a b Bool)
\end{code}

\begin{code}
filterListB (fb :: a -> Behavior b) predB l = do
{-
To generate the change event that updates this filter function we need to first make
a behavior list with an entry containing not only the value a, but the behavior b and
an event stream of type b, that occurs every time the behavior b changes. We want to do
this once for efficiency. 
-}

  l <- mapG (addE fb) l
  predE <- toStream predB
  case l of 
   l@(CollectionB ev1 beh1) -> do

{- now sample this list and create the initial filtered list with a value, and 
   initial FListItem values
-}
    t <- getFranTime
    xs <- fmap fromList $ beh1 `at` t
    pred <- predB `at` t
    let check :: (Ident,Triple a (Behavior b) (Event b)) 
              -> IO (Maybe (Ident,a),FListItem a b)
        check (id,Triple a b c) = do
         v <- b `at` t
	 if pred v then
	   return (Just (id,a),(id,Triple a v True))
	  else
	   return (Nothing,(id,Triple a v False))
    bs <- mapM check xs
    case unzip bs of
     (inits,gens) -> do

-- then generate the accumulating info event

      co <- changeOpsE xs ev1
      e <- (accumE (Triple pred gens []) $ 
		predE ==> flip changePredOp
		.|.
		(co ) ==> flip changePredEvs) 

-- finally make a list with initial values, and update operations from the 
-- accumulating event

      newListB (toList $ catMaybes inits) $ 
	mapEs threeVal e

addE :: (a -> Behavior b) -> a -> IO (Triple a (Behavior b) (Event b))
addE fb a = do
   let b = fb a
   e <- toStream b
   return (Triple a b e)
\end{code}



\begin{code}

data Triple a b c = Triple {oneVal :: a,twoVal :: b,threeVal :: c}
 deriving Show
\end{code}

generate the update ops, when filter function changes for list of items.

\begin{code}

changePredOp :: ListInfo a b -> (b -> Bool) -> ListInfo a b
changePredOp (Triple _ xs _) pred = 
  case changePreds pred xs of
    (xs,altered) -> (Triple pred xs altered)

changePreds :: (b -> Bool) -> [FListItem a b] -> ([FListItem a b],[ListOp a])
changePreds pred xs = 
  case unzip $ scan (change pred) xs of
   (xs,ops) -> (xs,catMaybes ops)
 where
  change pred p@(id,(Triple a b isp)) xs = 
    let ispnew = pred b in
    ((id,(Triple a b ispnew)),mkop id a xs isp ispnew)

  scan :: (a -> [a] -> b) -> [a] -> [b]
  scan f [] = []
  scan f (x:xs) = (f x xs) :scan f xs  
\end{code}

Making an update op to change items in list

\begin{code}
mkop :: Ident -- the id of value 
     -> a     -- the elt 
     -> [FListItem a b]  -- the rest of elts in list
     -> Bool  -- was it previously visible
     -> Bool  -- is it now visible
     -> Maybe (ListOp a) -- perhaps an update op depending on this
mkop id a _ True False = Just $ DeleteList id
mkop id a xs False True = 
 Just $ InsertList id a $ findNextVis threeVal (const False) xs
mkop id a _ _ _ = Nothing
\end{code}

To generate the change events we need to generate a val change event,
that lasts every time an element is added until it is deleted.
And generate a listop update when an update occurs, sampling the 
current value of the behavior b.

\begin{code}

data Change a b = ValChange Ident b | ListOp (ListOp (a,b)) 
 deriving Show
type Vals a b = Triple a (Behavior b) (Event b)

changeOpsE :: (Show a,Show b) => [(Ident,Vals a b)]
           -> Event (ListOp (Vals a b))
           -> IO (Event (Change a b)) 
changeOpsE inits ev = do
  -- every time an element is created listen to value changes on its
  -- behavior until the element is deleted
  e <- mapG mk ev
  ee <- join' e

  -- listen to all value changes on initial elements
  is <- fmap anyE $ mapM doOne inits

  -- every time a listop occurs make a change op, by sampling the value of
  -- its behavior
  return $ ((mapMaybeE mkC ev ) `snapshotFE` (bListToListB . snd) ==> app) 
	   
           .|.
           ee
           .|.
           is
 where

 app :: (([b] -> Change a b,[Behavior b]),[b]) -> Change a b
 app ((f,_),v) = f v

 mk :: ListOp (Vals a b) -> IO (Event (Change a b))
 mk (InsertList n a _) = doOne (n,a)
 mk (ResetList as) = mapM doOne (fromList as) >>= return . anyE 
 mk _ = return neverE

 join' :: Event (Event alpha) -> IO (Event alpha)
 join' ee = neverE `manyE` ee

 doOne :: (Ident,Vals a b) -> IO (Event (Change a b))
 doOne p@(ident, (Triple a bh e)) = do
 	oe <- onceE ((isDelete ident `filterE` ev ) -=> neverE)
        (e  ==> ValChange ident) 
		`switcherE` 
		 oe

 isDelete :: Ident -> ListOp (Vals a b) -> Bool
 isDelete ident (DeleteList n) = n == ident
 isDelete _ (ResetList _) = True
 isDelete _ _ = False

 mkC :: ListOp (Vals a b) -> Maybe ([b] -> Change a b,[Behavior b])
 mkC (InsertList n (Triple a bh _) pos) = 
	Just (\[b] -> ListOp $ InsertList n (a,b) pos,[bh])
 mkC (ResetList as) = 
	let as' = fromList as in
	Just (\bs -> ListOp $ ResetList $ 
				toList $ 
				zipWith (\(i,Triple a _ _) b -> (i,(a,b))) as' bs,
	      map (twoVal . snd) as')
 mkC (DeleteList n) = 
	Just (const $ ListOp $ DeleteList n,[])
 mkC mv@(MoveList n n') = Just (const $ ListOp $ MoveList n n',[])
\end{code}

we update the list info using the change event, creating an insert op when
an element is visible, a reset op filtering for visible elements, and a delete
op when an element has been visible. when a value changes send an insert or
delete op as relevant.

\begin{code}

changePredEvs :: ListInfo a b -> Change a b -> ListInfo a b
changePredEvs (Triple pred xs _) 
	      (ListOp (InsertList id (a,b) pos)) = 
  let isp = pred b 
      val = (id,Triple a b isp)
      newpos = realLoc threeVal xs pos
  in 
  (Triple pred (insertWith val newpos xs) 
          (if isp then [InsertList id a newpos] else [])
  )

changePredEvs (Triple pred _ _) (ListOp (ResetList ps)) =
  case unzip $ fmap change $ fromList ps of
    (xs,ys) -> (Triple pred ys [ResetList $ toList $ catMaybes xs])
 where
   change (id,(a,b)) = 
		       if pred b then (Just (id,a),(id,(Triple a b True)))
		       else (Nothing,(id,(Triple a b False)))

changePredEvs (Triple p xs _) (ListOp (DeleteList id)) = 
  case partition ((== id) . fst) xs of
   (vs,rest) ->
     (Triple p rest
             (if any (threeVal . snd) vs then [DeleteList id] else []))


changePredEvs (Triple p xs _) (ListOp (MoveList n pos)) = 
  case partition ((== n) . fst) xs of
   ([],as) -> (Triple p as [])
   (xs,as) -> (Triple p (foldl' (\as x -> insertWith x pos as) as xs)
		(if (any (threeVal . snd) xs) then 
		  [MoveList n (realLoc threeVal as pos)]
		 else []))	      

changePredEvs (Triple pred xs _) (ValChange id b) = 
  case changeWithPred id b (pred b) xs of
     (xs,ops) -> (Triple pred xs ops)


changeWithPred :: Ident -> b -> Bool 
               -> [FListItem a b] 
	       -> ([FListItem a b],[ListOp a])
changeWithPred id b vis xs = changeNGet xs []
 where
   changeNGet [] vs = (reverse vs,[])
   changeNGet ((oldid, (Triple a _ oldvis)):xs) vs | oldid == id  = 
      (reverse vs ++ (id,Triple a b vis):xs,
       maybeToList $ mkop id a xs oldvis vis)
   changeNGet (x:xs) vs = changeNGet xs (x:vs)

\end{code}

to do a behavioral sort we use a similar tactic to behavioral filter
This time we accumulate the ordering function;a list of identifier, value
and current behavior value; and list update ops.

\begin{code}
type SListInfo a b = Triple (b -> b -> Ordering) 
			       [SListItem a b]
			       [ListOp a]
type SListItem a b = (Ident,(a,b))
\end{code}

\begin{code}
sortListB :: (Show a,Show b) => (a -> Behavior b) ->  Behavior (b -> b -> Ordering) 
          -> ListB a 
	  -> IO (ListB a)
sortListB (fb :: a -> Behavior b) compB l = do
  l <- mapG (addE fb) l
  compE <- toStream compB
  case l of 
   l@(CollectionB ev1 beh1) -> do

{- now sample this list and create the initial filtered list with a value, and 
   initial FListItem values
-}
    t <- getFranTime
    xs <- fmap fromList $ beh1 `at` t
    comp <- compB `at` t
    let check :: (Ident,Triple a (Behavior b) (Event b)) 
              -> IO (SListItem a b)
        check (id,Triple a b c) = do
         v <- b `at` t
	 return (id,(a,v))
    cs <- mapM check xs
    case resetWithOrd comp cs of
     (inits,gens) -> do
       co <- changeOpsE xs ev1
       e <- accumE (Triple comp gens []) $
               ( co  ==> flip changeEvs)
               .|.
               (  compE ==> flip changeOp)
       newListB (toList inits) $ mapEs threeVal e 
    
\end{code}

to change with a change op
for a reset list - reset but after sorting with the current comparison fn
for an delete - remove the element and pass on a delete op
for an insert - insert into the list and create a new insert op, with a 
	        sorted position for it to go to
for a value change - move the element to its new sorted position, and
	             if this changes its position, pass on a move op
for a move op - ignore it, as elements should always be sorted, so manually
		moving has no effect
\begin{code}
changeEvs :: SListInfo a b -> Change a b
          -> SListInfo a b
changeEvs (Triple comp xs _) (ListOp (ResetList bs)) =
  case resetWithOrd comp (fromList bs) of
   (new,info) -> (Triple comp info [ResetList (toList new)])
changeEvs (Triple comp xs _) (ListOp (DeleteList id)) = 
  (Triple comp (filter ((/= id) . fst) xs) [DeleteList id])
changeEvs (Triple comp xs _) (ListOp (InsertList n (a,b) pos)) =
 case insertWithOrd comp n a b xs of
  (ys,pos) -> (Triple comp ys [InsertList n a pos])
changeEvs (Triple comp xs _) (ValChange id b) = 
 case moveWithOrd comp id b xs of
   (ys,Just pos) -> (Triple comp ys [MoveList id pos])
   (ys,_) -> (Triple comp ys [])
changeEvs (Triple comp xs _) _ = Triple comp xs []
\end{code}

helper functions to insert, move, reset and delete with an ordering function.
all return the position of the item in the sorted list
\begin{code}

insertWithOrd :: (b -> b -> Ordering) -> Ident -> a -> b -> [SListItem a b] 
	      -> ([SListItem a b],PlacePos Ident)
insertWithOrd comp id a b xs = insert xs [] 
 where
  insert [] vs = (reverse $ (id,(a,b)) : vs,PlaceBottom)
  insert l@(x@(id1,(_,b1)):xs) vs = 
    case comp b b1 of
      LT -> (reverse vs ++ (id,(a,b)):l,PlaceBefore id1)
      EQ -> (reverse vs ++ (id,(a,b)):l,PlaceBefore id1)
      GT -> insert xs (x:vs)

moveWithOrd :: (b -> b -> Ordering) -> Ident -> b -> [SListItem a b] 
	    -> ([SListItem a b], Maybe (PlacePos Ident))
moveWithOrd comp id b xs =
 case deleteNFind id xs of
  (as,Nothing) -> (as,Nothing)
  (as,Just ((a,_),pos)) -> 
    case insertWithOrd comp id a b as of
	(xs,p') -> (xs,if pos == p' then Nothing else Just p')

resetWithOrd :: (b -> b -> Ordering) 
	     -> [SListItem a b]
	     -> ([(Ident,a)],[SListItem a b])
resetWithOrd comp vs =
    unzip $ map split $ performSort comp vs
 where
      split val@(id,(a,b)) = ((id,a),val)

performSort :: (b -> b -> Ordering) -> [SListItem a b] -> [SListItem a b]
performSort comp vs = sortBy sorter vs
 where 
      sorter (_,(_,a)) (_,(_,b)) = comp a b


deleteNFind :: Ident -> [(Ident,a)] -> ([(Ident,a)],Maybe (a,PlacePos Ident))
deleteNFind id xs = delete xs []
  where
    delete [] _ = (xs,Nothing)
    delete (x@(id1, a):y@(nid, _):xs) vs |  id1 == id = (reverse vs ++ y:xs,Just (a,PlaceBefore nid))
    delete (x@(id1, a):[]) vs |  id1 == id = (reverse vs,Just (a,PlaceBottom))
    delete (x:ys) vs = delete ys (x:vs)

\end{code}

when we change the sorting op, resort the list and send a move event for every
element if the list has been changed

\begin{code}
changeOp :: SListInfo a b -> (b -> b -> Ordering) -> SListInfo a b
changeOp (Triple _ xs _) comp = 
  case performSort comp xs of
   xs' -> Triple comp xs' 
	    (if map fst xs == map fst xs' then [] 
	     else map (\(id,_) -> MoveList id PlaceTop) $ reverse xs')
\end{code}

This is not yet defined, do we need it?

\begin{code}
instance Monad g => MapG PlacePos a b g where
 mapG f PlaceTop = return PlaceTop
 mapG f PlaceBottom = return PlaceBottom
 mapG f (PlaceBefore x) = f x >>= return . PlaceBefore
 mapG f (PlaceAfter x) = f x >>= return . PlaceAfter

\end{code}
