diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/eventloop.cabal b/eventloop.cabal new file mode 100644 --- /dev/null +++ b/eventloop.cabal @@ -0,0 +1,94 @@ +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.2.1.1 +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.la.fleur@gmail.com +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.EventloopCore, + Eventloop.Types.EventTypes, + Eventloop.Types.Common, + Eventloop.Utility.Vectors, + Eventloop.RouteEvent, + 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.StdIn, + Eventloop.Module.StdOut, + Eventloop.Module.Timer + + -- Modules included in this library but not exported. + other-modules: Eventloop.Utility.Websockets, + Eventloop.Utility.BufferedWebsockets, + Eventloop.Utility.Config, + Eventloop.Utility.Trees.LayoutTree, + Eventloop.Utility.Trees.GeneralTree, + 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.BasicShapes.BasicShapes, + Eventloop.Module.BasicShapes.Types, + Eventloop.Module.BasicShapes.Classes, + Eventloop.Module.File.File, + Eventloop.Module.File.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 + + other-extensions: OverloadedStrings + + build-depends: base >=4.7 && <4.8, + 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.9, + bytestring >=0.10 && <0.11 + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell2010 + diff --git a/src/Eventloop/DefaultConfiguration.hs b/src/Eventloop/DefaultConfiguration.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/DefaultConfiguration.hs @@ -0,0 +1,38 @@ +module Eventloop.DefaultConfiguration where + +import Eventloop.EventloopCore +import Eventloop.Types.EventTypes +import Eventloop.RouteEvent + +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 + + +allModulesEventloopConfiguration :: progstateT -> {- Begin program state -} + (progstateT -> In -> (progstateT, [Out])) -> {- Eventloop function -} + EventloopConfiguration progstateT +allModulesEventloopConfiguration beginProgstate eventloop = (EventloopConfiguration + -- Begin program state + beginProgstate + -- Eventloop function + eventloop + -- OutEvent Router + routeOutEvent + -- SharedIOState + defaultSharedIOState + -- All module configurations + [ defaultFileModuleConfiguration + , defaultTimerModuleConfiguration + , defaultKeyboardModuleConfiguration + , defaultMouseModuleConfiguration + , defaultStdInModuleConfiguration + , defaultStdOutModuleConfiguration + ] + ) + +defaultSharedIOState :: SharedIOState +defaultSharedIOState = SharedIOState undefined diff --git a/src/Eventloop/EventloopCore.hs b/src/Eventloop/EventloopCore.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/EventloopCore.hs @@ -0,0 +1,166 @@ +module Eventloop.EventloopCore + ( startMainloop + ) where + +import Eventloop.Types.EventTypes + +import Data.Maybe + + +startMainloop :: EventloopConfiguration progstateT -> IO () +startMainloop eventloopConfig@(EventloopConfiguration { moduleConfigurations = moduleConfigs + , sharedIOState = sharedIO + }) = do + (sharedIO', moduleConfigs') <- withIOStateModules sharedIO initializer moduleConfigs + eventloopConfig'' <- startMainloopWithStart (eventloopConfig {moduleConfigurations=moduleConfigs', sharedIOState=sharedIO'}) + let + moduleConfigs'' = moduleConfigurations eventloopConfig'' + sharedIO'' = sharedIOState eventloopConfig'' + (sharedIO''', moduleStates''') <- withIOStateModules sharedIO'' teardown moduleConfigs'' + return () + +withIOStateModules :: SharedIOState -> + (EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> IO (SharedIOState, IOState))) -> + [EventloopModuleConfiguration] -> + IO (SharedIOState, [EventloopModuleConfiguration]) +withIOStateModules sharedIO _ [] = return (sharedIO, []) +withIOStateModules sharedIO getFunc (mc:mcs) = do + (sharedIO', mc') <- withIOStateModule sharedIO getFunc mc + (sharedIO'', mcs') <- withIOStateModules sharedIO' getFunc mcs + return (sharedIO'', mc':mcs') + +withIOStateModule :: SharedIOState -> + (EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> IO (SharedIOState, IOState))) -> + EventloopModuleConfiguration -> + IO (SharedIOState, EventloopModuleConfiguration) +withIOStateModule sharedIO getFunc mc = case (getFunc mc) of + Nothing -> return (sharedIO, mc) + Just (func) -> do + (sharedIO', iostate') <- func sharedIO (iostate mc) + return (sharedIO', mc {iostate=iostate'}) + + +startMainloopWithStart :: EventloopConfiguration progstateT -> IO (EventloopConfiguration progstateT) +startMainloopWithStart ec = handleMainloopUsingSource (return (ec, [Start])) + + +handleMainloopUsingSource :: IO (EventloopConfiguration progstateT, [In]) -> IO (EventloopConfiguration progstateT) +handleMainloopUsingSource source = do + (ec', inEvents) <- source + (ec'', inEvents') <- processEvents ec' preprocessor inEvents -- Do preprocess step + (ec'', stopFound) <- foldl (>>=) (return (ec'', False)) (map handleSingleInEvent inEvents') -- Handle each inEvent + if stopFound + then (return ec'') + else (handleMainloopUsingSource (receiveEvents ec'')) + + +receiveEvents :: EventloopConfiguration progstateT -> IO (EventloopConfiguration progstateT, [In]) +receiveEvents eventloopConfig = do + let + (moduleConfig:mcs) = moduleConfigurations eventloopConfig + eventRetrieverM = eventRetriever moduleConfig + sharedIO = sharedIOState eventloopConfig + checkNextModule sio mc = receiveEvents (eventloopConfig {moduleConfigurations=(mcs++[mc]), sharedIOState=sio}) + case eventRetrieverM of + Nothing -> checkNextModule sharedIO moduleConfig + Just er -> do + (sharedIO', iostate', inEvents) <- er sharedIO (iostate moduleConfig) + let + moduleConfig' = moduleConfig {iostate=iostate'} + case inEvents of + [] -> checkNextModule sharedIO' moduleConfig' + _ -> return (eventloopConfig {moduleConfigurations=(mcs++[moduleConfig']), sharedIOState=sharedIO'}, inEvents) + + +handleSingleInEvent :: In -> (EventloopConfiguration progstateT, Bool) -> IO (EventloopConfiguration progstateT, Bool) +handleSingleInEvent inEvent (ec, stopFound) | stopFound = return (ec, stopFound) + | otherwise = do + let + (ec', outEvents) = doEventloop ec inEvent -- Do eventloop step + (ec'', outEvents') <- processEvents ec' postprocessor outEvents -- Do postprocess step + sendOutEvents ec'' outEvents' -- Do send outEvents step + + +doEventloop :: EventloopConfiguration progstateT -> In -> (EventloopConfiguration progstateT, [Out]) +doEventloop ec inEvent = (ec', outEvents) + where + (progState', outEvents) = (eventloopFunc ec) (progState ec) inEvent + ec' = ec {progState = progState'} + + +sendOutEvents :: EventloopConfiguration progstateT -> [Out] -> IO (EventloopConfiguration progstateT, Bool) +sendOutEvents ec [] = return (ec, False) +sendOutEvents ec (Stop:outs) = return (ec, True) +sendOutEvents ec (out:outs) = case sendModuleConfigM of + Nothing -> error ("Could not send outEvent because module is not configured. Wanted to use module: " ++ (show moduleToRoute) ++ " Event: " ++ (show out)) + Just sendModuleConfig -> do + let + eventSenderFuncM = eventSender sendModuleConfig + moduleIOState = iostate sendModuleConfig + case eventSenderFuncM of + Nothing -> error ("Could not send outEvent because module eventsender is not configured. Using module: " ++ (show moduleToRoute) ++ " Event: " ++ (show out)) + Just eventSenderFunc -> do + (sharedIO', moduleIOState') <- eventSenderFunc sharedIO moduleIOState out + let + sendModuleConfig' = sendModuleConfig {iostate=moduleIOState'} + ec' = ec {moduleConfigurations=(replaceModuleConfiguration sendModuleConfig' moduleConfigs), sharedIOState=sharedIO'} + sendOutEvents ec' outs + where + sharedIO = sharedIOState ec + moduleToRoute = (outRouter ec) out + moduleConfigs = moduleConfigurations ec + sendModuleConfigM = findModuleConfiguration moduleToRoute moduleConfigs + + +processEventModule :: SharedIOState -> + EventloopModuleConfiguration -> + (EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event]))) -> -- Function from moduleconfig to pre-/postprocess function + event -> + IO (SharedIOState, EventloopModuleConfiguration, [event]) +processEventModule sharedIO eventloopModuleConfig getFunc event = do + let + processFuncM = getFunc eventloopModuleConfig + case processFuncM of + Nothing -> return (sharedIO, eventloopModuleConfig, [event]) + Just processFunc -> do + (sharedIO', iostate', events) <- processFunc sharedIO (iostate eventloopModuleConfig) event + return (sharedIO', eventloopModuleConfig {iostate=iostate'}, events) + + +processEventsModules :: SharedIOState -> + [EventloopModuleConfiguration] -> + (EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event]))) -> -- Function from moduleconfig to pre-/postprocess function + [event] -> + IO (SharedIOState, [EventloopModuleConfiguration], [event]) +processEventsModules sharedIO mcs _ [] = return (sharedIO, mcs, []) +processEventsModules sharedIO [] _ events = return (sharedIO, [], events) +processEventsModules sharedIO (moduleConfig:mcs) getFunc (event:events) = do + (sharedIO', moduleConfig', moreEvents) <- processEventModule sharedIO moduleConfig getFunc event + (sharedIO'', mcs', moreEvents') <- processEventsModules sharedIO' mcs getFunc moreEvents + (sharedIO''', mcs'', events') <- processEventsModules sharedIO'' (moduleConfig':mcs') getFunc events + return (sharedIO''', mcs'', moreEvents' ++ events') + + +processEvents :: EventloopConfiguration progstateT -> + (EventloopModuleConfiguration -> Maybe (SharedIOState -> IOState -> event -> IO (SharedIOState, IOState, [event]))) -> -- Function from moduleconfig to pre-/postprocess function + [event] -> + IO (EventloopConfiguration progstateT, [event]) +processEvents eventloopConfig getFunc events = do + let + moduleConfigs = moduleConfigurations eventloopConfig + sharedIO = sharedIOState eventloopConfig + (sharedIO', moduleConfigs', events') <- processEventsModules sharedIO moduleConfigs getFunc events + return (eventloopConfig {moduleConfigurations=moduleConfigs', sharedIOState=sharedIO'}, events') + + +findModuleConfiguration :: EventloopModuleIdentifier -> [EventloopModuleConfiguration] -> Maybe EventloopModuleConfiguration +findModuleConfiguration _ [] = Nothing +findModuleConfiguration id (mc:mcs) | id == moduleId = Just mc + | otherwise = findModuleConfiguration id mcs + where + moduleId = moduleIdentifier mc + +replaceModuleConfiguration :: EventloopModuleConfiguration -> [EventloopModuleConfiguration] -> [EventloopModuleConfiguration] +replaceModuleConfiguration _ [] = [] +replaceModuleConfiguration mc (mc':mcs) | moduleIdentifier mc == moduleIdentifier mc' = (mc:mcs) + | otherwise = (mc':(replaceModuleConfiguration mc mcs)) diff --git a/src/Eventloop/Module/BasicShapes.hs b/src/Eventloop/Module/BasicShapes.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/BasicShapes.hs @@ -0,0 +1,7 @@ +module Eventloop.Module.BasicShapes + ( module Eventloop.Module.BasicShapes.BasicShapes + , module Eventloop.Module.BasicShapes.Types + ) where + +import Eventloop.Module.BasicShapes.BasicShapes +import Eventloop.Module.BasicShapes.Types diff --git a/src/Eventloop/Module/BasicShapes/BasicShapes.hs b/src/Eventloop/Module/BasicShapes/BasicShapes.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/BasicShapes/BasicShapes.hs @@ -0,0 +1,31 @@ +module Eventloop.Module.BasicShapes.BasicShapes where + +import Eventloop.Module.BasicShapes.Types +import Eventloop.Types.EventTypes +import Eventloop.Module.BasicShapes.Classes + +defaultBasicShapesModuleConfiguration = ( EventloopModuleConfiguration + basicShapesModuleIdentifier + defaultBasicShapesModuleIOState + Nothing + Nothing + Nothing + (Just basicShapesPostProcessor) + Nothing + Nothing + ) + + +defaultBasicShapesModuleIOState :: IOState +defaultBasicShapesModuleIOState = NoState + + +basicShapesModuleIdentifier :: EventloopModuleIdentifier +basicShapesModuleIdentifier = "basicshapes" + + +basicShapesPostProcessor :: PostProcessor +basicShapesPostProcessor shared iostate (OutBasicShapes basicShapesOut ) = return (shared, iostate, [OutCanvas canvasOut]) + where + canvasOut = toCanvasOut basicShapesOut +basicShapesPostProcessor shared iostate out = return (shared, iostate, [out]) diff --git a/src/Eventloop/Module/BasicShapes/Classes.hs b/src/Eventloop/Module/BasicShapes/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/BasicShapes/Classes.hs @@ -0,0 +1,207 @@ +module Eventloop.Module.BasicShapes.Classes where + +import Eventloop.Utility.Vectors +import Eventloop.Module.BasicShapes.Types +import qualified Eventloop.Module.Websocket.Canvas.Types as CT + + +addBoundingBox :: BoundingBox -> BoundingBox -> BoundingBox +addBoundingBox (BoundingBox p11 p21 p31 p41) (BoundingBox p12 p22 p32 p42) = BoundingBox (Point (xMin, yMin)) (Point (xMax, yMin)) (Point (xMax, yMax)) (Point (xMin, yMax)) + where + allPoints = [p11, p21, p31, p41, p12, p22, p32, p42] + xs = map (\(Point (x,y)) -> x) allPoints + ys = map (\(Point (x,y)) -> y) allPoints + xMin = minimum xs + xMax = maximum xs + yMin = minimum ys + yMax = maximum ys + +foldBoundingBoxes :: (BoundingBox -> BoundingBox -> BoundingBox) -> [BoundingBox] -> BoundingBox +foldBoundingBoxes _ [] = error "Tried to fold zero bounding boxes which is no bounding box. Undefined!" +foldBoundingBoxes op (box:bs) = foldl op box bs + + +translateBoundingBox :: Translation -> BoundingBox -> BoundingBox +translateBoundingBox pTrans = opOnBoundingBox ((|+|) pTrans) + +opOnBoundingBox :: (Point -> Point) -> BoundingBox -> BoundingBox +opOnBoundingBox op (BoundingBox p1 p2 p3 p4) = BoundingBox (op p1) + (op p2) + (op p3) + (op p4) + + +allPolygonPoints :: AmountOfPoints -> Point -> Radius -> [Point] +allPolygonPoints n centralPoint r | n < 1 = error "A 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 + + +roundPoint :: Point -> CT.ScreenPoint +roundPoint (Point (x, y)) = (round x, round y) + + +roundShapeColor :: ShapeColor -> (CT.ScreenColor, CT.ScreenColor) +roundShapeColor (strokeColor, fillColor) = (roundColor strokeColor, roundColor fillColor) + +roundColor :: Color -> CT.ScreenColor +roundColor (r, b, g, a) = (round r, round b, round g, a) + +instance RotateLeftAround BoundingBox where + rotateLeftAround rotatePoint aDeg box = opOnBoundingBox (rotateLeftAround rotatePoint aDeg) box + + +class (ToBoundingBox a) => ToCenter a where + toCenter :: a -> Point + +instance ToCenter Primitive where + toCenter = toCenter.toBoundingBox + +instance ToCenter Shape where + toCenter = toCenter.toBoundingBox + +instance ToCenter BoundingBox where + toCenter (BoundingBox (Point (x1, y1)) (Point (x2, y2)) _ (Point (x4, y4))) = Point (x1 + 0.5 * w, y1 + 0.5 * h) + where + w = x2 - x1 + h = y4 - x1 + + +class ToBoundingBox a where + toBoundingBox :: a -> BoundingBox + +instance ToBoundingBox BoundingBox where + toBoundingBox box = box + +instance ToBoundingBox Primitive where + toBoundingBox (Rectangle (Point (x, y)) (w, h)) = BoundingBox (Point (x, y)) (Point (x + w, y)) (Point (x + w, y + h)) (Point (x, y + h)) + toBoundingBox (Circle p r) = toBoundingBox (Rectangle p (r, r)) + toBoundingBox (Polygon _ p r) = toBoundingBox (Circle p r) + toBoundingBox (Text _ _ _ p) = BoundingBox p p p p + toBoundingBox (Line p1 p2) = BoundingBox p1 p2 p2 p1 + toBoundingBox (MultiLine p1 p2 ops) = BoundingBox (Point (xMin, yMin)) (Point (xMax, yMin)) (Point (xMax, yMax)) (Point (xMin, yMax)) + where + points = p1:p2:ops + xs = map (\(Point (x, y)) -> x) points + ys = map (\(Point (x, y)) -> y) points + xMin = minimum xs + xMax = maximum xs + yMin = minimum ys + yMax = maximum ys + +instance ToBoundingBox Shape where + toBoundingBox (BaseShape prim _ (Just rotation)) = rotatedBox + where + baseBox = toBoundingBox prim + rotationPoint = findRotationPoint prim rotation + (Rotation _ angle) = rotation + rotatedBox = rotateLeftAround rotationPoint angle baseBox + toBoundingBox (BaseShape prim _ Nothing) = toBoundingBox prim + toBoundingBox (CompositeShape shapes (Just translation) (Just rotation)) = rotateLeftAround rotationPoint angle translatedBox + where + baseBox = toBoundingBox (CompositeShape shapes Nothing Nothing) + translatedBox = translateBoundingBox translation baseBox + rotationPoint = findRotationPoint translatedBox rotation + (Rotation _ angle) = rotation + toBoundingBox (CompositeShape shapes (Just translation) Nothing) = translateBoundingBox translation baseBox + where + baseBox = toBoundingBox (CompositeShape shapes Nothing Nothing) + toBoundingBox (CompositeShape shapes Nothing (Just rotation)) = rotateLeftAround rotationPoint angle baseBox + where + baseBox = toBoundingBox (CompositeShape shapes Nothing Nothing) + rotationPoint = findRotationPoint baseBox rotation + (Rotation _ angle) = rotation + toBoundingBox (CompositeShape shapes Nothing Nothing) = foldBoundingBoxes addBoundingBox $ map toBoundingBox shapes + + + +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 + where + canvasOperations = (concat.(map toCanvasOperations)) shapes + + +class ToCanvasOperations a where + toCanvasOperations :: a -> [CT.CanvasOperation] + +instance ToCanvasOperations Shape where + toCanvasOperations (BaseShape prim color (Just rotation)) + | angle == 0 = drawOperations + | otherwise = [ CT.DoTransform CT.Save + , CT.DoTransform (CT.Translate screenRotationPoint) + , CT.DoTransform (CT.Rotate screenAngle) + ] ++ drawOperations ++ + [ CT.DoTransform CT.Restore + ] + where + screenRotationPoint = roundPoint $ findRotationPoint prim rotation + drawOperations = toCanvasOperations (BaseShape prim color Nothing) + (Rotation _ angle) = rotation + screenAngle = round angle + + -- Rotation is broken. When we translated to rotationpoint, translation of prim should be adjusted accordingly (prim' = move prim (-rotationPoint)) + -- Multiline gets filled even though we do moveto finally. Solution: Move ShapeColor to primitives and skip fill for both Line and MultiLine + -- Rectangle might be broken. Not sure though. The translation point might be, visually, bottom right instead of bottom right in the coordinate system. + + toCanvasOperations (BaseShape (Text text fontF fontS p) color Nothing) = [CT.DrawText canvasText p' textRender] + where + canvasText = CT.CanvasText text (CT.Font fontF $ round fontS) CT.AlignCenter + textRender = CT.TextFill (CT.CanvasColor screenFillColor) + (screenStrokeColor, screenFillColor) = roundShapeColor color + p' = roundPoint p + + toCanvasOperations (BaseShape prim color Nothing) = [CT.DrawPath startingPoint screenPathParts pathStroke pathFill] + where + (screenPathParts, startingPoint) = toScreenPathParts prim + pathStroke = CT.PathStroke (CT.CanvasColor screenStrokeColor) + pathFill = CT.PathFill (CT.CanvasColor screenFillColor) + (screenStrokeColor, screenFillColor) = roundShapeColor color + + toCanvasOperations (CompositeShape shapes Nothing Nothing) = concat canvasOperationsList + where + canvasOperationsList = map toCanvasOperations shapes + +class ToScreenPathPart a where + toScreenPathParts :: a -> ([CT.ScreenPathPart], CT.ScreenStartingPoint) + +instance ToScreenPathPart Primitive where + toScreenPathParts (Rectangle p (w, h)) = ([CT.Rectangle p' (w', h')], p') + where + p' = roundPoint p + w' = round w + h' = round h + toScreenPathParts (Circle p r) = ([CT.Arc (p', r') 0 360], p') + where + p' = roundPoint p + r' = round r + toScreenPathParts (Polygon n p r) = (lines, screenPoint) + where + polygonPoints = allPolygonPoints n p r + (screenPoint:ps) = map roundPoint polygonPoints + lines = [CT.LineTo screenPoint' | screenPoint' <- (ps ++ [screenPoint])] + toScreenPathParts (Text {}) = error "Text is stupid and not implemented the same way in JS canvas" + toScreenPathParts (Line p1 p2) = ([CT.LineTo p2'], p1') + where + p1' = roundPoint p1 + p2' = roundPoint p2 + + toScreenPathParts (MultiLine p1 p2 otherPoints) = (lines ++ [CT.MoveTo p1'], p1') + where + allPoints = p1:p2:otherPoints + (p1':otherPoints') = map roundPoint allPoints + lines = [CT.LineTo p' | p' <- otherPoints'] + + + diff --git a/src/Eventloop/Module/BasicShapes/Types.hs b/src/Eventloop/Module/BasicShapes/Types.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/BasicShapes/Types.hs @@ -0,0 +1,81 @@ +module Eventloop.Module.BasicShapes.Types + ( module Eventloop.Module.BasicShapes.Types + , CT.CanvasId + ) where + +import qualified Eventloop.Module.Websocket.Canvas.Types as CT +import Eventloop.Utility.Vectors + +type GraphicalNumeric = Float +type Translation = 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 ShapeColor = (StrokeColor, FillColor) + +type UpperLeft = Point +type UpperRight = Point +type LowerLeft = Point +type LowerRight = Point + +type AmountOfPoints = Int + +type FontFamily = [Char] +type FontSize = GraphicalNumeric + + +data BasicShapesOut = DrawShapes CT.CanvasId [Shape] + deriving (Show, Eq) + +data Shape = BaseShape Primitive ShapeColor (Maybe Rotation) + | CompositeShape [Shape] (Maybe Translation) (Maybe Rotation) -- ^Should contain atleast 1 shape + deriving (Show, Eq) + +data Primitive = Rectangle { translation :: Translation + , dimensions :: Dimensions + } -- ^Translation is upperleftcorner + | Circle { translation :: Translation + , radius :: Radius + } -- ^Translation is center + | Polygon { amountOfPoints :: AmountOfPoints + , translation :: Translation + , radius :: Radius + } -- ^Translation is center + | Text { text :: [Char] + , fontFamily :: FontFamily + , fontSize :: FontSize + , translation :: Translation + } -- ^Translation is center, does not have a boundingbox due to technical limitations + | Line { point1 :: Point + , point2 :: Point + } + | MultiLine { point1 :: Point + , point2 :: Point + , otherPoints :: [Point] + } + deriving (Show, Eq) + + +data Rotation = Rotation RotatePoint Angle + deriving (Show, Eq) + +data RotatePoint = AroundCenter + | AroundPoint Point + deriving (Show, Eq) + +data BoundingBox = BoundingBox UpperLeft UpperRight LowerRight LowerLeft + deriving (Show, Eq) + + + diff --git a/src/Eventloop/Module/DrawTrees.hs b/src/Eventloop/Module/DrawTrees.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/DrawTrees.hs @@ -0,0 +1,7 @@ +module Eventloop.Module.DrawTrees + ( module Eventloop.Module.DrawTrees.Types + , module Eventloop.Module.DrawTrees.DrawTrees + ) where + +import Eventloop.Module.DrawTrees.Types +import Eventloop.Module.DrawTrees.DrawTrees diff --git a/src/Eventloop/Module/DrawTrees/DrawTrees.hs b/src/Eventloop/Module/DrawTrees/DrawTrees.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/DrawTrees/DrawTrees.hs @@ -0,0 +1,171 @@ +module Eventloop.Module.DrawTrees.DrawTrees where + +import Eventloop.Module.DrawTrees.Types +import Eventloop.Utility.Trees.LayoutTree +import Eventloop.Utility.Trees.GeneralTree +import Eventloop.Module.BasicShapes.Types + +import Eventloop.Types.EventTypes + + +defaultDrawTreesModuleConfiguration :: EventloopModuleConfiguration +defaultDrawTreesModuleConfiguration = ( EventloopModuleConfiguration + drawTreesModuleIdentifier + defaultDrawTreesModuleIOState + Nothing + Nothing + Nothing + (Just drawTreesPostProcessor) + Nothing + Nothing + ) + +defaultDrawTreesModuleIOState :: IOState +defaultDrawTreesModuleIOState = NoState + +drawTreesModuleIdentifier :: EventloopModuleIdentifier +drawTreesModuleIdentifier = "parseTree" + + +drawTreesPostProcessor :: PostProcessor +drawTreesPostProcessor shared iostate (OutDrawTrees (DrawTrees canvasId trees)) = return (shared, iostate, [OutBasicShapes $ DrawShapes canvasId [shapeTrees]]) + where + shapeTrees = showGeneralTreeList (map generalizeTree trees) +drawTreesPostProcessor shared iostate out = return (shared, iostate, [out]) + + +showGeneralTreeList :: [GeneralTree] -> Shape +showGeneralTreeList list = showGeneralTreeList' 0 0 0 0 list + +showGeneralTreeList' :: LeftOffset -> TopOffset -> Float -> Int -> [GeneralTree] -> Shape +showGeneralTreeList' _ _ _ _ [] = CompositeShape [] Nothing Nothing +showGeneralTreeList' left top maxBottom i (x:xs) | right <= 1024 = CompositeShape (text:gtree:gtrees) Nothing Nothing + | width > 1024 = CompositeShape (text:gtree:gtrees) Nothing Nothing + | otherwise = showGeneralTreeList' 0 maxBottom' maxBottom' i (x:xs) + where + maxBottom' = max maxBottom bottom + (ltree, right, bottom) = layoutGeneralTree left top x + gtree = printTree ltree + CompositeShape gtrees _ _ = showGeneralTreeList' (right + marginBetweenTrees) top maxBottom' i' xs + i' = i + 1 + text = treeIndex i (left, top) + width = right - left + + +instance GeneralizeTree Tree where + generalizeTree (TParseTree tree) = generalizeTree tree + generalizeTree (TRBTree tree) = generalizeTree tree + generalizeTree (TRoseTree tree) = generalizeTree tree + + +instance GeneralizeTree ParseTree where + generalizeTree (ParseNode str children) = GeneralTreeBox content children'WithLines + where + content = [GeneralNodeText (0,0,0, 255) str] + children'WithLines = zip (repeat line) (map generalizeTree children) + line = GeneralLine (125,125,125, 255) + + +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 = [GeneralNode (0,0,0, 255) 10, GeneralNodeText (0,0,0, 255) str] + children'WithLines = zip (repeat line) (map generalizeTree children) + line = GeneralLine (0,0,0, 255) + +parseExampleTree = ParseNode "z" + [ ParseNode "aaa" + [ ParseNode "bbb" + [ ParseNode "ccc" [], + ParseNode "ddd" [] + ], + ParseNode "a" + [ParseNode "fff" [], + ParseNode "ggg" [], + ParseNode "hhh" [] + ], + ParseNode "iii" + [ParseNode "z" [] + ] + ], + ParseNode "kkk" + [ParseNode "lll" [], + ParseNode "mmm" + [ParseNode "nnn" + [ParseNode "q" [], + ParseNode "r" [] + ], + ParseNode "ooo" [], + ParseNode "ppp" [] + ] + ] + ] + +rbExampleTree = RBNode NodeBlack "12" + [ RBNode NodeRed "11" + [ RBNode NodeBlack "16" + [ RBNode NodeBlack "" [], + RBNode NodeBlack "" [] + ], + RBNode NodeBlack "24" + [RBNode NodeBlack "" [], + RBNode NodeBlack "" [] + ] + ], + RBNode NodeRed "13" + [RBNode NodeBlack "36" [], + RBNode NodeBlack "28" + [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/Types.hs b/src/Eventloop/Module/DrawTrees/Types.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/DrawTrees/Types.hs @@ -0,0 +1,35 @@ +module Eventloop.Module.DrawTrees.Types where + +import Eventloop.Module.Websocket.Canvas.Types +import Eventloop.Utility.Trees.GeneralTree + + +data DrawTreesOut = DrawTrees CanvasId [Tree] + deriving (Show, Eq) + +data Tree = TParseTree ParseTree + | TRBTree RBTree + | TRoseTree RoseTree + deriving (Show, Eq) + + +data ParseTree = ParseNode String [ParseTree] + deriving (Show, Eq) + + +data NodeColor = NodeRed + | NodeBlack + | NodeGrey + deriving (Show, Eq) + +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 new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/File.hs @@ -0,0 +1,7 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/File/File.hs @@ -0,0 +1,163 @@ +module Eventloop.Module.File.File + ( defaultFileModuleConfiguration + , defaultFileModuleIOState + , fileModuleIdentifier + , fileEventRetriever + , fileEventSender + , fileTeardown + ) where + +import Data.Maybe +import System.IO + +import Eventloop.Types.EventTypes +import Eventloop.Module.File.Types + +defaultFileModuleConfiguration :: EventloopModuleConfiguration +defaultFileModuleConfiguration = ( EventloopModuleConfiguration + fileModuleIdentifier + defaultFileModuleIOState + Nothing + (Just fileEventRetriever) + Nothing + Nothing + (Just fileTeardown) + (Just fileEventSender) + ) + +defaultFileModuleIOState :: IOState +defaultFileModuleIOState = FileState [] [] + +fileModuleIdentifier :: EventloopModuleIdentifier +fileModuleIdentifier = "file" + +fileEventRetriever :: EventRetriever +fileEventRetriever sharedIO filestate@(FileState { newFileInEvents = newFileInEvents + }) = return (sharedIO, filestate', newFileInEvents') + where + newFileInEvents' = [InFile x | x <- newFileInEvents] + filestate' = filestate {newFileInEvents = []} + + +fileEventSender :: EventSender +fileEventSender sharedIO fileState (OutFile a) = do + fileState' <- fileEventSender' fileState a + return (sharedIO, fileState') + + +fileEventSender' :: IOState -> FileOut -> IO IOState +fileEventSender' fs (OpenFile filepath iomode) = do + handle <- openFile filepath iomode + let + fileOpenedEvent = FileOpened filepath True + opened' = (opened fs) ++ [(filepath, handle, iomode)] + otherInEvents = newFileInEvents fs + fs' = fs {newFileInEvents=(otherInEvents ++ [fileOpenedEvent]), opened=opened'} + return fs' + +fileEventSender' fs (CloseFile filepath) | openfileM == Nothing = return fs + | otherwise = do + hClose handle + return fs' + where + openedFiles = opened fs + openfileM = retrieveOpenedFile openedFiles filepath + (fp, handle, iomode) = fromJust openfileM + openedFiles' = removeOpenedFile openedFiles filepath + closedFileEvent = FileClosed filepath True + fs' = fs {newFileInEvents=(newFileInEvents fs ++ [closedFileEvent]), opened=openedFiles'} + +fileEventSender' fs (RetrieveContents filepath) = doReadAction filepath fs RetrievedContents retrieveContents +fileEventSender' fs (RetrieveLine filepath) = doReadAction filepath fs RetrievedLine hGetLine +fileEventSender' fs (RetrieveChar filepath) = doReadAction filepath fs RetrievedChar hGetChar +fileEventSender' fs (IfEOF filepath) = getFromFile filepath fs fileIsOpened IsEOF hIsEOF + +fileEventSender' fs (WriteTo filepath contents) | fileIsWriteable (opened fs) filepath = do + hPutStr handle contents + let + fs' = fs {newFileInEvents = (newFileInEvents fs) ++ [WroteTo filepath True]} + return fs' + | otherwise = return fs + where + Just (fp, handle, iomode) = retrieveOpenedFile (opened fs) filepath + + +doReadAction :: FilePath -> IOState -> (FilePath -> a -> FileIn) -> (Handle -> IO a) -> IO IOState +doReadAction filepath fs inEvent readAction = getFromFile filepath fs fileIsReadable inEvent readAction + + +getFromFile :: FilePath -> + IOState -> + ([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 IOState +getFromFile filepath fs@(FileState { opened = opened + , newFileInEvents = newFileInEvents + }) fileCheck inEvent action | fileCheck opened filepath = do + result <- action handle + let + newInEvent = inEvent filepath result + fs' = fs {newFileInEvents=newFileInEvents ++ [newInEvent]} + return fs' + | otherwise = return fs + where + Just (fp, handle, iomode) = retrieveOpenedFile opened 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 sharedIO fs = do + closeAllFiles handles + return (sharedIO, fs {opened=[]}) + where + handles = map (\(fp, h, iom) -> h) (opened fs) + +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 new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/File/Types.hs @@ -0,0 +1,23 @@ +module Eventloop.Module.File.Types where + +import System.IO + +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) diff --git a/src/Eventloop/Module/StdIn.hs b/src/Eventloop/Module/StdIn.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/StdIn.hs @@ -0,0 +1,7 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/StdIn/StdIn.hs @@ -0,0 +1,61 @@ +module Eventloop.Module.StdIn.StdIn + ( defaultStdInModuleConfiguration + , defaultStdInModuleIOState + , stdInModuleIdentifier + , stdInEventRetriever + , stdInEventSender + ) where + +import System.IO +import Data.String + +import Eventloop.Types.EventTypes +import Eventloop.Module.StdIn.Types + +defaultStdInModuleConfiguration :: EventloopModuleConfiguration +defaultStdInModuleConfiguration = ( EventloopModuleConfiguration + stdInModuleIdentifier + defaultStdInModuleIOState + Nothing + (Just stdInEventRetriever) + Nothing + Nothing + Nothing + (Just stdInEventSender) + ) + +defaultStdInModuleIOState :: IOState +defaultStdInModuleIOState = StdInState [] + +stdInModuleIdentifier :: EventloopModuleIdentifier +stdInModuleIdentifier = "stdin" + + +stdInEventRetriever :: EventRetriever +stdInEventRetriever sharedIO (StdInState events) = return (sharedIO, StdInState [], inEvents) + where + inEvents = map InStdIn events + +stdInEventSender :: EventSender +stdInEventSender sharedIO stdInState (OutStdIn a) = do + stdInState' <- stdInEventSender' stdInState a + return (sharedIO, stdInState') + +stdInEventSender' :: IOState -> StdInOut -> IO IOState +stdInEventSender' stdInState StdInReceiveContents = doStdInGet stdInState linedGetContents StdInReceivedContents + where + linedGetContents = (getContents >>= (\strContents -> return $ lines strContents)) + +stdInEventSender' stdInState StdInReceiveLine = doStdInGet stdInState getLine StdInReceivedLine +stdInEventSender' stdInState StdInReceiveChar = doStdInGet stdInState getChar StdInReceivedChar + + +doStdInGet :: IOState -> (IO a) -> (a -> StdInIn) -> IO IOState +doStdInGet stdInState source typeEvent = do + let + events = newStdInInEvents stdInState + content <- source + let + event = typeEvent content + events' = events ++ [event] + return (stdInState {newStdInInEvents = events'}) diff --git a/src/Eventloop/Module/StdIn/Types.hs b/src/Eventloop/Module/StdIn/Types.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/StdIn/Types.hs @@ -0,0 +1,11 @@ +module Eventloop.Module.StdIn.Types where + +data StdInIn = StdInReceivedContents [[Char]] + | StdInReceivedLine [Char] + | StdInReceivedChar Char + deriving (Eq, Show) + +data StdInOut = StdInReceiveContents + | StdInReceiveLine + | StdInReceiveChar + deriving (Eq, Show) diff --git a/src/Eventloop/Module/StdOut.hs b/src/Eventloop/Module/StdOut.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/StdOut.hs @@ -0,0 +1,7 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/StdOut/StdOut.hs @@ -0,0 +1,32 @@ +module Eventloop.Module.StdOut.StdOut + ( defaultStdOutModuleConfiguration + , stdOutModuleIdentifier + , stdOutEventSender + ) where + +import System.IO + +import Eventloop.Types.EventTypes +import Eventloop.Module.StdOut.Types + +defaultStdOutModuleConfiguration :: EventloopModuleConfiguration +defaultStdOutModuleConfiguration = ( EventloopModuleConfiguration + stdOutModuleIdentifier + NoState + Nothing + Nothing + Nothing + Nothing + Nothing + (Just stdOutEventSender) + ) + +stdOutModuleIdentifier :: EventloopModuleIdentifier +stdOutModuleIdentifier = "stdout" + + +stdOutEventSender :: EventSender +stdOutEventSender sharedIO state (OutStdOut (StdOutMessage str)) = do + putStr str + hFlush stdout + return (sharedIO, state) diff --git a/src/Eventloop/Module/StdOut/Types.hs b/src/Eventloop/Module/StdOut/Types.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/StdOut/Types.hs @@ -0,0 +1,4 @@ +module Eventloop.Module.StdOut.Types where + +data StdOutOut = StdOutMessage [Char] + deriving (Eq, Show) diff --git a/src/Eventloop/Module/Timer.hs b/src/Eventloop/Module/Timer.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/Timer.hs @@ -0,0 +1,7 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/Timer/Timer.hs @@ -0,0 +1,122 @@ +module Eventloop.Module.Timer.Timer + ( defaultTimerModuleConfiguration + , defaultTimerModuleIOState + , timerModuleIdentifier + , timerInitializer + , timerEventRetriever + , timerEventSender + , timerTeardown + ) where + +import Control.Concurrent.Timer +import Control.Concurrent.MVar +import Control.Concurrent.Suspend.Lifted +import Data.Maybe +import Data.List + +import Eventloop.Types.EventTypes +import Eventloop.Module.Timer.Types + + +defaultTimerModuleConfiguration :: EventloopModuleConfiguration +defaultTimerModuleConfiguration = ( EventloopModuleConfiguration + timerModuleIdentifier + defaultTimerModuleIOState + (Just timerInitializer) + (Just timerEventRetriever) + Nothing + Nothing + (Just timerTeardown) + (Just timerEventSender) + ) + +defaultTimerModuleIOState :: IOState +defaultTimerModuleIOState = TimerState [] [] undefined undefined + +timerModuleIdentifier :: EventloopModuleIdentifier +timerModuleIdentifier = "timer" + + +timerInitializer :: Initializer +timerInitializer sharedIO _ = do + incTickBuff <- newMVar [] + incITickBuff <- newMVar [] + return (sharedIO, TimerState [] [] incITickBuff incTickBuff) + + +timerEventRetriever :: EventRetriever +timerEventRetriever sharedIO timerState = do + let + incTickBuff = incomingTickBuffer timerState + incITickBuff = incomingIntervalTickBuffer timerState + incTicks <- swapMVar incTickBuff [] + incITicks <- swapMVar incITickBuff [] + let + tickedTimerIds = map (\(Tick id) -> id) incTicks + startedTimers' <- foldr (\id startedTimersIO -> (startedTimersIO >>= unregisterTimer id)) (return $ startedTimers timerState) tickedTimerIds + return (sharedIO, timerState{startedTimers = startedTimers'}, (map InTimer incTicks) ++ (map InTimer incITicks)) + + +timerEventSender :: EventSender +timerEventSender sharedIO timerState (OutTimer a) = do + timerState' <- timerEventSender' timerState a + return (sharedIO, timerState') + +timerEventSender' :: IOState -> TimerOut -> IO IOState +timerEventSender' timerState (SetTimer id delay) = do + let + incTickBuff = incomingTickBuffer timerState + startedTimers_ = startedTimers timerState + startedTimers' <- registerTimer startedTimers_ incTickBuff id delay (oneShotStart) + let + timerState' = timerState {startedTimers = startedTimers'} + return timerState' + +timerEventSender' timerState (SetIntervalTimer id delay) = do + let + incITickBuff = incomingIntervalTickBuffer timerState + startedITimers = startedIntervalTimers timerState + startedITimers' <- registerTimer startedITimers incITickBuff id delay (repeatedStart) + let + timerState' = timerState {startedIntervalTimers = startedITimers'} + return timerState' + +timerEventSender' timerState (UnsetTimer id) = do + startedTimers' <- unregisterTimer id (startedTimers timerState) + startedITimers' <- unregisterTimer id (startedIntervalTimers timerState) + return (timerState {startedTimers = startedTimers', startedIntervalTimers=startedITimers'}) + + +timerTeardown :: Teardown +timerTeardown sharedIO timerState = do + let + allStartedTimers = (startedTimers timerState) ++ (startedIntervalTimers timerState) + allStartedIds = map fst allStartedTimers + sequence_ (map (\id -> unregisterTimer id allStartedTimers) allStartedIds) + return (sharedIO, timerState {startedTimers = [], startedIntervalTimers = []}) + + +registerTimer :: [StartedTimer] -> IncomingTickBuffer -> TimerId -> MicroSecondDelay -> TimerStartFunction -> IO [StartedTimer] +registerTimer startedTimers incTickBuff id delay startFunc = do + timer <- newTimer + startFunc timer (tick id incTickBuff) ((usDelay.fromIntegral) delay) + return (startedTimers ++ [(id, timer)]) + + +unregisterTimer :: TimerId -> [StartedTimer] -> IO [StartedTimer] +unregisterTimer id startedTimers = do + let + startedTimerM = findStartedTimer startedTimers id + stopAction (Just (_, timer)) = stopTimer timer + stopAction Nothing = return () + startedTimers' = filter (\(id', _) -> id /= id') startedTimers + stopAction startedTimerM + return startedTimers' + + +findStartedTimer :: [StartedTimer] -> TimerId -> Maybe StartedTimer +findStartedTimer startedTimers id = find (\(id', timer) -> id == id') startedTimers + + +tick :: TimerId -> IncomingTickBuffer -> IO () +tick id incTickBuff = modifyMVar_ incTickBuff (\ticks -> return $ ticks ++ [Tick id]) diff --git a/src/Eventloop/Module/Timer/Types.hs b/src/Eventloop/Module/Timer/Types.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/Timer/Types.hs @@ -0,0 +1,19 @@ +module Eventloop.Module.Timer.Types where + +import Control.Concurrent.MVar +import Control.Concurrent.Timer +import Control.Concurrent.Suspend.Lifted + +type MicroSecondDelay = Int -- Microseconds +type TimerId = [Char] +type IncomingTickBuffer = MVar [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) diff --git a/src/Eventloop/Module/Websocket/Canvas.hs b/src/Eventloop/Module/Websocket/Canvas.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/Websocket/Canvas.hs @@ -0,0 +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 +import Eventloop.Module.Websocket.Canvas.Types diff --git a/src/Eventloop/Module/Websocket/Canvas/Canvas.hs b/src/Eventloop/Module/Websocket/Canvas/Canvas.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/Websocket/Canvas/Canvas.hs @@ -0,0 +1,99 @@ +module Eventloop.Module.Websocket.Canvas.Canvas where + +import Control.Concurrent.MVar +import Control.Concurrent +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as LBS + +import Eventloop.Utility.Config +import Eventloop.Types.EventTypes +import Eventloop.Module.Websocket.Canvas.Types +import Eventloop.Module.Websocket.Canvas.JSONEncoding + +import qualified Eventloop.Utility.Websockets as WS + +defaultCanvasModuleConfiguration :: EventloopModuleConfiguration +defaultCanvasModuleConfiguration = ( EventloopModuleConfiguration + canvasModuleIdentifier + defaultCanvasModuleIOState + (Just canvasInitializer) + (Just canvasEventRetriever) + Nothing + Nothing + (Just canvasTeardown) + (Just canvasEventSender) + ) + +defaultCanvasModuleIOState :: IOState +defaultCanvasModuleIOState = CanvasState undefined undefined undefined undefined undefined undefined + +canvasModuleIdentifier :: EventloopModuleIdentifier +canvasModuleIdentifier = "canvas" + + +canvasInitializer :: Initializer +canvasInitializer sharedIO _ = do + (comRecvBuffer, clientConn, serverSock) <- WS.setupWebsocketConnection ipAddress canvasPort + userRecvBuffer <- newMVar [] + sysRecvBuffer <- newEmptyMVar + routerThreadId <- forkIO (router comRecvBuffer userRecvBuffer sysRecvBuffer) + --TODO Add measuretext to sharedIO + return (sharedIO, CanvasState comRecvBuffer userRecvBuffer sysRecvBuffer clientConn serverSock routerThreadId) + + +canvasEventRetriever :: EventRetriever +canvasEventRetriever sharedIO canvasState = do + let + userRecvBuffer = canvasUserReceiveBuffer canvasState + messages <- takeMVar userRecvBuffer + putMVar userRecvBuffer [] + return (sharedIO, canvasState, (map InCanvas messages)) + + +canvasEventSender :: EventSender +canvasEventSender sharedIO canvasState (OutCanvas canvasOut) = do + let + conn = clientConnection canvasState + sendRoutedMessageOut conn (OutUserCanvas canvasOut) + return (sharedIO, canvasState) + + + +canvasTeardown :: Teardown +canvasTeardown sharedIO canvasState = do + WS.closeWebsocketConnection (serverSocket canvasState) (clientConnection canvasState) + killThread (routerThreadId canvasState) + return (sharedIO, canvasState) + + +sendRoutedMessageOut :: WS.Connection -> RoutedMessageOut -> IO () +sendRoutedMessageOut conn out = WS.writeMessage conn $ LBS.unpack $ encode out + + +router :: WS.ReceiveBuffer -> CanvasUserReceiveBuffer -> CanvasSystemReceiveBuffer -> IO () +router comRecvBuffer userRecvBuffer sysRecvBuffer = do + encodedRoutedIn <- takeMVar comRecvBuffer + let + Just routedIn = decode $ LBS.pack encodedRoutedIn :: Maybe RoutedMessageIn + case routedIn of + (InUserCanvas canvasIn) -> do + ins <- takeMVar userRecvBuffer + putMVar userRecvBuffer (ins ++ [canvasIn]) + nextStep + (InSystemCanvas canvasIn) -> do + putMVar sysRecvBuffer canvasIn + nextStep + where + nextStep = router comRecvBuffer userRecvBuffer sysRecvBuffer + + +--TODO +measureText :: IOState -> CanvasId -> CanvasText -> IO ScreenDimensions +measureText canvasState canvasId canvasText = return (4,4) + + + + + + + diff --git a/src/Eventloop/Module/Websocket/Canvas/JSONEncoding.hs b/src/Eventloop/Module/Websocket/Canvas/JSONEncoding.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/Websocket/Canvas/JSONEncoding.hs @@ -0,0 +1,222 @@ +{-# 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 .: "canvasid" + <*> (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 .: "canvasid" + <*> (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 + 1504 -> AlignStart + 1505 -> AlignEnd + + + +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 canvasId canvasText) = operationObject (toOpcode d) [ toJSON canvasId + , toJSON canvasText + ] + + +instance ToJSON CanvasOut where + toJSON d@(SetupCanvas canvasId zIndex screenDimensions canvasPosition) = operationObject (toOpcode d) [ toJSON canvasId + , toJSON zIndex + , toJSON screenDimensions + , toJSON canvasPosition + ] + toJSON d@(TeardownCanvas canvasId) = operationObject (toOpcode d) [toJSON canvasId] + toJSON d@(CanvasOperations canvasId canvasOperations) = operationObject (toOpcode d) [ toJSON canvasId + , toJSON canvasOperations + ] + toJSON d@(MeasureText canvasId text) = operationObject (toOpcode d) [ toJSON canvasId + , 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 textRender) = operationObject (toOpcode d) [ toJSON canvasText + , toJSON screenPoint + , toJSON textRender + ] + toJSON d@(DoTransform canvasTransform) = operationObject (toOpcode d) [toJSON canvasTransform] + toJSON d@(Clear clearPart) = operationObject (toOpcode d) [toJSON clearPart] + + +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 + ] + + +instance ToJSON PathStroke where + toJSON d@(PathStroke pathRenderStrokeStyle) = operationObject (toOpcode d) [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 TextRender where + toJSON d@(TextStroke textRenderStyle) = operationObject (toOpcode d) [ toJSON textRenderStyle + ] + toJSON d@(TextFill textRenderStyle) = operationObject (toOpcode d) [ toJSON textRenderStyle + ] + + +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 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 new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/Websocket/Canvas/Opcode.hs @@ -0,0 +1,93 @@ +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 + +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 + +instance ToOpcode PathStroke where + toOpcode (PathStroke _) = 501 + toOpcode (PathNoStroke) = 502 + +instance ToOpcode PathFill where + toOpcode (PathFill _) = 601 + toOpcode (PathNoFill) = 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 TextRender where + toOpcode (TextStroke _) = 1401 + toOpcode (TextFill _) = 1402 + +instance ToOpcode Alignment where + toOpcode (AlignLeft) = 1501 + toOpcode (AlignRight) = 1502 + toOpcode (AlignCenter) = 1503 + toOpcode (AlignStart) = 1504 + toOpcode (AlignEnd) = 1505 + +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 diff --git a/src/Eventloop/Module/Websocket/Canvas/Types.hs b/src/Eventloop/Module/Websocket/Canvas/Types.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/Websocket/Canvas/Types.hs @@ -0,0 +1,207 @@ +module Eventloop.Module.Websocket.Canvas.Types where + +import Control.Concurrent.MVar + +import Eventloop.Types.Common + +type CanvasUserReceiveBuffer = MVar [CanvasIn] +type CanvasSystemReceiveBuffer = MVar SystemCanvasIn + +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 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) + +{- |Opcode: 2100-} +data SystemCanvasIn = SystemMeasuredText CanvasId CanvasText ScreenDimensions {- ^Opcode: 2101-} + deriving (Eq, Show) + +{- |Opcode: 2000-} +data SystemCanvasOut = SystemMeasureText CanvasId CanvasText {- ^Opcode: 2001-} + deriving (Eq, Show) + +{- |Opcode: 0100-} +data CanvasIn = MeasuredText CanvasId 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-} +type CanvasPositionLeft = CSSUnit +type CanvasPositionRight = CSSUnit + +type CanvasPosition = (CanvasPositionLeft, CanvasPositionRight) + +data CanvasOut = SetupCanvas CanvasId ZIndex ScreenDimensions CanvasPosition {- ^Opcode: 0201-} + | TeardownCanvas CanvasId {- ^Opcode: 0202-} + | CanvasOperations CanvasId [CanvasOperation] {- ^Opcode: 0203-} + | MeasureText CanvasId CanvasText {- ^Opcode: 0204-} + deriving (Eq, Show) + +{- |Opcode: 0300-} +data CanvasOperation = DrawPath ScreenStartingPoint [ScreenPathPart] PathStroke PathFill {- ^Opcode: 0301 -} + | DrawText CanvasText ScreenPoint TextRender {- ^Opcode: 0302 -} + | DoTransform CanvasTransform {- ^Opcode: 0303 -} + | Clear ClearPart {- ^Opcode: 0304 -} + deriving (Eq, Show) + +{- |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-} + deriving (Eq, Show) + +{- Styling of Shapes -} +{- |Opcode: 0500-} +type PathRenderStrokeStyle = RenderStyle + +data PathStroke = PathStroke PathRenderStrokeStyle {- ^Opcode: 0501-} + | PathNoStroke {- ^Opcode: 0502-} + deriving (Eq, Show) + +{- |Opcode: 0600-} +type PathRenderFillStyle = RenderStyle + +data PathFill = PathFill PathRenderFillStyle {- ^Opcode: 0601-} + | PathNoFill {- ^Opcode: 0602-} + deriving (Eq, Show) + +{- |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) + +{- |Opcode: 0800-} +data CanvasImage = CanvasElement CanvasId ScreenPoint ScreenDimensions {- ^Opcode: 0801-} + | ImageData ScreenDimensions [ScreenPixel] {- ^Opcode: 0802 + [ScreenPixel] should be as long as width * height * 4 + -} + deriving (Eq, Show) +{- |Opcode: 0900-} +data PatternRepetition = Repeat {- ^Opcode: 0901-} + | RepeatX {- ^Opcode: 0902-} + | RepeatY {- ^Opcode: 0903-} + | NoRepeat {- ^Opcode: 0904-} + deriving (Eq, Show) + +{- |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) + +{- To Draw Text -} +{- |Opcode: 1200-} +data CanvasText = CanvasText [Char] Font Alignment {- ^Opcode: 1201-} + deriving (Eq, Show) + +{- |Opcode: 1300-} +data Font = Font FontFamily FontSize {- ^Opcode: 1301-} + deriving (Eq, Show) + +{- |Opcode: 1400-} +type TextStrokeRenderStyle = RenderStyle +type TextFillRenderStyle = RenderStyle + +data TextRender = TextStroke TextStrokeRenderStyle {- ^Opcode: 1401-} + | TextFill TextFillRenderStyle {- ^Opcode: 1402-} + deriving (Eq, Show) + +{- |Opcode: 1500-} +data Alignment = AlignLeft {- ^Opcode: 1501-} + | AlignRight {- ^Opcode: 1502-} + | AlignCenter {- ^Opcode: 1503-} + | AlignStart {- ^Opcode: 1504-} + | AlignEnd {- ^Opcode: 1505-} + deriving (Eq, Show) + +{- 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) + +{- |Opcode: 1800-} +data CSSUnit = CSSPixels Int {- ^Opcode: 1801-} + | CSSPercentage Int {- ^Opcode: 1802-} + deriving (Eq, Show) + +{- |Opcode: 1900 -} +data ClearPart = ClearRectangle ScreenPoint ScreenDimensions {- ^Opcode: 1901-} + | ClearCanvas {- ^Opcode: 1902-} + deriving (Eq, Show) diff --git a/src/Eventloop/Module/Websocket/Keyboard.hs b/src/Eventloop/Module/Websocket/Keyboard.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/Websocket/Keyboard.hs @@ -0,0 +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 +import Eventloop.Module.Websocket.Keyboard.Types diff --git a/src/Eventloop/Module/Websocket/Keyboard/Keyboard.hs b/src/Eventloop/Module/Websocket/Keyboard/Keyboard.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/Websocket/Keyboard/Keyboard.hs @@ -0,0 +1,69 @@ + {-# LANGUAGE OverloadedStrings #-} +module Eventloop.Module.Websocket.Keyboard.Keyboard + ( defaultKeyboardModuleConfiguration + , defaultKeyboardModuleIOState + , keyboardModuleIdentifier + , keyboardInitializer + , keyboardEventRetriever + , keyboardTeardown + ) where + +import Data.Aeson +import Data.Maybe +import Control.Applicative +import qualified Data.ByteString.Lazy.Char8 as BL + +import Eventloop.Types.EventTypes +import Eventloop.Module.Websocket.Keyboard.Types +import Eventloop.Utility.Config +import qualified Eventloop.Utility.BufferedWebsockets as WS + + +defaultKeyboardModuleConfiguration :: EventloopModuleConfiguration +defaultKeyboardModuleConfiguration = ( EventloopModuleConfiguration + keyboardModuleIdentifier + defaultKeyboardModuleIOState + (Just keyboardInitializer) + (Just keyboardEventRetriever) + Nothing + Nothing + (Just keyboardTeardown) + Nothing + ) + + +defaultKeyboardModuleIOState :: IOState +defaultKeyboardModuleIOState = KeyboardState undefined undefined undefined + +keyboardModuleIdentifier :: EventloopModuleIdentifier +keyboardModuleIdentifier = "keyboard" + + +instance FromJSON Keyboard where + parseJSON (Object v) = Key <$> v .: "key" + + +keyboardInitializer :: Initializer +keyboardInitializer sharedIO _ = do + (recvBuffer, clientConn, serverSock) <- WS.setupWebsocketConnection ipAddress keyboardPort + return (sharedIO, KeyboardState recvBuffer clientConn serverSock) + + +keyboardEventRetriever :: EventRetriever +keyboardEventRetriever sharedIO keyboardState = do + messages <- WS.takeMessages (receiveBuffer keyboardState) + return (sharedIO, keyboardState, map ((.) InKeyboard messageToKeyboardIn) messages) + + +messageToKeyboardIn :: WS.Message -> Keyboard +messageToKeyboardIn message = fromJust.decode $ BL.pack message + + +keyboardTeardown :: Teardown +keyboardTeardown sharedIO ks@(KeyboardState _ clientConn serverSock) = do + WS.closeWebsocketConnection serverSock clientConn + return (sharedIO, ks) + + + + diff --git a/src/Eventloop/Module/Websocket/Keyboard/Types.hs b/src/Eventloop/Module/Websocket/Keyboard/Types.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/Websocket/Keyboard/Types.hs @@ -0,0 +1,4 @@ +module Eventloop.Module.Websocket.Keyboard.Types where + +data Keyboard = Key [Char] + deriving (Eq, Show) diff --git a/src/Eventloop/Module/Websocket/Mouse.hs b/src/Eventloop/Module/Websocket/Mouse.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/Websocket/Mouse.hs @@ -0,0 +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 +import Eventloop.Module.Websocket.Mouse.Types diff --git a/src/Eventloop/Module/Websocket/Mouse/Mouse.hs b/src/Eventloop/Module/Websocket/Mouse/Mouse.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/Websocket/Mouse/Mouse.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE OverloadedStrings #-} +module Eventloop.Module.Websocket.Mouse.Mouse + ( defaultMouseModuleConfiguration + , defaultMouseModuleIOState + , mouseModuleIdentifier + , mouseInitializer + , mouseEventRetriever + , mouseTeardown + ) where + +import Data.Aeson +import Data.Aeson.Types +import Control.Monad +import Control.Applicative +import Data.Maybe +import qualified Data.ByteString.Lazy.Char8 as BL + +import qualified Eventloop.Utility.BufferedWebsockets as WS +import Eventloop.Types.EventTypes +import Eventloop.Types.Common +import Eventloop.Module.Websocket.Mouse.Types +import Eventloop.Utility.Config + + +defaultMouseModuleConfiguration :: EventloopModuleConfiguration +defaultMouseModuleConfiguration = ( EventloopModuleConfiguration + mouseModuleIdentifier + defaultMouseModuleIOState + (Just mouseInitializer) + (Just mouseEventRetriever) + Nothing + Nothing + (Just mouseTeardown) + Nothing + ) + +defaultMouseModuleIOState :: IOState +defaultMouseModuleIOState = MouseState undefined undefined undefined + +mouseModuleIdentifier :: EventloopModuleIdentifier +mouseModuleIdentifier = "mouse" + + +instance FromJSON Mouse where + parseJSON (Object v) = (v .: "type") >>= (parseMouseEvent v) + + +parseMouseEvent :: Object -> [Char] -> Parser Mouse +parseMouseEvent v eventType = case eventType of "click" -> Click <$> buttonP <*> posP + "dblclick" -> DoubleClick <$> buttonP <*> posP + "mousedown" -> MouseDown <$> buttonP <*> posP + "mouseup" -> MouseUp <$> buttonP <*> posP + "mouseenter" -> MouseEnter <$> posP + "mouseleave" -> MouseLeave <$> posP + "mousemove" -> MouseMove <$> posP + where + buttonP = parseMouseButton <$> (v.: "button") + posP = parseMousePosition v + + +parseMouseButton :: [Char] -> MouseButton +parseMouseButton "left" = MouseLeft +parseMouseButton "middle" = MouseMiddle +parseMouseButton "right" = MouseRight + + +parseMousePosition :: Object -> Parser Point +parseMousePosition v = (\x y -> (x, y)) <$> xP <*> yP + where + xP = v .: "x" + yP = v .: "y" + + +mouseInitializer :: Initializer +mouseInitializer sharedIO _ = do + (recvBuffer, clientConn, serverSock) <- WS.setupWebsocketConnection ipAddress mousePort + return (sharedIO, MouseState recvBuffer clientConn serverSock) + + +mouseEventRetriever :: EventRetriever +mouseEventRetriever sharedIO mouseState = do + messages <- WS.takeMessages (receiveBuffer mouseState) + return (sharedIO, mouseState, map ((.) InMouse messageToMouseIn) messages) + + +messageToMouseIn :: WS.Message -> Mouse +messageToMouseIn message = fromJust.decode $ BL.pack message + + +mouseTeardown :: Teardown +mouseTeardown sharedIO ms@(MouseState _ clientConn serverSock) = do + WS.closeWebsocketConnection serverSock clientConn + return (sharedIO, ms) + diff --git a/src/Eventloop/Module/Websocket/Mouse/Types.hs b/src/Eventloop/Module/Websocket/Mouse/Types.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Module/Websocket/Mouse/Types.hs @@ -0,0 +1,19 @@ +module Eventloop.Module.Websocket.Mouse.Types where + +import Eventloop.Types.Common + +type Point = (Float, Float) + +data Mouse = Click MouseButton Point + | DoubleClick MouseButton Point + | MouseMove Point + | MouseDown MouseButton Point + | MouseUp MouseButton Point + | MouseEnter Point + | MouseLeave Point + deriving (Eq, Show) + +data MouseButton = MouseLeft + | MouseRight + | MouseMiddle + deriving (Eq, Show) diff --git a/src/Eventloop/RouteEvent.hs b/src/Eventloop/RouteEvent.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/RouteEvent.hs @@ -0,0 +1,18 @@ +module Eventloop.RouteEvent where + +import Eventloop.Types.EventTypes + +import Eventloop.Module.File +import Eventloop.Module.Timer +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 + _ -> error ("Could not find route for out event: " ++ show out) diff --git a/src/Eventloop/Types/Common.hs b/src/Eventloop/Types/Common.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Types/Common.hs @@ -0,0 +1,4 @@ +module Eventloop.Types.Common where + +type NamedId = [Char] +type NumericId = Int diff --git a/src/Eventloop/Types/EventTypes.hs b/src/Eventloop/Types/EventTypes.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Types/EventTypes.hs @@ -0,0 +1,111 @@ +module Eventloop.Types.EventTypes where + +import System.IO +import Data.Maybe +import Control.Concurrent + +import qualified Eventloop.Utility.Websockets as WS +import qualified Eventloop.Utility.BufferedWebsockets as BWS + +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.StdIn.Types +import Eventloop.Module.StdOut.Types +import Eventloop.Module.Timer.Types + + + +-- General Types +type EventloopModuleIdentifier = [Char] +type Initializer = SharedIOState -> IOState -> IO (SharedIOState, IOState) +type EventRetriever = SharedIOState -> IOState -> IO (SharedIOState, IOState, [In]) +type PreProcessor = SharedIOState -> IOState -> In -> IO (SharedIOState, IOState, [In]) +type PostProcessor = SharedIOState -> IOState -> Out -> IO (SharedIOState, IOState, [Out]) +type EventSender = SharedIOState -> IOState -> Out -> IO (SharedIOState, IOState) +type Teardown = SharedIOState -> IOState -> IO (SharedIOState, IOState) + +type OutEventRouter = Out -> EventloopModuleIdentifier + + +data EventloopModuleConfiguration = EventloopModuleConfiguration { moduleIdentifier :: EventloopModuleIdentifier + , iostate :: IOState + , initializer :: Maybe Initializer + , eventRetriever :: Maybe EventRetriever + , preprocessor :: Maybe PreProcessor + , postprocessor :: Maybe PostProcessor + , teardown :: Maybe Teardown + , eventSender :: Maybe EventSender + } + +data EventloopConfiguration progstateT = EventloopConfiguration { progState :: progstateT + , eventloopFunc :: progstateT -> In -> (progstateT, [Out]) + , outRouter :: OutEventRouter + , sharedIOState :: SharedIOState + , moduleConfigurations :: [EventloopModuleConfiguration] + } + +data In = Start + | InKeyboard Keyboard + | InMouse Mouse + | InFile FileIn + | InTimer TimerIn + | InStdIn StdInIn + | InCanvas CanvasIn + deriving (Eq, Show) + + +data Out = OutFile FileOut + | OutTimer TimerOut + | OutStdOut StdOutOut + | OutStdIn StdInOut + | OutCanvas CanvasOut + | OutBasicShapes BasicShapesOut + | OutDrawTrees DrawTreesOut + | Stop + deriving (Eq, Show) + + +-- Shared IO State +data SharedIOState = SharedIOState { measureText :: CanvasText -> IO ScreenDimensions + } + +-- Modules IO State +data IOState = MouseState { receiveBuffer :: BWS.BufferedReceiveBuffer + , clientConnection :: BWS.Connection + , serverSocket :: BWS.Socket + } + | KeyboardState { receiveBuffer :: BWS.BufferedReceiveBuffer + , clientConnection :: BWS.Connection + , serverSocket :: BWS.Socket + } + | CanvasState { commonReceiveBuffer :: WS.ReceiveBuffer + , canvasUserReceiveBuffer :: CanvasUserReceiveBuffer + , canvasSystemReceiveBuffer :: CanvasSystemReceiveBuffer + , clientConnection :: WS.Connection + , serverSocket :: WS.Socket + , routerThreadId :: ThreadId + } + | StdInState { newStdInInEvents :: [StdInIn] + } + | TimerState { startedIntervalTimers :: [StartedTimer] + , startedTimers :: [StartedTimer] + , incomingIntervalTickBuffer :: IncomingTickBuffer + , incomingTickBuffer :: IncomingTickBuffer + } + | FileState { newFileInEvents :: [FileIn] + , opened :: [OpenFile] + } + | NoState + + +-- API module types +type APIName = [Char] +type Parameter = [Char] +type Value = [Char] +type Parameters =[(Parameter, Value)] + + diff --git a/src/Eventloop/Utility/BufferedWebsockets.hs b/src/Eventloop/Utility/BufferedWebsockets.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Utility/BufferedWebsockets.hs @@ -0,0 +1,58 @@ +module Eventloop.Utility.BufferedWebsockets + ( module Eventloop.Utility.Websockets + , module Eventloop.Utility.BufferedWebsockets + ) where + + + +import qualified Data.Text as T +import qualified Network.Socket as S +import Network.WebSockets hiding (Message) +import Control.Concurrent.MVar +import Control.Concurrent + +import Eventloop.Utility.Websockets hiding ( ReceiveBuffer + , setupWebsocketConnection + , spawnReader + , readIntoBuffer + , hasMessage + , takeMessage + ) + +type BufferedReceiveBuffer = MVar [Message] + +setupWebsocketConnection :: Host -> Port -> IO (BufferedReceiveBuffer, Connection, S.Socket) +setupWebsocketConnection host port = S.withSocketsDo $ do + serverSocket <- createBindListenServerSocket host port + clientConnection <- acceptFirstConnection serverSocket + recvBuffer <- newMVar [] + spawnReader recvBuffer clientConnection + return (recvBuffer, clientConnection, serverSocket) + + +spawnReader :: BufferedReceiveBuffer -> Connection -> IO ThreadId +spawnReader recvBuffer conn = do + forkIO (readIntoBuffer recvBuffer conn) + --Spawn reader but with function that catches closeRequest exception and closes the connection + + +readIntoBuffer :: BufferedReceiveBuffer -> Connection -> IO () +readIntoBuffer recvBuffer conn = do + textMessage <- receiveData conn + let + message = T.unpack textMessage + messages <- takeMVar recvBuffer + putMVar recvBuffer (messages ++ [message]) + readIntoBuffer recvBuffer conn + + +hasMessages :: BufferedReceiveBuffer -> IO Bool +hasMessages recvBuffer = do + messages <- readMVar recvBuffer + return ((length messages) > 0) + +takeMessages :: BufferedReceiveBuffer -> IO [Message] +takeMessages recvBuffer = do + messages <- takeMVar recvBuffer + putMVar recvBuffer [] + return messages diff --git a/src/Eventloop/Utility/Config.hs b/src/Eventloop/Utility/Config.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Utility/Config.hs @@ -0,0 +1,8 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Eventloop/Utility/Trees/GeneralTree.hs @@ -0,0 +1,134 @@ +module Eventloop.Utility.Trees.GeneralTree where + +import Eventloop.Module.BasicShapes.Types +import Eventloop.Utility.Vectors +import Eventloop.Utility.Trees.LayoutTree + + +data GeneralTree = GeneralTreeBox [GeneralNodeContent] [(GeneralLine, GeneralTree)] + deriving (Show, Eq) + +data GeneralNodeContent = GeneralNodeText FillColor String + | GeneralNode FillColor Radius + deriving (Show, Eq) + +data GeneralLine = GeneralLine StrokeColor + deriving (Show, Eq) + + +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 +treeIndex i (x, y) = BaseShape (Text iStr "Courier" 20 p) ((0,0,0,0), (255,75,75, 255)) Nothing + where + iStr = show i + (wText, hText) = textSize iStr + p = Point (x + 0.5 * wText, y) diff --git a/src/Eventloop/Utility/Trees/LayoutTree.hs b/src/Eventloop/Utility/Trees/LayoutTree.hs new file mode 100644 --- /dev/null +++ b/src/Eventloop/Utility/Trees/LayoutTree.hs @@ -0,0 +1,57 @@ +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 = 2 :: 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)) = BaseShape (Text text textFont height ((Point (xOffset, yOffset)) |+| p)) ((0,0,0,0), fillColor) Nothing +printNodeContent (xOffset, yOffset) (LayoutNode fillColor p r) = BaseShape (Circle ((Point (xOffset, yOffset)) |+| p) r) ((0,0,0,0), fillColor) Nothing + + +printLine :: Point -> (LayoutLine, LayoutTree) -> Shape +printLine startPoint ((LayoutLine lineColor),(LBox point topConnect _ _ _)) = BaseShape (Line startMarg endMarg) (lineColor, (0,0,0,0)) 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 new file mode 100644 --- /dev/null +++ b/src/Eventloop/Utility/Vectors.hs @@ -0,0 +1,99 @@ +module Eventloop.Utility.Vectors where + +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) + +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) + + +originPoint = Point (0,0) + + +class (RotateLeftAround a) => Vector2D a where + (|+|) :: a -> a -> a + (|-|) :: a -> a -> a + negateVector :: a -> a + +instance Vector2D PolarCoord where + pc1 |+| pc2 = toPolarCoord $ (toPoint pc1) |+| (toPoint pc2) + pc1 |-| pc2 = toPolarCoord $ (toPoint pc1) |-| (toPoint pc2) + negateVector pc1 = rotateLeftAround (Point (0,0)) 180 pc1 + +instance Vector2D Point where + (Point (x1, y1)) |+| (Point (x2, y2)) = Point (x1 + x2, y1 + y2) + (Point (x1, y1)) |-| (Point (x2, y2)) = Point (x2 - x1, y2 - y1) + negateVector (Point (x, y)) = Point (-x, -y) + + +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, 0.5 * pi + localRads) + | x < 0 && y < 0 = PolarCoord (len, 1.0 * pi + localRads) + | x > 0 && y < 0 = PolarCoord (len, 1.5 * pi + localRads) + where + x' = abs x + y' = abs y + localRads = atan (y' / x') + 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' = rotatePoint |-| p + 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 new file mode 100644 --- /dev/null +++ b/src/Eventloop/Utility/Websockets.hs @@ -0,0 +1,92 @@ +module Eventloop.Utility.Websockets + ( module Eventloop.Utility.Websockets + , S.Socket + , Connection + ) where + +import qualified Network.Socket as S +import qualified Data.Text as T +import Network.WebSockets hiding (Message) +import Control.Concurrent.MVar +import Control.Concurrent +import Control.Exception +import Data.ByteString.Lazy + +type Host = [Char] +type Port = Int +type Message = [Char] +type ReceiveBuffer = MVar Message + + +createBindListenServerSocket :: Host -> Port -> IO S.Socket +createBindListenServerSocket host port = do + host' <- S.inet_addr host + 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 +acceptFirstConnection serverSocket = do + (clientSocket, clientAddr) <- S.accept serverSocket + pendingConnection <- makePendingConnection clientSocket defaultConnectionOptions + connection <- acceptRequest pendingConnection + return connection + + +setupWebsocketConnection :: Host -> Port -> IO (ReceiveBuffer, Connection, S.Socket) +setupWebsocketConnection host port = S.withSocketsDo $ do + serverSocket <- createBindListenServerSocket host port + clientConnection <- acceptFirstConnection serverSocket + recvBuffer <- newEmptyMVar + spawnReader recvBuffer clientConnection + return (recvBuffer, clientConnection, serverSocket) + + +spawnReader :: ReceiveBuffer -> Connection -> IO ThreadId +spawnReader recvBuffer conn = do + forkIO (readIntoBuffer recvBuffer conn) + + +readIntoBuffer :: ReceiveBuffer -> Connection -> IO () +readIntoBuffer recvBuffer conn = handle handleCloseRequestException $ do + textMessage <- receiveData conn + let + message = T.unpack textMessage + putMVar recvBuffer message + readIntoBuffer recvBuffer conn + +handleCloseRequestException :: ConnectionException -> IO () +handleCloseRequestException (CloseRequest i reason) | i == 1000 = return () + | otherwise = Prelude.putStrLn ("Connection was closed but reason unknown: " ++ show i ++ show reason) +handleCloseRequestException (ConnectionClosed) = Prelude.putStrLn ("Connection was closed unexpectedly") +handleCloseRequestException (ParseException text) = Prelude.putStrLn ("Parse exception on message: " ++ text) + + +hasMessage :: ReceiveBuffer -> IO Bool +hasMessage recvBuffer = do + buffer <- tryReadMVar recvBuffer + return (buffer /= Nothing) + + +takeMessage :: ReceiveBuffer -> IO Message +takeMessage recvBuffer = do + message <- takeMVar recvBuffer + return message + + +writeMessage :: Connection -> Message -> IO () +writeMessage conn message = sendTextData conn (T.pack message) + + +writeBinaryMessage :: Connection -> ByteString -> IO () +writeBinaryMessage conn message = sendBinaryData conn message + + +closeWebsocketConnection :: S.Socket -> Connection -> IO () +closeWebsocketConnection serverSocket clientConnection = do + S.sClose serverSocket + sendClose clientConnection (T.pack "Shutting down..") +