module Eventloop.Module.BasicShapes.Classes where import Eventloop.Utility.Vectors import Eventloop.Module.BasicShapes.Types 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 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 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) 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 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 = x4 - x1 h = y2 - y1 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, 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 {- 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? 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. Waarom ik een boundingbox met de verkeerde punten op de verkeerde plekken krijg, blijft een raadsel. Even kijken of foldBoundingBoxes goed werkt of niet //TODO NIET VERGETEN JAN TE MAILEN!!! -} 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 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 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 toCanvasOperations (CompositeShape shapes (Just translate) Nothing) = [ CT.DoTransform CT.Save , CT.DoTransform (CT.Translate screenTranslationPoint) ] ++ drawOperations ++ [ CT.DoTransform CT.Restore ] where screenTranslationPoint = roundPoint translate drawOperations = toCanvasOperations (CompositeShape shapes Nothing Nothing) class ToScreenPathPart a where toScreenPathParts :: a -> ([CT.ScreenPathPart], CT.ScreenStartingPoint, Maybe FillColor) 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 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']