diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,30 @@ -Copyright (c) 2015, Sebastiaan la Fleur - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Sebastiaan la Fleur nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c) 2015, Sebastiaan la Fleur + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Sebastiaan la Fleur nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/eventloop.cabal b/eventloop.cabal --- a/eventloop.cabal +++ b/eventloop.cabal @@ -1,120 +1,120 @@ -name: eventloop - --- The package version. See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented. --- http://www.haskell.org/haskellwiki/Package_versioning_policy --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 0.8.2.7 -synopsis: A different take on an IO system. Based on Amanda's IO loop, this eventloop takes a function that maps input events to output events. It can easily be extended by modules that represent IO devices or join multiple modules together. -description: A different take on an IO system. Based on Amanda's IO loop, this eventloop takes a function that maps input events to output events. It can easily be extended by modules that represent IO devices or join multiple modules together. - Each module exists of a initialize and teardown function that are both called once at startup and shutting down. During run-time, a module can provice a preprocessor function (which transforms input events before they get to the eventloop), - and a postprocessor function (which transforms output events after they are received from the eventloop but before they are send off). Next to these bookkeeping functions, a module can exist of a (check for events and an event retrieve) function pair - which result in input events and an addition to the event sender function which handles output events. This results in the following states: - - |Start|: initialize -> |Run-Time| -> teardown - |Run-Time|: eventCheckers - Yes > preprocessors -> eventloop -> postprocessors -> event sender -> |Run-Time| - |- No > |Run-Time| - - Each module has a piece of "memory"/state which is defined by the module itself and all of the module states are combined in the IO state. When writing/installing a module, modifications has to be made at certain points in the code - due to the poor modularity of Haskell. -homepage: - -license: BSD3 -license-file: LICENSE -author: Sebastiaan la Fleur -maintainer: sebastiaan@slafleur.nl -copyright: University of Twente 2015 | Sebastiaan la Fleur 2015 -category: Eventloop -build-type: Simple --- extra-source-files: -cabal-version: >=1.10 - -library - exposed-modules: Eventloop.Core, - Eventloop.DefaultConfiguration, - - Eventloop.Module.Websocket.Canvas, - Eventloop.Module.Websocket.Keyboard, - Eventloop.Module.Websocket.Mouse, - Eventloop.Module.DrawTrees, - Eventloop.Module.BasicShapes, - Eventloop.Module.File, - Eventloop.Module.StatefulGraphics, - Eventloop.Module.StdIn, - Eventloop.Module.StdOut, - Eventloop.Module.Timer, - Eventloop.Module.Graphs, - - Eventloop.Types.Common, - Eventloop.Types.Events, - Eventloop.Types.System, - - Eventloop.Utility.Vectors, - Eventloop.Utility.Trees.GeneralTree - - -- Modules included in this library but not exported. - other-modules: Eventloop.OutRouter, - Eventloop.Module.Websocket.Canvas.Canvas, - Eventloop.Module.Websocket.Canvas.JSONEncoding, - Eventloop.Module.Websocket.Canvas.Opcode, - Eventloop.Module.Websocket.Canvas.Types, - Eventloop.Module.Websocket.Keyboard.Keyboard, - Eventloop.Module.Websocket.Keyboard.Types, - Eventloop.Module.Websocket.Mouse.Mouse, - Eventloop.Module.Websocket.Mouse.Types, - Eventloop.Module.DrawTrees.DrawTrees, - Eventloop.Module.DrawTrees.Types, - Eventloop.Module.DrawTrees.RoseTreeGeneric, - Eventloop.Module.BasicShapes.BasicShapes, - Eventloop.Module.BasicShapes.Types, - Eventloop.Module.BasicShapes.Classes, - Eventloop.Module.BasicShapes.MeasureTextHack, - Eventloop.Module.File.File, - Eventloop.Module.File.Types, - Eventloop.Module.StatefulGraphics.StatefulGraphics, - Eventloop.Module.StatefulGraphics.Types, - Eventloop.Module.StdIn.StdIn, - Eventloop.Module.StdIn.Types, - Eventloop.Module.StdOut.StdOut, - Eventloop.Module.StdOut.Types, - Eventloop.Module.Timer.Timer, - Eventloop.Module.Timer.Types, - Eventloop.Module.Graphs.Graphs, - Eventloop.Module.Graphs.Types, - - Eventloop.System.DisplayExceptionThread, - Eventloop.System.EventloopThread, - Eventloop.System.InitializationThread, - Eventloop.System.OutRouterThread, - Eventloop.System.Processing, - Eventloop.System.RetrieverThread, - Eventloop.System.SenderThread, - Eventloop.System.Setup, - Eventloop.System.TeardownThread, - - Eventloop.Types.Exception, - - Eventloop.Utility.Websockets, - Eventloop.Utility.Config, - Eventloop.Utility.Trees.LayoutTree - - other-extensions: OverloadedStrings - - build-depends: base >=4.8 && <4.12, - network >=2.6 && <2.7, - text >=1.2 && <1.3, - websockets >=0.9 && <0.10, - timers >=0.2 && <0.3, - suspend >=0.2 && <0.3, - aeson >=0.8 && <0.12, - bytestring >=0.10 && <0.11, - concurrent-utilities >=0.2 && <0.3, - stm >=2.4 && <2.5, - deepseq >=1.4 && <1.5 - - -- Directories containing source files. - hs-source-dirs: src - - -- Base language which the package is written in. - default-language: Haskell2010 +name: eventloop + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.8.2.8 +synopsis: A different take on an IO system. Based on Amanda's IO loop, this eventloop takes a function that maps input events to output events. It can easily be extended by modules that represent IO devices or join multiple modules together. +description: A different take on an IO system. Based on Amanda's IO loop, this eventloop takes a function that maps input events to output events. It can easily be extended by modules that represent IO devices or join multiple modules together. + Each module exists of a initialize and teardown function that are both called once at startup and shutting down. During run-time, a module can provice a preprocessor function (which transforms input events before they get to the eventloop), + and a postprocessor function (which transforms output events after they are received from the eventloop but before they are send off). Next to these bookkeeping functions, a module can exist of a (check for events and an event retrieve) function pair + which result in input events and an addition to the event sender function which handles output events. This results in the following states: + + |Start|: initialize -> |Run-Time| -> teardown + |Run-Time|: eventCheckers - Yes > preprocessors -> eventloop -> postprocessors -> event sender -> |Run-Time| + |- No > |Run-Time| + + Each module has a piece of "memory"/state which is defined by the module itself and all of the module states are combined in the IO state. When writing/installing a module, modifications has to be made at certain points in the code + due to the poor modularity of Haskell. +homepage: - +license: BSD3 +license-file: LICENSE +author: Sebastiaan la Fleur +maintainer: sebastiaan@slafleur.nl +copyright: University of Twente 2015 | Sebastiaan la Fleur 2015 +category: Eventloop +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Eventloop.Core, + Eventloop.DefaultConfiguration, + + Eventloop.Module.Websocket.Canvas, + Eventloop.Module.Websocket.Keyboard, + Eventloop.Module.Websocket.Mouse, + Eventloop.Module.DrawTrees, + Eventloop.Module.BasicShapes, + Eventloop.Module.File, + Eventloop.Module.StatefulGraphics, + Eventloop.Module.StdIn, + Eventloop.Module.StdOut, + Eventloop.Module.Timer, + Eventloop.Module.Graphs, + + Eventloop.Types.Common, + Eventloop.Types.Events, + Eventloop.Types.System, + + Eventloop.Utility.Vectors, + Eventloop.Utility.Trees.GeneralTree + + -- Modules included in this library but not exported. + other-modules: Eventloop.OutRouter, + Eventloop.Module.Websocket.Canvas.Canvas, + Eventloop.Module.Websocket.Canvas.JSONEncoding, + Eventloop.Module.Websocket.Canvas.Opcode, + Eventloop.Module.Websocket.Canvas.Types, + Eventloop.Module.Websocket.Keyboard.Keyboard, + Eventloop.Module.Websocket.Keyboard.Types, + Eventloop.Module.Websocket.Mouse.Mouse, + Eventloop.Module.Websocket.Mouse.Types, + Eventloop.Module.DrawTrees.DrawTrees, + Eventloop.Module.DrawTrees.Types, + Eventloop.Module.DrawTrees.RoseTreeGeneric, + Eventloop.Module.BasicShapes.BasicShapes, + Eventloop.Module.BasicShapes.Types, + Eventloop.Module.BasicShapes.Classes, + Eventloop.Module.BasicShapes.MeasureTextHack, + Eventloop.Module.File.File, + Eventloop.Module.File.Types, + Eventloop.Module.StatefulGraphics.StatefulGraphics, + Eventloop.Module.StatefulGraphics.Types, + Eventloop.Module.StdIn.StdIn, + Eventloop.Module.StdIn.Types, + Eventloop.Module.StdOut.StdOut, + Eventloop.Module.StdOut.Types, + Eventloop.Module.Timer.Timer, + Eventloop.Module.Timer.Types, + Eventloop.Module.Graphs.Graphs, + Eventloop.Module.Graphs.Types, + + Eventloop.System.DisplayExceptionThread, + Eventloop.System.EventloopThread, + Eventloop.System.InitializationThread, + Eventloop.System.OutRouterThread, + Eventloop.System.Processing, + Eventloop.System.RetrieverThread, + Eventloop.System.SenderThread, + Eventloop.System.Setup, + Eventloop.System.TeardownThread, + + Eventloop.Types.Exception, + + Eventloop.Utility.Websockets, + Eventloop.Utility.Config, + Eventloop.Utility.Trees.LayoutTree + + other-extensions: OverloadedStrings + + build-depends: base >=4.8 && <4.13, + network >=2.6 && <2.9, + text >=1.2 && <1.3, + websockets >=0.9 && <0.13, + aeson >=0.8 && <1.5, + timers >=0.2 && <0.3, + suspend >=0.2 && <0.3, + bytestring >=0.10 && <0.11, + concurrent-utilities >=0.2 && <0.3, + stm >=2.4 && <2.6, + deepseq >=1.4 && <1.5 + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell2010 diff --git a/src/Eventloop/Core.hs b/src/Eventloop/Core.hs --- a/src/Eventloop/Core.hs +++ b/src/Eventloop/Core.hs @@ -1,234 +1,234 @@ -module Eventloop.Core where - -import Control.Exception -import Control.Concurrent -import Control.Concurrent.MVar -import Control.Concurrent.ExceptionCollection -import Control.Concurrent.Suspend.Lifted -import Control.Concurrent.Thread -import Control.Concurrent.Timer -import Control.Concurrent.Datastructures.BlockingConcurrentQueue - -import Eventloop.System.DisplayExceptionThread -import Eventloop.System.EventloopThread -import Eventloop.System.InitializationThread -import Eventloop.System.OutRouterThread -import Eventloop.System.RetrieverThread -import Eventloop.System.SenderThread -import Eventloop.System.Setup -import Eventloop.System.TeardownThread -import Eventloop.Types.Events -import Eventloop.Types.Exception -import Eventloop.Types.System - - - -{- | Starts the entire system. First the setup phase is handled to setup the different -concurrent resources. This is followed by the initialization phase where all modules are initialised. -Than, the different worker threads are spawned and finally the system thread will go to work as the eventloop thread. - -Shutting down is handled centrally through the system thread (main thread). -If any of the threads(including the system thread) receive an exception, only the first exception is thrown to the system -thread which will try to shutdown immediately. This exception is logged by the system thread. -All other exceptions are logged by their respective threads. The system thread will than shutdown the worker -threads. This is done by throwing exceptions to all workerthreads except sender threads. These are sent a Stop event. -If they take longer than 1 second, to finish up, they will also be thrown an exception. --} -startEventloopSystem :: EventloopSetupConfiguration progstateT - -> IO () -startEventloopSystem setupConfig - = do - systemConfig <- setupEventloopSystemConfig setupConfig -- Setup - systemConfig' <- catch (startInitializing systemConfig) -- Initialization - (\shutdownException -> do - logException (exceptions systemConfig) shutdownException -- Log the thrown exception - return systemConfig - ) - failed <- hasExceptions (exceptions systemConfig') - case failed of - True -> return () - False -> do - let - moduleConfigs_ = moduleConfigs systemConfig' - exceptions_ = exceptions systemConfig' - isStoppingM_ = isStoppingM systemConfig' - catch ( do - let - retrieverThreadActions = threadActionsBasedOnModule systemConfig' startRetrieving retrieverM moduleConfigs_ - outRouterAction = startOutRouting systemConfig' - senderThreadActions = threadActionsBasedOnModule systemConfig' startSending senderConfigM moduleConfigs_ - -- Spawn worker threads - mapM_ (spawnWorkerThread systemConfig' registerRetrieverThread) retrieverThreadActions - spawnWorkerThread systemConfig' registerOutRouterThread outRouterAction - mapM_ (spawnWorkerThread systemConfig' registerSenderThread) senderThreadActions - startEventlooping systemConfig' -- Eventlooping - ) - ( \shutdownException -> do - swapMVar isStoppingM_ True -- If its already true, nothing happens, otherwise notify other threads the system thread is already shutting down - logException exceptions_ shutdownException -- Log the thrown exception - - -- Send a stop to the OutRouter - outRouter <- outRouterThread systemConfig' - let - eventloopConfig_ = eventloopConfig systemConfig' - outEventQueue_ = outEventQueue eventloopConfig_ - putInBlockingConcurrentQueue outEventQueue_ Stop - - -- Wait for the Stop to propagate - threadDelay 1000000 - - -- Kill the outrouter and senders if need be - senders <- senderThreads systemConfig' - senderTimers <- mapM (terminateWithinOrThrowException 2000000 (toException ShuttingDownException)) (outRouter ++ senders) - - -- Wait for the outRouter and Sender - joinThreads (outRouter ++ senders) - - -- Stop all outrouter and sender kill timers if they are still active - mapM_ stopTimer senderTimers - - -- Stop the retriever threads - retrievers <- retrieverThreads systemConfig' - mapM_ throwShutdownExceptionToThread retrievers - - -- Wait for all retrievers - joinThreads retrievers - ) - -- Clean up the system - startTeardowning systemConfig' - startDisplayingExceptions systemConfig' - -terminateWithinOrThrowException :: Int - -> SomeException - -> Thread - -> IO TimerIO -terminateWithinOrThrowException delay e t - = oneShotTimer ( do - term <- isTerminated t - case term of - True -> return () - False -> throwTo (getThreadId t) e - ) - ((usDelay.fromIntegral) delay) - -{- | -Utility function in order to create the different thread actions in the system. -Assumed is that the action requires the system configuration, the module configuration and some resource -that may be available in the module configuration. --} -threadActionsBasedOnModule :: EventloopSystemConfiguration progstateT - -> (EventloopSystemConfiguration progstateT -> (EventloopModuleConfiguration, resource) -> IO ()) - -> (EventloopModuleConfiguration -> Maybe resource) - -> [EventloopModuleConfiguration] - -> [IO ()] -threadActionsBasedOnModule _ _ _ [] = [] -threadActionsBasedOnModule systemconfig action getResourceFunc (moduleConfig:mcs) - = case (getResourceFunc moduleConfig) of - Nothing -> otherThreadActions - (Just resource) -> (action systemconfig (moduleConfig, resource)):otherThreadActions - where - otherThreadActions = threadActionsBasedOnModule systemconfig action getResourceFunc mcs - - -spawnWorkerThread :: EventloopSystemConfiguration progstateT - -> (EventloopSystemConfiguration progstateT -> Thread -> IO ()) - -> IO () - -> IO () -spawnWorkerThread systemconfig logAction action - = do - thread <- forkThread $ do - catch action - ( \exception -> - case (fromException exception) of - (Just ShuttingDownException) -> - return () - _ -> do - isStopping <- takeMVar isStoppingM_ - putMVar isStoppingM_ True - case isStopping of - True -> do - case (fromException exception) of - (Just RequestShutdownException) -> return () - _ -> logException exceptions_ exception - False -> throwTo systemTid exception - ) - logAction systemconfig thread - - where - exceptions_ = exceptions systemconfig - systemTid = systemThreadId systemconfig - isStoppingM_ = isStoppingM systemconfig - - -registerRetrieverThread :: EventloopSystemConfiguration progstateT - -> Thread - -> IO () -registerRetrieverThread systemconfig thread - = do - retrieverThreads <- takeMVar retrieverThreadsM_ - putMVar retrieverThreadsM_ (retrieverThreads ++ [thread]) - where - retrieverThreadsM_ = retrieverThreadsM systemconfig - - -registerOutRouterThread :: EventloopSystemConfiguration progstateT - -> Thread - -> IO () -registerOutRouterThread systemconfig thread - = putMVar (outRouterThreadM systemconfig) thread - - -registerSenderThread :: EventloopSystemConfiguration progstateT - -> Thread - -> IO () -registerSenderThread systemconfig thread - = do - senderThreads <- takeMVar senderThreadsM_ - putMVar senderThreadsM_ (senderThreads ++ [thread]) - where - senderThreadsM_ = senderThreadsM systemconfig - - -throwShutdownExceptionToThread :: Thread -> IO () -throwShutdownExceptionToThread thread - = throwTo (getThreadId thread) ShuttingDownException - - -allWorkerThreads :: EventloopSystemConfiguration progstateT - -> IO [Thread] -allWorkerThreads systemconfig - = do - retrievers <- retrieverThreads systemconfig - outRouter <- outRouterThread systemconfig - senders <- senderThreads systemconfig - return (retrievers ++ outRouter ++ senders) - - -retrieverThreads :: EventloopSystemConfiguration progstateT - -> IO [Thread] -retrieverThreads systemconfig - = readMVar retrieverThreadsM_ - where - retrieverThreadsM_ = retrieverThreadsM systemconfig - - -outRouterThread :: EventloopSystemConfiguration progstateT - -> IO [Thread] -outRouterThread systemconfig - = do - hasNotOutRouterThread <- isEmptyMVar outRouterThreadM_ - case hasNotOutRouterThread of - True -> return [] - False -> do - outRouterThread <- readMVar outRouterThreadM_ - return [outRouterThread] - where - outRouterThreadM_ = outRouterThreadM systemconfig - - -senderThreads :: EventloopSystemConfiguration progstateT - -> IO [Thread] -senderThreads systemconfig - = readMVar senderThreadsM_ - where - senderThreadsM_ = senderThreadsM systemconfig +module Eventloop.Core where + +import Control.Exception +import Control.Concurrent +import Control.Concurrent.MVar +import Control.Concurrent.ExceptionCollection +import Control.Concurrent.Suspend.Lifted +import Control.Concurrent.Thread +import Control.Concurrent.Timer +import Control.Concurrent.Datastructures.BlockingConcurrentQueue + +import Eventloop.System.DisplayExceptionThread +import Eventloop.System.EventloopThread +import Eventloop.System.InitializationThread +import Eventloop.System.OutRouterThread +import Eventloop.System.RetrieverThread +import Eventloop.System.SenderThread +import Eventloop.System.Setup +import Eventloop.System.TeardownThread +import Eventloop.Types.Events +import Eventloop.Types.Exception +import Eventloop.Types.System + + + +{- | Starts the entire system. First the setup phase is handled to setup the different +concurrent resources. This is followed by the initialization phase where all modules are initialised. +Than, the different worker threads are spawned and finally the system thread will go to work as the eventloop thread. + +Shutting down is handled centrally through the system thread (main thread). +If any of the threads(including the system thread) receive an exception, only the first exception is thrown to the system +thread which will try to shutdown immediately. This exception is logged by the system thread. +All other exceptions are logged by their respective threads. The system thread will than shutdown the worker +threads. This is done by throwing exceptions to all workerthreads except sender threads. These are sent a Stop event. +If they take longer than 1 second, to finish up, they will also be thrown an exception. +-} +startEventloopSystem :: EventloopSetupConfiguration progstateT + -> IO () +startEventloopSystem setupConfig + = do + systemConfig <- setupEventloopSystemConfig setupConfig -- Setup + systemConfig' <- catch (startInitializing systemConfig) -- Initialization + (\shutdownException -> do + logException (exceptions systemConfig) shutdownException -- Log the thrown exception + return systemConfig + ) + failed <- hasExceptions (exceptions systemConfig') + case failed of + True -> return () + False -> do + let + moduleConfigs_ = moduleConfigs systemConfig' + exceptions_ = exceptions systemConfig' + isStoppingM_ = isStoppingM systemConfig' + catch ( do + let + retrieverThreadActions = threadActionsBasedOnModule systemConfig' startRetrieving retrieverM moduleConfigs_ + outRouterAction = startOutRouting systemConfig' + senderThreadActions = threadActionsBasedOnModule systemConfig' startSending senderConfigM moduleConfigs_ + -- Spawn worker threads + mapM_ (spawnWorkerThread systemConfig' registerRetrieverThread) retrieverThreadActions + spawnWorkerThread systemConfig' registerOutRouterThread outRouterAction + mapM_ (spawnWorkerThread systemConfig' registerSenderThread) senderThreadActions + startEventlooping systemConfig' -- Eventlooping + ) + ( \shutdownException -> do + swapMVar isStoppingM_ True -- If its already true, nothing happens, otherwise notify other threads the system thread is already shutting down + logException exceptions_ shutdownException -- Log the thrown exception + + -- Send a stop to the OutRouter + outRouter <- outRouterThread systemConfig' + let + eventloopConfig_ = eventloopConfig systemConfig' + outEventQueue_ = outEventQueue eventloopConfig_ + putInBlockingConcurrentQueue outEventQueue_ Stop + + -- Wait for the Stop to propagate + threadDelay 1000000 + + -- Kill the outrouter and senders if need be + senders <- senderThreads systemConfig' + senderTimers <- mapM (terminateWithinOrThrowException 2000000 (toException ShuttingDownException)) (outRouter ++ senders) + + -- Wait for the outRouter and Sender + joinThreads (outRouter ++ senders) + + -- Stop all outrouter and sender kill timers if they are still active + mapM_ stopTimer senderTimers + + -- Stop the retriever threads + retrievers <- retrieverThreads systemConfig' + mapM_ throwShutdownExceptionToThread retrievers + + -- Wait for all retrievers + joinThreads retrievers + ) + -- Clean up the system + startTeardowning systemConfig' + startDisplayingExceptions systemConfig' + +terminateWithinOrThrowException :: Int + -> SomeException + -> Thread + -> IO TimerIO +terminateWithinOrThrowException delay e t + = oneShotTimer ( do + term <- isTerminated t + case term of + True -> return () + False -> throwTo (getThreadId t) e + ) + ((usDelay.fromIntegral) delay) + +{- | +Utility function in order to create the different thread actions in the system. +Assumed is that the action requires the system configuration, the module configuration and some resource +that may be available in the module configuration. +-} +threadActionsBasedOnModule :: EventloopSystemConfiguration progstateT + -> (EventloopSystemConfiguration progstateT -> (EventloopModuleConfiguration, resource) -> IO ()) + -> (EventloopModuleConfiguration -> Maybe resource) + -> [EventloopModuleConfiguration] + -> [IO ()] +threadActionsBasedOnModule _ _ _ [] = [] +threadActionsBasedOnModule systemconfig action getResourceFunc (moduleConfig:mcs) + = case (getResourceFunc moduleConfig) of + Nothing -> otherThreadActions + (Just resource) -> (action systemconfig (moduleConfig, resource)):otherThreadActions + where + otherThreadActions = threadActionsBasedOnModule systemconfig action getResourceFunc mcs + + +spawnWorkerThread :: EventloopSystemConfiguration progstateT + -> (EventloopSystemConfiguration progstateT -> Thread -> IO ()) + -> IO () + -> IO () +spawnWorkerThread systemconfig logAction action + = do + thread <- forkThread $ do + catch action + ( \exception -> + case (fromException exception) of + (Just ShuttingDownException) -> + return () + _ -> do + isStopping <- takeMVar isStoppingM_ + putMVar isStoppingM_ True + case isStopping of + True -> do + case (fromException exception) of + (Just RequestShutdownException) -> return () + _ -> logException exceptions_ exception + False -> throwTo systemTid exception + ) + logAction systemconfig thread + + where + exceptions_ = exceptions systemconfig + systemTid = systemThreadId systemconfig + isStoppingM_ = isStoppingM systemconfig + + +registerRetrieverThread :: EventloopSystemConfiguration progstateT + -> Thread + -> IO () +registerRetrieverThread systemconfig thread + = do + retrieverThreads <- takeMVar retrieverThreadsM_ + putMVar retrieverThreadsM_ (retrieverThreads ++ [thread]) + where + retrieverThreadsM_ = retrieverThreadsM systemconfig + + +registerOutRouterThread :: EventloopSystemConfiguration progstateT + -> Thread + -> IO () +registerOutRouterThread systemconfig thread + = putMVar (outRouterThreadM systemconfig) thread + + +registerSenderThread :: EventloopSystemConfiguration progstateT + -> Thread + -> IO () +registerSenderThread systemconfig thread + = do + senderThreads <- takeMVar senderThreadsM_ + putMVar senderThreadsM_ (senderThreads ++ [thread]) + where + senderThreadsM_ = senderThreadsM systemconfig + + +throwShutdownExceptionToThread :: Thread -> IO () +throwShutdownExceptionToThread thread + = throwTo (getThreadId thread) ShuttingDownException + + +allWorkerThreads :: EventloopSystemConfiguration progstateT + -> IO [Thread] +allWorkerThreads systemconfig + = do + retrievers <- retrieverThreads systemconfig + outRouter <- outRouterThread systemconfig + senders <- senderThreads systemconfig + return (retrievers ++ outRouter ++ senders) + + +retrieverThreads :: EventloopSystemConfiguration progstateT + -> IO [Thread] +retrieverThreads systemconfig + = readMVar retrieverThreadsM_ + where + retrieverThreadsM_ = retrieverThreadsM systemconfig + + +outRouterThread :: EventloopSystemConfiguration progstateT + -> IO [Thread] +outRouterThread systemconfig + = do + hasNotOutRouterThread <- isEmptyMVar outRouterThreadM_ + case hasNotOutRouterThread of + True -> return [] + False -> do + outRouterThread <- readMVar outRouterThreadM_ + return [outRouterThread] + where + outRouterThreadM_ = outRouterThreadM systemconfig + + +senderThreads :: EventloopSystemConfiguration progstateT + -> IO [Thread] +senderThreads systemconfig + = readMVar senderThreadsM_ + where + senderThreadsM_ = senderThreadsM systemconfig diff --git a/src/Eventloop/DefaultConfiguration.hs b/src/Eventloop/DefaultConfiguration.hs --- a/src/Eventloop/DefaultConfiguration.hs +++ b/src/Eventloop/DefaultConfiguration.hs @@ -1,44 +1,44 @@ -module Eventloop.DefaultConfiguration where - -import Control.Concurrent.SafePrint - -import Eventloop.Module.Websocket.Keyboard -import Eventloop.Module.Websocket.Mouse -import Eventloop.Module.File -import Eventloop.Module.StdOut -import Eventloop.Module.StdIn -import Eventloop.Module.Timer -import Eventloop.Types.Events -import Eventloop.Types.System - -allModulesEventloopSetupConfiguration :: progstateT -> {- Begin program state -} - (progstateT -> In -> (progstateT, [Out])) -> {- Eventloop function -} - EventloopSetupConfiguration progstateT -allModulesEventloopSetupConfiguration beginProgstate eventloop - = ( EventloopSetupConfiguration - -- Begin program state - beginProgstate - - -- Eventloop function - eventloop - - -- All module setupconfigurations - [ setupFileModuleConfiguration - , setupTimerModuleConfiguration - , setupKeyboardModuleConfiguration - , setupMouseModuleConfiguration - , setupStdInModuleConfiguration - , setupStdOutModuleConfiguration - ] - ) - - -setupSharedIOConstants :: IO SharedIOConstants -setupSharedIOConstants - = do - safePrintToken <- createSafePrintToken - return (SharedIOConstants safePrintToken undefined) - -setupSharedIOState :: IO SharedIOState -setupSharedIOState +module Eventloop.DefaultConfiguration where + +import Control.Concurrent.SafePrint + +import Eventloop.Module.Websocket.Keyboard +import Eventloop.Module.Websocket.Mouse +import Eventloop.Module.File +import Eventloop.Module.StdOut +import Eventloop.Module.StdIn +import Eventloop.Module.Timer +import Eventloop.Types.Events +import Eventloop.Types.System + +allModulesEventloopSetupConfiguration :: progstateT -> {- Begin program state -} + (progstateT -> In -> (progstateT, [Out])) -> {- Eventloop function -} + EventloopSetupConfiguration progstateT +allModulesEventloopSetupConfiguration beginProgstate eventloop + = ( EventloopSetupConfiguration + -- Begin program state + beginProgstate + + -- Eventloop function + eventloop + + -- All module setupconfigurations + [ setupFileModuleConfiguration + , setupTimerModuleConfiguration + , setupKeyboardModuleConfiguration + , setupMouseModuleConfiguration + , setupStdInModuleConfiguration + , setupStdOutModuleConfiguration + ] + ) + + +setupSharedIOConstants :: IO SharedIOConstants +setupSharedIOConstants + = do + safePrintToken <- createSafePrintToken + return (SharedIOConstants safePrintToken undefined) + +setupSharedIOState :: IO SharedIOState +setupSharedIOState = return SharedIOState diff --git a/src/Eventloop/Module/BasicShapes.hs b/src/Eventloop/Module/BasicShapes.hs --- a/src/Eventloop/Module/BasicShapes.hs +++ b/src/Eventloop/Module/BasicShapes.hs @@ -1,9 +1,9 @@ -module Eventloop.Module.BasicShapes - ( module Eventloop.Module.BasicShapes.BasicShapes - , module Eventloop.Module.BasicShapes.Types - , module Eventloop.Module.BasicShapes.Classes - ) where - -import Eventloop.Module.BasicShapes.BasicShapes -import Eventloop.Module.BasicShapes.Types +module Eventloop.Module.BasicShapes + ( module Eventloop.Module.BasicShapes.BasicShapes + , module Eventloop.Module.BasicShapes.Types + , module Eventloop.Module.BasicShapes.Classes + ) where + +import Eventloop.Module.BasicShapes.BasicShapes +import Eventloop.Module.BasicShapes.Types import Eventloop.Module.BasicShapes.Classes diff --git a/src/Eventloop/Module/BasicShapes/BasicShapes.hs b/src/Eventloop/Module/BasicShapes/BasicShapes.hs --- a/src/Eventloop/Module/BasicShapes/BasicShapes.hs +++ b/src/Eventloop/Module/BasicShapes/BasicShapes.hs @@ -1,46 +1,46 @@ -module Eventloop.Module.BasicShapes.BasicShapes - ( setupBasicShapesModuleConfiguration - , basicShapesModuleIdentifier - , basicShapesPostProcessor - ) where - -import Control.Concurrent.SafePrint - -import Eventloop.Module.BasicShapes.Types -import Eventloop.Module.BasicShapes.Classes -import Eventloop.Module.BasicShapes.MeasureTextHack -import Eventloop.Types.Common -import Eventloop.Types.Events -import Eventloop.Types.System - -setupBasicShapesModuleConfiguration :: EventloopSetupModuleConfiguration -setupBasicShapesModuleConfiguration = ( EventloopSetupModuleConfiguration - basicShapesModuleIdentifier - (Just basicShapesInitializer) - Nothing - Nothing - (Just basicShapesPostProcessor) - Nothing - Nothing - ) - - -basicShapesModuleIdentifier :: EventloopModuleIdentifier -basicShapesModuleIdentifier = "basicshapes" - - -basicShapesInitializer :: Initializer -basicShapesInitializer sharedConst sharedIO - = do - saveMeasureText (measureText sharedConst) - return (sharedConst, sharedIO, NoConstants, NoState) - - -basicShapesPostProcessor :: PostProcessor -basicShapesPostProcessor sharedConst sharedIOT ioConst ioStateT (OutBasicShapes basicShapesOut) - = return [OutCanvas canvasOut] - where - canvasOut = toCanvasOut basicShapesOut - -basicShapesPostProcessor sharedConst sharedIOT ioConst ioStateT out +module Eventloop.Module.BasicShapes.BasicShapes + ( setupBasicShapesModuleConfiguration + , basicShapesModuleIdentifier + , basicShapesPostProcessor + ) where + +import Control.Concurrent.SafePrint + +import Eventloop.Module.BasicShapes.Types +import Eventloop.Module.BasicShapes.Classes +import Eventloop.Module.BasicShapes.MeasureTextHack +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System + +setupBasicShapesModuleConfiguration :: EventloopSetupModuleConfiguration +setupBasicShapesModuleConfiguration = ( EventloopSetupModuleConfiguration + basicShapesModuleIdentifier + (Just basicShapesInitializer) + Nothing + Nothing + (Just basicShapesPostProcessor) + Nothing + Nothing + ) + + +basicShapesModuleIdentifier :: EventloopModuleIdentifier +basicShapesModuleIdentifier = "basicshapes" + + +basicShapesInitializer :: Initializer +basicShapesInitializer sharedConst sharedIO + = do + saveMeasureText (measureText sharedConst) + return (sharedConst, sharedIO, NoConstants, NoState) + + +basicShapesPostProcessor :: PostProcessor +basicShapesPostProcessor sharedConst sharedIOT ioConst ioStateT (OutBasicShapes basicShapesOut) + = return [OutCanvas canvasOut] + where + canvasOut = toCanvasOut basicShapesOut + +basicShapesPostProcessor sharedConst sharedIOT ioConst ioStateT out = return [out] diff --git a/src/Eventloop/Module/BasicShapes/Classes.hs b/src/Eventloop/Module/BasicShapes/Classes.hs --- a/src/Eventloop/Module/BasicShapes/Classes.hs +++ b/src/Eventloop/Module/BasicShapes/Classes.hs @@ -1,531 +1,529 @@ -module Eventloop.Module.BasicShapes.Classes where - -import Control.Concurrent.MVar -import Data.Maybe - -import Eventloop.Utility.Vectors -import Eventloop.Module.BasicShapes.Types -import Eventloop.Module.BasicShapes.MeasureTextHack -import qualified Eventloop.Module.Websocket.Canvas.Types as CT - -{- -The center of a boundingbox is not the center of an element - Rectangle - Intersection of two halves of adjoining sides - Circle - Centre point - RegularPolygon - Centre point - Text - See boundingbox to rectangle - Line - Halfway down the line - MultiLine - See boundingbox -Split into points to calc boundingbox - Rectangle - Split into 4 corners - Circle - Top, left, right and bottom points on the circle - RegularPolygon - Split into the regular polygon points - Text - Split into 4 corners of bbox - Line - Split into the two points - MultiLine - Split into the different points with stroke - Polygon - Split into the different points with stroke --} - -{- -Bugs: -- BoundingBox of circle fails. Cannot use 'rotate points on circle' method. -- Difficult rotation? (Stacked composite shapes) --} - -data GeometricPrimitive = Points [Point] - | CircleArea Point Radius - deriving (Show, Eq) - - -instance RotateLeftAround GeometricPrimitive where - rotateLeftAround p angle (Points points) - = Points $ map (rotateLeftAround p angle) points - rotateLeftAround p angle (CircleArea p' r) - = CircleArea (rotateLeftAround p angle p') r - - -opOnBoundingBox :: (Point -> Point) -> BoundingBox -> BoundingBox -opOnBoundingBox op (BoundingBox p1 p2 p3 p4) = BoundingBox (op p1) - (op p2) - (op p3) - (op p4) - - -instance ExtremaCoord BoundingBox where - xMin (BoundingBox ll _ _ _) = x ll - xMax (BoundingBox _ _ ur _) = x ur - yMin (BoundingBox ll _ _ _) = y ll - yMax (BoundingBox _ _ ur _) = y ur - - -instance ExtremaCoord GeometricPrimitive where - xMin (Points points) = xMin points - xMin (CircleArea (Point (x, y)) r) = x - r - - xMax (Points points) = xMax points - xMax (CircleArea (Point (x, y)) r) = x + r - - yMin (Points points) = yMin points - yMin (CircleArea (Point (x, y)) r) = y - r - - yMax (Points points) = yMax points - yMax (CircleArea (Point (x, y)) r) = y + r - - -instance RotateLeftAround BoundingBox where - rotateLeftAround p angle bbox = opOnBoundingBox (rotateLeftAround p angle) bbox - - - -allRegularPolygonPoints :: NumberOfPoints -> Point -> Radius -> [Point] -allRegularPolygonPoints n centralPoint r | n < 1 = error "A regular polygon with 0 or more sides doesn't exist!" - | otherwise = [centralPoint |+| (toPoint (PolarCoord (r, angle))) |angle <- anglesRads] - where - anglePart = 360 / (fromIntegral n) - startAngle = 0 - anglesDeg = filter (< 360) [startAngle, startAngle + anglePart..360] - anglesRads = map degreesToRadians anglesDeg - - -boundingBoxFromPrimitives :: [GeometricPrimitive] -> BoundingBox -boundingBoxFromPrimitives primitives - = BoundingBox (Point (xMin_, yMin_)) (Point (xMin_, yMax_)) (Point (xMax_, yMax_)) (Point (xMax_, yMin_)) - where - xMin_ = minimum $ map xMin primitives - xMax_ = maximum $ map xMax primitives - yMin_ = minimum $ map yMin primitives - yMax_ = maximum $ map yMax primitives - - -normalizeBBox :: BoundingBox -> BoundingBox -normalizeBBox (BoundingBox p1 p2 p3 p4) - = boundingBoxFromPrimitives [Points [p1, p2, p3, p4]] - - -roundPoint :: Point -> CT.ScreenPoint -roundPoint (Point (x, y)) = (round x, round y) - - -roundColor :: Color -> CT.ScreenColor -roundColor (r, b, g, a) = (round r, round b, round g, a) - -strokePointsForLine :: StrokeLineThickness -> Point -> Point -> [Point] -strokePointsForLine thick p1 p2 - = [ followVector (0.5 * thick) upPerpVector p1 - , followVector (0.5 * thick) upPerpVector p2 - , followVector (0.5 * thick) downPerpVector p1 - , followVector (0.5 * thick) downPerpVector p2 - ] - - where - upPerpVector = upPerpendicular p1 p2 - downPerpVector = negateVector upPerpVector - -strokePointsForConnection :: StrokeLineThickness -> Point -> Point -> Point -> [Point] -strokePointsForConnection strokeWidth start inspected dest - | start == inspected && inspected == dest = [dest] - | start == inspected = strokePointsForLine strokeWidth inspected dest - | inspected == dest = strokePointsForLine strokeWidth start inspected - | isJust mp1 && isJust mp2 = [fromJust mp1, fromJust mp2] - | otherwise = [sup1, sdown1] -- Is possible due to rounding. Direction vectors are roughly parallel but stepping points are not equal - -- GHC will think parallel vectors are parallel while they are not. So no intersection as stepping points are slightly different - -- Just return half width up and down from inspected as this is close enough - where - halfWidth = strokeWidth / 2 - quart = 0.5 * pi - v1 = inspected |-| start - v1' = negateVector v1 - v2 = inspected |-| dest - v2' = negateVector v2 - upv1 = turnToVector v1 quart v2 - sup1 = followVector halfWidth upv1 inspected - upv2 = turnToVector v2 quart v1 - sup2 = followVector halfWidth upv2 inspected - downv1 = negateVector upv1 - sdown1 = followVector halfWidth downv1 inspected - downv2 = negateVector upv2 - sdown2 = followVector halfWidth downv2 inspected - mp1 = intersectVector sdown1 v1 sdown2 v2 - mp2 = intersectVector sup1 v1 sup2 v2 - - -strokePoints :: StrokeLineThickness -> [Point] -> [Point] -strokePoints strokeWidth ps - | l >= 3 = concat $ map (\(start, inspected, dest) -> strokePointsForConnection strokeWidth start inspected dest) connections - | otherwise = [] - where - l = length ps - connections = zip3 ps (drop 1 ps) (drop 2 ps) - - -strokePointsClosedPath :: StrokeLineThickness -> [Point] -> [Point] -strokePointsClosedPath strokeWidth ps - | length ps >= 3 = strokePoints strokeWidth (ps ++ take 2 ps) - | otherwise = [] - - -instance Translate Shape where - translate p c@(CompositeShape {positionM=Nothing}) - = c {positionM = (Just p)} - translate p c@(CompositeShape {positionM=(Just p1)}) - = c {positionM = (Just $ p1 |+| p)} - translate p r@(Rectangle {position=trans}) - = r {position = trans |+| p} - translate p c@(Circle {position=trans}) - = c {position = trans |+| p} - translate p po@(RegularPolygon {position=trans}) - = po {position = trans |+| p} - translate p t@(Text {position=trans}) - = t {position = trans |+| p} - translate pTrans l@(Line {point1=p1, point2=p2}) - = l {point1 = (p1 |+| pTrans), point2 = (p2 |+| pTrans)} - translate pTrans ml@(MultiLine {points=points}) - = ml {points = (map ((|+|) pTrans) points)} - translate pTrans a@(Polygon {points=points}) - = a {points = (map ((|+|) pTrans) points)} - -instance Translate GeometricPrimitive where - translate p (Points points) = Points (map (|+| p) points) - translate p (CircleArea p' r) = CircleArea (p |+| p') r - - -class ToPrimitives a where - toPrimitives :: a -> [GeometricPrimitive] - -instance ToPrimitives BoundingBox where - toPrimitives (BoundingBox ll ul ur lr) = [Points [ll, ul, ur, lr]] - -instance ToPrimitives Shape where - toPrimitives (CompositeShape shapes positionM Nothing) - | isJust positionM = map (translate (fromJust positionM)) primitives - | otherwise = primitives - where - primitives = concat $ map toPrimitives shapes - toPrimitives (Rectangle {position=(Point (x, y)), dimensions=(w, h), strokeLineThickness=thick, rotationM=Nothing}) - = [ Points [ Point (x - hthick, y - hthick) - , Point (x - hthick, y + h + hthick) - , Point (x + w + hthick, y + h + hthick) - , Point (x + w + hthick, y - hthick) - ] - ] - where - hthick = 0.5 * thick - toPrimitives (Circle {position=p, radius=r, strokeLineThickness=thick, rotationM=Nothing}) - = [CircleArea p (r + 0.5 * thick)] - toPrimitives (RegularPolygon {numberOfPoints=a, position=p, radius=r, strokeLineThickness=thick, rotationM=Nothing}) - = toPrimitives (Polygon points undefined thick undefined Nothing) - where - points = allRegularPolygonPoints a p r - toPrimitives text@(Text {position=(Point (x,y)), alignment=align, rotationM=Nothing}) - = [ Points $ case align of - CT.AlignLeft -> [ Point (x, y) - , Point (x, y + height) - , Point (x + width, y) - , Point (x + width, y + height) - ] - CT.AlignCenter -> [ Point (x - hwidth, y - hheight) - , Point (x - hwidth, y + hheight) - , Point (x + hwidth, y - hheight) - , Point (x + hwidth, y + hheight) - ] - CT.AlignRight -> [ Point (x, y) - , Point (x, y + height) - , Point (x - width, y) - , Point (x - width, y + height) - ] - ] - where - canvasText = toCanvasText text - (width_, height_) = useMeasureText canvasText - width = fromIntegral width_ - hwidth = width * 0.5 - height = fromIntegral height_ - hheight = height * 0.5 - - toPrimitives (Line {point1=p1, point2=p2, strokeLineThickness=thick, rotationM=Nothing}) - = [Points (strokePointsForLine thick p1 p2)] - toPrimitives (MultiLine {points=points, strokeLineThickness=thick, strokeColor=color, rotationM=Nothing}) - | len >= 3 = (Points strokePoints_) : (concat $ map toPrimitives lines) - | len == 2 = toPrimitives (Line p1 p2 thick color Nothing) - | otherwise = error "Multilines should atleast include 2 points!" - where - [p1, p2] = points - len = length points - strokePoints_ = strokePoints thick points - tailPoints = drop 1 points - linePoints = zip points tailPoints - lines = map (\(p, p') -> Line p p' thick undefined Nothing) linePoints - toPrimitives (FilledMultiLine {points=points, fillWidth=fillThick, strokeLineThickness=strokeThick, rotationM=Nothing}) - = (toPrimitives (MultiLine points fillThick undefined Nothing)) ++ (toPrimitives (MultiLine points (fillThick + strokeThick) undefined Nothing)) - toPrimitives pol@(Polygon {points=points, strokeLineThickness=thick, rotationM=Nothing}) - | length points >= 3 = [ Points (strokePointsClosedPath thick points)] - | length points == 2 = toPrimitives (Line p1 p2 thick undefined Nothing) - | length points == 1 = [ CircleArea p1 thick ] - | otherwise = [ Points []] - where - (p1:p2:ps) = points - toPrimitives shape - = map (rotateLeftAround rotatePoint angle) (toPrimitives shapePreRotate) - where - shapePreRotate = shape{rotationM=Nothing} - (Just rotation@(Rotation _ angle)) = rotationM shape - rotatePoint = findRotationPoint shapePreRotate rotation - - -class ToCenter a where - toCenter :: a -> Point - -instance ToCenter BoundingBox where - toCenter bbox - = Point (minX + 0.5 * (maxX - minX), minY + 0.5 * (maxY - minY)) - where - minX = xMin bbox - maxX = xMax bbox - minY = yMin bbox - maxY = yMax bbox - -instance ToCenter Shape where - toCenter c@(CompositeShape {positionM=(Just p), rotationM=Nothing}) - = p |+| center - where - center = toCenter c{positionM=Nothing} - toCenter c@(CompositeShape {shapes=shapes, positionM=Nothing, rotationM=Nothing}) - = averagePoint centers - where - centers = map toCenter shapes - toCenter r@(Rectangle {dimensions=(width, height), position=p, rotationM=Nothing}) - = p |+| (Point (0.5 * width, 0.5 * height)) - toCenter c@(Circle {position=p, rotationM=Nothing}) - = p - toCenter po@(RegularPolygon {position=p, rotationM=Nothing}) - = p - toCenter t@(Text {rotationM=Nothing}) - = (toCenter.toBoundingBox) t - toCenter l@(Line {}) - = (toCenter.toBoundingBox) l - toCenter ml@(MultiLine {}) - = (toCenter.toBoundingBox) ml - toCenter fml@(FilledMultiLine {}) - = (toCenter.toBoundingBox) fml - toCenter a@(Polygon {}) - = (toCenter.toBoundingBox) a - toCenter shape - = rotateLeftAround rotationPoint angle center - where - (Just rotation) = rotationM shape - shapePreRotate = shape{rotationM=Nothing} - center = toCenter shapePreRotate - rotationPoint = findRotationPoint shapePreRotate rotation - (Rotation _ angle) = rotation - - -class (ToPrimitives a) => ToBoundingBox a where - toBoundingBox :: a -> BoundingBox - -instance ToBoundingBox BoundingBox where - toBoundingBox box = box - -instance ToBoundingBox Shape where - toBoundingBox a - = boundingBoxFromPrimitives $ toPrimitives a - - -class (ToBoundingBox a) => Overlaps a where - {- - The boundingbox of a1 partially overlaps the boundingbox of a2. Ofcourse if overlaps(a1, a2) then - overlaps(a2, a1). However, if contains(a1, a2) or contains(a2, a1), then overlaps(a1, a2) == false - -} - overlaps :: (Overlaps b) => a -> b -> Bool - overlaps a1 a2 - | contains a1 a2 || contains a2 a1 = False - | xMax b1 < xMin b2 = False -- b1 is left of b2 - | xMin b1 > xMax b2 = False -- b2 is right of b2 - | yMax b1 < yMin b2 = False -- b1 is lower than b2 - | yMin b1 > yMax b2 = False -- b1 is higher than b2 - | otherwise = True - where - b1 = toBoundingBox a1 - b2 = toBoundingBox a2 - - {- - The boundingbox of a1 contains the boundingbox of a2. If boundingbox(a2) > boundingbox(a1) - then a1 can never contain a2. If boundingbox(a2) == boundingbox(a1) and contains(a1, a2) - then also contains(a2, a1). - -} - contains :: (Overlaps b) => a -> b -> Bool - contains a1 a2 - | xMax b2 <= xMax b1 && - xMin b2 >= xMin b1 && - yMax b2 <= yMax b1 && - yMin b2 >= yMin b1 = True - | otherwise = False - where - b1 = toBoundingBox a1 - b2 = toBoundingBox a2 - - touches :: (Overlaps b) => a -> b -> Bool - touches a1 a2 = overlaps a1 a2 || contains a1 a2 || contains a2 a1 - - -instance Overlaps Shape -instance Overlaps BoundingBox - - -findRotationPoint :: (ToCenter a) => a -> Rotation -> Point -findRotationPoint a (Rotation AroundCenter _) = toCenter a -findRotationPoint _ (Rotation (AroundPoint p) _) = p - -class ToCanvasOut a where - toCanvasOut :: a -> CT.CanvasOut - -instance ToCanvasOut BasicShapesOut where - toCanvasOut (DrawShapes canvasId shapes) = CT.CanvasOperations canvasId (canvasOperations ++ [CT.Frame]) - where - canvasOperations = (concat.(map toCanvasOperations)) shapes - - -class ToCanvasOperations a where - toCanvasOperations :: a -> [CT.CanvasOperation] - - -toCanvasText :: Shape -> CT.CanvasText -toCanvasText (Text {text=text, fontFamily=family_, fontSize=size, alignment=align}) - = CT.CanvasText text (CT.Font family_ $ round size) align - - -instance ToCanvasOperations Shape where - toCanvasOperations (CompositeShape shapes Nothing Nothing) - = (concat.(map toCanvasOperations)) shapes - - toCanvasOperations (CompositeShape shapes (Just translate) Nothing) - = [ CT.DoTransform CT.Save - , CT.DoTransform (CT.Translate screenPositionPoint) - ] ++ drawOperations ++ - [ CT.DoTransform CT.Restore - ] - where - screenPositionPoint = roundPoint translate - drawOperations = toCanvasOperations (CompositeShape shapes Nothing Nothing) - - toCanvasOperations text@(Text { position=p - , fillColor=fill - , strokeLineThickness=thick - , strokeColor=stroke - , rotationM=Nothing - }) - = [CT.DrawText canvasText p' textStroke textFill] - where - canvasText = toCanvasText text - textFill = CT.TextFill (CT.CanvasColor screenFillColor) - textStroke = CT.TextStroke thick (CT.CanvasColor screenStrokeColor) - screenStrokeColor = roundColor stroke - screenFillColor = roundColor fill - p' = roundPoint p - - toCanvasOperations (FilledMultiLine points fillWidth fillColor strokeThick strokeColor Nothing) - = toCanvasOperations (MultiLine points (fillWidth + strokeThick) strokeColor Nothing) - ++ toCanvasOperations (MultiLine points fillWidth fillColor Nothing) - - toCanvasOperations shape - -- Might be any rotated shape - | isJust (rotationM shape) = [ CT.DoTransform CT.Save - , CT.DoTransform (CT.Translate screenRotationPoint) - , CT.DoTransform (CT.Rotate screenAngle) - ] - ++ (toCanvasOperations movedShape) ++ - [ CT.DoTransform CT.Restore - ] - -- Can only be Rectangle, Circle, RegularPolygon, Line, MultiLine or Polygon - | isJust screenPathPartsM = [CT.DrawPath startingPoint screenPathParts pathStroke canvasPathFill] - | otherwise = [] - where - (Just rotation) = rotationM shape - shapePreRotate = shape{rotationM = Nothing} - rotationPoint = findRotationPoint shapePreRotate rotation - screenRotationPoint = roundPoint rotationPoint - (Rotation _ angle) = rotation - screenAngle = round angle - movedShape = translate (negateVector rotationPoint) shapePreRotate - - canvasPathFill = toCanvasPathFill shape - screenPathPartsM = toScreenPathParts shape - Just (screenPathParts, startingPoint) = screenPathPartsM - screenStrokeColor = roundColor $ strokeColor shape - thick = strokeLineThickness shape - pathStroke = CT.PathStroke thick (CT.CanvasColor screenStrokeColor) - - -class ToScreenPathPart a where - toScreenPathParts :: a -> Maybe ([CT.ScreenPathPart], CT.ScreenStartingPoint) - -instance ToScreenPathPart Shape where - toScreenPathParts (Rectangle {position=p, dimensions=(w, h)}) - = Just ([CT.Rectangle p' (w', h')], p') - where - p' = roundPoint p - w' = round w - h' = round h - toScreenPathParts (Circle {position=p, radius=r}) - = Just ([CT.Arc (p', r') 0 360], p') - where - p' = roundPoint p - r' = round r - toScreenPathParts (RegularPolygon {position=p, numberOfPoints=n, radius=r}) - = Just (lines ++ [CT.ClosePath], screenPoint) - where - polygonPoints = allRegularPolygonPoints n p r - (screenPoint:ps) = map roundPoint polygonPoints - lines = [CT.LineTo screenPoint' | screenPoint' <- (ps ++ [screenPoint])] - toScreenPathParts (Line {point1=p1, point2=p2}) - = Just ([CT.LineTo p2'], p1') - where - p1' = roundPoint p1 - p2' = roundPoint p2 - - toScreenPathParts (MultiLine {points=points}) - | (length points) > 0 = Just (lines ++ [CT.MoveTo p1'], p1') - | otherwise = Nothing - where - (p1':otherPoints') = map roundPoint points - lines = [CT.LineTo p' | p' <- otherPoints'] - - toScreenPathParts pol@(Polygon {points=points}) - | (length points) > 0 = Just (lines ++ [CT.ClosePath], p1') - | otherwise = Nothing - where - allPoints = allScreenPolygonPoints pol - (p1':otherPoints') = map roundPoint allPoints - lines = [CT.LineTo p' | p' <- otherPoints'] - - -toCanvasPathFill :: Shape -> CT.PathFill -toCanvasPathFill shape - | hasCanvasPathFill shape = CT.PathFill (CT.CanvasColor screenFillColor) - | otherwise = CT.NoPathFill - where - fillColor_ = fillColor shape - screenFillColor = roundColor fillColor_ - - -hasCanvasPathFill :: Shape -> Bool -hasCanvasPathFill (Rectangle {}) - = True -hasCanvasPathFill (Circle {}) - = True -hasCanvasPathFill (RegularPolygon {}) - = True -hasCanvasPathFill (Polygon {}) - = True -hasCanvasPathFill _ - = False - - -allScreenPolygonPoints :: Shape -> [Point] -allScreenPolygonPoints (Polygon {points=points}) - | (length points) >= 2 = points ++ [firstP] - | otherwise = points - where - firstP = head points - lastP = last points - - +module Eventloop.Module.BasicShapes.Classes where + +import Control.Concurrent.MVar +import Data.Maybe + +import Eventloop.Utility.Vectors +import Eventloop.Module.BasicShapes.Types +import Eventloop.Module.BasicShapes.MeasureTextHack +import qualified Eventloop.Module.Websocket.Canvas.Types as CT + +{- +The center of a boundingbox is not the center of an element + Rectangle - Intersection of two halves of adjoining sides + Circle - Centre point + RegularPolygon - Centre point + Text - See boundingbox to rectangle + Line - Halfway down the line + MultiLine - See boundingbox +Split into points to calc boundingbox + Rectangle - Split into 4 corners + Circle - Top, left, right and bottom points on the circle + RegularPolygon - Split into the regular polygon points + Text - Split into 4 corners of bbox + Line - Split into the two points + MultiLine - Split into the different points with stroke + Polygon - Split into the different points with stroke +-} + +{- +Bugs: +- BoundingBox of circle fails. Cannot use 'rotate points on circle' method. +- Difficult rotation? (Stacked composite shapes) +-} + +data GeometricPrimitive = Points [Point] + | CircleArea Point Radius + deriving (Show, Eq) + + +instance RotateLeftAround GeometricPrimitive where + rotateLeftAround p angle (Points points) + = Points $ map (rotateLeftAround p angle) points + rotateLeftAround p angle (CircleArea p' r) + = CircleArea (rotateLeftAround p angle p') r + + +opOnBoundingBox :: (Point -> Point) -> BoundingBox -> BoundingBox +opOnBoundingBox op (BoundingBox p1 p2 p3 p4) = BoundingBox (op p1) + (op p2) + (op p3) + (op p4) + + +instance ExtremaCoord BoundingBox where + xMin (BoundingBox ll _ _ _) = x ll + xMax (BoundingBox _ _ ur _) = x ur + yMin (BoundingBox ll _ _ _) = y ll + yMax (BoundingBox _ _ ur _) = y ur + + +instance ExtremaCoord GeometricPrimitive where + xMin (Points points) = xMin points + xMin (CircleArea (Point (x, y)) r) = x - r + + xMax (Points points) = xMax points + xMax (CircleArea (Point (x, y)) r) = x + r + + yMin (Points points) = yMin points + yMin (CircleArea (Point (x, y)) r) = y - r + + yMax (Points points) = yMax points + yMax (CircleArea (Point (x, y)) r) = y + r + + +instance RotateLeftAround BoundingBox where + rotateLeftAround p angle bbox = opOnBoundingBox (rotateLeftAround p angle) bbox + + + +allRegularPolygonPoints :: NumberOfPoints -> Point -> Radius -> [Point] +allRegularPolygonPoints n centralPoint r | n < 1 = error "A regular polygon with 0 or more sides doesn't exist!" + | otherwise = [centralPoint |+| (toPoint (PolarCoord (r, angle))) |angle <- anglesRads] + where + anglePart = 360 / (fromIntegral n) + startAngle = 0 + anglesDeg = filter (< 360) [startAngle, startAngle + anglePart..360] + anglesRads = map degreesToRadians anglesDeg + + +boundingBoxFromPrimitives :: [GeometricPrimitive] -> BoundingBox +boundingBoxFromPrimitives primitives + = BoundingBox (Point (xMin_, yMin_)) (Point (xMin_, yMax_)) (Point (xMax_, yMax_)) (Point (xMax_, yMin_)) + where + xMin_ = minimum $ map xMin primitives + xMax_ = maximum $ map xMax primitives + yMin_ = minimum $ map yMin primitives + yMax_ = maximum $ map yMax primitives + + +normalizeBBox :: BoundingBox -> BoundingBox +normalizeBBox (BoundingBox p1 p2 p3 p4) + = boundingBoxFromPrimitives [Points [p1, p2, p3, p4]] + + +roundPoint :: Point -> CT.ScreenPoint +roundPoint (Point (x, y)) = (round x, round y) + + +roundColor :: Color -> CT.ScreenColor +roundColor (r, b, g, a) = (round r, round b, round g, a) + +strokePointsForLine :: StrokeLineThickness -> Point -> Point -> [Point] +strokePointsForLine thick p1 p2 + = [ followVector (0.5 * thick) upPerpVector p1 + , followVector (0.5 * thick) upPerpVector p2 + , followVector (0.5 * thick) downPerpVector p1 + , followVector (0.5 * thick) downPerpVector p2 + ] + + where + upPerpVector = upPerpendicular p1 p2 + downPerpVector = negateVector upPerpVector + +strokePointsForConnection :: StrokeLineThickness -> Point -> Point -> Point -> [Point] +strokePointsForConnection strokeWidth start inspected dest + | start == inspected && inspected == dest = [dest] + | start == inspected = strokePointsForLine strokeWidth inspected dest + | inspected == dest = strokePointsForLine strokeWidth start inspected + | isJust mp1 && isJust mp2 = [fromJust mp1, fromJust mp2] + | otherwise = [sup1, sdown1] -- Is possible due to rounding. Direction vectors are roughly parallel but stepping points are not equal + -- GHC will think parallel vectors are parallel while they are not. So no intersection as stepping points are slightly different + -- Just return half width up and down from inspected as this is close enough + where + halfWidth = strokeWidth / 2 + quart = 0.5 * pi + v1 = inspected |-| start + v1' = negateVector v1 + v2 = inspected |-| dest + v2' = negateVector v2 + upv1 = turnToVector v1 quart v2 + sup1 = followVector halfWidth upv1 inspected + upv2 = turnToVector v2 quart v1 + sup2 = followVector halfWidth upv2 inspected + downv1 = negateVector upv1 + sdown1 = followVector halfWidth downv1 inspected + downv2 = negateVector upv2 + sdown2 = followVector halfWidth downv2 inspected + mp1 = intersectVector sdown1 v1 sdown2 v2 + mp2 = intersectVector sup1 v1 sup2 v2 + + +strokePoints :: StrokeLineThickness -> [Point] -> [Point] +strokePoints strokeWidth ps + | l >= 3 = concat $ map (\(start, inspected, dest) -> strokePointsForConnection strokeWidth start inspected dest) connections + | otherwise = [] + where + l = length ps + connections = zip3 ps (drop 1 ps) (drop 2 ps) + + +strokePointsClosedPath :: StrokeLineThickness -> [Point] -> [Point] +strokePointsClosedPath strokeWidth ps + | length ps >= 3 = strokePoints strokeWidth (ps ++ take 2 ps) + | otherwise = [] + + +instance Translate Shape where + translate p c@(CompositeShape {positionM=Nothing}) + = c {positionM = (Just p)} + translate p c@(CompositeShape {positionM=(Just p1)}) + = c {positionM = (Just $ p1 |+| p)} + translate p r@(Rectangle {position=trans}) + = r {position = trans |+| p} + translate p c@(Circle {position=trans}) + = c {position = trans |+| p} + translate p po@(RegularPolygon {position=trans}) + = po {position = trans |+| p} + translate p t@(Text {position=trans}) + = t {position = trans |+| p} + translate pTrans l@(Line {point1=p1, point2=p2}) + = l {point1 = (p1 |+| pTrans), point2 = (p2 |+| pTrans)} + translate pTrans ml@(MultiLine {points=points}) + = ml {points = (map ((|+|) pTrans) points)} + translate pTrans a@(Polygon {points=points}) + = a {points = (map ((|+|) pTrans) points)} + +instance Translate GeometricPrimitive where + translate p (Points points) = Points (map (|+| p) points) + translate p (CircleArea p' r) = CircleArea (p |+| p') r + + +class ToPrimitives a where + toPrimitives :: a -> [GeometricPrimitive] + +instance ToPrimitives BoundingBox where + toPrimitives (BoundingBox ll ul ur lr) = [Points [ll, ul, ur, lr]] + +instance ToPrimitives Shape where + toPrimitives (CompositeShape shapes positionM Nothing) + | isJust positionM = map (translate (fromJust positionM)) primitives + | otherwise = primitives + where + primitives = concat $ map toPrimitives shapes + toPrimitives (Rectangle {position=(Point (x, y)), dimensions=(w, h), strokeLineThickness=thick, rotationM=Nothing}) + = [ Points [ Point (x - hthick, y - hthick) + , Point (x - hthick, y + h + hthick) + , Point (x + w + hthick, y + h + hthick) + , Point (x + w + hthick, y - hthick) + ] + ] + where + hthick = 0.5 * thick + toPrimitives (Circle {position=p, radius=r, strokeLineThickness=thick, rotationM=Nothing}) + = [CircleArea p (r + 0.5 * thick)] + toPrimitives (RegularPolygon {numberOfPoints=a, position=p, radius=r, strokeLineThickness=thick, rotationM=Nothing}) + = toPrimitives (Polygon points undefined thick undefined Nothing) + where + points = allRegularPolygonPoints a p r + toPrimitives text@(Text {position=(Point (x,y)), alignment=align, rotationM=Nothing}) + = [ Points $ case align of + CT.AlignLeft -> [ Point (x, y) + , Point (x, y + height) + , Point (x + width, y) + , Point (x + width, y + height) + ] + CT.AlignCenter -> [ Point (x - hwidth, y - hheight) + , Point (x - hwidth, y + hheight) + , Point (x + hwidth, y - hheight) + , Point (x + hwidth, y + hheight) + ] + CT.AlignRight -> [ Point (x, y) + , Point (x, y + height) + , Point (x - width, y) + , Point (x - width, y + height) + ] + ] + where + canvasText = toCanvasText text + (width_, height_) = useMeasureText canvasText + width = fromIntegral width_ + hwidth = width * 0.5 + height = fromIntegral height_ + hheight = height * 0.5 + + toPrimitives (Line {point1=p1, point2=p2, strokeLineThickness=thick, rotationM=Nothing}) + = [Points (strokePointsForLine thick p1 p2)] + toPrimitives (MultiLine {points=points, strokeLineThickness=thick, strokeColor=color, rotationM=Nothing}) + | len >= 3 = (Points strokePoints_) : (concat $ map toPrimitives lines) + | len == 2 = toPrimitives (Line p1 p2 thick color Nothing) + | otherwise = error "Multilines should atleast include 2 points!" + where + [p1, p2] = points + len = length points + strokePoints_ = strokePoints thick points + tailPoints = drop 1 points + linePoints = zip points tailPoints + lines = map (\(p, p') -> Line p p' thick undefined Nothing) linePoints + toPrimitives (FilledMultiLine {points=points, fillWidth=fillThick, strokeLineThickness=strokeThick, rotationM=Nothing}) + = (toPrimitives (MultiLine points fillThick undefined Nothing)) ++ (toPrimitives (MultiLine points (fillThick + strokeThick) undefined Nothing)) + toPrimitives pol@(Polygon {points=points, strokeLineThickness=thick, rotationM=Nothing}) + | length points >= 3 = [ Points (strokePointsClosedPath thick points)] + | length points == 2 = toPrimitives (Line p1 p2 thick undefined Nothing) + | length points == 1 = [ CircleArea p1 thick ] + | otherwise = [ Points []] + where + (p1:p2:ps) = points + toPrimitives shape + = map (rotateLeftAround rotatePoint angle) (toPrimitives shapePreRotate) + where + shapePreRotate = shape{rotationM=Nothing} + (Just rotation@(Rotation _ angle)) = rotationM shape + rotatePoint = findRotationPoint shapePreRotate rotation + + +class ToCenter a where + toCenter :: a -> Point + +instance ToCenter BoundingBox where + toCenter bbox + = Point (minX + 0.5 * (maxX - minX), minY + 0.5 * (maxY - minY)) + where + minX = xMin bbox + maxX = xMax bbox + minY = yMin bbox + maxY = yMax bbox + +instance ToCenter Shape where + toCenter c@(CompositeShape {positionM=(Just p), rotationM=Nothing}) + = p |+| center + where + center = toCenter c{positionM=Nothing} + toCenter c@(CompositeShape {shapes=shapes, positionM=Nothing, rotationM=Nothing}) + = averagePoint centers + where + centers = map toCenter shapes + toCenter r@(Rectangle {dimensions=(width, height), position=p, rotationM=Nothing}) + = p |+| (Point (0.5 * width, 0.5 * height)) + toCenter c@(Circle {position=p, rotationM=Nothing}) + = p + toCenter po@(RegularPolygon {position=p, rotationM=Nothing}) + = p + toCenter t@(Text {rotationM=Nothing}) + = (toCenter.toBoundingBox) t + toCenter l@(Line {}) + = (toCenter.toBoundingBox) l + toCenter ml@(MultiLine {}) + = (toCenter.toBoundingBox) ml + toCenter fml@(FilledMultiLine {}) + = (toCenter.toBoundingBox) fml + toCenter a@(Polygon {}) + = (toCenter.toBoundingBox) a + toCenter shape + = rotateLeftAround rotationPoint angle center + where + (Just rotation) = rotationM shape + shapePreRotate = shape{rotationM=Nothing} + center = toCenter shapePreRotate + rotationPoint = findRotationPoint shapePreRotate rotation + (Rotation _ angle) = rotation + + +class (ToPrimitives a) => ToBoundingBox a where + toBoundingBox :: a -> BoundingBox + +instance ToBoundingBox BoundingBox where + toBoundingBox box = box + +instance ToBoundingBox Shape where + toBoundingBox a + = boundingBoxFromPrimitives $ toPrimitives a + + +class (ToBoundingBox a) => Overlaps a where + {- + The boundingbox of a1 partially overlaps the boundingbox of a2. Ofcourse if overlaps(a1, a2) then + overlaps(a2, a1). However, if contains(a1, a2) or contains(a2, a1), then overlaps(a1, a2) == false + -} + overlaps :: (Overlaps b) => a -> b -> Bool + overlaps a1 a2 + | contains a1 a2 || contains a2 a1 = False + | xMax b1 < xMin b2 = False -- b1 is left of b2 + | xMin b1 > xMax b2 = False -- b2 is right of b2 + | yMax b1 < yMin b2 = False -- b1 is lower than b2 + | yMin b1 > yMax b2 = False -- b1 is higher than b2 + | otherwise = True + where + b1 = toBoundingBox a1 + b2 = toBoundingBox a2 + + {- + The boundingbox of a1 contains the boundingbox of a2. If boundingbox(a2) > boundingbox(a1) + then a1 can never contain a2. If boundingbox(a2) == boundingbox(a1) and contains(a1, a2) + then also contains(a2, a1). + -} + contains :: (Overlaps b) => a -> b -> Bool + contains a1 a2 + | xMax b2 <= xMax b1 && + xMin b2 >= xMin b1 && + yMax b2 <= yMax b1 && + yMin b2 >= yMin b1 = True + | otherwise = False + where + b1 = toBoundingBox a1 + b2 = toBoundingBox a2 + + touches :: (Overlaps b) => a -> b -> Bool + touches a1 a2 = overlaps a1 a2 || contains a1 a2 || contains a2 a1 + + +instance Overlaps Shape +instance Overlaps BoundingBox + + +findRotationPoint :: (ToCenter a) => a -> Rotation -> Point +findRotationPoint a (Rotation AroundCenter _) = toCenter a +findRotationPoint _ (Rotation (AroundPoint p) _) = p + +class ToCanvasOut a where + toCanvasOut :: a -> CT.CanvasOut + +instance ToCanvasOut BasicShapesOut where + toCanvasOut (DrawShapes canvasId shapes) = CT.CanvasOperations canvasId (canvasOperations ++ [CT.Frame]) + where + canvasOperations = (concat.(map toCanvasOperations)) shapes + + +class ToCanvasOperations a where + toCanvasOperations :: a -> [CT.CanvasOperation] + + +toCanvasText :: Shape -> CT.CanvasText +toCanvasText (Text {text=text, fontFamily=family_, fontSize=size, alignment=align}) + = CT.CanvasText text (CT.Font family_ $ round size) align + + +instance ToCanvasOperations Shape where + toCanvasOperations (CompositeShape shapes Nothing Nothing) + = (concat.(map toCanvasOperations)) shapes + + toCanvasOperations (CompositeShape shapes (Just translate) Nothing) + = [ CT.DoTransform CT.Save + , CT.DoTransform (CT.Translate screenPositionPoint) + ] ++ drawOperations ++ + [ CT.DoTransform CT.Restore + ] + where + screenPositionPoint = roundPoint translate + drawOperations = toCanvasOperations (CompositeShape shapes Nothing Nothing) + + toCanvasOperations text@(Text { position=p + , fillColor=fill + , strokeLineThickness=thick + , strokeColor=stroke + , rotationM=Nothing + }) + = [CT.DrawText canvasText p' textStroke textFill] + where + canvasText = toCanvasText text + textFill = CT.TextFill (CT.CanvasColor screenFillColor) + textStroke = CT.TextStroke thick (CT.CanvasColor screenStrokeColor) + screenStrokeColor = roundColor stroke + screenFillColor = roundColor fill + p' = roundPoint p + + toCanvasOperations (FilledMultiLine points fillWidth fillColor strokeThick strokeColor Nothing) + = toCanvasOperations (MultiLine points (fillWidth + strokeThick) strokeColor Nothing) + ++ toCanvasOperations (MultiLine points fillWidth fillColor Nothing) + + toCanvasOperations shape + -- Might be any rotated shape + | isJust (rotationM shape) = [ CT.DoTransform CT.Save + , CT.DoTransform (CT.Translate screenRotationPoint) + , CT.DoTransform (CT.Rotate screenAngle) + ] + ++ (toCanvasOperations movedShape) ++ + [ CT.DoTransform CT.Restore + ] + -- Can only be Rectangle, Circle, RegularPolygon, Line, MultiLine or Polygon + | isJust screenPathPartsM = [CT.DrawPath startingPoint screenPathParts pathStroke canvasPathFill] + | otherwise = [] + where + (Just rotation) = rotationM shape + shapePreRotate = shape{rotationM = Nothing} + rotationPoint = findRotationPoint shapePreRotate rotation + screenRotationPoint = roundPoint rotationPoint + (Rotation _ angle) = rotation + screenAngle = round angle + movedShape = translate (negateVector rotationPoint) shapePreRotate + + canvasPathFill = toCanvasPathFill shape + screenPathPartsM = toScreenPathParts shape + Just (screenPathParts, startingPoint) = screenPathPartsM + screenStrokeColor = roundColor $ strokeColor shape + thick = strokeLineThickness shape + pathStroke = CT.PathStroke thick (CT.CanvasColor screenStrokeColor) + + +class ToScreenPathPart a where + toScreenPathParts :: a -> Maybe ([CT.ScreenPathPart], CT.ScreenStartingPoint) + +instance ToScreenPathPart Shape where + toScreenPathParts (Rectangle {position=p, dimensions=(w, h)}) + = Just ([CT.Rectangle p' (w', h')], p') + where + p' = roundPoint p + w' = round w + h' = round h + toScreenPathParts (Circle {position=p, radius=r}) + = Just ([CT.Arc (p', r') 0 360], p') + where + p' = roundPoint p + r' = round r + toScreenPathParts (RegularPolygon {position=p, numberOfPoints=n, radius=r}) + = Just (lines ++ [CT.ClosePath], screenPoint) + where + polygonPoints = allRegularPolygonPoints n p r + (screenPoint:ps) = map roundPoint polygonPoints + lines = [CT.LineTo screenPoint' | screenPoint' <- (ps ++ [screenPoint])] + toScreenPathParts (Line {point1=p1, point2=p2}) + = Just ([CT.LineTo p2'], p1') + where + p1' = roundPoint p1 + p2' = roundPoint p2 + + toScreenPathParts (MultiLine {points=points}) + | (length points) > 0 = Just (lines ++ [CT.MoveTo p1'], p1') + | otherwise = Nothing + where + (p1':otherPoints') = map roundPoint points + lines = [CT.LineTo p' | p' <- otherPoints'] + + toScreenPathParts pol@(Polygon {points=points}) + | (length points) > 0 = Just (lines ++ [CT.ClosePath], p1') + | otherwise = Nothing + where + allPoints = allScreenPolygonPoints pol + (p1':otherPoints') = map roundPoint allPoints + lines = [CT.LineTo p' | p' <- otherPoints'] + + +toCanvasPathFill :: Shape -> CT.PathFill +toCanvasPathFill shape + | hasCanvasPathFill shape = CT.PathFill (CT.CanvasColor screenFillColor) + | otherwise = CT.NoPathFill + where + fillColor_ = fillColor shape + screenFillColor = roundColor fillColor_ + + +hasCanvasPathFill :: Shape -> Bool +hasCanvasPathFill (Rectangle {}) + = True +hasCanvasPathFill (Circle {}) + = True +hasCanvasPathFill (RegularPolygon {}) + = True +hasCanvasPathFill (Polygon {}) + = True +hasCanvasPathFill _ + = False + + +allScreenPolygonPoints :: Shape -> [Point] +allScreenPolygonPoints (Polygon {points=points}) + | (length points) >= 2 = points ++ [firstP] + | otherwise = points + where + firstP = head points + lastP = last points diff --git a/src/Eventloop/Module/BasicShapes/Types.hs b/src/Eventloop/Module/BasicShapes/Types.hs --- a/src/Eventloop/Module/BasicShapes/Types.hs +++ b/src/Eventloop/Module/BasicShapes/Types.hs @@ -1,123 +1,120 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} -module Eventloop.Module.BasicShapes.Types - ( module Eventloop.Module.BasicShapes.Types - , CanvasId - , Alignment(..) - ) where - -import Eventloop.Module.Websocket.Canvas.Types (CanvasId, Alignment(..)) -import Eventloop.Utility.Vectors - -import GHC.Generics (Generic) -import Control.DeepSeq - - -type GraphicalNumeric = Float -type Position = Point - -type Width = GraphicalNumeric -type Height = GraphicalNumeric -type Dimensions = (Width, Height) - -type Radius = GraphicalNumeric - -type Red = GraphicalNumeric -type Green = GraphicalNumeric -type Blue = GraphicalNumeric -type Alpha = GraphicalNumeric -type Color = (Red, Green, Blue, Alpha) -type FillColor = Color -type StrokeColor = Color - -type FillThickness = GraphicalNumeric -type StrokeLineThickness = GraphicalNumeric - -type UpperLeft = Point -type UpperRight = Point -type LowerLeft = Point -type LowerRight = Point - -type NumberOfPoints = Int - -type FontFamily = [Char] -type FontSize = GraphicalNumeric - - -data BasicShapesOut = DrawShapes CanvasId [Shape] - deriving (Show, Eq, Generic, NFData) - -data Shape = CompositeShape { shapes :: [Shape] - , positionM :: Maybe Position - , rotationM :: Maybe Rotation - } -- ^Should contain atleast 1 shape. Rotation before Position - | Rectangle { position :: Position - , dimensions :: Dimensions - , fillColor :: FillColor - , strokeLineThickness :: StrokeLineThickness - , strokeColor :: StrokeColor - , rotationM :: Maybe Rotation - } -- ^| Position is upperleftcorner. Position is the corner closes to origin. Visually in canvas, this is top left. In a Cartesian coördinate system, this is bottom left. - | Circle { position :: Position - , radius :: Radius - , fillColor :: FillColor - , strokeLineThickness :: StrokeLineThickness - , strokeColor :: StrokeColor - , rotationM :: Maybe Rotation - } -- ^| Position is center - | RegularPolygon { position :: Position - , numberOfPoints :: NumberOfPoints - , radius :: Radius - , fillColor :: FillColor - , strokeLineThickness :: StrokeLineThickness - , strokeColor :: StrokeColor - , rotationM :: Maybe Rotation - } -- ^The first point of the regular polygon, always starts in the direction from the x-axis.(Towards x-infinity). Position is the the centre of the regular polygon - | Text { text :: [Char] - , fontFamily :: FontFamily - , fontSize :: FontSize - , position :: Position - , alignment :: Alignment - , fillColor :: FillColor - , strokeLineThickness :: StrokeLineThickness - , strokeColor :: StrokeColor - , rotationM :: Maybe Rotation - } - | Line { point1 :: Point - , point2 :: Point - , strokeLineThickness :: StrokeLineThickness - , strokeColor :: StrokeColor - , rotationM :: Maybe Rotation - } - | MultiLine { points :: [Point] -- ^| Can contain any number of points - , strokeLineThickness :: StrokeLineThickness - , strokeColor :: StrokeColor - , rotationM :: Maybe Rotation - } - | FilledMultiLine { points :: [Point] - , fillWidth :: FillThickness - , fillColor :: FillColor - , strokeLineThickness :: StrokeLineThickness - , strokeColor :: StrokeColor - , rotationM :: Maybe Rotation - } - | Polygon { points :: [Point] -- ^| Closes shape automatically with fill. Do not forget that the fill encloses the entire path. This means that half of the stroke is overwritten by the fill. - , fillColor :: FillColor - , strokeLineThickness :: StrokeLineThickness - , strokeColor :: StrokeColor - , rotationM :: Maybe Rotation - } - deriving (Show, Eq, Generic, NFData) - - -data Rotation = Rotation RotatePoint Angle -- ^| Rotation is around a point on the canvas. May be the centre of the boundingbox (enclosing rectangle) or an arbitrary point. Angle is in degrees and counter-clockwise in the coördinate system(from the x-axis to the y-axis) and visually on canvas clock-wise. - deriving (Show, Eq, Generic, NFData) - -data RotatePoint = AroundCenter - | AroundPoint Point - deriving (Show, Eq, Generic, NFData) - -data BoundingBox = BoundingBox LowerLeft UpperLeft UpperRight LowerRight -- ^| The point indications are from the perspective of a regular Cartesian coördinate system. - deriving (Show, Eq) - - - +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +module Eventloop.Module.BasicShapes.Types + ( module Eventloop.Module.BasicShapes.Types + , CanvasId + , Alignment(..) + ) where + +import Eventloop.Module.Websocket.Canvas.Types (CanvasId, Alignment(..)) +import Eventloop.Utility.Vectors + +import GHC.Generics (Generic) +import Control.DeepSeq + + +type GraphicalNumeric = Float +type Position = Point + +type Width = GraphicalNumeric +type Height = GraphicalNumeric +type Dimensions = (Width, Height) + +type Radius = GraphicalNumeric + +type Red = GraphicalNumeric +type Green = GraphicalNumeric +type Blue = GraphicalNumeric +type Alpha = GraphicalNumeric +type Color = (Red, Green, Blue, Alpha) +type FillColor = Color +type StrokeColor = Color + +type FillThickness = GraphicalNumeric +type StrokeLineThickness = GraphicalNumeric + +type UpperLeft = Point +type UpperRight = Point +type LowerLeft = Point +type LowerRight = Point + +type NumberOfPoints = Int + +type FontFamily = [Char] +type FontSize = GraphicalNumeric + + +data BasicShapesOut = DrawShapes CanvasId [Shape] + deriving (Show, Eq, Generic, NFData) + +data Shape = CompositeShape { shapes :: [Shape] + , positionM :: Maybe Position + , rotationM :: Maybe Rotation + } -- ^Should contain atleast 1 shape. Rotation before Position + | Rectangle { position :: Position + , dimensions :: Dimensions + , fillColor :: FillColor + , strokeLineThickness :: StrokeLineThickness + , strokeColor :: StrokeColor + , rotationM :: Maybe Rotation + } -- ^| Position is upperleftcorner. Position is the corner closes to origin. Visually in canvas, this is top left. In a Cartesian coördinate system, this is bottom left. + | Circle { position :: Position + , radius :: Radius + , fillColor :: FillColor + , strokeLineThickness :: StrokeLineThickness + , strokeColor :: StrokeColor + , rotationM :: Maybe Rotation + } -- ^| Position is center + | RegularPolygon { position :: Position + , numberOfPoints :: NumberOfPoints + , radius :: Radius + , fillColor :: FillColor + , strokeLineThickness :: StrokeLineThickness + , strokeColor :: StrokeColor + , rotationM :: Maybe Rotation + } -- ^The first point of the regular polygon, always starts in the direction from the x-axis.(Towards x-infinity). Position is the the centre of the regular polygon + | Text { text :: [Char] + , fontFamily :: FontFamily + , fontSize :: FontSize + , position :: Position + , alignment :: Alignment + , fillColor :: FillColor + , strokeLineThickness :: StrokeLineThickness + , strokeColor :: StrokeColor + , rotationM :: Maybe Rotation + } + | Line { point1 :: Point + , point2 :: Point + , strokeLineThickness :: StrokeLineThickness + , strokeColor :: StrokeColor + , rotationM :: Maybe Rotation + } + | MultiLine { points :: [Point] -- ^| Can contain any number of points + , strokeLineThickness :: StrokeLineThickness + , strokeColor :: StrokeColor + , rotationM :: Maybe Rotation + } + | FilledMultiLine { points :: [Point] + , fillWidth :: FillThickness + , fillColor :: FillColor + , strokeLineThickness :: StrokeLineThickness + , strokeColor :: StrokeColor + , rotationM :: Maybe Rotation + } + | Polygon { points :: [Point] -- ^| Closes shape automatically with fill. Do not forget that the fill encloses the entire path. This means that half of the stroke is overwritten by the fill. + , fillColor :: FillColor + , strokeLineThickness :: StrokeLineThickness + , strokeColor :: StrokeColor + , rotationM :: Maybe Rotation + } + deriving (Show, Eq, Generic, NFData) + + +data Rotation = Rotation RotatePoint Angle -- ^| Rotation is around a point on the canvas. May be the centre of the boundingbox (enclosing rectangle) or an arbitrary point. Angle is in degrees and counter-clockwise in the coördinate system(from the x-axis to the y-axis) and visually on canvas clock-wise. + deriving (Show, Eq, Generic, NFData) + +data RotatePoint = AroundCenter + | AroundPoint Point + deriving (Show, Eq, Generic, NFData) + +data BoundingBox = BoundingBox LowerLeft UpperLeft UpperRight LowerRight -- ^| The point indications are from the perspective of a regular Cartesian coördinate system. + deriving (Show, Eq) diff --git a/src/Eventloop/Module/DrawTrees.hs b/src/Eventloop/Module/DrawTrees.hs --- a/src/Eventloop/Module/DrawTrees.hs +++ b/src/Eventloop/Module/DrawTrees.hs @@ -1,9 +1,9 @@ -module Eventloop.Module.DrawTrees - ( module Eventloop.Module.DrawTrees.Types - , module Eventloop.Module.DrawTrees.DrawTrees - , module Eventloop.Module.DrawTrees.RoseTreeGeneric - ) where - -import Eventloop.Module.DrawTrees.Types -import Eventloop.Module.DrawTrees.DrawTrees +module Eventloop.Module.DrawTrees + ( module Eventloop.Module.DrawTrees.Types + , module Eventloop.Module.DrawTrees.DrawTrees + , module Eventloop.Module.DrawTrees.RoseTreeGeneric + ) where + +import Eventloop.Module.DrawTrees.Types +import Eventloop.Module.DrawTrees.DrawTrees import Eventloop.Module.DrawTrees.RoseTreeGeneric diff --git a/src/Eventloop/Module/DrawTrees/DrawTrees.hs b/src/Eventloop/Module/DrawTrees/DrawTrees.hs --- a/src/Eventloop/Module/DrawTrees/DrawTrees.hs +++ b/src/Eventloop/Module/DrawTrees/DrawTrees.hs @@ -1,145 +1,145 @@ -module Eventloop.Module.DrawTrees.DrawTrees - ( setupDrawTreesModuleConfiguration - , drawTreesModuleIdentifier - , drawTreesPostProcessor - , showGeneralTreeList - , rbExampleTree - , roseExampleTree - ) where - -import Eventloop.Module.DrawTrees.Types -import Eventloop.Utility.Trees.LayoutTree -import Eventloop.Utility.Trees.GeneralTree -import Eventloop.Module.BasicShapes.Types -import Eventloop.Types.Common -import Eventloop.Types.Events -import Eventloop.Types.System - - -setupDrawTreesModuleConfiguration :: EventloopSetupModuleConfiguration -setupDrawTreesModuleConfiguration = ( EventloopSetupModuleConfiguration - drawTreesModuleIdentifier - Nothing - Nothing - Nothing - (Just drawTreesPostProcessor) - Nothing - Nothing - ) - -drawTreesModuleIdentifier :: EventloopModuleIdentifier -drawTreesModuleIdentifier = "parseTree" - - -drawTreesPostProcessor :: PostProcessor -drawTreesPostProcessor sharedConst sharedIOT ioConst ioStateT (OutDrawTrees (DrawTrees canvasId trees)) - = return [OutBasicShapes $ DrawShapes canvasId [shapeTrees]] - where - (shapeTrees, _, _) = showGeneralTreeList trees - -drawTreesPostProcessor sharedConst sharedIOT ioConst ioStateT out - = return [out] - - -maxWidth :: Int -maxWidth = 1024 - -showGeneralTreeList :: [GeneralTree] -> (Shape, RightOffset, BottomOffset) -showGeneralTreeList list = showGeneralTreeList' 0 0 0 0 list - -showGeneralTreeList' :: LeftOffset -> TopOffset -> Float -> Int -> [GeneralTree] -> (Shape, RightOffset, BottomOffset) -showGeneralTreeList' _ _ _ _ [] = (CompositeShape [] Nothing Nothing, 0, 0) -showGeneralTreeList' left top maxBottom i (x:xs) | right <= 1024 || width > 1024 = (CompositeShape (treeShapes ++ gtrees) Nothing Nothing, rightOff', botOff') - | otherwise = showGeneralTreeList' 0 maxBottom' maxBottom' i (x:xs) - where - maxBottom' = max maxBottom bottom - (CompositeShape treeShapes _ _, right, bottom) = showGeneralTree left top i x - (CompositeShape gtrees _ _, rightOff, botOff) = showGeneralTreeList' (right + marginBetweenTrees) top maxBottom' i' xs - i' = i + 1 - width = right - left - rightOff' = max rightOff right - botOff' = max bottom botOff - - -showGeneralTree :: LeftOffset -> TopOffset -> Int -> GeneralTree -> (Shape, RightOffset, BottomOffset) -showGeneralTree left top i tree = (CompositeShape [treeIndexShape, treeShape] Nothing Nothing, right, bottom) - where - (ltree, right, bottom) = layoutGeneralTree left' top tree - treeShape = printTree ltree - (treeIndexShape, left') = treeIndex i (left, top) - -instance GeneralizeTree RBTree where - generalizeTree (RBNode col _ []) = GeneralTreeBox content [] - where - content = [GeneralNode (nodeColorToFillColor col) 5] - - generalizeTree (RBNode col str children) = GeneralTreeBox content children'WithLines - where - content = [GeneralNode (nodeColorToFillColor col) 20, GeneralNodeText (0,0,0, 255) str] - children' = map generalizeTree children - line = GeneralLine (0,0,0, 255) - children'WithLines = zip (repeat line) children' - -nodeColorToFillColor :: NodeColor -> FillColor -nodeColorToFillColor NodeRed = (255, 0, 0, 255) -nodeColorToFillColor NodeBlack = (0, 0, 0, 255) -nodeColorToFillColor NodeGrey = (125, 125, 125, 255) - - -instance GeneralizeTree RoseTree where - generalizeTree (RoseNode str children) = GeneralTreeBox content children'WithLines - where - content = [GeneralNodeText (0,0,0, 255) str] - children'WithLines = zip (repeat line) (map generalizeTree children) - line = GeneralLine (0,0,0, 255) - -rbExampleTree = RBNode NodeBlack "12" - [ RBNode NodeRed "10" - [ RBNode NodeBlack "9" - [ RBNode NodeBlack "" [], - RBNode NodeBlack "" [] - ], - RBNode NodeBlack "11" - [RBNode NodeBlack "" [], - RBNode NodeBlack "" [] - ] - ], - RBNode NodeRed "13" - [RBNode NodeBlack "36" [], - RBNode NodeBlack "42" - [RBNode NodeRed "36" - [RBNode NodeBlack "" [], - RBNode NodeBlack "" [] - ], - RBNode NodeBlack "" [] - ] - ] - ] - -roseExampleTree = RoseNode "z" - [ RoseNode "aaa" - [ RoseNode "bbb" - [ RoseNode "ccc" [], - RoseNode "ddd" [] - ], - RoseNode "" - [RoseNode "fff" [], - RoseNode "ggg" [], - RoseNode "hhh" [] - ], - RoseNode "iii" - [RoseNode "" [] - ] - ], - RoseNode "kkk" - [RoseNode "lll" [], - RoseNode "mmm" - [RoseNode "nnn" - [RoseNode "q" [], - RoseNode "r" [] - ], - RoseNode "ooo" [], - RoseNode "ppp" [] - ] - ] +module Eventloop.Module.DrawTrees.DrawTrees + ( setupDrawTreesModuleConfiguration + , drawTreesModuleIdentifier + , drawTreesPostProcessor + , showGeneralTreeList + , rbExampleTree + , roseExampleTree + ) where + +import Eventloop.Module.DrawTrees.Types +import Eventloop.Utility.Trees.LayoutTree +import Eventloop.Utility.Trees.GeneralTree +import Eventloop.Module.BasicShapes.Types +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System + + +setupDrawTreesModuleConfiguration :: EventloopSetupModuleConfiguration +setupDrawTreesModuleConfiguration = ( EventloopSetupModuleConfiguration + drawTreesModuleIdentifier + Nothing + Nothing + Nothing + (Just drawTreesPostProcessor) + Nothing + Nothing + ) + +drawTreesModuleIdentifier :: EventloopModuleIdentifier +drawTreesModuleIdentifier = "parseTree" + + +drawTreesPostProcessor :: PostProcessor +drawTreesPostProcessor sharedConst sharedIOT ioConst ioStateT (OutDrawTrees (DrawTrees canvasId trees)) + = return [OutBasicShapes $ DrawShapes canvasId [shapeTrees]] + where + (shapeTrees, _, _) = showGeneralTreeList trees + +drawTreesPostProcessor sharedConst sharedIOT ioConst ioStateT out + = return [out] + + +maxWidth :: Int +maxWidth = 1024 + +showGeneralTreeList :: [GeneralTree] -> (Shape, RightOffset, BottomOffset) +showGeneralTreeList list = showGeneralTreeList' 0 0 0 0 list + +showGeneralTreeList' :: LeftOffset -> TopOffset -> Float -> Int -> [GeneralTree] -> (Shape, RightOffset, BottomOffset) +showGeneralTreeList' _ _ _ _ [] = (CompositeShape [] Nothing Nothing, 0, 0) +showGeneralTreeList' left top maxBottom i (x:xs) | right <= 1024 || width > 1024 = (CompositeShape (treeShapes ++ gtrees) Nothing Nothing, rightOff', botOff') + | otherwise = showGeneralTreeList' 0 maxBottom' maxBottom' i (x:xs) + where + maxBottom' = max maxBottom bottom + (CompositeShape treeShapes _ _, right, bottom) = showGeneralTree left top i x + (CompositeShape gtrees _ _, rightOff, botOff) = showGeneralTreeList' (right + marginBetweenTrees) top maxBottom' i' xs + i' = i + 1 + width = right - left + rightOff' = max rightOff right + botOff' = max bottom botOff + + +showGeneralTree :: LeftOffset -> TopOffset -> Int -> GeneralTree -> (Shape, RightOffset, BottomOffset) +showGeneralTree left top i tree = (CompositeShape [treeIndexShape, treeShape] Nothing Nothing, right, bottom) + where + (ltree, right, bottom) = layoutGeneralTree left' top tree + treeShape = printTree ltree + (treeIndexShape, left') = treeIndex i (left, top) + +instance GeneralizeTree RBTree where + generalizeTree (RBNode col _ []) = GeneralTreeBox content [] + where + content = [GeneralNode (nodeColorToFillColor col) 5] + + generalizeTree (RBNode col str children) = GeneralTreeBox content children'WithLines + where + content = [GeneralNode (nodeColorToFillColor col) 20, GeneralNodeText (0,0,0, 255) str] + children' = map generalizeTree children + line = GeneralLine (0,0,0, 255) + children'WithLines = zip (repeat line) children' + +nodeColorToFillColor :: NodeColor -> FillColor +nodeColorToFillColor NodeRed = (255, 0, 0, 255) +nodeColorToFillColor NodeBlack = (0, 0, 0, 255) +nodeColorToFillColor NodeGrey = (125, 125, 125, 255) + + +instance GeneralizeTree RoseTree where + generalizeTree (RoseNode str children) = GeneralTreeBox content children'WithLines + where + content = [GeneralNodeText (0,0,0, 255) str] + children'WithLines = zip (repeat line) (map generalizeTree children) + line = GeneralLine (0,0,0, 255) + +rbExampleTree = RBNode NodeBlack "12" + [ RBNode NodeRed "10" + [ RBNode NodeBlack "9" + [ RBNode NodeBlack "" [], + RBNode NodeBlack "" [] + ], + RBNode NodeBlack "11" + [RBNode NodeBlack "" [], + RBNode NodeBlack "" [] + ] + ], + RBNode NodeRed "13" + [RBNode NodeBlack "36" [], + RBNode NodeBlack "42" + [RBNode NodeRed "36" + [RBNode NodeBlack "" [], + RBNode NodeBlack "" [] + ], + RBNode NodeBlack "" [] + ] + ] + ] + +roseExampleTree = RoseNode "z" + [ RoseNode "aaa" + [ RoseNode "bbb" + [ RoseNode "ccc" [], + RoseNode "ddd" [] + ], + RoseNode "" + [RoseNode "fff" [], + RoseNode "ggg" [], + RoseNode "hhh" [] + ], + RoseNode "iii" + [RoseNode "" [] + ] + ], + RoseNode "kkk" + [RoseNode "lll" [], + RoseNode "mmm" + [RoseNode "nnn" + [RoseNode "q" [], + RoseNode "r" [] + ], + RoseNode "ooo" [], + RoseNode "ppp" [] + ] + ] ] diff --git a/src/Eventloop/Module/DrawTrees/RoseTreeGeneric.hs b/src/Eventloop/Module/DrawTrees/RoseTreeGeneric.hs --- a/src/Eventloop/Module/DrawTrees/RoseTreeGeneric.hs +++ b/src/Eventloop/Module/DrawTrees/RoseTreeGeneric.hs @@ -1,92 +1,92 @@ -{-# LANGUAGE TypeOperators, DefaultSignatures, FlexibleContexts, DeriveGeneric, - DeriveAnyClass, TypeSynonymInstances, FlexibleInstances, - ScopedTypeVariables, StandaloneDeriving #-} -module Eventloop.Module.DrawTrees.RoseTreeGeneric - ( ToRoseTree (..) - , genericToRoseTree - ) where - -import GHC.Generics -import Eventloop.Module.DrawTrees.Types - -emptyNode = RoseNode "" [] - -cleanTree = concatMap mergeProduct - . filter (/= emptyNode) - -mergeProduct (RoseNode "" xs) = xs -mergeProduct r = [r] - --- | Convert to a 'RoseTree' -class ToRoseTree a where - -- | Convert to a 'RoseTree' - toRoseTree :: a -> RoseTree - default toRoseTree :: (Generic a, GToRoseTree (Rep a)) => a -> RoseTree - toRoseTree = genericToRoseTree - --- | A version of 'toRoseTree' that works for any data type that has an --- instance for 'Generic' -genericToRoseTree :: (Generic a, GToRoseTree (Rep a)) => a -> RoseTree -genericToRoseTree = gtoRoseTree . from - -class GToRoseTree f where - gtoRoseTree :: f a -> RoseTree - --- constants -instance ToRoseTree c => GToRoseTree (K1 i c) where - gtoRoseTree = toRoseTree . unK1 - --- meta -instance {-# OVERLAPPABLE #-} GToRoseTree f => GToRoseTree (M1 i c f) where - gtoRoseTree = gtoRoseTree . unM1 - --- constructors -instance (Constructor c, GToRoseTree f) => GToRoseTree (C1 c f) where - gtoRoseTree = RoseNode (conName (undefined :: t c f p)) - . cleanTree - . (:[]) - . gtoRoseTree - . unM1 - --- unit -instance GToRoseTree U1 where - gtoRoseTree U1 = emptyNode - --- void -instance GToRoseTree V1 where - gtoRoseTree _ = emptyNode - --- product -instance (GToRoseTree f, GToRoseTree g) => GToRoseTree (f :*: g) where - gtoRoseTree (f1 :*: g1) = RoseNode "" (cleanTree [gtoRoseTree f1, gtoRoseTree g1]) - --- sum -instance (GToRoseTree f, GToRoseTree g) => GToRoseTree (f :+: g) where - gtoRoseTree (L1 f1) = gtoRoseTree f1 - gtoRoseTree (R1 g1) = gtoRoseTree g1 - -instance ToRoseTree Int where - toRoseTree i = RoseNode (show i) [] - -instance ToRoseTree Integer where - toRoseTree i = RoseNode (show i) [] - -instance ToRoseTree Float where - toRoseTree f = RoseNode (show f) [] - -instance ToRoseTree Double where - toRoseTree d = RoseNode (show d) [] - -instance ToRoseTree Char where - toRoseTree c = RoseNode [c] [] - -deriving instance ToRoseTree Bool -deriving instance ToRoseTree Ordering -deriving instance (ToRoseTree l, ToRoseTree r) => ToRoseTree (Either l r) -deriving instance ToRoseTree a => ToRoseTree (Maybe a) - -instance {-# OVERLAPPABLE #-} ToRoseTree a => ToRoseTree [a] where - toRoseTree = RoseNode "" . cleanTree . map toRoseTree - -instance ToRoseTree String where - toRoseTree s = RoseNode s [] +{-# LANGUAGE TypeOperators, DefaultSignatures, FlexibleContexts, DeriveGeneric, + DeriveAnyClass, TypeSynonymInstances, FlexibleInstances, + ScopedTypeVariables, StandaloneDeriving #-} +module Eventloop.Module.DrawTrees.RoseTreeGeneric + ( ToRoseTree (..) + , genericToRoseTree + ) where + +import GHC.Generics +import Eventloop.Module.DrawTrees.Types + +emptyNode = RoseNode "" [] + +cleanTree = concatMap mergeProduct + . filter (/= emptyNode) + +mergeProduct (RoseNode "" xs) = xs +mergeProduct r = [r] + +-- | Convert to a 'RoseTree' +class ToRoseTree a where + -- | Convert to a 'RoseTree' + toRoseTree :: a -> RoseTree + default toRoseTree :: (Generic a, GToRoseTree (Rep a)) => a -> RoseTree + toRoseTree = genericToRoseTree + +-- | A version of 'toRoseTree' that works for any data type that has an +-- instance for 'Generic' +genericToRoseTree :: (Generic a, GToRoseTree (Rep a)) => a -> RoseTree +genericToRoseTree = gtoRoseTree . from + +class GToRoseTree f where + gtoRoseTree :: f a -> RoseTree + +-- constants +instance ToRoseTree c => GToRoseTree (K1 i c) where + gtoRoseTree = toRoseTree . unK1 + +-- meta +instance {-# OVERLAPPABLE #-} GToRoseTree f => GToRoseTree (M1 i c f) where + gtoRoseTree = gtoRoseTree . unM1 + +-- constructors +instance (Constructor c, GToRoseTree f) => GToRoseTree (C1 c f) where + gtoRoseTree = RoseNode (conName (undefined :: t c f p)) + . cleanTree + . (:[]) + . gtoRoseTree + . unM1 + +-- unit +instance GToRoseTree U1 where + gtoRoseTree U1 = emptyNode + +-- void +instance GToRoseTree V1 where + gtoRoseTree _ = emptyNode + +-- product +instance (GToRoseTree f, GToRoseTree g) => GToRoseTree (f :*: g) where + gtoRoseTree (f1 :*: g1) = RoseNode "" (cleanTree [gtoRoseTree f1, gtoRoseTree g1]) + +-- sum +instance (GToRoseTree f, GToRoseTree g) => GToRoseTree (f :+: g) where + gtoRoseTree (L1 f1) = gtoRoseTree f1 + gtoRoseTree (R1 g1) = gtoRoseTree g1 + +instance ToRoseTree Int where + toRoseTree i = RoseNode (show i) [] + +instance ToRoseTree Integer where + toRoseTree i = RoseNode (show i) [] + +instance ToRoseTree Float where + toRoseTree f = RoseNode (show f) [] + +instance ToRoseTree Double where + toRoseTree d = RoseNode (show d) [] + +instance ToRoseTree Char where + toRoseTree c = RoseNode [c] [] + +deriving instance ToRoseTree Bool +deriving instance ToRoseTree Ordering +deriving instance (ToRoseTree l, ToRoseTree r) => ToRoseTree (Either l r) +deriving instance ToRoseTree a => ToRoseTree (Maybe a) + +instance {-# OVERLAPPABLE #-} ToRoseTree a => ToRoseTree [a] where + toRoseTree = RoseNode "" . cleanTree . map toRoseTree + +instance ToRoseTree String where + toRoseTree s = RoseNode s [] diff --git a/src/Eventloop/Module/DrawTrees/Types.hs b/src/Eventloop/Module/DrawTrees/Types.hs --- a/src/Eventloop/Module/DrawTrees/Types.hs +++ b/src/Eventloop/Module/DrawTrees/Types.hs @@ -1,30 +1,25 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} -module Eventloop.Module.DrawTrees.Types where - -import Eventloop.Module.Websocket.Canvas.Types -import Eventloop.Utility.Trees.GeneralTree - -import GHC.Generics (Generic) -import Control.DeepSeq - - -data DrawTreesOut = DrawTrees CanvasId [GeneralTree] - deriving (Show, Eq, Generic, NFData) - - -data NodeColor = NodeRed - | NodeBlack - | NodeGrey - deriving (Show, Eq, Generic, NFData) - -data RBTree = RBNode NodeColor String [RBTree] - deriving (Show, Eq) - - -data RoseTree = RoseNode String [RoseTree] - deriving (Show, Eq) - - - - - +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +module Eventloop.Module.DrawTrees.Types where + +import Eventloop.Module.Websocket.Canvas.Types +import Eventloop.Utility.Trees.GeneralTree + +import GHC.Generics (Generic) +import Control.DeepSeq + + +data DrawTreesOut = DrawTrees CanvasId [GeneralTree] + deriving (Show, Eq, Generic, NFData) + + +data NodeColor = NodeRed + | NodeBlack + | NodeGrey + deriving (Show, Eq, Generic, NFData) + +data RBTree = RBNode NodeColor String [RBTree] + deriving (Show, Eq) + + +data RoseTree = RoseNode String [RoseTree] + deriving (Show, Eq) diff --git a/src/Eventloop/Module/File.hs b/src/Eventloop/Module/File.hs --- a/src/Eventloop/Module/File.hs +++ b/src/Eventloop/Module/File.hs @@ -1,7 +1,7 @@ -module Eventloop.Module.File - ( module Eventloop.Module.File.File - , module Eventloop.Module.File.Types - ) where - -import Eventloop.Module.File.File +module Eventloop.Module.File + ( module Eventloop.Module.File.File + , module Eventloop.Module.File.Types + ) where + +import Eventloop.Module.File.File import Eventloop.Module.File.Types diff --git a/src/Eventloop/Module/File/File.hs b/src/Eventloop/Module/File/File.hs --- a/src/Eventloop/Module/File/File.hs +++ b/src/Eventloop/Module/File/File.hs @@ -1,185 +1,185 @@ -module Eventloop.Module.File.File - ( setupFileModuleConfiguration - , fileModuleIdentifier - , fileEventRetriever - , fileEventSender - , fileTeardown - ) where - -import Data.Maybe -import Control.Concurrent.Datastructures.BlockingConcurrentQueue -import Control.Concurrent.STM -import System.IO - -import Eventloop.Module.File.Types -import Eventloop.Types.Common -import Eventloop.Types.Events -import Eventloop.Types.System - - -setupFileModuleConfiguration :: EventloopSetupModuleConfiguration -setupFileModuleConfiguration = ( EventloopSetupModuleConfiguration - fileModuleIdentifier - (Just fileInitializer) - (Just fileEventRetriever) - Nothing - Nothing - (Just fileEventSender) - (Just fileTeardown) - ) - -fileModuleIdentifier :: EventloopModuleIdentifier -fileModuleIdentifier = "file" - - -fileInitializer :: Initializer -fileInitializer sharedConst sharedIO - = do - inQueue <- createBlockingConcurrentQueue - return (sharedConst, sharedIO, FileConstants inQueue, FileState []) - - -fileEventRetriever :: EventRetriever -fileEventRetriever sharedConst sharedIOT ioConst ioStateT - = do - fileInEvents <- takeAllFromBlockingConcurrentQueue queue - return (map InFile fileInEvents) - where - queue = fileInQueue ioConst - - -fileEventSender :: EventSender -fileEventSender _ _ _ _ Stop = return () -fileEventSender sharedConst sharedIOT ioConst ioStateT (OutFile out) - = do - (FileState openFiles) <- readTVarIO ioStateT - (openFiles', inEvents) <- fileEventSender' openFiles out - atomically $ writeTVar ioStateT (FileState openFiles') - putAllInBlockingConcurrentQueue inQueue inEvents - where - inQueue = fileInQueue ioConst - - -fileEventSender' :: [OpenFile] -> FileOut -> IO ([OpenFile], [FileIn]) -fileEventSender' openFiles (OpenFile filepath iomode) - = do - handle <- openFile filepath iomode - let - fileOpenedEvent = FileOpened filepath True - openFiles' = openFiles ++ [(filepath, handle, iomode)] - return (openFiles', [fileOpenedEvent]) - -fileEventSender' openFiles (CloseFile filepath) - | openFileM == Nothing = return ([], []) - | otherwise = do - hClose handle - return (openFiles', [closedFileEvent]) - where - openFileM = retrieveOpenedFile openFiles filepath - (fp, handle, iomode) = fromJust openFileM - openFiles' = removeOpenedFile openFiles filepath - closedFileEvent = FileClosed filepath True - -fileEventSender' openFiles (RetrieveContents filepath) - = doReadAction filepath openFiles RetrievedContents retrieveContents - -fileEventSender' openFiles (RetrieveLine filepath) - = doReadAction filepath openFiles RetrievedLine hGetLine - -fileEventSender' openFiles (RetrieveChar filepath) - = doReadAction filepath openFiles RetrievedChar hGetChar - -fileEventSender' openFiles (IfEOF filepath) - = getFromFile filepath openFiles fileIsOpened IsEOF hIsEOF - -fileEventSender' openFiles (WriteTo filepath contents) - | fileIsWriteable openFiles filepath = do - hPutStr handle contents - return (openFiles, [WroteTo filepath True]) - | otherwise = return (openFiles, []) - where - Just (fp, handle, iomode) = retrieveOpenedFile openFiles filepath - - -doReadAction :: FilePath - -> [OpenFile] - -> (FilePath -> a -> FileIn) - -> (Handle -> IO a) - -> IO ([OpenFile], [FileIn]) -doReadAction filepath openFiles inEvent readAction - = getFromFile filepath openFiles fileIsReadable inEvent readAction - - -getFromFile :: FilePath -> - [OpenFile] -> - ([OpenFile] -> FilePath -> Bool) -> {- Check if the action should be done -} - (FilePath -> a -> FileIn) -> {- The inEvent Constructor -} - (Handle -> IO a) -> {- The action which will grant a result -} - IO ([OpenFile], [FileIn]) -getFromFile filepath openFiles fileCheck inEvent action - | fileCheck openFiles filepath = do - result <- action handle - return (openFiles, [inEvent filepath result]) - | otherwise = return (openFiles, []) - where - Just (fp, handle, iomode) = retrieveOpenedFile openFiles filepath - - -fileIsReadable :: [OpenFile] -> FilePath -> Bool -fileIsReadable opened filepath | fileIsOpened opened filepath = iomode == ReadMode || iomode == ReadWriteMode - | otherwise = False - where - Just (fp, handle, iomode) = retrieveOpenedFile opened filepath - - -fileIsWriteable :: [OpenFile] -> FilePath -> Bool -fileIsWriteable opened filepath | fileIsOpened opened filepath = iomode == WriteMode || iomode == ReadWriteMode || iomode == AppendMode - | otherwise = False - where - Just (fp, handle, iomode) = retrieveOpenedFile opened filepath - - -fileIsOpened :: [OpenFile] -> FilePath -> Bool -fileIsOpened opened filepath = not (openedFileM == Nothing) - where - openedFileM = retrieveOpenedFile opened filepath - - -retrieveContents :: Handle -> IO [[Char]] -retrieveContents handle = do - line <- hGetLine handle - isEOF <- hIsEOF handle - if isEOF - then - return [line] - else do - lines <- retrieveContents handle - return (line:lines) - - -retrieveOpenedFile :: [OpenFile] -> FilePath -> Maybe OpenFile -retrieveOpenedFile [] _ = Nothing -retrieveOpenedFile (openfile@(fp, h, iom):ofs) ufp | ufp == fp = Just openfile - | otherwise = retrieveOpenedFile ofs ufp - - -removeOpenedFile :: [OpenFile] -> FilePath -> [OpenFile] -removeOpenedFile [] _ = [] -removeOpenedFile (openfile@(fp, h, iom):ofs) ufp | ufp == fp = ofs - | otherwise = openfile:(removeOpenedFile ofs ufp) - - -fileTeardown :: Teardown -fileTeardown sharedConst sharedIO ioConst ioState - = do - closeAllFiles handles - return (sharedIO) - where - handles = map (\(fp, h, iom) -> h) (opened ioState) - - -closeAllFiles :: [Handle] -> IO () -closeAllFiles [] = return () -closeAllFiles (h:hs) = do - hClose h +module Eventloop.Module.File.File + ( setupFileModuleConfiguration + , fileModuleIdentifier + , fileEventRetriever + , fileEventSender + , fileTeardown + ) where + +import Data.Maybe +import Control.Concurrent.Datastructures.BlockingConcurrentQueue +import Control.Concurrent.STM +import System.IO + +import Eventloop.Module.File.Types +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System + + +setupFileModuleConfiguration :: EventloopSetupModuleConfiguration +setupFileModuleConfiguration = ( EventloopSetupModuleConfiguration + fileModuleIdentifier + (Just fileInitializer) + (Just fileEventRetriever) + Nothing + Nothing + (Just fileEventSender) + (Just fileTeardown) + ) + +fileModuleIdentifier :: EventloopModuleIdentifier +fileModuleIdentifier = "file" + + +fileInitializer :: Initializer +fileInitializer sharedConst sharedIO + = do + inQueue <- createBlockingConcurrentQueue + return (sharedConst, sharedIO, FileConstants inQueue, FileState []) + + +fileEventRetriever :: EventRetriever +fileEventRetriever sharedConst sharedIOT ioConst ioStateT + = do + fileInEvents <- takeAllFromBlockingConcurrentQueue queue + return (map InFile fileInEvents) + where + queue = fileInQueue ioConst + + +fileEventSender :: EventSender +fileEventSender _ _ _ _ Stop = return () +fileEventSender sharedConst sharedIOT ioConst ioStateT (OutFile out) + = do + (FileState openFiles) <- readTVarIO ioStateT + (openFiles', inEvents) <- fileEventSender' openFiles out + atomically $ writeTVar ioStateT (FileState openFiles') + putAllInBlockingConcurrentQueue inQueue inEvents + where + inQueue = fileInQueue ioConst + + +fileEventSender' :: [OpenFile] -> FileOut -> IO ([OpenFile], [FileIn]) +fileEventSender' openFiles (OpenFile filepath iomode) + = do + handle <- openFile filepath iomode + let + fileOpenedEvent = FileOpened filepath True + openFiles' = openFiles ++ [(filepath, handle, iomode)] + return (openFiles', [fileOpenedEvent]) + +fileEventSender' openFiles (CloseFile filepath) + | openFileM == Nothing = return ([], []) + | otherwise = do + hClose handle + return (openFiles', [closedFileEvent]) + where + openFileM = retrieveOpenedFile openFiles filepath + (fp, handle, iomode) = fromJust openFileM + openFiles' = removeOpenedFile openFiles filepath + closedFileEvent = FileClosed filepath True + +fileEventSender' openFiles (RetrieveContents filepath) + = doReadAction filepath openFiles RetrievedContents retrieveContents + +fileEventSender' openFiles (RetrieveLine filepath) + = doReadAction filepath openFiles RetrievedLine hGetLine + +fileEventSender' openFiles (RetrieveChar filepath) + = doReadAction filepath openFiles RetrievedChar hGetChar + +fileEventSender' openFiles (IfEOF filepath) + = getFromFile filepath openFiles fileIsOpened IsEOF hIsEOF + +fileEventSender' openFiles (WriteTo filepath contents) + | fileIsWriteable openFiles filepath = do + hPutStr handle contents + return (openFiles, [WroteTo filepath True]) + | otherwise = return (openFiles, []) + where + Just (fp, handle, iomode) = retrieveOpenedFile openFiles filepath + + +doReadAction :: FilePath + -> [OpenFile] + -> (FilePath -> a -> FileIn) + -> (Handle -> IO a) + -> IO ([OpenFile], [FileIn]) +doReadAction filepath openFiles inEvent readAction + = getFromFile filepath openFiles fileIsReadable inEvent readAction + + +getFromFile :: FilePath -> + [OpenFile] -> + ([OpenFile] -> FilePath -> Bool) -> {- Check if the action should be done -} + (FilePath -> a -> FileIn) -> {- The inEvent Constructor -} + (Handle -> IO a) -> {- The action which will grant a result -} + IO ([OpenFile], [FileIn]) +getFromFile filepath openFiles fileCheck inEvent action + | fileCheck openFiles filepath = do + result <- action handle + return (openFiles, [inEvent filepath result]) + | otherwise = return (openFiles, []) + where + Just (fp, handle, iomode) = retrieveOpenedFile openFiles filepath + + +fileIsReadable :: [OpenFile] -> FilePath -> Bool +fileIsReadable opened filepath | fileIsOpened opened filepath = iomode == ReadMode || iomode == ReadWriteMode + | otherwise = False + where + Just (fp, handle, iomode) = retrieveOpenedFile opened filepath + + +fileIsWriteable :: [OpenFile] -> FilePath -> Bool +fileIsWriteable opened filepath | fileIsOpened opened filepath = iomode == WriteMode || iomode == ReadWriteMode || iomode == AppendMode + | otherwise = False + where + Just (fp, handle, iomode) = retrieveOpenedFile opened filepath + + +fileIsOpened :: [OpenFile] -> FilePath -> Bool +fileIsOpened opened filepath = not (openedFileM == Nothing) + where + openedFileM = retrieveOpenedFile opened filepath + + +retrieveContents :: Handle -> IO [[Char]] +retrieveContents handle = do + line <- hGetLine handle + isEOF <- hIsEOF handle + if isEOF + then + return [line] + else do + lines <- retrieveContents handle + return (line:lines) + + +retrieveOpenedFile :: [OpenFile] -> FilePath -> Maybe OpenFile +retrieveOpenedFile [] _ = Nothing +retrieveOpenedFile (openfile@(fp, h, iom):ofs) ufp | ufp == fp = Just openfile + | otherwise = retrieveOpenedFile ofs ufp + + +removeOpenedFile :: [OpenFile] -> FilePath -> [OpenFile] +removeOpenedFile [] _ = [] +removeOpenedFile (openfile@(fp, h, iom):ofs) ufp | ufp == fp = ofs + | otherwise = openfile:(removeOpenedFile ofs ufp) + + +fileTeardown :: Teardown +fileTeardown sharedConst sharedIO ioConst ioState + = do + closeAllFiles handles + return (sharedIO) + where + handles = map (\(fp, h, iom) -> h) (opened ioState) + + +closeAllFiles :: [Handle] -> IO () +closeAllFiles [] = return () +closeAllFiles (h:hs) = do + hClose h closeAllFiles hs diff --git a/src/Eventloop/Module/File/Types.hs b/src/Eventloop/Module/File/Types.hs --- a/src/Eventloop/Module/File/Types.hs +++ b/src/Eventloop/Module/File/Types.hs @@ -1,29 +1,29 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass, StandaloneDeriving #-} -module Eventloop.Module.File.Types where - -import System.IO -import GHC.Generics (Generic) -import Control.DeepSeq - -type OpenFile = (FilePath, Handle, IOMode) - -data FileIn = FileOpened FilePath Bool - | FileClosed FilePath Bool - | RetrievedContents FilePath [[Char]] - | RetrievedLine FilePath [Char] - | RetrievedChar FilePath Char - | IsEOF FilePath Bool - | WroteTo FilePath Bool - deriving (Eq, Show) - -data FileOut = OpenFile FilePath IOMode - | CloseFile FilePath - | RetrieveContents FilePath - | RetrieveLine FilePath - | RetrieveChar FilePath - | IfEOF FilePath - | WriteTo FilePath [Char] - deriving (Eq, Show, Generic, NFData) - -deriving instance Generic IOMode +{-# LANGUAGE DeriveGeneric, DeriveAnyClass, StandaloneDeriving #-} +module Eventloop.Module.File.Types where + +import System.IO +import GHC.Generics (Generic) +import Control.DeepSeq + +type OpenFile = (FilePath, Handle, IOMode) + +data FileIn = FileOpened FilePath Bool + | FileClosed FilePath Bool + | RetrievedContents FilePath [[Char]] + | RetrievedLine FilePath [Char] + | RetrievedChar FilePath Char + | IsEOF FilePath Bool + | WroteTo FilePath Bool + deriving (Eq, Show) + +data FileOut = OpenFile FilePath IOMode + | CloseFile FilePath + | RetrieveContents FilePath + | RetrieveLine FilePath + | RetrieveChar FilePath + | IfEOF FilePath + | WriteTo FilePath [Char] + deriving (Eq, Show, Generic, NFData) + +deriving instance Generic IOMode deriving instance NFData IOMode diff --git a/src/Eventloop/Module/Graphs.hs b/src/Eventloop/Module/Graphs.hs --- a/src/Eventloop/Module/Graphs.hs +++ b/src/Eventloop/Module/Graphs.hs @@ -1,7 +1,7 @@ -module Eventloop.Module.Graphs - ( module Eventloop.Module.Graphs.Graphs - , module Eventloop.Module.Graphs.Types - ) where - -import Eventloop.Module.Graphs.Graphs +module Eventloop.Module.Graphs + ( module Eventloop.Module.Graphs.Graphs + , module Eventloop.Module.Graphs.Types + ) where + +import Eventloop.Module.Graphs.Graphs import Eventloop.Module.Graphs.Types diff --git a/src/Eventloop/Module/Graphs/Graphs.hs b/src/Eventloop/Module/Graphs/Graphs.hs --- a/src/Eventloop/Module/Graphs/Graphs.hs +++ b/src/Eventloop/Module/Graphs/Graphs.hs @@ -1,230 +1,230 @@ -module Eventloop.Module.Graphs.Graphs where - - -import Eventloop.Module.Graphs.Types -import qualified Eventloop.Module.Websocket.Canvas as C -import qualified Eventloop.Module.Websocket.Mouse as M -import qualified Eventloop.Module.Websocket.Keyboard as K -import qualified Eventloop.Module.BasicShapes as BS -import Eventloop.Types.Common -import Eventloop.Types.Events -import Eventloop.Types.System -import Eventloop.Utility.Vectors - - -setupGraphsModuleConfiguration :: EventloopSetupModuleConfiguration -setupGraphsModuleConfiguration = ( EventloopSetupModuleConfiguration - graphsModuleIdentifier - Nothing - Nothing - (Just graphsPreProcessor) - (Just graphsPostProcessor) - Nothing - Nothing - ) - -graphsModuleIdentifier :: EventloopModuleIdentifier -graphsModuleIdentifier = "graphs" - - - -nodeRadius = 20 :: Float -textSize = 16 :: Float -textFont = "Courier" -xArrowSize = 6 :: Float -yArrowSize = 6 :: Float -weightHeight = 15 :: Float - -dimCanvasGraphs = (840,440) :: (Float, Float) -roundDimCanvasGraphs = (round $ fst dimCanvasGraphs, round $ snd dimCanvasGraphs) :: (Int, Int) -canvasGraphsWidth = fst dimCanvasGraphs -canvasGraphsHeight = snd dimCanvasGraphs - -instructionsHeight = 200 :: Float -instructionsBeginAt = instructionsHeight + canvasGraphsHeight -canvasInstrWidth = canvasGraphsWidth -canvasInstrHeight = instructionsHeight * 2 + canvasGraphsHeight -dimCanvasInstr = (canvasInstrWidth, canvasInstrHeight) -roundDimCanvasInstr = (round $ fst dimCanvasInstr, round $ snd dimCanvasInstr) :: (Int, Int) - -canvasIdGraphs = 1 :: C.CanvasId -canvasIdInstructions = 2 :: C.CanvasId - - --- | Checkes to see if there is a node on a certain position -onNode :: [Node] -> Pos -> Maybe Node -onNode [] _ = Nothing -onNode (n@(_, (nx, ny), _):ns) (x,y) | difference <= nodeRadius = Just n - | otherwise = onNode ns (x,y) - where - dx = nx - x - dy = ny - y - difference = sqrt (dx^2 + dy^2) - - - --- | Abstracts the standardized 'EventLoop.Types.EventTypes' to 'GraphsIn' -graphsPreProcessor :: PreProcessor -graphsPreProcessor sharedConst sharedIOT ioConst ioStateT (InMouse (M.Mouse M.MouseCanvas 1 event (Point p))) - | x >=0 && y >= 0 && y <= canvasGraphsHeight && x <= canvasGraphsWidth = return [InGraphs $ Mouse event p] - | otherwise = return [] - where - (x, y) = p - -graphsPreProcessor sharedConst sharedIOT ioConst ioStateT k@(InKeyboard (K.Key key)) - = return [k, InGraphs $ Key key] - -graphsPreProcessor sharedConst sharedIOT ioConst ioStateT inEvent - = return [inEvent] - - --- | Abstracts 'GraphsOut' back to 'BasicShapes' and 'Canvas' events -graphsPostProcessor :: PostProcessor -graphsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutGraphs SetupGraphs) - = return [ OutCanvas $ C.SetupCanvas canvasIdGraphs 1 roundDimCanvasGraphs (C.CSSPosition C.CSSFromCenter (C.CSSPercentage 50, C.CSSPercentage 50)) - , OutCanvas $ C.SetupCanvas canvasIdInstructions 2 roundDimCanvasInstr (C.CSSPosition C.CSSFromCenter (C.CSSPercentage 50, C.CSSPercentage 50)) - ] - - -graphsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutGraphs (DrawGraph graph)) - = return [ OutCanvas $ C.CanvasOperations canvasIdGraphs [C.Clear C.ClearCanvas] - , OutBasicShapes $ BS.DrawShapes canvasIdGraphs shapes - ] - where - shapes = graphToShapes graph - -graphsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutGraphs (Instructions is)) - = return [ OutCanvas $ C.CanvasOperations canvasIdInstructions [C.Clear C.ClearCanvas] - , OutBasicShapes $ BS.DrawShapes canvasIdInstructions shapes - ] - where - startPLine = Point (0, 0) - endPLine = Point (canvasGraphsWidth, 0) - lineHeight = 2 - lineShape = BS.Line startPLine endPLine lineHeight (0,0,0,255) Nothing - textShape = (\line p -> BS.Text line textFont textSize p BS.AlignCenter (0,0,0,255) 0 (0,0,0,0) Nothing) - textMargin = 2 - heights = iterate ((+) (textSize + textMargin)) lineHeight - isAndHeights = zip is heights - instructionShapes = map (\(line, top) -> textShape line $ Point (0.5 * canvasGraphsWidth, top)) isAndHeights - shapes = [BS.CompositeShape (lineShape:instructionShapes) (Just (Point (0, instructionsBeginAt))) Nothing] - -graphsPostProcessor sharedConst sharedIOT ioConst ioStateT out - = return [out] - --- | Translates color datatype to RGBA codes -colorToRGBAColor :: Color -> BS.Color -colorToRGBAColor Red = (255, 0, 0, 255) -colorToRGBAColor Blue = (0, 0, 255, 255) -colorToRGBAColor Green = (0, 255, 0, 255) -colorToRGBAColor Purple = (255, 0, 255, 255) -colorToRGBAColor Grey = (125, 125, 125, 255) -colorToRGBAColor Yellow = (255, 255, 0, 255) -colorToRGBAColor Orange = (255, 125, 0, 255) -colorToRGBAColor Black = (0, 0, 0, 255) -colorToRGBAColor White = (255, 255, 255, 255) - - --- | Translates the thickness to a float -thicknessToFloat :: Thickness -> BS.StrokeLineThickness -thicknessToFloat Thick = 3.0 -thicknessToFloat Thin = 1.0 - - -findNode :: [Node] -> Label -> Node -findNode [] l = error ("Tried to find a node in the graph with label '" ++ (show l) ++ "' but could not find it!") -findNode (n@(ln, _, _):ns) l | l == ln = n - | otherwise = findNode ns l - - -graphToShapes :: Graph -> [BS.Shape] -graphToShapes graph - = (concat nodeShapes) ++ (concat edgeShapes) - where - allNodes = nodes graph - allEdges = edges graph - isDirected = directed graph - isWeighted = weighted graph - allEdgesWithNodes = map (\e@(l1, l2,_,_,_) -> (findNode allNodes l1, findNode allNodes l2, e)) allEdges - nodeShapes = map nodeToShapes allNodes - edgeShapes = map (\(n1, n2, e) -> edgeToShapes n1 n2 e isDirected isWeighted) allEdgesWithNodes - - -nodeToShapes :: Node -> [BS.Shape] -nodeToShapes (l, p, col) - = [ BS.Circle (Point p) nodeRadius color 2 (0,0,0,255) Nothing - , BS.Text lStr textFont textSize (Point p) BS.AlignCenter (0,0,0,255) 3 (0,0,0,255) Nothing - ] - where - color = colorToRGBAColor col - lStr = [l] - - -edgeToShapes :: Node -> Node -> Edge -> Directed -> Weighted -> [BS.Shape] -edgeToShapes (_, p1, _) (_, p2, _) (_, _, col, w, thick) directed weighted - = lineShape:(weightShapes ++ directShapes) - where - directShapes | directed == Directed = [ BS.Line (Point arrowStart) (Point arrow1End) thickness color Nothing - , BS.Line (Point arrowStart) (Point arrow2End) thickness color Nothing - ] - | directed == Undirected = [] - weightShapes | weighted == Weighted = [BS.Text wStr textFont textSize (Point textPos) BS.AlignCenter (0,0,0,255) 0 (0,0,0,0) Nothing] - | weighted == Unweighted = [] - where - wStr = show w - lineShape = BS.Line (Point lineStart) (Point lineEnd) thickness color Nothing - thickness = thicknessToFloat thick - color = colorToRGBAColor col - -- Margin line vector stuff - lineVector = vectorize p1 p2 - lineVector' = vectorize p2 p1 - lineStart = posOnVector nodeRadius lineVector p1 - lineEnd = posOnVector nodeRadius lineVector' p2 - -- Arrow directed vector stuff - arrowPerpStart = posOnVector xArrowSize lineVector' lineEnd - upPerpLineVector = upPerpendicularTo p1 p2 - downPerpLineVector = downPerpendicularTo p1 p2 - arrowStart = lineEnd - arrow1End = posOnVector yArrowSize upPerpLineVector arrowPerpStart - arrow2End = posOnVector yArrowSize downPerpLineVector arrowPerpStart - -- Weight vector stuff - halfSize = vectorSize lineVector' / 2 - textPerpStart = posOnVector halfSize lineVector p1 - textPos = posOnVector weightHeight upPerpLineVector textPerpStart - - --- | Returns the point when making a step f long from the point start in the direction of the vector. The length between start pos and result pos is always f. -posOnVector :: Float -> Vector -> Pos -> Pos -posOnVector f (xv, yv) (xStart, yStart) = (x, y) - where - x = xStart + fraction * xv - y = yStart + fraction * yv - fraction = f / size - size = vectorSize (xv, yv) - --- | Vector from p1 to p2 -vectorize :: Pos -> Pos -> Vector -vectorize (x1, y1) (x2, y2) = (x2 - x1, y2 - y1) - - --- | Returns the vector perpendicular on the given vector between the 2 points. Always has positive y and vector length 1; y is inverted in canvas -downPerpendicularTo :: Pos -> Pos -> Vector -downPerpendicularTo (x1, y1) (x2, y2) | y2 > y1 = ((-1) * sign * (abs yv) / size, (abs xv) / size) - | otherwise = ( sign * (abs yv) / size, (abs xv) / size) - where - (xv, yv) = vectorize (x1, y1) (x2, y2) - size = vectorSize (xv, yv) - sign = case xv of - 0 -> (-1) - _ -> xv / (abs xv) - - --- | Returns the vector perpendicular on the given vector between the 2 points. Always has negative y and vector length 1; y is inverted in canvas -upPerpendicularTo :: Pos -> Pos -> Vector -upPerpendicularTo p1 p2 = ((-1) * xp, (-1) * yp) - where - (xp, yp) = downPerpendicularTo p1 p2 - --- | Returns the size of the vector -vectorSize :: Vector -> Float -vectorSize (x, y) = sqrt (x^2 + y^2) +module Eventloop.Module.Graphs.Graphs where + + +import Eventloop.Module.Graphs.Types +import qualified Eventloop.Module.Websocket.Canvas as C +import qualified Eventloop.Module.Websocket.Mouse as M +import qualified Eventloop.Module.Websocket.Keyboard as K +import qualified Eventloop.Module.BasicShapes as BS +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System +import Eventloop.Utility.Vectors + + +setupGraphsModuleConfiguration :: EventloopSetupModuleConfiguration +setupGraphsModuleConfiguration = ( EventloopSetupModuleConfiguration + graphsModuleIdentifier + Nothing + Nothing + (Just graphsPreProcessor) + (Just graphsPostProcessor) + Nothing + Nothing + ) + +graphsModuleIdentifier :: EventloopModuleIdentifier +graphsModuleIdentifier = "graphs" + + + +nodeRadius = 20 :: Float +textSize = 16 :: Float +textFont = "Courier" +xArrowSize = 6 :: Float +yArrowSize = 6 :: Float +weightHeight = 15 :: Float + +dimCanvasGraphs = (840,440) :: (Float, Float) +roundDimCanvasGraphs = (round $ fst dimCanvasGraphs, round $ snd dimCanvasGraphs) :: (Int, Int) +canvasGraphsWidth = fst dimCanvasGraphs +canvasGraphsHeight = snd dimCanvasGraphs + +instructionsHeight = 200 :: Float +instructionsBeginAt = instructionsHeight + canvasGraphsHeight +canvasInstrWidth = canvasGraphsWidth +canvasInstrHeight = instructionsHeight * 2 + canvasGraphsHeight +dimCanvasInstr = (canvasInstrWidth, canvasInstrHeight) +roundDimCanvasInstr = (round $ fst dimCanvasInstr, round $ snd dimCanvasInstr) :: (Int, Int) + +canvasIdGraphs = 1 :: C.CanvasId +canvasIdInstructions = 2 :: C.CanvasId + + +-- | Checkes to see if there is a node on a certain position +onNode :: [Node] -> Pos -> Maybe Node +onNode [] _ = Nothing +onNode (n@(_, (nx, ny), _):ns) (x,y) | difference <= nodeRadius = Just n + | otherwise = onNode ns (x,y) + where + dx = nx - x + dy = ny - y + difference = sqrt (dx^2 + dy^2) + + + +-- | Abstracts the standardized 'EventLoop.Types.EventTypes' to 'GraphsIn' +graphsPreProcessor :: PreProcessor +graphsPreProcessor sharedConst sharedIOT ioConst ioStateT (InMouse (M.Mouse M.MouseCanvas 1 event (Point p))) + | x >=0 && y >= 0 && y <= canvasGraphsHeight && x <= canvasGraphsWidth = return [InGraphs $ Mouse event p] + | otherwise = return [] + where + (x, y) = p + +graphsPreProcessor sharedConst sharedIOT ioConst ioStateT k@(InKeyboard (K.Key key)) + = return [k, InGraphs $ Key key] + +graphsPreProcessor sharedConst sharedIOT ioConst ioStateT inEvent + = return [inEvent] + + +-- | Abstracts 'GraphsOut' back to 'BasicShapes' and 'Canvas' events +graphsPostProcessor :: PostProcessor +graphsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutGraphs SetupGraphs) + = return [ OutCanvas $ C.SetupCanvas canvasIdGraphs 1 roundDimCanvasGraphs (C.CSSPosition C.CSSFromCenter (C.CSSPercentage 50, C.CSSPercentage 50)) + , OutCanvas $ C.SetupCanvas canvasIdInstructions 2 roundDimCanvasInstr (C.CSSPosition C.CSSFromCenter (C.CSSPercentage 50, C.CSSPercentage 50)) + ] + + +graphsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutGraphs (DrawGraph graph)) + = return [ OutCanvas $ C.CanvasOperations canvasIdGraphs [C.Clear C.ClearCanvas] + , OutBasicShapes $ BS.DrawShapes canvasIdGraphs shapes + ] + where + shapes = graphToShapes graph + +graphsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutGraphs (Instructions is)) + = return [ OutCanvas $ C.CanvasOperations canvasIdInstructions [C.Clear C.ClearCanvas] + , OutBasicShapes $ BS.DrawShapes canvasIdInstructions shapes + ] + where + startPLine = Point (0, 0) + endPLine = Point (canvasGraphsWidth, 0) + lineHeight = 2 + lineShape = BS.Line startPLine endPLine lineHeight (0,0,0,255) Nothing + textShape = (\line p -> BS.Text line textFont textSize p BS.AlignCenter (0,0,0,255) 0 (0,0,0,0) Nothing) + textMargin = 2 + heights = iterate ((+) (textSize + textMargin)) lineHeight + isAndHeights = zip is heights + instructionShapes = map (\(line, top) -> textShape line $ Point (0.5 * canvasGraphsWidth, top)) isAndHeights + shapes = [BS.CompositeShape (lineShape:instructionShapes) (Just (Point (0, instructionsBeginAt))) Nothing] + +graphsPostProcessor sharedConst sharedIOT ioConst ioStateT out + = return [out] + +-- | Translates color datatype to RGBA codes +colorToRGBAColor :: Color -> BS.Color +colorToRGBAColor Red = (255, 0, 0, 255) +colorToRGBAColor Blue = (0, 0, 255, 255) +colorToRGBAColor Green = (0, 255, 0, 255) +colorToRGBAColor Purple = (255, 0, 255, 255) +colorToRGBAColor Grey = (125, 125, 125, 255) +colorToRGBAColor Yellow = (255, 255, 0, 255) +colorToRGBAColor Orange = (255, 125, 0, 255) +colorToRGBAColor Black = (0, 0, 0, 255) +colorToRGBAColor White = (255, 255, 255, 255) + + +-- | Translates the thickness to a float +thicknessToFloat :: Thickness -> BS.StrokeLineThickness +thicknessToFloat Thick = 3.0 +thicknessToFloat Thin = 1.0 + + +findNode :: [Node] -> Label -> Node +findNode [] l = error ("Tried to find a node in the graph with label '" ++ (show l) ++ "' but could not find it!") +findNode (n@(ln, _, _):ns) l | l == ln = n + | otherwise = findNode ns l + + +graphToShapes :: Graph -> [BS.Shape] +graphToShapes graph + = (concat nodeShapes) ++ (concat edgeShapes) + where + allNodes = nodes graph + allEdges = edges graph + isDirected = directed graph + isWeighted = weighted graph + allEdgesWithNodes = map (\e@(l1, l2,_,_,_) -> (findNode allNodes l1, findNode allNodes l2, e)) allEdges + nodeShapes = map nodeToShapes allNodes + edgeShapes = map (\(n1, n2, e) -> edgeToShapes n1 n2 e isDirected isWeighted) allEdgesWithNodes + + +nodeToShapes :: Node -> [BS.Shape] +nodeToShapes (l, p, col) + = [ BS.Circle (Point p) nodeRadius color 2 (0,0,0,255) Nothing + , BS.Text lStr textFont textSize (Point p) BS.AlignCenter (0,0,0,255) 3 (0,0,0,255) Nothing + ] + where + color = colorToRGBAColor col + lStr = [l] + + +edgeToShapes :: Node -> Node -> Edge -> Directed -> Weighted -> [BS.Shape] +edgeToShapes (_, p1, _) (_, p2, _) (_, _, col, w, thick) directed weighted + = lineShape:(weightShapes ++ directShapes) + where + directShapes | directed == Directed = [ BS.Line (Point arrowStart) (Point arrow1End) thickness color Nothing + , BS.Line (Point arrowStart) (Point arrow2End) thickness color Nothing + ] + | directed == Undirected = [] + weightShapes | weighted == Weighted = [BS.Text wStr textFont textSize (Point textPos) BS.AlignCenter (0,0,0,255) 0 (0,0,0,0) Nothing] + | weighted == Unweighted = [] + where + wStr = show w + lineShape = BS.Line (Point lineStart) (Point lineEnd) thickness color Nothing + thickness = thicknessToFloat thick + color = colorToRGBAColor col + -- Margin line vector stuff + lineVector = vectorize p1 p2 + lineVector' = vectorize p2 p1 + lineStart = posOnVector nodeRadius lineVector p1 + lineEnd = posOnVector nodeRadius lineVector' p2 + -- Arrow directed vector stuff + arrowPerpStart = posOnVector xArrowSize lineVector' lineEnd + upPerpLineVector = upPerpendicularTo p1 p2 + downPerpLineVector = downPerpendicularTo p1 p2 + arrowStart = lineEnd + arrow1End = posOnVector yArrowSize upPerpLineVector arrowPerpStart + arrow2End = posOnVector yArrowSize downPerpLineVector arrowPerpStart + -- Weight vector stuff + halfSize = vectorSize lineVector' / 2 + textPerpStart = posOnVector halfSize lineVector p1 + textPos = posOnVector weightHeight upPerpLineVector textPerpStart + + +-- | Returns the point when making a step f long from the point start in the direction of the vector. The length between start pos and result pos is always f. +posOnVector :: Float -> Vector -> Pos -> Pos +posOnVector f (xv, yv) (xStart, yStart) = (x, y) + where + x = xStart + fraction * xv + y = yStart + fraction * yv + fraction = f / size + size = vectorSize (xv, yv) + +-- | Vector from p1 to p2 +vectorize :: Pos -> Pos -> Vector +vectorize (x1, y1) (x2, y2) = (x2 - x1, y2 - y1) + + +-- | Returns the vector perpendicular on the given vector between the 2 points. Always has positive y and vector length 1; y is inverted in canvas +downPerpendicularTo :: Pos -> Pos -> Vector +downPerpendicularTo (x1, y1) (x2, y2) | y2 > y1 = ((-1) * sign * (abs yv) / size, (abs xv) / size) + | otherwise = ( sign * (abs yv) / size, (abs xv) / size) + where + (xv, yv) = vectorize (x1, y1) (x2, y2) + size = vectorSize (xv, yv) + sign = case xv of + 0 -> (-1) + _ -> xv / (abs xv) + + +-- | Returns the vector perpendicular on the given vector between the 2 points. Always has negative y and vector length 1; y is inverted in canvas +upPerpendicularTo :: Pos -> Pos -> Vector +upPerpendicularTo p1 p2 = ((-1) * xp, (-1) * yp) + where + (xp, yp) = downPerpendicularTo p1 p2 + +-- | Returns the size of the vector +vectorSize :: Vector -> Float +vectorSize (x, y) = sqrt (x^2 + y^2) diff --git a/src/Eventloop/Module/Graphs/Types.hs b/src/Eventloop/Module/Graphs/Types.hs --- a/src/Eventloop/Module/Graphs/Types.hs +++ b/src/Eventloop/Module/Graphs/Types.hs @@ -1,62 +1,62 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} -module Eventloop.Module.Graphs.Types - ( module Eventloop.Module.Graphs.Types - , M.MouseEvent(..) - , M.MouseButton(..) - ) where - -import GHC.Generics (Generic) -import Control.DeepSeq - -import qualified Eventloop.Module.Websocket.Mouse.Types as M - -type Pos = (Float, Float) -type Vector = (Float, Float) - - -data GraphsIn = Mouse M.MouseEvent Pos - | Key [Char] - deriving (Eq, Show) - -data GraphsOut = SetupGraphs - | DrawGraph Graph - | Instructions [String] - deriving (Eq, Show, Generic, NFData) - ------ Graph ----- -type Label = Char -type Weight = Float - -type Node = (Label, Pos, Color) -type Edge = (Label, Label, Color, Weight, Thickness) - -data Graph = Graph - { nodes :: [Node] - , edges :: [Edge] - , directed :: Directed - , weighted :: Weighted - } deriving (Eq, Show, Generic, NFData) - ------ Graph Graphical ----- -data Color = Red - | Blue - | Green - | Purple - | Grey - | Yellow - | Orange - | Black - | White - deriving (Eq, Show, Generic, NFData) - -data Thickness = Thin - | Thick - deriving (Eq, Show, Generic, NFData) - -data Directed = Directed - | Undirected - deriving (Eq, Show, Generic, NFData) - -data Weighted = Weighted - | Unweighted +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +module Eventloop.Module.Graphs.Types + ( module Eventloop.Module.Graphs.Types + , M.MouseEvent(..) + , M.MouseButton(..) + ) where + +import GHC.Generics (Generic) +import Control.DeepSeq + +import qualified Eventloop.Module.Websocket.Mouse.Types as M + +type Pos = (Float, Float) +type Vector = (Float, Float) + + +data GraphsIn = Mouse M.MouseEvent Pos + | Key [Char] + deriving (Eq, Show) + +data GraphsOut = SetupGraphs + | DrawGraph Graph + | Instructions [String] + deriving (Eq, Show, Generic, NFData) + +----- Graph ----- +type Label = Char +type Weight = Float + +type Node = (Label, Pos, Color) +type Edge = (Label, Label, Color, Weight, Thickness) + +data Graph = Graph + { nodes :: [Node] + , edges :: [Edge] + , directed :: Directed + , weighted :: Weighted + } deriving (Eq, Show, Generic, NFData) + +----- Graph Graphical ----- +data Color = Red + | Blue + | Green + | Purple + | Grey + | Yellow + | Orange + | Black + | White + deriving (Eq, Show, Generic, NFData) + +data Thickness = Thin + | Thick + deriving (Eq, Show, Generic, NFData) + +data Directed = Directed + | Undirected + deriving (Eq, Show, Generic, NFData) + +data Weighted = Weighted + | Unweighted deriving (Eq, Show, Generic, NFData) diff --git a/src/Eventloop/Module/StatefulGraphics/StatefulGraphics.hs b/src/Eventloop/Module/StatefulGraphics/StatefulGraphics.hs --- a/src/Eventloop/Module/StatefulGraphics/StatefulGraphics.hs +++ b/src/Eventloop/Module/StatefulGraphics/StatefulGraphics.hs @@ -40,7 +40,8 @@ statefulGraphicsPostProcessor :: PostProcessor statefulGraphicsPostProcessor sharedConst sharedIOT ioConst ioStateT (OutStatefulGraphics canvasId commands) = atomically $ do - (StatefulGraphicsState states) <- readTVar ioStateT + -- HACK: (StatefulGraphicsState states) is a failable pattern that GHC-8.6 doesn't want to compile because there is no MonadFail STM instance + ~(StatefulGraphicsState states) <- readTVar ioStateT let stateM = findGraphicalState states canvasId state = case stateM of diff --git a/src/Eventloop/Module/StdIn.hs b/src/Eventloop/Module/StdIn.hs --- a/src/Eventloop/Module/StdIn.hs +++ b/src/Eventloop/Module/StdIn.hs @@ -1,7 +1,7 @@ -module Eventloop.Module.StdIn - ( module Eventloop.Module.StdIn.StdIn - , module Eventloop.Module.StdIn.Types - ) where - -import Eventloop.Module.StdIn.StdIn +module Eventloop.Module.StdIn + ( module Eventloop.Module.StdIn.StdIn + , module Eventloop.Module.StdIn.Types + ) where + +import Eventloop.Module.StdIn.StdIn import Eventloop.Module.StdIn.Types diff --git a/src/Eventloop/Module/StdIn/StdIn.hs b/src/Eventloop/Module/StdIn/StdIn.hs --- a/src/Eventloop/Module/StdIn/StdIn.hs +++ b/src/Eventloop/Module/StdIn/StdIn.hs @@ -1,77 +1,77 @@ -module Eventloop.Module.StdIn.StdIn - ( setupStdInModuleConfiguration - , stdInModuleIdentifier - , stdInInitializer - , stdInEventRetriever - , stdInEventSender - ) where - -import System.IO -import Data.String -import Control.Concurrent.Datastructures.BlockingConcurrentQueue -import Control.Concurrent.STM - -import Eventloop.Module.StdIn.Types -import Eventloop.Types.Common -import Eventloop.Types.Events -import Eventloop.Types.System - -setupStdInModuleConfiguration :: EventloopSetupModuleConfiguration -setupStdInModuleConfiguration = ( EventloopSetupModuleConfiguration - stdInModuleIdentifier - (Just stdInInitializer) - (Just stdInEventRetriever) - Nothing - Nothing - (Just stdInEventSender) - Nothing - ) - - -stdInModuleIdentifier :: EventloopModuleIdentifier -stdInModuleIdentifier = "stdin" - - -stdInInitializer :: Initializer -stdInInitializer sharedConst sharedIO - = do - inQueue <- createBlockingConcurrentQueue - return (sharedConst, sharedIO, StdInConstants inQueue, NoState) - - -stdInEventRetriever :: EventRetriever -stdInEventRetriever sharedConst sharedIOT ioConst ioStateT - = do - inEvents <- takeAllFromBlockingConcurrentQueue inQueue - return (map InStdIn inEvents) - where - inQueue = stdInInQueue ioConst - - -stdInEventSender :: EventSender -stdInEventSender _ _ _ _ Stop = return () -stdInEventSender sharedConst sharedIOT ioConst ioStateT (OutStdIn a) - = do - inEvents <- stdInEventSender' a - putAllInBlockingConcurrentQueue inQueue inEvents - where - inQueue = stdInInQueue ioConst - - -stdInEventSender' :: StdInOut -> IO [StdInIn] -stdInEventSender' StdInReceiveContents - = doStdInGet linedGetContents StdInReceivedContents - where - linedGetContents = (getContents >>= (\strContents -> return $ lines strContents)) - -stdInEventSender' StdInReceiveLine - = doStdInGet getLine StdInReceivedLine -stdInEventSender' StdInReceiveChar - = doStdInGet getChar StdInReceivedChar - - -doStdInGet :: (IO a) -> (a -> StdInIn) -> IO [StdInIn] -doStdInGet source typeEvent - = do - content <- source +module Eventloop.Module.StdIn.StdIn + ( setupStdInModuleConfiguration + , stdInModuleIdentifier + , stdInInitializer + , stdInEventRetriever + , stdInEventSender + ) where + +import System.IO +import Data.String +import Control.Concurrent.Datastructures.BlockingConcurrentQueue +import Control.Concurrent.STM + +import Eventloop.Module.StdIn.Types +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System + +setupStdInModuleConfiguration :: EventloopSetupModuleConfiguration +setupStdInModuleConfiguration = ( EventloopSetupModuleConfiguration + stdInModuleIdentifier + (Just stdInInitializer) + (Just stdInEventRetriever) + Nothing + Nothing + (Just stdInEventSender) + Nothing + ) + + +stdInModuleIdentifier :: EventloopModuleIdentifier +stdInModuleIdentifier = "stdin" + + +stdInInitializer :: Initializer +stdInInitializer sharedConst sharedIO + = do + inQueue <- createBlockingConcurrentQueue + return (sharedConst, sharedIO, StdInConstants inQueue, NoState) + + +stdInEventRetriever :: EventRetriever +stdInEventRetriever sharedConst sharedIOT ioConst ioStateT + = do + inEvents <- takeAllFromBlockingConcurrentQueue inQueue + return (map InStdIn inEvents) + where + inQueue = stdInInQueue ioConst + + +stdInEventSender :: EventSender +stdInEventSender _ _ _ _ Stop = return () +stdInEventSender sharedConst sharedIOT ioConst ioStateT (OutStdIn a) + = do + inEvents <- stdInEventSender' a + putAllInBlockingConcurrentQueue inQueue inEvents + where + inQueue = stdInInQueue ioConst + + +stdInEventSender' :: StdInOut -> IO [StdInIn] +stdInEventSender' StdInReceiveContents + = doStdInGet linedGetContents StdInReceivedContents + where + linedGetContents = (getContents >>= (\strContents -> return $ lines strContents)) + +stdInEventSender' StdInReceiveLine + = doStdInGet getLine StdInReceivedLine +stdInEventSender' StdInReceiveChar + = doStdInGet getChar StdInReceivedChar + + +doStdInGet :: (IO a) -> (a -> StdInIn) -> IO [StdInIn] +doStdInGet source typeEvent + = do + content <- source return ([typeEvent content]) diff --git a/src/Eventloop/Module/StdIn/Types.hs b/src/Eventloop/Module/StdIn/Types.hs --- a/src/Eventloop/Module/StdIn/Types.hs +++ b/src/Eventloop/Module/StdIn/Types.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} -module Eventloop.Module.StdIn.Types where - -import GHC.Generics (Generic) -import Control.DeepSeq - -data StdInIn = StdInReceivedContents [[Char]] - | StdInReceivedLine [Char] - | StdInReceivedChar Char - deriving (Eq, Show) - -data StdInOut = StdInReceiveContents - | StdInReceiveLine - | StdInReceiveChar +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +module Eventloop.Module.StdIn.Types where + +import GHC.Generics (Generic) +import Control.DeepSeq + +data StdInIn = StdInReceivedContents [[Char]] + | StdInReceivedLine [Char] + | StdInReceivedChar Char + deriving (Eq, Show) + +data StdInOut = StdInReceiveContents + | StdInReceiveLine + | StdInReceiveChar deriving (Eq, Show, Generic, NFData) diff --git a/src/Eventloop/Module/StdOut.hs b/src/Eventloop/Module/StdOut.hs --- a/src/Eventloop/Module/StdOut.hs +++ b/src/Eventloop/Module/StdOut.hs @@ -1,7 +1,7 @@ -module Eventloop.Module.StdOut - ( module Eventloop.Module.StdOut.StdOut - , module Eventloop.Module.StdOut.Types - ) where - -import Eventloop.Module.StdOut.StdOut +module Eventloop.Module.StdOut + ( module Eventloop.Module.StdOut.StdOut + , module Eventloop.Module.StdOut.Types + ) where + +import Eventloop.Module.StdOut.StdOut import Eventloop.Module.StdOut.Types diff --git a/src/Eventloop/Module/StdOut/StdOut.hs b/src/Eventloop/Module/StdOut/StdOut.hs --- a/src/Eventloop/Module/StdOut/StdOut.hs +++ b/src/Eventloop/Module/StdOut/StdOut.hs @@ -1,39 +1,39 @@ -module Eventloop.Module.StdOut.StdOut - ( setupStdOutModuleConfiguration - , stdOutModuleIdentifier - , stdOutEventSender - ) where - -import System.IO - -import Control.Concurrent.MVar -import Control.Concurrent.SafePrint - -import Eventloop.Module.StdOut.Types -import Eventloop.Types.Common -import Eventloop.Types.Events -import Eventloop.Types.System - -setupStdOutModuleConfiguration :: EventloopSetupModuleConfiguration -setupStdOutModuleConfiguration = ( EventloopSetupModuleConfiguration - stdOutModuleIdentifier - Nothing - Nothing - Nothing - Nothing - (Just stdOutEventSender) - Nothing - ) - -stdOutModuleIdentifier :: EventloopModuleIdentifier -stdOutModuleIdentifier = "stdout" - - -stdOutEventSender :: EventSender -stdOutEventSender _ _ _ _ Stop = return () -stdOutEventSender sharedConst sharedIOT ioConst ioStateT (OutStdOut (StdOutMessage str)) - = do - safePrint token str - hFlush stdout - where +module Eventloop.Module.StdOut.StdOut + ( setupStdOutModuleConfiguration + , stdOutModuleIdentifier + , stdOutEventSender + ) where + +import System.IO + +import Control.Concurrent.MVar +import Control.Concurrent.SafePrint + +import Eventloop.Module.StdOut.Types +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System + +setupStdOutModuleConfiguration :: EventloopSetupModuleConfiguration +setupStdOutModuleConfiguration = ( EventloopSetupModuleConfiguration + stdOutModuleIdentifier + Nothing + Nothing + Nothing + Nothing + (Just stdOutEventSender) + Nothing + ) + +stdOutModuleIdentifier :: EventloopModuleIdentifier +stdOutModuleIdentifier = "stdout" + + +stdOutEventSender :: EventSender +stdOutEventSender _ _ _ _ Stop = return () +stdOutEventSender sharedConst sharedIOT ioConst ioStateT (OutStdOut (StdOutMessage str)) + = do + safePrint token str + hFlush stdout + where token = safePrintToken sharedConst diff --git a/src/Eventloop/Module/StdOut/Types.hs b/src/Eventloop/Module/StdOut/Types.hs --- a/src/Eventloop/Module/StdOut/Types.hs +++ b/src/Eventloop/Module/StdOut/Types.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} -module Eventloop.Module.StdOut.Types where - -import GHC.Generics (Generic) -import Control.DeepSeq - -data StdOutOut = StdOutMessage [Char] +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +module Eventloop.Module.StdOut.Types where + +import GHC.Generics (Generic) +import Control.DeepSeq + +data StdOutOut = StdOutMessage [Char] deriving (Eq, Show, Generic, NFData) diff --git a/src/Eventloop/Module/Timer.hs b/src/Eventloop/Module/Timer.hs --- a/src/Eventloop/Module/Timer.hs +++ b/src/Eventloop/Module/Timer.hs @@ -1,7 +1,7 @@ -module Eventloop.Module.Timer - ( module Eventloop.Module.Timer.Timer - , module Eventloop.Module.Timer.Types - ) where - -import Eventloop.Module.Timer.Timer +module Eventloop.Module.Timer + ( module Eventloop.Module.Timer.Timer + , module Eventloop.Module.Timer.Types + ) where + +import Eventloop.Module.Timer.Timer import Eventloop.Module.Timer.Types diff --git a/src/Eventloop/Module/Timer/Timer.hs b/src/Eventloop/Module/Timer/Timer.hs --- a/src/Eventloop/Module/Timer/Timer.hs +++ b/src/Eventloop/Module/Timer/Timer.hs @@ -1,154 +1,154 @@ -module Eventloop.Module.Timer.Timer - ( setupTimerModuleConfiguration - , timerModuleIdentifier - , timerInitializer - , timerEventRetriever - , timerEventSender - , timerTeardown - ) where - -import Control.Concurrent.Datastructures.BlockingConcurrentQueue -import Control.Concurrent.STM -import Control.Concurrent.Timer -import Control.Concurrent.Suspend.Lifted -import Data.Maybe -import Data.List - -import Eventloop.Module.Timer.Types -import Eventloop.Types.Common -import Eventloop.Types.Events -import Eventloop.Types.System - - -setupTimerModuleConfiguration :: EventloopSetupModuleConfiguration -setupTimerModuleConfiguration = ( EventloopSetupModuleConfiguration - timerModuleIdentifier - (Just timerInitializer) - (Just timerEventRetriever) - Nothing - Nothing - (Just timerEventSender) - (Just timerTeardown) - ) - -timerModuleIdentifier :: EventloopModuleIdentifier -timerModuleIdentifier = "timer" - - -timerInitializer :: Initializer -timerInitializer sharedConst sharedIO - = do - inQueue <- createBlockingConcurrentQueue - return (sharedConst, sharedIO, TimerConstants inQueue, TimerState [] []) - - -timerEventRetriever :: EventRetriever -timerEventRetriever sharedConst sharedIOT ioConst ioStateT - = do - inTicks <- takeAllFromBlockingConcurrentQueue inQueue - ioState <- readTVarIO ioStateT -- This first read is just a snapshot - let - toStop = map (\(Tick id) -> id) inTicks - startedTimers_ = startedTimers ioState - sequence $ map (haltTimer startedTimers_) toStop - atomically $ do - ioState' <- readTVar ioStateT - let - startedTimers_' = startedTimers ioState' - startedTimers_'' = foldl unregisterTimer startedTimers_' toStop - writeTVar ioStateT (ioState'{startedTimers = startedTimers_'}) - - return (map InTimer inTicks) - where - inQueue = tickInQueue ioConst - - -timerEventSender :: EventSender -timerEventSender _ _ _ _ Stop = return () -timerEventSender sharedConst sharedIOT ioConst ioStateT (OutTimer a) - = timerEventSender' ioStateT tickBuffer a - where - tickBuffer = tickInQueue ioConst - - -timerEventSender' :: TVar IOState -> TickBuffer -> TimerOut -> IO () -timerEventSender' ioStateT tickBuffer (SetTimer id delay) - = do - startedTimer <- startTimer tickBuffer id delay (oneShotStart) - atomically $ do - ioState <- readTVar ioStateT - let - startedTimers_' = registerTimer (startedTimers ioState) startedTimer - writeTVar ioStateT ioState{startedTimers=startedTimers_'} - -timerEventSender' ioStateT tickBuffer (SetIntervalTimer id delay) - = do - startedTimer <- startTimer tickBuffer id delay (repeatedStart) - atomically $ do - ioState <- readTVar ioStateT - let - startedITimers_' = registerTimer (startedIntervalTimers ioState) startedTimer - writeTVar ioStateT ioState{startedIntervalTimers=startedITimers_'} - -timerEventSender' ioStateT tickBuffer (UnsetTimer id) - = do - ioState <- readTVarIO ioStateT -- This first read is just a snapshot - let - startedTimers_ = startedTimers ioState - startedITimers_ = startedIntervalTimers ioState - haltTimer startedTimers_ id - haltTimer startedITimers_ id - atomically $ do - ioState' <- readTVar ioStateT - let - startedTimers_' = startedTimers ioState' - startedITimers_' = startedIntervalTimers ioState' - writeTVar ioStateT ioState'{ startedTimers = startedTimers_' - , startedIntervalTimers = startedITimers_' - } - - -timerTeardown :: Teardown -timerTeardown sharedConst sharedIO ioConst ioState - = do - let - allStartedTimers = (startedTimers ioState) ++ (startedIntervalTimers ioState) - allStartedIds = map fst allStartedTimers - sequence_ $ map (haltTimer allStartedTimers) allStartedIds - return sharedIO - - -registerTimer :: [StartedTimer] -> StartedTimer -> [StartedTimer] -registerTimer startedTimers startedTimer - = startedTimers ++ [startedTimer] - - -startTimer :: TickBuffer -> TimerId -> MicroSecondDelay -> TimerStartFunction -> IO StartedTimer -startTimer incTickBuff id delay startFunc - = do - timer <- newTimer - startFunc timer (tick id incTickBuff) ((usDelay.fromIntegral) delay) - return (id, timer) - - -unregisterTimer :: [StartedTimer] -> TimerId -> [StartedTimer] -unregisterTimer startedTimers id - = filter (\(id', _) -> id /= id') startedTimers - - -haltTimer :: [StartedTimer] -> TimerId -> IO () -haltTimer startedTimers id - = do - let - startedTimerM = findStartedTimer startedTimers id - stopAction (Just (_, timer)) = stopTimer timer - stopAction Nothing = return () - stopAction startedTimerM - - -findStartedTimer :: [StartedTimer] -> TimerId -> Maybe StartedTimer -findStartedTimer startedTimers id = find (\(id', timer) -> id == id') startedTimers - - -tick :: TimerId -> TickBuffer -> IO () +module Eventloop.Module.Timer.Timer + ( setupTimerModuleConfiguration + , timerModuleIdentifier + , timerInitializer + , timerEventRetriever + , timerEventSender + , timerTeardown + ) where + +import Control.Concurrent.Datastructures.BlockingConcurrentQueue +import Control.Concurrent.STM +import Control.Concurrent.Timer +import Control.Concurrent.Suspend.Lifted +import Data.Maybe +import Data.List + +import Eventloop.Module.Timer.Types +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System + + +setupTimerModuleConfiguration :: EventloopSetupModuleConfiguration +setupTimerModuleConfiguration = ( EventloopSetupModuleConfiguration + timerModuleIdentifier + (Just timerInitializer) + (Just timerEventRetriever) + Nothing + Nothing + (Just timerEventSender) + (Just timerTeardown) + ) + +timerModuleIdentifier :: EventloopModuleIdentifier +timerModuleIdentifier = "timer" + + +timerInitializer :: Initializer +timerInitializer sharedConst sharedIO + = do + inQueue <- createBlockingConcurrentQueue + return (sharedConst, sharedIO, TimerConstants inQueue, TimerState [] []) + + +timerEventRetriever :: EventRetriever +timerEventRetriever sharedConst sharedIOT ioConst ioStateT + = do + inTicks <- takeAllFromBlockingConcurrentQueue inQueue + ioState <- readTVarIO ioStateT -- This first read is just a snapshot + let + toStop = map (\(Tick id) -> id) inTicks + startedTimers_ = startedTimers ioState + sequence $ map (haltTimer startedTimers_) toStop + atomically $ do + ioState' <- readTVar ioStateT + let + startedTimers_' = startedTimers ioState' + startedTimers_'' = foldl unregisterTimer startedTimers_' toStop + writeTVar ioStateT (ioState'{startedTimers = startedTimers_'}) + + return (map InTimer inTicks) + where + inQueue = tickInQueue ioConst + + +timerEventSender :: EventSender +timerEventSender _ _ _ _ Stop = return () +timerEventSender sharedConst sharedIOT ioConst ioStateT (OutTimer a) + = timerEventSender' ioStateT tickBuffer a + where + tickBuffer = tickInQueue ioConst + + +timerEventSender' :: TVar IOState -> TickBuffer -> TimerOut -> IO () +timerEventSender' ioStateT tickBuffer (SetTimer id delay) + = do + startedTimer <- startTimer tickBuffer id delay (oneShotStart) + atomically $ do + ioState <- readTVar ioStateT + let + startedTimers_' = registerTimer (startedTimers ioState) startedTimer + writeTVar ioStateT ioState{startedTimers=startedTimers_'} + +timerEventSender' ioStateT tickBuffer (SetIntervalTimer id delay) + = do + startedTimer <- startTimer tickBuffer id delay (repeatedStart) + atomically $ do + ioState <- readTVar ioStateT + let + startedITimers_' = registerTimer (startedIntervalTimers ioState) startedTimer + writeTVar ioStateT ioState{startedIntervalTimers=startedITimers_'} + +timerEventSender' ioStateT tickBuffer (UnsetTimer id) + = do + ioState <- readTVarIO ioStateT -- This first read is just a snapshot + let + startedTimers_ = startedTimers ioState + startedITimers_ = startedIntervalTimers ioState + haltTimer startedTimers_ id + haltTimer startedITimers_ id + atomically $ do + ioState' <- readTVar ioStateT + let + startedTimers_' = startedTimers ioState' + startedITimers_' = startedIntervalTimers ioState' + writeTVar ioStateT ioState'{ startedTimers = startedTimers_' + , startedIntervalTimers = startedITimers_' + } + + +timerTeardown :: Teardown +timerTeardown sharedConst sharedIO ioConst ioState + = do + let + allStartedTimers = (startedTimers ioState) ++ (startedIntervalTimers ioState) + allStartedIds = map fst allStartedTimers + sequence_ $ map (haltTimer allStartedTimers) allStartedIds + return sharedIO + + +registerTimer :: [StartedTimer] -> StartedTimer -> [StartedTimer] +registerTimer startedTimers startedTimer + = startedTimers ++ [startedTimer] + + +startTimer :: TickBuffer -> TimerId -> MicroSecondDelay -> TimerStartFunction -> IO StartedTimer +startTimer incTickBuff id delay startFunc + = do + timer <- newTimer + startFunc timer (tick id incTickBuff) ((usDelay.fromIntegral) delay) + return (id, timer) + + +unregisterTimer :: [StartedTimer] -> TimerId -> [StartedTimer] +unregisterTimer startedTimers id + = filter (\(id', _) -> id /= id') startedTimers + + +haltTimer :: [StartedTimer] -> TimerId -> IO () +haltTimer startedTimers id + = do + let + startedTimerM = findStartedTimer startedTimers id + stopAction (Just (_, timer)) = stopTimer timer + stopAction Nothing = return () + stopAction startedTimerM + + +findStartedTimer :: [StartedTimer] -> TimerId -> Maybe StartedTimer +findStartedTimer startedTimers id = find (\(id', timer) -> id == id') startedTimers + + +tick :: TimerId -> TickBuffer -> IO () tick id tickBuffer = putInBlockingConcurrentQueue tickBuffer (Tick id) diff --git a/src/Eventloop/Module/Timer/Types.hs b/src/Eventloop/Module/Timer/Types.hs --- a/src/Eventloop/Module/Timer/Types.hs +++ b/src/Eventloop/Module/Timer/Types.hs @@ -1,23 +1,23 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} -module Eventloop.Module.Timer.Types where - -import GHC.Generics (Generic) -import Control.DeepSeq - -import Control.Concurrent.Datastructures.BlockingConcurrentQueue -import Control.Concurrent.Timer -import Control.Concurrent.Suspend.Lifted - -type MicroSecondDelay = Int -- Microseconds -type TimerId = [Char] -type TickBuffer = BlockingConcurrentQueue TimerIn -type StartedTimer = (TimerId, TimerIO) -type TimerStartFunction = (TimerIO -> IO () -> Delay -> IO Bool) - -data TimerIn = Tick TimerId - deriving (Eq, Show) - -data TimerOut = SetTimer TimerId MicroSecondDelay - | SetIntervalTimer TimerId MicroSecondDelay - | UnsetTimer TimerId +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +module Eventloop.Module.Timer.Types where + +import GHC.Generics (Generic) +import Control.DeepSeq + +import Control.Concurrent.Datastructures.BlockingConcurrentQueue +import Control.Concurrent.Timer +import Control.Concurrent.Suspend.Lifted + +type MicroSecondDelay = Int -- Microseconds +type TimerId = [Char] +type TickBuffer = BlockingConcurrentQueue TimerIn +type StartedTimer = (TimerId, TimerIO) +type TimerStartFunction = (TimerIO -> IO () -> Delay -> IO Bool) + +data TimerIn = Tick TimerId + deriving (Eq, Show) + +data TimerOut = SetTimer TimerId MicroSecondDelay + | SetIntervalTimer TimerId MicroSecondDelay + | UnsetTimer TimerId deriving (Eq, Show, Generic, NFData) diff --git a/src/Eventloop/Module/Websocket/Canvas.hs b/src/Eventloop/Module/Websocket/Canvas.hs --- a/src/Eventloop/Module/Websocket/Canvas.hs +++ b/src/Eventloop/Module/Websocket/Canvas.hs @@ -1,7 +1,7 @@ -module Eventloop.Module.Websocket.Canvas - ( module Eventloop.Module.Websocket.Canvas.Canvas - , module Eventloop.Module.Websocket.Canvas.Types - ) where - -import Eventloop.Module.Websocket.Canvas.Canvas +module Eventloop.Module.Websocket.Canvas + ( module Eventloop.Module.Websocket.Canvas.Canvas + , module Eventloop.Module.Websocket.Canvas.Types + ) where + +import Eventloop.Module.Websocket.Canvas.Canvas import Eventloop.Module.Websocket.Canvas.Types diff --git a/src/Eventloop/Module/Websocket/Canvas/Canvas.hs b/src/Eventloop/Module/Websocket/Canvas/Canvas.hs --- a/src/Eventloop/Module/Websocket/Canvas/Canvas.hs +++ b/src/Eventloop/Module/Websocket/Canvas/Canvas.hs @@ -1,132 +1,132 @@ -module Eventloop.Module.Websocket.Canvas.Canvas - ( setupCanvasModuleConfiguration - , canvasModuleIdentifier - , canvasInitializer - , canvasEventRetriever - , canvasEventSender - ) where - - -import Control.Concurrent -import Control.Concurrent.MVar -import Control.Concurrent.SafePrint -import Control.Concurrent.Thread -import Data.Aeson -import Data.Maybe -import qualified Data.ByteString.Lazy.Char8 as LBS - -import Eventloop.Module.Websocket.Canvas.Types -import Eventloop.Module.Websocket.Canvas.JSONEncoding -import Eventloop.Types.Common -import Eventloop.Types.Events -import Eventloop.Types.System -import Eventloop.Utility.Config -import Eventloop.Utility.Websockets - - -setupCanvasModuleConfiguration :: EventloopSetupModuleConfiguration -setupCanvasModuleConfiguration = ( EventloopSetupModuleConfiguration - canvasModuleIdentifier - (Just canvasInitializer) - (Just canvasEventRetriever) - Nothing - Nothing - (Just canvasEventSender) - (Just canvasTeardown) - ) - - -canvasModuleIdentifier :: EventloopModuleIdentifier -canvasModuleIdentifier = "canvas" - - -canvasInitializer :: Initializer -canvasInitializer sharedConst sharedIO - = do - (clientSocket, clientConn, serverSock) <- setupWebsocketConnection iNADDR_ANY canvasPort - safePrintLn (safePrintToken sharedConst) "Canvas connection successfull!" - sysRecvBuffer <- newEmptyMVar - measureTextLock <- newMVar () - let - ioConst = CanvasConstants sysRecvBuffer clientSocket clientConn serverSock - measureText_' = measureText_ ioConst measureTextLock - sharedConst' = sharedConst{measureText = measureText_'} - return (sharedConst', sharedIO, ioConst, NoState) - - -canvasEventRetriever :: EventRetriever -canvasEventRetriever sharedConst sharedIOT ioConst ioStateT - = do - isConnected <- isConnected sock - case isConnected of - False -> return [] - True -> do - messageM <- takeMessage safePrintToken_ sock conn - case messageM of - Nothing -> return [] - (Just message) -> do - let - inRouted = fromJust.decode $ LBS.pack message - inCanvasM <- route sysBuffer inRouted - case inCanvasM of - Nothing -> return [] - (Just inCanvas) -> return [InCanvas inCanvas] - where - sock = clientSocket ioConst - conn = clientConnection ioConst - sysBuffer = canvasSystemReceiveBuffer ioConst - safePrintToken_ = safePrintToken sharedConst - - -canvasEventSender :: EventSender -canvasEventSender sharedConst sharedIOT ioConst ioStateT (OutCanvas canvasOut) - = sendRoutedMessageOut conn (OutUserCanvas canvasOut) - where - conn = clientConnection ioConst - -canvasEventSender sharedConst sharedIOT ioConst ioStateT Stop - = do - closeWebsocketConnection safePrintToken_ serverSock clientSock conn - where - serverSock = serverSocket ioConst - clientSock = clientSocket ioConst - conn = clientConnection ioConst - safePrintToken_ = safePrintToken sharedConst - - -canvasTeardown :: Teardown -canvasTeardown sharedConst sharedIO ioConst ioState - = do - destroyWebsocketConnection serverSock clientSock - return sharedIO - where - serverSock = serverSocket ioConst - clientSock = clientSocket ioConst - conn = clientConnection ioConst - - -sendRoutedMessageOut :: Connection -> RoutedMessageOut -> IO () -sendRoutedMessageOut conn out = writeMessage conn $ LBS.unpack $ encode out - - -route :: CanvasSystemReceiveBuffer -> RoutedMessageIn -> IO (Maybe CanvasIn) -route sysRecvBuffer routedIn - = case routedIn of - (InUserCanvas canvasIn) -> return (Just canvasIn) - (InSystemCanvas canvasIn) -> do - putMVar sysRecvBuffer canvasIn - return Nothing - - -measureText_ :: IOConstants -> MVar () -> CanvasText -> IO ScreenDimensions -measureText_ ioConst lock canvasText - = do - lock_ <- takeMVar lock - sendRoutedMessageOut conn outMsg - (SystemMeasuredText _ screenDims) <- takeMVar buf - putMVar lock lock_ - return screenDims - where - conn = clientConnection ioConst - buf = canvasSystemReceiveBuffer ioConst +module Eventloop.Module.Websocket.Canvas.Canvas + ( setupCanvasModuleConfiguration + , canvasModuleIdentifier + , canvasInitializer + , canvasEventRetriever + , canvasEventSender + ) where + + +import Control.Concurrent +import Control.Concurrent.MVar +import Control.Concurrent.SafePrint +import Control.Concurrent.Thread +import Data.Aeson +import Data.Maybe +import qualified Data.ByteString.Lazy.Char8 as LBS + +import Eventloop.Module.Websocket.Canvas.Types +import Eventloop.Module.Websocket.Canvas.JSONEncoding +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System +import Eventloop.Utility.Config +import Eventloop.Utility.Websockets + + +setupCanvasModuleConfiguration :: EventloopSetupModuleConfiguration +setupCanvasModuleConfiguration = ( EventloopSetupModuleConfiguration + canvasModuleIdentifier + (Just canvasInitializer) + (Just canvasEventRetriever) + Nothing + Nothing + (Just canvasEventSender) + (Just canvasTeardown) + ) + + +canvasModuleIdentifier :: EventloopModuleIdentifier +canvasModuleIdentifier = "canvas" + + +canvasInitializer :: Initializer +canvasInitializer sharedConst sharedIO + = do + (clientSocket, clientConn, serverSock) <- setupWebsocketConnection iNADDR_ANY canvasPort + safePrintLn (safePrintToken sharedConst) "Canvas connection successfull!" + sysRecvBuffer <- newEmptyMVar + measureTextLock <- newMVar () + let + ioConst = CanvasConstants sysRecvBuffer clientSocket clientConn serverSock + measureText_' = measureText_ ioConst measureTextLock + sharedConst' = sharedConst{measureText = measureText_'} + return (sharedConst', sharedIO, ioConst, NoState) + + +canvasEventRetriever :: EventRetriever +canvasEventRetriever sharedConst sharedIOT ioConst ioStateT + = do + isConnected <- isConnected sock + case isConnected of + False -> return [] + True -> do + messageM <- takeMessage safePrintToken_ sock conn + case messageM of + Nothing -> return [] + (Just message) -> do + let + inRouted = fromJust.decode $ LBS.pack message + inCanvasM <- route sysBuffer inRouted + case inCanvasM of + Nothing -> return [] + (Just inCanvas) -> return [InCanvas inCanvas] + where + sock = clientSocket ioConst + conn = clientConnection ioConst + sysBuffer = canvasSystemReceiveBuffer ioConst + safePrintToken_ = safePrintToken sharedConst + + +canvasEventSender :: EventSender +canvasEventSender sharedConst sharedIOT ioConst ioStateT (OutCanvas canvasOut) + = sendRoutedMessageOut conn (OutUserCanvas canvasOut) + where + conn = clientConnection ioConst + +canvasEventSender sharedConst sharedIOT ioConst ioStateT Stop + = do + closeWebsocketConnection safePrintToken_ serverSock clientSock conn + where + serverSock = serverSocket ioConst + clientSock = clientSocket ioConst + conn = clientConnection ioConst + safePrintToken_ = safePrintToken sharedConst + + +canvasTeardown :: Teardown +canvasTeardown sharedConst sharedIO ioConst ioState + = do + destroyWebsocketConnection serverSock clientSock + return sharedIO + where + serverSock = serverSocket ioConst + clientSock = clientSocket ioConst + conn = clientConnection ioConst + + +sendRoutedMessageOut :: Connection -> RoutedMessageOut -> IO () +sendRoutedMessageOut conn out = writeMessage conn $ LBS.unpack $ encode out + + +route :: CanvasSystemReceiveBuffer -> RoutedMessageIn -> IO (Maybe CanvasIn) +route sysRecvBuffer routedIn + = case routedIn of + (InUserCanvas canvasIn) -> return (Just canvasIn) + (InSystemCanvas canvasIn) -> do + putMVar sysRecvBuffer canvasIn + return Nothing + + +measureText_ :: IOConstants -> MVar () -> CanvasText -> IO ScreenDimensions +measureText_ ioConst lock canvasText + = do + lock_ <- takeMVar lock + sendRoutedMessageOut conn outMsg + (SystemMeasuredText _ screenDims) <- takeMVar buf + putMVar lock lock_ + return screenDims + where + conn = clientConnection ioConst + buf = canvasSystemReceiveBuffer ioConst outMsg = OutSystemCanvas $ SystemMeasureText canvasText diff --git a/src/Eventloop/Module/Websocket/Canvas/JSONEncoding.hs b/src/Eventloop/Module/Websocket/Canvas/JSONEncoding.hs --- a/src/Eventloop/Module/Websocket/Canvas/JSONEncoding.hs +++ b/src/Eventloop/Module/Websocket/Canvas/JSONEncoding.hs @@ -1,233 +1,233 @@ -{-# LANGUAGE OverloadedStrings #-} -module Eventloop.Module.Websocket.Canvas.JSONEncoding where - -import Data.Aeson -import Data.Aeson.Types -import Control.Applicative -import Control.Monad - -import Eventloop.Module.Websocket.Canvas.Types -import Eventloop.Module.Websocket.Canvas.Opcode - - -instance FromJSON RoutedMessageIn where - parseJSON (Object v) = do - route <- v .: "r" :: Parser [Char] - obj <- v .: "o" - case route of - "s" -> InSystemCanvas <$> (parseJSON obj) - "u" -> InUserCanvas <$> (parseJSON obj) - -instance FromJSON SystemCanvasIn where - parseJSON (Object v) = do - opCode <- v .: "t" :: Parser Int - case opCode of - 2101 -> SystemMeasuredText <$> (v .: "canvastext" >>= parseJSON) - <*> ( (\width height -> (width, height)) - <$> v .: "width" - <*> v .: "height" - ) - -instance FromJSON CanvasIn where - parseJSON (Object v) = do - opCode <- v .: "t" :: Parser Int - case opCode of - 101 -> MeasuredText <$> (v .: "canvastext" >>= parseJSON) - <*> ( (\width height -> (width, height)) - <$> v .: "width" - <*> v .: "height" - ) - -instance FromJSON CanvasText where - parseJSON (Object v) = CanvasText <$> v .: "text" <*> (v .: "font" >>= parseJSON) <*> (v .: "alignment" >>= parseJSON) - - -instance FromJSON Font where - parseJSON (Object v) = Font <$> v .: "fontfamily" <*> v .: "fontsize" - - -instance FromJSON Alignment where - parseJSON (Object v) = do - alignment <- v .: "t" :: Parser Int - return $ case alignment of - 1501 -> AlignLeft - 1502 -> AlignRight - 1503 -> AlignCenter - - - -operationObject :: Opcode -> [Value] -> Value -operationObject opcode [] = object ["t" .= opcode] -operationObject opcode encodedArguments = object ["t" .= opcode, "a" .= encodedArguments] - - -instance ToJSON RoutedMessageOut where - toJSON d@(OutUserCanvas canvasOut) = object ["r" .= route, "o" .= canvasOut] - where - route = "u" :: [Char] - toJSON d@(OutSystemCanvas canvasOut) = object ["r" .= route, "o" .= canvasOut] - where - route = "s" :: [Char] - - -instance ToJSON SystemCanvasOut where - toJSON d@(SystemMeasureText canvasText) = operationObject (toOpcode d) [ toJSON canvasText - ] - - -instance ToJSON CanvasOut where - toJSON d@(SetupCanvas canvasId zIndex screenDimensions cssPosition) = operationObject (toOpcode d) [ toJSON canvasId - , toJSON zIndex - , toJSON screenDimensions - , toJSON cssPosition - ] - toJSON d@(TeardownCanvas canvasId) = operationObject (toOpcode d) [toJSON canvasId] - toJSON d@(CanvasOperations canvasId canvasOperations) = operationObject (toOpcode d) [ toJSON canvasId - , toJSON canvasOperations - ] - toJSON d@(MeasureText text) = operationObject (toOpcode d) [ toJSON text - ] - - -instance ToJSON CanvasOperation where - toJSON d@(DrawPath screenStartingPoint screenPathParts pathStroke pathFill) = operationObject (toOpcode d) [ toJSON screenStartingPoint - , toJSON screenPathParts - , toJSON pathStroke - , toJSON pathFill - ] - toJSON d@(DrawText canvasText screenPoint textStroke textFill) = operationObject (toOpcode d) [ toJSON canvasText - , toJSON screenPoint - , toJSON textStroke - , toJSON textFill - ] - toJSON d@(DoTransform canvasTransform) = operationObject (toOpcode d) [toJSON canvasTransform] - toJSON d@(Clear clearPart) = operationObject (toOpcode d) [toJSON clearPart] - toJSON d@(Frame) = operationObject (toOpcode d) [] - - -instance ToJSON ScreenPathPart where - toJSON d@(MoveTo screenPoint) = operationObject (toOpcode d) [toJSON screenPoint] - toJSON d@(LineTo screenPoint) = operationObject (toOpcode d) [toJSON screenPoint] - toJSON d@(BezierCurveTo screenControlPoint1 screenControlPoint2 screenEndPoint) = operationObject (toOpcode d) [ toJSON screenControlPoint1 - , toJSON screenControlPoint2 - , toJSON screenEndPoint - ] - toJSON d@(QuadraticCurveTo screenControlPoint screenEndPoint) = operationObject (toOpcode d) [ toJSON screenControlPoint - , toJSON screenEndPoint - ] - toJSON d@(ArcTo screenControlPoint1 screenControlPoint2 screenRadius) = operationObject (toOpcode d) [ toJSON screenControlPoint1 - , toJSON screenControlPoint2 - , toJSON screenRadius - ] - toJSON d@(Arc screenCircle screenStartingAngle screenEndAngle) = operationObject (toOpcode d) [ toJSON screenCircle - , toJSON screenStartingAngle - , toJSON screenEndAngle - ] - toJSON d@(Rectangle screenPoint screenDimensions) = operationObject (toOpcode d) [ toJSON screenPoint - , toJSON screenDimensions - ] - toJSON d@(ClosePath) = operationObject (toOpcode d) [] - -instance ToJSON PathStroke where - toJSON d@(PathStroke screenLineThickness pathRenderStrokeStyle) = operationObject (toOpcode d) [ toJSON screenLineThickness - , toJSON pathRenderStrokeStyle - ] - toJSON d = operationObject (toOpcode d) [] - - -instance ToJSON PathFill where - toJSON d@(PathFill pathRenderFillStyle) = operationObject (toOpcode d) [toJSON pathRenderFillStyle] - toJSON d = operationObject (toOpcode d) [] - - -instance ToJSON RenderStyle where - toJSON d@(CanvasColor screenColor) = operationObject (toOpcode d) [toJSON screenColor] - toJSON d@(CanvasGradient canvasGradientType canvasColorStops) = operationObject (toOpcode d) [ toJSON canvasGradientType - , toJSON canvasColorStops - ] - - toJSON d@(CanvasPattern canvasImage patternRepetition) = operationObject (toOpcode d) [ toJSON canvasImage - , toJSON patternRepetition - ] - - -instance ToJSON CanvasImage where - toJSON d@(CanvasElement canvasId screenPoint screenDimensions) = operationObject (toOpcode d) [ toJSON canvasId - , toJSON screenPoint - , toJSON screenDimensions - ] - - toJSON d@(ImageData screenDimensions screenPixels) = operationObject (toOpcode d) [ toJSON screenDimensions - , toJSON screenPixels - ] - -instance ToJSON PatternRepetition where - toJSON d = operationObject (toOpcode d) [] - - -instance ToJSON CanvasGradientType where - toJSON d@(RadialGradient screenCircle1 screenCircle2) = operationObject (toOpcode d) [ toJSON screenCircle1 - , toJSON screenCircle2 - ] - - toJSON d@(LinearGradient screenPoint1 screenPoint2) = operationObject (toOpcode d) [ toJSON screenPoint1 - , toJSON screenPoint2 - ] - - -instance ToJSON CanvasText where - toJSON d@(CanvasText text font alignment) = operationObject (toOpcode d) [ toJSON text - , toJSON font - , toJSON alignment - ] - - -instance ToJSON Font where - toJSON d@(Font fontFamily fontSize) = operationObject (toOpcode d) [ toJSON fontFamily - , toJSON fontSize - ] - - -instance ToJSON TextStroke where - toJSON d@(TextStroke screenLineThickness textRenderStyle) = operationObject (toOpcode d) [ toJSON screenLineThickness - , toJSON textRenderStyle - ] - toJSON d@(NoTextStroke) = operationObject (toOpcode d) [] - -instance ToJSON TextFill where - toJSON d@(TextFill textRenderStyle) = operationObject (toOpcode d) [ toJSON textRenderStyle - ] - toJSON d@(NoTextFill) = operationObject (toOpcode d) [] - - -instance ToJSON Alignment where - toJSON d = operationObject (toOpcode d) [] - - -instance ToJSON CanvasTransform where - toJSON d@(Translate screenPoint) = operationObject (toOpcode d) [toJSON screenPoint] - toJSON d@(Rotate screenAngle) = operationObject (toOpcode d) [toJSON screenAngle] - toJSON d@(Scale x y) = operationObject (toOpcode d) [toJSON x, toJSON y] - toJSON d@(Transform tm) = operationObject (toOpcode d) [toJSON tm] - toJSON d@(SetTransform tm) = operationObject (toOpcode d) [toJSON tm] - toJSON d = operationObject (toOpcode d) [] - - -instance ToJSON CSSPosition where - toJSON d@(CSSPosition cssBindPoint cssMeasurements) = operationObject (toOpcode d) [ toJSON cssBindPoint - , toJSON cssMeasurements - ] - -instance ToJSON CSSBindPoint where - toJSON d = operationObject (toOpcode d) [] - -instance ToJSON CSSUnit where - toJSON d@(CSSPixels i) = operationObject (toOpcode d) [toJSON i] - toJSON d@(CSSPercentage i) = operationObject (toOpcode d) [toJSON i] - - -instance ToJSON ClearPart where - toJSON d@(ClearRectangle screenPoint screenDimensions) = operationObject (toOpcode d) [ toJSON screenPoint - , toJSON screenDimensions - ] +{-# LANGUAGE OverloadedStrings #-} +module Eventloop.Module.Websocket.Canvas.JSONEncoding where + +import Data.Aeson +import Data.Aeson.Types +import Control.Applicative +import Control.Monad + +import Eventloop.Module.Websocket.Canvas.Types +import Eventloop.Module.Websocket.Canvas.Opcode + + +instance FromJSON RoutedMessageIn where + parseJSON (Object v) = do + route <- v .: "r" :: Parser [Char] + obj <- v .: "o" + case route of + "s" -> InSystemCanvas <$> (parseJSON obj) + "u" -> InUserCanvas <$> (parseJSON obj) + +instance FromJSON SystemCanvasIn where + parseJSON (Object v) = do + opCode <- v .: "t" :: Parser Int + case opCode of + 2101 -> SystemMeasuredText <$> (v .: "canvastext" >>= parseJSON) + <*> ( (\width height -> (width, height)) + <$> v .: "width" + <*> v .: "height" + ) + +instance FromJSON CanvasIn where + parseJSON (Object v) = do + opCode <- v .: "t" :: Parser Int + case opCode of + 101 -> MeasuredText <$> (v .: "canvastext" >>= parseJSON) + <*> ( (\width height -> (width, height)) + <$> v .: "width" + <*> v .: "height" + ) + +instance FromJSON CanvasText where + parseJSON (Object v) = CanvasText <$> v .: "text" <*> (v .: "font" >>= parseJSON) <*> (v .: "alignment" >>= parseJSON) + + +instance FromJSON Font where + parseJSON (Object v) = Font <$> v .: "fontfamily" <*> v .: "fontsize" + + +instance FromJSON Alignment where + parseJSON (Object v) = do + alignment <- v .: "t" :: Parser Int + return $ case alignment of + 1501 -> AlignLeft + 1502 -> AlignRight + 1503 -> AlignCenter + + + +operationObject :: Opcode -> [Value] -> Value +operationObject opcode [] = object ["t" .= opcode] +operationObject opcode encodedArguments = object ["t" .= opcode, "a" .= encodedArguments] + + +instance ToJSON RoutedMessageOut where + toJSON d@(OutUserCanvas canvasOut) = object ["r" .= route, "o" .= canvasOut] + where + route = "u" :: [Char] + toJSON d@(OutSystemCanvas canvasOut) = object ["r" .= route, "o" .= canvasOut] + where + route = "s" :: [Char] + + +instance ToJSON SystemCanvasOut where + toJSON d@(SystemMeasureText canvasText) = operationObject (toOpcode d) [ toJSON canvasText + ] + + +instance ToJSON CanvasOut where + toJSON d@(SetupCanvas canvasId zIndex screenDimensions cssPosition) = operationObject (toOpcode d) [ toJSON canvasId + , toJSON zIndex + , toJSON screenDimensions + , toJSON cssPosition + ] + toJSON d@(TeardownCanvas canvasId) = operationObject (toOpcode d) [toJSON canvasId] + toJSON d@(CanvasOperations canvasId canvasOperations) = operationObject (toOpcode d) [ toJSON canvasId + , toJSON canvasOperations + ] + toJSON d@(MeasureText text) = operationObject (toOpcode d) [ toJSON text + ] + + +instance ToJSON CanvasOperation where + toJSON d@(DrawPath screenStartingPoint screenPathParts pathStroke pathFill) = operationObject (toOpcode d) [ toJSON screenStartingPoint + , toJSON screenPathParts + , toJSON pathStroke + , toJSON pathFill + ] + toJSON d@(DrawText canvasText screenPoint textStroke textFill) = operationObject (toOpcode d) [ toJSON canvasText + , toJSON screenPoint + , toJSON textStroke + , toJSON textFill + ] + toJSON d@(DoTransform canvasTransform) = operationObject (toOpcode d) [toJSON canvasTransform] + toJSON d@(Clear clearPart) = operationObject (toOpcode d) [toJSON clearPart] + toJSON d@(Frame) = operationObject (toOpcode d) [] + + +instance ToJSON ScreenPathPart where + toJSON d@(MoveTo screenPoint) = operationObject (toOpcode d) [toJSON screenPoint] + toJSON d@(LineTo screenPoint) = operationObject (toOpcode d) [toJSON screenPoint] + toJSON d@(BezierCurveTo screenControlPoint1 screenControlPoint2 screenEndPoint) = operationObject (toOpcode d) [ toJSON screenControlPoint1 + , toJSON screenControlPoint2 + , toJSON screenEndPoint + ] + toJSON d@(QuadraticCurveTo screenControlPoint screenEndPoint) = operationObject (toOpcode d) [ toJSON screenControlPoint + , toJSON screenEndPoint + ] + toJSON d@(ArcTo screenControlPoint1 screenControlPoint2 screenRadius) = operationObject (toOpcode d) [ toJSON screenControlPoint1 + , toJSON screenControlPoint2 + , toJSON screenRadius + ] + toJSON d@(Arc screenCircle screenStartingAngle screenEndAngle) = operationObject (toOpcode d) [ toJSON screenCircle + , toJSON screenStartingAngle + , toJSON screenEndAngle + ] + toJSON d@(Rectangle screenPoint screenDimensions) = operationObject (toOpcode d) [ toJSON screenPoint + , toJSON screenDimensions + ] + toJSON d@(ClosePath) = operationObject (toOpcode d) [] + +instance ToJSON PathStroke where + toJSON d@(PathStroke screenLineThickness pathRenderStrokeStyle) = operationObject (toOpcode d) [ toJSON screenLineThickness + , toJSON pathRenderStrokeStyle + ] + toJSON d = operationObject (toOpcode d) [] + + +instance ToJSON PathFill where + toJSON d@(PathFill pathRenderFillStyle) = operationObject (toOpcode d) [toJSON pathRenderFillStyle] + toJSON d = operationObject (toOpcode d) [] + + +instance ToJSON RenderStyle where + toJSON d@(CanvasColor screenColor) = operationObject (toOpcode d) [toJSON screenColor] + toJSON d@(CanvasGradient canvasGradientType canvasColorStops) = operationObject (toOpcode d) [ toJSON canvasGradientType + , toJSON canvasColorStops + ] + + toJSON d@(CanvasPattern canvasImage patternRepetition) = operationObject (toOpcode d) [ toJSON canvasImage + , toJSON patternRepetition + ] + + +instance ToJSON CanvasImage where + toJSON d@(CanvasElement canvasId screenPoint screenDimensions) = operationObject (toOpcode d) [ toJSON canvasId + , toJSON screenPoint + , toJSON screenDimensions + ] + + toJSON d@(ImageData screenDimensions screenPixels) = operationObject (toOpcode d) [ toJSON screenDimensions + , toJSON screenPixels + ] + +instance ToJSON PatternRepetition where + toJSON d = operationObject (toOpcode d) [] + + +instance ToJSON CanvasGradientType where + toJSON d@(RadialGradient screenCircle1 screenCircle2) = operationObject (toOpcode d) [ toJSON screenCircle1 + , toJSON screenCircle2 + ] + + toJSON d@(LinearGradient screenPoint1 screenPoint2) = operationObject (toOpcode d) [ toJSON screenPoint1 + , toJSON screenPoint2 + ] + + +instance ToJSON CanvasText where + toJSON d@(CanvasText text font alignment) = operationObject (toOpcode d) [ toJSON text + , toJSON font + , toJSON alignment + ] + + +instance ToJSON Font where + toJSON d@(Font fontFamily fontSize) = operationObject (toOpcode d) [ toJSON fontFamily + , toJSON fontSize + ] + + +instance ToJSON TextStroke where + toJSON d@(TextStroke screenLineThickness textRenderStyle) = operationObject (toOpcode d) [ toJSON screenLineThickness + , toJSON textRenderStyle + ] + toJSON d@(NoTextStroke) = operationObject (toOpcode d) [] + +instance ToJSON TextFill where + toJSON d@(TextFill textRenderStyle) = operationObject (toOpcode d) [ toJSON textRenderStyle + ] + toJSON d@(NoTextFill) = operationObject (toOpcode d) [] + + +instance ToJSON Alignment where + toJSON d = operationObject (toOpcode d) [] + + +instance ToJSON CanvasTransform where + toJSON d@(Translate screenPoint) = operationObject (toOpcode d) [toJSON screenPoint] + toJSON d@(Rotate screenAngle) = operationObject (toOpcode d) [toJSON screenAngle] + toJSON d@(Scale x y) = operationObject (toOpcode d) [toJSON x, toJSON y] + toJSON d@(Transform tm) = operationObject (toOpcode d) [toJSON tm] + toJSON d@(SetTransform tm) = operationObject (toOpcode d) [toJSON tm] + toJSON d = operationObject (toOpcode d) [] + + +instance ToJSON CSSPosition where + toJSON d@(CSSPosition cssBindPoint cssMeasurements) = operationObject (toOpcode d) [ toJSON cssBindPoint + , toJSON cssMeasurements + ] + +instance ToJSON CSSBindPoint where + toJSON d = operationObject (toOpcode d) [] + +instance ToJSON CSSUnit where + toJSON d@(CSSPixels i) = operationObject (toOpcode d) [toJSON i] + toJSON d@(CSSPercentage i) = operationObject (toOpcode d) [toJSON i] + + +instance ToJSON ClearPart where + toJSON d@(ClearRectangle screenPoint screenDimensions) = operationObject (toOpcode d) [ toJSON screenPoint + , toJSON screenDimensions + ] toJSON d = operationObject (toOpcode d) [] diff --git a/src/Eventloop/Module/Websocket/Canvas/Opcode.hs b/src/Eventloop/Module/Websocket/Canvas/Opcode.hs --- a/src/Eventloop/Module/Websocket/Canvas/Opcode.hs +++ b/src/Eventloop/Module/Websocket/Canvas/Opcode.hs @@ -1,104 +1,104 @@ -module Eventloop.Module.Websocket.Canvas.Opcode where - -import Eventloop.Module.Websocket.Canvas.Types - -class ToOpcode a where - toOpcode :: a -> Opcode - - -instance ToOpcode SystemCanvasOut where - toOpcode (SystemMeasureText _) = 2001 - -instance ToOpcode CanvasOut where - toOpcode (SetupCanvas _ _ _ _) = 201 - toOpcode (TeardownCanvas _) = 202 - toOpcode (CanvasOperations _ _) = 203 - toOpcode (MeasureText _) = 204 - -instance ToOpcode CanvasOperation where - toOpcode (DrawPath _ _ _ _) = 301 - toOpcode (DrawText _ _ _ _) = 302 - toOpcode (DoTransform _) = 303 - toOpcode (Clear _) = 304 - toOpcode (Frame) = 305 - -instance ToOpcode ScreenPathPart where - toOpcode (MoveTo _) = 401 - toOpcode (LineTo _) = 402 - toOpcode (BezierCurveTo _ _ _) = 403 - toOpcode (QuadraticCurveTo _ _) = 404 - toOpcode (ArcTo _ _ _) = 405 - toOpcode (Arc _ _ _) = 406 - toOpcode (Rectangle _ _) = 407 - toOpcode (ClosePath) = 408 - -instance ToOpcode PathStroke where - toOpcode (PathStroke _ _) = 501 - toOpcode (NoPathStroke) = 502 - -instance ToOpcode PathFill where - toOpcode (PathFill _) = 601 - toOpcode (NoPathFill) = 602 - -instance ToOpcode RenderStyle where - toOpcode (CanvasColor _) = 701 - toOpcode (CanvasGradient _ _) = 702 - toOpcode (CanvasPattern _ _) = 703 - -instance ToOpcode CanvasImage where - toOpcode (CanvasElement _ _ _) = 801 - toOpcode (ImageData _ _) = 802 - -instance ToOpcode PatternRepetition where - toOpcode (Repeat) = 901 - toOpcode (RepeatX) = 902 - toOpcode (RepeatY) = 903 - toOpcode (NoRepeat) = 0904 - -instance ToOpcode CanvasGradientType where - toOpcode (RadialGradient _ _) = 1001 - toOpcode (LinearGradient _ _) = 1002 - -instance ToOpcode CanvasText where - toOpcode (CanvasText _ _ _) = 1201 - -instance ToOpcode Font where - toOpcode (Font _ _) = 1301 - -instance ToOpcode TextStroke where - toOpcode (TextStroke _ _) = 1401 - toOpcode (NoTextStroke) = 1402 - -instance ToOpcode TextFill where - toOpcode (TextFill _) = 2401 - toOpcode (NoTextFill) = 2402 - -instance ToOpcode Alignment where - toOpcode (AlignLeft) = 1501 - toOpcode (AlignRight) = 1502 - toOpcode (AlignCenter) = 1503 - -instance ToOpcode CanvasTransform where - toOpcode (Save) = 1601 - toOpcode (Restore) = 1602 - toOpcode (Translate _) = 1603 - toOpcode (Rotate _) = 1604 - toOpcode (Scale _ _) = 1605 - toOpcode (Transform _) = 1606 - toOpcode (SetTransform _) = 1607 - toOpcode (ResetTransform) = 1608 - -instance ToOpcode CSSUnit where - toOpcode (CSSPixels _) = 1801 - toOpcode (CSSPercentage _) = 1802 - -instance ToOpcode ClearPart where - toOpcode (ClearRectangle _ _) = 1901 - toOpcode (ClearCanvas) = 1902 - -instance ToOpcode CSSPosition where - toOpcode (CSSPosition _ _) = 2201 - -instance ToOpcode CSSBindPoint where - toOpcode (CSSFromCenter) = 2301 - toOpcode (CSSFromDefault) = 2302 +module Eventloop.Module.Websocket.Canvas.Opcode where + +import Eventloop.Module.Websocket.Canvas.Types + +class ToOpcode a where + toOpcode :: a -> Opcode + + +instance ToOpcode SystemCanvasOut where + toOpcode (SystemMeasureText _) = 2001 + +instance ToOpcode CanvasOut where + toOpcode (SetupCanvas _ _ _ _) = 201 + toOpcode (TeardownCanvas _) = 202 + toOpcode (CanvasOperations _ _) = 203 + toOpcode (MeasureText _) = 204 + +instance ToOpcode CanvasOperation where + toOpcode (DrawPath _ _ _ _) = 301 + toOpcode (DrawText _ _ _ _) = 302 + toOpcode (DoTransform _) = 303 + toOpcode (Clear _) = 304 + toOpcode (Frame) = 305 + +instance ToOpcode ScreenPathPart where + toOpcode (MoveTo _) = 401 + toOpcode (LineTo _) = 402 + toOpcode (BezierCurveTo _ _ _) = 403 + toOpcode (QuadraticCurveTo _ _) = 404 + toOpcode (ArcTo _ _ _) = 405 + toOpcode (Arc _ _ _) = 406 + toOpcode (Rectangle _ _) = 407 + toOpcode (ClosePath) = 408 + +instance ToOpcode PathStroke where + toOpcode (PathStroke _ _) = 501 + toOpcode (NoPathStroke) = 502 + +instance ToOpcode PathFill where + toOpcode (PathFill _) = 601 + toOpcode (NoPathFill) = 602 + +instance ToOpcode RenderStyle where + toOpcode (CanvasColor _) = 701 + toOpcode (CanvasGradient _ _) = 702 + toOpcode (CanvasPattern _ _) = 703 + +instance ToOpcode CanvasImage where + toOpcode (CanvasElement _ _ _) = 801 + toOpcode (ImageData _ _) = 802 + +instance ToOpcode PatternRepetition where + toOpcode (Repeat) = 901 + toOpcode (RepeatX) = 902 + toOpcode (RepeatY) = 903 + toOpcode (NoRepeat) = 0904 + +instance ToOpcode CanvasGradientType where + toOpcode (RadialGradient _ _) = 1001 + toOpcode (LinearGradient _ _) = 1002 + +instance ToOpcode CanvasText where + toOpcode (CanvasText _ _ _) = 1201 + +instance ToOpcode Font where + toOpcode (Font _ _) = 1301 + +instance ToOpcode TextStroke where + toOpcode (TextStroke _ _) = 1401 + toOpcode (NoTextStroke) = 1402 + +instance ToOpcode TextFill where + toOpcode (TextFill _) = 2401 + toOpcode (NoTextFill) = 2402 + +instance ToOpcode Alignment where + toOpcode (AlignLeft) = 1501 + toOpcode (AlignRight) = 1502 + toOpcode (AlignCenter) = 1503 + +instance ToOpcode CanvasTransform where + toOpcode (Save) = 1601 + toOpcode (Restore) = 1602 + toOpcode (Translate _) = 1603 + toOpcode (Rotate _) = 1604 + toOpcode (Scale _ _) = 1605 + toOpcode (Transform _) = 1606 + toOpcode (SetTransform _) = 1607 + toOpcode (ResetTransform) = 1608 + +instance ToOpcode CSSUnit where + toOpcode (CSSPixels _) = 1801 + toOpcode (CSSPercentage _) = 1802 + +instance ToOpcode ClearPart where + toOpcode (ClearRectangle _ _) = 1901 + toOpcode (ClearCanvas) = 1902 + +instance ToOpcode CSSPosition where + toOpcode (CSSPosition _ _) = 2201 + +instance ToOpcode CSSBindPoint where + toOpcode (CSSFromCenter) = 2301 + toOpcode (CSSFromDefault) = 2302 diff --git a/src/Eventloop/Module/Websocket/Canvas/Types.hs b/src/Eventloop/Module/Websocket/Canvas/Types.hs --- a/src/Eventloop/Module/Websocket/Canvas/Types.hs +++ b/src/Eventloop/Module/Websocket/Canvas/Types.hs @@ -1,229 +1,229 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} -module Eventloop.Module.Websocket.Canvas.Types where - -import Control.Concurrent.MVar -import GHC.Generics (Generic) -import Control.DeepSeq - -import Eventloop.Types.Common - -type CanvasSystemReceiveBuffer = MVar SystemCanvasIn - -instance Show (MVar a) where - show _ = "CanvasSystemReceiveBuffer" - - -type Opcode = Int - -type ScreenMetric = Int -type ScreenX = ScreenMetric -type ScreenY = ScreenMetric -type ScreenWidth = ScreenMetric -type ScreenHeight = ScreenMetric -type ScreenRadius = ScreenMetric -type ScreenAngle = ScreenMetric -- ^In degrees - -type ScreenPoint = (ScreenX, ScreenY) -type ScreenDimensions = (ScreenWidth, ScreenHeight) - -type ScreenStartingPoint = ScreenPoint -type ScreenControlPoint = ScreenPoint -type ScreenEndPoint = ScreenPoint - -type ScreenStartingAngle = ScreenAngle -type ScreenEndAngle = ScreenAngle - -type CanvasId = NumericId -type ZIndex = Int - -type ScreenColorMetric = Int -type ScreenRed = ScreenColorMetric -type ScreenGreen = ScreenColorMetric -type ScreenBlue = ScreenColorMetric -type ScreenAlpha = Float -type ScreenColor = (ScreenRed, ScreenGreen, ScreenBlue, ScreenAlpha) -type ScreenPixel = ScreenColor - -type ColorStopOffset = Float - -type ScreenCircle = (ScreenPoint, ScreenRadius) - -type ScaleUnit = Float -type ScaleX = ScaleUnit -type ScaleY = ScaleUnit - -type ScreenLineThickness = Float - -type FontFamily = [Char] -type FontSize = Int -- In Pixels - - -data RoutedMessageIn = InUserCanvas CanvasIn - | InSystemCanvas SystemCanvasIn - deriving (Eq, Show) - -data RoutedMessageOut = OutUserCanvas CanvasOut - | OutSystemCanvas SystemCanvasOut - deriving (Eq, Show, Generic, NFData) - -{- |Opcode: 2100-} -data SystemCanvasIn = SystemMeasuredText CanvasText ScreenDimensions {- ^Opcode: 2101-} - deriving (Eq, Show) - -{- |Opcode: 2000-} -data SystemCanvasOut = SystemMeasureText CanvasText {- ^Opcode: 2001-} - deriving (Eq, Show, Generic, NFData) - -{- |Opcode: 0100-} -data CanvasIn = MeasuredText CanvasText ScreenDimensions {- ^Opcode: 0101-} - deriving (Eq, Show) - - -{- Main types -} -{- | Reserved type words - Type: t | Opcode - Arguments: a | List of arguments for that data type - Route: r | Either 's' for system or 'u' for user - Object: o | The object that is beneath - - Example: - {'r': 's', 'o': {SystemMeasuredText object}} - - SystemMeasuredText object: {'t':2102, 'a':[CanvasId, CanvasText object, ScreenDimensions]} --} - -{- |Opcode: 0200-} -data CanvasOut = SetupCanvas CanvasId ZIndex ScreenDimensions CSSPosition {- ^Opcode: 0201-} - | TeardownCanvas CanvasId {- ^Opcode: 0202-} - | CanvasOperations CanvasId [CanvasOperation] {- ^Opcode: 0203-} - | MeasureText CanvasText {- ^Opcode: 0204-} - deriving (Eq, Show, Generic, NFData) - -{- |Opcode: 0300-} -data CanvasOperation = DrawPath ScreenStartingPoint [ScreenPathPart] PathStroke PathFill {- ^Opcode: 0301 -} - | DrawText CanvasText ScreenPoint TextStroke TextFill {- ^Opcode: 0302 -} - | DoTransform CanvasTransform {- ^Opcode: 0303 -} - | Clear ClearPart {- ^Opcode: 0304 -} - | Frame {- ^Opcode: 0305 -} - deriving (Eq, Show, Generic, NFData) - -{- |Opcode: 0400-} -data ScreenPathPart = MoveTo ScreenPoint {- ^Opcode: 0401-} - | LineTo ScreenPoint {- ^Opcode: 0402-} - | BezierCurveTo ScreenControlPoint ScreenControlPoint ScreenEndPoint {- ^Opcode: 0403-} - | QuadraticCurveTo ScreenControlPoint ScreenEndPoint {- ^Opcode: 0404-} - | ArcTo ScreenControlPoint ScreenControlPoint ScreenRadius {- ^Opcode: 0405-} - | Arc ScreenCircle ScreenStartingAngle ScreenEndAngle {- ^Opcode: 0406-} - | Rectangle ScreenPoint ScreenDimensions {- ^Opcode: 0407-} - | ClosePath {- ^Opcode: 0408-} - deriving (Eq, Show, Generic, NFData) - -{- Styling of Shapes -} -{- |Opcode: 0500-} -type PathRenderStrokeStyle = RenderStyle - -data PathStroke = PathStroke ScreenLineThickness PathRenderStrokeStyle {- ^Opcode: 0501-} - | NoPathStroke {- ^Opcode: 0502-} - deriving (Eq, Show, Generic, NFData) - -{- |Opcode: 0600-} -type PathRenderFillStyle = RenderStyle - -data PathFill = PathFill PathRenderFillStyle {- ^Opcode: 0601-} - | NoPathFill {- ^Opcode: 0602-} - deriving (Eq, Show, Generic, NFData) - -{- |Opcode: 0700-} -type CanvasColorStop = (ColorStopOffset, ScreenColor) - -data RenderStyle = CanvasColor ScreenColor {- ^Opcode: 0701-} - | CanvasGradient CanvasGradientType [CanvasColorStop] {- ^Opcode:0702-} - | CanvasPattern CanvasImage PatternRepetition {- ^Opcode: 0703-} - deriving (Eq, Show, Generic, NFData) - -{- |Opcode: 0800-} -data CanvasImage = CanvasElement CanvasId ScreenPoint ScreenDimensions {- ^Opcode: 0801-} - | ImageData ScreenDimensions [ScreenPixel] {- ^Opcode: 0802 - [ScreenPixel] should be as long as width * height * 4. Each quad is red,green,blue,alpha - -} - deriving (Eq, Show, Generic, NFData) -{- |Opcode: 0900-} -data PatternRepetition = Repeat {- ^Opcode: 0901-} - | RepeatX {- ^Opcode: 0902-} - | RepeatY {- ^Opcode: 0903-} - | NoRepeat {- ^Opcode: 0904-} - deriving (Eq, Show, Generic, NFData) - -{- |Opcode: 1000-} -data CanvasGradientType = RadialGradient ScreenCircle ScreenCircle {- ^Opcode: 1001 - First circle = inner circle, Second circle is enclosing circle - -} - | LinearGradient ScreenPoint ScreenPoint {- ^Opcode: 1002-} - deriving (Eq, Show, Generic, NFData) - -{- To Draw Text -} -{- |Opcode: 1200-} -data CanvasText = CanvasText [Char] Font Alignment {- ^Opcode: 1201-} - deriving (Eq, Show, Generic, NFData) - -{- |Opcode: 1300-} -data Font = Font FontFamily FontSize {- ^Opcode: 1301-} - deriving (Eq, Show, Generic, NFData) - -{- |Opcode: 1400-} -type TextStrokeRenderStyle = RenderStyle -type TextFillRenderStyle = RenderStyle - -data TextStroke = TextStroke ScreenLineThickness TextStrokeRenderStyle {- ^Opcode: 1401-} - | NoTextStroke {- ^Opcode: 1402-} - deriving (Eq, Show, Generic, NFData) - -{- |Opcode: 2400-} -data TextFill = TextFill TextFillRenderStyle {- ^Opcode: 2401-} - | NoTextFill {- ^Opcode: 2402-} - deriving (Eq, Show, Generic, NFData) - -{- |Opcode: 1500-} -data Alignment = AlignLeft {- ^Opcode: 1501-} - | AlignRight {- ^Opcode: 1502-} - | AlignCenter {- ^Opcode: 1503-} - deriving (Eq, Show, Generic, NFData) - -{- Transform The Canvas -} -{- |Opcode: 1600-} -type TransformUnit = Float -type TransformationMatrix = (TransformUnit, TransformUnit, TransformUnit, TransformUnit, TransformUnit, TransformUnit) - -data CanvasTransform = Save {- ^Opcode: 1601-} - | Restore {- ^Opcode: 1602-} - | Translate ScreenPoint {- ^Opcode: 1603-} - | Rotate ScreenAngle {- ^Opcode: 1604-} - | Scale ScaleX ScaleY {- ^Opcode: 1605-} - | Transform TransformationMatrix {- ^Opcode: 1606-} - | SetTransform TransformationMatrix {- ^Opcode: 1607-} - | ResetTransform {- ^Opcode: 1608-} - deriving (Eq, Show, Generic, NFData) - -{- CSS Position of DOM elements -} -{- |Opcode: 2200-} -type CSSLeftOffset = CSSUnit -type CSSTopOffset = CSSUnit -type CSSMeasurements = (CSSLeftOffset, CSSTopOffset) - -data CSSPosition = CSSPosition CSSBindPoint CSSMeasurements {- ^Opcode: 2201-} - deriving (Eq, Show, Generic, NFData) - -{- |Opcode: 2300-} -data CSSBindPoint = CSSFromCenter {- ^Opcode: 2301-} - | CSSFromDefault {- ^Opcode: 2302 Usually this is the top left corner of the element -} - deriving (Eq, Show, Generic, NFData) - -{- |Opcode: 1800-} -data CSSUnit = CSSPixels Int {- ^Opcode: 1801-} - | CSSPercentage Int {- ^Opcode: 1802-} - deriving (Eq, Show, Generic, NFData) - -{- |Opcode: 1900 -} -data ClearPart = ClearRectangle ScreenPoint ScreenDimensions {- ^Opcode: 1901-} - | ClearCanvas {- ^Opcode: 1902-} +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +module Eventloop.Module.Websocket.Canvas.Types where + +import Control.Concurrent.MVar +import GHC.Generics (Generic) +import Control.DeepSeq + +import Eventloop.Types.Common + +type CanvasSystemReceiveBuffer = MVar SystemCanvasIn + +instance Show (MVar a) where + show _ = "CanvasSystemReceiveBuffer" + + +type Opcode = Int + +type ScreenMetric = Int +type ScreenX = ScreenMetric +type ScreenY = ScreenMetric +type ScreenWidth = ScreenMetric +type ScreenHeight = ScreenMetric +type ScreenRadius = ScreenMetric +type ScreenAngle = ScreenMetric -- ^In degrees + +type ScreenPoint = (ScreenX, ScreenY) +type ScreenDimensions = (ScreenWidth, ScreenHeight) + +type ScreenStartingPoint = ScreenPoint +type ScreenControlPoint = ScreenPoint +type ScreenEndPoint = ScreenPoint + +type ScreenStartingAngle = ScreenAngle +type ScreenEndAngle = ScreenAngle + +type CanvasId = NumericId +type ZIndex = Int + +type ScreenColorMetric = Int +type ScreenRed = ScreenColorMetric +type ScreenGreen = ScreenColorMetric +type ScreenBlue = ScreenColorMetric +type ScreenAlpha = Float +type ScreenColor = (ScreenRed, ScreenGreen, ScreenBlue, ScreenAlpha) +type ScreenPixel = ScreenColor + +type ColorStopOffset = Float + +type ScreenCircle = (ScreenPoint, ScreenRadius) + +type ScaleUnit = Float +type ScaleX = ScaleUnit +type ScaleY = ScaleUnit + +type ScreenLineThickness = Float + +type FontFamily = [Char] +type FontSize = Int -- In Pixels + + +data RoutedMessageIn = InUserCanvas CanvasIn + | InSystemCanvas SystemCanvasIn + deriving (Eq, Show) + +data RoutedMessageOut = OutUserCanvas CanvasOut + | OutSystemCanvas SystemCanvasOut + deriving (Eq, Show, Generic, NFData) + +{- |Opcode: 2100-} +data SystemCanvasIn = SystemMeasuredText CanvasText ScreenDimensions {- ^Opcode: 2101-} + deriving (Eq, Show) + +{- |Opcode: 2000-} +data SystemCanvasOut = SystemMeasureText CanvasText {- ^Opcode: 2001-} + deriving (Eq, Show, Generic, NFData) + +{- |Opcode: 0100-} +data CanvasIn = MeasuredText CanvasText ScreenDimensions {- ^Opcode: 0101-} + deriving (Eq, Show) + + +{- Main types -} +{- | Reserved type words + Type: t | Opcode + Arguments: a | List of arguments for that data type + Route: r | Either 's' for system or 'u' for user + Object: o | The object that is beneath + + Example: + {'r': 's', 'o': {SystemMeasuredText object}} + + SystemMeasuredText object: {'t':2102, 'a':[CanvasId, CanvasText object, ScreenDimensions]} +-} + +{- |Opcode: 0200-} +data CanvasOut = SetupCanvas CanvasId ZIndex ScreenDimensions CSSPosition {- ^Opcode: 0201-} + | TeardownCanvas CanvasId {- ^Opcode: 0202-} + | CanvasOperations CanvasId [CanvasOperation] {- ^Opcode: 0203-} + | MeasureText CanvasText {- ^Opcode: 0204-} + deriving (Eq, Show, Generic, NFData) + +{- |Opcode: 0300-} +data CanvasOperation = DrawPath ScreenStartingPoint [ScreenPathPart] PathStroke PathFill {- ^Opcode: 0301 -} + | DrawText CanvasText ScreenPoint TextStroke TextFill {- ^Opcode: 0302 -} + | DoTransform CanvasTransform {- ^Opcode: 0303 -} + | Clear ClearPart {- ^Opcode: 0304 -} + | Frame {- ^Opcode: 0305 -} + deriving (Eq, Show, Generic, NFData) + +{- |Opcode: 0400-} +data ScreenPathPart = MoveTo ScreenPoint {- ^Opcode: 0401-} + | LineTo ScreenPoint {- ^Opcode: 0402-} + | BezierCurveTo ScreenControlPoint ScreenControlPoint ScreenEndPoint {- ^Opcode: 0403-} + | QuadraticCurveTo ScreenControlPoint ScreenEndPoint {- ^Opcode: 0404-} + | ArcTo ScreenControlPoint ScreenControlPoint ScreenRadius {- ^Opcode: 0405-} + | Arc ScreenCircle ScreenStartingAngle ScreenEndAngle {- ^Opcode: 0406-} + | Rectangle ScreenPoint ScreenDimensions {- ^Opcode: 0407-} + | ClosePath {- ^Opcode: 0408-} + deriving (Eq, Show, Generic, NFData) + +{- Styling of Shapes -} +{- |Opcode: 0500-} +type PathRenderStrokeStyle = RenderStyle + +data PathStroke = PathStroke ScreenLineThickness PathRenderStrokeStyle {- ^Opcode: 0501-} + | NoPathStroke {- ^Opcode: 0502-} + deriving (Eq, Show, Generic, NFData) + +{- |Opcode: 0600-} +type PathRenderFillStyle = RenderStyle + +data PathFill = PathFill PathRenderFillStyle {- ^Opcode: 0601-} + | NoPathFill {- ^Opcode: 0602-} + deriving (Eq, Show, Generic, NFData) + +{- |Opcode: 0700-} +type CanvasColorStop = (ColorStopOffset, ScreenColor) + +data RenderStyle = CanvasColor ScreenColor {- ^Opcode: 0701-} + | CanvasGradient CanvasGradientType [CanvasColorStop] {- ^Opcode:0702-} + | CanvasPattern CanvasImage PatternRepetition {- ^Opcode: 0703-} + deriving (Eq, Show, Generic, NFData) + +{- |Opcode: 0800-} +data CanvasImage = CanvasElement CanvasId ScreenPoint ScreenDimensions {- ^Opcode: 0801-} + | ImageData ScreenDimensions [ScreenPixel] {- ^Opcode: 0802 + [ScreenPixel] should be as long as width * height * 4. Each quad is red,green,blue,alpha + -} + deriving (Eq, Show, Generic, NFData) +{- |Opcode: 0900-} +data PatternRepetition = Repeat {- ^Opcode: 0901-} + | RepeatX {- ^Opcode: 0902-} + | RepeatY {- ^Opcode: 0903-} + | NoRepeat {- ^Opcode: 0904-} + deriving (Eq, Show, Generic, NFData) + +{- |Opcode: 1000-} +data CanvasGradientType = RadialGradient ScreenCircle ScreenCircle {- ^Opcode: 1001 + First circle = inner circle, Second circle is enclosing circle + -} + | LinearGradient ScreenPoint ScreenPoint {- ^Opcode: 1002-} + deriving (Eq, Show, Generic, NFData) + +{- To Draw Text -} +{- |Opcode: 1200-} +data CanvasText = CanvasText [Char] Font Alignment {- ^Opcode: 1201-} + deriving (Eq, Show, Generic, NFData) + +{- |Opcode: 1300-} +data Font = Font FontFamily FontSize {- ^Opcode: 1301-} + deriving (Eq, Show, Generic, NFData) + +{- |Opcode: 1400-} +type TextStrokeRenderStyle = RenderStyle +type TextFillRenderStyle = RenderStyle + +data TextStroke = TextStroke ScreenLineThickness TextStrokeRenderStyle {- ^Opcode: 1401-} + | NoTextStroke {- ^Opcode: 1402-} + deriving (Eq, Show, Generic, NFData) + +{- |Opcode: 2400-} +data TextFill = TextFill TextFillRenderStyle {- ^Opcode: 2401-} + | NoTextFill {- ^Opcode: 2402-} + deriving (Eq, Show, Generic, NFData) + +{- |Opcode: 1500-} +data Alignment = AlignLeft {- ^Opcode: 1501-} + | AlignRight {- ^Opcode: 1502-} + | AlignCenter {- ^Opcode: 1503-} + deriving (Eq, Show, Generic, NFData) + +{- Transform The Canvas -} +{- |Opcode: 1600-} +type TransformUnit = Float +type TransformationMatrix = (TransformUnit, TransformUnit, TransformUnit, TransformUnit, TransformUnit, TransformUnit) + +data CanvasTransform = Save {- ^Opcode: 1601-} + | Restore {- ^Opcode: 1602-} + | Translate ScreenPoint {- ^Opcode: 1603-} + | Rotate ScreenAngle {- ^Opcode: 1604-} + | Scale ScaleX ScaleY {- ^Opcode: 1605-} + | Transform TransformationMatrix {- ^Opcode: 1606-} + | SetTransform TransformationMatrix {- ^Opcode: 1607-} + | ResetTransform {- ^Opcode: 1608-} + deriving (Eq, Show, Generic, NFData) + +{- CSS Position of DOM elements -} +{- |Opcode: 2200-} +type CSSLeftOffset = CSSUnit +type CSSTopOffset = CSSUnit +type CSSMeasurements = (CSSLeftOffset, CSSTopOffset) + +data CSSPosition = CSSPosition CSSBindPoint CSSMeasurements {- ^Opcode: 2201-} + deriving (Eq, Show, Generic, NFData) + +{- |Opcode: 2300-} +data CSSBindPoint = CSSFromCenter {- ^Opcode: 2301-} + | CSSFromDefault {- ^Opcode: 2302 Usually this is the top left corner of the element -} + deriving (Eq, Show, Generic, NFData) + +{- |Opcode: 1800-} +data CSSUnit = CSSPixels Int {- ^Opcode: 1801-} + | CSSPercentage Int {- ^Opcode: 1802-} + deriving (Eq, Show, Generic, NFData) + +{- |Opcode: 1900 -} +data ClearPart = ClearRectangle ScreenPoint ScreenDimensions {- ^Opcode: 1901-} + | ClearCanvas {- ^Opcode: 1902-} deriving (Eq, Show, Generic, NFData) diff --git a/src/Eventloop/Module/Websocket/Keyboard.hs b/src/Eventloop/Module/Websocket/Keyboard.hs --- a/src/Eventloop/Module/Websocket/Keyboard.hs +++ b/src/Eventloop/Module/Websocket/Keyboard.hs @@ -1,7 +1,7 @@ -module Eventloop.Module.Websocket.Keyboard - ( module Eventloop.Module.Websocket.Keyboard.Keyboard - , module Eventloop.Module.Websocket.Keyboard.Types - ) where - -import Eventloop.Module.Websocket.Keyboard.Keyboard +module Eventloop.Module.Websocket.Keyboard + ( module Eventloop.Module.Websocket.Keyboard.Keyboard + , module Eventloop.Module.Websocket.Keyboard.Types + ) where + +import Eventloop.Module.Websocket.Keyboard.Keyboard import Eventloop.Module.Websocket.Keyboard.Types diff --git a/src/Eventloop/Module/Websocket/Keyboard/Keyboard.hs b/src/Eventloop/Module/Websocket/Keyboard/Keyboard.hs --- a/src/Eventloop/Module/Websocket/Keyboard/Keyboard.hs +++ b/src/Eventloop/Module/Websocket/Keyboard/Keyboard.hs @@ -1,92 +1,92 @@ - {-# LANGUAGE OverloadedStrings #-} -module Eventloop.Module.Websocket.Keyboard.Keyboard - ( setupKeyboardModuleConfiguration - , keyboardModuleIdentifier - , keyboardInitializer - , keyboardEventRetriever - , keyboardEventSender - ) where - -import Data.Aeson -import Data.Maybe -import Control.Applicative -import Control.Concurrent.MVar -import Control.Concurrent.SafePrint -import qualified Data.ByteString.Lazy.Char8 as BL - -import Eventloop.Types.Common -import Eventloop.Types.Events -import Eventloop.Types.System -import Eventloop.Module.Websocket.Keyboard.Types -import Eventloop.Utility.Config -import Eventloop.Utility.Websockets - - -setupKeyboardModuleConfiguration :: EventloopSetupModuleConfiguration -setupKeyboardModuleConfiguration = ( EventloopSetupModuleConfiguration - keyboardModuleIdentifier - (Just keyboardInitializer) - (Just keyboardEventRetriever) - Nothing - Nothing - (Just keyboardEventSender) - Nothing - ) - - -keyboardModuleIdentifier :: EventloopModuleIdentifier -keyboardModuleIdentifier = "keyboard" - - -instance FromJSON Keyboard where - parseJSON (Object v) = Key <$> v .: "key" - - -keyboardInitializer :: Initializer -keyboardInitializer sharedConst sharedIO - = do - (clientSocket, clientConn, serverSock) <- setupWebsocketConnection iNADDR_ANY keyboardPort - safePrintLn (safePrintToken sharedConst) "Keyboard connection successfull" - return (sharedConst, sharedIO, KeyboardConstants clientSocket clientConn serverSock, NoState) - - -keyboardEventRetriever :: EventRetriever -keyboardEventRetriever sharedConst sharedIOT ioConst ioStateT - = do - isConnected <- isConnected sock - case isConnected of - False -> return [] - True -> do - messageM <- takeMessage safePrintToken_ sock conn - case messageM of - Nothing -> return [] - (Just message) -> return [InKeyboard $ messageToKeyboardIn message] - where - sock = clientSocket ioConst - conn = clientConnection ioConst - safePrintToken_ = safePrintToken sharedConst - - -messageToKeyboardIn :: Message -> Keyboard -messageToKeyboardIn message = fromJust.decode $ BL.pack message - - -keyboardEventSender :: EventSender -keyboardEventSender sharedConst sharedIOT ioConst ioStateT Stop - = do - closeWebsocketConnection safePrintToken_ serverSock clientSock conn - where - serverSock = serverSocket ioConst - clientSock = clientSocket ioConst - conn = clientConnection ioConst - safePrintToken_ = safePrintToken sharedConst - -keyboardTeardown :: Teardown -keyboardTeardown sharedConst sharedIO ioConst ioState - = do - destroyWebsocketConnection serverSock clientSock - return sharedIO - where - serverSock = serverSocket ioConst - clientSock = clientSocket ioConst + {-# LANGUAGE OverloadedStrings #-} +module Eventloop.Module.Websocket.Keyboard.Keyboard + ( setupKeyboardModuleConfiguration + , keyboardModuleIdentifier + , keyboardInitializer + , keyboardEventRetriever + , keyboardEventSender + ) where + +import Data.Aeson +import Data.Maybe +import Control.Applicative +import Control.Concurrent.MVar +import Control.Concurrent.SafePrint +import qualified Data.ByteString.Lazy.Char8 as BL + +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System +import Eventloop.Module.Websocket.Keyboard.Types +import Eventloop.Utility.Config +import Eventloop.Utility.Websockets + + +setupKeyboardModuleConfiguration :: EventloopSetupModuleConfiguration +setupKeyboardModuleConfiguration = ( EventloopSetupModuleConfiguration + keyboardModuleIdentifier + (Just keyboardInitializer) + (Just keyboardEventRetriever) + Nothing + Nothing + (Just keyboardEventSender) + Nothing + ) + + +keyboardModuleIdentifier :: EventloopModuleIdentifier +keyboardModuleIdentifier = "keyboard" + + +instance FromJSON Keyboard where + parseJSON (Object v) = Key <$> v .: "key" + + +keyboardInitializer :: Initializer +keyboardInitializer sharedConst sharedIO + = do + (clientSocket, clientConn, serverSock) <- setupWebsocketConnection iNADDR_ANY keyboardPort + safePrintLn (safePrintToken sharedConst) "Keyboard connection successfull" + return (sharedConst, sharedIO, KeyboardConstants clientSocket clientConn serverSock, NoState) + + +keyboardEventRetriever :: EventRetriever +keyboardEventRetriever sharedConst sharedIOT ioConst ioStateT + = do + isConnected <- isConnected sock + case isConnected of + False -> return [] + True -> do + messageM <- takeMessage safePrintToken_ sock conn + case messageM of + Nothing -> return [] + (Just message) -> return [InKeyboard $ messageToKeyboardIn message] + where + sock = clientSocket ioConst + conn = clientConnection ioConst + safePrintToken_ = safePrintToken sharedConst + + +messageToKeyboardIn :: Message -> Keyboard +messageToKeyboardIn message = fromJust.decode $ BL.pack message + + +keyboardEventSender :: EventSender +keyboardEventSender sharedConst sharedIOT ioConst ioStateT Stop + = do + closeWebsocketConnection safePrintToken_ serverSock clientSock conn + where + serverSock = serverSocket ioConst + clientSock = clientSocket ioConst + conn = clientConnection ioConst + safePrintToken_ = safePrintToken sharedConst + +keyboardTeardown :: Teardown +keyboardTeardown sharedConst sharedIO ioConst ioState + = do + destroyWebsocketConnection serverSock clientSock + return sharedIO + where + serverSock = serverSocket ioConst + clientSock = clientSocket ioConst conn = clientConnection ioConst diff --git a/src/Eventloop/Module/Websocket/Keyboard/Types.hs b/src/Eventloop/Module/Websocket/Keyboard/Types.hs --- a/src/Eventloop/Module/Websocket/Keyboard/Types.hs +++ b/src/Eventloop/Module/Websocket/Keyboard/Types.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} -module Eventloop.Module.Websocket.Keyboard.Types where - -import GHC.Generics (Generic) -import Control.DeepSeq - -{-| Almost all key presses are registered including modifier keys. - Expect character keys to come in as their character. Press a c, get - a "c". If a modifier is used and a different character is expected, - it will be that instead. Press shift + c, get a "C". Modifiers are also - sent as their string representation: "shift", "ctrl" or "alt". Space is - expected as "space". -} -data Keyboard = Key [Char] +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +module Eventloop.Module.Websocket.Keyboard.Types where + +import GHC.Generics (Generic) +import Control.DeepSeq + +{-| Almost all key presses are registered including modifier keys. + Expect character keys to come in as their character. Press a c, get + a "c". If a modifier is used and a different character is expected, + it will be that instead. Press shift + c, get a "C". Modifiers are also + sent as their string representation: "shift", "ctrl" or "alt". Space is + expected as "space". -} +data Keyboard = Key [Char] deriving (Eq, Show, Generic, NFData) diff --git a/src/Eventloop/Module/Websocket/Mouse.hs b/src/Eventloop/Module/Websocket/Mouse.hs --- a/src/Eventloop/Module/Websocket/Mouse.hs +++ b/src/Eventloop/Module/Websocket/Mouse.hs @@ -1,7 +1,7 @@ -module Eventloop.Module.Websocket.Mouse - ( module Eventloop.Module.Websocket.Mouse.Mouse - , module Eventloop.Module.Websocket.Mouse.Types - ) where - -import Eventloop.Module.Websocket.Mouse.Mouse +module Eventloop.Module.Websocket.Mouse + ( module Eventloop.Module.Websocket.Mouse.Mouse + , module Eventloop.Module.Websocket.Mouse.Types + ) where + +import Eventloop.Module.Websocket.Mouse.Mouse import Eventloop.Module.Websocket.Mouse.Types diff --git a/src/Eventloop/Module/Websocket/Mouse/Mouse.hs b/src/Eventloop/Module/Websocket/Mouse/Mouse.hs --- a/src/Eventloop/Module/Websocket/Mouse/Mouse.hs +++ b/src/Eventloop/Module/Websocket/Mouse/Mouse.hs @@ -1,137 +1,137 @@ -{-# LANGUAGE OverloadedStrings #-} -module Eventloop.Module.Websocket.Mouse.Mouse - ( setupMouseModuleConfiguration - , mouseModuleIdentifier - , mouseInitializer - , mouseEventRetriever - , mouseEventSender - ) where - -import Control.Applicative -import Control.Monad -import Control.Concurrent.MVar -import Control.Concurrent.SafePrint -import Data.Aeson -import Data.Aeson.Types -import qualified Data.ByteString.Lazy.Char8 as BL -import Data.Maybe - -import Eventloop.Module.Websocket.Mouse.Types -import Eventloop.Types.Common -import Eventloop.Types.Events -import Eventloop.Types.System -import Eventloop.Utility.Websockets -import Eventloop.Utility.Config -import Eventloop.Utility.Vectors - -setupMouseModuleConfiguration :: EventloopSetupModuleConfiguration -setupMouseModuleConfiguration = ( EventloopSetupModuleConfiguration - mouseModuleIdentifier - (Just mouseInitializer) - (Just mouseEventRetriever) - Nothing - Nothing - (Just mouseEventSender) - Nothing - ) - - -mouseModuleIdentifier :: EventloopModuleIdentifier -mouseModuleIdentifier = "mouse" - - -instance FromJSON MouseIn where - parseJSON vO@(Object v) - = do - mouseEvent <- parseJSON vO :: Parser MouseEvent - mouseType <- parseJSON vO :: Parser MouseType - point <- parseJSON vO :: Parser Point - id <- v .: "id" :: Parser NumericId - return $ Mouse mouseType id mouseEvent point - - -instance FromJSON MouseType where - parseJSON (Object v) - = do - type' <- v .: "elementType" :: Parser String - return $ case type' of "canvas" -> MouseCanvas - "svg" -> MouseSVG - -instance FromJSON MouseEvent where - parseJSON (Object v) - = do - eventType <- v .: "mouseEventType" :: Parser String - button <- parseJSON (Object v) :: Parser MouseButton - return $ case eventType of "click" -> Click button - "dblclick" -> DoubleClick button - "mousedown" -> MouseDown button - "mouseup" -> MouseUp button - "mouseenter" -> MouseEnter - "mouseleave" -> MouseLeave - "mousemove" -> MouseMove - -instance FromJSON MouseButton where - parseJSON (Object v) - = do - button <- v .: "button" :: Parser String - return $ case button of "left" -> MouseLeft - "middle" -> MouseMiddle - "right" -> MouseRight - -instance FromJSON Point where - parseJSON (Object v) - = do - x <- v .: "x" - y <- v .: "y" - return $ Point (x, y) - - -mouseInitializer :: Initializer -mouseInitializer sharedConst sharedIO - = do - (clientSocket, clientConn, serverSock) <- setupWebsocketConnection iNADDR_ANY mousePort - safePrintLn (safePrintToken sharedConst) "Mouse connection succesfull" - return (sharedConst, sharedIO, MouseConstants clientSocket clientConn serverSock, NoState) - - -mouseEventRetriever :: EventRetriever -mouseEventRetriever sharedConst sharedIOT ioConst ioStateT - = do - isConnected <- isConnected sock - case isConnected of - False -> return [] - True -> do - messageM <- takeMessage safePrintToken_ sock conn - case messageM of - Nothing -> return [] - (Just message) -> return [InMouse $ messageToMouseIn message] - where - sock = clientSocket ioConst - conn = clientConnection ioConst - safePrintToken_ = safePrintToken sharedConst - - -messageToMouseIn :: Message -> MouseIn -messageToMouseIn message = fromJust.decode $ BL.pack message - - -mouseEventSender :: EventSender -mouseEventSender sharedConst sharedIOT ioConst ioStateT Stop - = do - closeWebsocketConnection safePrintToken_ serverSock clientSock conn - where - serverSock = serverSocket ioConst - clientSock = clientSocket ioConst - conn = clientConnection ioConst - safePrintToken_ = safePrintToken sharedConst - - -mouseTeardown :: Teardown -mouseTeardown sharedConst sharedIO ioConst ioState - = do - destroyWebsocketConnection serverSock clientSock - return sharedIO - where - serverSock = serverSocket ioConst - clientSock = clientSocket ioConst +{-# LANGUAGE OverloadedStrings #-} +module Eventloop.Module.Websocket.Mouse.Mouse + ( setupMouseModuleConfiguration + , mouseModuleIdentifier + , mouseInitializer + , mouseEventRetriever + , mouseEventSender + ) where + +import Control.Applicative +import Control.Monad +import Control.Concurrent.MVar +import Control.Concurrent.SafePrint +import Data.Aeson +import Data.Aeson.Types +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Maybe + +import Eventloop.Module.Websocket.Mouse.Types +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.System +import Eventloop.Utility.Websockets +import Eventloop.Utility.Config +import Eventloop.Utility.Vectors + +setupMouseModuleConfiguration :: EventloopSetupModuleConfiguration +setupMouseModuleConfiguration = ( EventloopSetupModuleConfiguration + mouseModuleIdentifier + (Just mouseInitializer) + (Just mouseEventRetriever) + Nothing + Nothing + (Just mouseEventSender) + Nothing + ) + + +mouseModuleIdentifier :: EventloopModuleIdentifier +mouseModuleIdentifier = "mouse" + + +instance FromJSON MouseIn where + parseJSON vO@(Object v) + = do + mouseEvent <- parseJSON vO :: Parser MouseEvent + mouseType <- parseJSON vO :: Parser MouseType + point <- parseJSON vO :: Parser Point + id <- v .: "id" :: Parser NumericId + return $ Mouse mouseType id mouseEvent point + + +instance FromJSON MouseType where + parseJSON (Object v) + = do + type' <- v .: "elementType" :: Parser String + return $ case type' of "canvas" -> MouseCanvas + "svg" -> MouseSVG + +instance FromJSON MouseEvent where + parseJSON (Object v) + = do + eventType <- v .: "mouseEventType" :: Parser String + button <- parseJSON (Object v) :: Parser MouseButton + return $ case eventType of "click" -> Click button + "dblclick" -> DoubleClick button + "mousedown" -> MouseDown button + "mouseup" -> MouseUp button + "mouseenter" -> MouseEnter + "mouseleave" -> MouseLeave + "mousemove" -> MouseMove + +instance FromJSON MouseButton where + parseJSON (Object v) + = do + button <- v .: "button" :: Parser String + return $ case button of "left" -> MouseLeft + "middle" -> MouseMiddle + "right" -> MouseRight + +instance FromJSON Point where + parseJSON (Object v) + = do + x <- v .: "x" + y <- v .: "y" + return $ Point (x, y) + + +mouseInitializer :: Initializer +mouseInitializer sharedConst sharedIO + = do + (clientSocket, clientConn, serverSock) <- setupWebsocketConnection iNADDR_ANY mousePort + safePrintLn (safePrintToken sharedConst) "Mouse connection succesfull" + return (sharedConst, sharedIO, MouseConstants clientSocket clientConn serverSock, NoState) + + +mouseEventRetriever :: EventRetriever +mouseEventRetriever sharedConst sharedIOT ioConst ioStateT + = do + isConnected <- isConnected sock + case isConnected of + False -> return [] + True -> do + messageM <- takeMessage safePrintToken_ sock conn + case messageM of + Nothing -> return [] + (Just message) -> return [InMouse $ messageToMouseIn message] + where + sock = clientSocket ioConst + conn = clientConnection ioConst + safePrintToken_ = safePrintToken sharedConst + + +messageToMouseIn :: Message -> MouseIn +messageToMouseIn message = fromJust.decode $ BL.pack message + + +mouseEventSender :: EventSender +mouseEventSender sharedConst sharedIOT ioConst ioStateT Stop + = do + closeWebsocketConnection safePrintToken_ serverSock clientSock conn + where + serverSock = serverSocket ioConst + clientSock = clientSocket ioConst + conn = clientConnection ioConst + safePrintToken_ = safePrintToken sharedConst + + +mouseTeardown :: Teardown +mouseTeardown sharedConst sharedIO ioConst ioState + = do + destroyWebsocketConnection serverSock clientSock + return sharedIO + where + serverSock = serverSocket ioConst + clientSock = clientSocket ioConst conn = clientConnection ioConst diff --git a/src/Eventloop/Module/Websocket/Mouse/Types.hs b/src/Eventloop/Module/Websocket/Mouse/Types.hs --- a/src/Eventloop/Module/Websocket/Mouse/Types.hs +++ b/src/Eventloop/Module/Websocket/Mouse/Types.hs @@ -1,29 +1,29 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} -module Eventloop.Module.Websocket.Mouse.Types where - -import GHC.Generics (Generic) -import Control.DeepSeq - -import Eventloop.Types.Common -import Eventloop.Utility.Vectors - -data MouseIn = Mouse MouseType NumericId MouseEvent Point - deriving (Eq, Show) - -data MouseType = MouseCanvas - | MouseSVG - deriving (Eq, Show) - -data MouseEvent = Click MouseButton - | DoubleClick MouseButton - | MouseMove - | MouseDown MouseButton - | MouseUp MouseButton - | MouseEnter - | MouseLeave - deriving (Eq, Show) - -data MouseButton = MouseLeft - | MouseRight - | MouseMiddle +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +module Eventloop.Module.Websocket.Mouse.Types where + +import GHC.Generics (Generic) +import Control.DeepSeq + +import Eventloop.Types.Common +import Eventloop.Utility.Vectors + +data MouseIn = Mouse MouseType NumericId MouseEvent Point + deriving (Eq, Show) + +data MouseType = MouseCanvas + | MouseSVG + deriving (Eq, Show) + +data MouseEvent = Click MouseButton + | DoubleClick MouseButton + | MouseMove + | MouseDown MouseButton + | MouseUp MouseButton + | MouseEnter + | MouseLeave + deriving (Eq, Show) + +data MouseButton = MouseLeft + | MouseRight + | MouseMiddle deriving (Eq, Show, Generic, NFData) diff --git a/src/Eventloop/OutRouter.hs b/src/Eventloop/OutRouter.hs --- a/src/Eventloop/OutRouter.hs +++ b/src/Eventloop/OutRouter.hs @@ -1,21 +1,21 @@ -module Eventloop.OutRouter where - -import Eventloop.Types.Events -import Eventloop.Types.System - -import Eventloop.Module.File -import Eventloop.Module.Timer -import Eventloop.Module.StatefulGraphics -import Eventloop.Module.StdIn -import Eventloop.Module.StdOut -import Eventloop.Module.Websocket.Canvas - -routeOutEvent :: OutEventRouter -routeOutEvent out = case out of - (OutFile _) -> fileModuleIdentifier - (OutTimer _) -> timerModuleIdentifier - (OutStdOut _) -> stdOutModuleIdentifier - (OutStdIn _) -> stdInModuleIdentifier - (OutCanvas _) -> canvasModuleIdentifier - (OutStatefulGraphics _ _) -> statefulGraphicsModuleIdentifier +module Eventloop.OutRouter where + +import Eventloop.Types.Events +import Eventloop.Types.System + +import Eventloop.Module.File +import Eventloop.Module.Timer +import Eventloop.Module.StatefulGraphics +import Eventloop.Module.StdIn +import Eventloop.Module.StdOut +import Eventloop.Module.Websocket.Canvas + +routeOutEvent :: OutEventRouter +routeOutEvent out = case out of + (OutFile _) -> fileModuleIdentifier + (OutTimer _) -> timerModuleIdentifier + (OutStdOut _) -> stdOutModuleIdentifier + (OutStdIn _) -> stdInModuleIdentifier + (OutCanvas _) -> canvasModuleIdentifier + (OutStatefulGraphics _ _) -> statefulGraphicsModuleIdentifier _ -> error ("Could not find route for out event: " ++ show out) diff --git a/src/Eventloop/System/DisplayExceptionThread.hs b/src/Eventloop/System/DisplayExceptionThread.hs --- a/src/Eventloop/System/DisplayExceptionThread.hs +++ b/src/Eventloop/System/DisplayExceptionThread.hs @@ -1,26 +1,26 @@ -module Eventloop.System.DisplayExceptionThread - ( startDisplayingExceptions - ) where - -import qualified Control.Exception as E -import Control.Concurrent.ExceptionCollection -import Control.Concurrent.SafePrint - -import Eventloop.Types.Exception -import Eventloop.Types.System - - -startDisplayingExceptions :: EventloopSystemConfiguration progstateT - -> IO () -startDisplayingExceptions systemConfig - = do - exceptions_ <- collectExceptions (exceptions systemConfig) - mapM_ (displayException safePrintToken_) exceptions_ - where - safePrintToken_ = safePrintToken (sharedIOConstants systemConfig) - - -displayException :: SafePrintToken - -> E.SomeException - -> IO () +module Eventloop.System.DisplayExceptionThread + ( startDisplayingExceptions + ) where + +import qualified Control.Exception as E +import Control.Concurrent.ExceptionCollection +import Control.Concurrent.SafePrint + +import Eventloop.Types.Exception +import Eventloop.Types.System + + +startDisplayingExceptions :: EventloopSystemConfiguration progstateT + -> IO () +startDisplayingExceptions systemConfig + = do + exceptions_ <- collectExceptions (exceptions systemConfig) + mapM_ (displayException safePrintToken_) exceptions_ + where + safePrintToken_ = safePrintToken (sharedIOConstants systemConfig) + + +displayException :: SafePrintToken + -> E.SomeException + -> IO () displayException safePrintToken exception = safePrintLn safePrintToken (show exception) diff --git a/src/Eventloop/System/EventloopThread.hs b/src/Eventloop/System/EventloopThread.hs --- a/src/Eventloop/System/EventloopThread.hs +++ b/src/Eventloop/System/EventloopThread.hs @@ -1,80 +1,80 @@ -module Eventloop.System.EventloopThread where - -import Control.DeepSeq -import Control.Exception -import Control.Monad -import Control.Concurrent.ExceptionUtility -import Control.Concurrent.MVar -import Control.Concurrent.STM -import Control.Concurrent.Datastructures.BlockingConcurrentQueue -import Data.Maybe - -import Eventloop.System.Processing -import Eventloop.Types.Common -import Eventloop.Types.Exception -import Eventloop.Types.Events -import Eventloop.Types.System - -startEventlooping :: EventloopSystemConfiguration progstateT - -> IO () -startEventlooping systemConfig - = handle - ( \exception -> - case (fromException exception) of - (Just RequestShutdownException) -> throwIO RequestShutdownException - _ -> throwIO (EventloopException exception) - ) - ( do - putInBlockingConcurrentQueue inEventQueue_ Start - forever $ do - inEvent <- takeFromBlockingConcurrentQueue inEventQueue_ -- Take an In event - processedInEvents <- processEvents "Preprocessing" systemConfig modulePreprocessors [inEvent] -- Preprocess it - outEvents <- eventloopSteps eventloop progstateT_ processedInEvents -- Eventloop over the preprocessed In events - processedOutEvents <- processEvents "Postprocessing" systemConfig modulePostprocessors outEvents -- Postprocess the Out events - evaluatedOutEvents <- evaluate $ force processedOutEvents - putAllInBlockingConcurrentQueue outEventQueue_ processedOutEvents -- Send the processed Out events to the OutRouter - ) - where - eventloopConfig_ = eventloopConfig systemConfig - eventloop = eventloopFunc eventloopConfig_ - progstateT_ = progstateT eventloopConfig_ - inEventQueue_ = inEventQueue eventloopConfig_ - outEventQueue_ = outEventQueue eventloopConfig_ - moduleConfigurations_ = moduleConfigs systemConfig - modulePreprocessors = findProcessors moduleConfigurations_ preprocessorM - modulePostprocessors = findProcessors moduleConfigurations_ postprocessorM - - -findProcessors :: [EventloopModuleConfiguration] - -> (EventloopModuleConfiguration -> Maybe (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event])) -- Pre-/Postprocessor function - -> [(EventloopModuleIdentifier, IOConstants, TVar IOState, (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event]))] -findProcessors moduleConfigs getProcessorFunc - = moduleProcessors - where - moduleProcessorsM = map (\moduleConfig -> (moduleId moduleConfig, ioConstants moduleConfig, ioStateT moduleConfig, getProcessorFunc moduleConfig)) moduleConfigs - moduleProcessorsJ = filter (\(_, _, _, processFuncM) -> isJust processFuncM) moduleProcessorsM - moduleProcessors = map (\(id, ioConst, iostate, (Just processFunc)) -> (id, ioConst, iostate, processFunc)) moduleProcessorsJ - - -eventloopSteps :: (progstateT -> In -> (progstateT, [Out])) {-^ eventloop function -} - -> TVar progstateT - -> [In] - -> IO [Out] -eventloopSteps eventloop progstateT inEvents - = sequencedSteps >>= (return.concat) - where - inEventSteps = map (eventloopStep eventloop progstateT) inEvents - sequencedSteps = sequence inEventSteps - - -eventloopStep :: (progstateT -> In -> (progstateT, [Out])) {-^ eventloop function -} - -> TVar progstateT - -> In - -> IO [Out] -eventloopStep eventloop progStateT inEvent - = do - progState <- readTVarIO progStateT - let - (progState', outEvents) = eventloop progState inEvent - atomically $ writeTVar progStateT progState' +module Eventloop.System.EventloopThread where + +import Control.DeepSeq +import Control.Exception +import Control.Monad +import Control.Concurrent.ExceptionUtility +import Control.Concurrent.MVar +import Control.Concurrent.STM +import Control.Concurrent.Datastructures.BlockingConcurrentQueue +import Data.Maybe + +import Eventloop.System.Processing +import Eventloop.Types.Common +import Eventloop.Types.Exception +import Eventloop.Types.Events +import Eventloop.Types.System + +startEventlooping :: EventloopSystemConfiguration progstateT + -> IO () +startEventlooping systemConfig + = handle + ( \exception -> + case (fromException exception) of + (Just RequestShutdownException) -> throwIO RequestShutdownException + _ -> throwIO (EventloopException exception) + ) + ( do + putInBlockingConcurrentQueue inEventQueue_ Start + forever $ do + inEvent <- takeFromBlockingConcurrentQueue inEventQueue_ -- Take an In event + processedInEvents <- processEvents "Preprocessing" systemConfig modulePreprocessors [inEvent] -- Preprocess it + outEvents <- eventloopSteps eventloop progstateT_ processedInEvents -- Eventloop over the preprocessed In events + processedOutEvents <- processEvents "Postprocessing" systemConfig modulePostprocessors outEvents -- Postprocess the Out events + evaluatedOutEvents <- evaluate $ force processedOutEvents + putAllInBlockingConcurrentQueue outEventQueue_ processedOutEvents -- Send the processed Out events to the OutRouter + ) + where + eventloopConfig_ = eventloopConfig systemConfig + eventloop = eventloopFunc eventloopConfig_ + progstateT_ = progstateT eventloopConfig_ + inEventQueue_ = inEventQueue eventloopConfig_ + outEventQueue_ = outEventQueue eventloopConfig_ + moduleConfigurations_ = moduleConfigs systemConfig + modulePreprocessors = findProcessors moduleConfigurations_ preprocessorM + modulePostprocessors = findProcessors moduleConfigurations_ postprocessorM + + +findProcessors :: [EventloopModuleConfiguration] + -> (EventloopModuleConfiguration -> Maybe (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event])) -- Pre-/Postprocessor function + -> [(EventloopModuleIdentifier, IOConstants, TVar IOState, (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event]))] +findProcessors moduleConfigs getProcessorFunc + = moduleProcessors + where + moduleProcessorsM = map (\moduleConfig -> (moduleId moduleConfig, ioConstants moduleConfig, ioStateT moduleConfig, getProcessorFunc moduleConfig)) moduleConfigs + moduleProcessorsJ = filter (\(_, _, _, processFuncM) -> isJust processFuncM) moduleProcessorsM + moduleProcessors = map (\(id, ioConst, iostate, (Just processFunc)) -> (id, ioConst, iostate, processFunc)) moduleProcessorsJ + + +eventloopSteps :: (progstateT -> In -> (progstateT, [Out])) {-^ eventloop function -} + -> TVar progstateT + -> [In] + -> IO [Out] +eventloopSteps eventloop progstateT inEvents + = sequencedSteps >>= (return.concat) + where + inEventSteps = map (eventloopStep eventloop progstateT) inEvents + sequencedSteps = sequence inEventSteps + + +eventloopStep :: (progstateT -> In -> (progstateT, [Out])) {-^ eventloop function -} + -> TVar progstateT + -> In + -> IO [Out] +eventloopStep eventloop progStateT inEvent + = do + progState <- readTVarIO progStateT + let + (progState', outEvents) = eventloop progState inEvent + atomically $ writeTVar progStateT progState' return outEvents diff --git a/src/Eventloop/System/InitializationThread.hs b/src/Eventloop/System/InitializationThread.hs --- a/src/Eventloop/System/InitializationThread.hs +++ b/src/Eventloop/System/InitializationThread.hs @@ -1,59 +1,59 @@ -module Eventloop.System.InitializationThread - ( startInitializing - ) where - -import Control.Exception -import Control.Concurrent.STM -import Data.List - -import Eventloop.Types.Exception -import Eventloop.Types.System - - -startInitializing :: EventloopSystemConfiguration progstateT - -> IO (EventloopSystemConfiguration progstateT) -startInitializing systemConfig - = do - sharedIO <- readTVarIO sharedIOT_ - (sharedConst', sharedIO', moduleConfigs_') <- initializeModules sharedConst sharedIO moduleConfigs_ - atomically $ writeTVar sharedIOT_ sharedIO' - return systemConfig{moduleConfigs = reverse $ moduleConfigs_', sharedIOConstants = sharedConst'} - where - sharedConst = sharedIOConstants systemConfig - sharedIOT_ = sharedIOStateT systemConfig - moduleConfigs_ = reverse $ moduleConfigs systemConfig - - -initializeModules :: SharedIOConstants - -> SharedIOState - -> [EventloopModuleConfiguration] - -> IO (SharedIOConstants, SharedIOState, [EventloopModuleConfiguration]) -initializeModules sharedConst sharedIO [] = return (sharedConst, sharedIO, []) -initializeModules sharedConst sharedIO (moduleConfig:configs) - = do - (sharedConst', sharedIO', moduleConfig') <- initializeModule sharedConst sharedIO moduleConfig - (sharedConst'', sharedIO'', configs') <- initializeModules sharedConst' sharedIO' configs - return (sharedConst'', sharedIO'', moduleConfig':configs') - - -initializeModule :: SharedIOConstants - -> SharedIOState - -> EventloopModuleConfiguration - -> IO (SharedIOConstants, SharedIOState, EventloopModuleConfiguration) -initializeModule sharedConst sharedIO moduleConfig - = case (initializerM moduleConfig) of - Nothing -> return (sharedConst, sharedIO, moduleConfig) - (Just initializer) -> handle - ( \exception -> - throwIO (InitializationException moduleId_ exception) - ) - ( do - ioState <- readTVarIO ioStateT_ - (sharedConst', sharedIO', ioConst', ioState') <- initializer sharedConst sharedIO - atomically $ writeTVar ioStateT_ ioState' - return (sharedConst', sharedIO', moduleConfig {ioConstants = ioConst'}) - ) - where - moduleId_ = moduleId moduleConfig - ioConst = ioConstants moduleConfig +module Eventloop.System.InitializationThread + ( startInitializing + ) where + +import Control.Exception +import Control.Concurrent.STM +import Data.List + +import Eventloop.Types.Exception +import Eventloop.Types.System + + +startInitializing :: EventloopSystemConfiguration progstateT + -> IO (EventloopSystemConfiguration progstateT) +startInitializing systemConfig + = do + sharedIO <- readTVarIO sharedIOT_ + (sharedConst', sharedIO', moduleConfigs_') <- initializeModules sharedConst sharedIO moduleConfigs_ + atomically $ writeTVar sharedIOT_ sharedIO' + return systemConfig{moduleConfigs = reverse $ moduleConfigs_', sharedIOConstants = sharedConst'} + where + sharedConst = sharedIOConstants systemConfig + sharedIOT_ = sharedIOStateT systemConfig + moduleConfigs_ = reverse $ moduleConfigs systemConfig + + +initializeModules :: SharedIOConstants + -> SharedIOState + -> [EventloopModuleConfiguration] + -> IO (SharedIOConstants, SharedIOState, [EventloopModuleConfiguration]) +initializeModules sharedConst sharedIO [] = return (sharedConst, sharedIO, []) +initializeModules sharedConst sharedIO (moduleConfig:configs) + = do + (sharedConst', sharedIO', moduleConfig') <- initializeModule sharedConst sharedIO moduleConfig + (sharedConst'', sharedIO'', configs') <- initializeModules sharedConst' sharedIO' configs + return (sharedConst'', sharedIO'', moduleConfig':configs') + + +initializeModule :: SharedIOConstants + -> SharedIOState + -> EventloopModuleConfiguration + -> IO (SharedIOConstants, SharedIOState, EventloopModuleConfiguration) +initializeModule sharedConst sharedIO moduleConfig + = case (initializerM moduleConfig) of + Nothing -> return (sharedConst, sharedIO, moduleConfig) + (Just initializer) -> handle + ( \exception -> + throwIO (InitializationException moduleId_ exception) + ) + ( do + ioState <- readTVarIO ioStateT_ + (sharedConst', sharedIO', ioConst', ioState') <- initializer sharedConst sharedIO + atomically $ writeTVar ioStateT_ ioState' + return (sharedConst', sharedIO', moduleConfig {ioConstants = ioConst'}) + ) + where + moduleId_ = moduleId moduleConfig + ioConst = ioConstants moduleConfig ioStateT_ = ioStateT moduleConfig diff --git a/src/Eventloop/System/OutRouterThread.hs b/src/Eventloop/System/OutRouterThread.hs --- a/src/Eventloop/System/OutRouterThread.hs +++ b/src/Eventloop/System/OutRouterThread.hs @@ -1,68 +1,68 @@ -module Eventloop.System.OutRouterThread where - -import Control.Exception -import Control.Monad -import Control.Concurrent -import Control.Concurrent.Datastructures.BlockingConcurrentQueue - -import Eventloop.OutRouter -import Eventloop.Types.Common -import Eventloop.Types.Events -import Eventloop.Types.Exception -import Eventloop.Types.System - -{- | Grab an outEvent from the outEventQueue and route it to the correct module sender if any. -If there isn't one, throw a NoOutRouteException. The router will continue until it: -- Comes across a Stop outEvent: Raises a RequestShutdownException -- Raises an exception -- Receives an exception (Only possibility is ShutdownException) -In all cases, a Stop outEvent is sent to all module senders. --} -startOutRouting :: EventloopSystemConfiguration progstateT - -> IO () -startOutRouting systemConfig - = catch (forever $ do - outEvent <- takeFromBlockingConcurrentQueue outEventQueue_ - case outEvent of - Stop -> throwIO RequestShutdownException - _ -> outRouteOne moduleIdsSenderQueues outEvent - ) - (\exception -> do - outRouteBroadcastStop moduleIdsSenderQueues - throwIO (exception :: SomeException) - ) - where - moduleIdsSenderQueues = outRoutes (moduleConfigs systemConfig) - outEventQueue_ = outEventQueue (eventloopConfig systemConfig) - - -outRoutes :: [EventloopModuleConfiguration] -> [(EventloopModuleIdentifier, SenderEventQueue)] -outRoutes [] = [] -outRoutes (moduleConfig:mcs) = case (senderConfigM moduleConfig) of - Nothing -> outRoutes mcs - (Just moduleSenderConfig) -> (moduleId moduleConfig, senderEventQueue moduleSenderConfig):(outRoutes mcs) - - -outRouteOne :: [(EventloopModuleIdentifier, SenderEventQueue)] - -> Out - -> IO () -outRouteOne targetIdsSenderQueues outEvent - = case targetSenderQueueM of - Nothing -> - throwIO (NoOutRouteException outEvent) - (Just targetSenderQueue) -> - putInBlockingConcurrentQueue targetSenderQueue outEvent - where - targetModuleIdentifier = routeOutEvent outEvent - targetSenderQueueM = lookup targetModuleIdentifier targetIdsSenderQueues - - -outRouteBroadcastStop :: [(EventloopModuleIdentifier, SenderEventQueue)] - -> IO () -outRouteBroadcastStop [] - = return () -outRouteBroadcastStop targetIdsSenderQueues - = mapM_ broadcastAction (map snd targetIdsSenderQueues) - where - broadcastAction targetSenderQueue = +module Eventloop.System.OutRouterThread where + +import Control.Exception +import Control.Monad +import Control.Concurrent +import Control.Concurrent.Datastructures.BlockingConcurrentQueue + +import Eventloop.OutRouter +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.Exception +import Eventloop.Types.System + +{- | Grab an outEvent from the outEventQueue and route it to the correct module sender if any. +If there isn't one, throw a NoOutRouteException. The router will continue until it: +- Comes across a Stop outEvent: Raises a RequestShutdownException +- Raises an exception +- Receives an exception (Only possibility is ShutdownException) +In all cases, a Stop outEvent is sent to all module senders. +-} +startOutRouting :: EventloopSystemConfiguration progstateT + -> IO () +startOutRouting systemConfig + = catch (forever $ do + outEvent <- takeFromBlockingConcurrentQueue outEventQueue_ + case outEvent of + Stop -> throwIO RequestShutdownException + _ -> outRouteOne moduleIdsSenderQueues outEvent + ) + (\exception -> do + outRouteBroadcastStop moduleIdsSenderQueues + throwIO (exception :: SomeException) + ) + where + moduleIdsSenderQueues = outRoutes (moduleConfigs systemConfig) + outEventQueue_ = outEventQueue (eventloopConfig systemConfig) + + +outRoutes :: [EventloopModuleConfiguration] -> [(EventloopModuleIdentifier, SenderEventQueue)] +outRoutes [] = [] +outRoutes (moduleConfig:mcs) = case (senderConfigM moduleConfig) of + Nothing -> outRoutes mcs + (Just moduleSenderConfig) -> (moduleId moduleConfig, senderEventQueue moduleSenderConfig):(outRoutes mcs) + + +outRouteOne :: [(EventloopModuleIdentifier, SenderEventQueue)] + -> Out + -> IO () +outRouteOne targetIdsSenderQueues outEvent + = case targetSenderQueueM of + Nothing -> + throwIO (NoOutRouteException outEvent) + (Just targetSenderQueue) -> + putInBlockingConcurrentQueue targetSenderQueue outEvent + where + targetModuleIdentifier = routeOutEvent outEvent + targetSenderQueueM = lookup targetModuleIdentifier targetIdsSenderQueues + + +outRouteBroadcastStop :: [(EventloopModuleIdentifier, SenderEventQueue)] + -> IO () +outRouteBroadcastStop [] + = return () +outRouteBroadcastStop targetIdsSenderQueues + = mapM_ broadcastAction (map snd targetIdsSenderQueues) + where + broadcastAction targetSenderQueue = putInBlockingConcurrentQueue targetSenderQueue Stop diff --git a/src/Eventloop/System/Processing.hs b/src/Eventloop/System/Processing.hs --- a/src/Eventloop/System/Processing.hs +++ b/src/Eventloop/System/Processing.hs @@ -1,73 +1,73 @@ -module Eventloop.System.Processing where - -import Control.Exception -import Control.Concurrent.ExceptionUtility -import Control.Concurrent.STM - -import Eventloop.Types.Common -import Eventloop.Types.Exception -import Eventloop.Types.Events -import Eventloop.Types.System - -{- - To handle the pre-/postprocessing of in/out events - Per module is needed: (moduleIdentifier, ioStateT, processFunc) - Only modules with the appropriate processFunc are included if they exist --} - -processEventWithModule :: ProcessingDescription - -> SharedIOConstants - -> TVar SharedIOState - -> ( EventloopModuleIdentifier - , IOConstants - , TVar IOState - , (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event]) - ) - -> event - -> IO [event] -processEventWithModule processingDescription sharedConst sharedIOT (moduleId, ioConst, ioStateT, processFunc) event - = handle - ( \exception -> - throwIO (ProcessingException processingDescription moduleId exception) - ) - ( do - processFunc sharedConst sharedIOT ioConst ioStateT event - ) - - -processEventsWithModules :: ProcessingDescription - -> SharedIOConstants - -> TVar SharedIOState - -> [( EventloopModuleIdentifier - , IOConstants - , TVar IOState - , (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event]) - )] - -> [event] - -> IO [event] -processEventsWithModules _ _ _ _ [] - = return [] -processEventsWithModules _ _ _ [] events - = return events -processEventsWithModules processingDescription sharedConst sharedIOT (moduleProcessor:mps) (event:events) - = do - generatedEvents <- processEventWithModule processingDescription sharedConst sharedIOT moduleProcessor event - processedEvents <- processEventsWithModules processingDescription sharedConst sharedIOT mps generatedEvents - restProcessedEvents <- processEventsWithModules processingDescription sharedConst sharedIOT (moduleProcessor:mps) events - return (processedEvents ++ restProcessedEvents) - - -processEvents :: ProcessingDescription - -> EventloopSystemConfiguration progstateT - -> [( EventloopModuleIdentifier - , IOConstants - , TVar IOState - , (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event]) - )] - -> [event] - -> IO [event] -processEvents processingDescription systemConfig moduleProcessors events - = processEventsWithModules processingDescription sharedConst sharedIOT moduleProcessors events - where - sharedIOT = sharedIOStateT systemConfig +module Eventloop.System.Processing where + +import Control.Exception +import Control.Concurrent.ExceptionUtility +import Control.Concurrent.STM + +import Eventloop.Types.Common +import Eventloop.Types.Exception +import Eventloop.Types.Events +import Eventloop.Types.System + +{- + To handle the pre-/postprocessing of in/out events + Per module is needed: (moduleIdentifier, ioStateT, processFunc) + Only modules with the appropriate processFunc are included if they exist +-} + +processEventWithModule :: ProcessingDescription + -> SharedIOConstants + -> TVar SharedIOState + -> ( EventloopModuleIdentifier + , IOConstants + , TVar IOState + , (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event]) + ) + -> event + -> IO [event] +processEventWithModule processingDescription sharedConst sharedIOT (moduleId, ioConst, ioStateT, processFunc) event + = handle + ( \exception -> + throwIO (ProcessingException processingDescription moduleId exception) + ) + ( do + processFunc sharedConst sharedIOT ioConst ioStateT event + ) + + +processEventsWithModules :: ProcessingDescription + -> SharedIOConstants + -> TVar SharedIOState + -> [( EventloopModuleIdentifier + , IOConstants + , TVar IOState + , (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event]) + )] + -> [event] + -> IO [event] +processEventsWithModules _ _ _ _ [] + = return [] +processEventsWithModules _ _ _ [] events + = return events +processEventsWithModules processingDescription sharedConst sharedIOT (moduleProcessor:mps) (event:events) + = do + generatedEvents <- processEventWithModule processingDescription sharedConst sharedIOT moduleProcessor event + processedEvents <- processEventsWithModules processingDescription sharedConst sharedIOT mps generatedEvents + restProcessedEvents <- processEventsWithModules processingDescription sharedConst sharedIOT (moduleProcessor:mps) events + return (processedEvents ++ restProcessedEvents) + + +processEvents :: ProcessingDescription + -> EventloopSystemConfiguration progstateT + -> [( EventloopModuleIdentifier + , IOConstants + , TVar IOState + , (SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> event -> IO [event]) + )] + -> [event] + -> IO [event] +processEvents processingDescription systemConfig moduleProcessors events + = processEventsWithModules processingDescription sharedConst sharedIOT moduleProcessors events + where + sharedIOT = sharedIOStateT systemConfig sharedConst = sharedIOConstants systemConfig diff --git a/src/Eventloop/System/RetrieverThread.hs b/src/Eventloop/System/RetrieverThread.hs --- a/src/Eventloop/System/RetrieverThread.hs +++ b/src/Eventloop/System/RetrieverThread.hs @@ -1,45 +1,45 @@ -module Eventloop.System.RetrieverThread where - -import Control.Exception -import Control.Monad -import Control.Concurrent.STM -import Control.Concurrent.Datastructures.BlockingConcurrentQueue - -import Eventloop.Types.Common -import Eventloop.Types.Exception -import Eventloop.Types.System - -startRetrieving :: EventloopSystemConfiguration progstateT - -> (EventloopModuleConfiguration, EventRetriever) - -> IO () -startRetrieving systemConfig (moduleConfig, retriever) - = forever (retrieveOne moduleId_ sharedConst sharedIOStateT_ ioConst ioStateT_ retriever inEventQueue_) - where - moduleId_ = moduleId moduleConfig - eventloopConfiguration = eventloopConfig systemConfig - sharedConst = sharedIOConstants systemConfig - sharedIOStateT_ = sharedIOStateT systemConfig - inEventQueue_ = inEventQueue eventloopConfiguration - ioConst = ioConstants moduleConfig - ioStateT_ = ioStateT moduleConfig - - -retrieveOne :: EventloopModuleIdentifier -> - SharedIOConstants -> - TVar SharedIOState -> - IOConstants -> - TVar IOState -> - EventRetriever -> - InEventQueue -> - IO () -retrieveOne moduleId sharedConst sharedIOT ioConst iostateT retriever inEventQueue - = handle ( \exception -> - -- Wrap the exception if it isn't a ShuttingDownException - case (fromException exception) of - (Just ShuttingDownException) -> throwIO ShuttingDownException - _ -> throwIO (RetrievingException moduleId exception) - ) - ( do - inEvents <- retriever sharedConst sharedIOT ioConst iostateT - putAllInBlockingConcurrentQueue inEventQueue inEvents +module Eventloop.System.RetrieverThread where + +import Control.Exception +import Control.Monad +import Control.Concurrent.STM +import Control.Concurrent.Datastructures.BlockingConcurrentQueue + +import Eventloop.Types.Common +import Eventloop.Types.Exception +import Eventloop.Types.System + +startRetrieving :: EventloopSystemConfiguration progstateT + -> (EventloopModuleConfiguration, EventRetriever) + -> IO () +startRetrieving systemConfig (moduleConfig, retriever) + = forever (retrieveOne moduleId_ sharedConst sharedIOStateT_ ioConst ioStateT_ retriever inEventQueue_) + where + moduleId_ = moduleId moduleConfig + eventloopConfiguration = eventloopConfig systemConfig + sharedConst = sharedIOConstants systemConfig + sharedIOStateT_ = sharedIOStateT systemConfig + inEventQueue_ = inEventQueue eventloopConfiguration + ioConst = ioConstants moduleConfig + ioStateT_ = ioStateT moduleConfig + + +retrieveOne :: EventloopModuleIdentifier -> + SharedIOConstants -> + TVar SharedIOState -> + IOConstants -> + TVar IOState -> + EventRetriever -> + InEventQueue -> + IO () +retrieveOne moduleId sharedConst sharedIOT ioConst iostateT retriever inEventQueue + = handle ( \exception -> + -- Wrap the exception if it isn't a ShuttingDownException + case (fromException exception) of + (Just ShuttingDownException) -> throwIO ShuttingDownException + _ -> throwIO (RetrievingException moduleId exception) + ) + ( do + inEvents <- retriever sharedConst sharedIOT ioConst iostateT + putAllInBlockingConcurrentQueue inEventQueue inEvents ) diff --git a/src/Eventloop/System/SenderThread.hs b/src/Eventloop/System/SenderThread.hs --- a/src/Eventloop/System/SenderThread.hs +++ b/src/Eventloop/System/SenderThread.hs @@ -1,50 +1,50 @@ -module Eventloop.System.SenderThread where - -import Control.Exception -import Control.Monad -import Control.Concurrent.STM -import Control.Concurrent.Datastructures.BlockingConcurrentQueue - -import Eventloop.Types.Common -import Eventloop.Types.Events -import Eventloop.Types.Exception -import Eventloop.Types.System - -startSending :: EventloopSystemConfiguration progstateT - -> (EventloopModuleConfiguration, EventloopModuleSenderConfiguration) - -> IO () -startSending systemConfig (moduleConfig, moduleSenderConfig) - = forever $ do - outEvent <- takeFromBlockingConcurrentQueue senderEventQueue_ - case outEvent of - Stop -> do - sendOne moduleId_ sharedConst sharedIOT ioConst ioStateT_ sender_ Stop - throwIO RequestShutdownException - _ -> sendOne moduleId_ sharedConst sharedIOT ioConst ioStateT_ sender_ outEvent - where - moduleId_ = moduleId moduleConfig - sharedConst = sharedIOConstants systemConfig - sharedIOT = sharedIOStateT systemConfig - ioConst = ioConstants moduleConfig - ioStateT_ = ioStateT moduleConfig - sender_ = sender moduleSenderConfig - senderEventQueue_ = senderEventQueue moduleSenderConfig - - -sendOne :: EventloopModuleIdentifier - -> SharedIOConstants - -> TVar SharedIOState - -> IOConstants - -> TVar IOState - -> EventSender - -> Out - -> IO () -sendOne moduleId sharedConst sharedIOT ioConst ioStateT sender outEvent - = handle ( \exception -> - -- Wrap the exception if it isn't a ShuttingDownException - case (fromException exception) of - (Just ShuttingDownException) -> throwIO ShuttingDownException - _ -> throwIO (SendingException moduleId outEvent exception) - ) - ( sender sharedConst sharedIOT ioConst ioStateT outEvent +module Eventloop.System.SenderThread where + +import Control.Exception +import Control.Monad +import Control.Concurrent.STM +import Control.Concurrent.Datastructures.BlockingConcurrentQueue + +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.Exception +import Eventloop.Types.System + +startSending :: EventloopSystemConfiguration progstateT + -> (EventloopModuleConfiguration, EventloopModuleSenderConfiguration) + -> IO () +startSending systemConfig (moduleConfig, moduleSenderConfig) + = forever $ do + outEvent <- takeFromBlockingConcurrentQueue senderEventQueue_ + case outEvent of + Stop -> do + sendOne moduleId_ sharedConst sharedIOT ioConst ioStateT_ sender_ Stop + throwIO RequestShutdownException + _ -> sendOne moduleId_ sharedConst sharedIOT ioConst ioStateT_ sender_ outEvent + where + moduleId_ = moduleId moduleConfig + sharedConst = sharedIOConstants systemConfig + sharedIOT = sharedIOStateT systemConfig + ioConst = ioConstants moduleConfig + ioStateT_ = ioStateT moduleConfig + sender_ = sender moduleSenderConfig + senderEventQueue_ = senderEventQueue moduleSenderConfig + + +sendOne :: EventloopModuleIdentifier + -> SharedIOConstants + -> TVar SharedIOState + -> IOConstants + -> TVar IOState + -> EventSender + -> Out + -> IO () +sendOne moduleId sharedConst sharedIOT ioConst ioStateT sender outEvent + = handle ( \exception -> + -- Wrap the exception if it isn't a ShuttingDownException + case (fromException exception) of + (Just ShuttingDownException) -> throwIO ShuttingDownException + _ -> throwIO (SendingException moduleId outEvent exception) + ) + ( sender sharedConst sharedIOT ioConst ioStateT outEvent ) diff --git a/src/Eventloop/System/Setup.hs b/src/Eventloop/System/Setup.hs --- a/src/Eventloop/System/Setup.hs +++ b/src/Eventloop/System/Setup.hs @@ -1,91 +1,91 @@ -module Eventloop.System.Setup - ( setupEventloopSystemConfig - ) where - -import Control.Concurrent -import Control.Concurrent.ExceptionCollection -import Control.Concurrent.MVar -import Control.Concurrent.STM -import Control.Concurrent.Datastructures.BlockingConcurrentQueue - -import Eventloop.DefaultConfiguration -import Eventloop.Types.System - - -setupEventloopSystemConfig :: EventloopSetupConfiguration progstateT - -> IO (EventloopSystemConfiguration progstateT) -setupEventloopSystemConfig setupConfig - = do - eventloopConfig_ <- setupEventloopConfiguration setupConfig - moduleConfigurations_ <- mapM setupEventloopModuleConfig (setupModuleConfigurations setupConfig) - sharedIOConst <- setupSharedIOConstants - sharedIOState_ <- setupSharedIOState - sharedIOStateT_ <- newTVarIO sharedIOState_ - systemThreadId_ <- myThreadId - retrieverThreadsM_ <- newMVar [] - outRouterThreadM_ <- newEmptyMVar - senderThreadsM_ <- newMVar [] - exceptionCollection <- createExceptionCollection - isStoppingM_ <- newMVar False - - return ( EventloopSystemConfiguration - eventloopConfig_ - moduleConfigurations_ - sharedIOConst - sharedIOStateT_ - systemThreadId_ - retrieverThreadsM_ - outRouterThreadM_ - senderThreadsM_ - exceptionCollection - isStoppingM_ - ) - - -setupEventloopConfiguration :: EventloopSetupConfiguration progstateT - -> IO (EventloopConfiguration progstateT) -setupEventloopConfiguration setupConfig - = do - progStateT_ <- newTVarIO (beginProgstate setupConfig) - inEventQueue_ <- createBlockingConcurrentQueue - outEventQueue_ <- createBlockingConcurrentQueue - - return ( EventloopConfiguration - progStateT_ - (eventloopF setupConfig) - inEventQueue_ - outEventQueue_ - ) - - -setupEventloopModuleConfig :: EventloopSetupModuleConfiguration - -> IO EventloopModuleConfiguration -setupEventloopModuleConfig setupModuleConfig - = do - ioStateT <- newTVarIO NoState - senderConfig <- setupEventloopModuleSenderConfiguration (eventSenderF setupModuleConfig) - - return ( EventloopModuleConfiguration - (moduleIdentifier setupModuleConfig) - NoConstants - ioStateT - (initializerF setupModuleConfig) - (eventRetrieverF setupModuleConfig) - (preprocessorF setupModuleConfig) - (postprocessorF setupModuleConfig) - senderConfig - (teardownF setupModuleConfig) - ) - where - moduleId_ = moduleIdentifier setupModuleConfig - - - -setupEventloopModuleSenderConfiguration :: Maybe EventSender - -> IO (Maybe EventloopModuleSenderConfiguration) -setupEventloopModuleSenderConfiguration Nothing = return Nothing -setupEventloopModuleSenderConfiguration (Just eventSender_) - = do - senderEventQueue_ <- createBlockingConcurrentQueue - +module Eventloop.System.Setup + ( setupEventloopSystemConfig + ) where + +import Control.Concurrent +import Control.Concurrent.ExceptionCollection +import Control.Concurrent.MVar +import Control.Concurrent.STM +import Control.Concurrent.Datastructures.BlockingConcurrentQueue + +import Eventloop.DefaultConfiguration +import Eventloop.Types.System + + +setupEventloopSystemConfig :: EventloopSetupConfiguration progstateT + -> IO (EventloopSystemConfiguration progstateT) +setupEventloopSystemConfig setupConfig + = do + eventloopConfig_ <- setupEventloopConfiguration setupConfig + moduleConfigurations_ <- mapM setupEventloopModuleConfig (setupModuleConfigurations setupConfig) + sharedIOConst <- setupSharedIOConstants + sharedIOState_ <- setupSharedIOState + sharedIOStateT_ <- newTVarIO sharedIOState_ + systemThreadId_ <- myThreadId + retrieverThreadsM_ <- newMVar [] + outRouterThreadM_ <- newEmptyMVar + senderThreadsM_ <- newMVar [] + exceptionCollection <- createExceptionCollection + isStoppingM_ <- newMVar False + + return ( EventloopSystemConfiguration + eventloopConfig_ + moduleConfigurations_ + sharedIOConst + sharedIOStateT_ + systemThreadId_ + retrieverThreadsM_ + outRouterThreadM_ + senderThreadsM_ + exceptionCollection + isStoppingM_ + ) + + +setupEventloopConfiguration :: EventloopSetupConfiguration progstateT + -> IO (EventloopConfiguration progstateT) +setupEventloopConfiguration setupConfig + = do + progStateT_ <- newTVarIO (beginProgstate setupConfig) + inEventQueue_ <- createBlockingConcurrentQueue + outEventQueue_ <- createBlockingConcurrentQueue + + return ( EventloopConfiguration + progStateT_ + (eventloopF setupConfig) + inEventQueue_ + outEventQueue_ + ) + + +setupEventloopModuleConfig :: EventloopSetupModuleConfiguration + -> IO EventloopModuleConfiguration +setupEventloopModuleConfig setupModuleConfig + = do + ioStateT <- newTVarIO NoState + senderConfig <- setupEventloopModuleSenderConfiguration (eventSenderF setupModuleConfig) + + return ( EventloopModuleConfiguration + (moduleIdentifier setupModuleConfig) + NoConstants + ioStateT + (initializerF setupModuleConfig) + (eventRetrieverF setupModuleConfig) + (preprocessorF setupModuleConfig) + (postprocessorF setupModuleConfig) + senderConfig + (teardownF setupModuleConfig) + ) + where + moduleId_ = moduleIdentifier setupModuleConfig + + + +setupEventloopModuleSenderConfiguration :: Maybe EventSender + -> IO (Maybe EventloopModuleSenderConfiguration) +setupEventloopModuleSenderConfiguration Nothing = return Nothing +setupEventloopModuleSenderConfiguration (Just eventSender_) + = do + senderEventQueue_ <- createBlockingConcurrentQueue + return (Just (EventloopModuleSenderConfiguration eventSender_ senderEventQueue_)) diff --git a/src/Eventloop/System/TeardownThread.hs b/src/Eventloop/System/TeardownThread.hs --- a/src/Eventloop/System/TeardownThread.hs +++ b/src/Eventloop/System/TeardownThread.hs @@ -1,58 +1,58 @@ -module Eventloop.System.TeardownThread - ( startTeardowning - ) where - -import Control.Exception -import Control.Concurrent.ExceptionCollection -import Control.Concurrent.STM - -import Eventloop.Types.Exception -import Eventloop.Types.System - - -startTeardowning :: EventloopSystemConfiguration progstateT - -> IO () -startTeardowning systemConfig - = do - sharedIO <- readTVarIO sharedIOStateT_ - sharedIO' <- teardownModules sharedConst sharedIO systemConfig moduleConfigs_ - atomically $ writeTVar sharedIOStateT_ sharedIO' - where - sharedConst = sharedIOConstants systemConfig - sharedIOStateT_ = sharedIOStateT systemConfig - moduleConfigs_ = moduleConfigs systemConfig - - -teardownModules :: SharedIOConstants - -> SharedIOState - -> EventloopSystemConfiguration progstateT - -> [EventloopModuleConfiguration] - -> IO SharedIOState -teardownModules _ sharedIO _ [] = return sharedIO -teardownModules sharedConst sharedIO systemConfig (moduleConfig:configs) - = do - sharedIO' <- teardownModule sharedConst sharedIO systemConfig moduleConfig - teardownModules sharedConst sharedIO' systemConfig configs - - -teardownModule :: SharedIOConstants - -> SharedIOState - -> EventloopSystemConfiguration progstateT - -> EventloopModuleConfiguration - -> IO SharedIOState -teardownModule sharedConst sharedIO systemConfig moduleConfig - = case (teardownM moduleConfig) of - Nothing -> return (sharedIO) - (Just teardown) -> handle - ( \exception -> do - logException (exceptions systemConfig) (toException $ TeardownException moduleId_ exception) - return sharedIO - ) - ( do - ioState <- readTVarIO ioStateT_ - teardown sharedConst sharedIO ioConst ioState - ) - where - moduleId_ = moduleId moduleConfig - ioConst = ioConstants moduleConfig +module Eventloop.System.TeardownThread + ( startTeardowning + ) where + +import Control.Exception +import Control.Concurrent.ExceptionCollection +import Control.Concurrent.STM + +import Eventloop.Types.Exception +import Eventloop.Types.System + + +startTeardowning :: EventloopSystemConfiguration progstateT + -> IO () +startTeardowning systemConfig + = do + sharedIO <- readTVarIO sharedIOStateT_ + sharedIO' <- teardownModules sharedConst sharedIO systemConfig moduleConfigs_ + atomically $ writeTVar sharedIOStateT_ sharedIO' + where + sharedConst = sharedIOConstants systemConfig + sharedIOStateT_ = sharedIOStateT systemConfig + moduleConfigs_ = moduleConfigs systemConfig + + +teardownModules :: SharedIOConstants + -> SharedIOState + -> EventloopSystemConfiguration progstateT + -> [EventloopModuleConfiguration] + -> IO SharedIOState +teardownModules _ sharedIO _ [] = return sharedIO +teardownModules sharedConst sharedIO systemConfig (moduleConfig:configs) + = do + sharedIO' <- teardownModule sharedConst sharedIO systemConfig moduleConfig + teardownModules sharedConst sharedIO' systemConfig configs + + +teardownModule :: SharedIOConstants + -> SharedIOState + -> EventloopSystemConfiguration progstateT + -> EventloopModuleConfiguration + -> IO SharedIOState +teardownModule sharedConst sharedIO systemConfig moduleConfig + = case (teardownM moduleConfig) of + Nothing -> return (sharedIO) + (Just teardown) -> handle + ( \exception -> do + logException (exceptions systemConfig) (toException $ TeardownException moduleId_ exception) + return sharedIO + ) + ( do + ioState <- readTVarIO ioStateT_ + teardown sharedConst sharedIO ioConst ioState + ) + where + moduleId_ = moduleId moduleConfig + ioConst = ioConstants moduleConfig ioStateT_ = ioStateT moduleConfig diff --git a/src/Eventloop/Types/Common.hs b/src/Eventloop/Types/Common.hs --- a/src/Eventloop/Types/Common.hs +++ b/src/Eventloop/Types/Common.hs @@ -1,7 +1,7 @@ -module Eventloop.Types.Common where - -type EventloopModuleIdentifier = [Char] -type ProcessingDescription = [Char] - -type NamedId = [Char] +module Eventloop.Types.Common where + +type EventloopModuleIdentifier = [Char] +type ProcessingDescription = [Char] + +type NamedId = [Char] type NumericId = Int diff --git a/src/Eventloop/Types/Events.hs b/src/Eventloop/Types/Events.hs --- a/src/Eventloop/Types/Events.hs +++ b/src/Eventloop/Types/Events.hs @@ -1,41 +1,41 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} -module Eventloop.Types.Events where - -import GHC.Generics (Generic) -import Control.DeepSeq - -import Eventloop.Module.Websocket.Keyboard.Types -import Eventloop.Module.Websocket.Mouse.Types -import Eventloop.Module.Websocket.Canvas.Types -import Eventloop.Module.DrawTrees.Types -import Eventloop.Module.BasicShapes.Types -import Eventloop.Module.File.Types -import Eventloop.Module.StatefulGraphics.Types -import Eventloop.Module.StdIn.Types -import Eventloop.Module.StdOut.Types -import Eventloop.Module.Timer.Types -import Eventloop.Module.Graphs.Types - - -data In = Start - | InKeyboard Keyboard - | InMouse MouseIn - | InFile FileIn - | InTimer TimerIn - | InStdIn StdInIn - | InCanvas CanvasIn - | InGraphs GraphsIn - deriving (Eq, Show) - - -data Out = OutFile FileOut - | OutTimer TimerOut - | OutStdOut StdOutOut - | OutStdIn StdInOut - | OutCanvas CanvasOut - | OutBasicShapes BasicShapesOut - | OutDrawTrees DrawTreesOut - | OutGraphs GraphsOut - | OutStatefulGraphics CanvasId [StatefulGraphicsOut] - | Stop +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +module Eventloop.Types.Events where + +import GHC.Generics (Generic) +import Control.DeepSeq + +import Eventloop.Module.Websocket.Keyboard.Types +import Eventloop.Module.Websocket.Mouse.Types +import Eventloop.Module.Websocket.Canvas.Types +import Eventloop.Module.DrawTrees.Types +import Eventloop.Module.BasicShapes.Types +import Eventloop.Module.File.Types +import Eventloop.Module.StatefulGraphics.Types +import Eventloop.Module.StdIn.Types +import Eventloop.Module.StdOut.Types +import Eventloop.Module.Timer.Types +import Eventloop.Module.Graphs.Types + + +data In = Start + | InKeyboard Keyboard + | InMouse MouseIn + | InFile FileIn + | InTimer TimerIn + | InStdIn StdInIn + | InCanvas CanvasIn + | InGraphs GraphsIn + deriving (Eq, Show) + + +data Out = OutFile FileOut + | OutTimer TimerOut + | OutStdOut StdOutOut + | OutStdIn StdInOut + | OutCanvas CanvasOut + | OutBasicShapes BasicShapesOut + | OutDrawTrees DrawTreesOut + | OutGraphs GraphsOut + | OutStatefulGraphics CanvasId [StatefulGraphicsOut] + | Stop deriving (Eq, Show, Generic, NFData) diff --git a/src/Eventloop/Types/Exception.hs b/src/Eventloop/Types/Exception.hs --- a/src/Eventloop/Types/Exception.hs +++ b/src/Eventloop/Types/Exception.hs @@ -1,68 +1,68 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Eventloop.Types.Exception where - - -import Control.Exception -import Data.Typeable - -import Eventloop.Types.Common -import Eventloop.Types.Events - - -data EventloopException = ShuttingDownException - | RequestShutdownException - | NoOutRouteException Out - | InitializationException EventloopModuleIdentifier SomeException - | RetrievingException EventloopModuleIdentifier SomeException - | ProcessingException ProcessingDescription EventloopModuleIdentifier SomeException - | EventloopException SomeException - | SendingException EventloopModuleIdentifier Out SomeException - | TeardownException EventloopModuleIdentifier SomeException - - deriving (Typeable) - -instance Exception EventloopException - - -instance Show EventloopException where - show ShuttingDownException = exceptionMessage "A shutting down exception has been logged. This should not happen. Please contact an administrator." - [] - show RequestShutdownException = "System is shutting down..." - - show (NoOutRouteException out) = exceptionMessage "Tried to route an Out even to a module but could not find an appropriate configured event sender." - [ ("Out event", show out) - ] - show (InitializationException moduleId e) = exceptionMessage "Tried to initialize a module but something happened." - [ ("Module", moduleId) - , ("Exception", show e) - ] - show (RetrievingException moduleId e) = exceptionMessage "Tried to retrieve an In event from a module but something happened. The retriever has been shutdown." - [ ("Module", moduleId) - , ("Exception", show e) - ] - show (ProcessingException processDesc moduleId e) = exceptionMessage "Tried to process an In\\Out event with a module but something happened." - [ ("Processor", processDesc) - , ("Module", moduleId) - , ("Exception", show e) - ] - show (EventloopException e) = exceptionMessage "An exception occurred in your eventloop program." - [ ("Exception", show e) - ] - show (SendingException moduleId out e) = exceptionMessage "Tried to send an Out event with a module but something happened." - [ ("Module", moduleId) - , ("Out event", show out) - , ("Exception", show e) - ] - show (TeardownException moduleId e) = exceptionMessage "Tried to teardown a module but something happened." - [ ("Module", moduleId) - , ("Exception", show e) - ] - -exceptionMessage :: String - -> [(String, String)] - -> String -exceptionMessage description fields - = "- Exc: " ++ description ++ "\n" ++ (concat fieldLines) - where +{-# LANGUAGE DeriveDataTypeable #-} + +module Eventloop.Types.Exception where + + +import Control.Exception +import Data.Typeable + +import Eventloop.Types.Common +import Eventloop.Types.Events + + +data EventloopException = ShuttingDownException + | RequestShutdownException + | NoOutRouteException Out + | InitializationException EventloopModuleIdentifier SomeException + | RetrievingException EventloopModuleIdentifier SomeException + | ProcessingException ProcessingDescription EventloopModuleIdentifier SomeException + | EventloopException SomeException + | SendingException EventloopModuleIdentifier Out SomeException + | TeardownException EventloopModuleIdentifier SomeException + + deriving (Typeable) + +instance Exception EventloopException + + +instance Show EventloopException where + show ShuttingDownException = exceptionMessage "A shutting down exception has been logged. This should not happen. Please contact an administrator." + [] + show RequestShutdownException = "System is shutting down..." + + show (NoOutRouteException out) = exceptionMessage "Tried to route an Out even to a module but could not find an appropriate configured event sender." + [ ("Out event", show out) + ] + show (InitializationException moduleId e) = exceptionMessage "Tried to initialize a module but something happened." + [ ("Module", moduleId) + , ("Exception", show e) + ] + show (RetrievingException moduleId e) = exceptionMessage "Tried to retrieve an In event from a module but something happened. The retriever has been shutdown." + [ ("Module", moduleId) + , ("Exception", show e) + ] + show (ProcessingException processDesc moduleId e) = exceptionMessage "Tried to process an In\\Out event with a module but something happened." + [ ("Processor", processDesc) + , ("Module", moduleId) + , ("Exception", show e) + ] + show (EventloopException e) = exceptionMessage "An exception occurred in your eventloop program." + [ ("Exception", show e) + ] + show (SendingException moduleId out e) = exceptionMessage "Tried to send an Out event with a module but something happened." + [ ("Module", moduleId) + , ("Out event", show out) + , ("Exception", show e) + ] + show (TeardownException moduleId e) = exceptionMessage "Tried to teardown a module but something happened." + [ ("Module", moduleId) + , ("Exception", show e) + ] + +exceptionMessage :: String + -> [(String, String)] + -> String +exceptionMessage description fields + = "- Exc: " ++ description ++ "\n" ++ (concat fieldLines) + where fieldLines = map (\(field, value) -> " " ++ field ++ ": " ++ value ++ "\n") fields diff --git a/src/Eventloop/Types/System.hs b/src/Eventloop/Types/System.hs --- a/src/Eventloop/Types/System.hs +++ b/src/Eventloop/Types/System.hs @@ -1,137 +1,137 @@ -module Eventloop.Types.System where - -import Control.Concurrent -import Control.Concurrent.ExceptionCollection -import Control.Concurrent.MVar -import Control.Concurrent.Thread -import Control.Concurrent.SafePrint -import Control.Concurrent.STM -import Control.Concurrent.Datastructures.BlockingConcurrentQueue -import Control.Exception -import Data.Maybe - -import Eventloop.Module.Websocket.Keyboard.Types -import Eventloop.Module.Websocket.Mouse.Types -import Eventloop.Module.Websocket.Canvas.Types -import Eventloop.Module.File.Types -import Eventloop.Module.StatefulGraphics.Types -import Eventloop.Module.StdIn.Types -import Eventloop.Module.StdOut.Types -import Eventloop.Module.Timer.Types - -import Eventloop.Types.Common -import Eventloop.Types.Events -import Eventloop.Types.Exception -import Eventloop.Utility.Websockets - - -type Initializer = SharedIOConstants -> SharedIOState -> IO (SharedIOConstants, SharedIOState, IOConstants, IOState) -type EventRetriever = SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> IO [In] -type PreProcessor = SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> In -> IO [In] -type PostProcessor = SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> Out -> IO [Out] -type EventSender = SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> Out -> IO () -type Teardown = SharedIOConstants -> SharedIOState -> IOConstants -> IOState -> IO SharedIOState - -type OutEventRouter = Out -> EventloopModuleIdentifier - -type InEventQueue = BlockingConcurrentQueue In -type OutEventQueue = BlockingConcurrentQueue Out -type SenderEventQueue = BlockingConcurrentQueue Out - --- System Configurations -data EventloopModuleConfiguration - = EventloopModuleConfiguration { moduleId :: EventloopModuleIdentifier - , ioConstants :: IOConstants - , ioStateT :: TVar IOState - , initializerM :: Maybe Initializer - , retrieverM :: Maybe EventRetriever - , preprocessorM :: Maybe PreProcessor - , postprocessorM :: Maybe PostProcessor - , senderConfigM :: Maybe EventloopModuleSenderConfiguration - , teardownM :: Maybe Teardown - } - - -data EventloopModuleSenderConfiguration - = EventloopModuleSenderConfiguration { sender :: EventSender - , senderEventQueue :: BlockingConcurrentQueue Out - } - - -data EventloopConfiguration progstateT - = EventloopConfiguration { progstateT :: TVar progstateT - , eventloopFunc :: progstateT -> In -> (progstateT, [Out]) - , inEventQueue :: InEventQueue - , outEventQueue :: OutEventQueue - } - - -data EventloopSystemConfiguration progstateT - = EventloopSystemConfiguration { eventloopConfig :: EventloopConfiguration progstateT - , moduleConfigs :: [EventloopModuleConfiguration] - , sharedIOConstants :: SharedIOConstants - , sharedIOStateT :: TVar SharedIOState - , systemThreadId :: ThreadId - , retrieverThreadsM :: MVar [Thread] - , outRouterThreadM :: MVar Thread - , senderThreadsM :: MVar [Thread] - , exceptions :: ExceptionCollection SomeException - , isStoppingM :: MVar Bool - } - --- Setup Configurations -data EventloopSetupConfiguration progstateT - = EventloopSetupConfiguration { beginProgstate :: progstateT - , eventloopF :: progstateT -> In -> (progstateT, [Out]) - , setupModuleConfigurations :: [EventloopSetupModuleConfiguration] - } - - -data EventloopSetupModuleConfiguration - = EventloopSetupModuleConfiguration { moduleIdentifier :: EventloopModuleIdentifier - , initializerF :: Maybe Initializer - , eventRetrieverF :: Maybe EventRetriever - , preprocessorF :: Maybe PreProcessor - , postprocessorF :: Maybe PostProcessor - , eventSenderF :: Maybe EventSender - , teardownF :: Maybe Teardown - } - - --- Shared IO State -data SharedIOConstants = SharedIOConstants { safePrintToken :: SafePrintToken - , measureText :: CanvasText -> IO ScreenDimensions - } -data SharedIOState = SharedIOState {} - --- Modules IO State -data IOConstants = MouseConstants { clientSocket :: ClientSocket - , clientConnection :: Connection - , serverSocket :: ServerSocket - } - | KeyboardConstants { clientSocket :: ClientSocket - , clientConnection :: Connection - , serverSocket :: ServerSocket - } - | CanvasConstants { canvasSystemReceiveBuffer :: CanvasSystemReceiveBuffer - , clientSocket :: ClientSocket - , clientConnection :: Connection - , serverSocket :: ServerSocket - } - | StdInConstants { stdInInQueue :: BlockingConcurrentQueue StdInIn - } - | TimerConstants { tickInQueue :: BlockingConcurrentQueue TimerIn - } - | FileConstants { fileInQueue :: BlockingConcurrentQueue FileIn - } - | NoConstants - deriving Show - -data IOState = TimerState { startedIntervalTimers :: [StartedTimer] - , startedTimers :: [StartedTimer] - } - | FileState { opened :: [OpenFile] - } - | StatefulGraphicsState { states :: GraphicsStates - } - | NoState +module Eventloop.Types.System where + +import Control.Concurrent +import Control.Concurrent.ExceptionCollection +import Control.Concurrent.MVar +import Control.Concurrent.Thread +import Control.Concurrent.SafePrint +import Control.Concurrent.STM +import Control.Concurrent.Datastructures.BlockingConcurrentQueue +import Control.Exception +import Data.Maybe + +import Eventloop.Module.Websocket.Keyboard.Types +import Eventloop.Module.Websocket.Mouse.Types +import Eventloop.Module.Websocket.Canvas.Types +import Eventloop.Module.File.Types +import Eventloop.Module.StatefulGraphics.Types +import Eventloop.Module.StdIn.Types +import Eventloop.Module.StdOut.Types +import Eventloop.Module.Timer.Types + +import Eventloop.Types.Common +import Eventloop.Types.Events +import Eventloop.Types.Exception +import Eventloop.Utility.Websockets + + +type Initializer = SharedIOConstants -> SharedIOState -> IO (SharedIOConstants, SharedIOState, IOConstants, IOState) +type EventRetriever = SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> IO [In] +type PreProcessor = SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> In -> IO [In] +type PostProcessor = SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> Out -> IO [Out] +type EventSender = SharedIOConstants -> TVar SharedIOState -> IOConstants -> TVar IOState -> Out -> IO () +type Teardown = SharedIOConstants -> SharedIOState -> IOConstants -> IOState -> IO SharedIOState + +type OutEventRouter = Out -> EventloopModuleIdentifier + +type InEventQueue = BlockingConcurrentQueue In +type OutEventQueue = BlockingConcurrentQueue Out +type SenderEventQueue = BlockingConcurrentQueue Out + +-- System Configurations +data EventloopModuleConfiguration + = EventloopModuleConfiguration { moduleId :: EventloopModuleIdentifier + , ioConstants :: IOConstants + , ioStateT :: TVar IOState + , initializerM :: Maybe Initializer + , retrieverM :: Maybe EventRetriever + , preprocessorM :: Maybe PreProcessor + , postprocessorM :: Maybe PostProcessor + , senderConfigM :: Maybe EventloopModuleSenderConfiguration + , teardownM :: Maybe Teardown + } + + +data EventloopModuleSenderConfiguration + = EventloopModuleSenderConfiguration { sender :: EventSender + , senderEventQueue :: BlockingConcurrentQueue Out + } + + +data EventloopConfiguration progstateT + = EventloopConfiguration { progstateT :: TVar progstateT + , eventloopFunc :: progstateT -> In -> (progstateT, [Out]) + , inEventQueue :: InEventQueue + , outEventQueue :: OutEventQueue + } + + +data EventloopSystemConfiguration progstateT + = EventloopSystemConfiguration { eventloopConfig :: EventloopConfiguration progstateT + , moduleConfigs :: [EventloopModuleConfiguration] + , sharedIOConstants :: SharedIOConstants + , sharedIOStateT :: TVar SharedIOState + , systemThreadId :: ThreadId + , retrieverThreadsM :: MVar [Thread] + , outRouterThreadM :: MVar Thread + , senderThreadsM :: MVar [Thread] + , exceptions :: ExceptionCollection SomeException + , isStoppingM :: MVar Bool + } + +-- Setup Configurations +data EventloopSetupConfiguration progstateT + = EventloopSetupConfiguration { beginProgstate :: progstateT + , eventloopF :: progstateT -> In -> (progstateT, [Out]) + , setupModuleConfigurations :: [EventloopSetupModuleConfiguration] + } + + +data EventloopSetupModuleConfiguration + = EventloopSetupModuleConfiguration { moduleIdentifier :: EventloopModuleIdentifier + , initializerF :: Maybe Initializer + , eventRetrieverF :: Maybe EventRetriever + , preprocessorF :: Maybe PreProcessor + , postprocessorF :: Maybe PostProcessor + , eventSenderF :: Maybe EventSender + , teardownF :: Maybe Teardown + } + + +-- Shared IO State +data SharedIOConstants = SharedIOConstants { safePrintToken :: SafePrintToken + , measureText :: CanvasText -> IO ScreenDimensions + } +data SharedIOState = SharedIOState {} + +-- Modules IO State +data IOConstants = MouseConstants { clientSocket :: ClientSocket + , clientConnection :: Connection + , serverSocket :: ServerSocket + } + | KeyboardConstants { clientSocket :: ClientSocket + , clientConnection :: Connection + , serverSocket :: ServerSocket + } + | CanvasConstants { canvasSystemReceiveBuffer :: CanvasSystemReceiveBuffer + , clientSocket :: ClientSocket + , clientConnection :: Connection + , serverSocket :: ServerSocket + } + | StdInConstants { stdInInQueue :: BlockingConcurrentQueue StdInIn + } + | TimerConstants { tickInQueue :: BlockingConcurrentQueue TimerIn + } + | FileConstants { fileInQueue :: BlockingConcurrentQueue FileIn + } + | NoConstants + deriving Show + +data IOState = TimerState { startedIntervalTimers :: [StartedTimer] + , startedTimers :: [StartedTimer] + } + | FileState { opened :: [OpenFile] + } + | StatefulGraphicsState { states :: GraphicsStates + } + | NoState diff --git a/src/Eventloop/Utility/Config.hs b/src/Eventloop/Utility/Config.hs --- a/src/Eventloop/Utility/Config.hs +++ b/src/Eventloop/Utility/Config.hs @@ -1,8 +1,8 @@ -module Eventloop.Utility.Config where - -import Eventloop.Utility.Websockets - -ipAddress = "127.0.0.1" :: Host -keyboardPort = 9161 :: Port -mousePort = 9162 :: Port +module Eventloop.Utility.Config where + +import Eventloop.Utility.Websockets + +ipAddress = "127.0.0.1" :: Host +keyboardPort = 9161 :: Port +mousePort = 9162 :: Port canvasPort = 9163 :: Port diff --git a/src/Eventloop/Utility/Trees/GeneralTree.hs b/src/Eventloop/Utility/Trees/GeneralTree.hs --- a/src/Eventloop/Utility/Trees/GeneralTree.hs +++ b/src/Eventloop/Utility/Trees/GeneralTree.hs @@ -1,140 +1,139 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} -module Eventloop.Utility.Trees.GeneralTree where - -import GHC.Generics (Generic) -import Control.DeepSeq - -import Eventloop.Module.BasicShapes.Types -import Eventloop.Utility.Vectors -import Eventloop.Utility.Trees.LayoutTree - - -data GeneralTree = GeneralTreeBox [GeneralNodeContent] [(GeneralLine, GeneralTree)] - deriving (Show, Eq, Generic, NFData) - -data GeneralNodeContent = GeneralNodeText FillColor String - | GeneralNode FillColor Radius - deriving (Show, Eq, Generic, NFData) - -data GeneralLine = GeneralLine StrokeColor - deriving (Show, Eq, Generic, NFData) - - -type LeftOffset = X -type TopOffset = Y -type RightOffset = X -type BottomOffset = Y -type Middle = GraphicalNumeric - -type Pos = (X, Y) - -class GeneralizeTree a where - generalizeTree :: a -> GeneralTree - -instance GeneralizeTree GeneralTree where - generalizeTree a = a - - - --- Courier 16px -textFont = "Courier" -textHeight = 16 :: Float -- px -charWidth = 10 :: Float - -marginBetweenTrees = 10 :: Float -marginBetweenNodeContent = 2 :: Float -marginBetweenNodeRows = 20 :: Float -marginBetweenNodeColumns = 20 :: Float - - - - -generalNodeDimension :: GeneralTree -> Dimensions -generalNodeDimension (GeneralTreeBox content _) = flattenDimensions contentDimensions - where - contentDimensions = map generalNodeContentDimension content - - -flattenDimensions :: [Dimensions] -> Dimensions -flattenDimensions [] = (0.0,0.0) -flattenDimensions [d] = d -flattenDimensions ((w,h):ds) = (max w wTotal, h + marginBetweenNodeContent + hTotal) - where - (wTotal, hTotal) = flattenDimensions ds - - -generalNodeContentDimension :: GeneralNodeContent -> Dimensions -generalNodeContentDimension (GeneralNodeText _ str) = textSize str -generalNodeContentDimension (GeneralNode _ r ) = (2*r, 2*r) - - -layoutGeneralTree :: LeftOffset -> TopOffset -> GeneralTree -> (LayoutTree, RightOffset, BottomOffset) -layoutGeneralTree leftOffset topOffset box@(GeneralTreeBox content children) = (LBox (Point (x, y)) topConnect bottomConnect lcs lchildrenWithLines, rightOffset, bottomOffsetChildren) - where - x = leftBorder - y = topOffset - middle = (rightOffset - leftOffset) / 2 + leftOffset - rightOffset = max rightOffsetChildren (leftOffset + width) - leftBorder = middle - (width / 2) - topConnect = Point (width / 2, 0) - bottomConnect = Point (width / 2, height) - (width, height) = generalNodeDimension box - lcs = layoutGeneralNodeContentList (width / 2) 0 content - (lchildrenWithLines, rightOffsetChildren, bottomOffsetChildren) = layoutGeneralTreeChildren leftOffset (topOffset + marginBetweenNodeRows + height) children - -layoutGeneralTreeChildren :: LeftOffset -> TopOffset -> [(GeneralLine, GeneralTree)] -> ([(LayoutLine, LayoutTree)], RightOffset, BottomOffset) -layoutGeneralTreeChildren left top treesWithLines =(zip lLines lTrees, right, bottom) - where - lines = map fst treesWithLines - generalTrees = map snd treesWithLines - lLines = map layoutLine lines - (lTrees, right, bottom) = layoutGeneralTrees left top generalTrees - -layoutLine :: GeneralLine -> LayoutLine -layoutLine (GeneralLine color) = LayoutLine color - -layoutGeneralTrees :: LeftOffset -> TopOffset -> [GeneralTree] -> ([LayoutTree], RightOffset, BottomOffset) -layoutGeneralTrees left top [] = ([], left, top) -layoutGeneralTrees left top [box] = (\(a,b,c) -> ([a],b,c)) $ layoutGeneralTree left top box -layoutGeneralTrees left top (box:bs) = (lbox:lrest, rightRest, max bottom bottomRest) - where - (lbox, right , bottom) = layoutGeneralTree left top box - (lrest, rightRest, bottomRest) = (layoutGeneralTrees (right + marginBetweenNodeColumns) top bs) - -layoutGeneralNodeContentList :: Middle -> Height -> [GeneralNodeContent] -> [LayoutNodeContent] -layoutGeneralNodeContentList _ _ [] = [] -layoutGeneralNodeContentList middle height [nc] = [layoutGeneralNodeContent (middle, height) nc] -layoutGeneralNodeContentList middle height (nc:ncs) = lnc:(layoutGeneralNodeContentList middle height' ncs) - where - height' = height + ncHeight + marginBetweenNodeContent - (_, ncHeight) = generalNodeContentDimension nc - lnc = layoutGeneralNodeContent (middle, height) nc - -layoutGeneralNodeContent :: Pos -> GeneralNodeContent -> LayoutNodeContent -layoutGeneralNodeContent (middle, top) gnc@(GeneralNodeText color str) = LayoutNodeText color (Point (x,y)) str (textSize str) - where - x = middle - y = top - (w, h) = generalNodeContentDimension gnc - -layoutGeneralNodeContent (middle, top) gnc@(GeneralNode color rad) = LayoutNode color (Point (x,y)) rad - where - x = middle - y = top + h/2 - (w, h) = generalNodeContentDimension gnc - --- (width, height) -textSize :: [Char] -> (Float, Float) -textSize str = (textWidth, textHeight) - where - textWidth = charWidth * (fromIntegral (length str)) - - -treeIndex :: Int -> Offset -> (Shape, LeftOffset) -treeIndex i (x, y) = (text, x + wText) - where - iStr = show i - (wText, hText) = textSize iStr - p = Point (x, y) - text = Text iStr "Courier" 20 p AlignLeft (255,75,75, 255) 1 (0,0,0,0) Nothing - +{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +module Eventloop.Utility.Trees.GeneralTree where + +import GHC.Generics (Generic) +import Control.DeepSeq + +import Eventloop.Module.BasicShapes.Types +import Eventloop.Utility.Vectors +import Eventloop.Utility.Trees.LayoutTree + + +data GeneralTree = GeneralTreeBox [GeneralNodeContent] [(GeneralLine, GeneralTree)] + deriving (Show, Eq, Generic, NFData) + +data GeneralNodeContent = GeneralNodeText FillColor String + | GeneralNode FillColor Radius + deriving (Show, Eq, Generic, NFData) + +data GeneralLine = GeneralLine StrokeColor + deriving (Show, Eq, Generic, NFData) + + +type LeftOffset = X +type TopOffset = Y +type RightOffset = X +type BottomOffset = Y +type Middle = GraphicalNumeric + +type Pos = (X, Y) + +class GeneralizeTree a where + generalizeTree :: a -> GeneralTree + +instance GeneralizeTree GeneralTree where + generalizeTree a = a + + + +-- Courier 16px +textFont = "Courier" +textHeight = 16 :: Float -- px +charWidth = 10 :: Float + +marginBetweenTrees = 10 :: Float +marginBetweenNodeContent = 2 :: Float +marginBetweenNodeRows = 20 :: Float +marginBetweenNodeColumns = 20 :: Float + + + + +generalNodeDimension :: GeneralTree -> Dimensions +generalNodeDimension (GeneralTreeBox content _) = flattenDimensions contentDimensions + where + contentDimensions = map generalNodeContentDimension content + + +flattenDimensions :: [Dimensions] -> Dimensions +flattenDimensions [] = (0.0,0.0) +flattenDimensions [d] = d +flattenDimensions ((w,h):ds) = (max w wTotal, h + marginBetweenNodeContent + hTotal) + where + (wTotal, hTotal) = flattenDimensions ds + + +generalNodeContentDimension :: GeneralNodeContent -> Dimensions +generalNodeContentDimension (GeneralNodeText _ str) = textSize str +generalNodeContentDimension (GeneralNode _ r ) = (2*r, 2*r) + + +layoutGeneralTree :: LeftOffset -> TopOffset -> GeneralTree -> (LayoutTree, RightOffset, BottomOffset) +layoutGeneralTree leftOffset topOffset box@(GeneralTreeBox content children) = (LBox (Point (x, y)) topConnect bottomConnect lcs lchildrenWithLines, rightOffset, bottomOffsetChildren) + where + x = leftBorder + y = topOffset + middle = (rightOffset - leftOffset) / 2 + leftOffset + rightOffset = max rightOffsetChildren (leftOffset + width) + leftBorder = middle - (width / 2) + topConnect = Point (width / 2, 0) + bottomConnect = Point (width / 2, height) + (width, height) = generalNodeDimension box + lcs = layoutGeneralNodeContentList (width / 2) 0 content + (lchildrenWithLines, rightOffsetChildren, bottomOffsetChildren) = layoutGeneralTreeChildren leftOffset (topOffset + marginBetweenNodeRows + height) children + +layoutGeneralTreeChildren :: LeftOffset -> TopOffset -> [(GeneralLine, GeneralTree)] -> ([(LayoutLine, LayoutTree)], RightOffset, BottomOffset) +layoutGeneralTreeChildren left top treesWithLines =(zip lLines lTrees, right, bottom) + where + lines = map fst treesWithLines + generalTrees = map snd treesWithLines + lLines = map layoutLine lines + (lTrees, right, bottom) = layoutGeneralTrees left top generalTrees + +layoutLine :: GeneralLine -> LayoutLine +layoutLine (GeneralLine color) = LayoutLine color + +layoutGeneralTrees :: LeftOffset -> TopOffset -> [GeneralTree] -> ([LayoutTree], RightOffset, BottomOffset) +layoutGeneralTrees left top [] = ([], left, top) +layoutGeneralTrees left top [box] = (\(a,b,c) -> ([a],b,c)) $ layoutGeneralTree left top box +layoutGeneralTrees left top (box:bs) = (lbox:lrest, rightRest, max bottom bottomRest) + where + (lbox, right , bottom) = layoutGeneralTree left top box + (lrest, rightRest, bottomRest) = (layoutGeneralTrees (right + marginBetweenNodeColumns) top bs) + +layoutGeneralNodeContentList :: Middle -> Height -> [GeneralNodeContent] -> [LayoutNodeContent] +layoutGeneralNodeContentList _ _ [] = [] +layoutGeneralNodeContentList middle height [nc] = [layoutGeneralNodeContent (middle, height) nc] +layoutGeneralNodeContentList middle height (nc:ncs) = lnc:(layoutGeneralNodeContentList middle height' ncs) + where + height' = height + ncHeight + marginBetweenNodeContent + (_, ncHeight) = generalNodeContentDimension nc + lnc = layoutGeneralNodeContent (middle, height) nc + +layoutGeneralNodeContent :: Pos -> GeneralNodeContent -> LayoutNodeContent +layoutGeneralNodeContent (middle, top) gnc@(GeneralNodeText color str) = LayoutNodeText color (Point (x,y)) str (textSize str) + where + x = middle + y = top + (w, h) = generalNodeContentDimension gnc + +layoutGeneralNodeContent (middle, top) gnc@(GeneralNode color rad) = LayoutNode color (Point (x,y)) rad + where + x = middle + y = top + h/2 + (w, h) = generalNodeContentDimension gnc + +-- (width, height) +textSize :: [Char] -> (Float, Float) +textSize str = (textWidth, textHeight) + where + textWidth = charWidth * (fromIntegral (length str)) + + +treeIndex :: Int -> Offset -> (Shape, LeftOffset) +treeIndex i (x, y) = (text, x + wText) + where + iStr = show i + (wText, hText) = textSize iStr + p = Point (x, y) + text = Text iStr "Courier" 20 p AlignLeft (255,75,75, 255) 1 (0,0,0,0) Nothing diff --git a/src/Eventloop/Utility/Trees/LayoutTree.hs b/src/Eventloop/Utility/Trees/LayoutTree.hs --- a/src/Eventloop/Utility/Trees/LayoutTree.hs +++ b/src/Eventloop/Utility/Trees/LayoutTree.hs @@ -1,58 +1,58 @@ -module Eventloop.Utility.Trees.LayoutTree where - -import Eventloop.Module.BasicShapes.Types -import Eventloop.Utility.Vectors - -data LayoutTree = LBox Point TopConnect BottomConnect [LayoutNodeContent] [(LayoutLine, LayoutTree)] - deriving (Show, Eq) - -data LayoutNodeContent = LayoutNodeText FillColor Point String Dimensions - | LayoutNode FillColor Point Radius - deriving (Show, Eq) - -data LayoutLine = LayoutLine StrokeColor - deriving (Show, Eq) - -type TopConnect = Connect -type BottomConnect = Connect -type Connect = Point - - -marginLine = 3 :: Float -lineThickness = 1 :: Float -textThickness = 1 :: Float -textFont = "Courier" - - -printTree :: LayoutTree -> Shape -printTree (LBox (Point offset) _ botConnect nodeContents childrenWithLines) = CompositeShape (shapeChildren ++ shapeLines ++ shapeContents) Nothing Nothing - where - children = map snd childrenWithLines - shapeChildren = map printTree children - shapeContents = map (printNodeContent offset) nodeContents - shapeLines = map (printLine (botConnect')) childrenWithLines - botConnect' = (Point offset) |+| botConnect - - - -printNodeContent :: Offset -> LayoutNodeContent -> Shape -printNodeContent (xOffset, yOffset) (LayoutNodeText fillColor p text (_, height)) = Text text textFont height ((Point (xOffset, yOffset)) |+| p) AlignCenter fillColor textThickness (0,0,0,0) Nothing -printNodeContent (xOffset, yOffset) (LayoutNode fillColor p r) = Circle ((Point (xOffset, yOffset)) |+| p) r fillColor lineThickness (0,0,0,0) Nothing - - -printLine :: Point -> (LayoutLine, LayoutTree) -> Shape -printLine startPoint ((LayoutLine lineColor),(LBox point topConnect _ _ _)) = Line startMarg endMarg lineThickness lineColor Nothing - where - startMarg = marginizeLinePoints marginLine startPoint endPoint - endMarg = marginizeLinePoints marginLine endPoint startPoint - endPoint = point |+| topConnect - - -marginizeLinePoints :: GraphicalNumeric -> Point -> Point -> Point -marginizeLinePoints margin p1@(Point (xStart, yStart)) p2@(Point (xEnd, yEnd)) = Point (xStart', yStart') - where - xStart' = xStart + fraction * xSize - yStart' = yStart + fraction * ySize - fraction = margin / size - size = lengthBetweenPoints p1 p2 +module Eventloop.Utility.Trees.LayoutTree where + +import Eventloop.Module.BasicShapes.Types +import Eventloop.Utility.Vectors + +data LayoutTree = LBox Point TopConnect BottomConnect [LayoutNodeContent] [(LayoutLine, LayoutTree)] + deriving (Show, Eq) + +data LayoutNodeContent = LayoutNodeText FillColor Point String Dimensions + | LayoutNode FillColor Point Radius + deriving (Show, Eq) + +data LayoutLine = LayoutLine StrokeColor + deriving (Show, Eq) + +type TopConnect = Connect +type BottomConnect = Connect +type Connect = Point + + +marginLine = 3 :: Float +lineThickness = 1 :: Float +textThickness = 1 :: Float +textFont = "Courier" + + +printTree :: LayoutTree -> Shape +printTree (LBox (Point offset) _ botConnect nodeContents childrenWithLines) = CompositeShape (shapeChildren ++ shapeLines ++ shapeContents) Nothing Nothing + where + children = map snd childrenWithLines + shapeChildren = map printTree children + shapeContents = map (printNodeContent offset) nodeContents + shapeLines = map (printLine (botConnect')) childrenWithLines + botConnect' = (Point offset) |+| botConnect + + + +printNodeContent :: Offset -> LayoutNodeContent -> Shape +printNodeContent (xOffset, yOffset) (LayoutNodeText fillColor p text (_, height)) = Text text textFont height ((Point (xOffset, yOffset)) |+| p) AlignCenter fillColor textThickness (0,0,0,0) Nothing +printNodeContent (xOffset, yOffset) (LayoutNode fillColor p r) = Circle ((Point (xOffset, yOffset)) |+| p) r fillColor lineThickness (0,0,0,0) Nothing + + +printLine :: Point -> (LayoutLine, LayoutTree) -> Shape +printLine startPoint ((LayoutLine lineColor),(LBox point topConnect _ _ _)) = Line startMarg endMarg lineThickness lineColor Nothing + where + startMarg = marginizeLinePoints marginLine startPoint endPoint + endMarg = marginizeLinePoints marginLine endPoint startPoint + endPoint = point |+| topConnect + + +marginizeLinePoints :: GraphicalNumeric -> Point -> Point -> Point +marginizeLinePoints margin p1@(Point (xStart, yStart)) p2@(Point (xEnd, yEnd)) = Point (xStart', yStart') + where + xStart' = xStart + fraction * xSize + yStart' = yStart + fraction * ySize + fraction = margin / size + size = lengthBetweenPoints p1 p2 (xSize, ySize) = differenceBetweenPoints p1 p2 diff --git a/src/Eventloop/Utility/Vectors.hs b/src/Eventloop/Utility/Vectors.hs --- a/src/Eventloop/Utility/Vectors.hs +++ b/src/Eventloop/Utility/Vectors.hs @@ -1,264 +1,264 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass, FlexibleInstances #-} -module Eventloop.Utility.Vectors where - -import GHC.Generics (Generic) -import Control.DeepSeq -import Data.Fixed (mod') - -type Angle = Float -- ^In degrees -type Radians = Float -type Length = Float - -type X = Float -type Y = Float -type Offset = (X, Y) - -data PolarCoord = PolarCoord (Length, Radians) - deriving (Show, Eq) - -data Point = Point (X, Y) - deriving (Show, Eq, Generic, NFData) - -class Coord a where - x :: a -> X - y :: a -> Y - -instance Coord Point where - x (Point (x_, _)) = x_ - y (Point (_, y_)) = y_ - -instance Coord PolarCoord where - x = x.toPoint - y = y.toPoint - - -class ExtremaCoord a where - xMin :: a -> X - xMax :: a -> X - yMin :: a -> Y - yMax :: a -> Y - -instance ExtremaCoord [Point] where - xMin points = minimum $ map x points - xMax points = maximum $ map x points - yMin points = minimum $ map y points - yMax points = maximum $ map y points - - -degreesToRadians :: Angle -> Radians -degreesToRadians d = (pi / 180) * d - - -radiansToDegrees :: Radians -> Angle -radiansToDegrees rads = (180 / pi) * rads - - -lengthToPoint :: Point -> Length -lengthToPoint = lengthBetweenPoints originPoint - - -lengthBetweenPoints :: Point -> Point -> Length -lengthBetweenPoints p1 p2 = sqrt (x'^2 + y'^2) - where - (x', y') = differenceBetweenPoints p1 p2 - - -differenceBetweenPoints :: Point -> Point -> (X, Y) -differenceBetweenPoints (Point (x1, y1)) (Point (x2, y2)) = (x2 - x1, y2 - y1) - - -averagePoint :: [Point] -> Point -averagePoint points - = average - where - total = foldl (|+|) originPoint points - average = total |/ (toInteger (length points)) - - --- | Returns the vector perpendicular on the given vector between the 2 points. Always has positive y and vector length 1; y is inverted in canvas -downPerpendicular :: Point -> Point -> Point -downPerpendicular p1@(Point (x1, y1)) p2@(Point (x2, y2)) - | y2 > y1 = Point ((-1) * sign * (abs yv) / size, (abs xv) / size) - | otherwise = Point ( sign * (abs yv) / size, (abs xv) / size) - where - (xv, yv) = differenceBetweenPoints p1 p2 - size = lengthBetweenPoints p1 p2 - sign = case xv of - 0 -> (-1) - _ -> xv / (abs xv) - - --- | Returns the vector perpendicular on the given vector between the 2 points. Always has negative y and vector length 1; y is inverted in canvas -upPerpendicular :: Point -> Point -> Point -upPerpendicular p1 p2 = negateVector $ downPerpendicular p1 p2 - - -followVector :: Float -> Point -> Point -> Point -followVector distance followP startP - = (followP |* fraction) |+| startP - where - fraction = distance / size - size = lengthBetweenPoints followP originPoint - - -intersectVector :: Point -> Point -> Point -> Point -> Maybe Point -intersectVector s1@(Point (sx1, sy1)) v1@(Point (vx1, vy1)) s2@(Point (sx2, sy2)) v2@(Point (vx2, vy2)) - -- Optimization - | sx1 == sx2 && sy1 == sy2 = Just $ Point (sx1, sy1) - - -- alpha relation exists - | alpha4_1_divisor /= 0 = Just $ Point(vx1 * alpha4_1 + sx1, vy1 * alpha4_1 + sy1) - -- 2 or more directions are empty in such a way alpha does not exist: (v2x == 0 || v1y == 0) && (v1x == 0 && v2y == 0) - - -- 2 vector direction == zero - | vx1 == 0 && vy1 /= 0 && vx2 == 0 && vy2 /= 0 && sx1 == sx2 = Just $ Point (sx1, alpha_vy1_zero * vy2 + sy2) -- Do as if vy1 == 0 even if it isn't. We need to choose a point - | vx1 /= 0 && vy1 == 0 && vx2 /= 0 && vy2 == 0 && sy1 == sy2 = Just $ Point (alpha_vx1_zero * vx2 + sx2, sy1) - - | vx1 == 0 && vy1 == 0 && vx2 /= 0 && vy2 /= 0 && alpha_vx1_zero == alpha_vy1_zero = Just $ Point (alpha_vx1_zero * vx2 + sx2, alpha_vy1_zero * vy2 + sy2) - | vx1 /= 0 && vy1 /= 0 && vx2 == 0 && vy2 == 0 && alpha_vx2_zero == alpha_vy2_zero = Just $ Point (alpha_vx2_zero * vx1 + sx1, alpha_vy2_zero * vy1 + sy1) - - -- 3 vector direction == zero - | vx1 /= 0 && vy1 == 0 && vx2 == 0 && vy2 == 0 && sy1 == sy2 = Just $ Point (alpha_vx2_zero * vx1 + sx1, sy1) - | vx1 == 0 && vy1 /= 0 && vx2 == 0 && vy2 == 0 && sx1 == sx2 = Just $ Point (sx1, alpha_vy2_zero * vy1 + sy1) - | vx1 == 0 && vy1 == 0 && vx2 /= 0 && vy2 == 0 && sy1 == sy2 = Just $ Point (alpha_vx1_zero * vx2 + sx2, sy2) - | vx1 == 0 && vy1 == 0 && vx2 == 0 && vy2 /= 0 && sx1 == sx2 = Just $ Point (sx2, alpha_vy1_zero * vy2 + sy2) - - -- 4 vector direction == zero - | vx1 == 0 && vy1 == 0 && vx2 == 0 && vy2 == 0 && s1 == s2 = Just $ s1 - - | otherwise = Nothing - where - alpha4_1_divisor = vx2 * vy1 - vx1 * vy2 - alpha4 (Point (dx1, dy1)) (Point (x1, y1)) (Point (dx2, dy2)) (Point (x2, y2)) = (dy2 * x1 - x2 * dy2 + dx2 * y2 - dx2 * y1) / (dx2 * dy1 - dx1 * dy2) - alpha4_1 = alpha4 v1 s1 v2 s2 - alpha4_2 = alpha4 v2 s2 v1 s1 - - alphaZero dx1 x1 x2 = (x2 - x1) / dx1 - alpha_vx1_zero = alphaZero vx2 sx2 sx1 - alpha_vx2_zero = alphaZero vx1 sx1 sx2 - alpha_vy1_zero = alphaZero vy2 sy2 sy1 - alpha_vy2_zero = alphaZero vy1 sy1 sy2 - - -turnToVector :: Point -> Radians -> Point -> Point -turnToVector toTurn@(Point (tux, tuy)) a turnTo@(Point (tox, toy)) - | (diffRadianCCW >= 0 && diffRadianCCW <= half) || (diffRadianCCW' >= 0 && diffRadianCCW' <= half) = toPoint (PolarCoord (1, radianToTurn + a)) - | otherwise = toPoint (PolarCoord (1, radianToTurn - a)) - where - (PolarCoord (_, radianToTurn)) = toPolarCoord toTurn - (PolarCoord (_, radianTurnTo)) = toPolarCoord turnTo - whole = 2 * pi - half = pi - quart = 0.5 * pi - diffRadianCCW = radianTurnTo - radianToTurn - radianTurnTo' = mod' (radianTurnTo - quart) whole - radianToTurn' = mod' (radianToTurn - quart) whole - diffRadianCCW' = radianTurnTo' - radianToTurn' -- Extra check due to hard split between 0 and 360 - - -originPoint = Point (0,0) - -class Translate a where - translate :: Point -> a -> a - - -class (Coord a) => Vector2D a where - (|+|) :: a -> a -> a - (|-|) :: a -> a -> a - (|/) :: (Real b) => a -> b -> a - (|*) :: (Real b) => a -> b -> a - negateVector :: a -> a - angleBetween :: a -> a -> Radians - -instance Vector2D PolarCoord where - pc1 |+| pc2 = toPolarCoord $ (toPoint pc1) |+| (toPoint pc2) - pc1 |-| pc2 = toPolarCoord $ (toPoint pc1) |-| (toPoint pc2) - (PolarCoord (l, a)) |/ scalar - = PolarCoord (fromRational (l' / scalar'), a) - where - l' = toRational l - scalar' = toRational scalar - (PolarCoord (l, a)) |* scalar - = PolarCoord (fromRational (l' * scalar'), a) - where - l' = toRational l - scalar' = toRational scalar - negateVector pc1 = rotateLeftAround (Point (0,0)) 180 pc1 - - angleBetween pc1 pc2 - = angleBetween (toPoint pc1) (toPoint pc2) - - -instance Vector2D Point where - (Point (x1, y1)) |+| (Point (x2, y2)) - = Point (x1 + x2, y1 + y2) - - (Point (x1, y1)) |-| (Point (x2, y2)) - = Point (x1 - x2, y1 - y2) - - (Point (x1, y1)) |/ scalar - = Point (fromRational x', fromRational y') - where - x' = toRational x1 / toRational scalar - y' = toRational y1 / toRational scalar - - (Point (x1, y1)) |* scalar - = Point (fromRational x', fromRational y') - where - x' = toRational x1 * toRational scalar - y' = toRational y1 * toRational scalar - - negateVector (Point (x, y)) - = Point (-x, -y) - - angleBetween v1@(Point (v1x, v1y)) v2@(Point (v2x, v2y)) - = acos (dotProduct / (lv1 * lv2)) - where - dotProduct = v1x * v2x + v1y * v2y - lv1 = lengthToPoint v1 - lv2 = lengthToPoint v2 - - -class ToPoint a where - toPoint :: a -> Point - -instance ToPoint PolarCoord where - toPoint (PolarCoord (len, rads)) = Point (len * (cos rads), len * (sin rads)) - - -class ToPolarCoord a where - toPolarCoord :: a -> PolarCoord - -instance ToPolarCoord Point where - toPolarCoord (Point (x, y)) | x == 0 && y == 0 = PolarCoord (0.0, 0.0) - | x == 0 && y > 0 = PolarCoord (y, 0.5 * pi) - | x == 0 && y < 0 = PolarCoord (y, 1.5 * pi) - | x > 0 && y == 0 = PolarCoord (x, 0.0 * pi) - | x < 0 && y == 0 = PolarCoord (x, 1.0 * pi) - | x > 0 && y > 0 = PolarCoord (len, 0.0 * pi + localRads) - | x < 0 && y > 0 = PolarCoord (len, 1.0 * pi - localRads) - | x < 0 && y < 0 = PolarCoord (len, 1.0 * pi + localRads) - | x > 0 && y < 0 = PolarCoord (len, 2.0 * pi - localRads) - where - x' = abs x - y' = abs y - localRads = asin (y' / len) - len = lengthToPoint (Point (x, y)) - - - -class RotateLeftAround a where - rotateLeftAround :: Point -> Angle -> a -> a - -instance RotateLeftAround PolarCoord where - rotateLeftAround rotatePoint aDeg = toPolarCoord.(rotateLeftAround rotatePoint aDeg).toPoint - - -instance RotateLeftAround Point where - rotateLeftAround rotatePoint aDeg p = p'' |+| rotatePoint - where - p' = p |-| rotatePoint - pc'@(PolarCoord (len', rads')) = toPolarCoord p' - aRads = degreesToRadians aDeg - pc'' = PolarCoord (len', rads' + aRads) +{-# LANGUAGE DeriveGeneric, DeriveAnyClass, FlexibleInstances #-} +module Eventloop.Utility.Vectors where + +import GHC.Generics (Generic) +import Control.DeepSeq +import Data.Fixed (mod') + +type Angle = Float -- ^In degrees +type Radians = Float +type Length = Float + +type X = Float +type Y = Float +type Offset = (X, Y) + +data PolarCoord = PolarCoord (Length, Radians) + deriving (Show, Eq) + +data Point = Point (X, Y) + deriving (Show, Eq, Generic, NFData) + +class Coord a where + x :: a -> X + y :: a -> Y + +instance Coord Point where + x (Point (x_, _)) = x_ + y (Point (_, y_)) = y_ + +instance Coord PolarCoord where + x = x.toPoint + y = y.toPoint + + +class ExtremaCoord a where + xMin :: a -> X + xMax :: a -> X + yMin :: a -> Y + yMax :: a -> Y + +instance ExtremaCoord [Point] where + xMin points = minimum $ map x points + xMax points = maximum $ map x points + yMin points = minimum $ map y points + yMax points = maximum $ map y points + + +degreesToRadians :: Angle -> Radians +degreesToRadians d = (pi / 180) * d + + +radiansToDegrees :: Radians -> Angle +radiansToDegrees rads = (180 / pi) * rads + + +lengthToPoint :: Point -> Length +lengthToPoint = lengthBetweenPoints originPoint + + +lengthBetweenPoints :: Point -> Point -> Length +lengthBetweenPoints p1 p2 = sqrt (x'^2 + y'^2) + where + (x', y') = differenceBetweenPoints p1 p2 + + +differenceBetweenPoints :: Point -> Point -> (X, Y) +differenceBetweenPoints (Point (x1, y1)) (Point (x2, y2)) = (x2 - x1, y2 - y1) + + +averagePoint :: [Point] -> Point +averagePoint points + = average + where + total = foldl (|+|) originPoint points + average = total |/ (toInteger (length points)) + + +-- | Returns the vector perpendicular on the given vector between the 2 points. Always has positive y and vector length 1; y is inverted in canvas +downPerpendicular :: Point -> Point -> Point +downPerpendicular p1@(Point (x1, y1)) p2@(Point (x2, y2)) + | y2 > y1 = Point ((-1) * sign * (abs yv) / size, (abs xv) / size) + | otherwise = Point ( sign * (abs yv) / size, (abs xv) / size) + where + (xv, yv) = differenceBetweenPoints p1 p2 + size = lengthBetweenPoints p1 p2 + sign = case xv of + 0 -> (-1) + _ -> xv / (abs xv) + + +-- | Returns the vector perpendicular on the given vector between the 2 points. Always has negative y and vector length 1; y is inverted in canvas +upPerpendicular :: Point -> Point -> Point +upPerpendicular p1 p2 = negateVector $ downPerpendicular p1 p2 + + +followVector :: Float -> Point -> Point -> Point +followVector distance followP startP + = (followP |* fraction) |+| startP + where + fraction = distance / size + size = lengthBetweenPoints followP originPoint + + +intersectVector :: Point -> Point -> Point -> Point -> Maybe Point +intersectVector s1@(Point (sx1, sy1)) v1@(Point (vx1, vy1)) s2@(Point (sx2, sy2)) v2@(Point (vx2, vy2)) + -- Optimization + | sx1 == sx2 && sy1 == sy2 = Just $ Point (sx1, sy1) + + -- alpha relation exists + | alpha4_1_divisor /= 0 = Just $ Point(vx1 * alpha4_1 + sx1, vy1 * alpha4_1 + sy1) + -- 2 or more directions are empty in such a way alpha does not exist: (v2x == 0 || v1y == 0) && (v1x == 0 && v2y == 0) + + -- 2 vector direction == zero + | vx1 == 0 && vy1 /= 0 && vx2 == 0 && vy2 /= 0 && sx1 == sx2 = Just $ Point (sx1, alpha_vy1_zero * vy2 + sy2) -- Do as if vy1 == 0 even if it isn't. We need to choose a point + | vx1 /= 0 && vy1 == 0 && vx2 /= 0 && vy2 == 0 && sy1 == sy2 = Just $ Point (alpha_vx1_zero * vx2 + sx2, sy1) + + | vx1 == 0 && vy1 == 0 && vx2 /= 0 && vy2 /= 0 && alpha_vx1_zero == alpha_vy1_zero = Just $ Point (alpha_vx1_zero * vx2 + sx2, alpha_vy1_zero * vy2 + sy2) + | vx1 /= 0 && vy1 /= 0 && vx2 == 0 && vy2 == 0 && alpha_vx2_zero == alpha_vy2_zero = Just $ Point (alpha_vx2_zero * vx1 + sx1, alpha_vy2_zero * vy1 + sy1) + + -- 3 vector direction == zero + | vx1 /= 0 && vy1 == 0 && vx2 == 0 && vy2 == 0 && sy1 == sy2 = Just $ Point (alpha_vx2_zero * vx1 + sx1, sy1) + | vx1 == 0 && vy1 /= 0 && vx2 == 0 && vy2 == 0 && sx1 == sx2 = Just $ Point (sx1, alpha_vy2_zero * vy1 + sy1) + | vx1 == 0 && vy1 == 0 && vx2 /= 0 && vy2 == 0 && sy1 == sy2 = Just $ Point (alpha_vx1_zero * vx2 + sx2, sy2) + | vx1 == 0 && vy1 == 0 && vx2 == 0 && vy2 /= 0 && sx1 == sx2 = Just $ Point (sx2, alpha_vy1_zero * vy2 + sy2) + + -- 4 vector direction == zero + | vx1 == 0 && vy1 == 0 && vx2 == 0 && vy2 == 0 && s1 == s2 = Just $ s1 + + | otherwise = Nothing + where + alpha4_1_divisor = vx2 * vy1 - vx1 * vy2 + alpha4 (Point (dx1, dy1)) (Point (x1, y1)) (Point (dx2, dy2)) (Point (x2, y2)) = (dy2 * x1 - x2 * dy2 + dx2 * y2 - dx2 * y1) / (dx2 * dy1 - dx1 * dy2) + alpha4_1 = alpha4 v1 s1 v2 s2 + alpha4_2 = alpha4 v2 s2 v1 s1 + + alphaZero dx1 x1 x2 = (x2 - x1) / dx1 + alpha_vx1_zero = alphaZero vx2 sx2 sx1 + alpha_vx2_zero = alphaZero vx1 sx1 sx2 + alpha_vy1_zero = alphaZero vy2 sy2 sy1 + alpha_vy2_zero = alphaZero vy1 sy1 sy2 + + +turnToVector :: Point -> Radians -> Point -> Point +turnToVector toTurn@(Point (tux, tuy)) a turnTo@(Point (tox, toy)) + | (diffRadianCCW >= 0 && diffRadianCCW <= half) || (diffRadianCCW' >= 0 && diffRadianCCW' <= half) = toPoint (PolarCoord (1, radianToTurn + a)) + | otherwise = toPoint (PolarCoord (1, radianToTurn - a)) + where + (PolarCoord (_, radianToTurn)) = toPolarCoord toTurn + (PolarCoord (_, radianTurnTo)) = toPolarCoord turnTo + whole = 2 * pi + half = pi + quart = 0.5 * pi + diffRadianCCW = radianTurnTo - radianToTurn + radianTurnTo' = mod' (radianTurnTo - quart) whole + radianToTurn' = mod' (radianToTurn - quart) whole + diffRadianCCW' = radianTurnTo' - radianToTurn' -- Extra check due to hard split between 0 and 360 + + +originPoint = Point (0,0) + +class Translate a where + translate :: Point -> a -> a + + +class (Coord a) => Vector2D a where + (|+|) :: a -> a -> a + (|-|) :: a -> a -> a + (|/) :: (Real b) => a -> b -> a + (|*) :: (Real b) => a -> b -> a + negateVector :: a -> a + angleBetween :: a -> a -> Radians + +instance Vector2D PolarCoord where + pc1 |+| pc2 = toPolarCoord $ (toPoint pc1) |+| (toPoint pc2) + pc1 |-| pc2 = toPolarCoord $ (toPoint pc1) |-| (toPoint pc2) + (PolarCoord (l, a)) |/ scalar + = PolarCoord (fromRational (l' / scalar'), a) + where + l' = toRational l + scalar' = toRational scalar + (PolarCoord (l, a)) |* scalar + = PolarCoord (fromRational (l' * scalar'), a) + where + l' = toRational l + scalar' = toRational scalar + negateVector pc1 = rotateLeftAround (Point (0,0)) 180 pc1 + + angleBetween pc1 pc2 + = angleBetween (toPoint pc1) (toPoint pc2) + + +instance Vector2D Point where + (Point (x1, y1)) |+| (Point (x2, y2)) + = Point (x1 + x2, y1 + y2) + + (Point (x1, y1)) |-| (Point (x2, y2)) + = Point (x1 - x2, y1 - y2) + + (Point (x1, y1)) |/ scalar + = Point (fromRational x', fromRational y') + where + x' = toRational x1 / toRational scalar + y' = toRational y1 / toRational scalar + + (Point (x1, y1)) |* scalar + = Point (fromRational x', fromRational y') + where + x' = toRational x1 * toRational scalar + y' = toRational y1 * toRational scalar + + negateVector (Point (x, y)) + = Point (-x, -y) + + angleBetween v1@(Point (v1x, v1y)) v2@(Point (v2x, v2y)) + = acos (dotProduct / (lv1 * lv2)) + where + dotProduct = v1x * v2x + v1y * v2y + lv1 = lengthToPoint v1 + lv2 = lengthToPoint v2 + + +class ToPoint a where + toPoint :: a -> Point + +instance ToPoint PolarCoord where + toPoint (PolarCoord (len, rads)) = Point (len * (cos rads), len * (sin rads)) + + +class ToPolarCoord a where + toPolarCoord :: a -> PolarCoord + +instance ToPolarCoord Point where + toPolarCoord (Point (x, y)) | x == 0 && y == 0 = PolarCoord (0.0, 0.0) + | x == 0 && y > 0 = PolarCoord (y, 0.5 * pi) + | x == 0 && y < 0 = PolarCoord (y, 1.5 * pi) + | x > 0 && y == 0 = PolarCoord (x, 0.0 * pi) + | x < 0 && y == 0 = PolarCoord (x, 1.0 * pi) + | x > 0 && y > 0 = PolarCoord (len, 0.0 * pi + localRads) + | x < 0 && y > 0 = PolarCoord (len, 1.0 * pi - localRads) + | x < 0 && y < 0 = PolarCoord (len, 1.0 * pi + localRads) + | x > 0 && y < 0 = PolarCoord (len, 2.0 * pi - localRads) + where + x' = abs x + y' = abs y + localRads = asin (y' / len) + len = lengthToPoint (Point (x, y)) + + + +class RotateLeftAround a where + rotateLeftAround :: Point -> Angle -> a -> a + +instance RotateLeftAround PolarCoord where + rotateLeftAround rotatePoint aDeg = toPolarCoord.(rotateLeftAround rotatePoint aDeg).toPoint + + +instance RotateLeftAround Point where + rotateLeftAround rotatePoint aDeg p = p'' |+| rotatePoint + where + p' = p |-| rotatePoint + pc'@(PolarCoord (len', rads')) = toPolarCoord p' + aRads = degreesToRadians aDeg + pc'' = PolarCoord (len', rads' + aRads) p'' = toPoint pc'' diff --git a/src/Eventloop/Utility/Websockets.hs b/src/Eventloop/Utility/Websockets.hs --- a/src/Eventloop/Utility/Websockets.hs +++ b/src/Eventloop/Utility/Websockets.hs @@ -1,129 +1,128 @@ -module Eventloop.Utility.Websockets - ( module Eventloop.Utility.Websockets - , Connection - , S.iNADDR_ANY - ) where - -import qualified Network.Socket as S -import qualified Data.Text as T -import Network.WebSockets hiding (Message) -import Control.Concurrent -import Control.Concurrent.MVar -import Control.Concurrent.SafePrint -import Control.Concurrent.Thread -import Control.Exception -import Data.ByteString.Lazy - - - -type Host = [Char] -type Port = Int -type Message = [Char] -type ReceiveBuffer = MVar Message - -type ServerSocket = S.Socket -type ClientSocket = S.Socket - -type ReaderThread = Thread -type UnbufferedReaderThread = ReaderThread - -instance Show Connection where - show _ = "Connection" - -createBindListenServerSocket :: S.HostAddress -> Port -> IO ServerSocket -createBindListenServerSocket host port = do - socket <- S.socket S.AF_INET S.Stream S.defaultProtocol - S.setSocketOption socket S.ReuseAddr 1 - S.bindSocket socket (S.SockAddrInet (fromIntegral port) host) - S.listen socket 5 - return socket - - -acceptFirstConnection :: S.Socket -> IO (Connection, ClientSocket) -acceptFirstConnection serverSocket = do - (clientSocket, clientAddr) <- S.accept serverSocket - pendingConnection <- makePendingConnection clientSocket defaultConnectionOptions - connection <- acceptRequest pendingConnection - return (connection, clientSocket) - - -setupWebsocketConnection :: S.HostAddress -> Port -> IO (ClientSocket, Connection, ServerSocket) -setupWebsocketConnection host port = S.withSocketsDo $ do - serverSocket <- createBindListenServerSocket host port - (clientConnection, clientSocket) <- acceptFirstConnection serverSocket - return (clientSocket, clientConnection, serverSocket) - - - - -handleCloseRequestException :: ClientSocket -> SafePrintToken -> ConnectionException -> IO (Maybe Message) -handleCloseRequestException clientSocket safePrintToken (CloseRequest i reason) - | i == 1000 = do - safePrintLn safePrintToken "Client connection was closed elegantly." - S.sClose clientSocket - return Nothing - | otherwise = do - safePrintLn safePrintToken ("Connection was closed but reason unknown: " ++ show i ++ " " ++ show reason) - S.sClose clientSocket - return Nothing - -handleCloseRequestException clientSocket safePrintToken (ConnectionClosed) - = do - safePrintLn safePrintToken ("Connection was closed unexpectedly") - S.sClose clientSocket - throw ConnectionClosed - -handleCloseRequestException clientSocket safePrintToken (ParseException text) - = do - safePrintLn safePrintToken ("Parse exception on message: " ++ text) - S.sClose clientSocket - throw (ParseException text) - - -takeMessage :: SafePrintToken -> ClientSocket -> Connection -> IO (Maybe Message) -takeMessage safePrintToken sock conn - = handle (handleCloseRequestException sock safePrintToken) $ do - textMessage <- receiveData conn - let - message = T.unpack textMessage - return (Just message) - - -writeMessage :: Connection -> Message -> IO () -writeMessage conn message = sendTextData conn (T.pack message) - -writeBinaryMessage :: Connection -> ByteString -> IO () -writeBinaryMessage conn message = sendBinaryData conn message - - -isConnected :: S.Socket -> IO Bool -isConnected sock = S.sIsConnected sock - -closeWebsocketConnection :: SafePrintToken -> ServerSocket -> ClientSocket -> Connection -> IO () -closeWebsocketConnection safePrintToken serverSocket clientSocket clientConnection - = do - S.sClose serverSocket - isConnected <- isConnected clientSocket - case isConnected of - False -> safePrintLn safePrintToken "Tried to close client connection but was already closed" - True -> do - safePrintLn safePrintToken "Closing client connection..." - handle - (\(exception) -> - case (exception :: ConnectionException) of - ConnectionClosed -> do - safePrintLn safePrintToken "Socket still open, but stream had an error" - S.sClose clientSocket - safePrintLn safePrintToken "Client connection closed!" - _ -> safePrintLn safePrintToken "this should never happen, contact an administrator! ERROR: WS 01" - ) - ( sendClose clientConnection (T.pack "Shutting down..") - ) - - -destroyWebsocketConnection :: ServerSocket -> ClientSocket -> IO () -destroyWebsocketConnection serverSocket clientSocket - = do - S.close serverSocket - S.close clientSocket - +module Eventloop.Utility.Websockets + ( module Eventloop.Utility.Websockets + , Connection + , S.iNADDR_ANY + ) where + +import qualified Network.Socket as S +import qualified Data.Text as T +import Network.WebSockets hiding (Message) +import Control.Concurrent +import Control.Concurrent.MVar +import Control.Concurrent.SafePrint +import Control.Concurrent.Thread +import Control.Exception +import Data.ByteString.Lazy + + + +type Host = [Char] +type Port = Int +type Message = [Char] +type ReceiveBuffer = MVar Message + +type ServerSocket = S.Socket +type ClientSocket = S.Socket + +type ReaderThread = Thread +type UnbufferedReaderThread = ReaderThread + +instance Show Connection where + show _ = "Connection" + +createBindListenServerSocket :: S.HostAddress -> Port -> IO ServerSocket +createBindListenServerSocket host port = do + socket <- S.socket S.AF_INET S.Stream S.defaultProtocol + S.setSocketOption socket S.ReuseAddr 1 + S.bindSocket socket (S.SockAddrInet (fromIntegral port) host) + S.listen socket 5 + return socket + + +acceptFirstConnection :: S.Socket -> IO (Connection, ClientSocket) +acceptFirstConnection serverSocket = do + (clientSocket, clientAddr) <- S.accept serverSocket + pendingConnection <- makePendingConnection clientSocket defaultConnectionOptions + connection <- acceptRequest pendingConnection + return (connection, clientSocket) + + +setupWebsocketConnection :: S.HostAddress -> Port -> IO (ClientSocket, Connection, ServerSocket) +setupWebsocketConnection host port = S.withSocketsDo $ do + serverSocket <- createBindListenServerSocket host port + (clientConnection, clientSocket) <- acceptFirstConnection serverSocket + return (clientSocket, clientConnection, serverSocket) + + + + +handleCloseRequestException :: ClientSocket -> SafePrintToken -> ConnectionException -> IO (Maybe Message) +handleCloseRequestException clientSocket safePrintToken (CloseRequest i reason) + | i == 1000 = do + safePrintLn safePrintToken "Client connection was closed elegantly." + S.sClose clientSocket + return Nothing + | otherwise = do + safePrintLn safePrintToken ("Connection was closed but reason unknown: " ++ show i ++ " " ++ show reason) + S.sClose clientSocket + return Nothing + +handleCloseRequestException clientSocket safePrintToken (ConnectionClosed) + = do + safePrintLn safePrintToken ("Connection was closed unexpectedly") + S.sClose clientSocket + throw ConnectionClosed + +handleCloseRequestException clientSocket safePrintToken (ParseException text) + = do + safePrintLn safePrintToken ("Parse exception on message: " ++ text) + S.sClose clientSocket + throw (ParseException text) + + +takeMessage :: SafePrintToken -> ClientSocket -> Connection -> IO (Maybe Message) +takeMessage safePrintToken sock conn + = handle (handleCloseRequestException sock safePrintToken) $ do + textMessage <- receiveData conn + let + message = T.unpack textMessage + return (Just message) + + +writeMessage :: Connection -> Message -> IO () +writeMessage conn message = sendTextData conn (T.pack message) + +writeBinaryMessage :: Connection -> ByteString -> IO () +writeBinaryMessage conn message = sendBinaryData conn message + + +isConnected :: S.Socket -> IO Bool +isConnected sock = S.sIsConnected sock + +closeWebsocketConnection :: SafePrintToken -> ServerSocket -> ClientSocket -> Connection -> IO () +closeWebsocketConnection safePrintToken serverSocket clientSocket clientConnection + = do + S.sClose serverSocket + isConnected <- isConnected clientSocket + case isConnected of + False -> safePrintLn safePrintToken "Tried to close client connection but was already closed" + True -> do + safePrintLn safePrintToken "Closing client connection..." + handle + (\(exception) -> + case (exception :: ConnectionException) of + ConnectionClosed -> do + safePrintLn safePrintToken "Socket still open, but stream had an error" + S.sClose clientSocket + safePrintLn safePrintToken "Client connection closed!" + _ -> safePrintLn safePrintToken "this should never happen, contact an administrator! ERROR: WS 01" + ) + ( sendClose clientConnection (T.pack "Shutting down..") + ) + + +destroyWebsocketConnection :: ServerSocket -> ClientSocket -> IO () +destroyWebsocketConnection serverSocket clientSocket + = do + S.close serverSocket + S.close clientSocket