```module Eventloop.Module.BasicShapes.Classes where

import Control.Concurrent.MVar

import Data.Maybe

import Eventloop.Utility.Vectors

import Eventloop.Module.BasicShapes.Types

import Eventloop.Module.BasicShapes.MeasureTextHack

import qualified Eventloop.Module.Websocket.Canvas.Types as CT

{-
The center of a boundingbox is not the center of an element
Rectangle - Intersection of two halves of adjoining sides
Circle    - Centre point
RegularPolygon   - Centre point
Text      - See boundingbox to rectangle
Line      - Halfway down the line
MultiLine - See boundingbox
Split into points to calc boundingbox
Rectangle - Split into 4 corners
Circle    - Top, left, right and bottom points on the circle
RegularPolygon   - Split into the regular polygon points
Text      - Split into 4 corners of bbox
Line      - Split into the two points
MultiLine - Split into the different points with stroke
Polygon   - Split into the different points with stroke
-}

{-
Bugs:
- BoundingBox of circle fails. Cannot use 'rotate points on circle' method.
- Difficult rotation? (Stacked composite shapes)
-}

data GeometricPrimitive = Points [Point]

deriving (Show, Eq)

instance RotateLeftAround GeometricPrimitive where

rotateLeftAround p angle (Points points)

= Points \$ map (rotateLeftAround p angle) points

rotateLeftAround p angle (CircleArea p' r)

= CircleArea (rotateLeftAround p angle p') r

opOnBoundingBox :: (Point -> Point) -> BoundingBox -> BoundingBox

opOnBoundingBox op (BoundingBox p1 p2 p3 p4) = BoundingBox (op p1)

(op p2)

(op p3)

(op p4)

instance ExtremaCoord BoundingBox where

xMin (BoundingBox ll _ _ _) = x ll

xMax (BoundingBox _ _ ur _) = x ur

yMin (BoundingBox ll _ _ _) = y ll

yMax (BoundingBox _ _ ur _) = y ur

instance ExtremaCoord GeometricPrimitive where

xMin (Points points) = xMin points

xMin (CircleArea (Point (x, y)) r) = x - r

xMax (Points points) = xMax points

xMax (CircleArea (Point (x, y)) r) = x + r

yMin (Points points) = yMin points

yMin (CircleArea (Point (x, y)) r) = y - r

yMax (Points points) = yMax points

yMax (CircleArea (Point (x, y)) r) = y + r

instance RotateLeftAround BoundingBox where

rotateLeftAround p angle bbox = opOnBoundingBox (rotateLeftAround p angle) bbox

allRegularPolygonPoints :: NumberOfPoints -> Point -> Radius -> [Point]

allRegularPolygonPoints n centralPoint r | n < 1 = error "A regular 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]

boundingBoxFromPrimitives :: [GeometricPrimitive] -> BoundingBox

boundingBoxFromPrimitives primitives

= BoundingBox (Point (xMin_, yMin_)) (Point (xMin_, yMax_)) (Point (xMax_, yMax_)) (Point (xMax_, yMin_))

where

xMin_ = minimum \$ map xMin primitives

xMax_ = maximum \$ map xMax primitives

yMin_ = minimum \$ map yMin primitives

yMax_ = maximum \$ map yMax primitives

normalizeBBox :: BoundingBox -> BoundingBox

normalizeBBox (BoundingBox p1 p2 p3 p4)

= boundingBoxFromPrimitives [Points [p1, p2, p3, p4]]

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)

strokePointsForLine :: StrokeLineThickness -> Point -> Point -> [Point]

strokePointsForLine thick p1 p2

= [ followVector (0.5 * thick) upPerpVector p1

, followVector (0.5 * thick) upPerpVector p2

, followVector (0.5 * thick) downPerpVector p1

, followVector (0.5 * thick) downPerpVector p2

]

where

upPerpVector = upPerpendicular p1 p2

downPerpVector = negateVector upPerpVector

strokePointsForConnection :: StrokeLineThickness -> Point -> Point -> Point -> [Point]

strokePointsForConnection strokeWidth start inspected dest

| start == inspected && inspected == dest = [dest]

| start == inspected                      = strokePointsForLine strokeWidth inspected dest

| inspected == dest                       = strokePointsForLine strokeWidth start inspected

| isJust mp1 && isJust mp2                = [fromJust mp1, fromJust mp2]

| otherwise                               = [sup1, sdown1] -- Is possible due to rounding. Direction vectors are roughly parallel but stepping points are not equal

-- GHC will think parallel vectors are parallel while they are not. So no intersection as stepping points are slightly different

-- Just return half width up and down from inspected as this is close enough

where

halfWidth = strokeWidth / 2

quart = 0.5 * pi

v1 = inspected |-| start

v1' = negateVector v1

v2 = inspected |-| dest

v2' = negateVector v2

upv1 = turnToVector v1 quart v2

sup1 = followVector halfWidth upv1 inspected

upv2 = turnToVector v2 quart v1

sup2 = followVector halfWidth upv2 inspected

downv1 = negateVector upv1

sdown1 = followVector halfWidth downv1 inspected

downv2 = negateVector upv2

sdown2 = followVector halfWidth downv2 inspected

mp1 = intersectVector sdown1 v1 sdown2 v2

mp2 = intersectVector sup1 v1 sup2 v2

strokePoints :: StrokeLineThickness -> [Point] -> [Point]

strokePoints strokeWidth ps

| l >= 3    = concat \$ map (\(start, inspected, dest) -> strokePointsForConnection strokeWidth start inspected dest) connections

| otherwise = []

where

l = length ps

connections = zip3 ps (drop 1 ps) (drop 2 ps)

strokePointsClosedPath :: StrokeLineThickness -> [Point] -> [Point]

strokePointsClosedPath strokeWidth ps

| length ps >= 3 = strokePoints strokeWidth (ps ++ take 2 ps)

| otherwise = []

instance Translate Shape where

translate p c@(CompositeShape {positionM=Nothing})

= c {positionM = (Just p)}

translate p c@(CompositeShape {positionM=(Just p1)})

= c {positionM = (Just \$ p1 |+| p)}

translate p r@(Rectangle {position=trans})

= r {position = trans |+| p}

translate p c@(Circle {position=trans})

= c {position = trans |+| p}

translate p po@(RegularPolygon {position=trans})

= po {position = trans |+| p}

translate p t@(Text {position=trans})

= t {position = trans |+| p}

translate pTrans l@(Line {point1=p1, point2=p2})

= l {point1 = (p1 |+| pTrans), point2 = (p2 |+| pTrans)}

translate pTrans ml@(MultiLine {points=points})

= ml {points = (map ((|+|) pTrans) points)}

translate pTrans a@(Polygon {points=points})

= a {points = (map ((|+|) pTrans) points)}

instance Translate GeometricPrimitive where

translate p (Points points) = Points (map (|+| p) points)

translate p (CircleArea p' r) = CircleArea (p |+| p') r

class ToPrimitives a where

toPrimitives :: a -> [GeometricPrimitive]

instance ToPrimitives BoundingBox where

toPrimitives (BoundingBox ll ul ur lr) = [Points [ll, ul, ur, lr]]

instance ToPrimitives Shape where

toPrimitives (CompositeShape shapes positionM Nothing)

| isJust positionM = map (translate (fromJust positionM)) primitives

| otherwise           = primitives

where

primitives = concat \$ map toPrimitives shapes

toPrimitives (Rectangle {position=(Point (x, y)), dimensions=(w, h), strokeLineThickness=thick, rotationM=Nothing})

= [ Points [ Point (x - hthick, y - hthick)

, Point (x - hthick, y + h + hthick)

, Point (x + w + hthick, y + h + hthick)

, Point (x + w + hthick, y - hthick)

]

]

where

hthick = 0.5 * thick

toPrimitives (Circle {position=p, radius=r, strokeLineThickness=thick, rotationM=Nothing})

= [CircleArea p (r + 0.5 * thick)]

toPrimitives (RegularPolygon {numberOfPoints=a, position=p, radius=r, strokeLineThickness=thick, rotationM=Nothing})

= toPrimitives (Polygon points undefined thick undefined Nothing)

where

points = allRegularPolygonPoints a p r

toPrimitives text@(Text {position=(Point (x,y)), alignment=align, rotationM=Nothing})

= [ Points \$ case align of

CT.AlignLeft   -> [ Point (x, y)

, Point (x, y + height)

, Point (x + width, y)

, Point (x + width, y + height)

]

CT.AlignCenter -> [ Point (x - hwidth, y - hheight)

, Point (x - hwidth, y + hheight)

, Point (x + hwidth, y - hheight)

, Point (x + hwidth, y + hheight)

]

CT.AlignRight  -> [ Point (x, y)

, Point (x, y + height)

, Point (x - width, y)

, Point (x - width, y + height)

]

]

where

canvasText = toCanvasText text

(width_, height_) = useMeasureText canvasText

width = fromIntegral width_

hwidth = width * 0.5

height = fromIntegral height_

hheight = height * 0.5

toPrimitives (Line {point1=p1, point2=p2, strokeLineThickness=thick, rotationM=Nothing})

= [Points (strokePointsForLine thick p1 p2)]

toPrimitives (MultiLine {points=points, strokeLineThickness=thick, strokeColor=color, rotationM=Nothing})

| len >= 3 = (Points strokePoints_) : (concat \$ map toPrimitives lines)

| len == 2 = toPrimitives (Line p1 p2 thick color Nothing)

| otherwise = error "Multilines should atleast include 2 points!"

where

[p1, p2] = points

len = length points

strokePoints_ = strokePoints thick points

tailPoints = drop 1 points

linePoints = zip points tailPoints

lines = map (\(p, p') -> Line p p' thick undefined Nothing) linePoints

toPrimitives (FilledMultiLine {points=points, fillWidth=fillThick, strokeLineThickness=strokeThick, rotationM=Nothing})

= (toPrimitives (MultiLine points fillThick undefined Nothing)) ++ (toPrimitives (MultiLine points (fillThick + strokeThick) undefined Nothing))

toPrimitives pol@(Polygon {points=points, strokeLineThickness=thick, rotationM=Nothing})

| length points >= 3 = [ Points (strokePointsClosedPath thick points)]

| length points == 2 = toPrimitives (Line p1 p2 thick undefined Nothing)

| length points == 1 = [ CircleArea p1 thick ]

| otherwise          = [ Points []]

where

(p1:p2:ps) = points

toPrimitives shape

= map (rotateLeftAround rotatePoint angle) (toPrimitives shapePreRotate)

where

shapePreRotate = shape{rotationM=Nothing}

(Just rotation@(Rotation _ angle)) = rotationM shape

rotatePoint = findRotationPoint shapePreRotate rotation

class ToCenter a where

toCenter :: a -> Point

instance ToCenter BoundingBox where

toCenter bbox

= Point (minX + 0.5 * (maxX - minX), minY + 0.5 * (maxY - minY))

where

minX = xMin bbox

maxX = xMax bbox

minY = yMin bbox

maxY = yMax bbox

instance ToCenter Shape where

toCenter c@(CompositeShape {positionM=(Just p), rotationM=Nothing})

= p |+| center

where

center = toCenter c{positionM=Nothing}

toCenter c@(CompositeShape {shapes=shapes, positionM=Nothing, rotationM=Nothing})

= averagePoint centers

where

centers = map toCenter shapes

toCenter r@(Rectangle {dimensions=(width, height), position=p, rotationM=Nothing})

= p |+| (Point (0.5 * width, 0.5 * height))

toCenter c@(Circle {position=p, rotationM=Nothing})

= p

toCenter po@(RegularPolygon {position=p, rotationM=Nothing})

= p

toCenter t@(Text {rotationM=Nothing})

= (toCenter.toBoundingBox) t

toCenter l@(Line {})

= (toCenter.toBoundingBox) l

toCenter ml@(MultiLine {})

= (toCenter.toBoundingBox) ml

toCenter fml@(FilledMultiLine {})

= (toCenter.toBoundingBox) fml

toCenter a@(Polygon {})

= (toCenter.toBoundingBox) a

toCenter shape

= rotateLeftAround rotationPoint angle center

where

(Just rotation) = rotationM shape

shapePreRotate = shape{rotationM=Nothing}

center = toCenter shapePreRotate

rotationPoint = findRotationPoint shapePreRotate rotation

(Rotation _ angle) = rotation

class (ToPrimitives a) => ToBoundingBox a where

toBoundingBox :: a -> BoundingBox

instance ToBoundingBox BoundingBox where

toBoundingBox box = box

instance ToBoundingBox Shape where

toBoundingBox a

= boundingBoxFromPrimitives \$ toPrimitives a

class (ToBoundingBox a) => Overlaps a where

{-
The boundingbox of a1 partially overlaps the boundingbox of a2. Ofcourse if overlaps(a1, a2) then
overlaps(a2, a1). However, if contains(a1, a2) or contains(a2, a1), then overlaps(a1, a2) == false
-}

overlaps :: (Overlaps b) => a -> b -> Bool

overlaps a1 a2

| contains a1 a2 || contains a2 a1 = False

| xMax b1 < xMin b2 = False -- b1 is left of b2

| xMin b1 > xMax b2 = False -- b2 is right of b2

| yMax b1 < yMin b2 = False -- b1 is lower than b2

| yMin b1 > yMax b2 = False -- b1 is higher than b2

| otherwise = True

where

b1 = toBoundingBox a1

b2 = toBoundingBox a2

{-
The boundingbox of a1 contains the boundingbox of a2. If boundingbox(a2) > boundingbox(a1)
then a1 can never contain a2. If boundingbox(a2) == boundingbox(a1) and contains(a1, a2)
then also contains(a2, a1).
-}

contains :: (Overlaps b) => a -> b -> Bool

contains a1 a2

| xMax b2 <= xMax b1 &&

xMin b2 >= xMin b1 &&

yMax b2 <= yMax b1 &&

yMin b2 >= yMin b1 = True

| otherwise = False

where

b1 = toBoundingBox a1

b2 = toBoundingBox a2

touches :: (Overlaps b) => a -> b -> Bool

touches a1 a2 = overlaps a1 a2 || contains a1 a2 || contains a2 a1

instance Overlaps Shape

instance Overlaps BoundingBox

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 ++ [CT.Frame])

where

canvasOperations = (concat.(map toCanvasOperations)) shapes

class ToCanvasOperations a where

toCanvasOperations :: a -> [CT.CanvasOperation]

toCanvasText :: Shape -> CT.CanvasText

toCanvasText (Text {text=text, fontFamily=family_, fontSize=size, alignment=align})

= CT.CanvasText text (CT.Font family_ \$ round size) align

instance ToCanvasOperations Shape where

toCanvasOperations (CompositeShape shapes Nothing Nothing)

= (concat.(map toCanvasOperations)) shapes

toCanvasOperations (CompositeShape shapes (Just translate) Nothing)

= [ CT.DoTransform CT.Save

, CT.DoTransform (CT.Translate screenPositionPoint)

] ++ drawOperations ++

[ CT.DoTransform CT.Restore

]

where

screenPositionPoint = roundPoint translate

drawOperations = toCanvasOperations (CompositeShape shapes Nothing Nothing)

toCanvasOperations text@(Text { position=p

, fillColor=fill

, strokeLineThickness=thick

, strokeColor=stroke

, rotationM=Nothing

})

= [CT.DrawText canvasText p' textStroke textFill]

where

canvasText = toCanvasText text

textFill = CT.TextFill (CT.CanvasColor screenFillColor)

textStroke = CT.TextStroke thick (CT.CanvasColor screenStrokeColor)

screenStrokeColor = roundColor stroke

screenFillColor = roundColor fill

p' = roundPoint p

toCanvasOperations (FilledMultiLine points fillWidth fillColor strokeThick strokeColor Nothing)

=  toCanvasOperations (MultiLine points (fillWidth + strokeThick) strokeColor Nothing)

++ toCanvasOperations (MultiLine points fillWidth fillColor Nothing)

toCanvasOperations shape

-- Might be any rotated shape

| isJust (rotationM shape) = [ CT.DoTransform CT.Save

, CT.DoTransform (CT.Translate screenRotationPoint)

, CT.DoTransform (CT.Rotate screenAngle)

]

++ (toCanvasOperations movedShape) ++

[ CT.DoTransform CT.Restore

]

-- Can only be Rectangle, Circle, RegularPolygon, Line, MultiLine or Polygon

| isJust screenPathPartsM  = [CT.DrawPath startingPoint screenPathParts pathStroke canvasPathFill]

| otherwise                = []

where

(Just rotation) = rotationM shape

shapePreRotate = shape{rotationM = Nothing}

rotationPoint = findRotationPoint shapePreRotate rotation

screenRotationPoint = roundPoint rotationPoint

(Rotation _ angle) = rotation

screenAngle = round angle

movedShape = translate (negateVector rotationPoint) shapePreRotate

canvasPathFill = toCanvasPathFill shape

screenPathPartsM = toScreenPathParts shape

Just (screenPathParts, startingPoint) = screenPathPartsM

screenStrokeColor = roundColor \$ strokeColor shape

thick = strokeLineThickness shape

pathStroke = CT.PathStroke thick (CT.CanvasColor screenStrokeColor)

class ToScreenPathPart a where

toScreenPathParts :: a -> Maybe ([CT.ScreenPathPart], CT.ScreenStartingPoint)

instance ToScreenPathPart Shape where

toScreenPathParts (Rectangle {position=p, dimensions=(w, h)})

= Just ([CT.Rectangle p' (w', h')], p')

where

p' = roundPoint p

w' = round w

h' = round h

= Just ([CT.Arc (p', r') 0 360], p')

where

p' = roundPoint p

r' = round r

= Just (lines ++ [CT.ClosePath], screenPoint)

where

polygonPoints = allRegularPolygonPoints n p r

(screenPoint:ps) = map roundPoint polygonPoints

lines = [CT.LineTo screenPoint' | screenPoint' <- (ps ++ [screenPoint])]

toScreenPathParts (Line {point1=p1, point2=p2})

= Just ([CT.LineTo p2'], p1')

where

p1' = roundPoint p1

p2' = roundPoint p2

toScreenPathParts (MultiLine {points=points})

| (length points) > 0 = Just (lines ++ [CT.MoveTo p1'], p1')

| otherwise           = Nothing

where

(p1':otherPoints') = map roundPoint points

lines = [CT.LineTo p' | p' <- otherPoints']

toScreenPathParts pol@(Polygon {points=points})

| (length points) > 0 = Just (lines ++ [CT.ClosePath], p1')

| otherwise           = Nothing

where

allPoints = allScreenPolygonPoints pol

(p1':otherPoints') = map roundPoint allPoints

lines = [CT.LineTo p' | p' <- otherPoints']

toCanvasPathFill :: Shape -> CT.PathFill

toCanvasPathFill shape

| hasCanvasPathFill shape = CT.PathFill (CT.CanvasColor screenFillColor)

| otherwise               = CT.NoPathFill

where

fillColor_ = fillColor shape

screenFillColor = roundColor fillColor_

hasCanvasPathFill :: Shape -> Bool

hasCanvasPathFill (Rectangle {})

= True

hasCanvasPathFill (Circle {})

= True

hasCanvasPathFill (RegularPolygon {})

= True

hasCanvasPathFill (Polygon {})

= True

hasCanvasPathFill _

= False

allScreenPolygonPoints :: Shape -> [Point]

allScreenPolygonPoints (Polygon {points=points})

| (length points) >= 2 = points ++ [firstP]

| otherwise            = points

where