{-# LANGUAGE TupleSections #-}
module Geometry.Zone
    ( ddaExt
    ) 
    where
import Geometry.Data

import Data.Foldable
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS

foldl2'
    :: (b -> a -> a -> b) 
    -> b 
    -> [a]
    -> b
foldl2' f s (t:ts) = fst $ foldl' g (s, t) ts
  where
    g (r,x) y = (f r x y,y)
foldl2' _ s _ = s

sortArguments 
    :: Ord a 
    => (a -> a -> b)
    -> a -> a -> b
sortArguments f x y
    | x < y = f x y
    | otherwise = f y x
sortArgumentsReverse
    :: Ord a 
    => (a -> a -> [b])
    -> a -> a -> [b]
sortArgumentsReverse f x y
    | x < y = f x y
    | otherwise = reverse $ f y x

intervalBounds
    :: Float    -- ^ interval threshold
    -> Float    -- ^ First endpoint
    -> Float    -- ^ Second endpoint
    -> [Float]
intervalBounds = sortArgumentsReverse . f
  where 
    f r a b 
        | x > b = [a]
        | otherwise = (a : [x,x+r..b])
      where
        x = floorTo r a + r

floorTo :: Float -> Float -> Float
floorTo r x = r * (fromIntegral ((floor $ x / r) :: Int))

ceilingTo :: Float -> Float -> Float
ceilingTo r x = r * (fromIntegral ((ceiling $ x / r) :: Int))

divTo :: Float -> Float -> Int
{-# INLINE divTo #-}
divTo s = floor . (/s)

flipV :: Point2 -> Point2
{-# INLINE flipV #-}
flipV (V2 a b) = V2 b a

applyInverted 
    :: (Point2 -> Point2 -> [Point2])
    -> Point2 -> Point2 -> [Point2]
applyInverted f sp@(V2 sx sy) ep@(V2 ex ey)
    | abs (sx-ex) > abs (sy-ey) = f sp ep
    | otherwise = map flipV $ f (flipV sp) (flipV ep)

sizeZoneOfPoint' :: Float -> Point2 -> V2 Int
sizeZoneOfPoint' s = fmap (divTo s)

increasingInterval :: Int -> Int -> [Int]
increasingInterval x y
    | y > x = [x .. y]
    | otherwise = [y .. x]

-- | Determines which horizontal and vertical lines on a grid are crossed by a
-- line. For each adds the x-y index of the square to the right or above the
-- crossed grid line. Also adds the index of the square containing the start
-- point.
ddaExt :: Float -> V2 Float -> V2 Float -> IM.IntMap IS.IntSet
ddaExt s sp@(V2 sx sy) ep@(V2 ex ey) 
    | x1 <= x2 = addys . IM.fromDistinctAscList $ zip [x1 .. x2] 
                    $ map (IS.singleton . divTo s) [x1y,x1y+ydx..]
    | otherwise = addys . IM.fromDistinctAscList $ zip [x2-1 .. x1-1]
                    $ map (IS.singleton . divTo s) [x2y,x2y+ydx..]
  where
    x1 = divTo s sx
    x2 = divTo s ex
    x1y = fx' sp ep $ s * (fromIntegral x1)
    x2y = fx' sp ep $ s * (fromIntegral x2)
    ydx = s * ydx' sp ep
    addys m = add2s m ypairs 
    y1 = divTo s sy
    y2 = divTo s ey
    y1x = fy' sp ep $ s * (fromIntegral y1)
    y2x = fy' sp ep $ s * (fromIntegral y2)
    xdy = s * xdy' sp ep
    ypairs 
        | y1 <= y2  = zip (map (divTo s) [y1x,y1x+xdy..])
                         [y1 .. y2] 
        | otherwise = zip (map (divTo s) [y2x,y2x+xdy..])
                         [y2-1 .. y1-1] 

ydx' :: Point2 -> Point2 -> Float
{-# INLINE ydx' #-}
ydx' (V2 sx sy) (V2 ex ey)
    | sx == ex = 0
    | otherwise = (ey - sy) / (ex - sx)
xInt' :: Float -> Point2 -> Point2 -> Float
xInt' s (V2 sx _) (V2 ex _)
    | ex > sx = ceilingTo s sx
    | otherwise = floorTo s sx
fx' :: Point2 -> Point2 -> Float -> Float
fx' sp@(V2 sx sy) ep@(V2 _ ey) x
    | sy == ey = sy
    | otherwise = sy + ydx' sp ep * (x - sx)

xdy' :: Point2 -> Point2 -> Float
xdy' (V2 sx sy) (V2 ex ey)
    | sy == ey = 0
    | otherwise = (ex - sx) / (ey - sy)
yInt' :: Float -> Point2 -> Point2 -> Float
yInt' s (V2 _ sy) (V2 _ ey)
    | ey > sy = ceilingTo s sy
    | otherwise = floorTo s sy
fy' :: Point2 -> Point2 -> Float -> Float
fy' sp@(V2 sx sy) ep@(V2 ex _) y
    | sx == ex = sx
    | otherwise = sx + xdy' sp ep * (y - sy)

add2s :: IM.IntMap IS.IntSet -> [(Int,Int)] -> IM.IntMap IS.IntSet
{-# INLINE add2s #-}
add2s imis = foldl' 
    (\m (k,x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m)
    imis

addV2s :: IM.IntMap IS.IntSet -> [V2 Int] -> IM.IntMap IS.IntSet
{-# INLINE addV2s #-}
addV2s imis = foldl' 
    (\m (V2 k x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m)
    imis

pairsToIntMapSet :: [V2 Int] -> IM.IntMap IS.IntSet
pairsToIntMapSet = foldl' 
    (\m (V2 k x) -> IM.insertWith (\_ old -> IS.insert x old) k (IS.singleton x) m)
    IM.empty