{-# LANGUAGE BangPatterns #-}
-- | Handle straight lines polygon.

module Graphics.Rasterific.Line
    ( lineFromPath
    , decomposeLine
    , clipLine
    , sanitizeLine
    , sanitizeLineFilling
    , lineBreakAt
    , flattenLine
    , lineLength
    , offsetLine
    , isLinePoint
    , extendLine
    ) where

import Graphics.Rasterific.Linear
             ( V2( .. )
             , (^-^)
             , (^+^)
             , (^*)
             , lerp
             , norm )

import Graphics.Rasterific.Operators
import Graphics.Rasterific.Types

-- | Transform a list a point to a list of lines

--

-- > lineFromPath [a, b, c, d] = [Line a b, Line b c, Line c d]

--

lineFromPath :: [Point] -> [Line]
lineFromPath :: [Point] -> [Line]
lineFromPath [] = []
lineFromPath lst :: [Point]
lst@(Point
_:[Point]
rest) =
    (Point -> Point -> Line) -> (Point, Point) -> Line
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Point -> Point -> Line
Line ((Point, Point) -> Line) -> [(Point, Point)] -> [Line]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Point] -> [Point] -> [(Point, Point)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Point]
lst [Point]
rest

isLinePoint :: Line -> Bool
isLinePoint :: Line -> Bool
isLinePoint (Line Point
a Point
b) = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Point
a Point -> Point -> Bool
`isDistingableFrom` Point
b

lineLength :: Line -> Float
lineLength :: Line -> Float
lineLength (Line Point
a Point
b) = Point -> Float
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm (Point
b Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
a)

sanitizeLine :: Line -> Container Primitive
sanitizeLine :: Line -> Container Primitive
sanitizeLine l :: Line
l@(Line Point
p1 Point
p2)
  | Point
p1 Point -> Point -> Bool
`isNearby` Point
p2 = Container Primitive
forall a. Monoid a => a
mempty
  | Bool
otherwise = Primitive -> Container Primitive
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Primitive -> Container Primitive)
-> Primitive -> Container Primitive
forall a b. (a -> b) -> a -> b
$ Line -> Primitive
LinePrim Line
l

sanitizeLineFilling :: Line -> Container Primitive
sanitizeLineFilling :: Line -> Container Primitive
sanitizeLineFilling l :: Line
l@(Line Point
p1 Point
p2)
  | Point -> Bool
isDegenerate Point
p1 Bool -> Bool -> Bool
|| Point -> Bool
isDegenerate Point
p2 = Container Primitive
forall a. Monoid a => a
mempty
  | Bool
otherwise = Primitive -> Container Primitive
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Primitive -> Container Primitive)
-> Primitive -> Container Primitive
forall a b. (a -> b) -> a -> b
$ Line -> Primitive
LinePrim Line
l

lineBreakAt :: Line -> Float -> (Line, Line)
lineBreakAt :: Line -> Float -> (Line, Line)
lineBreakAt (Line Point
a Point
b) Float
t = (Point -> Point -> Line
Line Point
a Point
ab, Point -> Point -> Line
Line Point
ab Point
b)
  where ab :: Point
ab = Float -> Point -> Point -> Point
forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp Float
t Point
b Point
a

flattenLine :: Line -> Container Primitive
flattenLine :: Line -> Container Primitive
flattenLine = Primitive -> Container Primitive
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Primitive -> Container Primitive)
-> (Line -> Primitive) -> Line -> Container Primitive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> Primitive
LinePrim

offsetLine :: Float -> Line -> Container Primitive
offsetLine :: Float -> Line -> Container Primitive
offsetLine Float
offset (Line Point
a Point
b) = Primitive -> Container Primitive
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Primitive -> Container Primitive)
-> (Line -> Primitive) -> Line -> Container Primitive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> Primitive
LinePrim (Line -> Container Primitive) -> Line -> Container Primitive
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Line
Line Point
shiftedA Point
shiftedB
  where
   u :: Point
u = Point
a Point -> Point -> Point
forall v. (Floating v, Epsilon v) => V2 v -> V2 v -> V2 v
`normal` Point
b
   shiftedA :: Point
shiftedA = Point
a Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ (Point
u Point -> Float -> Point
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* Float
offset)
   shiftedB :: Point
shiftedB = Point
b Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^+^ (Point
u Point -> Float -> Point
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^* Float
offset)

-- | Clamp the bezier curve inside a rectangle

-- given in parameter.

clipLine :: Point     -- ^ Point representing the "minimal" point for cliping

         -> Point     -- ^ Point representing the "maximal" point for cliping

         -> Line      -- ^ The line

         -> Container Primitive
clipLine :: Point -> Point -> Line -> Container Primitive
clipLine Point
mini Point
maxi poly :: Line
poly@(Line Point
a Point
b)
    -- If we are in the range bound, return the curve

    -- unaltered

    | Bool
