{-# LANGUAGE TupleSections, TypeFamilies, MultiParamTypeClasses, TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
-- module Triangles
-- ( getRandomPixel
-- , getRandomTriangle
-- , getPointsInTriangle
-- , getTriangleAverageRGB
-- ) where

module Triangles where

import System.Random
import Data.Ratio
import qualified Debug.Trace
import qualified Data.Colour.SRGB.Linear as C
import Control.Parallel.Strategies
import qualified Data.Colour as C
import Data.Colour.SRGB.Linear (Colour)
import Data.Vector.Generic.Base (Vector)
import Data.Vector.Generic.Mutable (MVector)
import Data.List
import Data.Maybe
import qualified Data.Vector.Unboxed as Vec
import Data.Fixed
import Data.Vector.Unboxed.Deriving
import Diagrams.TwoD
import Diagrams.Prelude
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Arrow
-- import qualified Linear.Affine as L
type Image_ = Vec.Vector Pixel_
type Pixel_ = Colour Double
-- type Point = (Double, Double)
-- type Triangle = (Point, Point, Point)

toSRGBTuple :: Pixel_ -> (Double, Double, Double)
toSRGBTuple = srgb' . C.toRGB
    where
        srgb' (C.RGB {C.channelRed = red, C.channelGreen = green, C.channelBlue = blue}) = (red, green, blue)

fromSRGBTuple :: (Double, Double, Double) -> Pixel_
fromSRGBTuple (r, g, b) = C.rgb r g b

derivingUnbox "Pixel_"
    [t| Pixel_ -> (Double, Double, Double)|]
    [| toSRGBTuple |]
    [| fromSRGBTuple |]


randomPoints :: StdGen -> [(Double, Double)]
randomPoints = map (bimap toZeroToOneTuple toZeroToOneTuple) . randomRs ((0 :: Word, 0 :: Word), (maxBound, maxBound))
  where
    toZeroToOneTuple :: Word -> Double
    toZeroToOneTuple x = (fromIntegral x / (fromIntegral (maxBound :: Word)))

-- toPlanarGraph :: [Point P2 Double] -> [(Point P2 Double, Point P2 Double)]
-- toPlanarGraph :: [P2 Double] -> [Located (Path V2 Double)]
-- toPlanarGraph :: (V a ~ V2, TrailLike a) => [Point V2 (N a)] -> [(Point P2 Double, Point P2 Double)]

combinations :: (Floating b, Foldable (Diff p), Affine p, Ord b, Ord (p b)) => [p b] -> [(p b, p b)]
combinations xs =
  sortOn (abs . uncurry distanceA)
  . S.toList . S.fromList
  . filter (uncurry (/=))
  . concat . withStrategy (parListChunk 1000 rseq)
  . map (\x -> take edgeLengthThreshold . sortOn (abs . uncurry distanceA)
  . map (\y -> (min x y, max x y)) $ xs) $ xs
  where
    edgeLengthThreshold = 45

toPlanarGraph :: (Floating b, Ord b) => [Point V2 b] -> [(Point V2 b, Point V2 b)]
toPlanarGraph points =
  removeIntersections . combinations $ points
  where
    numPoints = length points

    removeIntersections = foldl' addIfNoIntersection []

    addIfNoIntersection xs x = if all (noIntersection x) xs then (x:xs) else xs

    noIntersection l1 l2 = (==) sharedEndPoint . length $ intersectPointsT (uncurry toLocatedTrail l1) (uncurry toLocatedTrail l2)
      where
        sharedEndPoint = (-) 4 . length . nub $ [fst l1, snd l1, fst l2, snd l2]

toLocatedTrail :: TrailLike a => Point (V a) (N a) -> Point (V a) (N a) -> Located a
toLocatedTrail p1 p2 = fromVertices [p1, p2] `at` p1


findTriangles :: Ord b => [(b, b)] -> S.Set (S.Set b)
findTriangles edges = S.unions . S.map threeCyclesOf . M.keysSet $ adjacencyMap
  where

    threeCyclesOf node =  S.unions
      . S.map (\x -> S.map (\y ->  S.fromList [node, x, y]) $ S.delete node . S.intersection originalNodeNeighbors . (M.!) adjacencyMap $ x) $ originalNodeNeighbors
      where
        originalNodeNeighbors = fromMaybe S.empty (adjacencyMap M.!? node)

    adjacencyMap = M.fromListWith S.union . map (second S.singleton) $ (edges ++ edgesReversed)
    edgesReversed = map (\(a, b) -> (b, a)) edges

pointsInTriangle tri = []
  where
    [fst, snd, thrd] = S.toList tri


getPointsInTriangle :: p -> S.Set (P2 Int) -> [(Int, Int)]
getPointsInTriangle image pts = S.toList . S.unions . map S.fromList $ [
                                 ptsBtween (makeLine p1 p3) (makeLine p1 p2),
                                 ptsBtween (makeLine p1 p3) (makeLine p2 p3),
                                 ptsBtween (makeLine p1 p2) (makeLine p2 p3)]
    where
        [p1, p2, p3] = sortOn fst . map (\(y, x) -> (x,y)) . map unp2 . S.toList $ pts

blendEqually colors = C.affineCombo (zip (repeat fraction) colors) $ C.black
    where
        fraction = 1.0 / (fromIntegral . length $ colors)

getTriangleAverageRGB :: Image_ -> (Int, Int)-> S.Set (P2 Int)  -> C.Colour Double
getTriangleAverageRGB image (y', x') triangle = blendEqually pixels
    where

        pixels :: [Pixel_]
        pixels = mapMaybe index' points

        points :: [(Int, Int)]
        points = getPointsInTriangle image triangle

        -- I got so upset that I put this function in here instead of in general scope that I went to bed for the night.
        index' :: (Int, Int) -> Maybe Pixel_
        index' (y, x)
            | y >= y' = Nothing
            | x >= x' = Nothing
            | y < 0   = Nothing
            | x < 0   = Nothing
            | otherwise = image Vec.!? ((y * x') + x)

ptsBtween :: LineMXB -> LineMXB -> [(Int, Int)]
ptsBtween l1 l2 = concatMap rasterLine . noSingletons $ [startingX .. endingX]
    where
        startingX = max (startX l1) (startX l2)
        endingX   = min (endX l1) (endX l2)

        rasterLine x = map (\y -> (y, x)) $ range' (yAt l1 x) (yAt l2 x)

noSingletons :: [a] -> [a]
noSingletons [x] = []
noSingletons l   = l

range' :: Int -> Int -> [Int]
range' a b = [(min a b) .. (max a b)]

yAt :: LineMXB -> Int -> Int
yAt (LineMXB {m = m, b = b}) x = round $ (m * (fromIntegral x)) + b

-- -- y = mx + b
-- -- y - mx = b

makeLine :: (Int, Int) -> (Int, Int) -> LineMXB
makeLine (y1, x1) (y2, x2) = LineMXB {
    m = slope,
    b = (fromIntegral y1) - (slope * (fromIntegral x1)),
    startX = min x1 x2,
    endX = max x1 x2
                                  }
    where
      slope = if x1 /= x2
        then (fromIntegral $ y1 - y2) % (fromIntegral $ x1 - x2)
        else fromIntegral . ceiling $ ((10.0 :: Double) ** 100.0)

data LineMXB = LineMXB
    {
        m :: Rational,
        b :: Rational,
        startX :: Int,
        endX :: Int
    } deriving (Show, Ord, Eq)

-- isPointInTriangle :: Triangle -> Point -> Bool
-- isPointInTriangle (v1, v2, v3) pt = not (has_neg && has_pos)
--     where
--         d1 = sign pt v1 v2
--         d2 = sign pt v2 v3
--         d3 = sign pt v3 v1

--         has_neg = (d1 < 0) || (d2 < 0) || (d3 < 0)
--         has_pos = (d1 > 0) || (d2 > 0) || (d3 > 0)

--         sign :: Point -> Point -> Point -> Int
--         sign p1 p2 p3 = (fst p1 - fst p3) * (snd p2 - snd p3) - (fst p2 - fst p3) * (snd p1 - snd p3)
