eventloop 0.6.0.0 → 0.7.0.0
raw patch · 28 files changed
+945/−387 lines, 28 filesdep +deepseq
Dependencies added: deepseq
Files
- eventloop.cabal +5/−4
- src/Eventloop/Module/BasicShapes/BasicShapes.hs +11/−1
- src/Eventloop/Module/BasicShapes/Classes.hs +363/−200
- src/Eventloop/Module/BasicShapes/MeasureTextHack.hs +24/−0
- src/Eventloop/Module/BasicShapes/Types.hs +59/−41
- src/Eventloop/Module/DrawTrees/Types.hs +6/−2
- src/Eventloop/Module/File/Types.hs +7/−1
- src/Eventloop/Module/Graphs/Graphs.hs +10/−16
- src/Eventloop/Module/Graphs/Types.hs +10/−6
- src/Eventloop/Module/StatefulGraphics.hs +1/−1
- src/Eventloop/Module/StatefulGraphics/StatefulGraphics.hs +188/−18
- src/Eventloop/Module/StatefulGraphics/Types.hs +45/−8
- src/Eventloop/Module/StdIn/Types.hs +5/−1
- src/Eventloop/Module/StdOut/StdOut.hs +1/−4
- src/Eventloop/Module/StdOut/Types.hs +5/−1
- src/Eventloop/Module/Timer/Types.hs +6/−2
- src/Eventloop/Module/Websocket/Canvas/Canvas.hs +21/−13
- src/Eventloop/Module/Websocket/Canvas/JSONEncoding.hs +9/−14
- src/Eventloop/Module/Websocket/Canvas/Opcode.hs +3/−4
- src/Eventloop/Module/Websocket/Canvas/Types.hs +29/−27
- src/Eventloop/Module/Websocket/Keyboard/Types.hs +5/−1
- src/Eventloop/Module/Websocket/Mouse/Types.hs +5/−1
- src/Eventloop/System/EventloopThread.hs +2/−0
- src/Eventloop/System/InitializationThread.hs +3/−2
- src/Eventloop/Types/Events.hs +5/−1
- src/Eventloop/Utility/Trees/GeneralTree.hs +8/−4
- src/Eventloop/Utility/Trees/LayoutTree.hs +3/−3
- src/Eventloop/Utility/Vectors.hs +106/−11
eventloop.cabal view
@@ -6,7 +6,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.6.0.0 +version: 0.7.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), @@ -68,6 +68,7 @@ Eventloop.Module.BasicShapes.BasicShapes, Eventloop.Module.BasicShapes.Types, Eventloop.Module.BasicShapes.Classes, + Eventloop.Module.BasicShapes.MeasureTextHack, Eventloop.Module.File.File, Eventloop.Module.File.Types, Eventloop.Module.StatefulGraphics.StatefulGraphics, @@ -108,11 +109,11 @@ aeson >=0.8 && <0.9, bytestring >=0.10 && <0.11, concurrent-utilities >=0.2 && <0.3, - stm >=2.4 && <2.5 + stm >=2.4 && <2.5, + deepseq >=1.4 && <1.5 -- Directories containing source files. hs-source-dirs: src -- Base language which the package is written in. - default-language: Haskell2010 - + default-language: Haskell2010
src/Eventloop/Module/BasicShapes/BasicShapes.hs view
@@ -4,8 +4,11 @@ , basicShapesPostProcessor ) where +import Control.Concurrent.SafePrint + import Eventloop.Module.BasicShapes.Types import Eventloop.Module.BasicShapes.Classes +import Eventloop.Module.BasicShapes.MeasureTextHack import Eventloop.Types.Common import Eventloop.Types.Events import Eventloop.Types.System @@ -13,7 +16,7 @@ setupBasicShapesModuleConfiguration :: EventloopSetupModuleConfiguration setupBasicShapesModuleConfiguration = ( EventloopSetupModuleConfiguration basicShapesModuleIdentifier - Nothing + (Just basicShapesInitializer) Nothing Nothing (Just basicShapesPostProcessor) @@ -24,6 +27,13 @@ basicShapesModuleIdentifier :: EventloopModuleIdentifier basicShapesModuleIdentifier = "basicshapes" + + +basicShapesInitializer :: Initializer +basicShapesInitializer sharedConst sharedIO + = do + saveMeasureText (measureText sharedConst) + return (sharedConst, sharedIO, NoConstants, NoState) basicShapesPostProcessor :: PostProcessor
src/Eventloop/Module/BasicShapes/Classes.hs view
@@ -1,34 +1,83 @@ module Eventloop.Module.BasicShapes.Classes where +import Control.Concurrent.MVar +import Data.Maybe + import Eventloop.Utility.Vectors import Eventloop.Module.BasicShapes.Types +import Eventloop.Module.BasicShapes.MeasureTextHack import qualified Eventloop.Module.Websocket.Canvas.Types as CT + import Debug.Trace -addBoundingBox :: BoundingBox -> BoundingBox -> BoundingBox -addBoundingBox (BoundingBox p11 p21 p31 p41) (BoundingBox p12 p22 p32 p42) = BoundingBox (Point (xMin, yMin)) (Point (xMin, yMax)) (Point (xMax, yMax)) (Point (xMax, yMin)) - 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 +{- +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 + 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 + Text - Split into 4 corners of bbox + Line - Split into the two points + MultiLine - Split into the different points +-} -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 - +{- +Bugs: +- BoundingBox of circle fails. Cannot use 'rotate points on circle' method. +- Difficult rotation? (Stacked composite shapes) +-} +data GeometricPrimitive = Points [Point] + | CircleArea Point Radius + + +instance RotateLeftAround GeometricPrimitive where + rotateLeftAround p angle (Points points) + = Points $ map (rotateLeftAround p angle) points + rotateLeftAround p angle (CircleArea p' r) + = CircleArea (rotateLeftAround p angle p') r + + opOnBoundingBox :: (Point -> Point) -> BoundingBox -> BoundingBox opOnBoundingBox op (BoundingBox p1 p2 p3 p4) = BoundingBox (op p1) (op p2) (op p3) (op p4) - + +instance ExtremaCoord BoundingBox where + xMin (BoundingBox ll _ _ _) = x ll + xMax (BoundingBox _ _ ur _) = x ur + yMin (BoundingBox ll _ _ _) = y ll + yMax (BoundingBox _ _ ur _) = y ur + + +instance ExtremaCoord GeometricPrimitive where + xMin (Points points) = xMin points + xMin (CircleArea (Point (x, y)) r) = x - r + + xMax (Points points) = xMax points + xMax (CircleArea (Point (x, y)) r) = x + r + + yMin (Points points) = yMin points + yMin (CircleArea (Point (x, y)) r) = y - r + + yMax (Points points) = yMax points + yMax (CircleArea (Point (x, y)) r) = y + r + + +instance RotateLeftAround BoundingBox where + rotateLeftAround p angle bbox = opOnBoundingBox (rotateLeftAround p angle) bbox + + + 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] @@ -37,8 +86,23 @@ startAngle = 0 anglesDeg = filter (< 360) [startAngle, startAngle + anglePart..360] anglesRads = map degreesToRadians anglesDeg - + +boundingBoxFromPrimitives :: [GeometricPrimitive] -> BoundingBox +boundingBoxFromPrimitives primitives + = BoundingBox (Point (xMin_, yMin_)) (Point (xMin_, yMax_)) (Point (xMax_, yMax_)) (Point (xMax_, yMin_)) + where + xMin_ = minimum $ map xMin primitives + xMax_ = maximum $ map xMax primitives + yMin_ = minimum $ map yMin primitives + yMax_ = maximum $ map yMax primitives + + +normalizeBBox :: BoundingBox -> BoundingBox +normalizeBBox (BoundingBox p1 p2 p3 p4) + = boundingBoxFromPrimitives [Points [p1, p2, p3, p4]] + + roundPoint :: Point -> CT.ScreenPoint roundPoint (Point (x, y)) = (round x, round y) @@ -46,117 +110,216 @@ roundColor :: Color -> CT.ScreenColor roundColor (r, b, g, a) = (round r, round b, round g, a) -instance Translate BoundingBox where - translate pTrans = opOnBoundingBox ((|+|) pTrans) instance Translate Shape where - translate p b@(BaseShape {primitive=prim}) = b {primitive = translate p prim} - translate p (CompositeShape shapes Nothing rotM) = CompositeShape shapes (Just p) rotM - translate p2 (CompositeShape shapes (Just p1) rotM) = CompositeShape shapes (Just $ p1 |+| p2) rotM - -instance Translate Primitive where - 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 pTrans (Line p1 p2) = Line (p1 |+| pTrans) (p2 |+| pTrans) - translate pTrans (MultiLine p1 p2 ops) = MultiLine (p1 |+| pTrans) (p2 |+| pTrans) (map ((|+|) pTrans) ops) - - -instance RotateLeftAround BoundingBox where - rotateLeftAround rotatePoint aDeg box = opOnBoundingBox (rotateLeftAround rotatePoint aDeg) box - + 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 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)} -class (ToBoundingBox a) => ToCenter a where +instance Translate GeometricPrimitive where + translate p (Points points) = Points (map (|+| p) points) + translate p (CircleArea p' r) = CircleArea (p |+| p') r + + +class ToPrimitives a where + toPrimitives :: a -> [GeometricPrimitive] + +instance ToPrimitives BoundingBox where + toPrimitives (BoundingBox ll ul ur lr) = [Points [ll, ul, ur, lr]] + +instance ToPrimitives Shape where + toPrimitives (CompositeShape shapes translationM Nothing) + | isJust translationM = map (translate (fromJust translationM)) primitives + | otherwise = primitives + where + primitives = concat $ map toPrimitives shapes + toPrimitives (Rectangle {translation=(Point (x, y)), dimensions=(w, h), strokeLineThickness=thick, rotationM=Nothing}) + = [ Points [ Point (x - hthick, y - hthick) + , Point (x - hthick, y + h + hthick) + , Point (x + w + hthick, y + h + hthick) + , Point (x + w + hthick, y - hthick) + ] + ] + where + hthick = 0.5 * thick + toPrimitives (Circle {translation=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) + | a == 2 = toPrimitives (Line p1 p2 thick undefined Nothing) + | a == 1 = [Points (take 1 points)] + | a == 0 = [Points []] + where + points = allPolygonPoints a p r + (p1:p2:ops) = points + toPrimitives text@(Text {translation=(Point (x,y)), alignment=align, rotationM=Nothing}) + = [ Points $ case align of + CT.AlignLeft -> [ Point (x, y) + , Point (x, y + height) + , Point (x + width, y) + , Point (x + width, y + height) + ] + CT.AlignCenter -> [ Point (x - hwidth, y - hheight) + , Point (x - hwidth, y + hheight) + , Point (x + hwidth, y - hheight) + , Point (x + hwidth, y + hheight) + ] + CT.AlignRight -> [ Point (x, y) + , Point (x, y + height) + , Point (x - width, y) + , Point (x - width, y + height) + ] + ] + where + canvasText = toCanvasText text + (width_, height_) = useMeasureText canvasText + width = fromIntegral width_ + hwidth = width * 0.5 + height = fromIntegral height_ + hheight = height * 0.5 + + toPrimitives (Line {point1=p1, point2=p2, strokeLineThickness=thick, rotationM=Nothing}) + = [ Points [ followVector (0.5 * thick) upPerpVector p1 + , followVector (0.5 * thick) upPerpVector p2 + , followVector (0.5 * thick) downPerpVector p1 + , followVector (0.5 * thick) downPerpVector p2 + ] + ] + where + upPerpVector = upPerpendicular p1 p2 + downPerpVector = negateVector upPerpVector + toPrimitives (MultiLine {point1=p1, point2=p2, otherPoints=ops, strokeLineThickness=thick, rotationM=Nothing}) + = concat $ map toPrimitives lines + where + allPoints = p1:p2:ops + tailPoints = p2:ops + linePoints = zip allPoints tailPoints + lines = map (\(p, p') -> Line p p' thick undefined Nothing) linePoints + toPrimitives shape + = map (rotateLeftAround rotatePoint angle) (toPrimitives shapePreRotate) + where + shapePreRotate = shape{rotationM=Nothing} + (Just rotation@(Rotation _ angle)) = rotationM shape + rotatePoint = findRotationPoint shapePreRotate rotation + + +class ToCenter a where toCenter :: a -> Point -instance ToCenter Primitive where - toCenter = toCenter.toBoundingBox - +instance ToCenter BoundingBox where + toCenter bbox + = Point (minX + 0.5 * (maxX - minX), minY + 0.5 * (maxY - minY)) + where + minX = xMin bbox + maxX = xMax bbox + minY = yMin bbox + maxY = yMax bbox + instance ToCenter Shape where - toCenter = toCenter.toBoundingBox + toCenter c@(CompositeShape {translationM=(Just p), rotationM=Nothing}) + = p |+| center + where + center = toCenter c{translationM=Nothing} + toCenter c@(CompositeShape {shapes=shapes, translationM=Nothing, rotationM=Nothing}) + = averagePoint centers + where + centers = map toCenter shapes + toCenter r@(Rectangle {dimensions=(width, height), translation=p, rotationM=Nothing}) + = p |+| (Point (0.5 * width, 0.5 * height)) + toCenter c@(Circle {translation=p, rotationM=Nothing}) + = p + toCenter po@(Polygon {translation=p, rotationM=Nothing}) + = p + toCenter t@(Text {rotationM=Nothing}) + = (toCenter.toBoundingBox) t + toCenter l@(Line {}) + = (toCenter.toBoundingBox) l + toCenter ml@(MultiLine {}) + = (toCenter.toBoundingBox) ml + toCenter shape + = rotateLeftAround rotationPoint angle center + where + (Just rotation) = rotationM shape + shapePreRotate = shape{rotationM=Nothing} + center = toCenter shapePreRotate + rotationPoint = findRotationPoint shapePreRotate rotation + (Rotation _ angle) = rotation -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 = x4 - x1 - h = y2 - y1 - - -class ToBoundingBox a where + +class (ToPrimitives a) => 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, y + h)) (Point (x + w, y + h)) (Point (x + w, y)) - toBoundingBox (Circle p r f) = trace ((++) "Circle P:" $ show (p |-| (Point (r, r)))) toBoundingBox (Rectangle (p |-| (Point (r, r))) (2 * r, 2 * r) f) - toBoundingBox (Polygon _ p r f) = toBoundingBox (Circle p r f) - toBoundingBox (Text _ _ _ p _) = BoundingBox p p p p - toBoundingBox (Line p1 p2) = toBoundingBox (MultiLine p1 p2 []) - toBoundingBox (MultiLine p1 p2 ops) = BoundingBox (Point (xMin, yMin)) (Point (xMin, yMax)) (Point (xMax, yMax)) (Point (xMax, yMin)) - 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 = translate translation baseBox - rotationPoint = findRotationPoint translatedBox rotation - (Rotation _ angle) = rotation - toBoundingBox (CompositeShape shapes (Just translation) Nothing) = translate 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 + toBoundingBox a + = boundingBoxFromPrimitives $ toPrimitives a -{- -Er is een probleem met waar de rotationpoint staat. -De boundingbox van CompositeShapes ziet er vreemd uit. -Het probleem kan zijn omdat er ergens nog de oude manier van boundingboxes staat, maar waar? -Als de boundingbox weer correct is, wordt het rotationpoint ook weer correct. -Daarnaast moet er nog even nagedacht worden over de translatie en rotatiepunt van op elkaar gestapelde -composite shapes. Wordt de boundingbox lokaal uitgerekend? Wordt het rotatiepunt lokaal uitgerekent? -Meerdere translaties op elkaar in canvas, kan dat of is de translatie steeds vanuit het oude origin? +class (ToBoundingBox a) => Overlaps a where + {- + The boundingbox of a1 partially overlaps the boundingbox of a2. Ofcourse if overlaps(a1, a2) then + overlaps(a2, a1). However, if contains(a1, a2) or contains(a2, a1), then overlaps(a1, a2) == false + -} + overlaps :: (Overlaps b) => a -> b -> Bool + overlaps a1 a2 + | contains a1 a2 || contains a2 a1 = False + | xMax b1 < xMin b2 = False -- b1 is left of b2 + | xMin b1 > xMax b2 = False -- b2 is right of b2 + | yMax b1 < yMin b2 = False -- b1 is lower than b2 + | yMin b1 > yMax b2 = False -- b1 is higher than b2 + | otherwise = True + where + b1 = toBoundingBox a1 + b2 = toBoundingBox a2 -Fix 1: De boundingboxes van shapes in compositeshape samen voegen zonder de translatie van die compositeshape. -Daarmee krijg je de locale boundingbox met de correcte center punt. + {- + The boundingbox of a1 contains the boundingbox of a2. If boundingbox(a2) > boundingbox(a1) + then a1 can never contain a2. If boundingbox(a2) == boundingbox(a1) and contains(a1, a2) + then also contains(a2, a1). + -} + contains :: (Overlaps b) => a -> b -> Bool + contains a1 a2 + | xMax b2 <= xMax b1 && + xMin b2 >= xMin b1 && + yMax b2 <= yMax b1 && + yMin b2 >= yMin b1 = True + | otherwise = False + where + b1 = toBoundingBox a1 + b2 = toBoundingBox a2 -Waarom ik een boundingbox met de verkeerde punten op de verkeerde plekken krijg, blijft een raadsel. -Even kijken of foldBoundingBoxes goed werkt of niet + touches :: (Overlaps b) => a -> b -> Bool + touches a1 a2 = overlaps a1 a2 || contains a1 a2 || contains a2 a1 --} +instance Overlaps Shape +instance Overlaps BoundingBox + + findRotationPoint :: (ToCenter a) => a -> Rotation -> Point findRotationPoint a (Rotation AroundCenter _) = toCenter a findRotationPoint _ (Rotation (AroundPoint p) _) = p - - + class ToCanvasOut a where toCanvasOut :: a -> CT.CanvasOut instance ToCanvasOut BasicShapesOut where - toCanvasOut (DrawShapes canvasId shapes) = CT.CanvasOperations canvasId canvasOperations + toCanvasOut (DrawShapes canvasId shapes) = CT.CanvasOperations canvasId (canvasOperations ++ [CT.Frame]) where canvasOperations = (concat.(map toCanvasOperations)) shapes @@ -164,79 +327,16 @@ class ToCanvasOperations a where toCanvasOperations :: a -> [CT.CanvasOperation] -instance ToCanvasOperations Shape where - toCanvasOperations (BaseShape prim lineThick color (Just rotation)) - | angle == 0 = toCanvasOperations (BaseShape prim lineThick color Nothing) - | otherwise = [ CT.DoTransform CT.Save - , CT.DoTransform (CT.Translate screenRotationPoint) - , CT.DoTransform (CT.Rotate screenAngle) - ] ++ movedDrawOperations ++ - [ CT.DoTransform CT.Restore - ] - where - rotationPoint = findRotationPoint prim rotation - screenRotationPoint = roundPoint rotationPoint - movedPrim = translate (negateVector rotationPoint) prim - movedDrawOperations = toCanvasOperations (BaseShape movedPrim lineThick 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)) - - toCanvasOperations (BaseShape (Text text fontF fontS p fillColor) lineThick strokeColor Nothing) = [CT.DrawText canvasText p' textStroke textFill] - where - canvasText = CT.CanvasText text (CT.Font fontF $ round fontS) CT.AlignCenter - textFill = CT.TextFill (CT.CanvasColor screenFillColor) - textStroke = CT.TextStroke (round lineThick) (CT.CanvasColor screenStrokeColor) - screenStrokeColor = roundColor strokeColor - screenFillColor = roundColor fillColor - p' = roundPoint p - toCanvasOperations (BaseShape prim lineThick strokeColor Nothing) = case fillColorM of - (Just fillColor') -> [CT.DrawPath startingPoint screenPathParts pathStroke pathFill] - where - screenFillColor = roundColor fillColor' - pathFill = CT.PathFill (CT.CanvasColor screenFillColor) - Nothing -> [CT.DrawPath startingPoint screenPathParts pathStroke CT.NoPathFill] - where - (screenPathParts, startingPoint, fillColorM) = toScreenPathParts prim - pathStroke = CT.PathStroke (round lineThick) (CT.CanvasColor screenStrokeColor) - screenStrokeColor = roundColor strokeColor +toCanvasText :: Shape -> CT.CanvasText +toCanvasText (Text {text=text, fontFamily=family_, fontSize=size, alignment=align}) + = CT.CanvasText text (CT.Font family_ $ round size) align - toCanvasOperations (CompositeShape shapes Nothing Nothing) = (concat.(map toCanvasOperations)) shapes - toCanvasOperations c@(CompositeShape shapes (Just translation) (Just rotation)) - | angle == 0 = toCanvasOperations (CompositeShape shapes (Just translation) Nothing) - | otherwise = trace (show $ rotationPoint) $ trace (show $ toBoundingBox c) $ trace (show movedDrawOperations) [ CT.DoTransform CT.Save - , CT.DoTransform (CT.Translate screenTotalTranslation) - , CT.DoTransform (CT.Rotate screenAngle) - ] ++ movedDrawOperations ++ - [ CT.DoTransform CT.Restore - ] - where - rotationPoint = findRotationPoint c rotation - movedShapes = map (translate (negateVector rotationPoint)) shapes - movedDrawOperations = toCanvasOperations (CompositeShape movedShapes Nothing Nothing) - (Rotation _ angle) = rotation - screenAngle = round angle - screenTotalTranslation = roundPoint (translation |+| rotationPoint) - - toCanvasOperations c@(CompositeShape shapes Nothing (Just rotation)) - | angle == 0 = toCanvasOperations (CompositeShape shapes Nothing Nothing) - | otherwise = [ CT.DoTransform CT.Save - , CT.DoTransform (CT.Translate screenRotationPoint) - , CT.DoTransform (CT.Rotate screenAngle) - ] ++ movedDrawOperations ++ - [ CT.DoTransform CT.Restore - ] - where - rotationPoint = findRotationPoint c rotation - movedShapes = map (translate (negateVector rotationPoint)) shapes - movedDrawOperations = toCanvasOperations (CompositeShape movedShapes Nothing Nothing) - (Rotation _ angle) = rotation - screenAngle = round angle - screenRotationPoint = roundPoint rotationPoint - +instance ToCanvasOperations Shape where + toCanvasOperations (CompositeShape shapes Nothing Nothing) + = (concat.(map toCanvasOperations)) shapes + toCanvasOperations (CompositeShape shapes (Just translate) Nothing) = [ CT.DoTransform CT.Save , CT.DoTransform (CT.Translate screenTranslationPoint) @@ -246,37 +346,100 @@ where screenTranslationPoint = roundPoint translate drawOperations = toCanvasOperations (CompositeShape shapes Nothing Nothing) - + + toCanvasOperations text@(Text { translation=p + , fillColor=fill + , strokeLineThickness=thick + , strokeColor=stroke + , rotationM=Nothing + }) + = [CT.DrawText canvasText p' textStroke textFill] + where + canvasText = toCanvasText text + textFill = CT.TextFill (CT.CanvasColor screenFillColor) + textStroke = CT.TextStroke (round thick) (CT.CanvasColor screenStrokeColor) + screenStrokeColor = roundColor stroke + screenFillColor = roundColor fill + p' = roundPoint p + + toCanvasOperations shape + -- Might be any rotated shape + | isJust (rotationM shape) = [ CT.DoTransform CT.Save + , CT.DoTransform (CT.Translate screenRotationPoint) + , CT.DoTransform (CT.Rotate screenAngle) + ] + ++ (toCanvasOperations movedShape) ++ + [ CT.DoTransform CT.Restore + ] + -- Can only be Rectangle, Circle, Polygon, Line or MultiLine + | otherwise = [CT.DrawPath startingPoint screenPathParts pathStroke canvasPathFill] + where + (Just rotation) = rotationM shape + shapePreRotate = shape{rotationM = Nothing} + rotationPoint = findRotationPoint shapePreRotate rotation + screenRotationPoint = roundPoint rotationPoint + (Rotation _ angle) = rotation + screenAngle = round angle + movedShape = translate (negateVector rotationPoint) shapePreRotate + + canvasPathFill = toCanvasPathFill shape + (screenPathParts, startingPoint) = toScreenPathParts shape + 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, Maybe FillColor) + toScreenPathParts :: a -> ([CT.ScreenPathPart], CT.ScreenStartingPoint) -instance ToScreenPathPart Primitive where - toScreenPathParts (Rectangle p (w, h) f) = ([CT.Rectangle p' (w', h')], p', Just f) - where - p' = roundPoint p - w' = round w - h' = round h - toScreenPathParts (Circle p r f) = ([CT.Arc (p', r') 0 360], p', Just f) - where - p' = roundPoint p - r' = round r - toScreenPathParts (Polygon n p r f) = (lines, screenPoint, Just f) - 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', Nothing) - where - p1' = roundPoint p1 - p2' = roundPoint p2 +instance ToScreenPathPart Shape where + toScreenPathParts (Rectangle {translation=p, dimensions=(w, h)}) + = ([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') + where + p' = roundPoint p + r' = round r + toScreenPathParts (Polygon {translation=p, amountOfPoints=n, radius=r}) + = (lines, screenPoint) + where + polygonPoints = allPolygonPoints 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') + where + p1' = roundPoint p1 + p2' = roundPoint p2 - toScreenPathParts (MultiLine p1 p2 otherPoints) = (lines ++ [CT.MoveTo p1'], p1', Nothing) - where - allPoints = p1:p2:otherPoints - (p1':otherPoints') = map roundPoint allPoints - lines = [CT.LineTo p' | p' <- otherPoints'] - - + toScreenPathParts (MultiLine {point1=p1, point2=p2, otherPoints=otherPoints_}) + = (lines ++ [CT.MoveTo p1'], p1') + where + allPoints = p1:p2:otherPoints_ + (p1':otherPoints') = map roundPoint allPoints + lines = [CT.LineTo p' | p' <- otherPoints'] + + +toCanvasPathFill :: Shape -> CT.PathFill +toCanvasPathFill shape + | hasCanvasPathFill shape = CT.PathFill (CT.CanvasColor screenFillColor) + | otherwise = CT.NoPathFill + where + fillColor_ = fillColor shape + screenFillColor = roundColor fillColor_ + + +hasCanvasPathFill :: Shape -> Bool +hasCanvasPathFill (Rectangle {}) + = True +hasCanvasPathFill (Circle {}) + = True +hasCanvasPathFill (Polygon {}) + = True +hasCanvasPathFill _ + = False
+ src/Eventloop/Module/BasicShapes/MeasureTextHack.hs view
@@ -0,0 +1,24 @@+module Eventloop.Module.BasicShapes.MeasureTextHack where++import Data.IORef+import System.IO.Unsafe++import Eventloop.Module.Websocket.Canvas.Types+++measureTextRef :: (IORef (CanvasText -> IO ScreenDimensions))+{-# NOINLINE measureTextRef #-}+measureTextRef = unsafePerformIO (newIORef undefined)+++saveMeasureText :: (CanvasText -> IO ScreenDimensions) ->+ IO ()+saveMeasureText f+ = writeIORef measureTextRef f+++useMeasureText :: CanvasText -> ScreenDimensions+useMeasureText text+ = unsafePerformIO $ do+ measureText <- readIORef measureTextRef+ measureText text
src/Eventloop/Module/BasicShapes/Types.hs view
@@ -1,11 +1,17 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Eventloop.Module.BasicShapes.Types ( module Eventloop.Module.BasicShapes.Types - , CT.CanvasId + , CanvasId + , Alignment(..) ) where -import qualified Eventloop.Module.Websocket.Canvas.Types as CT +import Eventloop.Module.Websocket.Canvas.Types (CanvasId, Alignment(..)) import Eventloop.Utility.Vectors +import GHC.Generics (Generic) +import Control.DeepSeq + + type GraphicalNumeric = Float type Translation = Point @@ -36,55 +42,67 @@ type FontSize = GraphicalNumeric -data BasicShapesOut = DrawShapes CT.CanvasId [Shape] - deriving (Show, Eq) +data BasicShapesOut = DrawShapes CanvasId [Shape] + deriving (Show, Eq, Generic, NFData) -data Shape = BaseShape { primitive :: Primitive +data Shape = CompositeShape { shapes :: [Shape] + , translationM :: Maybe Translation + , rotationM :: Maybe Rotation + } -- ^Should contain atleast 1 shape. Rotation before Translation + | Rectangle { translation :: Translation + , dimensions :: Dimensions + , fillColor :: FillColor , strokeLineThickness :: StrokeLineThickness , strokeColor :: StrokeColor - , rotationM :: (Maybe Rotation) + , 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 + , radius :: Radius + , fillColor :: FillColor + , strokeLineThickness :: StrokeLineThickness + , strokeColor :: StrokeColor + , rotationM :: Maybe Rotation + } -- ^| Translation is center + | Polygon { translation :: Translation + , amountOfPoints :: AmountOfPoints + , 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 + | Text { text :: [Char] + , fontFamily :: FontFamily + , fontSize :: FontSize + , translation :: Translation + , alignment :: Alignment + , fillColor :: FillColor + , strokeLineThickness :: StrokeLineThickness + , strokeColor :: StrokeColor + , rotationM :: Maybe Rotation + } -- ^Translation is horizontally the center and vertically the top of the text, does not have a boundingbox due to technical limitations + | Line { point1 :: Point + , point2 :: Point + , strokeLineThickness :: StrokeLineThickness + , strokeColor :: StrokeColor + , rotationM :: Maybe Rotation + } + | MultiLine { point1 :: Point + , point2 :: Point + , otherPoints :: [Point] + , strokeLineThickness :: StrokeLineThickness + , strokeColor :: StrokeColor + , rotationM :: Maybe Rotation } - | CompositeShape { shapes :: [Shape] - , translationM :: (Maybe Translation) - , rotationM :: (Maybe Rotation) - } -- ^Should contain atleast 1 shape - deriving (Show, Eq) - -data Primitive = Rectangle { translation :: Translation -- ^| Translation is the corner closes to origin. Visually in canvas, this is top left. In a Cartesian coördinate system, this is bottom left. - , dimensions :: Dimensions - , fillColor :: FillColor - } -- ^Translation is upperleftcorner - | Circle { translation :: Translation -- ^| Translation is the centre of the circle - , radius :: Radius - , fillColor :: FillColor - } -- ^Translation is center - | Polygon { amountOfPoints :: AmountOfPoints - , translation :: Translation -- ^| Translation is the the centre of the polygon - , radius :: Radius - , fillColor :: FillColor - } -- ^The first point of the polygon, always starts in the direction from the x-axis.(Towards x-infinity) - | Text { text :: [Char] - , fontFamily :: FontFamily - , fontSize :: FontSize - , translation :: Translation - , fillColor :: FillColor - } -- ^Translation is horizontally the center and vertically the top of the text, does not have a boundingbox due to technical limitations - | Line { point1 :: Point - , point2 :: Point - } - | MultiLine { point1 :: Point - , point2 :: Point - , otherPoints :: [Point] - } - deriving (Show, Eq) + deriving (Show, Eq, Generic, NFData) data Rotation = Rotation RotatePoint Angle -- ^| Rotation is around a point on the canvas. May be the centre of the boundingbox (enclosing rectangle) or an arbitrary point. Angle is in degrees and counter-clockwise in the coördinate system(from the x-axis to the y-axis) and visually on canvas clock-wise. - deriving (Show, Eq) + deriving (Show, Eq, Generic, NFData) data RotatePoint = AroundCenter | AroundPoint Point - deriving (Show, Eq) + deriving (Show, Eq, Generic, NFData) data BoundingBox = BoundingBox LowerLeft UpperLeft UpperRight LowerRight -- ^| The point indications are from the perspective of a regular Cartesian coördinate system. deriving (Show, Eq)
src/Eventloop/Module/DrawTrees/Types.hs view
@@ -1,17 +1,21 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Eventloop.Module.DrawTrees.Types where import Eventloop.Module.Websocket.Canvas.Types import Eventloop.Utility.Trees.GeneralTree +import GHC.Generics (Generic) +import Control.DeepSeq + data DrawTreesOut = DrawTrees CanvasId [GeneralTree] - deriving (Show, Eq) + deriving (Show, Eq, Generic, NFData) data NodeColor = NodeRed | NodeBlack | NodeGrey - deriving (Show, Eq) + deriving (Show, Eq, Generic, NFData) data RBTree = RBNode NodeColor String [RBTree] deriving (Show, Eq)
src/Eventloop/Module/File/Types.hs view
@@ -1,6 +1,9 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, StandaloneDeriving #-} module Eventloop.Module.File.Types where import System.IO +import GHC.Generics (Generic) +import Control.DeepSeq type OpenFile = (FilePath, Handle, IOMode) @@ -20,4 +23,7 @@ | RetrieveChar FilePath | IfEOF FilePath | WriteTo FilePath [Char] - deriving (Eq, Show)+ deriving (Eq, Show, Generic, NFData) + +deriving instance Generic IOMode +deriving instance NFData IOMode
src/Eventloop/Module/Graphs/Graphs.hs view
@@ -101,9 +101,8 @@ startPLine = Point (0, 0) endPLine = Point (canvasGraphsWidth, 0) lineHeight = 2 - lineShape = BS.BaseShape (BS.Line startPLine endPLine) lineHeight (0,0,0,255) Nothing - textShape = (\line p -> BS.BaseShape (textPrim line p) 0 (0,0,0,0) Nothing) - textPrim = (\line p -> BS.Text line textFont textSize p (0,0,0,255)) + lineShape = BS.Line startPLine endPLine lineHeight (0,0,0,255) Nothing + textShape = (\line p -> BS.Text line textFont textSize p BS.AlignCenter (0,0,0,255) 0 (0,0,0,0) Nothing) textMargin = 2 heights = iterate ((+) (textSize + textMargin)) lineHeight isAndHeights = zip is heights @@ -153,32 +152,27 @@ nodeToShapes :: Node -> [BS.Shape] nodeToShapes (l, p, col) - = [BS.BaseShape nodePrim 2 (0,0,0,255) Nothing, BS.BaseShape textPrim 3 (0,0,0,255) Nothing] + = [ BS.Circle (Point p) nodeRadius color 2 (0,0,0,255) Nothing + , BS.Text lStr textFont textSize (Point p) BS.AlignCenter (0,0,0,255) 3 (0,0,0,255) Nothing + ] where color = colorToRGBAColor col lStr = [l] - nodePrim = BS.Circle (Point p) nodeRadius color - textPrim = BS.Text lStr textFont textSize (Point p) (0,0,0,255) edgeToShapes :: Node -> Node -> Edge -> Directed -> Weighted -> [BS.Shape] edgeToShapes (_, p1, _) (_, p2, _) (_, _, col, w, thick) directed weighted = lineShape:(weightShapes ++ directShapes) where - directShapes | directed == Directed = [arrowShape arrow1Prim, arrowShape arrow2Prim] + directShapes | directed == Directed = [ BS.Line (Point arrowStart) (Point arrow1End) thickness color Nothing + , BS.Line (Point arrowStart) (Point arrow2End) thickness color Nothing + ] | directed == Undirected = [] - where - arrow1Prim = BS.Line (Point arrowStart) (Point arrow1End) - arrow2Prim = BS.Line (Point arrowStart) (Point arrow2End) - arrowShape prim = BS.BaseShape prim thickness color Nothing - weightShapes | weighted == Weighted = [BS.BaseShape weightPrim 0 (0,0,0,0) Nothing] + weightShapes | weighted == Weighted = [BS.Text wStr textFont textSize (Point textPos) BS.AlignCenter (0,0,0,255) 0 (0,0,0,0) Nothing] | weighted == Unweighted = [] where wStr = show w - weightPrim = BS.Text wStr textFont textSize (Point textPos) (0,0,0,255) - lineShape = BS.BaseShape linePrim thickness color Nothing - where - linePrim = BS.Line (Point lineStart) (Point lineEnd) + lineShape = BS.Line (Point lineStart) (Point lineEnd) thickness color Nothing thickness = thicknessToFloat thick color = colorToRGBAColor col -- Margin line vector stuff
src/Eventloop/Module/Graphs/Types.hs view
@@ -1,9 +1,13 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Eventloop.Module.Graphs.Types ( module Eventloop.Module.Graphs.Types , M.MouseEvent(..) , M.MouseButton(..) ) where +import GHC.Generics (Generic) +import Control.DeepSeq + import qualified Eventloop.Module.Websocket.Mouse.Types as M type Pos = (Float, Float) @@ -17,7 +21,7 @@ data GraphsOut = SetupGraphs | DrawGraph Graph | Instructions [String] - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) ----- Graph ----- type Label = Char @@ -31,7 +35,7 @@ , edges :: [Edge] , directed :: Directed , weighted :: Weighted - } deriving (Eq, Show) + } deriving (Eq, Show, Generic, NFData) ----- Graph Graphical ----- data Color = Red @@ -43,16 +47,16 @@ | Orange | Black | White - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) data Thickness = Thin | Thick - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) data Directed = Directed | Undirected - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) data Weighted = Weighted | Unweighted - deriving (Eq, Show)+ deriving (Eq, Show, Generic, NFData)
src/Eventloop/Module/StatefulGraphics.hs view
@@ -3,5 +3,5 @@ , module Eventloop.Module.StatefulGraphics.Types ) where -import Eventloop.Module.StatefulGraphics.StatefulGraphics+import Eventloop.Module.StatefulGraphics.StatefulGraphics hiding(GraphicPerformed(..)) import Eventloop.Module.StatefulGraphics.Types
src/Eventloop/Module/StatefulGraphics/StatefulGraphics.hs view
@@ -9,13 +9,16 @@ import Data.Maybe import Eventloop.Module.StatefulGraphics.Types- import Eventloop.Module.Websocket.Canvas import Eventloop.Module.BasicShapes import Eventloop.Types.Common import Eventloop.Types.Events import Eventloop.Types.System+import Eventloop.Utility.Vectors +import Debug.Trace++ setupStatefulGraphicsModuleConfiguration :: EventloopSetupModuleConfiguration setupStatefulGraphicsModuleConfiguration = ( EventloopSetupModuleConfiguration statefulGraphicsModuleIdentifier@@ -56,6 +59,18 @@ = return [out] +++getId :: StatefulBB -> NamedId+getId (StatefulBB (Stateful id _ _) _) = id++getZ :: StatefulBB -> ZIndex+getZ (StatefulBB (Stateful _ z _) _) = z++getShape :: StatefulBB -> Shape+getShape (StatefulBB (Stateful _ _ shape) _) = shape++ replaceGraphicalState :: GraphicsStates -> CanvasId -> GraphicsState -> GraphicsStates replaceGraphicalState [] id state = [(id, state)] replaceGraphicalState ((id, state):states) canvasId newState@@ -72,45 +87,200 @@ calculateNewScene :: CanvasId -> GraphicsState -> [StatefulGraphicsOut] -> (GraphicsState, [Out]) calculateNewScene canvasId state outs- = (state', [clearCanvas, OutBasicShapes $ DrawShapes canvasId basicShapes])+ = (state', [ OutCanvas $ CanvasOperations canvasId (map Clear removes)+ , OutBasicShapes $ DrawShapes canvasId basicShapes+ ]+ ) where (state', performed) = foldl foldPerform (state, []) outs foldPerform (state_, performed_) statefulOut = (state_', performed_ ++ [performed_']) where (state_', performed_') = performStatefulGraphicsOut state_ statefulOut+ (toRedraw, toRemove) = calculateRedraws state' performed+ toRedrawIds = statefulIds toRedraw+ toRemoveIds = trace ("To Redraw: " ++ (show toRedrawIds)) statefulIds toRemove+ basicShapes = trace ("To Remove: " ++ (show toRemoveIds)) (map getShape toRedraw)+ removes = map calculateRemove toRemove - clearCanvas = OutCanvas $ CanvasOperations canvasId [Clear ClearCanvas]- basicShapes = map snd state'+{-+Uses yMin as canvas treats rectangle from their lower left corner+-}+calculateRemove :: StatefulBB+ -> ClearPart+calculateRemove (StatefulBB _ bb)+ = ClearRectangle (round $ xMin bb, round $ yMin bb) (round width, round height)+ where+ height = (yMax bb) - (yMin bb)+ width = (xMax bb) - (xMin bb) +calculateRedraws :: GraphicsState+ -> [GraphicPerformed]+ -> (GraphicsState, GraphicsState) -- Redraw and Remove state+calculateRedraws _ [] = ([], [])+calculateRedraws state ((Drawn sbb):performed)+ = (toRedraw', toRemove)+ where+ id = getId sbb+ (toRedraw, toRemove) = calculateRedraws state performed+ (_, toRedraw') = calculateRedrawsForDrawn (state, toRedraw) sbb++calculateRedraws state ((Removed sg):performed)+ = (toRedraw', toRemove')+ where+ (toRedraw, toRemove) = calculateRedraws state performed+ (_, toRedraw', toRemove') = calculateRedrawsForRemoved (state, toRedraw, toRemove) sg++calculateRedraws state ((Modified sg):performed)+ -- | noDimChange oldGraphic newGraphic = calculateDraws toCheck toRedraw (Drawn sg) TODO Modified -> Drawn optimalization+ = calculateRedraws state ((Removed sg):(Drawn sg):performed)++calculateRedraws state (NoOp:performed)+ = calculateRedraws state performed+++{-+Only redraw when a graphic if the drawn graphic overlaps or if a graphic is above and contained by the drawn+graphic. Also add the drawn graphic to redraw.+However, if there is one graphic to be found that completely contains the drawn graphic, nothing has to happen.+Also, all graphics completely behind the drawn graphic, will not be redrawn.+-}+calculateRedrawsForDrawn :: (GraphicsState, GraphicsState) -- Current check and redraw state+ -> StatefulBB+ -> (GraphicsState, GraphicsState)+calculateRedrawsForDrawn (toCheck, toRedraw) new+ = foldl calculateRedrawsForDrawn (toCheck', toRedraw') checkNow+ where+ id = getId new+ z = getZ new+ (below, _, above) = splitOn (\sbb -> getId sbb == id) toCheck -- Find which graphics are above and below toProcess++ aboveOverlapped = filter (overlaps new) above+ aboveContained = filter (contains new) above+ aboveContainedBy = filter (\sg -> contains sg new) above+ aboveNotTouching = filter (not.(touches new)) above++ toCheck' = fst $ removeGraphic toCheck id+ toRedraw' = fst $ addOrReplaceGraphic toRedraw new++ checkNow = aboveOverlapped ++ aboveContained ++ aboveContainedBy+++calculateRedrawsForRemoved :: (GraphicsState, GraphicsState, GraphicsState) -- Current check and redraw state+ -> StatefulBB+ -> (GraphicsState, GraphicsState, GraphicsState)+calculateRedrawsForRemoved (toCheck, toRedraw, toRemove) old+ = (toCheck', toRedraw', toRemove')+ where+ id = getId old+ z = getZ old++ (below, above) = split (\sbb -> getZ sbb > z) toCheck -- Find which graphics are above and below toProcess++ belowOverlapped = filter (overlaps old) below+ belowContained = filter (contains old) below+ belowContainedBy = filter (\sg -> contains sg old) below++ aboveOverlapped = filter (overlaps old) above+ aboveContained = filter (contains old) above+ aboveContainedBy = filter (\sg -> contains sg old) above++ toRemove' = old:toRemove++ checkNow = belowOverlapped+ ++ belowContained+ ++ belowContainedBy+ ++ aboveOverlapped+ ++ aboveContained+ ++ aboveContainedBy+ (toCheck', toRedraw') = foldl calculateRedrawsForDrawn (toCheck, toRedraw) checkNow+++statefulIds :: GraphicsState -> [NamedId]+statefulIds = map getId+++statefulId :: StatefulGraphic -> NamedId+statefulId (Stateful id _ _) = id+++split :: (a -> Bool) -> [a] -> ([a], [a])+split _ [] = ([], [])+split on (x:xs)+ | on x = ([], x:xs)+ | otherwise = (x:xs', xs'')+ where+ (xs', xs'') = split on xs+++splitOn :: (a -> Bool) -> [a] -> ([a], Maybe a, [a])+splitOn _ [] = ([], Nothing, [])+splitOn on (x:xs)+ | on x = ([], Just x, xs)+ | otherwise = (x:xs', x', xs'')+ where+ (xs', x', xs'') = splitOn on xs++ performStatefulGraphicsOut :: GraphicsState -> StatefulGraphicsOut -> (GraphicsState, GraphicPerformed) performStatefulGraphicsOut state (Draw statefulGraphic) = case oldStatefulGraphicM of- Just oldStatefulGraphic -> (state', Modified statefulGraphic)- Nothing -> (state', Drawn statefulGraphic)+ Just oldStatefulGraphic -> (state', Modified statefulBB)+ Nothing -> (state', Drawn statefulBB) where- (state', oldStatefulGraphicM) = addOrReplaceGraphics state statefulGraphic+ statefulBB = (StatefulBB statefulGraphic bb)+ (state', oldStatefulGraphicM) = addOrReplaceGraphic state statefulBB+ bb = toBoundingBox statefulGraphic+ performStatefulGraphicsOut state (Remove id) = case oldStatefulGraphicM of Just oldStatefulGraphic -> (state', Removed oldStatefulGraphic) Nothing -> (state , NoOp) where- (state', oldStatefulGraphicM) = removeGraphics state id+ (state', oldStatefulGraphicM) = removeGraphic state id -addOrReplaceGraphics :: GraphicsState -> StatefulGraphic -> (GraphicsState, (Maybe StatefulGraphic))-addOrReplaceGraphics [] new = ([new], Nothing) -- Add action-addOrReplaceGraphics (old@(id, _):state) new@(id', newGraphic)- | id == id' = (new:state, Just old) -- Update action- | otherwise = (old:state', result)+addGraphic :: GraphicsState -> StatefulBB -> GraphicsState+addGraphic [] new = [new]+addGraphic (graphic:state) new+ | z > z' = new:graphic:state+ | otherwise = graphic:(addGraphic state new) where- (state', result) = addOrReplaceGraphics state new+ z = getZ graphic+ z' = getZ new -removeGraphics :: GraphicsState -> NamedId -> (GraphicsState, (Maybe StatefulGraphic))-removeGraphics [] _ = ([], Nothing)-removeGraphics (sg@(id, _):state) id'+addOrReplaceGraphic :: GraphicsState -> StatefulBB -> (GraphicsState, (Maybe StatefulBB))+addOrReplaceGraphic [] new = ([new], Nothing) -- Add action+addOrReplaceGraphic (graphic:state) new+ | id == id' && z == z' = (new:state, Just graphic) -- Simple update++ | id == id' && z /= z' = let -- Update action (must be z <= z')+ state' = addGraphic state new -- Insert new higher up+ in+ (state', Just graphic) -- new is higher, forget current=old++ | id /= id' && z > z' = let -- Add or update action+ (state', old) = removeGraphic state id' -- Search higher state for possible stale+ in+ (new:graphic:state', old)++ | otherwise = let -- Search further+ (state', result) = addOrReplaceGraphic state new+ in+ (graphic:state', result)+ where+ id = getId graphic+ z = getZ graphic+ id' = getId new+ z' = getZ new+++removeGraphic :: GraphicsState -> NamedId -> (GraphicsState, (Maybe StatefulBB))+removeGraphic [] _ = ([], Nothing)+removeGraphic (sg:state) id' | id == id' = (state, Just sg) | otherwise = (sg:state', result) where- (state', result) = removeGraphics state id'+ (state', result) = removeGraphic state id'+ id = getId sg
src/Eventloop/Module/StatefulGraphics/Types.hs view
@@ -1,22 +1,59 @@-module Eventloop.Module.StatefulGraphics.Types where+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+module Eventloop.Module.StatefulGraphics.Types+ ( module Eventloop.Module.Websocket.Canvas.Types+ , module Eventloop.Module.StatefulGraphics.Types+ ) where +import GHC.Generics (Generic)+import Control.DeepSeq+ import Eventloop.Types.Common import Eventloop.Module.BasicShapes.Types-import Eventloop.Module.Websocket.Canvas.Types+import Eventloop.Module.BasicShapes.Classes+import Eventloop.Module.Websocket.Canvas.Types (CanvasId, ZIndex) data StatefulGraphicsOut = Draw StatefulGraphic | Remove NamedId- deriving (Eq, Show)+ deriving (Eq, Show, Generic, NFData) data GraphicPerformed- = Drawn StatefulGraphic- | Modified StatefulGraphic- | Removed StatefulGraphic+ = Drawn StatefulBB+ | Modified StatefulBB+ | Removed StatefulBB | NoOp -type StatefulGraphic = (NamedId, Shape)+data StatefulGraphic = Stateful NamedId ZIndex Shape+ deriving (Show, Eq, Generic, NFData) -type GraphicsState = [StatefulGraphic]+data StatefulBB = StatefulBB StatefulGraphic BoundingBox+ deriving (Show, Eq)++type GraphicsState = [StatefulBB] type GraphicsStates = [(CanvasId, GraphicsState)] +instance ToPrimitives StatefulGraphic where+ toPrimitives (Stateful _ _ shape) = toPrimitives shape++instance ToBoundingBox StatefulGraphic where+ toBoundingBox (Stateful _ _ shape) = toBoundingBox shape++instance Overlaps StatefulGraphic++instance ToPrimitives StatefulBB where+ toPrimitives (StatefulBB stateful _) = toPrimitives stateful++instance ToBoundingBox StatefulBB where+ toBoundingBox (StatefulBB _ bb) = bb++instance Overlaps StatefulBB++++class NoDimChange a where+ noDimChange :: a -> a -> Bool+{-+instance NoDimChange Shape where+ noDimChange+ TODO for Modified -> Drawn optimalization+-}
src/Eventloop/Module/StdIn/Types.hs view
@@ -1,5 +1,9 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Eventloop.Module.StdIn.Types where +import GHC.Generics (Generic) +import Control.DeepSeq + data StdInIn = StdInReceivedContents [[Char]] | StdInReceivedLine [Char] | StdInReceivedChar Char @@ -8,4 +12,4 @@ data StdInOut = StdInReceiveContents | StdInReceiveLine | StdInReceiveChar - deriving (Eq, Show)+ deriving (Eq, Show, Generic, NFData)
src/Eventloop/Module/StdOut/StdOut.hs view
@@ -36,7 +36,4 @@ safePrint token str hFlush stdout where - token = safePrintToken sharedConst - -stdOutEventSender sharedConst sharedIOT ioConst ioStateT Stop - = return ()+ token = safePrintToken sharedConst
src/Eventloop/Module/StdOut/Types.hs view
@@ -1,4 +1,8 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Eventloop.Module.StdOut.Types where +import GHC.Generics (Generic) +import Control.DeepSeq + data StdOutOut = StdOutMessage [Char] - deriving (Eq, Show)+ deriving (Eq, Show, Generic, NFData)
src/Eventloop/Module/Timer/Types.hs view
@@ -1,5 +1,9 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Eventloop.Module.Timer.Types where - + +import GHC.Generics (Generic) +import Control.DeepSeq + import Control.Concurrent.Datastructures.BlockingConcurrentQueue import Control.Concurrent.Timer import Control.Concurrent.Suspend.Lifted @@ -16,4 +20,4 @@ data TimerOut = SetTimer TimerId MicroSecondDelay | SetIntervalTimer TimerId MicroSecondDelay | UnsetTimer TimerId - deriving (Eq, Show)+ deriving (Eq, Show, Generic, NFData)
src/Eventloop/Module/Websocket/Canvas/Canvas.hs view
@@ -46,15 +46,14 @@ (clientSocket, clientConn, serverSock) <- setupWebsocketConnection ipAddress canvasPort safePrintLn (safePrintToken sharedConst) "Canvas connection successfull!" sysRecvBuffer <- newEmptyMVar - --TODO Add measuretext to sharedIO - return (sharedConst, sharedIO, CanvasConstants sysRecvBuffer clientSocket clientConn serverSock, NoState) + measureTextLock <- newMVar () + let + ioConst = CanvasConstants sysRecvBuffer clientSocket clientConn serverSock + measureText_' = measureText_ ioConst measureTextLock + sharedConst' = sharedConst{measureText = measureText_'} + return (sharedConst', sharedIO, ioConst, NoState) -{- -TODO: -- Path bug -RELEASE -- measuretext in sharedIO --} + canvasEventRetriever :: EventRetriever canvasEventRetriever sharedConst sharedIOT ioConst ioStateT = do @@ -88,13 +87,13 @@ canvasEventSender sharedConst sharedIOT ioConst ioStateT Stop = do closeWebsocketConnection safePrintToken_ serverSock clientSock conn - -- Todo teardown measureText websocket connection where serverSock = serverSocket ioConst clientSock = clientSocket ioConst conn = clientConnection ioConst safePrintToken_ = safePrintToken sharedConst + canvasTeardown :: Teardown canvasTeardown sharedConst sharedIO ioConst ioState = do @@ -118,7 +117,16 @@ putMVar sysRecvBuffer canvasIn return Nothing - ---TODO -measureText :: IOState -> CanvasId -> CanvasText -> IO ScreenDimensions -measureText canvasState canvasId canvasText = return (4,4) + +measureText_ :: IOConstants -> MVar () -> CanvasText -> IO ScreenDimensions +measureText_ ioConst lock canvasText + = do + lock_ <- takeMVar lock + sendRoutedMessageOut conn outMsg + (SystemMeasuredText _ screenDims) <- takeMVar buf + putMVar lock lock_ + return screenDims + where + conn = clientConnection ioConst + buf = canvasSystemReceiveBuffer ioConst + outMsg = OutSystemCanvas $ SystemMeasureText canvasText
src/Eventloop/Module/Websocket/Canvas/JSONEncoding.hs view
@@ -22,19 +22,17 @@ parseJSON (Object v) = do opCode <- v .: "t" :: Parser Int case opCode of - 2101 -> SystemMeasuredText <$> v .: "canvasid" - <*> (v .: "canvastext" >>= parseJSON) - <*> ( (\width height -> (width, height)) + 2101 -> SystemMeasuredText <$> (v .: "canvastext" >>= parseJSON) + <*> ( (\width height -> (width, height)) <$> v .: "width" <*> v .: "height" - ) + ) instance FromJSON CanvasIn where parseJSON (Object v) = do opCode <- v .: "t" :: Parser Int case opCode of - 101 -> MeasuredText <$> v .: "canvasid" - <*> (v .: "canvastext" >>= parseJSON) + 101 -> MeasuredText <$> (v .: "canvastext" >>= parseJSON) <*> ( (\width height -> (width, height)) <$> v .: "width" <*> v .: "height" @@ -55,8 +53,6 @@ 1501 -> AlignLeft 1502 -> AlignRight 1503 -> AlignCenter - 1504 -> AlignStart - 1505 -> AlignEnd @@ -75,9 +71,8 @@ instance ToJSON SystemCanvasOut where - toJSON d@(SystemMeasureText canvasId canvasText) = operationObject (toOpcode d) [ toJSON canvasId - , toJSON canvasText - ] + toJSON d@(SystemMeasureText canvasText) = operationObject (toOpcode d) [ toJSON canvasText + ] instance ToJSON CanvasOut where @@ -90,9 +85,8 @@ toJSON d@(CanvasOperations canvasId canvasOperations) = operationObject (toOpcode d) [ toJSON canvasId , toJSON canvasOperations ] - toJSON d@(MeasureText canvasId text) = operationObject (toOpcode d) [ toJSON canvasId - , toJSON text - ] + toJSON d@(MeasureText text) = operationObject (toOpcode d) [ toJSON text + ] instance ToJSON CanvasOperation where @@ -108,6 +102,7 @@ ] toJSON d@(DoTransform canvasTransform) = operationObject (toOpcode d) [toJSON canvasTransform] toJSON d@(Clear clearPart) = operationObject (toOpcode d) [toJSON clearPart] + toJSON d@(Frame) = operationObject (toOpcode d) [] instance ToJSON ScreenPathPart where
src/Eventloop/Module/Websocket/Canvas/Opcode.hs view
@@ -7,19 +7,20 @@ instance ToOpcode SystemCanvasOut where - toOpcode (SystemMeasureText _ _) = 2001 + toOpcode (SystemMeasureText _) = 2001 instance ToOpcode CanvasOut where toOpcode (SetupCanvas _ _ _ _) = 201 toOpcode (TeardownCanvas _) = 202 toOpcode (CanvasOperations _ _) = 203 - toOpcode (MeasureText _ _) = 204 + toOpcode (MeasureText _) = 204 instance ToOpcode CanvasOperation where toOpcode (DrawPath _ _ _ _) = 301 toOpcode (DrawText _ _ _ _) = 302 toOpcode (DoTransform _) = 303 toOpcode (Clear _) = 304 + toOpcode (Frame) = 305 instance ToOpcode ScreenPathPart where toOpcode (MoveTo _) = 401 @@ -75,8 +76,6 @@ toOpcode (AlignLeft) = 1501 toOpcode (AlignRight) = 1502 toOpcode (AlignCenter) = 1503 - toOpcode (AlignStart) = 1504 - toOpcode (AlignEnd) = 1505 instance ToOpcode CanvasTransform where toOpcode (Save) = 1601
src/Eventloop/Module/Websocket/Canvas/Types.hs view
@@ -1,6 +1,9 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Eventloop.Module.Websocket.Canvas.Types where import Control.Concurrent.MVar +import GHC.Generics (Generic) +import Control.DeepSeq import Eventloop.Types.Common @@ -61,18 +64,18 @@ data RoutedMessageOut = OutUserCanvas CanvasOut | OutSystemCanvas SystemCanvasOut - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) {- |Opcode: 2100-} -data SystemCanvasIn = SystemMeasuredText CanvasId CanvasText ScreenDimensions {- ^Opcode: 2101-} +data SystemCanvasIn = SystemMeasuredText CanvasText ScreenDimensions {- ^Opcode: 2101-} deriving (Eq, Show) {- |Opcode: 2000-} -data SystemCanvasOut = SystemMeasureText CanvasId CanvasText {- ^Opcode: 2001-} - deriving (Eq, Show) +data SystemCanvasOut = SystemMeasureText CanvasText {- ^Opcode: 2001-} + deriving (Eq, Show, Generic, NFData) {- |Opcode: 0100-} -data CanvasIn = MeasuredText CanvasId CanvasText ScreenDimensions {- ^Opcode: 0101-} +data CanvasIn = MeasuredText CanvasText ScreenDimensions {- ^Opcode: 0101-} deriving (Eq, Show) @@ -93,15 +96,16 @@ data CanvasOut = SetupCanvas CanvasId ZIndex ScreenDimensions CSSPosition {- ^Opcode: 0201-} | TeardownCanvas CanvasId {- ^Opcode: 0202-} | CanvasOperations CanvasId [CanvasOperation] {- ^Opcode: 0203-} - | MeasureText CanvasId CanvasText {- ^Opcode: 0204-} - deriving (Eq, Show) + | MeasureText CanvasText {- ^Opcode: 0204-} + deriving (Eq, Show, Generic, NFData) {- |Opcode: 0300-} data CanvasOperation = DrawPath ScreenStartingPoint [ScreenPathPart] PathStroke PathFill {- ^Opcode: 0301 -} | DrawText CanvasText ScreenPoint TextStroke TextFill {- ^Opcode: 0302 -} | DoTransform CanvasTransform {- ^Opcode: 0303 -} | Clear ClearPart {- ^Opcode: 0304 -} - deriving (Eq, Show) + | Frame {- ^Opcode: 0305 -} + deriving (Eq, Show, Generic, NFData) {- |Opcode: 0400-} data ScreenPathPart = MoveTo ScreenPoint {- ^Opcode: 0401-} @@ -111,7 +115,7 @@ | ArcTo ScreenControlPoint ScreenControlPoint ScreenRadius {- ^Opcode: 0405-} | Arc ScreenCircle ScreenStartingAngle ScreenEndAngle {- ^Opcode: 0406-} | Rectangle ScreenPoint ScreenDimensions {- ^Opcode: 0407-} - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) {- Styling of Shapes -} {- |Opcode: 0500-} @@ -119,14 +123,14 @@ data PathStroke = PathStroke ScreenLineThickness PathRenderStrokeStyle {- ^Opcode: 0501-} | NoPathStroke {- ^Opcode: 0502-} - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) {- |Opcode: 0600-} type PathRenderFillStyle = RenderStyle data PathFill = PathFill PathRenderFillStyle {- ^Opcode: 0601-} | NoPathFill {- ^Opcode: 0602-} - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) {- |Opcode: 0700-} type CanvasColorStop = (ColorStopOffset, ScreenColor) @@ -134,36 +138,36 @@ data RenderStyle = CanvasColor ScreenColor {- ^Opcode: 0701-} | CanvasGradient CanvasGradientType [CanvasColorStop] {- ^Opcode:0702-} | CanvasPattern CanvasImage PatternRepetition {- ^Opcode: 0703-} - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) {- |Opcode: 0800-} data CanvasImage = CanvasElement CanvasId ScreenPoint ScreenDimensions {- ^Opcode: 0801-} | ImageData ScreenDimensions [ScreenPixel] {- ^Opcode: 0802 [ScreenPixel] should be as long as width * height * 4 -} - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) {- |Opcode: 0900-} data PatternRepetition = Repeat {- ^Opcode: 0901-} | RepeatX {- ^Opcode: 0902-} | RepeatY {- ^Opcode: 0903-} | NoRepeat {- ^Opcode: 0904-} - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) {- |Opcode: 1000-} data CanvasGradientType = RadialGradient ScreenCircle ScreenCircle {- ^Opcode: 1001 First circle = inner circle, Second circle is enclosing circle -} | LinearGradient ScreenPoint ScreenPoint {- ^Opcode: 1002-} - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) {- To Draw Text -} {- |Opcode: 1200-} data CanvasText = CanvasText [Char] Font Alignment {- ^Opcode: 1201-} - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) {- |Opcode: 1300-} data Font = Font FontFamily FontSize {- ^Opcode: 1301-} - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) {- |Opcode: 1400-} type TextStrokeRenderStyle = RenderStyle @@ -171,20 +175,18 @@ data TextStroke = TextStroke ScreenLineThickness TextStrokeRenderStyle {- ^Opcode: 1401-} | NoTextStroke {- ^Opcode: 1402-} - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) {- |Opcode: 2400-} data TextFill = TextFill TextFillRenderStyle {- ^Opcode: 2401-} | NoTextFill {- ^Opcode: 2402-} - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) {- |Opcode: 1500-} data Alignment = AlignLeft {- ^Opcode: 1501-} | AlignRight {- ^Opcode: 1502-} | AlignCenter {- ^Opcode: 1503-} - | AlignStart {- ^Opcode: 1504-} - | AlignEnd {- ^Opcode: 1505-} - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) {- Transform The Canvas -} {- |Opcode: 1600-} @@ -199,7 +201,7 @@ | Transform TransformationMatrix {- ^Opcode: 1606-} | SetTransform TransformationMatrix {- ^Opcode: 1607-} | ResetTransform {- ^Opcode: 1608-} - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) {- CSS Position of DOM elements -} {- |Opcode: 2200-} @@ -208,19 +210,19 @@ type CSSMeasurements = (CSSLeftOffset, CSSTopOffset) data CSSPosition = CSSPosition CSSBindPoint CSSMeasurements {- ^Opcode: 2201-} - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) {- |Opcode: 2300-} data CSSBindPoint = CSSFromCenter {- ^Opcode: 2301-} | CSSFromDefault {- ^Opcode: 2302 Usually this is the top left corner of the element -} - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) {- |Opcode: 1800-} data CSSUnit = CSSPixels Int {- ^Opcode: 1801-} | CSSPercentage Int {- ^Opcode: 1802-} - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) {- |Opcode: 1900 -} data ClearPart = ClearRectangle ScreenPoint ScreenDimensions {- ^Opcode: 1901-} | ClearCanvas {- ^Opcode: 1902-} - deriving (Eq, Show)+ deriving (Eq, Show, Generic, NFData)
src/Eventloop/Module/Websocket/Keyboard/Types.hs view
@@ -1,4 +1,8 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Eventloop.Module.Websocket.Keyboard.Types where +import GHC.Generics (Generic) +import Control.DeepSeq + data Keyboard = Key [Char] - deriving (Eq, Show)+ deriving (Eq, Show, Generic, NFData)
src/Eventloop/Module/Websocket/Mouse/Types.hs view
@@ -1,5 +1,9 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Eventloop.Module.Websocket.Mouse.Types where +import GHC.Generics (Generic) +import Control.DeepSeq + import Eventloop.Types.Common import Eventloop.Utility.Vectors @@ -22,4 +26,4 @@ data MouseButton = MouseLeft | MouseRight | MouseMiddle - deriving (Eq, Show)+ deriving (Eq, Show, Generic, NFData)
src/Eventloop/System/EventloopThread.hs view
@@ -1,5 +1,6 @@ module Eventloop.System.EventloopThread where +import Control.DeepSeq import Control.Exception import Control.Monad import Control.Concurrent.ExceptionUtility @@ -30,6 +31,7 @@ processedInEvents <- processEvents "Preprocessing" systemConfig modulePreprocessors [inEvent] -- Preprocess it outEvents <- eventloopSteps eventloop progstateT_ processedInEvents -- Eventloop over the preprocessed In events processedOutEvents <- processEvents "Postprocessing" systemConfig modulePostprocessors outEvents -- Postprocess the Out events + evaluatedOutEvents <- evaluate $ force processedOutEvents putAllInBlockingConcurrentQueue outEventQueue_ processedOutEvents -- Send the processed Out events to the OutRouter ) where
src/Eventloop/System/InitializationThread.hs view
@@ -4,6 +4,7 @@ import Control.Exception import Control.Concurrent.STM +import Data.List import Eventloop.Types.Exception import Eventloop.Types.System @@ -16,11 +17,11 @@ sharedIO <- readTVarIO sharedIOT_ (sharedConst', sharedIO', moduleConfigs_') <- initializeModules sharedConst sharedIO moduleConfigs_ atomically $ writeTVar sharedIOT_ sharedIO' - return systemConfig{moduleConfigs = moduleConfigs_', sharedIOConstants = sharedConst'} + return systemConfig{moduleConfigs = reverse $ moduleConfigs_', sharedIOConstants = sharedConst'} where sharedConst = sharedIOConstants systemConfig sharedIOT_ = sharedIOStateT systemConfig - moduleConfigs_ = moduleConfigs systemConfig + moduleConfigs_ = reverse $ moduleConfigs systemConfig initializeModules :: SharedIOConstants
src/Eventloop/Types/Events.hs view
@@ -1,5 +1,9 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Eventloop.Types.Events where +import GHC.Generics (Generic) +import Control.DeepSeq + import Eventloop.Module.Websocket.Keyboard.Types import Eventloop.Module.Websocket.Mouse.Types import Eventloop.Module.Websocket.Canvas.Types @@ -34,4 +38,4 @@ | OutGraphs GraphsOut | OutStatefulGraphics CanvasId [StatefulGraphicsOut] | Stop - deriving (Eq, Show)+ deriving (Eq, Show, Generic, NFData)
src/Eventloop/Utility/Trees/GeneralTree.hs view
@@ -1,19 +1,23 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Eventloop.Utility.Trees.GeneralTree where +import GHC.Generics (Generic) +import Control.DeepSeq + import Eventloop.Module.BasicShapes.Types import Eventloop.Utility.Vectors import Eventloop.Utility.Trees.LayoutTree data GeneralTree = GeneralTreeBox [GeneralNodeContent] [(GeneralLine, GeneralTree)] - deriving (Show, Eq) + deriving (Show, Eq, Generic, NFData) data GeneralNodeContent = GeneralNodeText FillColor String | GeneralNode FillColor Radius - deriving (Show, Eq) + deriving (Show, Eq, Generic, NFData) data GeneralLine = GeneralLine StrokeColor - deriving (Show, Eq) + deriving (Show, Eq, Generic, NFData) type LeftOffset = X @@ -127,7 +131,7 @@ treeIndex :: Int -> Offset -> Shape -treeIndex i (x, y) = BaseShape (Text iStr "Courier" 20 p (255,75,75, 255)) 1 (0,0,0,0) Nothing +treeIndex i (x, y) = Text iStr "Courier" 20 p AlignLeft (255,75,75, 255) 1 (0,0,0,0) Nothing where iStr = show i (wText, hText) = textSize iStr
src/Eventloop/Utility/Trees/LayoutTree.hs view
@@ -36,12 +36,12 @@ printNodeContent :: Offset -> LayoutNodeContent -> Shape -printNodeContent (xOffset, yOffset) (LayoutNodeText fillColor p text (_, height)) = BaseShape (Text text textFont height ((Point (xOffset, yOffset)) |+| p) fillColor) textThickness (0,0,0,0) Nothing -printNodeContent (xOffset, yOffset) (LayoutNode fillColor p r) = BaseShape (Circle ((Point (xOffset, yOffset)) |+| p) r fillColor) lineThickness (0,0,0,0) Nothing +printNodeContent (xOffset, yOffset) (LayoutNodeText fillColor p text (_, height)) = Text text textFont height ((Point (xOffset, yOffset)) |+| p) AlignCenter fillColor textThickness (0,0,0,0) Nothing +printNodeContent (xOffset, yOffset) (LayoutNode fillColor p r) = Circle ((Point (xOffset, yOffset)) |+| p) r fillColor lineThickness (0,0,0,0) Nothing printLine :: Point -> (LayoutLine, LayoutTree) -> Shape -printLine startPoint ((LayoutLine lineColor),(LBox point topConnect _ _ _)) = BaseShape (Line startMarg endMarg) lineThickness lineColor Nothing +printLine startPoint ((LayoutLine lineColor),(LBox point topConnect _ _ _)) = Line startMarg endMarg lineThickness lineColor Nothing where startMarg = marginizeLinePoints marginLine startPoint endPoint endMarg = marginizeLinePoints marginLine endPoint startPoint
src/Eventloop/Utility/Vectors.hs view
@@ -1,5 +1,9 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, FlexibleInstances #-} module Eventloop.Utility.Vectors where +import GHC.Generics (Generic) +import Control.DeepSeq + type Angle = Float -- ^In degrees type Radians = Float type Length = Float @@ -12,8 +16,35 @@ deriving (Show, Eq) data Point = Point (X, Y) - deriving (Show, Eq) + deriving (Show, Eq, Generic, NFData) + +class Coord a where + x :: a -> X + y :: a -> Y + +instance Coord Point where + x (Point (x_, _)) = x_ + y (Point (_, y_)) = y_ + +instance Coord PolarCoord where + x = x.toPoint + y = y.toPoint + + +class ExtremaCoord a where + xMin :: a -> X + xMax :: a -> X + yMin :: a -> Y + yMax :: a -> Y + +instance ExtremaCoord [Point] where + xMin points = minimum $ map x points + xMax points = maximum $ map x points + yMin points = minimum $ map y points + yMax points = maximum $ map y points + + degreesToRadians :: Angle -> Radians degreesToRadians d = (pi / 180) * d @@ -34,29 +65,92 @@ differenceBetweenPoints :: Point -> Point -> (X, Y) differenceBetweenPoints (Point (x1, y1)) (Point (x2, y2)) = (x2 - x1, y2 - y1) - - + + +averagePoint :: [Point] -> Point +averagePoint points + = average + where + total = foldl (|+|) originPoint points + average = total |\ (toInteger (length points)) + + +-- | Returns the vector perpendicular on the given vector between the 2 points. Always has positive y and vector length 1; y is inverted in canvas +downPerpendicular :: Point -> Point -> Point +downPerpendicular p1@(Point (x1, y1)) p2@(Point (x2, y2)) + | y2 > y1 = Point ((-1) * sign * (abs yv) / size, (abs xv) / size) + | otherwise = Point ( sign * (abs yv) / size, (abs xv) / size) + where + (xv, yv) = differenceBetweenPoints p1 p2 + size = lengthBetweenPoints p1 p2 + sign = case xv of + 0 -> (-1) + _ -> xv / (abs xv) + + +-- | Returns the vector perpendicular on the given vector between the 2 points. Always has negative y and vector length 1; y is inverted in canvas +upPerpendicular :: Point -> Point -> Point +upPerpendicular p1 p2 = negateVector $ downPerpendicular p1 p2 + + +followVector :: Float -> Point -> Point -> Point +followVector distance followP startP + = (followP |* fraction) |+| startP + where + fraction = distance / size + size = lengthBetweenPoints followP originPoint + + originPoint = Point (0,0) class Translate a where translate :: Point -> a -> a -class (RotateLeftAround a) => Vector2D a where +class (Coord a) => Vector2D a where (|+|) :: a -> a -> a (|-|) :: a -> a -> a + (|\) :: (Real b) => a -> b -> a + (|*) :: (Real b) => a -> b -> a negateVector :: a -> a instance Vector2D PolarCoord where pc1 |+| pc2 = toPolarCoord $ (toPoint pc1) |+| (toPoint pc2) pc1 |-| pc2 = toPolarCoord $ (toPoint pc1) |-| (toPoint pc2) + (PolarCoord (l, a)) |\ scalar + = PolarCoord (fromRational (l' / scalar'), a) + where + l' = toRational l + scalar' = toRational scalar + (PolarCoord (l, a)) |* scalar + = PolarCoord (fromRational (l' * scalar'), a) + where + l' = toRational l + scalar' = toRational scalar negateVector pc1 = rotateLeftAround (Point (0,0)) 180 pc1 instance Vector2D Point where - (Point (x1, y1)) |+| (Point (x2, y2)) = Point (x1 + x2, y1 + y2) - (Point (x1, y1)) |-| (Point (x2, y2)) = Point (x1 - x2, y1 - y2) - negateVector (Point (x, y)) = Point (-x, -y) + (Point (x1, y1)) |+| (Point (x2, y2)) + = Point (x1 + x2, y1 + y2) + (Point (x1, y1)) |-| (Point (x2, y2)) + = Point (x1 - x2, y1 - y2) + + (Point (x1, y1)) |\ scalar + = Point (fromRational x', fromRational y') + where + x' = toRational x1 / toRational scalar + y' = toRational y1 / toRational scalar + + (Point (x1, y1)) |* scalar + = Point (fromRational x', fromRational y') + where + x' = toRational x1 * toRational scalar + y' = toRational y1 * toRational scalar + + negateVector (Point (x, y)) + = Point (-x, -y) + class ToPoint a where toPoint :: a -> Point @@ -75,13 +169,13 @@ | 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.0 * pi + localRads) - | x > 0 && y < 0 = PolarCoord (len, 1.5 * pi + localRads) + | x > 0 && y < 0 = PolarCoord (len, 2.0 * pi - localRads) where x' = abs x y' = abs y - localRads = atan (y' / x') + localRads = asin (y' / len) len = lengthToPoint (Point (x, y)) @@ -91,11 +185,12 @@ 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 + p' = p |-| rotatePoint pc'@(PolarCoord (len', rads')) = toPolarCoord p' aRads = degreesToRadians aDeg pc'' = PolarCoord (len', rads' + aRads)