eventloop-0.2.1.1: 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
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']