module Eventloop.Module.StatefulGraphics.StatefulGraphics ( setupStatefulGraphicsModuleConfiguration , statefulGraphicsModuleIdentifier , statefulGraphicsInitializer , statefulGraphicsPostProcessor , statefulGraphicsTeardown ) where 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 Data.Maybe import Debug.Trace setupStatefulGraphicsModuleConfiguration :: EventloopSetupModuleConfiguration setupStatefulGraphicsModuleConfiguration = ( EventloopSetupModuleConfiguration statefulGraphicsModuleIdentifier (Just statefulGraphicsInitializer) Nothing Nothing (Just statefulGraphicsPostProcessor) Nothing (Just statefulGraphicsTeardown) ) statefulGraphicsModuleIdentifier :: EventloopModuleIdentifier statefulGraphicsModuleIdentifier = "statefulgraphics" statefulGraphicsInitializer :: Initializer statefulGraphicsInitializer sharedIO = return (sharedIO, StatefulGraphicsState []) statefulGraphicsTeardown :: Teardown statefulGraphicsTeardown sharedIO statefulState = return (sharedIO) statefulGraphicsPostProcessor :: PostProcessor statefulGraphicsPostProcessor shared (StatefulGraphicsState states) (OutStatefulGraphics canvasId commands) = return (shared, StatefulGraphicsState states', newScene) where (state', newScene) = calculateNewScene canvasId state commands stateM = findGraphicalState states canvasId state = case stateM of Just state_ -> state_ Nothing -> [] states' = replaceGraphicalState states canvasId state' statefulGraphicsPostProcessor shared iostate out = return (shared, iostate, [out]) 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 = trace "Calculate new scene" (state', [clearCanvas, OutBasicShapes $ DrawShapes canvasId basicShapes]) where (state', performed) = trace ("Outs: " ++ (show $ length outs)) foldl foldPerform (state, []) outs foldPerform (state_, performed_) statefulOut = (state_', performed_ ++ [performed_']) where (state_', performed_') = performStatefulGraphicsOut state_ statefulOut clearCanvas = OutCanvas $ CanvasOperations canvasId [Clear ClearCanvas] basicShapes = map snd state' performStatefulGraphicsOut :: GraphicsState -> StatefulGraphicsOut -> (GraphicsState, GraphicPerformed) performStatefulGraphicsOut state (Draw statefulGraphic) = case oldStatefulGraphicM of Just oldStatefulGraphic -> trace ("Modified: " ++ (show $ fst statefulGraphic)) (state', Modified statefulGraphic) Nothing -> trace ("Drawn: " ++ (show $ fst statefulGraphic)) (state', Drawn statefulGraphic) where (state', oldStatefulGraphicM) = addOrReplaceGraphics state statefulGraphic performStatefulGraphicsOut state (Remove id) = case oldStatefulGraphicM of Just oldStatefulGraphic -> trace ("Removed: " ++ (show id)) (state', Removed oldStatefulGraphic) Nothing -> trace ("NoOp: " ++ (show id)) (state , NoOp) where (state', oldStatefulGraphicM) = removeGraphics state id addOrReplaceGraphics :: GraphicsState -> StatefulGraphic -> (GraphicsState, (Maybe StatefulGraphic)) addOrReplaceGraphics [] new = ([new], Nothing) -- Add action addOrReplaceGraphics (old@(id, _):state) new@(id', newGraphic) | id == id' = (new:state, Just old) -- Update action | otherwise = (old:state', result) where (state', result) = addOrReplaceGraphics state new removeGraphics :: GraphicsState -> NamedId -> (GraphicsState, (Maybe StatefulGraphic)) removeGraphics [] _ = ([], Nothing) removeGraphics (sg@(id, _):state) id' | id == id' = (state, Just sg) | otherwise = (sg:state', result) where (state', result) = removeGraphics state id'