module Util.VariableList(
newVariableListFromSet,
newVariableListFromList,
emptyVariableList,
singletonList,
VariableList,
ListDrawer(..),
attachListOp,
coMapListDrawer,
map2ListDrawer,
catVariableLists,
) where
import Data.Maybe
import Data.IORef
import Util.Computation
import Util.Registry
import Util.Sources
import Util.Sink
import Util.VariableSet
import Util.Delayer
import Util.Myers
data ListDrawer a pos = ListDrawer {
newPos :: Maybe pos -> Maybe a -> IO pos,
setPos :: pos -> Maybe a -> IO (),
delPos :: pos -> IO (),
redraw :: IO ()
}
data VariableList a = VariableList {
attachListOp :: forall pos . ParallelExec -> ListDrawer a pos -> IO (IO ())
}
instance Functor VariableList where
fmap fn (VariableList {attachListOp = attachListOp0}) =
let
attachListOp1 parallelEx listDrawer =
attachListOp0 parallelEx (coMapListDrawer fn listDrawer)
in
VariableList attachListOp1
coMapListDrawer :: (a -> b) -> ListDrawer b pos -> ListDrawer a pos
coMapListDrawer fn (ListDrawer {
newPos = newPos0,setPos = setPos0,delPos = delPos0,redraw = redraw0}) =
let
newPos1 posOpt aOpt = newPos0 posOpt (fmap fn aOpt)
setPos1 pos aOpt = setPos0 pos (fmap fn aOpt)
delPos1 = delPos0
redraw1 = redraw0
in
ListDrawer {
newPos = newPos1,setPos = setPos1,delPos = delPos1,redraw = redraw1}
map2ListDrawer :: (pos1 -> pos2) -> (pos2 -> pos1) ->
ListDrawer b pos1 -> ListDrawer b pos2
map2ListDrawer toPos2 toPos1 (ListDrawer {
newPos = newPos1,setPos = setPos1,delPos = delPos1,redraw = redraw1}) =
let
newPos2 pos2Opt aOpt =
do
pos1 <- newPos1 (fmap toPos1 pos2Opt) aOpt
return (toPos2 pos1)
setPos2 pos2 aOpt = setPos1 (toPos1 pos2) aOpt
delPos2 pos2 = delPos1 (toPos1 pos2)
redraw2 = redraw1
in
ListDrawer {
newPos = newPos2,setPos = setPos2,delPos = delPos2,redraw = redraw2}
instance HasAddDelayer (VariableList a) where
addDelayer delayer (VariableList attachListOp0) =
let
attachListOp1 parallelX listDrawer0 =
do
listDrawer1 <- addDelayerIO delayer listDrawer0
attachListOp0 parallelX listDrawer1
in
VariableList attachListOp1
instance HasAddDelayerIO (ListDrawer a pos) where
addDelayerIO delayer listDrawer0 =
do
delayedAction <- newDelayedAction (redraw listDrawer0)
let
redraw1 = delayedAct delayer delayedAction
listDrawer1 = listDrawer0 {redraw = redraw1}
return listDrawer1
emptyVariableList :: VariableList a
emptyVariableList =
let
attachListOp _ _ = return done
in
VariableList attachListOp
singletonList :: forall a . a -> VariableList a
singletonList a =
let
attachListOp :: forall pos . ParallelExec -> ListDrawer a pos
-> IO (IO ())
attachListOp parallelX listDrawer =
do
parallelExec parallelX (
do
newPos listDrawer Nothing (Just a)
done
)
return done
in
VariableList attachListOp
newVariableListFromSet :: forall a . Ord a => VariableSetSource a
-> VariableList a
newVariableListFromSet (variableSetSource :: VariableSetSource a) =
let
attachListOp :: forall pos . ParallelExec -> ListDrawer a pos
-> IO (IO ())
attachListOp parallelX listDrawer =
do
(posRegistry :: Registry a pos) <- newRegistry
groupingCount <- newIORef 0
let
updateFn :: VariableSetUpdate a -> IO ()
updateFn (AddElement a) =
do
addElement a
groupCount <- readIORef groupingCount
when (groupCount == 0) (redraw listDrawer)
updateFn (DelElement a) =
do
delElement a
groupCount <- readIORef groupingCount
when (groupCount == 0) (redraw listDrawer)
updateFn BeginGroup = modifyIORef groupingCount (+1)
updateFn EndGroup =
do
groupCount0 <- readIORef groupingCount
let
groupCount1 = groupCount0 1
writeIORef groupingCount groupCount1
when (groupCount1 == 0) (redraw listDrawer)
initialElements :: [a] -> IO ()
initialElements as =
do
mapM_ addElement as
redraw listDrawer
addElement :: a -> IO ()
addElement a =
do
pos <- newPos listDrawer Nothing (Just a)
setValue posRegistry a pos
delElement :: a -> IO ()
delElement a =
transformValue posRegistry a (\ posOpt -> case posOpt of
Just pos ->
do
delPos listDrawer pos
return (Nothing,())
)
sinkID <- newSinkID
(x,sink) <- addNewSinkWithInitial variableSetSource
initialElements updateFn sinkID parallelX
return (invalidate sinkID)
in
VariableList attachListOp
newVariableListFromList :: forall a . Ord a => SimpleSource [a]
-> VariableList a
newVariableListFromList (simpleSource :: SimpleSource [a]) =
let
attachListOp :: forall pos . ParallelExec -> ListDrawer a pos
-> IO (IO ())
attachListOp parallelX listDrawer =
do
(state :: IORef ([a],[pos])) <- newIORef ([],[])
let
updateList :: [a] -> IO ()
updateList newAs =
do
(oldAs,oldPos) <- readIORef state
let
changes = diff2 oldAs newAs
oldAsPlus :: [(a,Bool)]
oldAsPlus = concat (map
(\ diffElement -> case diffElement of
InSecond _ -> []
InFirst l -> map (\ a -> (a,False)) l
InBoth l -> map (\ a -> (a,True)) l
)
changes
)
newAsPlus :: [(a,Bool)]
newAsPlus = concat (map
(\ diffElement -> case diffElement of
InFirst _ -> []
InSecond l -> map (\ a -> (a,False)) l
InBoth l -> map (\ a -> (a,True)) l
)
changes
)
deleteAct = sequence_ (zipWith
(\ (oldA,isCommon) oldPos ->
if isCommon then done else
delPos listDrawer oldPos
)
oldAsPlus oldPos
)
commonPos = catMaybes
(zipWith
(\ (oldA,isCommon) oldPos ->
if isCommon
then
Just oldPos
else
Nothing
)
oldAsPlus oldPos
)
mkPairs :: Maybe pos -> [pos] -> [(a,Bool)]
-> [(Maybe pos,[a])] -> [(Maybe pos,[a])]
mkPairs lastPosOpt [] [] acc0 = acc0
mkPairs lastPosOpt poss0
(xs0@((a,isCommon):rest)) acc0 =
if isCommon
then
case poss0 of
pos:poss1 ->
mkPairs (Just pos) poss1 rest acc0
else
let
getInsertion :: [(a,Bool)]
-> ([a],[(a,Bool)])
getInsertion [] = ([],[])
getInsertion (xs@((_,True):_)) = ([],xs)
getInsertion (((a,False):xs0)) =
let
(as,xs1) = getInsertion xs0
in
(a:as,xs1)
(as,xs1) = getInsertion xs0
acc1 = (lastPosOpt,as) : acc0
in
case (poss0,xs1) of
([],[]) -> acc1
(pos:pos1,((_,True):xs2)) ->
mkPairs (Just pos) pos1 xs2 acc1
pairs :: [(Maybe pos,[a])]
pairs = mkPairs Nothing commonPos newAsPlus []
addAct :: IO [[pos]]
addAct = mapM
(\ (posOpt,as) ->
mapM
(\ a -> newPos listDrawer posOpt (Just a))
(reverse as)
)
pairs
(newPosss0 :: [[pos]]) <- addAct
deleteAct
redraw listDrawer
let
mkNewPos :: [(a,Bool)] -> [pos] -> [pos] -> [pos]
-> [pos]
mkNewPos [] [] [] posAcc = posAcc
mkNewPos ((_,isCommon):xs0) posOld posNew posAcc =
if isCommon
then
case posOld of
pos:posOld1 ->
mkNewPos xs0 posOld1 posNew (pos:posAcc)
else
case posNew of
pos:posNew1 ->
mkNewPos xs0 posOld posNew1 (pos:posAcc)
newPos = mkNewPos newAsPlus commonPos
(reverse (concat newPosss0)) []
writeIORef state (newAs,reverse newPos)
sinkID <- newSinkID
addNewSinkWithInitial simpleSource updateList updateList sinkID
parallelX
return (invalidate sinkID)
in
VariableList attachListOp
catVariableLists :: VariableList a -> VariableList a -> VariableList a
catVariableLists (VariableList attachListOp1) (VariableList attachListOp2) =
let
attachListOp parallelX listDrawer =
do
middlePos <- newPos listDrawer Nothing Nothing
let
listDrawer1 = listDrawer
newPos2 posOpt aOpt =
let
pos = fromMaybe middlePos posOpt
in
newPos listDrawer (Just pos) aOpt
listDrawer2 = listDrawer {newPos = newPos2}
destroy1 <- attachListOp1 parallelX listDrawer1
destroy2 <- attachListOp2 parallelX listDrawer2
return (destroy1 >> destroy2)
in
VariableList attachListOp