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]

                        | CircleArea Point Radius

                        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]

                                    anglesRads = map degreesToRadians anglesDeg





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

    toScreenPathParts (Circle {position=p, radius=r})

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

        where

            p' = roundPoint p

            r' = round r

    toScreenPathParts (RegularPolygon {position=p, numberOfPoints=n, radius=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

        firstP = head points

        lastP  = last points