eventloop 0.7.0.1 → 0.8.0.0
raw patch · 7 files changed
+121/−79 lines, 7 files
Files
- eventloop.cabal +2/−2
- src/Eventloop/Module/BasicShapes/Classes.hs +88/−56
- src/Eventloop/Module/BasicShapes/Types.hs +19/−15
- src/Eventloop/Module/Websocket/Canvas/Opcode.hs +1/−1
- src/Eventloop/Module/Websocket/Canvas/Types.hs +1/−1
- src/Eventloop/Module/Websocket/Keyboard/Types.hs +6/−0
- src/Eventloop/Utility/Vectors.hs +4/−4
eventloop.cabal view
@@ -6,7 +6,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.7.0.1 +version: 0.8.0.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), @@ -116,4 +116,4 @@ hs-source-dirs: src -- Base language which the package is written in. - default-language: Haskell2010+ default-language: Haskell2010
src/Eventloop/Module/BasicShapes/Classes.hs view
@@ -13,17 +13,18 @@ The center of a boundingbox is not the center of an element Rectangle - Intersection of two halves of adjoining sides Circle - Centre point - Polygon - Centre point + RegularPolygon - Centre point Text - See boundingbox to rectangle Line - Halfway down the line MultiLine - See boundingbox Split into points to calc boundingbox Rectangle - Split into 4 corners Circle - Top, left, right and bottom points on the circle - Polygon - Split into the polygon points + RegularPolygon - Split into the regular polygon points Text - Split into 4 corners of bbox Line - Split into the two points - MultiLine - Split into the different points + MultiLine - Split into the different points with stroke + Polygon - Split into the different points with stroke -} {- @@ -76,8 +77,8 @@ -allPolygonPoints :: AmountOfPoints -> Point -> Radius -> [Point] -allPolygonPoints n centralPoint r | n < 1 = error "A polygon with 0 or more sides doesn't exist!" +allRegularPolygonPoints :: NumberOfPoints -> Point -> Radius -> [Point] +allRegularPolygonPoints n centralPoint r | n < 1 = error "A regular polygon with 0 or more sides doesn't exist!" | otherwise = [centralPoint |+| (toPoint (PolarCoord (r, angle))) |angle <- anglesRads] where anglePart = 360 / (fromIntegral n) @@ -110,22 +111,24 @@ instance Translate Shape where - translate p c@(CompositeShape {translationM=Nothing}) - = c {translationM = (Just p)} - translate p c@(CompositeShape {translationM=(Just p1)}) - = c {translationM = (Just $ p1 |+| p)} - translate p r@(Rectangle {translation=trans}) - = r {translation = trans |+| p} - translate p c@(Circle {translation=trans}) - = c {translation = trans |+| p} - translate p po@(Polygon {translation=trans}) - = po {translation = trans |+| p} - translate p t@(Text {translation=trans}) - = t {translation = trans |+| p} + translate p c@(CompositeShape {positionM=Nothing}) + = c {positionM = (Just p)} + translate p c@(CompositeShape {positionM=(Just p1)}) + = c {positionM = (Just $ p1 |+| p)} + translate p r@(Rectangle {position=trans}) + = r {position = trans |+| p} + translate p c@(Circle {position=trans}) + = c {position = trans |+| p} + translate p po@(RegularPolygon {position=trans}) + = po {position = trans |+| p} + translate p t@(Text {position=trans}) + = t {position = trans |+| p} translate pTrans l@(Line {point1=p1, point2=p2}) = l {point1 = (p1 |+| pTrans), point2 = (p2 |+| pTrans)} - translate pTrans ml@(MultiLine {point1=p1, point2=p2, otherPoints=ops}) - = ml {point1 = (p1 |+| pTrans), point2 = (p2 |+| pTrans), otherPoints = (map ((|+|) pTrans) ops)} + translate pTrans ml@(MultiLine {points=points}) + = ml {points = (map ((|+|) pTrans) points)} + translate pTrans a@(Polygon {points=points}) + = a {points = (map ((|+|) pTrans) points)} instance Translate GeometricPrimitive where translate p (Points points) = Points (map (|+| p) points) @@ -139,12 +142,12 @@ toPrimitives (BoundingBox ll ul ur lr) = [Points [ll, ul, ur, lr]] instance ToPrimitives Shape where - toPrimitives (CompositeShape shapes translationM Nothing) - | isJust translationM = map (translate (fromJust translationM)) primitives + toPrimitives (CompositeShape shapes positionM Nothing) + | isJust positionM = map (translate (fromJust positionM)) primitives | otherwise = primitives where primitives = concat $ map toPrimitives shapes - toPrimitives (Rectangle {translation=(Point (x, y)), dimensions=(w, h), strokeLineThickness=thick, rotationM=Nothing}) + toPrimitives (Rectangle {position=(Point (x, y)), dimensions=(w, h), strokeLineThickness=thick, rotationM=Nothing}) = [ Points [ Point (x - hthick, y - hthick) , Point (x - hthick, y + h + hthick) , Point (x + w + hthick, y + h + hthick) @@ -153,17 +156,17 @@ ] where hthick = 0.5 * thick - toPrimitives (Circle {translation=p, radius=r, strokeLineThickness=thick, rotationM=Nothing}) + toPrimitives (Circle {position=p, radius=r, strokeLineThickness=thick, rotationM=Nothing}) = [CircleArea p (r + 0.5 * thick)] - toPrimitives (Polygon {amountOfPoints=a, translation=p, radius=r, strokeLineThickness=thick, rotationM=Nothing}) - | a > 2 = toPrimitives (MultiLine p1 p2 ops thick undefined Nothing) + 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 []] where - points = allPolygonPoints a p r + points = allRegularPolygonPoints a p r (p1:p2:ops) = points - toPrimitives text@(Text {translation=(Point (x,y)), alignment=align, rotationM=Nothing}) + toPrimitives text@(Text {position=(Point (x,y)), alignment=align, rotationM=Nothing}) = [ Points $ case align of CT.AlignLeft -> [ Point (x, y) , Point (x, y + height) @@ -199,13 +202,16 @@ where upPerpVector = upPerpendicular p1 p2 downPerpVector = negateVector upPerpVector - toPrimitives (MultiLine {point1=p1, point2=p2, otherPoints=ops, strokeLineThickness=thick, rotationM=Nothing}) + toPrimitives (MultiLine {points=points, strokeLineThickness=thick, rotationM=Nothing}) = concat $ map toPrimitives lines where - allPoints = p1:p2:ops - tailPoints = p2:ops - linePoints = zip allPoints tailPoints + 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) + where + allPoints = allScreenPolygonPoints pol toPrimitives shape = map (rotateLeftAround rotatePoint angle) (toPrimitives shapePreRotate) where @@ -227,19 +233,19 @@ maxY = yMax bbox instance ToCenter Shape where - toCenter c@(CompositeShape {translationM=(Just p), rotationM=Nothing}) + toCenter c@(CompositeShape {positionM=(Just p), rotationM=Nothing}) = p |+| center where - center = toCenter c{translationM=Nothing} - toCenter c@(CompositeShape {shapes=shapes, translationM=Nothing, rotationM=Nothing}) + center = toCenter c{positionM=Nothing} + toCenter c@(CompositeShape {shapes=shapes, positionM=Nothing, rotationM=Nothing}) = averagePoint centers where centers = map toCenter shapes - toCenter r@(Rectangle {dimensions=(width, height), translation=p, rotationM=Nothing}) + toCenter r@(Rectangle {dimensions=(width, height), position=p, rotationM=Nothing}) = p |+| (Point (0.5 * width, 0.5 * height)) - toCenter c@(Circle {translation=p, rotationM=Nothing}) + toCenter c@(Circle {position=p, rotationM=Nothing}) = p - toCenter po@(Polygon {translation=p, rotationM=Nothing}) + toCenter po@(RegularPolygon {position=p, rotationM=Nothing}) = p toCenter t@(Text {rotationM=Nothing}) = (toCenter.toBoundingBox) t @@ -247,6 +253,8 @@ = (toCenter.toBoundingBox) l toCenter ml@(MultiLine {}) = (toCenter.toBoundingBox) ml + toCenter a@(Polygon {}) + = (toCenter.toBoundingBox) a toCenter shape = rotateLeftAround rotationPoint angle center where @@ -337,15 +345,15 @@ toCanvasOperations (CompositeShape shapes (Just translate) Nothing) = [ CT.DoTransform CT.Save - , CT.DoTransform (CT.Translate screenTranslationPoint) + , CT.DoTransform (CT.Translate screenPositionPoint) ] ++ drawOperations ++ [ CT.DoTransform CT.Restore ] where - screenTranslationPoint = roundPoint translate + screenPositionPoint = roundPoint translate drawOperations = toCanvasOperations (CompositeShape shapes Nothing Nothing) - toCanvasOperations text@(Text { translation=p + toCanvasOperations text@(Text { position=p , fillColor=fill , strokeLineThickness=thick , strokeColor=stroke @@ -369,8 +377,9 @@ ++ (toCanvasOperations movedShape) ++ [ CT.DoTransform CT.Restore ] - -- Can only be Rectangle, Circle, Polygon, Line or MultiLine - | otherwise = [CT.DrawPath startingPoint screenPathParts pathStroke canvasPathFill] + -- Can only be Rectangle, Circle, RegularPolygon, Line, MultiLine or Polygon + | isJust screenPathPartsM = [CT.DrawPath startingPoint screenPathParts pathStroke canvasPathFill] + | otherwise = [] where (Just rotation) = rotationM shape shapePreRotate = shape{rotationM = Nothing} @@ -381,43 +390,52 @@ movedShape = translate (negateVector rotationPoint) shapePreRotate canvasPathFill = toCanvasPathFill shape - (screenPathParts, startingPoint) = toScreenPathParts shape + screenPathPartsM = toScreenPathParts shape + Just (screenPathParts, startingPoint) = screenPathPartsM screenStrokeColor = roundColor $ strokeColor shape thick = strokeLineThickness shape pathStroke = CT.PathStroke (round thick) (CT.CanvasColor screenStrokeColor) class ToScreenPathPart a where - toScreenPathParts :: a -> ([CT.ScreenPathPart], CT.ScreenStartingPoint) + toScreenPathParts :: a -> Maybe ([CT.ScreenPathPart], CT.ScreenStartingPoint) instance ToScreenPathPart Shape where - toScreenPathParts (Rectangle {translation=p, dimensions=(w, h)}) - = ([CT.Rectangle p' (w', h')], p') + toScreenPathParts (Rectangle {position=p, dimensions=(w, h)}) + = Just ([CT.Rectangle p' (w', h')], p') where p' = roundPoint p w' = round w h' = round h - toScreenPathParts (Circle {translation=p, radius=r}) - = ([CT.Arc (p', r') 0 360], p') + toScreenPathParts (Circle {position=p, radius=r}) + = Just ([CT.Arc (p', r') 0 360], p') where p' = roundPoint p r' = round r - toScreenPathParts (Polygon {translation=p, amountOfPoints=n, radius=r}) - = (lines, screenPoint) + toScreenPathParts (RegularPolygon {position=p, numberOfPoints=n, radius=r}) + = Just (lines, screenPoint) where - polygonPoints = allPolygonPoints n p r + polygonPoints = allRegularPolygonPoints n p r (screenPoint:ps) = map roundPoint polygonPoints lines = [CT.LineTo screenPoint' | screenPoint' <- (ps ++ [screenPoint])] toScreenPathParts (Line {point1=p1, point2=p2}) - = ([CT.LineTo p2'], p1') + = Just ([CT.LineTo p2'], p1') where p1' = roundPoint p1 p2' = roundPoint p2 - toScreenPathParts (MultiLine {point1=p1, point2=p2, otherPoints=otherPoints_}) - = (lines ++ [CT.MoveTo p1'], p1') + toScreenPathParts (MultiLine {points=points}) + | (length points) > 0 = Just (lines ++ [CT.MoveTo p1'], p1') + | otherwise = Nothing where - allPoints = p1:p2:otherPoints_ + (p1':otherPoints') = map roundPoint points + lines = [CT.LineTo p' | p' <- otherPoints'] + + toScreenPathParts pol@(Polygon {points=points}) + | (length points) > 0 = Just (lines ++ [CT.MoveTo p1'], p1') + | otherwise = Nothing + where + allPoints = allScreenPolygonPoints pol (p1':otherPoints') = map roundPoint allPoints lines = [CT.LineTo p' | p' <- otherPoints'] @@ -436,8 +454,22 @@ = True hasCanvasPathFill (Circle {}) = True +hasCanvasPathFill (RegularPolygon {}) + = True hasCanvasPathFill (Polygon {}) = True hasCanvasPathFill _ = False - + + +allScreenPolygonPoints :: Shape -> [Point] +allScreenPolygonPoints (Polygon {points=points, strokeLineThickness=thick}) + | (length points) >= 2 = points ++ [closeP] + | otherwise = points + where + firstP = head points + lastP = last points + closeP = followVector (0.5 * thick) (firstP |-| lastP) firstP + + +
src/Eventloop/Module/BasicShapes/Types.hs view
@@ -13,7 +13,7 @@ type GraphicalNumeric = Float -type Translation = Point +type Position = Point type Width = GraphicalNumeric type Height = GraphicalNumeric @@ -36,7 +36,7 @@ type LowerLeft = Point type LowerRight = Point -type AmountOfPoints = Int +type NumberOfPoints = Int type FontFamily = [Char] type FontSize = GraphicalNumeric @@ -46,35 +46,35 @@ deriving (Show, Eq, Generic, NFData) data Shape = CompositeShape { shapes :: [Shape] - , translationM :: Maybe Translation + , positionM :: Maybe Position , rotationM :: Maybe Rotation - } -- ^Should contain atleast 1 shape. Rotation before Translation - | Rectangle { translation :: Translation + } -- ^Should contain atleast 1 shape. Rotation before Position + | Rectangle { position :: Position , dimensions :: Dimensions , fillColor :: FillColor , strokeLineThickness :: StrokeLineThickness , strokeColor :: StrokeColor , rotationM :: Maybe Rotation - } -- ^| Translation is upperleftcorner. Translation is the corner closes to origin. Visually in canvas, this is top left. In a Cartesian coördinate system, this is bottom left. - | Circle { translation :: Translation + } -- ^| Position is upperleftcorner. Position is the corner closes to origin. Visually in canvas, this is top left. In a Cartesian coördinate system, this is bottom left. + | Circle { position :: Position , radius :: Radius , fillColor :: FillColor , strokeLineThickness :: StrokeLineThickness , strokeColor :: StrokeColor , rotationM :: Maybe Rotation - } -- ^| Translation is center - | Polygon { translation :: Translation - , amountOfPoints :: AmountOfPoints + } -- ^| Position is center + | RegularPolygon { position :: Position + , numberOfPoints :: NumberOfPoints , radius :: Radius , fillColor :: FillColor , strokeLineThickness :: StrokeLineThickness , strokeColor :: StrokeColor , rotationM :: Maybe Rotation - } -- ^The first point of the polygon, always starts in the direction from the x-axis.(Towards x-infinity). Translation is the the centre of the polygon + } -- ^The first point of the regular polygon, always starts in the direction from the x-axis.(Towards x-infinity). Position is the the centre of the regular polygon | Text { text :: [Char] , fontFamily :: FontFamily , fontSize :: FontSize - , translation :: Translation + , position :: Position , alignment :: Alignment , fillColor :: FillColor , strokeLineThickness :: StrokeLineThickness @@ -87,13 +87,17 @@ , strokeColor :: StrokeColor , rotationM :: Maybe Rotation } - | MultiLine { point1 :: Point - , point2 :: Point - , otherPoints :: [Point] + | MultiLine { points :: [Point] -- ^| Can contain any number of points , strokeLineThickness :: StrokeLineThickness , strokeColor :: StrokeColor , rotationM :: Maybe Rotation } + | Polygon { points :: [Point] -- ^| Closes shape automatically with fill. Do not forget that the fill encloses the entire path. This means that half of the stroke is overwritten by the fill. + , fillColor :: FillColor + , strokeLineThickness :: StrokeLineThickness + , strokeColor :: StrokeColor + , rotationM :: Maybe Rotation + } deriving (Show, Eq, Generic, NFData)
src/Eventloop/Module/Websocket/Canvas/Opcode.hs view
@@ -47,7 +47,7 @@ instance ToOpcode CanvasImage where toOpcode (CanvasElement _ _ _) = 801 toOpcode (ImageData _ _) = 802 - + instance ToOpcode PatternRepetition where toOpcode (Repeat) = 901 toOpcode (RepeatX) = 902
src/Eventloop/Module/Websocket/Canvas/Types.hs view
@@ -143,7 +143,7 @@ {- |Opcode: 0800-} data CanvasImage = CanvasElement CanvasId ScreenPoint ScreenDimensions {- ^Opcode: 0801-} | ImageData ScreenDimensions [ScreenPixel] {- ^Opcode: 0802 - [ScreenPixel] should be as long as width * height * 4 + [ScreenPixel] should be as long as width * height * 4. Each quad is red,green,blue,alpha -} deriving (Eq, Show, Generic, NFData) {- |Opcode: 0900-}
src/Eventloop/Module/Websocket/Keyboard/Types.hs view
@@ -4,5 +4,11 @@ import GHC.Generics (Generic) import Control.DeepSeq +{-| Almost all key presses are registered including modifier keys. + Expect character keys to come in as their character. Press a c, get + a "c". If a modifier is used and a different character is expected, + it will be that instead. Press shift + c, get a "C". Modifiers are also + sent as their string representation: "shift", "ctrl" or "alt". Space is + expected as "space". -} data Keyboard = Key [Char] deriving (Eq, Show, Generic, NFData)
src/Eventloop/Utility/Vectors.hs view
@@ -72,7 +72,7 @@ = average where total = foldl (|+|) originPoint points - average = total |\ (toInteger (length points)) + average = total |/ (toInteger (length points)) -- | Returns the vector perpendicular on the given vector between the 2 points. Always has positive y and vector length 1; y is inverted in canvas @@ -110,14 +110,14 @@ class (Coord a) => Vector2D a where (|+|) :: a -> a -> a (|-|) :: a -> a -> a - (|\) :: (Real b) => a -> b -> a + (|/) :: (Real b) => a -> b -> a (|*) :: (Real b) => a -> b -> a negateVector :: a -> a instance Vector2D PolarCoord where pc1 |+| pc2 = toPolarCoord $ (toPoint pc1) |+| (toPoint pc2) pc1 |-| pc2 = toPolarCoord $ (toPoint pc1) |-| (toPoint pc2) - (PolarCoord (l, a)) |\ scalar + (PolarCoord (l, a)) |/ scalar = PolarCoord (fromRational (l' / scalar'), a) where l' = toRational l @@ -136,7 +136,7 @@ (Point (x1, y1)) |-| (Point (x2, y2)) = Point (x1 - x2, y1 - y2) - (Point (x1, y1)) |\ scalar + (Point (x1, y1)) |/ scalar = Point (fromRational x', fromRational y') where x' = toRational x1 / toRational scalar