eventloop-0.5.1.0: src/Eventloop/Module/BasicShapes/Classes.hs
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
-}
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']