insideX Bool -> Bool -> Bool
&& Bool
insideY = Primitive -> Container Primitive
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Primitive -> Container Primitive)
-> (Line -> Primitive) -> Line -> Container Primitive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> Primitive
LinePrim (Line -> Container Primitive) -> Line -> Container Primitive
forall a b. (a -> b) -> a -> b
$ Line
poly
    -- If one of the component is outside, clamp

    -- the components on the boundaries and output a

    -- straight line on this boundary. Useful for the

    -- filing case, to clamp the polygon drawing on

    -- the edge

    | Bool
outsideX Bool -> Bool -> Bool
|| Bool
outsideY = Primitive -> Container Primitive
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Primitive -> Container Primitive)
-> (Line -> Primitive) -> Line -> Container Primitive
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Line -> Primitive
LinePrim (Line -> Container Primitive) -> Line -> Container Primitive
forall a b. (a -> b) -> a -> b
$ Point -> Point -> Line
Line Point
clampedA Point
clampedB

    -- Not completly inside nor outside, just divide

    -- and conquer.

    | Bool
otherwise = Line -> Container Primitive
recurse (Point -> Point -> Line
Line Point
a Point
m) Container Primitive -> Container Primitive -> Container Primitive
forall a. Semigroup a => a -> a -> a
<> Line -> Container Primitive
recurse (Point -> Point -> Line
Line Point
m Point
b)
  where -- Minimal & maximal dimension of the bezier curve

        bmin :: Point
bmin = Point -> Point -> Point
forall n (a :: * -> *). (Ord n, Applicative a) => a n -> a n -> a n
vmin Point
a Point
b
        bmax :: Point
bmax = Point -> Point -> Point
forall n (a :: * -> *). (Ord n, Applicative a) => a n -> a n -> a n
vmax Point
a Point
b

        recurse :: Line -> Container Primitive
recurse = Point -> Point -> Line -> Container Primitive
clipLine Point
mini Point
maxi

        clamper :: Point -> Point
clamper = Point -> Point -> Point -> Point
clampPoint Point
mini Point
maxi
        clampedA :: Point
clampedA = Point -> Point
clamper Point
a
        clampedB :: Point
clampedB = Point -> Point
clamper Point
b

        V2 Bool
insideX Bool
insideY = Point
mini Point -> Point -> V2 Bool
forall v (a :: * -> *).
(Ord v, Applicative a) =>
a v -> a v -> a Bool
^<=^ Point
bmin V2 Bool -> V2 Bool -> V2 Bool
forall (a :: * -> *). Applicative a => a Bool -> a Bool -> a Bool
^&&^ Point
bmax Point -> Point -> V2 Bool
forall v (a :: * -> *).
(Ord v, Applicative a) =>
a v -> a v -> a Bool
^<=^ Point
maxi
        V2 Bool
outsideX Bool
outsideY = Point
bmax Point -> Point -> V2 Bool
forall v (a :: * -> *).
(Ord v, Applicative a) =>
a v -> a v -> a Bool
^<=^ Point
mini V2 Bool -> V2 Bool -> V2 Bool
forall (a :: * -> *). Applicative a => a Bool -> a Bool -> a Bool
^||^ Point
maxi Point -> Point -> V2 Bool
forall v (a :: * -> *).
(Ord v, Applicative a) =>
a v -> a v -> a Bool
^<=^ Point
bmin

        -- A X-----X-----X B

        --        AB

        ab :: Point
ab = Point
a Point -> Point -> Point
forall (a :: * -> *) coord.
(Additive a, Fractional coord) =>
a coord -> a coord -> a coord
`midPoint` Point
b

        --  mini

        --     +-------------+

        --     |             |

        --     |             |

        --     |             |

        --     +-------------+

        --                   maxi

        -- the edgeSeparator vector encode which edge

        -- is te nearest to the midpoint.

        -- if True then it's the 'min' edges which are

        -- the nearest, otherwise it's the maximum edge

        edgeSeparator :: V2 Bool
edgeSeparator =
            Point -> Point
forall n (a :: * -> *). (Num n, Functor a) => a n -> a n
vabs (Point
ab Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
mini) Point -> Point -> V2 Bool
forall v (a :: * -> *).
(Ord v, Applicative a) =>
a v -> a v -> a Bool
^<^ Point -> Point
forall n (a :: * -> *). (Num n, Functor a) => a n -> a n
vabs (Point
ab Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
maxi)

        -- So here we 'solidify' the nearest edge position

        -- in an edge vector.

        edge :: Point
