{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleInstances #-}
module Graphics.Rasterific.Types
(
Vector
, Point
, Line( .. )
, Bezier( .. )
, CubicBezier( .. )
, Primitive( .. )
, Primitivable( .. )
, Geometry( .. )
, Producer
, Container
, containerOfList
, listOfContainer
, containerOfFunction
, PathCommand( .. )
, Path( .. )
, Transformable( .. )
, PointFoldable( .. )
, Cap( .. )
, Join( .. )
, FillMethod( .. )
, SamplerRepeat( .. )
, DashPattern
, StrokeWidth
, EdgeSample( .. )
, pathToPrimitives
, firstTangeantOf
, lastTangeantOf
, firstPointOf
, lastPointOf
, resplit
, Proxy( Proxy )
) where
import Data.DList( DList, fromList )
import Control.Monad.Identity( runIdentity )
import Data.Foldable( foldl', toList )
import qualified Data.Foldable as F
import Graphics.Rasterific.Linear( V2( .. ), (^-^), nearZero )
import Graphics.Rasterific.Operators
import Foreign.Ptr( castPtr )
import Foreign.Storable( Storable( sizeOf
, alignment
, peek
, poke
, peekElemOff
, pokeElemOff ) )
type Vector = V2 Float
type StrokeWidth = Float
type DashPattern = [Float]
data Proxy p = Proxy
data Cap
= CapStraight Float
| CapRound
deriving (Eq, Show)
data Join
= JoinRound
| JoinMiter Float
deriving (Eq, Show)
data FillMethod
= FillWinding
| FillEvenOdd
deriving (Eq, Enum, Show)
data SamplerRepeat
= SamplerPad
| SamplerRepeat
| SamplerReflect
deriving (Eq, Enum, Show)
data EdgeSample = EdgeSample
{ _sampleX :: {-# UNPACK #-} !Float
, _sampleY :: {-# UNPACK #-} !Float
, _sampleAlpha :: {-# UNPACK #-} !Float
, _sampleH :: {-# UNPACK #-} !Float
}
deriving Show
instance Storable EdgeSample where
sizeOf _ = 4 * sizeOf (0 :: Float)
alignment = sizeOf
{-# INLINE peek #-}
peek ptr = do
let q = castPtr ptr
sx <- peekElemOff q 0
sy <- peekElemOff q 1
sa <- peekElemOff q 2
sh <- peekElemOff q 3
return $ EdgeSample sx sy sa sh
{-# INLINE poke #-}
poke ptr (EdgeSample sx sy sa sh) = do
let q = castPtr ptr
pokeElemOff q 0 sx
pokeElemOff q 1 sy
pokeElemOff q 2 sa
pokeElemOff q 3 sh
class Transformable a where
transform :: (Point -> Point) -> a -> a
transform f = runIdentity . transformM (return . f)
transformM :: Monad m => (Point -> m Point) -> a -> m a
class PointFoldable a where
foldPoints :: (b -> Point -> b) -> b -> a -> b
instance Transformable Point where
{-# INLINE transform #-}
transform f = f
{-# INLINE transformM #-}
transformM f = f
instance PointFoldable Point where
{-# INLINE foldPoints #-}
foldPoints f = f
data Line = Line
{ _lineX0 :: {-# UNPACK #-} !Point
, _lineX1 :: {-# UNPACK #-} !Point
}
deriving Eq
instance Show Line where
show (Line a b) =
"Line (" ++ show a ++ ") ("
++ show b ++ ")"
instance Transformable Line where
{-# INLINE transformM #-}
transformM f (Line a b) = Line <$> f a <*> f b
instance PointFoldable Line where
{-# INLINE foldPoints #-}
foldPoints f acc (Line a b) = f (f acc b) a
data Bezier = Bezier
{
_bezierX0 :: {-# UNPACK #-} !Point
, _bezierX1 :: {-# UNPACK #-} !Point
, _bezierX2 :: {-# UNPACK #-} !Point
}
deriving Eq
instance Show Bezier where
show (Bezier a b c) =
"Bezier (" ++ show a ++ ") ("
++ show b ++ ") ("
++ show c ++ ")"
instance Transformable Bezier where
{-# INLINE transform #-}
transform f (Bezier a b c) = Bezier (f a) (f b) $ f c
{-# INLINE transformM #-}
transformM f (Bezier a b c) = Bezier <$> f a <*> f b <*> f c
instance PointFoldable Bezier where
{-# INLINE foldPoints #-}
foldPoints f acc (Bezier a b c) =
foldl' f acc [a, b, c]
data CubicBezier = CubicBezier
{
_cBezierX0 :: {-# UNPACK #-} !Point
, _cBezierX1 :: {-# UNPACK #-} !Point
, _cBezierX2 :: {-# UNPACK #-} !Point
, _cBezierX3 :: {-# UNPACK #-} !Point
}
deriving Eq
instance Show CubicBezier where
show (CubicBezier a b c d) =
"CubicBezier (" ++ show a ++ ") ("
++ show b ++ ") ("
++ show c ++ ") ("
++ show d ++ ")"
instance Transformable CubicBezier where
{-# INLINE transform #-}
transform f (CubicBezier a b c d) =
CubicBezier (f a) (f b) (f c) $ f d
transformM f (CubicBezier a b c d) =
CubicBezier <$> f a <*> f b <*> f c <*> f d
instance PointFoldable CubicBezier where
{-# INLINE foldPoints #-}
foldPoints f acc (CubicBezier a b c d) =
foldl' f acc [a, b, c, d]
data Primitive
= LinePrim !Line
| BezierPrim !Bezier
| CubicBezierPrim !CubicBezier
deriving (Eq, Show)
class Primitivable a where
toPrim :: a -> Primitive
instance Primitivable Primitive where toPrim = id
instance Primitivable Line where toPrim = LinePrim
instance Primitivable Bezier where toPrim = BezierPrim
instance Primitivable CubicBezier where toPrim = CubicBezierPrim
class Geometry a where
toPrimitives :: a -> [Primitive]
listToPrims :: (Foldable f) => f a -> [Primitive]
{-# INLINE listToPrims #-}
listToPrims = F.concatMap toPrimitives . F.toList
instance Geometry Path where
{-# INLINE toPrimitives #-}
toPrimitives = pathToPrimitives
instance Geometry Primitive where
toPrimitives e = [e]
{-# INLINE listToPrims #-}
listToPrims = F.toList
instance Geometry Line where
{-# INLINE toPrimitives #-}
toPrimitives e = [toPrim e]
instance Geometry Bezier where
{-# INLINE toPrimitives #-}
toPrimitives e = [toPrim e]
instance Geometry CubicBezier where
{-# INLINE toPrimitives #-}
toPrimitives e = [toPrim e]
instance (Foldable f, Geometry a) => Geometry (f a) where
{-# INLINE toPrimitives #-}
toPrimitives = listToPrims
instance Transformable Primitive where
{-# INLINE transform #-}
transform f (LinePrim l) = LinePrim $ transform f l
transform f (BezierPrim b) = BezierPrim $ transform f b
transform f (CubicBezierPrim c) = CubicBezierPrim $ transform f c
transformM f (LinePrim l) = LinePrim <$> transformM f l
transformM f (BezierPrim b) = BezierPrim <$> transformM f b
transformM f (CubicBezierPrim c) = CubicBezierPrim <$> transformM f c
instance PointFoldable Primitive where
{-# INLINE foldPoints #-}
foldPoints f acc = go
where go (LinePrim l) = foldPoints f acc l
go (BezierPrim b) = foldPoints f acc b
go (CubicBezierPrim c) = foldPoints f acc c
instance {-# OVERLAPPABLE #-} (Traversable f, Transformable a)
=> Transformable (f a) where
transform f = fmap (transform f)
transformM f = mapM (transformM f)
instance {-# OVERLAPPABLE #-} (Foldable f, PointFoldable a)
=> PointFoldable (f a) where
foldPoints f = foldl' (foldPoints f)
type Producer a = [a] -> [a]
type Container a = DList a
containerOfFunction :: ([a] -> [a]) -> Container a
containerOfFunction f = fromList $ f []
containerOfList :: [a] -> Container a
containerOfList = fromList
listOfContainer :: Container a -> [a]
listOfContainer = toList
data Path = Path
{
_pathOriginPoint :: Point
, _pathClose :: Bool
, _pathCommand :: [PathCommand]
}
deriving (Eq, Show)
instance Transformable Path where
{-# INLINE transform #-}
transform f (Path orig close rest) =
Path (f orig) close (transform f rest)
transformM f (Path orig close rest) =
Path <$> f orig <*> pure close <*> transformM f rest
instance PointFoldable Path where
{-# INLINE foldPoints #-}
foldPoints f acc (Path o _ rest) =
foldPoints f (f acc o) rest
data PathCommand
=
PathLineTo Point
| PathQuadraticBezierCurveTo Point Point
| PathCubicBezierCurveTo Point Point Point
deriving (Eq, Show)
instance Transformable PathCommand where
transform f (PathLineTo p) = PathLineTo $ f p
transform f (PathQuadraticBezierCurveTo p1 p2) =
PathQuadraticBezierCurveTo (f p1) $ f p2
transform f (PathCubicBezierCurveTo p1 p2 p3) =
PathCubicBezierCurveTo (f p1) (f p2) $ f p3
transformM f (PathLineTo p) = PathLineTo <$> f p
transformM f (PathQuadraticBezierCurveTo p1 p2) =
PathQuadraticBezierCurveTo <$> f p1 <*> f p2
transformM f (PathCubicBezierCurveTo p1 p2 p3) =
PathCubicBezierCurveTo <$> f p1 <*> f p2 <*> f p3
instance PointFoldable PathCommand where
foldPoints f acc (PathLineTo p) = f acc p
foldPoints f acc (PathQuadraticBezierCurveTo p1 p2) =
f (f acc p1) p2
foldPoints f acc (PathCubicBezierCurveTo p1 p2 p3) =
foldl' f acc [p1, p2, p3]
pathToPrimitives :: Path -> [Primitive]
pathToPrimitives (Path origin needClosing commands) = go origin commands
where
go prev [] | prev /= origin && needClosing = [LinePrim $ Line prev origin]
go _ [] = []
go prev (PathLineTo to : xs) =
LinePrim (Line prev to) : go to xs
go prev (PathQuadraticBezierCurveTo c1 to : xs) =
BezierPrim (Bezier prev c1 to) : go to xs
go prev (PathCubicBezierCurveTo c1 c2 to : xs) =
CubicBezierPrim (CubicBezier prev c1 c2 to) : go to xs
firstTangeantOf :: Primitive -> Vector
firstTangeantOf p = case p of
LinePrim (Line p0 p1) -> p1 ^-^ p0
BezierPrim (Bezier p0 p1 p2) ->
(p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1)
CubicBezierPrim (CubicBezier p0 p1 p2 _) ->
(p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1)
where
ifBigEnough a b | nearZero a = b
| otherwise = a
lastTangeantOf :: Primitive -> Vector
lastTangeantOf p = case p of
LinePrim (Line p0 p1) -> p1 ^-^ p0
BezierPrim (Bezier _ p1 p2) -> p2 ^-^ p1
CubicBezierPrim (CubicBezier _ _ p2 p3) -> p3 ^-^ p2
firstPointOf :: Primitive -> Point
firstPointOf p = case p of
LinePrim (Line p0 _) -> p0
BezierPrim (Bezier p0 _ _) -> p0
CubicBezierPrim (CubicBezier p0 _ _ _) -> p0
lastPointOf :: Primitive -> Point
lastPointOf p = case p of
LinePrim (Line _ p0) -> p0
BezierPrim (Bezier _ _ p0) -> p0
CubicBezierPrim (CubicBezier _ _ _ p0) -> p0
resplit :: [Primitive] -> [[Primitive]]
resplit = uncurry (:) . go where
go [] = ([], [])
go (x:xs@(y:_)) | lastPointOf x `isDistingableFrom` firstPointOf y =
([x], after:rest) where (after, rest) = go xs
go (x:xs) = (x:curr, rest) where (curr, rest) = go xs