eventloop 0.8.1.2 → 0.8.2.0

raw patch · 9 files changed

+113/−27 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• eventloop.cabal +4/−4
• src/Eventloop/Core.hs +2/−2
• src/Eventloop/Module/BasicShapes/Classes.hs +56/−15
• src/Eventloop/Module/BasicShapes/Types.hs +8/−0
• src/Eventloop/Module/Websocket/Canvas/JSONEncoding.hs +1/−1
• src/Eventloop/Module/Websocket/Canvas/Opcode.hs +1/−0
• src/Eventloop/Module/Websocket/Canvas/Types.hs +1/−0
• src/Eventloop/Utility/Vectors.hs +39/−3
• src/Eventloop/Utility/Websockets.hs +1/−2

@@ -6,7 +6,7 @@ -- PVP summary:      +-+------- breaking API changes
 --                   | | +----- non-breaking API additions
 --                   | | | +--- code changes with no API change
-version:             0.8.1.2
+version:             0.8.2.0
 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),
@@ -23,7 +23,7 @@ license:             BSD3
 license-file:        LICENSE
 author:              Sebastiaan la Fleur
-maintainer:          sebastiaan.la.fleur@gmail.com
+maintainer:          sebastiaan@slafleur.nl
 copyright:           University of Twente 2015 | Sebastiaan la Fleur 2015
 category:            Eventloop
 build-type:          Simple
@@ -101,13 +101,13 @@   
   other-extensions:    OverloadedStrings
   
-  build-depends:       base >=4.8 && <4.9, 
+  build-depends:       base >=4.8 && <4.10, 
                        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, 
+                       aeson >=0.8 && <0.12, 
                        bytestring >=0.10 && <0.11,
                        concurrent-utilities >=0.2 && <0.3,
                        stm >=2.4 && <2.5,

@@ -75,11 +75,11 @@                             putInBlockingConcurrentQueue outEventQueue_ Stop
 
                             -- Wait for the Stop to propagate
-                            threadDelay 100000
+                            threadDelay 1000000
 
                             -- Kill the outrouter and senders if need be
                             senders <- senderThreads systemConfig'
-                            senderTimers <- mapM (terminateWithinOrThrowException 1000000 (toException ShuttingDownException)) (outRouter ++ senders)
+                            senderTimers <- mapM (terminateWithinOrThrowException 2000000 (toException ShuttingDownException)) (outRouter ++ senders)
 
                             -- Wait for the outRouter and Sender
                             joinThreads (outRouter ++ senders)

@@ -110,6 +110,41 @@ roundColor (r, b, g, a) = (round r, round b, round g, a)
 
 
+strokePointsForConnection :: StrokeLineThickness -> Point -> Point -> Point -> [Point]
+strokePointsForConnection strokeWidth start inspected dest
+    = [intersectVector sdown1 v1 sdown2 v2, intersectVector sup1 v1 sup2 v2]
+    where
+        halfWidth = strokeWidth / 2
+        quart = 0.5 * pi
+        v1 = inspected |-| start
+        v1' = negateVector v1
+        v2 = inspected |-| dest
+        v2' = negateVector v2
+        upv1 = turnToVector v1 quart v2
+        sup1 = followVector halfWidth upv1 inspected
+        upv2 = turnToVector v2 quart v1
+        sup2 = followVector halfWidth upv2 inspected
+        downv1 = negateVector upv1
+        sdown1 = followVector halfWidth downv1 inspected
+        downv2 = negateVector upv2
+        sdown2 = followVector halfWidth downv2 inspected
+
+
+strokePoints :: StrokeLineThickness -> [Point] -> [Point]
+strokePoints strokeWidth ps
+    | l >= 3    = concat $ map (\(start, inspected, dest) -> strokePointsForConnection strokeWidth start inspected dest) connections
+    | otherwise = []
+    where
+        l = length ps
+        connections = zip3 ps (drop 1 ps) (drop 2 ps)
+
+
+strokePointsClosedPath :: StrokeLineThickness -> [Point] -> [Point]
+strokePointsClosedPath strokeWidth ps
+    | length ps >= 3 = strokePoints strokeWidth (ps ++ take 2 ps)
+    | otherwise = []
+
+
 instance Translate Shape where
     translate p c@(CompositeShape {positionM=Nothing})
         = c {positionM = (Just p)}
