module Main where

import qualified Codec.Picture.Png as PNG
import qualified Codec.Picture as Pic

import qualified Polygon
import qualified Line
import Polygon (Polygon(PolygonCW))
import Line (Line2, Line(Segment))
import Point2 (Point2(Point2), distance)

import qualified Data.List.Match as Match
import Control.Monad (liftM2)
import Data.List.HT (removeEach)
import Data.Maybe.HT (toMaybe)
import Data.Maybe (catMaybes, mapMaybe)


project ::
   (Fractional a, Ord a) =>
   Point2 a -> (Point2 a, Point2 a) -> Maybe (Point2 a)
project x (a, b) =
   let (r, _, _, y) = Line.distanceAux a b x
   in  toMaybe (0<=r && r<=1) y

segments :: (Eq a, Num a) => [Point2 a] -> [Line2 a]
segments = map (uncurry Segment) . Polygon.edges

intersections ::
   (Fractional a, Ord a) =>
   [Line2 a] -> [Line2 a] -> [Point2 a]
intersections segments0 segments1 =
   catMaybes $ liftM2 Line.intersect segments0 segments1

averageRGB :: (Eq a, Fractional a) => [(a, (a,a,a))] -> (a,a,a)
averageRGB weightColors =
   let (rs0, cs) = unzip weightColors
       rs = if all (0==) rs0 then Match.replicate rs0 1 else rs0
       rsum = sum rs
       scale r (red,green,blue) = (r*red, r*green, r*blue)
       add (red0,green0,blue0) (red1,green1,blue1) =
          (red0+red1, green0+green1, blue0+blue1)
   in  foldl1 add $ zipWith (\r c -> scale (r/rsum) c) rs cs

polyMany ::
   (Floating a, RealFrac a) =>
   [((a,a,a), [Point2 a])] -> Pic.Image Pic.PixelRGB8
polyMany colorPointss =
   let pointss = map snd colorPointss
       polys = map PolygonCW pointss
       intPointss =
          map
             (\(points, otherPointss) ->
                intersections (segments points)
                   (concatMap segments otherPointss)) $
          removeEach pointss
       render xi yi =
          let x = fromIntegral xi
              y = fromIntegral yi
              p = Point2 (x,y)
              minDist intPoints others this =
                 minimum $ map (distance p) $
                 (intPoints ++) $
                 filter (\q -> any (flip Polygon.contains q) others) $
                 (this++) $ mapMaybe (project p) $ Polygon.edges this
              minDists =
                 zipWith
                    (\intPoints (this, others) ->
                       minDist intPoints (map PolygonCW others) this)
                    intPointss (removeEach pointss)
              contained = map (flip Polygon.contains p) polys
              weightColors =
                 map snd $
                 filter fst $
                 zip contained $
                 zip minDists (map fst colorPointss)
              (red,green,blue) =
                 case weightColors of
                    [] -> (1,1,1)
                    [(_, color)] -> color
                    _ -> averageRGB weightColors
          in  Pic.PixelRGB8
                 (round (red*255)) (round (green*255)) (round (blue*255))
   in  Pic.generateImage render 256 256

poly2 ::
   (Floating a, RealFrac a) =>
   [Point2 a] -> [Point2 a] -> Pic.Image Pic.PixelRGB8
poly2 points0 points1 =
   let poly0 = PolygonCW points0
       poly1 = PolygonCW points1
       intPoints = intersections (segments points0) (segments points1)
       render xi yi =
          let x = fromIntegral xi
              y = fromIntegral yi
              p = Point2 (x,y)
              minDist other this =
                 minimum $ map (distance p) $
                 (intPoints ++) $ filter (Polygon.contains other) $
                 (this++) $ mapMaybe (project p) $ Polygon.edges this
              minDist0 = minDist poly1 points0
              minDist1 = minDist poly0 points1
              scale = 255 / (minDist0 + minDist1)
          in  case (Polygon.contains poly0 p, Polygon.contains poly1 p) of
                 (False, False) -> Pic.PixelRGB8 255 255 255
                 (False, True) -> Pic.PixelRGB8 0 0 255
                 (True, False) -> Pic.PixelRGB8 255 0 0
                 (True, True) ->
                    Pic.PixelRGB8
                       (round (minDist0*scale)) 0
                       (round (minDist1*scale))
   in  Pic.generateImage render 256 256


triangle :: Pic.Image Pic.PixelRGB8
triangle =
   let poly = PolygonCW [Point2 (10, 10), Point2 (200, 100), Point2 (100, 200)]
       render xi yi =
          let x, y :: Integer
              x = fromIntegral xi
              y = fromIntegral yi
          in  if Polygon.contains poly $ Point2 (x, y)
                then Pic.PixelRGB8 0 0 255
                else Pic.PixelRGB8 255 255 255
   in  Pic.generateImage render 256 256


gradient :: Pic.Image Pic.PixelRGB8
gradient =
   Pic.generateImage
      (\x y -> Pic.PixelRGB8 (fromIntegral x) (fromIntegral y) 128)
      256 256


triA, triB :: [Point2 Double]
triA = [Point2 (10, 10), Point2 (245, 100), Point2 (100, 245)]
triB = map (\(Point2 (x,y)) -> Point2 (255-x,y)) triA

isoBox :: (Eq a, Num a) => (a, a) -> (a, a) -> [Point2 a]
isoBox (l,t) (r,b) =
   [Point2 (l,t), Point2 (r,t), Point2 (r,b), Point2 (l,b)]

boxA, boxB :: [Point2 Double]
boxA = isoBox (10, 10) (200, 200)
boxB = isoBox (55, 55) (245, 245)

buxA, buxB, buxC, buxD :: [Point2 Double]
buxA = isoBox ( 10, 10) (150, 100)
buxB = isoBox (110, 10) (250, 100)
buxC = isoBox ( 30, 50) (170, 150)
buxD = isoBox (110, 80) (249, 170)

main :: IO ()
main = do
   PNG.writePng "/tmp/mixed.png" $
      polyMany [((1,0,0), boxA), ((1,1,0), boxB),
                ((0,1,0), triA), ((0,0,1), triB)]
   PNG.writePng "/tmp/boxes.png" $
      polyMany [((1,0,0), buxA), ((1,1,0), buxB),
                ((0,1,0), buxC), ((0,0,1), buxD)]
   PNG.writePng "/tmp/box2.png" $ poly2 boxA boxB
   PNG.writePng "/tmp/triangle2.png" $ poly2 triA triB
   PNG.writePng "/tmp/triangle.png" triangle
   PNG.writePng "/tmp/test.png" gradient