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
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']