@@ -159,13 +194,9 @@     toPrimitives (Circle {position=p, radius=r, strokeLineThickness=thick, rotationM=Nothing})
         = [CircleArea p (r + 0.5 * thick)]
     toPrimitives (RegularPolygon {numberOfPoints=a, position=p, radius=r, strokeLineThickness=thick, rotationM=Nothing})
-        | a > 2  = toPrimitives (MultiLine points thick undefined Nothing)
-        | a == 2 = toPrimitives (Line p1 p2 thick undefined Nothing)
-        | a == 1 = [Points (take 1 points)]
-        | a == 0 = [Points []]
+        = toPrimitives (Polygon points undefined thick undefined Nothing)
         where
              points = allRegularPolygonPoints a p r
-             (p1:p2:ops) = points
     toPrimitives text@(Text {position=(Point (x,y)), alignment=align, rotationM=Nothing})
         = [ Points $ case align of
             CT.AlignLeft   -> [ Point (x, y)
@@ -203,15 +234,21 @@             upPerpVector = upPerpendicular p1 p2
             downPerpVector = negateVector upPerpVector
     toPrimitives (MultiLine {points=points, strokeLineThickness=thick, rotationM=Nothing})
-        = concat $ map toPrimitives lines
+        = (Points strokePoints_) : (concat $ map toPrimitives lines)
         where
+            strokePoints_ = strokePoints thick points
             tailPoints = drop 1 points
             linePoints = zip points tailPoints
             lines = map (\(p, p') -> Line p p' thick undefined Nothing) linePoints
-    toPrimitives pol@(Polygon {points=points, strokeLineThickness=thick, strokeColor=strokeColor, rotationM=Nothing})
-        = toPrimitives (MultiLine allPoints thick strokeColor Nothing)
+    toPrimitives (FilledMultiLine {points=points, fillWidth=fillThick, strokeLineThickness=strokeThick, rotationM=Nothing})
+        = (toPrimitives (MultiLine points fillThick undefined Nothing)) ++ (toPrimitives (MultiLine points (fillThick + strokeThick) undefined Nothing))
+    toPrimitives pol@(Polygon {points=points, strokeLineThickness=thick, rotationM=Nothing})
+        | length points >= 3 = [ Points (strokePointsClosedPath thick points)]
+        | length points == 2 = toPrimitives (Line p1 p2 thick undefined Nothing)
+        | length points == 1 = [ CircleArea p1 thick ]
+        | otherwise          = [ Points []]
         where
-            allPoints = allScreenPolygonPoints pol
+            (p1:p2:ps) = points
     toPrimitives shape
         = map (rotateLeftAround rotatePoint angle) (toPrimitives shapePreRotate)
         where
@@ -253,6 +290,8 @@         = (toCenter.toBoundingBox) l
     toCenter ml@(MultiLine {})
         = (toCenter.toBoundingBox) ml
+    toCenter fml@(FilledMultiLine {})
+        = (toCenter.toBoundingBox) fml
     toCenter a@(Polygon {})
         = (toCenter.toBoundingBox) a
     toCenter shape
@@ -368,6 +407,10 @@           screenFillColor = roundColor fill
           p' = roundPoint p
 
+    toCanvasOperations (FilledMultiLine points fillWidth fillColor strokeThick strokeColor Nothing)
+        =  toCanvasOperations (MultiLine points (fillWidth + strokeThick) strokeColor Nothing)
+        ++ toCanvasOperations (MultiLine points fillWidth fillColor Nothing)
+
     toCanvasOperations shape
         -- Might be any rotated shape
         | isJust (rotationM shape) = [ CT.DoTransform CT.Save
@@ -413,7 +456,7 @@             p' = roundPoint p
             r' = round r
     toScreenPathParts (RegularPolygon {position=p, numberOfPoints=n, radius=r})
-        = Just (lines, screenPoint)
+        = Just (lines ++ [CT.ClosePath], screenPoint)
         where
             polygonPoints = allRegularPolygonPoints n p r
             (screenPoint:ps) = map roundPoint polygonPoints
@@ -432,7 +475,7 @@             lines = [CT.LineTo p' | p' <- otherPoints']
 
     toScreenPathParts pol@(Polygon {points=points})
-        | (length points) > 0 = Just (lines ++ [CT.MoveTo p1'], p1')
+        | (length points) > 0 = Just (lines ++ [CT.ClosePath], p1')
         | otherwise           = Nothing
         where
             allPoints = allScreenPolygonPoints pol
@@ -463,13 +506,11 @@ 
 
 allScreenPolygonPoints :: Shape -> [Point]
-allScreenPolygonPoints (Polygon {points=points, strokeLineThickness=thick})
-    | (length points) >= 2 = points ++ [closeP]
+allScreenPolygonPoints (Polygon {points=points})
+    | (length points) >= 2 = points ++ [firstP]
     | otherwise            = points
     where
         firstP = head points
         lastP  = last points
-        closeP = followVector (0.5 * thick) (firstP |-| lastP) firstP
-
 
 

@@ -29,6 +29,7 @@ type FillColor = Color
 type StrokeColor = Color
 
+type FillThickness = GraphicalNumeric
 type StrokeLineThickness = GraphicalNumeric
 
 type UpperLeft = Point
@@ -92,6 +93,13 @@                        , strokeColor :: StrokeColor
                        , rotationM :: Maybe Rotation
                        }
+           | FilledMultiLine { points :: [Point]
+                             , fillWidth :: FillThickness
+                             , fillColor :: FillColor
+                             , strokeLineThickness :: StrokeLineThickness
+                             , strokeColor :: StrokeColor
+                             , rotationM :: Maybe Rotation
+                             }
            | Polygon { points :: [Point] -- ^| Closes shape automatically with fill. Do not forget that the fill encloses the entire path. This means that half of the stroke is overwritten by the fill.
                      , fillColor :: FillColor
                      , strokeLineThickness :: StrokeLineThickness

@@ -126,8 +126,8 @@     toJSON d@(Rectangle screenPoint screenDimensions) = operationObject (toOpcode d) [ toJSON screenPoint
                                                                                      , toJSON screenDimensions
                                                                                      ]
+    toJSON d@(ClosePath) = operationObject (toOpcode d) []
 
-    
 instance ToJSON PathStroke where
     toJSON d@(PathStroke screenLineThickness pathRenderStrokeStyle) = operationObject (toOpcode d) [ toJSON screenLineThickness
                                                                                                    , toJSON pathRenderStrokeStyle

@@ -30,6 +30,7 @@     toOpcode (ArcTo _ _ _)           = 405
     toOpcode (Arc _ _ _)             = 406
     toOpcode (Rectangle _ _)         = 407
+    toOpcode (ClosePath)             = 408
 
 instance ToOpcode PathStroke where
     toOpcode (PathStroke _ _) = 501

@@ -115,6 +115,7 @@                     | ArcTo ScreenControlPoint ScreenControlPoint ScreenRadius {- ^Opcode: 0405-}
                     | Arc ScreenCircle ScreenStartingAngle ScreenEndAngle {- ^Opcode: 0406-}
                     | Rectangle ScreenPoint ScreenDimensions {- ^Opcode: 0407-}
+                    | ClosePath {- ^Opcode: 0408-}
                     deriving (Eq, Show, Generic, NFData)
 
 {- Styling of Shapes -}

@@ -3,6 +3,7 @@ 
 import GHC.Generics (Generic)
 import Control.DeepSeq
+import Data.Fixed (mod')
 
 type Angle = Float -- ^In degrees
 type Radians = Float
@@ -14,11 +15,10 @@ 
 data PolarCoord = PolarCoord (Length, Radians)
                 deriving (Show, Eq)
-                
+
 data Point = Point (X, Y)
             deriving (Show, Eq, Generic, NFData)
 
-
 class Coord a where
     x :: a -> X
     y :: a -> Y
@@ -101,6 +101,30 @@         size     = lengthBetweenPoints followP originPoint
 
 
+intersectVector :: Point -> Point -> Point -> Point -> Point
+intersectVector s1@(Point (s1x, s1y)) v1@(Point (v1x, v1y)) s2@(Point (s2x, s2y)) v2@(Point (v2x, v2y))
+    | v2y /= 0 = Point (v1x * lambda + s1x, v1y * lambda + s1y)
+    | otherwise = intersectVector s2 v2 s1 v1
+    where
+        lambda = (s1x - s2x - (v2x * s1y) / v2y + (v2x * s2y) / v2y) / ((v2x * v1y) / v2y - v1x)
+
+
+turnToVector :: Point -> Radians -> Point -> Point
+turnToVector toTurn@(Point (tux, tuy)) a turnTo@(Point (tox, toy))
+    | (diffRadianCCW >= 0 && diffRadianCCW  <= half) || (diffRadianCCW' >= 0 && diffRadianCCW' <= half) = toPoint (PolarCoord (1, radianToTurn + a))
+    | otherwise                                                                                         = toPoint (PolarCoord (1, radianToTurn - a))
+    where
+        (PolarCoord (_, radianToTurn)) = toPolarCoord toTurn
+        (PolarCoord (_, radianTurnTo)) = toPolarCoord turnTo
+        whole = 2 * pi
+        half = pi
+        quart = 0.5 * pi
+        diffRadianCCW = radianTurnTo - radianToTurn
+        radianTurnTo' = mod' (radianTurnTo - quart) whole
+        radianToTurn' = mod' (radianToTurn - quart) whole
+        diffRadianCCW' = radianTurnTo' - radianToTurn' -- Extra check due to hard split between 0 and 360
+
+
 originPoint = Point (0,0)
 
 class Translate a where
@@ -113,6 +137,7 @@     (|/)  :: (Real b) => a -> b -> a
     (|*)  :: (Real b) => a -> b -> a
     negateVector :: a -> a
+    angleBetween :: a -> a -> Radians
 
 instance Vector2D PolarCoord where
     pc1 |+| pc2 = toPolarCoord $ (toPoint pc1) |+| (toPoint pc2)
@@ -128,6 +153,10 @@             l' = toRational l
             scalar' = toRational scalar
     negateVector pc1 = rotateLeftAround (Point (0,0)) 180 pc1
+
+    angleBetween pc1 pc2
+        = angleBetween (toPoint pc1) (toPoint pc2)
+
     
 instance Vector2D Point where
     (Point (x1, y1)) |+| (Point (x2, y2))
@@ -151,7 +180,14 @@     negateVector (Point (x, y))
         = Point (-x, -y)
 
-    
+    angleBetween v1@(Point (v1x, v1y)) v2@(Point (v2x, v2y))
+        = acos (dotProduct / (lv1 * lv2))
+        where
+            dotProduct = v1x * v2x + v1y * v2y
+            lv1 = lengthToPoint v1
+            lv2 = lengthToPoint v2
+
+
 class ToPoint a where
     toPoint :: a -> Point
     

@@ -90,8 +90,7 @@                                 
                                 
 writeMessage :: Connection -> Message -> IO ()
-writeMessage conn message = do
-                                sendTextData conn (T.pack message)
+writeMessage conn message = sendTextData conn (T.pack message)
 
 writeBinaryMessage :: Connection -> ByteString -> IO ()
 writeBinaryMessage conn message = sendBinaryData conn message