module Eventloop.Module.StatefulGraphics.StatefulGraphics ( setupStatefulGraphicsModuleConfiguration , statefulGraphicsModuleIdentifier , statefulGraphicsInitializer , statefulGraphicsPostProcessor ) where import Control.Concurrent.STM import Data.Maybe import Eventloop.Module.StatefulGraphics.Types import Eventloop.Module.Websocket.Canvas import Eventloop.Module.BasicShapes import Eventloop.Types.Common import Eventloop.Types.Events import Eventloop.Types.System import Eventloop.Utility.Vectors setupStatefulGraphicsModuleConfiguration :: EventloopSetupModuleConfiguration setupStatefulGraphicsModuleConfiguration = ( EventloopSetupModuleConfiguration statefulGraphicsModuleIdentifier (Just statefulGraphicsInitializer) Nothing Nothing (Just statefulGraphicsPostProcessor) Nothing Nothing ) statefulGraphicsModuleIdentifier :: EventloopModuleIdentifier statefulGraphicsModuleIdentifier = "statefulgraphics" statefulGraphicsInitializer :: Initializer statefulGraphicsInitializer sharedConst sharedIO = return (sharedConst, sharedIO, NoConstants, StatefulGraphicsState []) statefulGraphicsPostProcessor :: PostProcessor statefulGraphicsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutStatefulGraphics canvasId commands) = atomically $ do (StatefulGraphicsState states) <- readTVar ioStateT let stateM = findGraphicalState states canvasId state = case stateM of Just state_ -> state_ Nothing -> [] (state', newScene) = calculateNewScene canvasId state commands states' = replaceGraphicalState states canvasId state' writeTVar ioStateT (StatefulGraphicsState states') return newScene statefulGraphicsPostProcessor sharedConst sharedIOT ioConst ioStateT out = return [out] getId :: StatefulBB -> NamedId getId (StatefulBB (Stateful id _ _) _) = id getZ :: StatefulBB -> ZIndex getZ (StatefulBB (Stateful _ z _) _) = z getShape :: StatefulBB -> Shape getShape (StatefulBB (Stateful _ _ shape) _) = shape replaceGraphicalState :: GraphicsStates -> CanvasId -> GraphicsState -> GraphicsStates replaceGraphicalState [] id state = [(id, state)] replaceGraphicalState ((id, state):states) canvasId newState | id == canvasId = (canvasId, newState):states | otherwise = (id, state):(replaceGraphicalState states canvasId newState) findGraphicalState :: GraphicsStates -> CanvasId -> Maybe GraphicsState findGraphicalState [] _ = Nothing findGraphicalState ((id, state):states) canvasId | id == canvasId = Just state | otherwise = findGraphicalState states canvasId calculateNewScene :: CanvasId -> GraphicsState -> [StatefulGraphicsOut] -> (GraphicsState, [Out]) calculateNewScene canvasId state outs = (state', [ OutCanvas $ CanvasOperations canvasId (map Clear removes) , OutBasicShapes $ DrawShapes canvasId basicShapes ] ) where (state', performed) = foldl foldPerform (state, []) outs foldPerform (state_, performed_) statefulOut = (state_', performed_ ++ [performed_']) where (state_', performed_') = performStatefulGraphicsOut state_ statefulOut (toRedraw, toRemove) = calculateRedraws state' performed basicShapes = map getShape toRedraw removes = map calculateRemove toRemove {- Uses yMin as canvas treats rectangle from their lower left corner -} calculateRemove :: StatefulBB -> ClearPart calculateRemove (StatefulBB _ bb) = ClearRectangle (round $ xMin bb, round $ yMin bb) (round width, round height) where height = (yMax bb) - (yMin bb) width = (xMax bb) - (xMin bb) calculateRedraws :: GraphicsState -> [GraphicPerformed] -> (GraphicsState, GraphicsState) -- Redraw and Remove state calculateRedraws _ [] = ([], []) calculateRedraws state ((Drawn sbb):performed) = (toRedraw', toRemove) where id = getId sbb (toRedraw, toRemove) = calculateRedraws state performed (_, toRedraw') = calculateRedrawsForDrawn (state, toRedraw) sbb calculateRedraws state ((Removed sg):performed) = (toRedraw', toRemove') where (toRedraw, toRemove) = calculateRedraws state performed (_, toRedraw', toRemove') = calculateRedrawsForRemoved (state, toRedraw, toRemove) sg calculateRedraws state ((Modified sg):performed) -- | noDimChange oldGraphic newGraphic = calculateDraws toCheck toRedraw (Drawn sg) TODO Modified -> Drawn optimalization = calculateRedraws state ((Removed sg):(Drawn sg):performed) calculateRedraws state (NoOp:performed) = calculateRedraws state performed {- Only redraw when a graphic if the drawn graphic overlaps or if a graphic is above and contained by the drawn graphic. Also add the drawn graphic to redraw. However, if there is one graphic to be found that completely contains the drawn graphic, nothing has to happen. Also, all graphics completely behind the drawn graphic, will not be redrawn. -} calculateRedrawsForDrawn :: (GraphicsState, GraphicsState) -- Current check and redraw state -> StatefulBB -> (GraphicsState, GraphicsState) calculateRedrawsForDrawn (toCheck, toRedraw) new = foldl calculateRedrawsForDrawn (toCheck', toRedraw') checkNow where id = getId new z = getZ new (below, _, above) = splitOn (\sbb -> getId sbb == id) toCheck -- Find which graphics are above and below toProcess aboveOverlapped = filter (overlaps new) above aboveContained = filter (contains new) above aboveContainedBy = filter (\sg -> contains sg new) above aboveNotTouching = filter (not.(touches new)) above toCheck' = fst $ removeGraphic toCheck id toRedraw' = fst $ addOrReplaceGraphic toRedraw new checkNow = aboveOverlapped ++ aboveContained ++ aboveContainedBy calculateRedrawsForRemoved :: (GraphicsState, GraphicsState, GraphicsState) -- Current check and redraw state -> StatefulBB -> (GraphicsState, GraphicsState, GraphicsState) calculateRedrawsForRemoved (toCheck, toRedraw, toRemove) old = (toCheck', toRedraw', toRemove') where id = getId old z = getZ old (below, above) = split (\sbb -> getZ sbb > z) toCheck -- Find which graphics are above and below toProcess belowOverlapped = filter (overlaps old) below belowContained = filter (contains old) below belowContainedBy = filter (\sg -> contains sg old) below aboveOverlapped = filter (overlaps old) above aboveContained = filter (contains old) above aboveContainedBy = filter (\sg -> contains sg old) above toRemove' = old:toRemove checkNow = belowOverlapped ++ belowContained ++ belowContainedBy ++ aboveOverlapped ++ aboveContained ++ aboveContainedBy (toCheck', toRedraw') = foldl calculateRedrawsForDrawn (toCheck, toRedraw) checkNow statefulIds :: GraphicsState -> [NamedId] statefulIds = map getId statefulId :: StatefulGraphic -> NamedId statefulId (Stateful id _ _) = id split :: (a -> Bool) -> [a] -> ([a], [a]) split _ [] = ([], []) split on (x:xs) | on x = ([], x:xs) | otherwise = (x:xs', xs'') where (xs', xs'') = split on xs splitOn :: (a -> Bool) -> [a] -> ([a], Maybe a, [a]) splitOn _ [] = ([], Nothing, []) splitOn on (x:xs) | on x = ([], Just x, xs) | otherwise = (x:xs', x', xs'') where (xs', x', xs'') = splitOn on xs performStatefulGraphicsOut :: GraphicsState -> StatefulGraphicsOut -> (GraphicsState, GraphicPerformed) performStatefulGraphicsOut state (Draw statefulGraphic) = case oldStatefulGraphicM of Just oldStatefulGraphic -> (state', Modified statefulBB) Nothing -> (state', Drawn statefulBB) where statefulBB = (StatefulBB statefulGraphic bb) (state', oldStatefulGraphicM) = addOrReplaceGraphic state statefulBB bb = toBoundingBox statefulGraphic performStatefulGraphicsOut state (Remove id) = case oldStatefulGraphicM of Just oldStatefulGraphic -> (state', Removed oldStatefulGraphic) Nothing -> (state , NoOp) where (state', oldStatefulGraphicM) = removeGraphic state id addGraphic :: GraphicsState -> StatefulBB -> GraphicsState addGraphic [] new = [new] addGraphic (graphic:state) new | z > z' = new:graphic:state | otherwise = graphic:(addGraphic state new) where z = getZ graphic z' = getZ new addOrReplaceGraphic :: GraphicsState -> StatefulBB -> (GraphicsState, (Maybe StatefulBB)) addOrReplaceGraphic [] new = ([new], Nothing) -- Add action addOrReplaceGraphic (graphic:state) new | id == id' && z == z' = (new:state, Just graphic) -- Simple update | id == id' && z /= z' = let -- Update action (must be z <= z') state' = addGraphic state new -- Insert new higher up in (state', Just graphic) -- new is higher, forget current=old | id /= id' && z > z' = let -- Add or update action (state', old) = removeGraphic state id' -- Search higher state for possible stale in (new:graphic:state', old) | otherwise = let -- Search further (state', result) = addOrReplaceGraphic state new in (graphic:state', result) where id = getId graphic z = getZ graphic id' = getId new z' = getZ new removeGraphic :: GraphicsState -> NamedId -> (GraphicsState, (Maybe StatefulBB)) removeGraphic [] _ = ([], Nothing) removeGraphic (sg:state) id' | id == id' = (state, Just sg) | otherwise = (sg:state', result) where (state', result) = removeGraphic state id' id = getId sg