{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TupleSections #-}

module Picture.Base (
    module Picture.Data,
    module Picture.Arc,
    module Color,
    blank,
    polygon,
    polygonWire,
    polygonZ,
    polygonCol,
    poly3,
    poly3Col,
    bezierQuad,
    arc,
    arcSolid,
    thickArc,
    --thickArcFull,
    thickCircle,
    thickLine,
    lineThick,
    thickLineCol,
    circleSolid,
    circleSolidCol,
    circle,
    line,
    lineCol,
    text,
    centerText,
    stackText,
    pictures,
    concatMapPic,
    appendPic,
    tranRot,
    translate,
    translate3,
    rotate,
    scale,
    color,
    zeroZ,
    setDepth,
    addDepth,
    setLayer,
    mirroryz,
    mirrorxz,
    overPos,
    picMap,
) where

import Color
import Data.Foldable
import Geometry
import Picture.Data
import Picture.Arc

blank :: Picture
{-# INLINE blank #-}
blank = mempty

polygonWire :: [Point2] -> Picture
{-# INLINE polygonWire #-}
polygonWire ps = line (ps ++ [head ps])

picFormat :: [Verx] -> Picture
picFormat = id

picMap :: (Verx -> Verx) -> Picture -> Picture
{-# INLINE picMap #-}
picMap = map

-- | Expects clockwise input.
polygon :: [Point2] -> Picture
{-# INLINE polygon #-}
polygon = picFormat . map f . polyToTris
  where
    f (V2 x y) = Verx (V3 x y 0) black [] BottomLayer polyNum

polygonZ :: [Point2] -> Float -> Picture
{-# INLINE polygonZ #-}
polygonZ ps z = picFormat . map (f . zeroZ) $ polyToTris ps
  where
    f pos = Verx pos black [z] BottomLayer polyzNum

polygonCol :: [(Point2, RGBA)] -> Picture
{-# INLINE polygonCol #-}
polygonCol = picFormat . polyToTris . map f
  where
    f (V2 x y, col) = Verx (V3 x y 0) col [] BottomLayer polyNum

poly3 :: [Point3] -> Picture
{-# INLINE poly3 #-}
poly3 = poly3Col . map (,black)

poly3Col :: [(Point3, RGBA)] -> Picture
{-# INLINE poly3Col #-}
poly3Col = picFormat . map f . polyToTris
  where
    f (pos, col) = Verx pos col [] BottomLayer polyNum

-- note that much of work computing the width of the bezier curve is done here
bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
bezierQuad cola colc ra rc a b c
    | a == b && b == c = blank
    | a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c
    | otherwise =
        bzhelp
            [ (aIn, cola, V2 (fa aIn) (fc aIn), V2 1 0)
            , (aIn, cola, V2 (fa aIn) (fc aIn), V2 1 0)
            , (cIn, colc, V2 (fa cIn) (fc cIn), V2 0 1)
            , (aX, cola, V2 1 0, V2 (fa' aX) (fc' aX))
            , (cX, colc, V2 0 1, V2 (fa' cX) (fc' cX))
            , (bX, colb, V2 0 0, V2 (fa' bX) (fc' bX))
            , (bX, colb, V2 0 0, V2 (fa' bX) (fc' bX))
            ]
  where
    colb = mixColors 0.5 0.5 cola colc
    b2a
        | isLHS a b c = a -.- b
        | otherwise = b -.- a
    aRadVec = 0.5 * ra *.* normalizeV (vNormal b2a)
    aX = a -.- aRadVec
    aIn = a +.+ aRadVec
    b2c
        | isLHS a b c = b -.- c
        | otherwise = c -.- b
    cRadVec = 0.5 * rc *.* normalizeV (vNormal b2c)
    cX = c -.- cRadVec
    cIn = c +.+ cRadVec
    bRadVec = 0.25 * (ra + rc) *.* normalizeV (a +.+ b -.- 2 *.* c)
    bX = b +.+ bRadVec
    bIn = b -.- bRadVec
    fa = extrapolate aX cX bX
    fc = extrapolate cX aX bX
    fa' = extrapolate aIn cIn bIn
    fc' = extrapolate cIn aIn bIn

bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture
bzhelp = picFormat . map f
  where
    f (V2 x y, col, V2 a b, V2 c d) = Verx (V3 x y 0) col [a, b, c, d] BottomLayer bezNum

-- given a one and two zeros of a linear function over x and y,
-- determine the function
-- so if f(ox,oy) = 1 and f(ax,ay) = f(bx,by) = 0, determines f
extrapolate :: Point2 -> Point2 -> Point2 -> Point2 -> Float
extrapolate (V2 ox oy) (V2 ax ay) (V2 bx by) (V2 x y) =
    ( x * (ay - by)
        + y * (bx - ax)
        + (ax * by - bx * ay)
    )
        / ( ox * (ay - by)
                + ax * (by - oy)
                + bx * (oy - ay)
          )

color :: RGBA -> Picture -> Picture
{-# INLINE color #-}
color = picMap . overCol . const

translateH :: Float -> Float -> Point3 -> Point3
{-# INLINE translateH #-}
translateH !a !b (V3 x y z) = V3 (x + a) (y + b) z

translate :: Float -> Float -> Picture -> Picture
{-# INLINE translate #-}
translate x = picMap . overPos . translateH x

translate3 :: Point3 -> Picture -> Picture
{-# INLINE translate3 #-}
translate3 = picMap . overPos . (+.+.+)

tranRot :: V2 Float -> Float -> Picture -> Picture
{-# INLINE tranRot #-}
tranRot (V2 x y) r = picMap $ overPos (translateH x y . rotate3 r)

setDepth :: Float -> Picture -> Picture
{-# INLINE setDepth #-}
--setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
setDepth d = picMap $ overPos (\(V3 x y _) -> V3 x y d)

addDepth :: Float -> Picture -> Picture
{-# INLINE addDepth #-}
--addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
addDepth d = picMap $ overPos (\(V3 x y z) -> V3 x y (z + d))

-- TODO change the Int here to a dedicated type
setLayer :: Layer -> Picture -> Picture
{-# INLINE setLayer #-}
setLayer i = picMap f
  where
    f v = v{_vxLayer = i}

scale3 :: Float -> Float -> Point3 -> Point3
{-# INLINE scale3 #-}
scale3 a b (V3 x y z) = V3 (x * a) (y * b) z

scale :: Float -> Float -> Picture -> Picture
{-# INLINE scale #-}
scale x = picMap . overPos . scale3 x

rotate :: Float -> Picture -> Picture
{-# INLINE rotate #-}
rotate = picMap . overPos . rotate3

concatMapPic :: Foldable t => (a -> Picture) -> t a -> Picture
{-# INLINE concatMapPic #-}
concatMapPic = foldMap

appendPic :: Picture -> Picture -> Picture
{-# INLINE appendPic #-}
appendPic = (<>)

pictures :: Foldable t => t Picture -> Picture
{-# INLINEABLE pictures #-}
pictures = fold

makeArc :: Float -> Point2 -> [Point2]
{-# INLINE makeArc #-}
makeArc rad (V2 a b) = map (`rotateV` V2 0 rad) angles
  where
    angles = [a, a + step .. b]
    step = pi * 0.2

circleSolid :: Float -> Picture
{-# INLINE circleSolid #-}
circleSolid = circleSolidCol white white

circleSolidCol :: Color -> Color -> Float -> Picture
{-# INLINE circleSolidCol #-}
circleSolidCol colC colE r =
    picFormat $
        map
            f
            [ (V3 (- r) r 0, colC)
            , (V3 (- r) (- r) 0, colE)
            , (V3 r (- r) 0, black)
            ]
  where
    f (pos, col) = Verx pos col [] BottomLayer ellNum

circle :: Float -> Picture
{-# INLINE circle #-}
circle rad = thickArc 0 (2 * pi) rad 1

centerText :: String -> Picture
{-# INLINE centerText #-}
centerText s = translate (25 + 50 * (negate . fromIntegral $ length s - 1)) 0 $ text s

stackText :: [String] -> Picture
{-# INLINE stackText #-}
stackText = mconcat . zipWith (\y s -> translate 0 y $ centerText s) [0, 100 ..]

text :: String -> Picture
{-# INLINE text #-}
text = picFormat . map f . stringToList
  where
    f (pos, col, V2 a b) = Verx pos col [a, b] BottomLayer textNum

line :: [Point2] -> Picture
{-# INLINE line #-}
line = thickLine 1

lineCol :: [(Point2, RGBA)] -> Picture
{-# INLINE lineCol #-}
lineCol = thickLineCol 1

lineThick :: Float -> [Point2] -> Picture
{-# INLINE lineThick #-}
lineThick t = pictures . f
  where
    f (x : y : ys)
        | x == y = f (x : ys)
        | otherwise = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y : ys)
    f _ = []
    n a b = (t * 0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))

thickLine :: Float -> [Point2] -> Picture
{-# INLINE thickLine #-}
thickLine t = pictures . f
  where
    f (x : y : ys)
        | x == y = f (x : ys)
        | otherwise = polygon [x +.+ n, x -.- n, y -.- n, y +.+ n] : f (y : ys)
      where
        n = (t * 0.5) *.* errorNormalizeV 42 (vNormal (x -.- y))
    f _ = []

thickLineCol :: Float -> [(Point2, RGBA)] -> Picture
{-# INLINE thickLineCol #-}
thickLineCol t = pictures . f
  where
    f ((x, c) : (y, c') : ys)
        | x == y = f ((x, c) : ys)
        | otherwise =
            polygonCol
                [ (x +.+ n x y, c)
                , (x -.- n x y, c)
                , (y -.- n x y, c')
                , (y +.+ n x y, c')
                ] :
            f ((y, c') : ys)
    f _ = []
    n a b = (t * 0.5) *.* squashNormalizeV (vNormal (a -.- b))

thickCircle :: Float -> Float -> Picture
{-# INLINE thickCircle #-}
thickCircle = thickArc 0 (2 * pi)

arcSolid ::
    -- | Start angle
    Float ->
    -- | End angle
    Float ->
    -- | Radius
    Float ->
    Picture
{-# INLINE arcSolid #-}
arcSolid startA endA rad = polygon $ V2 0 0 : makeArc rad (V2 startA endA)

arc ::
    -- | Start angle
    Float ->
    -- | End angle
    Float ->
    -- | Radius
    Float ->
    Picture
arc startA endA rad = thickArc startA endA rad 1
{-# INLINE arc #-}

--thickArcFull :: Float -> Float -> Color -> Float -> Float -> Color -> Float -> Picture
--{-# INLINE thickArcFull #-}
--thickArcFull sa sw sc ea ew ec rad 
--    | difference sa ea > pi / 2 = thickArcFull sa sw sc ma mw mc rad <> thickArcFull ma mw mc ea ew ec rad
--    | otherwise = map f
--            [ (V3 0 0 0, mc, V3 0 0 mw)
--            , (V3 xa ya 0, sc, V3 1 0 sw)
--            , (V3 xb yb 0, mc, V3 1 1 mw)
--            , (V3 0 0 0, sc, V3 0 0 sw)
--            , (V3 xb yb 0, mc, V3 1 1 mw)
--            , (V3 xc yc 0, ec, V3 0 1 ew)
--            ]
--  where
--    (V2 xa ya) = rotateV sa (V2 rad 0)
--    (V2 xb yb) = rotateV (0.5 * (sa + ea)) (V2 (rad * sqrt 2) 0)
--    (V2 xc yc) = rotateV ea (V2 rad 0)
--    f (pos, col, V3 a b c) = Verx pos col [a, b, c] BottomLayer arcNum
--    ma = 0.5 * (sa + ea)
--    mw = 0.5 * (sw + ew)
--    mc = mixColors 0.5 0.5 sc ec

thickArc :: Float -> Float -> Float -> Float -> Picture
{-# INLINE thickArc #-}
thickArc startA endA rad wdth = arcFull startA wdth white endA wdth white rad white
--thickArc startA endA rad wdth
--    | endA - startA > (pi / 2) =
--        pictures
--            [ thickArc (startA + pi / 2) endA rad wdth
--            , thickArcHelp startA (startA + pi / 2) r w
--            ]
--    | otherwise = thickArcHelp startA endA r w
--  where
--    r = rad + 0.5 * wdth
--    w = 1 - wdth / r

--thickArcHelp :: Float -> Float -> Float -> Float -> Picture
--{-# INLINE thickArcHelp #-}
--thickArcHelp startA endA rad wdth =
--    picFormat $
--        map
--            f
--            [ (V3 0 0 0, black, V3 0 0 wdth)
--            , (V3 xa ya 0, black, V3 1 0 wdth)
--            , (V3 xb yb 0, black, V3 1 1 wdth)
--            , (V3 0 0 0, black, V3 0 0 wdth)
--            , (V3 xb yb 0, black, V3 1 1 wdth)
--            , (V3 xc yc 0, black, V3 0 1 wdth)
--            ]
--  where
--    (V2 xa ya) = rotateV startA (V2 rad 0)
--    (V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * sqrt 2) 0)
--    (V2 xc yc) = rotateV endA (V2 rad 0)
--    f (pos, col, V3 a b c) = Verx pos col [a, b, c] BottomLayer arcNum

-- Currently the lens version is much slower
overPos :: (Point3 -> Point3) -> Verx -> Verx
{-# INLINE overPos #-}
--overPos = over vxPos
overPos f vx = vx{_vxPos = f (_vxPos vx)}

overCol :: (Point4 -> Point4) -> Verx -> Verx
{-# INLINE overCol #-}
overCol f vx = vx{_vxCol = f (_vxCol vx)}

-- no premature optimisation, consider changing to use texture arrays
stringToList :: String -> [(Point3, Point4, Point2)]
{-# INLINE stringToList #-}
stringToList = concatMap (uncurry charToTuple) . zip [0, 0.9 * dimText ..]
  where
    dimText = 100

charToTuple :: Float -> Char -> [(Point3, Point4, Point2)]
{-# INLINE charToTuple #-}
charToTuple x c =
    [ (V3 (x -50) (-100) 0, white, V2 offset 1)
    , (V3 (x -50) 100 0, white, V2 offset 0)
    , (V3 (x + 50) 100 0, white, V2 (offset + 1) 0)
    , (V3 (x -50) (-100) 0, white, V2 offset 1)
    , (V3 (x + 50) (-100) 0, white, V2 (offset + 1) 1)
    , (V3 (x + 50) 100 0, white, V2 (offset + 1) 0)
    ]
  where
    offset = fromIntegral (fromEnum c) - 32

mirrorxz :: Picture -> Picture
mirrorxz = picMap (overPos flipy)
  where
    flipy (V3 x y z) = V3 x (negate y) z

mirroryz :: Picture -> Picture
mirroryz = picMap (overPos flipx)
  where
    flipx (V3 x y z) = V3 (negate x) y z