{-# LANGUAGE BangPatterns #-}
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
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)
clipLine :: Point
-> Point
-> Line
-> Container Primitive
clipLine :: Point -> Point -> Line -> Container Primitive
clipLine Point
mini Point
maxi poly :: Line
poly@(Line Point
a Point
b)
| 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
| 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
| 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
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
ab :: Point
ab = Point
a Point -> Point -> Point
forall (a :: * -> *) coord.
(Additive a, Fractional coord) =>
a coord -> a coord -> a coord
`midPoint` Point
b
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)
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
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
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)
extendLine :: Float
-> Float
-> Line
-> 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)