module Eventloop.Module.BasicShapes.Classes where import Eventloop.Utility.Vectors import Eventloop.Module.BasicShapes.Types import qualified Eventloop.Module.Websocket.Canvas.Types as CT addBoundingBox :: BoundingBox -> BoundingBox -> BoundingBox addBoundingBox (BoundingBox p11 p21 p31 p41) (BoundingBox p12 p22 p32 p42) = BoundingBox (Point (xMin, yMin)) (Point (xMax, yMin)) (Point (xMax, yMax)) (Point (xMin, yMax)) where allPoints = [p11, p21, p31, p41, p12, p22, p32, p42] xs = map (\(Point (x,y)) -> x) allPoints ys = map (\(Point (x,y)) -> y) allPoints xMin = minimum xs xMax = maximum xs yMin = minimum ys yMax = maximum ys foldBoundingBoxes :: (BoundingBox -> BoundingBox -> BoundingBox) -> [BoundingBox] -> BoundingBox foldBoundingBoxes _ [] = error "Tried to fold zero bounding boxes which is no bounding box. Undefined!" foldBoundingBoxes op (box:bs) = foldl op box bs translateBoundingBox :: Translation -> BoundingBox -> BoundingBox translateBoundingBox pTrans = opOnBoundingBox ((|+|) pTrans) opOnBoundingBox :: (Point -> Point) -> BoundingBox -> BoundingBox opOnBoundingBox op (BoundingBox p1 p2 p3 p4) = BoundingBox (op p1) (op p2) (op p3) (op p4) allPolygonPoints :: AmountOfPoints -> Point -> Radius -> [Point] allPolygonPoints n centralPoint r | n < 1 = error "A polygon with 0 or more sides doesn't exist!" | otherwise = [centralPoint |+| (toPoint (PolarCoord (r, angle))) |angle <- anglesRads] where anglePart = 360 / (fromIntegral n) startAngle = 0 anglesDeg = filter (< 360) [startAngle, startAngle + anglePart..360] anglesRads = map degreesToRadians anglesDeg roundPoint :: Point -> CT.ScreenPoint roundPoint (Point (x, y)) = (round x, round y) roundShapeColor :: ShapeColor -> (CT.ScreenColor, CT.ScreenColor) roundShapeColor (strokeColor, fillColor) = (roundColor strokeColor, roundColor fillColor) roundColor :: Color -> CT.ScreenColor roundColor (r, b, g, a) = (round r, round b, round g, a) instance RotateLeftAround BoundingBox where rotateLeftAround rotatePoint aDeg box = opOnBoundingBox (rotateLeftAround rotatePoint aDeg) box class (ToBoundingBox a) => ToCenter a where toCenter :: a -> Point instance ToCenter Primitive where toCenter = toCenter.toBoundingBox instance ToCenter Shape where toCenter = toCenter.toBoundingBox instance ToCenter BoundingBox where toCenter (BoundingBox (Point (x1, y1)) (Point (x2, y2)) _ (Point (x4, y4))) = Point (x1 + 0.5 * w, y1 + 0.5 * h) where w = x2 - x1 h = y4 - x1 class ToBoundingBox a where toBoundingBox :: a -> BoundingBox instance ToBoundingBox BoundingBox where toBoundingBox box = box instance ToBoundingBox Primitive where toBoundingBox (Rectangle (Point (x, y)) (w, h)) = BoundingBox (Point (x, y)) (Point (x + w, y)) (Point (x + w, y + h)) (Point (x, y + h)) toBoundingBox (Circle p r) = toBoundingBox (Rectangle p (r, r)) toBoundingBox (Polygon _ p r) = toBoundingBox (Circle p r) toBoundingBox (Text _ _ _ p) = BoundingBox p p p p toBoundingBox (Line p1 p2) = BoundingBox p1 p2 p2 p1 toBoundingBox (MultiLine p1 p2 ops) = BoundingBox (Point (xMin, yMin)) (Point (xMax, yMin)) (Point (xMax, yMax)) (Point (xMin, yMax)) where points = p1:p2:ops xs = map (\(Point (x, y)) -> x) points ys = map (\(Point (x, y)) -> y) points xMin = minimum xs xMax = maximum xs yMin = minimum ys yMax = maximum ys instance ToBoundingBox Shape where toBoundingBox (BaseShape prim _ (Just rotation)) = rotatedBox where baseBox = toBoundingBox prim rotationPoint = findRotationPoint prim rotation (Rotation _ angle) = rotation rotatedBox = rotateLeftAround rotationPoint angle baseBox toBoundingBox (BaseShape prim _ Nothing) = toBoundingBox prim toBoundingBox (CompositeShape shapes (Just translation) (Just rotation)) = rotateLeftAround rotationPoint angle translatedBox where baseBox = toBoundingBox (CompositeShape shapes Nothing Nothing) translatedBox = translateBoundingBox translation baseBox rotationPoint = findRotationPoint translatedBox rotation (Rotation _ angle) = rotation toBoundingBox (CompositeShape shapes (Just translation) Nothing) = translateBoundingBox translation baseBox where baseBox = toBoundingBox (CompositeShape shapes Nothing Nothing) toBoundingBox (CompositeShape shapes Nothing (Just rotation)) = rotateLeftAround rotationPoint angle baseBox where baseBox = toBoundingBox (CompositeShape shapes Nothing Nothing) rotationPoint = findRotationPoint baseBox rotation (Rotation _ angle) = rotation toBoundingBox (CompositeShape shapes Nothing Nothing) = foldBoundingBoxes addBoundingBox $ map toBoundingBox shapes findRotationPoint :: (ToCenter a) => a -> Rotation -> Point findRotationPoint a (Rotation AroundCenter _) = toCenter a findRotationPoint _ (Rotation (AroundPoint p) _) = p class ToCanvasOut a where toCanvasOut :: a -> CT.CanvasOut instance ToCanvasOut BasicShapesOut where toCanvasOut (DrawShapes canvasId shapes) = CT.CanvasOperations canvasId canvasOperations where canvasOperations = (concat.(map toCanvasOperations)) shapes class ToCanvasOperations a where toCanvasOperations :: a -> [CT.CanvasOperation] instance ToCanvasOperations Shape where toCanvasOperations (BaseShape prim color (Just rotation)) | angle == 0 = drawOperations | otherwise = [ CT.DoTransform CT.Save , CT.DoTransform (CT.Translate screenRotationPoint) , CT.DoTransform (CT.Rotate screenAngle) ] ++ drawOperations ++ [ CT.DoTransform CT.Restore ] where screenRotationPoint = roundPoint $ findRotationPoint prim rotation drawOperations = toCanvasOperations (BaseShape prim color Nothing) (Rotation _ angle) = rotation screenAngle = round angle -- Rotation is broken. When we translated to rotationpoint, translation of prim should be adjusted accordingly (prim' = move prim (-rotationPoint)) -- Multiline gets filled even though we do moveto finally. Solution: Move ShapeColor to primitives and skip fill for both Line and MultiLine -- Rectangle might be broken. Not sure though. The translation point might be, visually, bottom right instead of bottom right in the coordinate system. toCanvasOperations (BaseShape (Text text fontF fontS p) color Nothing) = [CT.DrawText canvasText p' textRender] where canvasText = CT.CanvasText text (CT.Font fontF $ round fontS) CT.AlignCenter textRender = CT.TextFill (CT.CanvasColor screenFillColor) (screenStrokeColor, screenFillColor) = roundShapeColor color p' = roundPoint p toCanvasOperations (BaseShape prim color Nothing) = [CT.DrawPath startingPoint screenPathParts pathStroke pathFill] where (screenPathParts, startingPoint) = toScreenPathParts prim pathStroke = CT.PathStroke (CT.CanvasColor screenStrokeColor) pathFill = CT.PathFill (CT.CanvasColor screenFillColor) (screenStrokeColor, screenFillColor) = roundShapeColor color toCanvasOperations (CompositeShape shapes Nothing Nothing) = concat canvasOperationsList where canvasOperationsList = map toCanvasOperations shapes class ToScreenPathPart a where toScreenPathParts :: a -> ([CT.ScreenPathPart], CT.ScreenStartingPoint) instance ToScreenPathPart Primitive where toScreenPathParts (Rectangle p (w, h)) = ([CT.Rectangle p' (w', h')], p') where p' = roundPoint p w' = round w h' = round h toScreenPathParts (Circle p r) = ([CT.Arc (p', r') 0 360], p') where p' = roundPoint p r' = round r toScreenPathParts (Polygon n p r) = (lines, screenPoint) where polygonPoints = allPolygonPoints n p r (screenPoint:ps) = map roundPoint polygonPoints lines = [CT.LineTo screenPoint' | screenPoint' <- (ps ++ [screenPoint])] toScreenPathParts (Text {}) = error "Text is stupid and not implemented the same way in JS canvas" toScreenPathParts (Line p1 p2) = ([CT.LineTo p2'], p1') where p1' = roundPoint p1 p2' = roundPoint p2 toScreenPathParts (MultiLine p1 p2 otherPoints) = (lines ++ [CT.MoveTo p1'], p1') where allPoints = p1:p2:otherPoints (p1':otherPoints') = map roundPoint allPoints lines = [CT.LineTo p' | p' <- otherPoints']