edge = V2 Bool -> Point -> Point -> Point
forall (a :: * -> *) v.
Applicative a =>
a Bool -> a v -> a v -> a v
vpartition V2 Bool
edgeSeparator Point
mini Point
maxi

        -- If we're near an edge, snap the component to the

        -- edge.

        m :: Point
m = V2 Bool -> Point -> Point -> Point
forall (a :: * -> *) v.
Applicative a =>
a Bool -> a v -> a v -> a v
vpartition (Point -> Point
forall n (a :: * -> *). (Num n, Functor a) => a n -> a n
vabs (Point
ab Point -> Point -> Point
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ Point
edge) Point -> Float -> V2 Bool
forall (a :: * -> *) v.
(Applicative a, Ord v) =>
a v -> v -> a Bool
^< Float
0.1) Point
edge Point
ab

-- TODO: implement better algorithm for lines, should

-- be doable.

decomposeLine :: Line -> Producer EdgeSample
decomposeLine :: Line -> Producer EdgeSample
decomposeLine (Line (V2 Float
aRx Float
aRy) (V2 Float
bRx Float
bRy)) = Float -> Float -> Float -> Float -> Producer EdgeSample
go Float
aRx Float
aRy Float
bRx Float
bRy where
  go :: Float -> Float -> Float -> Float -> Producer EdgeSample
go !Float
ax !Float
ay !Float
bx !Float
by [EdgeSample]
cont
    | Bool
insideX Bool -> Bool -> Bool
&& Bool
insideY =
      let !px :: Float
px = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Float) -> Int -> Float
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
floorAx Int
floorBx
          !py :: Float
py = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Float) -> Int -> Float
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
floorAy Int
floorBy
          !w :: Float
w = Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- (Float
bx Float -> Float -> Float
forall a. Fractional a => a -> a -> a
`middle` Float
ax)
          !h :: Float
h = Float
by Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
ay
      in
      Float -> Float -> Float -> Float -> EdgeSample
EdgeSample (Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
0.5) (Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
0.5) (Float
w Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
h) Float
h EdgeSample -> Producer EdgeSample
forall a. a -> [a] -> [a]
: [EdgeSample]
cont
      where
        floorAx, floorAy :: Int
        !floorAx :: Int
floorAx = Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Float
ax
        !floorAy :: Int
floorAy = Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Float
ay

        !floorBx :: Int
floorBx = Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Float
bx
        !floorBy :: Int
floorBy = Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Float
by

        !insideX :: Bool
insideX = Int
floorAx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
floorBx Bool -> Bool -> Bool
|| Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Float
ax Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Float
bx :: Int)
        !insideY :: Bool
insideY = Int
floorAy Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
floorBy Bool -> Bool -> Bool
|| Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Float
ay Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Float
by :: Int)


  go !Float
ax !Float
ay !Float
bx !Float
by [EdgeSample]
cont = Float -> Float -> Float -> Float -> Producer EdgeSample
go Float
ax Float
ay Float
mx Float
my Producer EdgeSample -> Producer EdgeSample
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float -> Float -> Producer EdgeSample
go Float
mx Float
my Float
bx Float
by [EdgeSample]
cont
    where
      !abx :: Float
abx = Float
ax Float -> Float -> Float
forall a. Fractional a => a -> a -> a
`middle` Float
bx
      !aby :: Float
aby = Float
ay Float -> Float -> Float
forall a. Fractional a => a -> a -> a
`middle` Float
by

      !mx :: Float
mx | Float -> Float
forall a. Num a => a -> a
abs (Float
abx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
mini) Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
0.1 = Float
mini
          | Float -> Float
forall a. Num a => a -> a
abs (Float
abx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
maxi) Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
0.1 = Float
maxi
          | Bool
otherwise = Float
abx
         where !mini :: Float
mini = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Float
abx :: Int)
               !maxi :: Float
maxi = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Float
abx :: Int)

      !my :: Float
my | Float -> Float
forall a. Num a => a -> a
abs (Float
aby Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
mini) Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
0.1 = Float
mini
          | Float -> Float
forall a. Num a => a -> a
abs (Float
aby Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
maxi) Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
0.1 = Float
maxi
          | Bool
otherwise = Float
aby
         where !mini :: Float
mini = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Float
aby :: Int)
               !maxi :: Float
maxi = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Float
aby :: Int)

-- | Extend a line by two coefficient, giving a line that's a

-- linear extension of the original line.

--

-- law: extendLine 0 1 = id

extendLine :: Float  -- ^ Begin extension coefficient

           -> Float  -- ^ End extension coefficient

           -> Line   -- ^ Line to transform

           -> Line
extendLine :: Float -> Float -> Line -> Line
extendLine Float
beg Float
end (Line Point
p1 Point
p2) =
    Point -> Point -> Line
Line (Float -> Point -> Point -> Point
forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp Float
beg Point
p2 Point
p1) (Float -> Point -> Point -> Point
forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp Float
end Point
p2 Point
p1)