├── docimages └── dummy.png ├── Setup.hs ├── avatar.png ├── img └── logo.png ├── exec-src ├── maki_fab.JPG ├── test_img.png ├── Sample.hs ├── Arbitrary.hs └── snowflake.hs ├── test_fonts ├── DejaVuSans.ttf └── DejaVuSansMono.ttf ├── .gitmodules ├── .gitignore ├── Makefile ├── README.md ├── src └── Graphics │ └── Rasterific │ ├── Outline.hs │ ├── QuadraticFormula.hs │ ├── MiniLens.hs │ ├── PlaneBoundable.hs │ ├── Rasterize.hs │ ├── ComplexPrimitive.hs │ ├── Lenses.hs │ ├── PathWalker.hs │ ├── Operators.hs │ ├── BiSampleable.hs │ ├── Line.hs │ ├── Transformations.hs │ ├── Arc.hs │ ├── Texture.hs │ ├── Compositor.hs │ ├── CubicBezier │ └── FastForwardDifference.hs │ ├── Command.hs │ ├── QuadraticBezier.hs │ ├── StrokeInternal.hs │ ├── Linear.hs │ ├── Immediate.hs │ ├── PatchTypes.hs │ ├── CubicBezier.hs │ └── Shading.hs ├── LICENSE ├── changelog └── Rasterific.cabal /docimages/dummy.png: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /avatar.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Twinside/Rasterific/HEAD/avatar.png -------------------------------------------------------------------------------- /img/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Twinside/Rasterific/HEAD/img/logo.png -------------------------------------------------------------------------------- /exec-src/maki_fab.JPG: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Twinside/Rasterific/HEAD/exec-src/maki_fab.JPG -------------------------------------------------------------------------------- /exec-src/test_img.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Twinside/Rasterific/HEAD/exec-src/test_img.png -------------------------------------------------------------------------------- /test_fonts/DejaVuSans.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Twinside/Rasterific/HEAD/test_fonts/DejaVuSans.ttf -------------------------------------------------------------------------------- /test_fonts/DejaVuSansMono.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Twinside/Rasterific/HEAD/test_fonts/DejaVuSansMono.ttf -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "FontyFruity"] 2 | path = FontyFruity 3 | url = https://github.com/Twinside/FontyFruity.git 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox 2 | dist 3 | cabal 4 | cabal.sandbox.config 5 | *.png 6 | sources 7 | .hpc 8 | docimages/* 9 | test_results/* 10 | .stack-work 11 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | build: 3 | cabal build 4 | 5 | doc: 6 | cabal haddock 7 | 8 | depinstall: 9 | cabal install -j4 --only-dependencies 10 | 11 | run: 12 | dist/build/test/test 13 | 14 | test: 15 | dist/build/test/test 16 | 17 | lint: 18 | hlint lint src 19 | 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Rasterific 2 | ========== 3 | 4 | ![Rasterific logo](https://raw.github.com/Twinside/Rasterific/master/img/logo.png) 5 | 6 | [![Hackage](https://img.shields.io/hackage/v/Rasterific.svg)](http://hackage.haskell.org/package/Rasterific) 7 | 8 | Rasterific is a Haskell rasterization engine (a vectorial renderer) 9 | implemented on top of [JuicyPixels](https://github.com/Twinside/Juicy.Pixels). 10 | Rasterific bases its text rendering on [FontyFruity](https://github.com/Twinside/FontyFruity). 11 | 12 | Main capability 13 | --------------- 14 | 15 | * Draw vector graphics to an image. 16 | * Export graphics to PDF (since 0.6). 17 | 18 | Design 19 | ------ 20 | The renderer design is based on the 21 | [Nile](https://github.com/damelang/nile) / 22 | [Gezira](https://github.com/damelang/gezira) renderer from the STEP 23 | project from the [VPRI](http://www.vpri.org/index.html) institute. The 24 | interesting thing about this renderer is the conciseness of it's 25 | implementation, providing antialiased rendering in the way. 26 | 27 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/Outline.hs: -------------------------------------------------------------------------------- 1 | -- | This module provide helper functions to create outline 2 | -- of shapes. 3 | module Graphics.Rasterific.Outline 4 | ( StrokeWidth 5 | , strokize 6 | , S.dashedStrokize 7 | , S.approximatePathLength 8 | ) where 9 | 10 | import Graphics.Rasterific.Types 11 | import qualified Graphics.Rasterific.StrokeInternal as S 12 | 13 | -- | This function will create the outline of a given geometry 14 | -- given a path. You can then stroke it. 15 | -- 16 | -- > stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0) $ 17 | -- > strokize 40 JoinRound (CapRound, CapRound) $ 18 | -- > CubicBezier (V2 40 160) (V2 40 40) 19 | -- > (V2 160 40) (V2 160 160) 20 | -- 21 | -- <> 22 | -- 23 | strokize :: Geometry geom 24 | => StrokeWidth -- ^ Stroke width 25 | -> Join -- ^ Which kind of join will be used 26 | -> (Cap, Cap) -- ^ Start and end capping. 27 | -> geom -- ^ List of elements to strokize 28 | -> [Primitive] 29 | strokize w j c = listOfContainer . S.strokize w j c 30 | 31 | -------------------------------------------------------------------------------- /exec-src/Sample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | module Sample where 4 | 5 | import Codec.Picture 6 | import Codec.Picture.Gif 7 | import Graphics.Rasterific 8 | import Graphics.Rasterific.Texture 9 | import Graphics.Rasterific.Transformations 10 | 11 | triangles :: IO () 12 | triangles = 13 | case writeGifImages "triangles.gif" LoopingForever images of 14 | Left err -> putStrLn err 15 | Right v -> v 16 | 17 | where 18 | frameCount = 140 19 | images = 20 | [(greyPalette, 3, go (i * pi * 2 * (1 / frameCount))) 21 | | i <- [0 .. frameCount] ] 22 | go angle = renderDrawing 400 400 0 $ 23 | mapM_ (render angle) [1 .. 25] 24 | 25 | render angle n = 26 | withTransformation 27 | ( translate (V2 200 180) <> 28 | scale (1 / n + 1) (1 / n + 1) <> 29 | rotate (angle + 0.1 * angle * n) ) $ 30 | 31 | withTexture (uniformTexture (155 + 4 * floor n)) $ 32 | stroke 2 (JoinMiter 0) 33 | (CapStraight 0, CapStraight 0) 34 | triangle 35 | 36 | 37 | triangle = 38 | Path (V2 0 50) True 39 | [ PathLineTo (V2 50 (-30)) 40 | , PathLineTo (V2 (-50) (-30)) 41 | ] 42 | 43 | main :: IO () 44 | main = do 45 | triangles 46 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Vincent Berthoux 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Vincent Berthoux nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/QuadraticFormula.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Rasterific.QuadraticFormula( QuadraticFormula( .. ) 2 | , discriminant 3 | , formulaRoots 4 | ) where 5 | 6 | -- | Represent an equation `a * x^2 + b * x + c = 0` 7 | data QuadraticFormula a = QuadraticFormula 8 | { _coeffA :: !a -- ^ Coefficient for the square part (x^2) 9 | , _coeffB :: !a -- ^ Coefficient the linear part (x) 10 | , _coeffC :: !a -- ^ Constant 11 | } 12 | 13 | instance Functor QuadraticFormula where 14 | {-# INLINE fmap #-} 15 | fmap f (QuadraticFormula a b c) = 16 | QuadraticFormula (f a) (f b) (f c) 17 | 18 | instance Applicative QuadraticFormula where 19 | pure a = QuadraticFormula a a a 20 | {-# INLINE pure #-} 21 | 22 | QuadraticFormula a b c <*> QuadraticFormula d e f = 23 | QuadraticFormula (a d) (b e) (c f) 24 | {-# INLINE (<*>) #-} 25 | 26 | -- | Discriminant equation, if the result is: 27 | -- 28 | -- * Below 0, then the formula doesn't have any solution 29 | -- 30 | -- * Equal to 0, then the formula has an unique root. 31 | -- 32 | -- * Above 0, the formula has two solutions 33 | -- 34 | discriminant :: Num a => QuadraticFormula a -> a 35 | discriminant (QuadraticFormula a b c) = b * b - 4 * a *c 36 | 37 | -- | Extract all the roots of the formula ie. where the 38 | -- unknown gives a result of 0 39 | formulaRoots :: (Ord a, Floating a) => QuadraticFormula a -> [a] 40 | formulaRoots formula@(QuadraticFormula a b _) 41 | | disc < 0 = [] 42 | | disc == 0 = [positiveResult] 43 | | otherwise = [positiveResult, negativeResult] 44 | where 45 | disc = discriminant formula 46 | squarePart = sqrt disc 47 | positiveResult = (negate b + squarePart) / (2 * a) 48 | negativeResult = (negate b - squarePart) / (2 * a) 49 | 50 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/MiniLens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | module Graphics.Rasterific.MiniLens 3 | ( -- * Types 4 | Lens 5 | , Lens' 6 | , Traversal 7 | , Traversal' 8 | , lens 9 | 10 | -- * Getter 11 | , (.^) 12 | , view 13 | , use 14 | 15 | -- * Setter 16 | , (.~) 17 | , (.=) 18 | , (%=) 19 | , (+=) 20 | , set 21 | 22 | -- * Helper 23 | , (&) 24 | ) where 25 | 26 | import Control.Monad.Identity 27 | import Control.Applicative 28 | import Control.Monad.State as State 29 | import Data.Function( (&) ) 30 | 31 | infixl 8 .^ 32 | infixr 4 .~ 33 | infix 4 .=,%=,+= 34 | 35 | -- | Does it look familiar? yes it's the official 36 | -- Lens type. 37 | type Lens s t a b = 38 | forall f. Functor f => (a -> f b) -> s -> f t 39 | 40 | -- | Try to match the Lens' type alias. 41 | type Lens' s a = Lens s s a a 42 | 43 | -- | Traversal type, matched to the one of the lens 44 | -- package. 45 | type Traversal s t a b = 46 | forall f. Applicative f => (a -> f b) -> s -> f t 47 | 48 | type Traversal' s a = Traversal s s a a 49 | 50 | -- | Create a full lens out of setter and getter 51 | lens :: (s -> a) 52 | -> (s -> b -> t) 53 | -> Lens s t a b 54 | {-# INLINE lens #-} 55 | lens accessor setter = \f src -> 56 | fmap (setter src) $ f (accessor src) 57 | 58 | view :: s -> Lens s t a b -> a 59 | {-# INLINE view #-} 60 | view v l = getConst (l Const v) 61 | 62 | (.^) :: s -> Lens s t a b -> a 63 | {-# INLINE (.^) #-} 64 | (.^) = view 65 | 66 | set :: Lens' s a -> a -> s -> s 67 | {-# INLINE set #-} 68 | set l new v = runIdentity $ l (\_ -> Identity new) v 69 | 70 | (.~) :: Lens' s a -> a -> s -> s 71 | {-# INLINE (.~) #-} 72 | (.~) = set 73 | 74 | (.=) :: MonadState s m => Lens' s a -> a -> m () 75 | {-# INLINE (.=) #-} 76 | (.=) l v = State.modify (l .~ v) 77 | 78 | (%=) :: MonadState s m => Lens' s a -> (a -> a) -> m () 79 | {-# INLINE (%=) #-} 80 | (%=) l f = State.modify $ \s -> s & l .~ f (s .^ l) 81 | 82 | (+=) :: (Num a, MonadState s m) => Lens' s a -> a -> m () 83 | {-# INLINE (+=) #-} 84 | (+=) l n = l %= (+ n) 85 | 86 | use :: MonadState s m => Lens s t a b -> m a 87 | {-# INLINE use #-} 88 | use l = State.gets (.^ l) 89 | 90 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/PlaneBoundable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | -- | Module implementing types used for geometry 4 | -- bound calculations. 5 | module Graphics.Rasterific.PlaneBoundable ( PlaneBound( .. ) 6 | , PlaneBoundable( .. ) 7 | , boundWidth 8 | , boundHeight 9 | , boundLowerLeftCorner 10 | ) where 11 | 12 | import Graphics.Rasterific.Linear( V2( .. ) ) 13 | import Graphics.Rasterific.Types 14 | import Graphics.Rasterific.CubicBezier 15 | 16 | -- | Represent the minimal axis aligned rectangle 17 | -- in which some primitives can be drawn. Should 18 | -- fit to bezier curve and not use directly their 19 | -- control points. 20 | data PlaneBound = PlaneBound 21 | { -- | Corner upper left of the bounding box of 22 | -- the considered primitives. 23 | _planeMinBound :: !Point 24 | -- | Corner lower right of the bounding box of 25 | -- the considered primitives. 26 | , _planeMaxBound :: !Point 27 | } 28 | deriving (Eq, Show) 29 | 30 | -- | Extract the width of the bounds 31 | boundWidth :: PlaneBound -> Float 32 | boundWidth (PlaneBound (V2 x0 _) (V2 x1 _)) = x1 - x0 33 | 34 | -- | Extract the height of the bound 35 | boundHeight :: PlaneBound -> Float 36 | boundHeight (PlaneBound (V2 _ y0) (V2 _ y1)) = y1 - y0 37 | 38 | -- | Extract the position of the lower left corner of the 39 | -- bounds. 40 | boundLowerLeftCorner :: PlaneBound -> Point 41 | boundLowerLeftCorner (PlaneBound (V2 x _) (V2 _ y)) = V2 x y 42 | 43 | instance Semigroup PlaneBound where 44 | (<>) (PlaneBound mini1 maxi1) (PlaneBound mini2 maxi2) = 45 | PlaneBound (min <$> mini1 <*> mini2) 46 | (max <$> maxi1 <*> maxi2) 47 | 48 | instance Monoid PlaneBound where 49 | mappend = (<>) 50 | mempty = PlaneBound infPoint negInfPoint 51 | where 52 | infPoint = V2 (1 / 0) (1 / 0) 53 | negInfPoint = V2 (negate 1 / 0) (negate 1 / 0) 54 | 55 | -- | Class used to calculate bounds of various geometrical 56 | -- primitives. The calculated is precise, the bounding should 57 | -- be minimal with respect with drawn curve. 58 | class PlaneBoundable a where 59 | -- | Given a graphical elements, calculate it's bounds. 60 | planeBounds :: a -> PlaneBound 61 | 62 | instance PlaneBoundable Point where 63 | planeBounds a = PlaneBound a a 64 | 65 | instance PlaneBoundable Line where 66 | planeBounds (Line p1 p2) = planeBounds p1 <> planeBounds p2 67 | 68 | instance PlaneBoundable Bezier where 69 | planeBounds (Bezier p0 p1 p2) = 70 | planeBounds (CubicBezier p0 p1 p1 p2) 71 | 72 | instance PlaneBoundable CubicBezier where 73 | planeBounds = foldMap planeBounds . cubicBezierBounds 74 | 75 | instance PlaneBoundable Primitive where 76 | planeBounds (LinePrim l) = planeBounds l 77 | planeBounds (BezierPrim b) = planeBounds b 78 | planeBounds (CubicBezierPrim c) = planeBounds c 79 | 80 | -------------------------------------------------------------------------------- /exec-src/Arbitrary.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module Arbitrary( randomTests ) where 3 | 4 | import Control.DeepSeq 5 | import Test.QuickCheck 6 | import Codec.Picture 7 | import Graphics.Rasterific 8 | import Graphics.Rasterific.Texture 9 | 10 | instance Arbitrary a => Arbitrary (V2 a) where 11 | arbitrary = V2 <$> arbitrary <*> arbitrary 12 | 13 | instance Arbitrary PathCommand where 14 | arbitrary = oneof 15 | [ PathLineTo <$> arbitrary 16 | , PathQuadraticBezierCurveTo <$> arbitrary <*> arbitrary 17 | , PathCubicBezierCurveTo <$> arbitrary <*> arbitrary <*> arbitrary 18 | ] 19 | 20 | instance Arbitrary Path where 21 | arbitrary = Path <$> arbitrary <*> pure True <*> arbitrary 22 | 23 | instance Arbitrary SamplerRepeat where 24 | arbitrary = oneof $ map pure [toEnum 0 ..] 25 | 26 | instance Arbitrary FillMethod where 27 | arbitrary = oneof $ map pure [toEnum 0 ..] 28 | 29 | instance Arbitrary Join where 30 | arbitrary = oneof [pure JoinRound, JoinMiter <$> arbitrary] 31 | 32 | instance Arbitrary Cap where 33 | arbitrary = oneof [pure CapRound, CapStraight <$> arbitrary] 34 | 35 | newtype StrokeTest = StrokeTest (Drawing PixelRGBA8 ()) 36 | 37 | instance Show StrokeTest where 38 | show (StrokeTest sub) = 39 | "StrokeTest " ++ dumpDrawing sub 40 | 41 | instance Arbitrary StrokeTest where 42 | arbitrary = StrokeTest <$> 43 | (stroke <$> (getPositive <$> arbitrary) 44 | <*> arbitrary 45 | <*> arbitrary 46 | <*> (pathToPrimitives <$> arbitrary)) 47 | 48 | newtype DashedStrokeTest = DashedStrokeTest (Drawing PixelRGBA8 ()) 49 | 50 | instance Show DashedStrokeTest where 51 | show (DashedStrokeTest sub) = 52 | "StrokeTest " ++ dumpDrawing sub 53 | 54 | 55 | instance Arbitrary DashedStrokeTest where 56 | arbitrary = DashedStrokeTest <$> 57 | (dashedStroke <$> (fmap getPositive <$> arbitrary) 58 | <*> (getPositive <$> arbitrary) 59 | <*> arbitrary <*> arbitrary 60 | <*> (pathToPrimitives <$> arbitrary)) 61 | 62 | backgroundColor :: PixelRGBA8 63 | backgroundColor = PixelRGBA8 255 255 255 255 64 | 65 | frontTexture :: Texture PixelRGBA8 66 | frontTexture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255 67 | 68 | fillTest :: Path -> Bool 69 | fillTest path = deepseq img True 70 | where img = renderDrawing 200 200 backgroundColor $ 71 | withTexture frontTexture $ 72 | fill $ pathToPrimitives path 73 | 74 | strokeTest :: StrokeTest -> Bool 75 | strokeTest (StrokeTest test) = deepseq img True 76 | where img = renderDrawing 200 200 backgroundColor $ 77 | withTexture frontTexture test 78 | 79 | dashedStrokeTest :: DashedStrokeTest -> Bool 80 | dashedStrokeTest (DashedStrokeTest test) = deepseq img True 81 | where img = renderDrawing 200 200 backgroundColor $ 82 | withTexture frontTexture test 83 | 84 | randomTests :: IO () 85 | randomTests = do 86 | quickCheck fillTest 87 | quickCheck strokeTest 88 | quickCheck dashedStrokeTest 89 | 90 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/Rasterize.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Graphics.Rasterific.Rasterize 3 | ( CoverageSpan( .. ) 4 | , rasterize 5 | , toOpaqueCoverage 6 | , clip 7 | ) where 8 | 9 | import Control.Monad.ST( runST ) 10 | import Data.Fixed( mod' ) 11 | import Data.Monoid( Endo( Endo, appEndo ) ) 12 | import Graphics.Rasterific.Types 13 | import Graphics.Rasterific.QuadraticBezier 14 | import Graphics.Rasterific.CubicBezier 15 | import Graphics.Rasterific.Line 16 | import qualified Data.Vector as V 17 | import qualified Data.Vector.Algorithms.Intro as VS 18 | 19 | data CoverageSpan = CoverageSpan 20 | { _coverageX :: {-# UNPACK #-} !Float 21 | , _coverageY :: {-# UNPACK #-} !Float 22 | , _coverageVal :: {-# UNPACK #-} !Float 23 | , _coverageLength :: {-# UNPACK #-} !Float 24 | } 25 | deriving Show 26 | 27 | toOpaqueCoverage :: CoverageSpan -> CoverageSpan 28 | {-# INLINE toOpaqueCoverage #-} 29 | toOpaqueCoverage coverage = coverage { _coverageVal = 1 } 30 | 31 | combineEdgeSamples :: (Float -> Float) -> V.Vector EdgeSample 32 | -> [CoverageSpan] 33 | {-# INLINE combineEdgeSamples #-} 34 | combineEdgeSamples prepareCoverage vec = go 0 0 0 0 0 35 | where 36 | !maxi = V.length vec 37 | go !ix !x !y !a !_h | ix >= maxi = [CoverageSpan x y (prepareCoverage a) 1] 38 | go !ix !x !y !a !h = sub (vec `V.unsafeIndex` ix) where 39 | sub (EdgeSample x' y' a' h') 40 | | y == y' && x == x' = go (ix + 1) x' y' (a + a') (h + h') 41 | | y == y' = p1 : p2 : go (ix + 1) x' y' (h + a') (h + h') 42 | | otherwise = 43 | CoverageSpan x y (prepareCoverage a) 1 : go (ix + 1) x' y' a' h' 44 | where p1 = CoverageSpan x y (prepareCoverage a) 1 45 | p2 = CoverageSpan (x + 1) y (prepareCoverage h) (x' - x - 1) 46 | 47 | -- | Clip the geometry to a rectangle. 48 | clip :: Point -- ^ Minimum point (corner upper left) 49 | -> Point -- ^ Maximum point (corner bottom right) 50 | -> Primitive -- ^ Primitive to be clipped 51 | -> Container Primitive 52 | clip mini maxi (LinePrim l) = clipLine mini maxi l 53 | clip mini maxi (BezierPrim b) = clipBezier mini maxi b 54 | clip mini maxi (CubicBezierPrim c) = clipCubicBezier mini maxi c 55 | 56 | decompose :: Primitive -> Producer EdgeSample 57 | decompose (LinePrim l) = decomposeLine l 58 | decompose (BezierPrim b) = decomposeBeziers b 59 | decompose (CubicBezierPrim c) = 60 | {-decomposeCubicBezierForwardDifference c-} 61 | decomposeCubicBeziers c 62 | 63 | xyCompare :: EdgeSample -> EdgeSample -> Ordering 64 | {-# INLINE xyCompare #-} 65 | xyCompare !(EdgeSample { _sampleY = ay, _sampleX = ax }) 66 | !(EdgeSample { _sampleY = by, _sampleX = bx }) = 67 | case compare ay by of 68 | EQ -> compare ax bx 69 | c -> c 70 | 71 | sortEdgeSamples :: [EdgeSample] -> V.Vector EdgeSample 72 | sortEdgeSamples samples = runST $ do 73 | -- Resist the urge to make this a storable vector, 74 | -- it is actually a pessimisation. 75 | mutableVector <- V.unsafeThaw $ V.fromList samples 76 | VS.sortBy xyCompare mutableVector 77 | V.unsafeFreeze mutableVector 78 | 79 | rasterize :: FillMethod -> Container Primitive -> [CoverageSpan] 80 | rasterize method = 81 | case method of 82 | FillWinding -> combineEdgeSamples combineWinding 83 | . sortEdgeSamples 84 | . (($ []) . appEndo) 85 | . foldMap (Endo . decompose) 86 | FillEvenOdd -> combineEdgeSamples combineEvenOdd 87 | . sortEdgeSamples 88 | . (($ []) . appEndo) 89 | . foldMap (Endo . decompose) 90 | where combineWinding = min 1 . abs 91 | combineEvenOdd cov = abs $ abs (cov - 1) `mod'` 2 - 1 92 | 93 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/ComplexPrimitive.hs: -------------------------------------------------------------------------------- 1 | -- | Provide definition for some higher level objects (only slightly) 2 | module Graphics.Rasterific.ComplexPrimitive( rectangle 3 | , roundedRectangle 4 | , circle 5 | , ellipse 6 | ) where 7 | 8 | import Control.Applicative( empty, (<|>) ) 9 | import Control.Exception( throw, ArithException( .. ) ) 10 | 11 | import Graphics.Rasterific.Linear( V2( .. ), (^+^), (^*) ) 12 | import Graphics.Rasterific.Line 13 | import Graphics.Rasterific.CubicBezier 14 | import Graphics.Rasterific.Types 15 | 16 | isCoordValid :: RealFloat a => a -> Maybe ArithException 17 | isCoordValid v 18 | | isInfinite v = pure Overflow 19 | | isNaN v || isDenormalized v = pure Denormal 20 | | otherwise = empty 21 | 22 | isPointValid :: RealFloat a => V2 a -> Maybe ArithException 23 | isPointValid (V2 x y) = isCoordValid x <|> isCoordValid y 24 | 25 | -- | Generate a list of primitive representing a circle. 26 | -- 27 | -- > fill $ circle (V2 100 100) 75 28 | -- 29 | -- <> 30 | -- 31 | circle :: Point -- ^ Circle center in pixels 32 | -> Float -- ^ Circle radius in pixels 33 | -> [Primitive] 34 | circle p r 35 | | Just ex <- isCoordValid r <|> isPointValid p = throw ex 36 | circle center radius = 37 | CubicBezierPrim . transform mv <$> cubicBezierCircle 38 | where 39 | mv p = (p ^* radius) ^+^ center 40 | 41 | -- | Generate a list of primitive representing an ellipse. 42 | -- 43 | -- > fill $ ellipse (V2 100 100) 75 30 44 | -- 45 | -- <> 46 | -- 47 | ellipse :: Point -> Float -> Float -> [Primitive] 48 | ellipse c rx ry 49 | | Just ex <- isCoordValid rx <|> isCoordValid ry <|> isPointValid c = throw ex 50 | ellipse center rx ry = 51 | CubicBezierPrim . transform mv <$> cubicBezierCircle 52 | where 53 | mv (V2 x y) = V2 (x * rx) (y * ry) ^+^ center 54 | 55 | -- | Generate a list of primitive representing a 56 | -- rectangle 57 | -- 58 | -- > fill $ rectangle (V2 30 30) 150 100 59 | -- 60 | -- <> 61 | -- 62 | rectangle :: Point -- ^ Corner upper left 63 | -> Float -- ^ Width in pixel 64 | -> Float -- ^ Height in pixel 65 | -> [Primitive] 66 | rectangle p w h 67 | | Just ex <- isCoordValid w <|> isCoordValid h <|> isPointValid p = throw ex 68 | rectangle p@(V2 px py) w h = 69 | LinePrim <$> lineFromPath 70 | [ p, V2 (px + w) py, V2 (px + w) (py + h), V2 px (py + h), p ] 71 | 72 | -- | Generate a list of primitive representing a rectangle 73 | -- with rounded corner. 74 | -- 75 | -- > fill $ roundedRectangle (V2 10 10) 150 150 20 10 76 | -- 77 | -- <> 78 | -- 79 | roundedRectangle :: Point -- ^ Corner upper left 80 | -> Float -- ^ Width in pixel 81 | -> Float -- ^ Height in pixel. 82 | -> Float -- ^ Radius along the x axis of the rounded corner. In pixel. 83 | -> Float -- ^ Radius along the y axis of the rounded corner. In pixel. 84 | -> [Primitive] 85 | roundedRectangle p w h rx ry 86 | | Just ex <- isCoordValid w 87 | <|> isCoordValid h 88 | <|> isCoordValid rx 89 | <|> isCoordValid ry 90 | <|> isPointValid p = throw ex 91 | roundedRectangle (V2 px py) w h rx ry = 92 | [ CubicBezierPrim . transform (^+^ V2 xFar yNear) $ cornerTopR 93 | , LinePrim $ Line (V2 xFar py) (V2 xNear py) 94 | , CubicBezierPrim . transform (^+^ V2 (px + rx) (py + ry)) $ cornerTopL 95 | , LinePrim $ Line (V2 px yNear) (V2 px yFar) 96 | , CubicBezierPrim . transform (^+^ V2 (px + rx) yFar) $ cornerBottomL 97 | , LinePrim $ Line (V2 xNear (py + h)) (V2 xFar (py + h)) 98 | , CubicBezierPrim . transform (^+^ V2 xFar yFar) $ cornerBottomR 99 | , LinePrim $ Line (V2 (px + w) yFar) (V2 (px + w) yNear) 100 | ] 101 | where 102 | xNear = px + rx 103 | xFar = px + w - rx 104 | 105 | yNear = py + ry 106 | yFar = py + h - ry 107 | 108 | (cornerBottomR : 109 | cornerTopR : 110 | cornerTopL : 111 | cornerBottomL:_) = transform (\(V2 x y) -> V2 (x * rx) (y * ry)) <$> cubicBezierCircle 112 | 113 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/Lenses.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | -- | This module provide lenses compatible with the `lens` 3 | -- module but without the dependency to it. 4 | module Graphics.Rasterific.Lenses 5 | ( -- * Line lenses 6 | lineX0 7 | , lineX1 8 | , linePoints 9 | 10 | -- * Quadratic bezier curve 11 | , bezX0 12 | , bezX1 13 | , bezX2 14 | , bezierPoints 15 | 16 | -- * Cubic bezier lenses 17 | , cbezX0 18 | , cbezX1 19 | , cbezX2 20 | , cbezX3 21 | , cubicBezierPoints 22 | 23 | -- * Primitive lenses 24 | , primitivePoints 25 | 26 | -- * Path oriented lenses 27 | , pathCommandPoints 28 | , pathPoints 29 | 30 | -- * Type definition to match Lens 31 | , Lens 32 | , Lens' 33 | , Traversal 34 | , Traversal' 35 | ) where 36 | 37 | import Graphics.Rasterific.Types 38 | 39 | -- | Does it look familiar? yes it's the official 40 | -- Lens type. 41 | type Lens s t a b = 42 | forall f. Functor f => (a -> f b) -> s -> f t 43 | 44 | -- | Try to match the Lens' type alias. 45 | type Lens' s a = Lens s s a a 46 | 47 | -- | Traversal type, matched to the one of the lens 48 | -- package. 49 | type Traversal s t a b = 50 | forall f. Applicative f => (a -> f b) -> s -> f t 51 | 52 | type Traversal' s a = Traversal s s a a 53 | 54 | -- | Create a full lens out of setter and getter 55 | lens :: (s -> a) 56 | -> (s -> b -> t) 57 | -> Lens s t a b 58 | {-# INLINE lens #-} 59 | lens accessor setter = \f src -> 60 | fmap (setter src) $ f (accessor src) 61 | 62 | -- | Traverse all the points of a line. 63 | linePoints :: Traversal' Line Point 64 | linePoints f (Line p0 p1) = Line <$> f p0 <*> f p1 65 | 66 | -- | Line origin point. 67 | lineX0 :: Lens' Line Point 68 | lineX0 = lens _lineX0 setter where 69 | setter a b = a { _lineX0 = b } 70 | 71 | -- | Line end point. 72 | lineX1 :: Lens' Line Point 73 | lineX1 = lens _lineX1 setter where 74 | setter a b = a { _lineX1 = b } 75 | 76 | -- | Quadratic bezier starting point. 77 | bezX0 :: Lens' Bezier Point 78 | bezX0 = lens _bezierX0 setter where 79 | setter a b = a { _bezierX0 = b } 80 | 81 | -- | bezier control point. 82 | bezX1 :: Lens' Bezier Point 83 | bezX1 = lens _bezierX1 setter where 84 | setter a b = a { _bezierX1 = b } 85 | 86 | -- | bezier end point. 87 | bezX2 :: Lens' Bezier Point 88 | bezX2 = lens _bezierX2 setter where 89 | setter a b = a { _bezierX2 = b } 90 | 91 | -- | Traversal of all the bezier's points. 92 | bezierPoints :: Traversal' Bezier Point 93 | bezierPoints f (Bezier p0 p1 p2) = 94 | Bezier <$> f p0 <*> f p1 <*> f p2 95 | 96 | -- | Cubic bezier first point 97 | cbezX0 :: Lens' CubicBezier Point 98 | cbezX0 = lens _cBezierX0 setter where 99 | setter a b = a { _cBezierX0 = b } 100 | 101 | -- | Cubic bezier first control point. 102 | cbezX1 :: Lens' CubicBezier Point 103 | cbezX1 = lens _cBezierX1 setter where 104 | setter a b = a { _cBezierX1 = b } 105 | 106 | -- | Cubic bezier second control point. 107 | cbezX2 :: Lens' CubicBezier Point 108 | cbezX2 = lens _cBezierX2 setter where 109 | setter a b = a { _cBezierX2 = b } 110 | 111 | -- | Cubic bezier last point. 112 | cbezX3 :: Lens' CubicBezier Point 113 | cbezX3 = lens _cBezierX2 setter where 114 | setter a b = a { _cBezierX3 = b } 115 | 116 | -- | Traversal of all the points of the cubic bezier. 117 | cubicBezierPoints :: Traversal' CubicBezier Point 118 | cubicBezierPoints f (CubicBezier p0 p1 p2 p3) = 119 | CubicBezier <$> f p0 <*> f p1 <*> f p2 <*> f p3 120 | 121 | -- | Traverse all the points defined in the primitive. 122 | primitivePoints :: Traversal' Primitive Point 123 | primitivePoints f (LinePrim l) = LinePrim <$> linePoints f l 124 | primitivePoints f (BezierPrim b) = BezierPrim <$> bezierPoints f b 125 | primitivePoints f (CubicBezierPrim c) = 126 | CubicBezierPrim <$> cubicBezierPoints f c 127 | 128 | -- | Traversal of all the points of a path 129 | pathCommandPoints :: Traversal' PathCommand Point 130 | pathCommandPoints f (PathLineTo p) = PathLineTo <$> f p 131 | pathCommandPoints f (PathQuadraticBezierCurveTo p1 p2) = 132 | PathQuadraticBezierCurveTo <$> f p1 <*> f p2 133 | pathCommandPoints f (PathCubicBezierCurveTo p1 p2 p3) = 134 | PathCubicBezierCurveTo <$> f p1 <*> f p2 <*> f p3 135 | 136 | -- | Traversal of all the points in a path. 137 | pathPoints :: Traversal' Path Point 138 | pathPoints f (Path p0 yn comms) = 139 | Path <$> f p0 <*> pure yn <*> traverse (pathCommandPoints f) comms 140 | 141 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/PathWalker.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | -- | This module help the walking of path of any shape, 3 | -- being able to return the current position and the 4 | -- actual orientation. 5 | module Graphics.Rasterific.PathWalker( PathWalkerT 6 | , PathWalker 7 | , PathDrawer 8 | , runPathWalking 9 | , advanceBy 10 | , currentPosition 11 | , currentTangeant 12 | , drawOrdersOnPath 13 | ) where 14 | 15 | import Control.Monad.Identity( Identity ) 16 | import Control.Monad.State( StateT 17 | , MonadTrans 18 | , lift 19 | , evalStateT 20 | , modify 21 | , gets ) 22 | import Data.Maybe( fromMaybe ) 23 | 24 | import Graphics.Rasterific.Types 25 | import Graphics.Rasterific.Linear 26 | import Graphics.Rasterific.Transformations 27 | import Graphics.Rasterific.StrokeInternal 28 | import Graphics.Rasterific.PlaneBoundable 29 | import Graphics.Rasterific.Immediate 30 | 31 | -- | The walking transformer monad. 32 | newtype PathWalkerT m a = PathWalkerT (StateT WalkerState m a) 33 | deriving (Monad, Applicative, Functor, MonadTrans) 34 | 35 | -- | Simpler alias if monad transformers are not 36 | -- needed. 37 | type PathWalker a = PathWalkerT Identity a 38 | 39 | -- | State of the path walker, just a bunch of primitives 40 | -- with continuity guarantee. The continuity is guaranteed 41 | -- by the Path used to derive this primitives. 42 | newtype WalkerState = WalkerState 43 | { _walkerPrims :: [Primitive] 44 | } 45 | 46 | -- | Create a path walker from a given path 47 | runPathWalking :: (Monad m) => Path -> PathWalkerT m a -> m a 48 | runPathWalking path (PathWalkerT walker) = evalStateT walker initialState 49 | where 50 | initialState = WalkerState primsOfPath 51 | primsOfPath = listOfContainer 52 | . flatten 53 | . containerOfList 54 | $ pathToPrimitives path 55 | 56 | -- | Advance by the given amount of pixels on the path. 57 | advanceBy :: Monad m => Float -> PathWalkerT m () 58 | advanceBy by = PathWalkerT . modify $ \s -> 59 | let (_, leftPrimitives) = splitPrimitiveUntil by $ _walkerPrims s in 60 | s { _walkerPrims = leftPrimitives } 61 | 62 | -- | Obtain the current position if we are still on the 63 | -- path, if not, return Nothing. 64 | currentPosition :: (Monad m) => PathWalkerT m (Maybe Point) 65 | currentPosition = PathWalkerT $ gets (currPos . _walkerPrims) 66 | where 67 | currPos [] = Nothing 68 | currPos (prim:_) = Just $ firstPointOf prim 69 | 70 | -- | Obtain the current tangeant of the path if we're still 71 | -- on it. Return Nothing otherwise. 72 | currentTangeant :: (Monad m) => PathWalkerT m (Maybe Vector) 73 | currentTangeant = PathWalkerT $ gets (currTangeant . _walkerPrims) 74 | where 75 | currTangeant [] = Nothing 76 | currTangeant (prim:_) = Just . normalize $ firstTangeantOf prim 77 | 78 | -- | Callback function in charge to transform the DrawOrder 79 | -- given the transformation to place it on the path. 80 | type PathDrawer m px = 81 | Transformation -> PlaneBound -> DrawOrder px -> m () 82 | 83 | -- | This function is the workhorse of the placement, it will 84 | -- walk the path and calculate the appropriate transformation 85 | -- for every order. 86 | drawOrdersOnPath :: Monad m 87 | => PathDrawer m px -- ^ Function handling the placement of the order. 88 | -> Float -- ^ Starting offset 89 | -> Float -- ^ Baseline vertical position in the orders. 90 | -> Path -- ^ Path on which to place the orders. 91 | -> [DrawOrder px] -- ^ Orders to place on a path. 92 | -> m () 93 | drawOrdersOnPath drawer startOffset baseline path orders = 94 | runPathWalking path $ advanceBy startOffset >> go Nothing orders where 95 | go _ [] = return () 96 | go prevX (img : rest) = do 97 | let bounds = planeBounds img 98 | width = boundWidth bounds 99 | cx = fromMaybe startX prevX 100 | V2 startX _ = boundLowerLeftCorner bounds 101 | V2 endX _ = _planeMaxBound bounds 102 | halfWidth = width / 2 103 | spaceWidth = abs $ startX - cx 104 | translation = V2 (negate startX - halfWidth) (- baseline) 105 | 106 | if bounds == mempty then go prevX rest 107 | else do 108 | advanceBy (halfWidth + spaceWidth) 109 | mayPos <- currentPosition 110 | mayDir <- currentTangeant 111 | case (,) <$> mayPos <*> mayDir of 112 | Nothing -> return () -- out of path, stop drawing 113 | Just (pos, dir) -> do 114 | let imageTransform = 115 | translate pos <> toNewXBase dir 116 | <> translate translation 117 | lift $ drawer imageTransform bounds img 118 | advanceBy halfWidth 119 | go (Just endX) rest 120 | 121 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/Operators.hs: -------------------------------------------------------------------------------- 1 | -- | Module providing basic helper functions to help 2 | -- build vector/point calculations. 3 | module Graphics.Rasterific.Operators 4 | ( Point 5 | -- * Lifted operators 6 | , (^&&^) 7 | , (^||^) 8 | , (^==^) 9 | , (^/=^) 10 | , (^<=^) 11 | , (^<^) 12 | , (^<) 13 | 14 | -- * Lifted functions 15 | , vmin 16 | , vmax 17 | , vabs 18 | , vfloor 19 | , vceil 20 | , clampPoint 21 | , midPoint 22 | , middle 23 | , vpartition 24 | , normal 25 | , ifZero 26 | , isNearby 27 | , isDistingableFrom 28 | , isDegenerate 29 | ) where 30 | 31 | import Control.Applicative( liftA2, liftA3 ) 32 | 33 | import Graphics.Rasterific.Linear 34 | ( V2( .. ) 35 | , Additive( .. ) 36 | , Epsilon( nearZero ) 37 | , (^+^) 38 | , (^*) 39 | , dot 40 | , normalize 41 | ) 42 | 43 | infix 4 ^<, ^<=^, ^<^, ^==^, ^/=^ 44 | infixr 3 ^&&^ 45 | infixr 2 ^||^ 46 | 47 | -- | Represent a point 48 | type Point = V2 Float 49 | 50 | -- | Pairwise boolean and operator 51 | (^&&^) :: (Applicative a) => a Bool -> a Bool -> a Bool 52 | {-# INLINE (^&&^) #-} 53 | (^&&^) = liftA2 (&&) 54 | 55 | -- | Pairwise boolean or operator 56 | (^||^) :: (Applicative a) => a Bool -> a Bool -> a Bool 57 | {-# INLINE (^||^) #-} 58 | (^||^) = liftA2 (||) 59 | 60 | -- | Pairwise vector/point equal operator 61 | (^==^) :: (Eq v, Applicative a) => a v -> a v -> a Bool 62 | {-# INLINE (^==^) #-} 63 | (^==^) = liftA2 (==) 64 | 65 | -- | Pairwise vector/point lower than or equal operator 66 | (^<=^) :: (Ord v, Applicative a) => a v -> a v -> a Bool 67 | {-# INLINE (^<=^) #-} 68 | (^<=^) = liftA2 (<=) 69 | 70 | -- | Pairwise vector/point lower than operator 71 | (^<^) :: (Ord v, Applicative a) => a v -> a v -> a Bool 72 | {-# INLINE (^<^) #-} 73 | (^<^) = liftA2 (<) 74 | 75 | -- | Component/scalar lower than operator. 76 | (^<) :: (Applicative a, Ord v) => a v -> v -> a Bool 77 | {-# INLINE (^<) #-} 78 | (^<) vec v = (< v) <$> vec 79 | 80 | -- | Pairwise vector/point difference operator. 81 | (^/=^) :: (Applicative a, Eq v) => a v -> a v -> a Bool 82 | {-# INLINE (^/=^) #-} 83 | (^/=^) = liftA2 (/=) 84 | 85 | -- | Min function between two vector/points. 86 | -- Work on every component separately. 87 | vmin :: (Ord n, Applicative a) => a n -> a n -> a n 88 | {-# INLINE vmin #-} 89 | vmin = liftA2 min 90 | 91 | -- | Max function between to vector/point. 92 | -- Work on every component separatly. 93 | vmax :: (Ord n, Applicative a) => a n -> a n -> a n 94 | {-# INLINE vmax #-} 95 | vmax = liftA2 max 96 | 97 | -- | Abs function for every component of the vector/point. 98 | vabs :: (Num n, Functor a) => a n -> a n 99 | {-# INLINE vabs #-} 100 | vabs = fmap abs 101 | 102 | -- | Floor function for every component of the vector/point. 103 | vfloor :: (Functor a) => a Float -> a Int 104 | {-# INLINE vfloor #-} 105 | vfloor = fmap floor 106 | 107 | -- | ceil function for every component of the vector/point. 108 | vceil :: (Functor a) => a Float -> a Int 109 | {-# INLINE vceil #-} 110 | vceil = fmap ceiling 111 | 112 | -- | Given a point, clamp every coordinates between 113 | -- a given minimum and maximum. 114 | clampPoint :: Point -> Point -> Point -> Point 115 | {-# INLINE clampPoint #-} 116 | clampPoint mini maxi v = vmin maxi $ vmax mini v 117 | 118 | -- | Given two points, return a point in the middle 119 | -- of them. 120 | midPoint :: (Additive a, Fractional coord) => a coord -> a coord -> a coord 121 | {-# INLINE midPoint #-} 122 | midPoint a b = (a ^+^ b) ^* 0.5 123 | 124 | middle :: (Fractional a) => a -> a -> a 125 | {-# INLINE middle #-} 126 | middle a b = (a + b) * 0.5 127 | 128 | -- | Given a boolean choice vector, return elements of 129 | -- the first one if true, of the second one otherwise. 130 | vpartition :: (Applicative a) => a Bool -> a v -> a v -> a v 131 | {-# INLINE vpartition #-} 132 | vpartition = liftA3 choose 133 | where choose True a _ = a 134 | choose False _ b = b 135 | 136 | -- | Calculate a normal vector 137 | normal :: (Floating v, Epsilon v) => V2 v -> V2 v -> V2 v 138 | {-# INLINE normal #-} 139 | normal (V2 ax ay) (V2 bx by) = normalize $ V2 (ay - by) (bx - ax) 140 | 141 | -- | Return the second operand if the vector is 142 | -- nearly null 143 | ifZero :: (Epsilon v) => v -> v -> v 144 | {-# INLINE ifZero #-} 145 | ifZero u v | nearZero u = v 146 | | otherwise = u 147 | 148 | -- | Tell if two points are nearly indistinguishable. 149 | -- If indistinguishable, we can treat them as the same 150 | -- point. 151 | -- point with degenerate coordinates (Infinity/NaN) will be considered 152 | -- as nearby. 153 | isNearby :: Point -> Point -> Bool 154 | {-# INLINE isNearby #-} 155 | isNearby p1 p2 = 156 | -- we keep really small distances because when drawing geometry 157 | -- (possibly scaled) from a large model, every small line account 158 | -- to the coverage, and discarding "small" lines will make artifact 159 | -- because we didn't count coverage correctly. 160 | squareDist < 0.0001 || 161 | isNaN squareDist || isInfinite squareDist -- degenerate case protection 162 | where vec = p1 ^-^ p2 163 | squareDist = vec `dot` vec 164 | 165 | isDegenerate :: Point -> Bool 166 | isDegenerate (V2 x y) = 167 | isNaN x || isNaN y || isInfinite x || isInfinite y 168 | 169 | -- | simply `not (a `isNearby` b)` 170 | isDistingableFrom :: Point -> Point -> Bool 171 | {-# INLINE isDistingableFrom #-} 172 | isDistingableFrom a b = not $ isNearby a b 173 | 174 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/BiSampleable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# LANGUAGE FunctionalDependencies #-} 10 | -- | Module to describe bi-sampleable types 11 | module Graphics.Rasterific.BiSampleable 12 | ( BiSampleable( .. ) 13 | , bilinearInterpolation 14 | , sampledImageShader 15 | ) where 16 | 17 | import Data.Fixed( mod' ) 18 | import Codec.Picture 19 | ( Image( .. ) 20 | , Pixel8 21 | , Pixel( .. ) 22 | , PixelRGBA8( .. ) ) 23 | 24 | import Graphics.Rasterific.Linear 25 | import Graphics.Rasterific.Types 26 | import Graphics.Rasterific.Compositor 27 | import Graphics.Rasterific.Command 28 | import Graphics.Rasterific.PatchTypes 29 | import Graphics.Rasterific.Transformations 30 | 31 | -- | Interpolate a 2D point in a given type 32 | class BiSampleable sampled px | sampled -> px where 33 | -- | The interpolation function 34 | interpolate :: sampled -> Float -> Float -> px 35 | 36 | -- | Basic bilinear interpolator 37 | instance (Pixel px, Modulable (PixelBaseComponent px)) 38 | => BiSampleable (ParametricValues px) px where 39 | {-# INLINE interpolate #-} 40 | interpolate = bilinearPixelInterpolation 41 | 42 | -- | Bicubic interpolator 43 | instance ( InterpolablePixel px 44 | , Num (Holder px Float) 45 | ) => BiSampleable (CubicCoefficient px) px where 46 | {-# INLINE interpolate #-} 47 | interpolate = bicubicInterpolation 48 | 49 | -- | Bilinear interpolation of an image 50 | instance BiSampleable (ImageMesh PixelRGBA8) PixelRGBA8 where 51 | {-# INLINE interpolate #-} 52 | interpolate imesh xb yb = sampledImageShader (_meshImage imesh) SamplerPad x y 53 | where (V2 x y) = applyTransformation (_meshTransform imesh) (V2 xb yb) 54 | 55 | -- | Use another image as a texture for the filling. 56 | -- Contrary to `imageTexture`, this function perform a bilinear 57 | -- filtering on the texture. 58 | -- 59 | sampledImageShader :: forall px. RenderablePixel px 60 | => Image px -> SamplerRepeat -> ShaderFunction px 61 | {-# SPECIALIZE 62 | sampledImageShader :: Image Pixel8 -> SamplerRepeat 63 | -> ShaderFunction Pixel8 #-} 64 | {-# SPECIALIZE 65 | sampledImageShader :: Image PixelRGBA8 -> SamplerRepeat 66 | -> ShaderFunction PixelRGBA8 #-} 67 | sampledImageShader img _ _ _ 68 | | imageWidth img == 0 || imageHeight img == 0 = emptyPx 69 | sampledImageShader img sampling x y = 70 | (at px py `interpX` at pxn py) 71 | `interpY` 72 | (at px pyn `interpX` at pxn pyn) 73 | where 74 | coordSampler SamplerPad maxi v = min (maxi - 1) . max 0 $ floor v 75 | coordSampler SamplerReflect maxi v = 76 | floor $ abs (abs (v - maxif - 1) `mod'` (2 * maxif) - maxif - 1) 77 | where maxif = fromIntegral maxi 78 | coordSampler SamplerRepeat maxi v = floor v `mod` maxi 79 | 80 | w = fromIntegral $ imageWidth img 81 | h = fromIntegral $ imageHeight img 82 | 83 | clampedX = coordSampler sampling w 84 | clampedY = coordSampler sampling h 85 | 86 | px = clampedX x 87 | pxn = clampedX $ x + 1 88 | py = clampedY y 89 | pyn = clampedY $ y + 1 90 | 91 | dx, dy :: Float 92 | !dx = x - fromIntegral (floor x :: Int) 93 | !dy = y - fromIntegral (floor y :: Int) 94 | 95 | at :: Int -> Int -> px 96 | at !xx !yy = 97 | unsafePixelAt rawData $ (yy * w + xx) * compCount 98 | 99 | (covX, icovX) = clampCoverage dx 100 | (covY, icovY) = clampCoverage dy 101 | 102 | interpX = mixWith (const $ alphaOver covX icovX) 103 | interpY = mixWith (const $ alphaOver covY icovY) 104 | 105 | compCount = componentCount (undefined :: px) 106 | rawData = imageData img 107 | 108 | bilinearPixelInterpolation :: (Pixel px, Modulable (PixelBaseComponent px)) 109 | => ParametricValues px -> Float -> Float -> px 110 | {-# SPECIALIZE INLINE 111 | bilinearPixelInterpolation :: ParametricValues PixelRGBA8 -> Float -> Float -> PixelRGBA8 112 | #-} 113 | bilinearPixelInterpolation (ParametricValues { .. }) !dx !dy = 114 | mixWith (const $ alphaOver covY icovY) 115 | (mixWith (const $ alphaOver covX icovX) _northValue _eastValue) 116 | (mixWith (const $ alphaOver covX icovX) _westValue _southValue) 117 | where 118 | (!covX, !icovX) = clampCoverage dx 119 | (!covY, !icovY) = clampCoverage dy 120 | 121 | bilinearInterpolation :: InterpolablePixel px 122 | => ParametricValues px -> Float -> Float -> px 123 | {-# INLINE bilinearInterpolation #-} 124 | bilinearInterpolation ParametricValues { .. } u v = fromFloatPixel $ lerp v uBottom uTop where 125 | -- The arguments are flipped, because the lerp function from Linear is... 126 | -- inversed in u v 127 | !uTop = lerp u (toFloatPixel _eastValue) (toFloatPixel _northValue) 128 | !uBottom = lerp u (toFloatPixel _southValue) (toFloatPixel _westValue) 129 | 130 | 131 | bicubicInterpolation :: forall px . (InterpolablePixel px, Num (Holder px Float)) 132 | => CubicCoefficient px -> Float -> Float -> px 133 | bicubicInterpolation params x y = 134 | fromFloatPixel . fmap clamp $ af ^+^ bf ^+^ cf ^+^ df 135 | where 136 | ParametricValues a b c d = getCubicCoefficients params 137 | maxi = maxRepresentable (Proxy :: Proxy px) 138 | clamp = max 0 . min maxi 139 | xv, vy, vyy, vyyy :: V4 Float 140 | xv = V4 1 x (x*x) (x*x*x) 141 | vy = xv ^* y 142 | vyy = vy ^* y 143 | vyyy = vyy ^* y 144 | 145 | v1 ^^*^ v2 = (^*) <$> v1 <*> v2 146 | 147 | V4 af bf cf df = (a ^^*^ xv) ^+^ (b ^^*^ vy) ^+^ (c ^^*^ vyy) ^+^ (d ^^*^ vyyy) 148 | 149 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/Line.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | -- | Handle straight lines polygon. 3 | module Graphics.Rasterific.Line 4 | ( lineFromPath 5 | , decomposeLine 6 | , clipLine 7 | , sanitizeLine 8 | , sanitizeLineFilling 9 | , lineBreakAt 10 | , flattenLine 11 | , lineLength 12 | , offsetLine 13 | , isLinePoint 14 | , extendLine 15 | ) where 16 | 17 | import Graphics.Rasterific.Linear 18 | ( V2( .. ) 19 | , (^-^) 20 | , (^+^) 21 | , (^*) 22 | , lerp 23 | , norm ) 24 | 25 | import Graphics.Rasterific.Operators 26 | import Graphics.Rasterific.Types 27 | 28 | -- | Transform a list a point to a list of lines 29 | -- 30 | -- > lineFromPath [a, b, c, d] = [Line a b, Line b c, Line c d] 31 | -- 32 | lineFromPath :: [Point] -> [Line] 33 | lineFromPath [] = [] 34 | lineFromPath lst@(_:rest) = 35 | uncurry Line <$> zip lst rest 36 | 37 | isLinePoint :: Line -> Bool 38 | isLinePoint (Line a b) = not $ a `isDistingableFrom` b 39 | 40 | lineLength :: Line -> Float 41 | lineLength (Line a b) = norm (b ^-^ a) 42 | 43 | sanitizeLine :: Line -> Container Primitive 44 | sanitizeLine l@(Line p1 p2) 45 | | p1 `isNearby` p2 = mempty 46 | | otherwise = pure $ LinePrim l 47 | 48 | sanitizeLineFilling :: Line -> Container Primitive 49 | sanitizeLineFilling l@(Line p1 p2) 50 | | isDegenerate p1 || isDegenerate p2 = mempty 51 | | otherwise = pure $ LinePrim l 52 | 53 | lineBreakAt :: Line -> Float -> (Line, Line) 54 | lineBreakAt (Line a b) t = (Line a ab, Line ab b) 55 | where ab = lerp t b a 56 | 57 | flattenLine :: Line -> Container Primitive 58 | flattenLine = pure . LinePrim 59 | 60 | offsetLine :: Float -> Line -> Container Primitive 61 | offsetLine offset (Line a b) = pure . LinePrim $ Line shiftedA shiftedB 62 | where 63 | u = a `normal` b 64 | shiftedA = a ^+^ (u ^* offset) 65 | shiftedB = b ^+^ (u ^* offset) 66 | 67 | -- | Clamp the bezier curve inside a rectangle 68 | -- given in parameter. 69 | clipLine :: Point -- ^ Point representing the "minimal" point for cliping 70 | -> Point -- ^ Point representing the "maximal" point for cliping 71 | -> Line -- ^ The line 72 | -> Container Primitive 73 | clipLine mini maxi poly@(Line a b) 74 | -- If we are in the range bound, return the curve 75 | -- unaltered 76 | | insideX && insideY = pure . LinePrim $ poly 77 | -- If one of the component is outside, clamp 78 | -- the components on the boundaries and output a 79 | -- straight line on this boundary. Useful for the 80 | -- filing case, to clamp the polygon drawing on 81 | -- the edge 82 | | outsideX || outsideY = pure . LinePrim $ Line clampedA clampedB 83 | 84 | -- Not completly inside nor outside, just divide 85 | -- and conquer. 86 | | otherwise = recurse (Line a m) <> recurse (Line m b) 87 | where -- Minimal & maximal dimension of the bezier curve 88 | bmin = vmin a b 89 | bmax = vmax a b 90 | 91 | recurse = clipLine mini maxi 92 | 93 | clamper = clampPoint mini maxi 94 | clampedA = clamper a 95 | clampedB = clamper b 96 | 97 | V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi 98 | V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin 99 | 100 | -- A X-----X-----X B 101 | -- AB 102 | ab = a `midPoint` b 103 | 104 | -- mini 105 | -- +-------------+ 106 | -- | | 107 | -- | | 108 | -- | | 109 | -- +-------------+ 110 | -- maxi 111 | -- the edgeSeparator vector encode which edge 112 | -- is te nearest to the midpoint. 113 | -- if True then it's the 'min' edges which are 114 | -- the nearest, otherwise it's the maximum edge 115 | edgeSeparator = 116 | vabs (ab ^-^ mini) ^<^ vabs (ab ^-^ maxi) 117 | 118 | -- So here we 'solidify' the nearest edge position 119 | -- in an edge vector. 120 | edge = vpartition edgeSeparator mini maxi 121 | 122 | -- If we're near an edge, snap the component to the 123 | -- edge. 124 | m = vpartition (vabs (ab ^-^ edge) ^< 0.1) edge ab 125 | 126 | -- TODO: implement better algorithm for lines, should 127 | -- be doable. 128 | decomposeLine :: Line -> Producer EdgeSample 129 | decomposeLine (Line (V2 aRx aRy) (V2 bRx bRy)) = go aRx aRy bRx bRy where 130 | go !ax !ay !bx !by cont 131 | | insideX && insideY = 132 | let !px = fromIntegral $ min floorAx floorBx 133 | !py = fromIntegral $ min floorAy floorBy 134 | !w = px + 1 - (bx `middle` ax) 135 | !h = by - ay 136 | in 137 | EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont 138 | where 139 | floorAx, floorAy :: Int 140 | !floorAx = floor ax 141 | !floorAy = floor ay 142 | 143 | !floorBx = floor bx 144 | !floorBy = floor by 145 | 146 | !insideX = floorAx == floorBx || ceiling ax == (ceiling bx :: Int) 147 | !insideY = floorAy == floorBy || ceiling ay == (ceiling by :: Int) 148 | 149 | 150 | go !ax !ay !bx !by cont = go ax ay mx my $ go mx my bx by cont 151 | where 152 | !abx = ax `middle` bx 153 | !aby = ay `middle` by 154 | 155 | !mx | abs (abx - mini) < 0.1 = mini 156 | | abs (abx - maxi) < 0.1 = maxi 157 | | otherwise = abx 158 | where !mini = fromIntegral (floor abx :: Int) 159 | !maxi = fromIntegral (ceiling abx :: Int) 160 | 161 | !my | abs (aby - mini) < 0.1 = mini 162 | | abs (aby - maxi) < 0.1 = maxi 163 | | otherwise = aby 164 | where !mini = fromIntegral (floor aby :: Int) 165 | !maxi = fromIntegral (ceiling aby :: Int) 166 | 167 | -- | Extend a line by two coefficient, giving a line that's a 168 | -- linear extension of the original line. 169 | -- 170 | -- law: extendLine 0 1 = id 171 | extendLine :: Float -- ^ Begin extension coefficient 172 | -> Float -- ^ End extension coefficient 173 | -> Line -- ^ Line to transform 174 | -> Line 175 | extendLine beg end (Line p1 p2) = 176 | Line (lerp beg p2 p1) (lerp end p2 p1) 177 | 178 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/Transformations.hs: -------------------------------------------------------------------------------- 1 | -- | This module provide some helpers in order 2 | -- to perform basic geometric transformation on 3 | -- the drawable primitives. 4 | -- 5 | -- You can combine the transformation is `mappend` or 6 | -- the `(\<\>)` operator from "Data.Monoid" . 7 | module Graphics.Rasterific.Transformations 8 | ( Transformation( .. ) 9 | , applyTransformation 10 | , applyVectorTransformation 11 | , translate 12 | , scale 13 | , rotate 14 | , rotateCenter 15 | , skewX 16 | , skewY 17 | , toNewXBase 18 | , inverseTransformation 19 | ) where 20 | 21 | import Graphics.Rasterific.Types 22 | import Graphics.Rasterific.Linear( V2( .. ), normalize ) 23 | 24 | -- | Represent a 3*3 matrix for homogenous coordinates. 25 | -- 26 | -- > | A C E | 27 | -- > | B D F | 28 | -- > | 0 0 1 | 29 | -- 30 | data Transformation = Transformation 31 | { _transformA :: {-# UNPACK #-} !Float 32 | , _transformC :: {-# UNPACK #-} !Float 33 | , _transformE :: {-# UNPACK #-} !Float -- ^ X translation 34 | 35 | , _transformB :: {-# UNPACK #-} !Float 36 | , _transformD :: {-# UNPACK #-} !Float 37 | , _transformF :: {-# UNPACK #-} !Float -- ^ Y translation 38 | } 39 | deriving (Eq, Show) 40 | 41 | transformCombine :: Transformation -> Transformation -> Transformation 42 | transformCombine (Transformation a c e 43 | b d f) 44 | 45 | (Transformation a' c' e' 46 | b' d' f') = 47 | Transformation (a * a' + c * b' {- below b' is zero -}) 48 | (a * c' + c * d' {- below d' is zero -}) 49 | (a * e' + c * f' + e {- below f' is one -}) 50 | 51 | (b * a' + d * b' {- below b' is zero -}) 52 | (b * c' + d * d' {- below d' is zero -}) 53 | (b * e' + d * f' + f {- below f' is one -}) 54 | 55 | instance Semigroup Transformation where 56 | (<>) = transformCombine 57 | 58 | instance Monoid Transformation where 59 | mappend = (<>) 60 | mempty = Transformation 1 0 0 61 | 0 1 0 62 | 63 | -- | Effectively transform a point given a transformation. 64 | applyTransformation :: Transformation -> Point -> Point 65 | applyTransformation (Transformation a c e 66 | b d f) (V2 x y) = 67 | V2 (a * x + y * c + e) (b * x + d * y + f) 68 | 69 | -- | Effectively transform a vector given a transformation. 70 | -- The translation part won't be applied. 71 | applyVectorTransformation :: Transformation -> Vector -> Vector 72 | applyVectorTransformation 73 | (Transformation a c _e 74 | b d _f) (V2 x y) = 75 | V2 (a * x + y * c) (b * x + d * y) 76 | 77 | 78 | -- | Create a transformation representing a rotation 79 | -- on the plane. 80 | -- 81 | -- > fill . transform (applyTransformation $ rotate 0.2) 82 | -- > $ rectangle (V2 40 40) 120 120 83 | -- 84 | -- <> 85 | -- 86 | rotate :: Float -- ^ Rotation angle in radian. 87 | -> Transformation 88 | rotate angle = Transformation ca (-sa) 0 89 | sa ca 0 90 | where ca = cos angle 91 | sa = sin angle 92 | 93 | -- | Create a transformation representing a rotation 94 | -- on the plane. The rotation center is given in parameter 95 | -- 96 | -- > fill . transform (applyTransformation $ rotateCenter 0.2 (V2 200 200)) 97 | -- > $ rectangle (V2 40 40) 120 120 98 | -- 99 | -- <> 100 | -- 101 | rotateCenter :: Float -- ^ Rotation angle in radian 102 | -> Point -- ^ Rotation center 103 | -> Transformation 104 | rotateCenter angle p = 105 | translate p <> rotate angle <> translate (negate p) 106 | 107 | 108 | -- | Perform a scaling of the given primitives. 109 | -- 110 | -- > fill . transform (applyTransformation $ scale 2 2) 111 | -- > $ rectangle (V2 40 40) 40 40 112 | -- 113 | -- <> 114 | -- 115 | scale :: Float -> Float -> Transformation 116 | scale scaleX scaleY = 117 | Transformation scaleX 0 0 118 | 0 scaleY 0 119 | 120 | -- | Perform a translation of the given primitives. 121 | -- 122 | -- > fill . transform (applyTransformation $ translate (V2 100 100)) 123 | -- > $ rectangle (V2 40 40) 40 40 124 | -- 125 | -- <> 126 | -- 127 | translate :: Vector -> Transformation 128 | translate (V2 x y) = 129 | Transformation 1 0 x 130 | 0 1 y 131 | 132 | -- | Skew transformation along the 133 | -- X axis. 134 | -- 135 | -- > fill . transform (applyTransformation $ skewX 0.3) 136 | -- > $ rectangle (V2 50 50) 80 80 137 | -- 138 | -- <> 139 | -- 140 | skewX :: Float -> Transformation 141 | skewX v = 142 | Transformation 1 t 0 143 | 0 1 0 144 | where t = tan v 145 | 146 | -- | Skew transformation along the Y axis. 147 | -- 148 | -- > fill . transform (applyTransformation $ skewY 0.3) 149 | -- > $ rectangle (V2 50 50) 80 80 150 | -- 151 | -- <> 152 | -- 153 | skewY :: Float -> Transformation 154 | skewY v = 155 | Transformation 1 0 0 156 | t 1 0 157 | where t = tan v 158 | 159 | -- | Given a new X-acis vector, create a rotation matrix 160 | -- to get into this new base, assuming an Y basis orthonormal 161 | -- to the X one. 162 | toNewXBase :: Vector -> Transformation 163 | toNewXBase vec = 164 | Transformation dx (-dy) 0 165 | dy dx 0 166 | where V2 dx dy = normalize vec 167 | 168 | transformationDeterminant :: Transformation -> Float 169 | transformationDeterminant (Transformation a c _e 170 | b d _f) = a * d - c * b 171 | 172 | -- | Inverse a transformation (if possible) 173 | inverseTransformation :: Transformation -> Maybe Transformation 174 | inverseTransformation trans 175 | | transformationDeterminant trans == 0 = Nothing 176 | inverseTransformation (Transformation a c e 177 | b d f) = 178 | Just $ Transformation a' c' e' b' d' f' 179 | where det = a * d - b * c 180 | a' = d / det 181 | c' = (- c) / det 182 | e' = (c * f - e * d) / det 183 | 184 | b' = (- b) / det 185 | d' = a / det 186 | f' = (e * b - a * f) / det 187 | 188 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/Arc.hs: -------------------------------------------------------------------------------- 1 | -- | Translation of cairo-arc.c 2 | module Graphics.Rasterific.Arc( Direction( .. ), arcInDirection ) where 3 | 4 | import Data.Maybe( fromMaybe ) 5 | import qualified Data.Vector.Unboxed as VU 6 | 7 | import Graphics.Rasterific.Transformations 8 | import Graphics.Rasterific.Linear 9 | import Graphics.Rasterific.Types 10 | 11 | 12 | errorTable :: VU.Vector (Float, Float) 13 | errorTable = VU.imap calcAngle errors where 14 | calcAngle i a = (pi / fromIntegral i, a) 15 | errors = VU.fromListN 10 16 | [ 0.0185185185185185036127 17 | , 0.000272567143730179811158 18 | , 2.38647043651461047433e-05 19 | , 4.2455377443222443279e-06 20 | , 1.11281001494389081528e-06 21 | , 3.72662000942734705475e-07 22 | , 1.47783685574284411325e-07 23 | , 6.63240432022601149057e-08 24 | , 3.2715520137536980553e-08 25 | , 1.73863223499021216974e-08 26 | , 9.81410988043554039085e-09 ] 27 | 28 | {- Spline deviation from the circle in radius would be given by: 29 | 30 | error = sqrt (x**2 + y**2) - 1 31 | 32 | A simpler error function to work with is: 33 | 34 | e = x**2 + y**2 - 1 35 | 36 | From "Good approximation of circles by curvature-continuous Bezier 37 | curves", Tor Dokken and Morten Daehlen, Computer Aided Geometric 38 | Design 8 (1990) 22-41, we learn: 39 | 40 | abs (max(e)) = 4/27 * sin**6(angle/4) / cos**2(angle/4) 41 | 42 | and 43 | abs (error) =~ 1/2 * e 44 | 45 | Of course, this error value applies only for the particular spline 46 | approximation that is used in _cairo_gstate_arc_segment. -} 47 | fixAngleError :: Int -> Float -> Float 48 | fixAngleError i tolerance 49 | | errorNormalized > tolerance = fixAngleError (i + 1) tolerance 50 | | otherwise = angle 51 | where 52 | angle = pi / fromIntegral i 53 | errorNormalized = 2.0/27.0 * (sin (angle / 4) ** 6) / (cos (angle / 4) ** 2) 54 | 55 | arcMaxAngleForToleranceNormalized :: Float -> Float 56 | arcMaxAngleForToleranceNormalized tolerance = fixAngleError (angleIndex + 1) tolerance 57 | where 58 | angleIndex = fromMaybe 59 | (VU.length errorTable) $ 60 | VU.findIndex ((< tolerance) . snd) errorTable 61 | 62 | arcSegmentsNeeded :: Float -> Float -> Transformation -> Float 63 | -> Int 64 | arcSegmentsNeeded angle radius trans tolerance = ceiling (angle / maxAngle) where 65 | -- the error is amplified by at most the length of the 66 | -- major axis of the circle; see cairo-pen.c for a more detailed analysis 67 | -- of this. 68 | majorAxis = matrixTransformedCircleMajorAxis trans radius 69 | maxAngle = arcMaxAngleForToleranceNormalized (tolerance / majorAxis) 70 | 71 | -- determine the length of the major axis of a circle of the given radius 72 | -- after applying the transformation matrix. 73 | matrixTransformedCircleMajorAxis :: Transformation -> Float -> Float 74 | matrixTransformedCircleMajorAxis (Transformation a c _ 75 | b d _) radius = 76 | radius * sqrt (f + norm v) 77 | where 78 | i = a*a + b*b; 79 | j = c*c + d*d; 80 | 81 | f = 0.5 * (i + j) 82 | v = V2 (0.5 * (i - j)) (a * c + b * d) 83 | -- we don't need the minor axis length, which is 84 | -- double min = radius * sqrt (f - sqrt (g*g+h*h)); 85 | 86 | -- | Direction of the arc 87 | data Direction = Forward | Backward 88 | 89 | clampAngle :: Float -> Float -> Float 90 | clampAngle angleMin = go where 91 | go angleMax 92 | | angleMax - angleMin > 4 * pi = go $ angleMax - 2 * pi 93 | | otherwise = angleMax 94 | 95 | subdivideAngles :: (Monoid m) 96 | => Direction -> (Float -> Float -> m) -> Float -> Float -> m 97 | subdivideAngles dir f aMin = go aMin . clampAngle aMin where 98 | go angleMin angleMax | deltaAngle > pi = case dir of 99 | Forward -> go angleMin angleMid <> go angleMid angleMax 100 | Backward -> go angleMid angleMax <> go angleMin angleMid 101 | where 102 | deltaAngle = angleMax - angleMin 103 | angleMid = angleMin + deltaAngle / 2 104 | go angleMin angleMax = f angleMin angleMax 105 | 106 | 107 | {- We want to draw a single spline approximating a circular arc radius 108 | R from angle A to angle B. Since we want a symmetric spline that 109 | matches the endpoints of the arc in position and slope, we know 110 | that the spline control points must be: 111 | 112 | (R * cos(A), R * sin(A)) 113 | (R * cos(A) - h * sin(A), R * sin(A) + h * cos (A)) 114 | (R * cos(B) + h * sin(B), R * sin(B) - h * cos (B)) 115 | (R * cos(B), R * sin(B)) 116 | 117 | for some value of h. 118 | 119 | "Approximation of circular arcs by cubic poynomials", Michael 120 | Goldapp, Computer Aided Geometric Design 8 (1991) 227-238, provides 121 | various values of h along with error analysis for each. 122 | 123 | From that paper, a very practical value of h is: 124 | 125 | h = 4/3 * tan(angle/4) 126 | 127 | This value does not give the spline with minimal error, but it does 128 | provide a very good approximation, (6th-order convergence), and the 129 | error expression is quite simple, (see the comment for 130 | _arc_error_normalized). 131 | -} 132 | arcSegment :: Point -> Float -> Float -> Float -> PathCommand 133 | arcSegment (V2 xc yc) radius angleA angleB = PathCubicBezierCurveTo p1 p2 p3 where 134 | rSinA = radius * sin angleA 135 | rCosA = radius * cos angleA 136 | rSinB = radius * sin angleB 137 | rCosB = radius * cos angleB 138 | 139 | h = 4.0/3.0 * tan ((angleB - angleA) / 4.0) 140 | 141 | p1 = V2 (xc + rCosA - h * rSinA) (yc + rSinA + h * rCosA) 142 | p2 = V2 (xc + rCosB + h * rSinB) (yc + rSinB - h * rCosB) 143 | p3 = V2 (xc + rCosB) (yc + rSinB) 144 | 145 | -- | Translate an arc with a definition similar to the 146 | -- one given in Cairo to a list of bezier path command 147 | arcInDirection :: Point -- ^ center 148 | -> Float -- ^ Radius 149 | -> Direction 150 | -> Float -- ^ Tolerance 151 | -> Float -- ^ Angle minimum 152 | -> Float -- ^ Angle maximum 153 | -> [PathCommand] 154 | arcInDirection p@(V2 px py) radius dir tolerance 155 | | isNaN px || isNaN py || isNaN radius = mempty 156 | | otherwise = subdivideAngles dir go where 157 | go angleMin angleMax = commands where 158 | deltaAngle = angleMax - angleMin 159 | segmentCount = arcSegmentsNeeded deltaAngle radius mempty tolerance 160 | 161 | (angle, angleStep) = case dir of 162 | Forward -> (angleMin, deltaAngle / fromIntegral segmentCount) 163 | Backward -> (angleMax, - deltaAngle / fromIntegral segmentCount) 164 | 165 | commands = 166 | [arcSegment p radius a (a + angleStep) 167 | | i <- [0 .. segmentCount - 1] 168 | , let a = angle + angleStep * fromIntegral i] 169 | 170 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/Texture.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | 6 | -- | Module describing the various filling method of the 7 | -- geometric primitives. 8 | -- 9 | -- All points coordinate given in this module are expressed 10 | -- final image pixel coordinates. 11 | module Graphics.Rasterific.Texture 12 | ( Texture 13 | , Gradient 14 | , withSampler 15 | , uniformTexture 16 | -- * Texture kind 17 | , linearGradientTexture 18 | , radialGradientTexture 19 | , radialGradientWithFocusTexture 20 | , sampledImageTexture 21 | , patternTexture 22 | , meshPatchTexture 23 | 24 | -- * Texture manipulation 25 | , modulateTexture 26 | , transformTexture 27 | ) where 28 | 29 | 30 | import Codec.Picture.Types( Pixel( .. ), Image( .. ) ) 31 | import Graphics.Text.TrueType( Dpi ) 32 | import Graphics.Rasterific 33 | import Graphics.Rasterific.MeshPatch 34 | import Graphics.Rasterific.Command 35 | import Graphics.Rasterific.Transformations 36 | 37 | -- | Set the repeat pattern of the texture (if any). 38 | -- With padding: 39 | -- 40 | -- > withTexture (sampledImageTexture textureImage) $ 41 | -- > fill $ rectangle (V2 0 0) 200 200 42 | -- 43 | -- <> 44 | -- 45 | -- With repeat: 46 | -- 47 | -- > withTexture (withSampler SamplerRepeat $ 48 | -- > sampledImageTexture textureImage) $ 49 | -- > fill $ rectangle (V2 0 0) 200 200 50 | -- 51 | -- <> 52 | -- 53 | -- With reflect: 54 | -- 55 | -- > withTexture (withSampler SamplerReflect $ 56 | -- > sampledImageTexture textureImage) $ 57 | -- > fill $ rectangle (V2 0 0) 200 200 58 | -- 59 | -- <> 60 | -- 61 | withSampler :: SamplerRepeat -> Texture px -> Texture px 62 | withSampler = WithSampler 63 | 64 | -- | Transform the coordinates used for texture before applying 65 | -- it, allow interesting transformations. 66 | -- 67 | -- > withTexture (withSampler SamplerRepeat $ 68 | -- > transformTexture (rotateCenter 1 (V2 0 0) <> 69 | -- > scale 0.5 0.25) 70 | -- > $ sampledImageTexture textureImage) $ 71 | -- > fill $ rectangle (V2 0 0) 200 200 72 | -- 73 | -- <> 74 | -- 75 | transformTexture :: Transformation -> Texture px -> Texture px 76 | transformTexture = WithTextureTransform 77 | 78 | -- | The uniform texture is the simplest texture of all: 79 | -- an uniform color. 80 | uniformTexture :: px -- ^ The color used for all the texture. 81 | -> Texture px 82 | uniformTexture = SolidTexture 83 | 84 | 85 | -- | Texture using a mesh patch as definition 86 | meshPatchTexture :: PatchInterpolation -> MeshPatch px -> Texture px 87 | meshPatchTexture = MeshPatchTexture 88 | 89 | -- | Linear gradient texture. 90 | -- 91 | -- > let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) 92 | -- > ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) 93 | -- > ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in 94 | -- > withTexture (linearGradientTexture SamplerPad gradDef 95 | -- > (V2 40 40) (V2 130 130)) $ 96 | -- > fill $ circle (V2 100 100) 100 97 | -- 98 | -- <> 99 | -- 100 | linearGradientTexture :: Gradient px -- ^ Gradient description. 101 | -> Point -- ^ Linear gradient start point. 102 | -> Point -- ^ Linear gradient end point. 103 | -> Texture px 104 | linearGradientTexture gradient start end = 105 | LinearGradientTexture gradient (Line start end) 106 | 107 | -- | Use another image as a texture for the filling. 108 | -- Contrary to `imageTexture`, this function perform a bilinear 109 | -- filtering on the texture. 110 | -- 111 | sampledImageTexture :: Image px -> Texture px 112 | sampledImageTexture = SampledTexture 113 | 114 | -- | Radial gradient texture 115 | -- 116 | -- > let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) 117 | -- > ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) 118 | -- > ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in 119 | -- > withTexture (radialGradientTexture gradDef 120 | -- > (V2 100 100) 75) $ 121 | -- > fill $ circle (V2 100 100) 100 122 | -- 123 | -- <> 124 | -- 125 | radialGradientTexture :: Gradient px -- ^ Gradient description 126 | -> Point -- ^ Radial gradient center 127 | -> Float -- ^ Radial gradient radius 128 | -> Texture px 129 | radialGradientTexture = RadialGradientTexture 130 | 131 | -- | Radial gradient texture with a focus point. 132 | -- 133 | -- > let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) 134 | -- > ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) 135 | -- > ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in 136 | -- > withTexture (radialGradientWithFocusTexture gradDef 137 | -- > (V2 100 100) 75 (V2 70 70) ) $ 138 | -- > fill $ circle (V2 100 100) 100 139 | -- 140 | -- <> 141 | -- 142 | radialGradientWithFocusTexture 143 | :: Gradient px -- ^ Gradient description 144 | -> Point -- ^ Radial gradient center 145 | -> Float -- ^ Radial gradient radius 146 | -> Point -- ^ Radial gradient focus point 147 | -> Texture px 148 | radialGradientWithFocusTexture = RadialGradientWithFocusTexture 149 | 150 | -- | Perform a multiplication operation between a full color texture 151 | -- and a greyscale one, used for clip-path implementation. 152 | modulateTexture :: Texture px -- ^ The full blown texture. 153 | -> Texture (PixelBaseComponent px) -- ^ A greyscale modulation texture. 154 | -> Texture px -- ^ The resulting texture. 155 | modulateTexture = ModulateTexture 156 | 157 | 158 | -- | Use a drawing as a repeating background pattern. 159 | -- 160 | -- > let pattern = 161 | -- > patternTexture 40 40 96 (PixelRGBA8 0xFF 0x53 0x73 255) . 162 | -- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 255) $ 163 | -- > fill $ circle (V2 20 20) 13 164 | -- > in 165 | -- > withTexture pattern $ 166 | -- > fill $ roundedRectangle (V2 20 20) 160 160 20 20 167 | -- 168 | -- <> 169 | -- 170 | patternTexture :: RenderablePixel px 171 | => Int -- ^ Width 172 | -> Int -- ^ Height 173 | -> Dpi -- ^ Dpi if text is present in pattern 174 | -> px -- ^ Pattern background color 175 | -> Drawing px () -- ^ Drawing defining the pattern 176 | -> Texture px 177 | patternTexture w h dpi back drawing = 178 | PatternTexture w h back drawing $ 179 | renderDrawingAtDpi w h dpi back drawing 180 | 181 | -------------------------------------------------------------------------------- /changelog: -------------------------------------------------------------------------------- 1 | Change log 2 | ========== 3 | 4 | v0.7.5.3 April 1st 2020 5 | ----------------------- 6 | 7 | * Fix to draw really small features (tweaked tolerance again...) 8 | 9 | v0.7.5.2 April 1st 2020 10 | ----------------------- 11 | 12 | * No fish 13 | * handle transformation while stroking (woopsie...) 14 | 15 | v0.7.5.1 January 2020 16 | --------------------- 17 | 18 | * Reworked sanitization in the filling case, only culling geometry 19 | with generate coordinate, really small geometry can still contribute 20 | meaningfully to filling 21 | 22 | v0.7.5 November 2019 23 | -------------------- 24 | 25 | * Adding better sanitization of geometry in presence of NaN 26 | and infinity. 27 | * Better handling of max width and height of caching (related 28 | to weird clip issue combined with caching) 29 | 30 | v0.7.4.3 May 2019 31 | ----------------- 32 | 33 | * Fix round cap on degenerate cubic bezier (with null normal) 34 | 35 | v0.7.4.2 December 2018 36 | ---------------------- 37 | 38 | * Refactoring: minor enhancement in the PathWalker 39 | (newtype instead of single constructor data) (thanks to yairchu) 40 | * Fix: PDF rendering didn't produce valid pdf in some cases, 41 | the XRef table wasn't sorted by ID (thanks to robx) 42 | 43 | v0.7.4.1 October 2018 44 | --------------------- 45 | 46 | * Fix: GHC 8.6 compat 47 | 48 | v0.7.4 August 2018 49 | ------------------ 50 | 51 | * Fix: Rendering bug with self-closing cubic bezier curve 52 | * Fix: dashed stroking of tiny features 53 | * Adding: multiple page pdf rendering (jprider63) 54 | 55 | v0.7.3 56 | ------ 57 | 58 | * Fix: PDF output with stroke of width 0 (thanks to robx) 59 | 60 | v0.7.2.2/0.7.2.3 61 | ---------------- 62 | 63 | * Fix: adding Semigroup instances for GHC 8.4 64 | 65 | v0.7.2.1 66 | -------- 67 | 68 | * Fix: sampling empty image 69 | 70 | v0.7.2 71 | ------ 72 | 73 | * Fix: handling infinity/NaN in geometry helpers 74 | * Enhancement: better grandient mesh as texture handling. 75 | 76 | v0.7.1 77 | ------ 78 | 79 | * Addition: arc path helper 80 | * Fix: Composition of clip path with transformation. 81 | 82 | V0.7 83 | ---- 84 | 85 | * Addition: Gradient Mesh! 86 | 87 | v0.6.1.1 May 2016 88 | ----------------- 89 | 90 | * Fix: GHC 8.0 bound fix 91 | 92 | v0.6.1 May 2015 93 | --------------- 94 | 95 | * Fix: Correcting bytestring lower bounds 96 | 97 | v0.6 May 2015 98 | ------------- 99 | 100 | * Adding: repeating background pattern texture. 101 | * Added: PDF output without images (for now) 102 | 103 | v0.5.2.1 April 2015 104 | ------------------- 105 | 106 | * Fixed: non-composability of cached elements 107 | * Fixed: Border size when drawing images was twice too large. 108 | 109 | v0.5.2 April 2015 110 | ----------------- 111 | 112 | * Enhancement: Added a withGroupOpacity to render elements with 113 | a global opacity. 114 | 115 | v0.5.1 March 2015 116 | ----------------- 117 | 118 | * Enhancement: Generalizing geometry description, with automatic 119 | conversion, reducing the need of type constructor from Primitive, 120 | and directly filling Path. 121 | 122 | v0.5.0.3 February 2015 123 | ---------------------- 124 | 125 | * Fix: hackage documentation 126 | 127 | v0.5.0.2 February 2015 128 | ---------------------- 129 | * Removing test-suite as it's dependent of some repository-local files 130 | 131 | v0.5.0.1 February 2015 132 | ---------------------- 133 | * Fix: adding missing Arbitrary file in the distribution. 134 | 135 | v0.5 February 2015 136 | ------------------ 137 | 138 | * Breaking Change: Font size is now a newtype in FontyFruity, 139 | propagating the changes. 140 | * Allowing to specify DPI at the top level of the rendering 141 | request. 142 | * Adding: an helper function to retrieve the distance to the 143 | * Changed: font size switched to float. 144 | 145 | v0.4.2 February 2015 146 | -------------------- 147 | * Fix: Cubic bezier clipping 148 | 149 | v0.4.1 January 2015 150 | ------------------- 151 | * Fix: GHC 7.10 compilation 152 | * Adding: Various lens to access some primitive informations. 153 | 154 | v0.4 December 2014 155 | ------------------ 156 | 157 | * Breaking change: Changed the original position scheme for 158 | text, allowing to specify baseline or upper left corner 159 | 160 | * Tried: Fast forward differencing for cubic bezier, not worth 161 | the hassle 162 | * Enhancement: Further optimized decomposition of all primitives, 163 | less alocated memory. 164 | * Enhancement: After optimizing pixel writing, optimized pixel 165 | reading, yielding non-negligeable speed improvements. 166 | * Added: an "immediate" module to avoid constructing 167 | a scene tree. 168 | * Enhancement: Allowing both IO & (ST s) as drawing monads, enabling 169 | interleaved drawing with io operations. 170 | * Added: a "withPathOrientation" function to orient primitives 171 | on a path (allow to draw curved text) 172 | * Added: toNewXBase transformation to create a new basis given 173 | a X axis vector. 174 | * Added: a PathWalker module, to give access to the lower level 175 | path orientation facility. 176 | * Added: some GHC rules for transformations 177 | * Added: a new text function: 'printTextRanges' to allow 178 | easier complex text rendering 179 | 180 | v0.3 June 2014 181 | -------------- 182 | 183 | * Enhancement: Switching main free monad type to the church encoded one. 184 | * Enhancement: Optimized the bezier decomposition, strictness annotations 185 | made wonders. May require forward differencing in the future. 186 | * Enhancement: Implementing specific decomposition for lines. 187 | * Enhancement: Reworked texture system, now allowing some specialized 188 | filler (hoping faster computation). For now only the 189 | solid color has been optimized, and all the transformed 190 | textures. 191 | * Enhancement: Fixing space leak in combineEdgeSamples, avoiding 192 | many allocations. 193 | * Adding: bounding box calculation facility. 194 | * Adding: Exposing outline creation capability 195 | * Adding: a skewX & skewY transformation function. 196 | * Fixing: some numerical stability with the mitter join. 197 | 198 | v0.2.1 April 2014 199 | ----------------- 200 | 201 | * Fixing: transparency in gradients. 202 | * Fixing: alpha composition on top of translucent 203 | background. 204 | 205 | v0.2 April 2014 206 | --------------- 207 | 208 | * Adding: an ellipse helper. 209 | * Adding: a polyline helper. 210 | * Adding: a polygon helper. 211 | * Adding: monoid instance for Drawing. 212 | * Fixing: some stroking bug with cubic bezier curve. 213 | * Fixing: some documentation snippets. 214 | * Adding: a rounded rectangle helper. 215 | * Added: a even-odd filling rule. 216 | * Added: an offset for dashed stroking. 217 | * Added: a transformation module. 218 | * Change: Changed the Transformable typeclass, splitted 219 | it in two. 220 | * Added: a dumping function for the constructed 221 | drawing. 222 | * Adding: an image texture with bilinear filtering. 223 | * Adding: an image helper. 224 | * Enhancement: Some modest performance gain. 225 | 226 | v0.1 February 2014 227 | ------------------ 228 | 229 | * Initial version. 230 | 231 | -------------------------------------------------------------------------------- /Rasterific.cabal: -------------------------------------------------------------------------------- 1 | -- Initial Rasterific.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | name: Rasterific 4 | version: 0.7.5.4 5 | synopsis: A pure haskell drawing engine. 6 | -- A longer description of the package. 7 | description: 8 | <> 9 | . 10 | Rasterific is a vector drawing library (a rasterizer) 11 | implemented in pure haskell. 12 | . 13 | Can render vector graphics to an image and export vector data to PDF. 14 | 15 | license: BSD3 16 | license-file: LICENSE 17 | author: Vincent Berthoux 18 | maintainer: twinside@gmail.com 19 | 20 | -- A copyright notice. 21 | -- copyright: 22 | category: Graphics 23 | build-type: Simple 24 | 25 | -- extra-source-files: 26 | 27 | cabal-version: 1.18 28 | extra-doc-files: docimages/*.png 29 | extra-source-files: changelog 30 | , README.md 31 | , docimages/*.png 32 | , exec-src/docImageGenerator.hs 33 | 34 | Source-Repository head 35 | Type: git 36 | Location: git://github.com/Twinside/Rasterific.git 37 | 38 | Source-Repository this 39 | Type: git 40 | Location: git://github.com/Twinside/Rasterific.git 41 | Tag: v0.7.5.3 42 | 43 | flag embed_linear 44 | description: Embed a reduced version of Linear avoiding a (huge) dep 45 | Default: True 46 | 47 | library 48 | hs-source-dirs: src 49 | exposed-modules: Graphics.Rasterific 50 | , Graphics.Rasterific.Outline 51 | , Graphics.Rasterific.Texture 52 | , Graphics.Rasterific.Linear 53 | , Graphics.Rasterific.Lenses 54 | , Graphics.Rasterific.Transformations 55 | , Graphics.Rasterific.Immediate 56 | , Graphics.Rasterific.PathWalker 57 | , Graphics.Rasterific.Patch 58 | , Graphics.Rasterific.BiSampleable 59 | , Graphics.Rasterific.MeshPatch 60 | 61 | other-modules: Graphics.Rasterific.Line 62 | , Graphics.Rasterific.Command 63 | , Graphics.Rasterific.CubicBezier 64 | , Graphics.Rasterific.QuadraticBezier 65 | , Graphics.Rasterific.Operators 66 | , Graphics.Rasterific.Rasterize 67 | , Graphics.Rasterific.StrokeInternal 68 | , Graphics.Rasterific.ComplexPrimitive 69 | , Graphics.Rasterific.Types 70 | , Graphics.Rasterific.Compositor 71 | , Graphics.Rasterific.MicroPdf 72 | , Graphics.Rasterific.MiniLens 73 | , Graphics.Rasterific.Shading 74 | , Graphics.Rasterific.PlaneBoundable 75 | , Graphics.Rasterific.QuadraticFormula 76 | , Graphics.Rasterific.PatchTypes 77 | , Graphics.Rasterific.CubicBezier.FastForwardDifference 78 | , Graphics.Rasterific.Arc 79 | 80 | ghc-options: -O3 -Wall 81 | -- -ddump-simpl -ddump-to-file -dsuppress-module-prefixes -dsuppress-uniques 82 | ghc-prof-options: -Wall -auto-all 83 | default-language: Haskell2010 84 | 85 | if impl(ghc >= 8.0) 86 | ghc-options: -Wcompat -Wnoncanonical-monad-instances 87 | else 88 | -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8 89 | build-depends: fail == 4.9.*, semigroups == 0.18.* 90 | 91 | build-depends: base >= 4.9 && < 6 92 | , free >= 4.7 93 | , JuicyPixels >= 3.3.2 94 | , FontyFruity >= 0.5.3.4 && < 0.6 95 | , vector >= 0.9 96 | , mtl >= 1.9 97 | , dlist >= 0.6 98 | , primitive >= 0.5 99 | , vector-algorithms >= 0.3 100 | , bytestring >= 0.10.2 101 | , containers >= 0.5 102 | , transformers 103 | 104 | if !flag(embed_linear) 105 | build-depends: linear >= 1.3 106 | cpp-options: -DEXTERNAL_LINEAR 107 | 108 | Executable rastertest 109 | default-language: Haskell2010 110 | Main-Is: rastertest.hs 111 | ghc-options: -Wall -O2 112 | ghc-prof-options: -rtsopts -Wall -auto-all 113 | Hs-Source-Dirs: exec-src 114 | other-modules: Arbitrary 115 | , Sample 116 | 117 | Build-Depends: base >= 4.5 118 | , Rasterific 119 | , JuicyPixels 120 | , directory >= 1.2 121 | , filepath 122 | , vector 123 | , FontyFruity 124 | , binary 125 | , QuickCheck 126 | , deepseq 127 | , bytestring 128 | --, groom 129 | 130 | Executable doc_builder 131 | default-language: Haskell2010 132 | Main-Is: docImageGenerator.hs 133 | ghc-options: -Wall -O2 134 | ghc-prof-options: -rtsopts -Wall -auto-all 135 | Hs-Source-Dirs: exec-src 136 | if os(win32) 137 | cpp-options: -D__WIN32__ 138 | 139 | Build-Depends: base >= 4.5 140 | , Rasterific 141 | , JuicyPixels 142 | , directory >= 1.2 143 | , filepath 144 | , vector 145 | , FontyFruity 146 | , bytestring 147 | 148 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/Compositor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | -- | Compositor handle the pixel composition, which 5 | -- leads to texture composition. 6 | -- Very much a work in progress 7 | module Graphics.Rasterific.Compositor 8 | ( Compositor 9 | , Modulable( .. ) 10 | , InterpolablePixel( .. ) 11 | , maxDistance 12 | , RenderablePixel 13 | , ModulablePixel 14 | , compositionDestination 15 | , compositionAlpha 16 | , emptyPx 17 | ) where 18 | 19 | import Data.Kind ( Type ) 20 | 21 | import Foreign.Storable( Storable ) 22 | import Data.Bits( unsafeShiftR ) 23 | import Data.Word( Word8, Word32 ) 24 | 25 | import Codec.Picture.Types 26 | ( Pixel( .. ) 27 | , PixelRGB8( .. ) 28 | , PixelRGBA8( .. ) 29 | , PackeablePixel( .. ) ) 30 | 31 | import Graphics.Rasterific.Linear 32 | import Graphics.Rasterific.Types 33 | 34 | type Compositor px = 35 | PixelBaseComponent px -> 36 | PixelBaseComponent px -> px -> px -> px 37 | 38 | -- | Used for Coon patch rendering 39 | class ( Applicative (Holder a) 40 | , Functor (Holder a) 41 | , Foldable (Holder a) 42 | , Additive (Holder a) ) => InterpolablePixel a where 43 | type Holder a :: Type -> Type 44 | toFloatPixel :: a -> Holder a Float 45 | fromFloatPixel :: Holder a Float -> a 46 | maxRepresentable :: Proxy a -> Float 47 | 48 | maxDistance :: InterpolablePixel a => a -> a -> Float 49 | maxDistance p1 p2 = maximum $ abs <$> (toFloatPixel p1 ^-^ toFloatPixel p2) 50 | 51 | instance InterpolablePixel Float where 52 | type Holder Float = V1 53 | toFloatPixel = V1 54 | fromFloatPixel (V1 f) = f 55 | maxRepresentable Proxy = 1 56 | 57 | instance InterpolablePixel Word8 where 58 | type Holder Word8 = V1 59 | toFloatPixel = V1 . fromIntegral 60 | fromFloatPixel (V1 f) = floor f 61 | maxRepresentable Proxy = 255 62 | 63 | instance InterpolablePixel PixelRGB8 where 64 | type Holder PixelRGB8 = V3 65 | toFloatPixel (PixelRGB8 r g b) = V3 (to r) (to g) (to b) where to n = fromIntegral n 66 | fromFloatPixel (V3 r g b) = PixelRGB8 (to r) (to g) (to b) where to = floor 67 | maxRepresentable Proxy = 255 68 | 69 | instance InterpolablePixel PixelRGBA8 where 70 | type Holder PixelRGBA8 = V4 71 | toFloatPixel (PixelRGBA8 r g b a) = V4 (to r) (to g) (to b) (to a) 72 | where to n = fromIntegral n 73 | fromFloatPixel (V4 r g b a) = PixelRGBA8 (to r) (to g) (to b) (to a) 74 | where to = floor 75 | maxRepresentable Proxy = 255 76 | 77 | -- | This constraint ensure that a type is a pixel 78 | -- and we're allowed to modulate it's color components 79 | -- generically. 80 | type ModulablePixel px = 81 | ( Pixel px 82 | , PackeablePixel px 83 | , InterpolablePixel px 84 | , InterpolablePixel (PixelBaseComponent px) 85 | , Storable (PackedRepresentation px) 86 | , Modulable (PixelBaseComponent px)) 87 | 88 | -- | This constraint tells us that pixel component 89 | -- must also be pixel and be the "bottom" of component, 90 | -- we cannot go further than a PixelBaseComponent level. 91 | -- 92 | -- Tested pixel types are PixelRGBA8 & Pixel8 93 | type RenderablePixel px = 94 | ( ModulablePixel px 95 | , Pixel (PixelBaseComponent px) 96 | , PackeablePixel (PixelBaseComponent px) 97 | , Num (PackedRepresentation px) 98 | , Num (PackedRepresentation (PixelBaseComponent px)) 99 | , Num (Holder px Float) 100 | , Num (Holder (PixelBaseComponent px) Float) 101 | , Storable (PackedRepresentation (PixelBaseComponent px)) 102 | , PixelBaseComponent (PixelBaseComponent px) 103 | ~ (PixelBaseComponent px) 104 | ) 105 | 106 | -- | Typeclass intented at pixel value modulation. 107 | -- May be throwed out soon. 108 | class (Ord a, Num a) => Modulable a where 109 | -- | Empty value representing total transparency for the given type. 110 | emptyValue :: a 111 | -- | Full value representing total opacity for a given type. 112 | fullValue :: a 113 | -- | Given a Float in [0; 1], return the coverage in [emptyValue; fullValue] 114 | -- The second value is the inverse coverage 115 | clampCoverage :: Float -> (a, a) 116 | 117 | -- | Modulate two elements, staying in the [emptyValue; fullValue] range. 118 | modulate :: a -> a -> a 119 | 120 | -- | Implement a division between two elements. 121 | modiv :: a -> a -> a 122 | 123 | alphaOver :: a -- ^ coverage 124 | -> a -- ^ inverse coverage 125 | -> a -- ^ background 126 | -> a -- ^ foreground 127 | -> a 128 | alphaCompose :: a -> a -> a -> a -> a 129 | 130 | -- | Like modulate but also return the inverse coverage. 131 | coverageModulate :: a -> a -> (a, a) 132 | {-# INLINE coverageModulate #-} 133 | coverageModulate c a = (clamped, fullValue - clamped) 134 | where clamped = modulate a c 135 | 136 | instance Modulable Float where 137 | emptyValue = 0 138 | fullValue = 1 139 | clampCoverage f = (f, 1 - f) 140 | modulate = (*) 141 | modiv = (/) 142 | alphaCompose coverage inverseCoverage backAlpha _ = 143 | coverage + backAlpha * inverseCoverage 144 | alphaOver coverage inverseCoverage background painted = 145 | coverage * painted + background * inverseCoverage 146 | 147 | div255 :: Word32 -> Word32 148 | {-# INLINE div255 #-} 149 | div255 v = (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 150 | 151 | instance Modulable Word8 where 152 | {-# INLINE emptyValue #-} 153 | emptyValue = 0 154 | {-# INLINE fullValue #-} 155 | fullValue = 255 156 | {-# INLINE clampCoverage #-} 157 | clampCoverage f = (fromIntegral c, fromIntegral $ 255 - c) 158 | where c = toWord8 f 159 | 160 | {-# INLINE modulate #-} 161 | modulate c a = fromIntegral . div255 $ fi c * fi a + 128 162 | where fi :: Word8 -> Word32 163 | fi = fromIntegral 164 | 165 | {-# INLINE modiv #-} 166 | modiv c 0 = c 167 | modiv c a = fromIntegral . min 255 $ (fi c * 255) `div` fi a 168 | where fi :: Word8 -> Word32 169 | fi = fromIntegral 170 | 171 | {-# INLINE alphaCompose #-} 172 | alphaCompose coverage inverseCoverage backgroundAlpha _ = 173 | fromIntegral $ div255 v 174 | where fi :: Word8 -> Word32 175 | fi = fromIntegral 176 | v = fi coverage * 255 177 | + fi backgroundAlpha * fi inverseCoverage + 128 178 | 179 | {-# INLINE alphaOver #-} 180 | alphaOver coverage inverseCoverage background painted = 181 | fromIntegral $ div255 v 182 | where fi :: Word8 -> Word32 183 | fi = fromIntegral 184 | v = fi coverage * fi painted + fi background * fi inverseCoverage + 128 185 | 186 | 187 | toWord8 :: Float -> Int 188 | {-# INLINE toWord8 #-} 189 | toWord8 r = floor $ r * 255 + 0.5 190 | 191 | compositionDestination :: (Pixel px, Modulable (PixelBaseComponent px)) 192 | => Compositor px 193 | compositionDestination c _ _ = colorMap (modulate c) 194 | 195 | compositionAlpha :: (Pixel px, Modulable (PixelBaseComponent px)) 196 | => Compositor px 197 | {-# INLINE compositionAlpha #-} 198 | compositionAlpha c ic 199 | | c == emptyValue = const 200 | | c == fullValue = \_ n -> n 201 | | otherwise = \bottom top -> 202 | let bottomOpacity = pixelOpacity bottom 203 | alphaOut = alphaCompose c ic bottomOpacity (pixelOpacity top) 204 | colorComposer _ back fore = 205 | alphaOver c ic (back `modulate` bottomOpacity) fore 206 | `modiv` alphaOut 207 | in 208 | mixWithAlpha colorComposer (\_ _ -> alphaOut) bottom top 209 | 210 | emptyPx :: (RenderablePixel px) => px 211 | -- | Really need a "builder" function for pixel 212 | emptyPx = colorMap (const emptyValue) $ unpackPixel 0 213 | 214 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | module Graphics.Rasterific.CubicBezier.FastForwardDifference 5 | ( ForwardDifferenceCoefficient( .. ) 6 | , bezierToForwardDifferenceCoeff 7 | , rasterizerCubicBezier 8 | , rasterizeTensorPatch 9 | , rasterizeCoonPatch 10 | , estimateFDStepCount 11 | ) where 12 | 13 | import Control.Monad.Primitive( PrimMonad ) 14 | import Control.Monad.State( lift, get ) 15 | import Control.Monad.ST( ST ) 16 | import Data.Bits( unsafeShiftL ) 17 | 18 | import Codec.Picture( PixelRGBA8 ) 19 | import Codec.Picture.Types( MutableImage( .. ) ) 20 | 21 | import Graphics.Rasterific.Compositor 22 | import Graphics.Rasterific.Command 23 | import Graphics.Rasterific.Types 24 | import Graphics.Rasterific.Linear 25 | import Graphics.Rasterific.BiSampleable 26 | import Graphics.Rasterific.PatchTypes 27 | import Graphics.Rasterific.Shading 28 | 29 | data ForwardDifferenceCoefficient = ForwardDifferenceCoefficient 30 | { _fdA :: {-# UNPACK #-} !Float 31 | , _fdB :: {-# UNPACK #-} !Float 32 | , _fdC :: {-# UNPACK #-} !Float 33 | } 34 | 35 | -- | Given a cubic curve, return the initial step size and 36 | -- the coefficient for the forward difference. 37 | -- Initial step is assumed to be "1" 38 | bezierToForwardDifferenceCoeff 39 | :: CubicBezier 40 | -> V2 ForwardDifferenceCoefficient 41 | bezierToForwardDifferenceCoeff (CubicBezier x y z w) = V2 xCoeffs yCoeffs 42 | where 43 | xCoeffs = ForwardDifferenceCoefficient { _fdA = ax, _fdB = bx, _fdC = cx } 44 | yCoeffs = ForwardDifferenceCoefficient { _fdA = ay, _fdB = by, _fdC = cy } 45 | 46 | V2 ax ay = w ^-^ x 47 | V2 bx by = (w ^-^ z ^* 2 ^+^ y) ^* 6 48 | V2 cx cy = (w ^-^ z ^* 3 ^+^ y ^* 3 ^-^ x) ^* 6 49 | 50 | halveFDCoefficients :: ForwardDifferenceCoefficient -> ForwardDifferenceCoefficient 51 | halveFDCoefficients (ForwardDifferenceCoefficient a b c) = 52 | ForwardDifferenceCoefficient { _fdA = a', _fdB = b', _fdC = c' } 53 | where 54 | c' = c * 0.125 55 | b' = b * 0.25 - c' 56 | a' = (a - b') * 0.5 57 | 58 | updateForwardDifferencing :: ForwardDifferenceCoefficient -> ForwardDifferenceCoefficient 59 | updateForwardDifferencing (ForwardDifferenceCoefficient a b c) = 60 | ForwardDifferenceCoefficient (a + b) (b + c) c 61 | 62 | updatePointsAndCoeff :: (Applicative f', Applicative f, Additive f) 63 | => f' (f Float) -> f' (f ForwardDifferenceCoefficient) 64 | -> (f' (f Float), f' (f ForwardDifferenceCoefficient)) 65 | updatePointsAndCoeff pts coeffs = 66 | (advancePoint <$> pts <*> coeffs, fmap updateForwardDifferencing <$> coeffs) 67 | where 68 | fstOf (ForwardDifferenceCoefficient a _ _) = a 69 | advancePoint v c = v ^+^ (fstOf <$> c) 70 | 71 | 72 | estimateFDStepCount :: CubicBezier -> Int 73 | estimateFDStepCount (CubicBezier p0 p1 p2 p3) = 74 | toInt $ maximum [p0 `qd` p1, p2 `qd` p3, (p0 `qd` p2) / 4, (p1 `qd` p3) / 4] 75 | where 76 | toInt = scale . frexp . max 1 . (18 *) 77 | scale (_, r) = (r + 1) `div` 2 78 | 79 | 80 | fixIter :: Int -> (a -> a) -> a -> a 81 | fixIter count f = go count 82 | where 83 | go 0 a = a 84 | go n a = go (n-1) $ f a 85 | 86 | isPointInImage :: MutableImage s a -> Point -> Bool 87 | isPointInImage MutableImage { mutableImageWidth = w, mutableImageHeight = h } (V2 x y) = 88 | 0 <= x && x < fromIntegral w && 0 <= y && y < fromIntegral h 89 | 90 | isCubicBezierOutsideImage :: MutableImage s a -> CubicBezier -> Bool 91 | isCubicBezierOutsideImage img (CubicBezier a b c d) = 92 | not $ isIn a || isIn b || isIn c || isIn d 93 | where isIn = isPointInImage img 94 | 95 | isCubicBezierInImage :: MutableImage s a -> CubicBezier -> Bool 96 | isCubicBezierInImage img (CubicBezier a b c d) = 97 | isIn a && isIn b && isIn c && isIn d 98 | where isIn = isPointInImage img 99 | 100 | -- | Rasterize a cubic bezier curve using the Fast Forward Diffrence 101 | -- algorithm. 102 | rasterizerCubicBezier :: (PrimMonad m, ModulablePixel px, BiSampleable src px) 103 | => src -> CubicBezier 104 | -> Float -> Float 105 | -> Float -> Float 106 | -> DrawContext m px () 107 | {-# SPECIALIZE INLINE 108 | rasterizerCubicBezier :: (ParametricValues PixelRGBA8) -> CubicBezier 109 | -> Float -> Float 110 | -> Float -> Float 111 | -> DrawContext (ST s) PixelRGBA8 () #-} 112 | rasterizerCubicBezier source bez uStart vStart uEnd vEnd = do 113 | canvas <- get 114 | let !baseFfd = bezierToForwardDifferenceCoeff bez 115 | !shiftCount = estimateFDStepCount bez 116 | maxStepCount :: Int 117 | maxStepCount = 1 `unsafeShiftL` shiftCount 118 | !(V2 (ForwardDifferenceCoefficient ax' bx' cx) 119 | (ForwardDifferenceCoefficient ay' by' cy)) = 120 | fixIter shiftCount halveFDCoefficients <$> baseFfd 121 | 122 | !(V2 _du dv) = (V2 uEnd vEnd ^-^ V2 uStart vStart) ^/ fromIntegral maxStepCount 123 | !(V2 xStart yStart) = _cBezierX0 bez 124 | 125 | go !currentStep _ _ _ _ _ _ _ | currentStep >= maxStepCount = return () 126 | go !currentStep !ax !bx !ay !by !x !y !v = do 127 | let !color = interpolate source uStart v 128 | plotOpaquePixel canvas color (floor x) (floor y) 129 | go (currentStep + 1) 130 | (ax + bx) (bx + cx) 131 | (ay + by) (by + cy) 132 | (x + ax) (y + ay) 133 | (v + dv) 134 | 135 | goUnsafe !currentStep _ _ _ _ _ _ _ | currentStep >= maxStepCount = return () 136 | goUnsafe !currentStep !ax !bx !ay !by !x !y !v = do 137 | let !color = interpolate source uStart v 138 | unsafePlotOpaquePixel canvas color (floor x) (floor y) 139 | goUnsafe (currentStep + 1) 140 | (ax + bx) (bx + cx) 141 | (ay + by) (by + cy) 142 | (x + ax) (y + ay) 143 | (v + dv) 144 | 145 | if isCubicBezierOutsideImage canvas bez then 146 | return () 147 | else if isCubicBezierInImage canvas bez then 148 | lift $ goUnsafe 0 ax' bx' ay' by' xStart yStart vStart 149 | else 150 | lift $ go 0 ax' bx' ay' by' xStart yStart vStart 151 | 152 | -- | Rasterize a coon patch using the Fast Forward Diffrence algorithm, 153 | -- likely to be faster than the subdivision one. 154 | rasterizeCoonPatch :: (PrimMonad m, ModulablePixel px, BiSampleable src px) 155 | => CoonPatch src -> DrawContext m px () 156 | {-# SPECIALIZE rasterizeCoonPatch :: CoonPatch (ParametricValues PixelRGBA8) 157 | -> DrawContext (ST s) PixelRGBA8 () #-} 158 | rasterizeCoonPatch = rasterizeTensorPatch . toTensorPatch 159 | 160 | -- | Rasterize a tensor patch using the Fast Forward Diffrence algorithm, 161 | -- likely to be faster than the subdivision one. 162 | rasterizeTensorPatch :: (PrimMonad m, ModulablePixel px, BiSampleable src px) 163 | => TensorPatch src -> DrawContext m px () 164 | {-# SPECIALIZE rasterizeTensorPatch :: TensorPatch (ParametricValues PixelRGBA8) 165 | -> DrawContext (ST s) PixelRGBA8 () #-} 166 | rasterizeTensorPatch TensorPatch { .. } = 167 | go maxStepCount basePoints ffCoeff 0 168 | where 169 | !curves = V4 _curve0 _curve1 _curve2 _curve3 170 | !shiftStep = maximum $ estimateFDStepCount <$> [_curve0, _curve1, _curve2, _curve3] 171 | 172 | !basePoints = _cBezierX0 <$> curves 173 | !ffCoeff = 174 | fmap (fixIter shiftStep halveFDCoefficients) . bezierToForwardDifferenceCoeff <$> curves 175 | 176 | maxStepCount :: Int 177 | !maxStepCount = 1 `unsafeShiftL` shiftStep 178 | 179 | !du = 1 / fromIntegral maxStepCount 180 | 181 | toBezier (V4 a b c d) = CubicBezier a b c d 182 | 183 | go 0 _pts _coeffs _uvStart = return () 184 | go i !pts !coeffs !ut = do 185 | let (newPoints, newCoeff) = updatePointsAndCoeff pts coeffs 186 | rasterizerCubicBezier _tensorValues (toBezier pts) ut 0 ut 1 187 | go (i - 1) newPoints newCoeff (ut + du) 188 | 189 | frexp :: Float -> (Float, Int) 190 | frexp x 191 | | isNaN x = error "NaN given to frexp" 192 | | isInfinite x = error "infinity given to frexp" 193 | | otherwise = go x 0 194 | where 195 | go s e 196 | | s >= 1.0 = go (s / 2) (e + 1) 197 | | s < 0.5 = go (s * 2) (e - 1) 198 | | otherwise = (s, e) 199 | 200 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/Command.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | module Graphics.Rasterific.Command ( Drawing 7 | , DrawCommand( .. ) 8 | , DrawContext 9 | , TextRange( .. ) 10 | , dumpDrawing 11 | , Texture( .. ) 12 | , Gradient 13 | , ShaderFunction 14 | , ImageTransformer 15 | , dumpTexture 16 | ) where 17 | 18 | import Data.Kind ( Type ) 19 | 20 | import Control.Monad.ST( ST ) 21 | import Control.Monad.State( StateT ) 22 | import Control.Monad.Primitive( PrimState ) 23 | import Control.Monad.Free( Free( .. ), liftF ) 24 | import Control.Monad.Free.Church( F, fromF ) 25 | import Codec.Picture.Types( Image, Pixel( .. ), Pixel8 ) 26 | 27 | import Codec.Picture.Types( MutableImage ) 28 | import Graphics.Rasterific.Types 29 | import Graphics.Rasterific.Transformations 30 | import Graphics.Rasterific.PatchTypes 31 | 32 | import Graphics.Text.TrueType( Font, PointSize ) 33 | 34 | -- | Monad used to record the drawing actions. 35 | type Drawing px = F (DrawCommand px) 36 | 37 | -- | Monad used to describe the drawing context. 38 | type DrawContext m px = 39 | StateT (MutableImage (PrimState m) px) m 40 | 41 | -- | Structure defining how to render a text range 42 | data TextRange px = TextRange 43 | { _textFont :: Font -- ^ Font used during the rendering 44 | , _textSize :: PointSize -- ^ Size of the text (in pixels) 45 | , _text :: String -- ^ Text to draw 46 | -- | Texture to use for drawing, if Nothing, the currently 47 | -- active texture is used. 48 | , _textTexture :: Maybe (Texture px) 49 | } 50 | 51 | type ShaderFunction px = Float -> Float -> px 52 | 53 | type ImageTransformer px = Int -> Int -> px -> px 54 | 55 | -- | A gradient definition is just a list of stop 56 | -- and pixel values. For instance for a simple gradient 57 | -- of black to white, the finition would be : 58 | -- 59 | -- > [(0, PixelRGBA8 0 0 0 255), (1, PixelRGBA8 255 255 255 255)] 60 | -- 61 | -- the first stop value must be zero and the last, one. 62 | -- 63 | type Gradient px = [(Float, px)] 64 | 65 | -- | Reification of texture type 66 | data Texture (px :: Type) 67 | = SolidTexture !px 68 | | LinearGradientTexture !(Gradient px) !Line 69 | | RadialGradientTexture !(Gradient px) !Point !Float 70 | | RadialGradientWithFocusTexture !(Gradient px) !Point !Float !Point 71 | | WithSampler !SamplerRepeat (Texture px) 72 | | WithTextureTransform !Transformation (Texture px) 73 | | SampledTexture !(Image px) 74 | | RawTexture !(Image px) 75 | | ShaderTexture !(ShaderFunction px) 76 | | ModulateTexture (Texture px) (Texture (PixelBaseComponent px)) 77 | | AlphaModulateTexture (Texture px) (Texture (PixelBaseComponent px)) 78 | | PatternTexture !Int !Int !px (Drawing px ()) (Image px) 79 | | MeshPatchTexture !PatchInterpolation !(MeshPatch px) 80 | 81 | 82 | data DrawCommand px next 83 | = Fill FillMethod [Primitive] next 84 | | CustomRender (forall s. DrawContext (ST s) px ()) next 85 | | MeshPatchRender !PatchInterpolation (MeshPatch px) next 86 | | Stroke Float Join (Cap, Cap) [Primitive] next 87 | | DashedStroke Float DashPattern Float Join (Cap, Cap) [Primitive] next 88 | | TextFill Point [TextRange px] next 89 | | SetTexture (Texture px) 90 | (Drawing px ()) next 91 | | WithGlobalOpacity (PixelBaseComponent px) (Drawing px ()) next 92 | | WithImageEffect (Image px -> ImageTransformer px) (Drawing px ()) next 93 | | WithCliping (forall innerPixel. Drawing innerPixel ()) 94 | (Drawing px ()) next 95 | | WithTransform Transformation (Drawing px ()) next 96 | | WithPathOrientation Path Float (Drawing px ()) next 97 | 98 | -- | This function will spit out drawing instructions to 99 | -- help debugging. 100 | -- 101 | -- The outputted code looks like Haskell, but there is no 102 | -- guarantee that it is compilable. 103 | dumpDrawing :: ( Show px 104 | , Show (PixelBaseComponent px) 105 | , PixelBaseComponent (PixelBaseComponent px) 106 | ~ (PixelBaseComponent px) 107 | 108 | ) => Drawing px () -> String 109 | dumpDrawing = go . fromF where 110 | go :: 111 | ( Show px 112 | , Show (PixelBaseComponent px) 113 | , PixelBaseComponent (PixelBaseComponent px) 114 | ~ (PixelBaseComponent px) 115 | 116 | ) => Free (DrawCommand px) () -> String 117 | go (Pure ()) = "return ()" 118 | go (Free (MeshPatchRender i m next)) = 119 | "renderMeshPatch (" ++ show i ++ ") (" ++ show m ++ ") >>= " ++ go next 120 | go (Free (CustomRender _r next)) = 121 | "customRender _ >>= " ++ go next 122 | go (Free (WithImageEffect _effect sub next)) = 123 | "withImageEffect ({- fun -}) (" ++ go (fromF sub) ++ ") >>= " ++ go next 124 | go (Free (WithGlobalOpacity opa sub next)) = 125 | "withGlobalOpacity " ++ show opa ++ " (" ++ go (fromF sub) ++ ") >>= " ++ go next 126 | go (Free (WithPathOrientation path point drawing next)) = 127 | "withPathOrientation (" ++ show path ++ ") (" 128 | ++ show point ++ ") (" 129 | ++ go (fromF drawing) ++ ") >>= " 130 | ++ go next 131 | go (Free (Fill _ prims next)) = 132 | "fill " ++ show prims ++ " >>=\n" ++ go next 133 | go (Free (TextFill _ texts next)) = 134 | concat ["-- Text : " ++ _text t ++ "\n" | t <- texts] ++ go next 135 | go (Free (SetTexture tx drawing next)) = 136 | "withTexture (" ++ dumpTexture tx ++ ") (" ++ 137 | go (fromF drawing) ++ ") >>=\n" ++ go next 138 | go (Free (DashedStroke o pat w j cap prims next)) = 139 | "dashedStrokeWithOffset " 140 | ++ show o ++ " " 141 | ++ show pat ++ " " 142 | ++ show w ++ " (" 143 | ++ show j ++ ") " 144 | ++ show cap ++ " " 145 | ++ show prims ++ " >>=\n" ++ go next 146 | go (Free (Stroke w j cap prims next)) = 147 | "stroke " ++ show w ++ " (" 148 | ++ show j ++ ") " 149 | ++ show cap ++ " " 150 | ++ show prims ++ " >>=\n" ++ go next 151 | go (Free (WithTransform trans sub next)) = 152 | "withTransform (" ++ show trans ++ ") (" 153 | ++ go (fromF sub) ++ ") >>=\n " 154 | ++ go next 155 | go (Free (WithCliping clipping draw next)) = 156 | "withClipping (" ++ go (fromF $ withTexture clipTexture clipping) 157 | ++ ")\n" ++ 158 | " (" ++ go (fromF draw) ++ ")\n >>= " ++ 159 | go next 160 | where clipTexture = SolidTexture (0xFF :: Pixel8) 161 | withTexture texture subActions = 162 | liftF $ SetTexture texture subActions () 163 | 164 | dumpTexture :: ( Show px 165 | , Show (PixelBaseComponent px) 166 | , PixelBaseComponent (PixelBaseComponent px) 167 | ~ (PixelBaseComponent px) 168 | ) => Texture px -> String 169 | dumpTexture (SolidTexture px) = "uniformTexture (" ++ show px ++ ")" 170 | dumpTexture (MeshPatchTexture i mpx) = "meshTexture (" ++ show i ++ ") (" ++ show mpx ++ ")" 171 | dumpTexture (LinearGradientTexture grad (Line a b)) = 172 | "linearGradientTexture " ++ show grad ++ " (" ++ show a ++ ") (" ++ show b ++ ")" 173 | dumpTexture (RadialGradientTexture grad p rad) = 174 | "radialGradientTexture " ++ show grad ++ " (" ++ show p ++ ") " ++ show rad 175 | dumpTexture (RadialGradientWithFocusTexture grad center rad focus) = 176 | "radialGradientWithFocusTexture " ++ show grad ++ " (" ++ show center 177 | ++ ") " ++ show rad ++ " (" ++ show focus ++ ")" 178 | dumpTexture (WithSampler sampler sub) = 179 | "withSampler " ++ show sampler ++ " (" ++ dumpTexture sub ++ ")" 180 | dumpTexture (WithTextureTransform trans sub) = 181 | "transformTexture (" ++ show trans ++ ") (" ++ dumpTexture sub ++ ")" 182 | dumpTexture (SampledTexture _) = "sampledImageTexture " 183 | dumpTexture (RawTexture _) = "" 184 | dumpTexture (ShaderTexture _) = "shaderFunction " 185 | dumpTexture (ModulateTexture sub mask) = 186 | "modulateTexture (" ++ dumpTexture sub ++ ") (" 187 | ++ dumpTexture mask ++ ")" 188 | dumpTexture (AlphaModulateTexture sub mask) = 189 | "alphaModulate (" ++ dumpTexture sub ++ ") (" 190 | ++ dumpTexture mask ++ ")" 191 | dumpTexture (PatternTexture w h px sub _) = 192 | "patternTexture " ++ show w ++ " " ++ show h ++ " " ++ show px 193 | ++ " (" ++ dumpDrawing sub ++ ")" 194 | 195 | 196 | instance Functor (DrawCommand px) where 197 | fmap f (WithImageEffect effect sub next) = 198 | WithImageEffect effect sub $ f next 199 | fmap f (TextFill pos texts next) = 200 | TextFill pos texts $ f next 201 | fmap f (CustomRender m next) = 202 | CustomRender m $ f next 203 | fmap f (WithGlobalOpacity opa sub next) = 204 | WithGlobalOpacity opa sub $ f next 205 | fmap f (Fill method prims next) = Fill method prims $ f next 206 | fmap f (SetTexture t sub next) = SetTexture t sub $ f next 207 | fmap f (WithCliping sub com next) = 208 | WithCliping sub com $ f next 209 | fmap f (Stroke w j caps prims next) = 210 | Stroke w j caps prims $ f next 211 | fmap f (DashedStroke st pat w j caps prims next) = 212 | DashedStroke st pat w j caps prims $ f next 213 | fmap f (WithTransform trans draw next) = 214 | WithTransform trans draw $ f next 215 | fmap f (WithPathOrientation path point draw next) = 216 | WithPathOrientation path point draw $ f next 217 | fmap f (MeshPatchRender i mesh next) = 218 | MeshPatchRender i mesh $ f next 219 | 220 | instance Semigroup (Drawing px ()) where 221 | (<>) a b = a >> b 222 | 223 | instance Monoid (Drawing px ()) where 224 | mempty = return () 225 | mappend = (<>) 226 | 227 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/QuadraticBezier.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | -- | Module handling math regarding the handling of quadratic 5 | -- and cubic bezier curve. 6 | module Graphics.Rasterific.QuadraticBezier 7 | ( -- * Helper functions 8 | straightLine 9 | , bezierFromPath 10 | , decomposeBeziers 11 | , clipBezier 12 | , sanitizeBezier 13 | , sanitizeBezierFilling 14 | , offsetBezier 15 | , flattenBezier 16 | , bezierBreakAt 17 | , bezierLengthApproximation 18 | , isBezierPoint 19 | ) where 20 | 21 | import Graphics.Rasterific.Linear 22 | ( V2( .. ) 23 | , (^-^) 24 | , (^+^) 25 | , (^*) 26 | , dot 27 | , norm 28 | , lerp 29 | ) 30 | 31 | import Graphics.Rasterific.Operators 32 | import Graphics.Rasterific.Types 33 | 34 | -- | Create a list of bezier patch from a list of points, 35 | -- 36 | -- > bezierFromPath [a, b, c, d, e] == [Bezier a b c, Bezier c d e] 37 | -- > bezierFromPath [a, b, c, d, e, f] == [Bezier a b c, Bezier c d e] 38 | -- > bezierFromPath [a, b, c, d, e, f, g] == 39 | -- > [Bezier a b c, Bezier c d e, Bezier e f g] 40 | -- 41 | bezierFromPath :: [Point] -> [Bezier] 42 | bezierFromPath (a:b:rest@(c:_)) = Bezier a b c : bezierFromPath rest 43 | bezierFromPath _ = [] 44 | 45 | isBezierPoint :: Bezier -> Bool 46 | isBezierPoint (Bezier a b c) = 47 | not $ a `isDistingableFrom` b || 48 | b `isDistingableFrom` c 49 | 50 | -- | Only work if the quadratic bezier curve 51 | -- is nearly flat 52 | bezierLengthApproximation :: Bezier -> Float 53 | bezierLengthApproximation (Bezier a _ c) = 54 | norm $ c ^-^ a 55 | 56 | decomposeBeziers :: Bezier -> Producer EdgeSample 57 | decomposeBeziers (Bezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy)) = 58 | go aRx aRy bRx bRy cRx cRy where 59 | go ax ay _bx _by cx cy cont 60 | | insideX && insideY = 61 | let !px = fromIntegral $ min floorAx floorCx 62 | !py = fromIntegral $ min floorAy floorCy 63 | !w = px + 1 - cx `middle` ax 64 | !h = cy - ay 65 | in 66 | EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont 67 | where 68 | floorAx, floorAy :: Int 69 | !floorAx = floor ax 70 | !floorAy = floor ay 71 | 72 | !floorCx = floor cx 73 | !floorCy = floor cy 74 | 75 | !insideX = floorAx == floorCx || ceiling ax == (ceiling cx :: Int) 76 | !insideY = floorAy == floorCy || ceiling ay == (ceiling cy :: Int) 77 | 78 | 79 | go !ax !ay !bx !by !cx !cy cont = 80 | go ax ay abx aby mx my $ go mx my bcx bcy cx cy cont 81 | where 82 | !abx = ax `middle` bx 83 | !aby = ay `middle` by 84 | 85 | !bcx = bx `middle` cx 86 | !bcy = by `middle` cy 87 | 88 | !abbcx = abx `middle` bcx 89 | !abbcy = aby `middle` bcy 90 | 91 | !mx | abs (abbcx - mini) < 0.1 = mini 92 | | abs (abbcx - maxi) < 0.1 = maxi 93 | | otherwise = abbcx 94 | where !mini = fromIntegral (floor abbcx :: Int) 95 | !maxi = fromIntegral (ceiling abbcx :: Int) 96 | 97 | !my | abs (abbcy - mini) < 0.1 = mini 98 | | abs (abbcy - maxi) < 0.1 = maxi 99 | | otherwise = abbcy 100 | where !mini = fromIntegral (floor abbcy :: Int) 101 | !maxi = fromIntegral (ceiling abbcy :: Int) 102 | 103 | 104 | -- | Create a quadratic bezier curve representing 105 | -- a straight line. 106 | straightLine :: Point -> Point -> Bezier 107 | straightLine a c = Bezier a (a `midPoint` c) c 108 | 109 | -- | Clamp the bezier curve inside a rectangle 110 | -- given in parameter. 111 | clipBezier :: Point -- ^ Point representing the "minimal" point for cliping 112 | -> Point -- ^ Point representing the "maximal" point for cliping 113 | -> Bezier -- ^ The quadratic bezier curve to be clamped 114 | -> Container Primitive 115 | clipBezier mini maxi bezier@(Bezier a b c) 116 | -- If we are in the range bound, return the curve 117 | -- unaltered 118 | | insideX && insideY = pure $ BezierPrim bezier 119 | -- If one of the component is outside, clamp 120 | -- the components on the boundaries and output a 121 | -- straight line on this boundary. Useful for the 122 | -- filing case, to clamp the polygon drawing on 123 | -- the edge 124 | | outsideX || outsideY = 125 | pure . BezierPrim $ clampedA `straightLine` clampedC 126 | -- Not completly inside nor outside, just divide 127 | -- and conquer. 128 | | otherwise = 129 | recurse (Bezier a ab m) <> 130 | recurse (Bezier m bc c) 131 | where -- Minimal & maximal dimension of the bezier curve 132 | bmin = vmin a $ vmin b c 133 | bmax = vmax a $ vmax b c 134 | 135 | recurse = clipBezier mini maxi 136 | 137 | clamper = clampPoint mini maxi 138 | clampedA = clamper a 139 | clampedC = clamper c 140 | 141 | V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi 142 | V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin 143 | 144 | -- 145 | -- X B 146 | -- / \ 147 | -- / \ 148 | -- ab X--X--X bc 149 | -- / abbc \ 150 | -- / \ 151 | -- A X X C 152 | -- 153 | (ab, bc, abbc) = splitBezier bezier 154 | 155 | -- mini 156 | -- +-------------+ 157 | -- | | 158 | -- | | 159 | -- | | 160 | -- +-------------+ 161 | -- maxi 162 | -- the edgeSeparator vector encode which edge 163 | -- is te nearest to the midpoint. 164 | -- if True then it's the 'min' edges which are 165 | -- the nearest, otherwise it's the maximum edge 166 | edgeSeparator = 167 | vabs (abbc ^-^ mini) ^<^ vabs (abbc ^-^ maxi) 168 | 169 | -- So here we 'solidify' the nearest edge position 170 | -- in an edge vector. 171 | edge = vpartition edgeSeparator mini maxi 172 | 173 | -- If we're near an edge, snap the component to the 174 | -- edge. 175 | m = vpartition (vabs (abbc ^-^ edge) ^< 0.1) edge abbc 176 | 177 | 178 | -- | Rewrite the bezier curve to avoid degenerate cases. 179 | sanitizeBezier :: Bezier -> Container Primitive 180 | sanitizeBezier bezier@(Bezier a b c) 181 | -- If the two normals vector are far apart (cos nearly -1) 182 | -- 183 | -- u v 184 | -- <---------- ------------> 185 | -- because u dot v = ||u|| * ||v|| * cos(uv) 186 | -- 187 | -- This imply that AB and BC are nearly parallel 188 | | u `dot` v < -0.9999 = 189 | -- divide in to halves with 190 | sanitizeBezier (Bezier a (a `midPoint` abbc) abbc) <> 191 | sanitizeBezier (Bezier abbc (abbc `midPoint` c) c) 192 | 193 | -- b is far enough of b and c, (it's not a point) 194 | | a `isDistingableFrom` b && b `isDistingableFrom` c = 195 | pure . BezierPrim $ bezier 196 | 197 | -- if b is to nearby a or c, take the midpoint as new reference. 198 | | ac `isDistingableFrom` b = sanitizeBezier (Bezier a ac c) 199 | | otherwise = mempty 200 | where u = a `normal` b 201 | v = b `normal` c 202 | ac = a `midPoint` c 203 | abbc = (a `midPoint` b) `midPoint` (b `midPoint` c) 204 | 205 | sanitizeBezierFilling :: Bezier -> Container Primitive 206 | sanitizeBezierFilling bezier@(Bezier a b c) 207 | | isDegenerate a || isDegenerate b || isDegenerate c = mempty 208 | | otherwise = pure $ BezierPrim bezier 209 | 210 | bezierBreakAt :: Bezier -> Float -> (Bezier, Bezier) 211 | bezierBreakAt (Bezier a b c) t = (Bezier a ab abbc, Bezier abbc bc c) 212 | where 213 | -- X B 214 | -- / \ 215 | -- / \ 216 | -- ab X--X--X bc 217 | -- / abbc \ 218 | -- / \ 219 | -- A X X C 220 | ab = lerp t b a 221 | bc = lerp t c b 222 | abbc = lerp t bc ab 223 | 224 | splitBezier :: Bezier -> (Point, Point, Point) 225 | {-# INLINE splitBezier #-} 226 | splitBezier (Bezier a b c) = (ab, bc, abbc) 227 | where 228 | -- 229 | -- X B 230 | -- / \ 231 | -- / \ 232 | -- ab X--X--X bc 233 | -- / abbc \ 234 | -- / \ 235 | -- A X X C 236 | -- 237 | ab = a `midPoint` b 238 | bc = b `midPoint` c 239 | abbc = ab `midPoint` bc 240 | 241 | flattenBezier :: Bezier -> Container Primitive 242 | flattenBezier bezier@(Bezier a b c) 243 | -- If the spline is not too curvy, just return the 244 | -- shifted component 245 | | u `dot` v >= 0.9 = pure $ BezierPrim bezier 246 | -- Otherwise, divide and conquer 247 | | a /= b && b /= c = 248 | flattenBezier (Bezier a ab abbc) <> 249 | flattenBezier (Bezier abbc bc c) 250 | | otherwise = mempty 251 | where -- 252 | -- X B 253 | -- ^ /^\ ^ 254 | -- u \ /w| \ / v 255 | -- X-----X 256 | -- / \ 257 | -- / \ 258 | -- A X X C 259 | -- 260 | u = a `normal` b 261 | v = b `normal` c 262 | 263 | (ab, bc, abbc) = splitBezier bezier 264 | 265 | -- | Move the bezier to a new position with an offset. 266 | offsetBezier :: Float -> Bezier -> Container Primitive 267 | offsetBezier offset bezier@(Bezier a b c) 268 | -- If the spline is not too curvy, just return the 269 | -- shifted component 270 | | u `dot` v >= 0.9 = 271 | pure . BezierPrim $ Bezier shiftedA mergedB shiftedC 272 | -- Otherwise, divide and conquer 273 | | a /= b && b /= c = 274 | offsetBezier offset (Bezier a ab abbc) <> 275 | offsetBezier offset (Bezier abbc bc c) 276 | | otherwise = mempty 277 | where -- 278 | -- X B 279 | -- ^ /^\ ^ 280 | -- u \ /w| \ / v 281 | -- X-----X 282 | -- / \ 283 | -- / \ 284 | -- A X X C 285 | -- 286 | u = a `normal` b 287 | v = b `normal` c 288 | w = ab `normal` bc 289 | 290 | (ab, bc, abbc) = splitBezier bezier 291 | 292 | shiftedA = a ^+^ (u ^* offset) 293 | shiftedC = c ^+^ (v ^* offset) 294 | shiftedABBC = abbc ^+^ (w ^* offset) 295 | mergedB = 296 | (shiftedABBC ^* 2.0) ^-^ (shiftedA `midPoint` shiftedC) 297 | 298 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/StrokeInternal.hs: -------------------------------------------------------------------------------- 1 | module Graphics.Rasterific.StrokeInternal 2 | ( flatten 3 | , dashize 4 | , strokize 5 | , dashedStrokize 6 | , splitPrimitiveUntil 7 | , approximatePathLength 8 | , isPrimitivePoint 9 | , sanitize 10 | , sanitizeFilling 11 | ) where 12 | 13 | import Graphics.Rasterific.Linear 14 | ( V2( .. ) 15 | , (^-^) 16 | , (^+^) 17 | , (^*) 18 | , dot 19 | , nearZero 20 | ) 21 | 22 | import Graphics.Rasterific.Operators 23 | import Graphics.Rasterific.Types 24 | import Graphics.Rasterific.QuadraticBezier 25 | import Graphics.Rasterific.CubicBezier 26 | import Graphics.Rasterific.Line 27 | 28 | lastPoint :: Primitive -> Point 29 | lastPoint (LinePrim (Line _ x1)) = x1 30 | lastPoint (BezierPrim (Bezier _ _ x2)) = x2 31 | lastPoint (CubicBezierPrim (CubicBezier _ _ _ x3)) = x3 32 | 33 | lastPointAndNormal :: Primitive -> (Point, Vector) 34 | lastPointAndNormal (LinePrim (Line a b)) = (b, a `normal` b) 35 | lastPointAndNormal (BezierPrim (Bezier _ b c)) = (c, b `normal` c) 36 | lastPointAndNormal (CubicBezierPrim (CubicBezier _ _ c d)) = (d, c `normal` d) 37 | 38 | firstPointAndNormal :: Primitive -> (Point, Vector) 39 | firstPointAndNormal (LinePrim (Line a b)) = (a, a `normal` b) 40 | firstPointAndNormal (BezierPrim (Bezier a b _)) = (a, a `normal` b) 41 | firstPointAndNormal (CubicBezierPrim (CubicBezier a b _ _)) = (a, a `normal` b) 42 | 43 | isPrimitivePoint :: Primitive -> Bool 44 | isPrimitivePoint p = case p of 45 | LinePrim l -> isLinePoint l 46 | BezierPrim b -> isBezierPoint b 47 | CubicBezierPrim c -> isCubicBezierPoint c 48 | 49 | reversePrimitive :: Primitive -> Primitive 50 | reversePrimitive (LinePrim (Line a b)) = LinePrim (Line b a) 51 | reversePrimitive (BezierPrim (Bezier a b c)) = 52 | BezierPrim (Bezier c b a) 53 | reversePrimitive (CubicBezierPrim (CubicBezier a b c d)) = 54 | CubicBezierPrim (CubicBezier d c b a) 55 | 56 | -- | Create a "rounded" join or cap 57 | roundJoin :: Float -> Point -> Vector -> Vector -> Container Primitive 58 | roundJoin offset p = go 59 | where go u v 60 | -- If we're already on a nice curvature, 61 | -- don't bother doing anything 62 | | u `dot` w >= 0.9 = pure . BezierPrim $ Bezier a b c 63 | | otherwise = go u w <> go w v 64 | where -- ^ 65 | -- |w 66 | -- a X---X c 67 | -- \ / 68 | -- Xp 69 | -- ^ / \ ^ 70 | -- u\/ \/v 71 | -- / \ . 72 | a = p ^+^ u ^* offset 73 | c = p ^+^ v ^* offset 74 | 75 | w = (a `normal` c) `ifZero` u 76 | 77 | -- Same as offseting 78 | n = p ^+^ w ^* offset 79 | b = n ^* 2 ^-^ (a `midPoint` c) 80 | 81 | -- | Put a cap at the end of a bezier curve, depending 82 | -- on the kind of cap wanted. 83 | cap :: Float -> Cap -> Primitive -> Container Primitive 84 | cap offset CapRound prim 85 | | nearZero u = cap offset (CapStraight 0) prim 86 | | otherwise = roundJoin offset p u (- u) 87 | where (p, u) = lastPointAndNormal prim 88 | 89 | cap offset (CapStraight cVal) prim = 90 | pure (d `lineFromTo` e) <> pure (e `lineFromTo` f) 91 | <> pure (f `lineFromTo` g) 92 | where -- The usual "normal" 93 | (p, u@(V2 ux uy)) = lastPointAndNormal prim 94 | -- Vector pointing in the direction of the curve 95 | -- of norm 1 96 | v = V2 uy $ negate ux 97 | 98 | -- Finishing points around the edge 99 | -- -u*offset u*offset 100 | -- <-><-> 101 | -- d/ / /g 102 | -- / / / 103 | -- / / / 104 | -- / 105 | -- / curve 106 | -- 107 | d = p ^+^ u ^* offset 108 | g = p ^-^ u ^* offset 109 | 110 | -- Create the "far" points 111 | -- 112 | -- e f 113 | -- / / ^ 114 | -- / / / v * offset * cVal 115 | -- d/ / /g 116 | -- / / / 117 | -- / / / 118 | -- / 119 | -- / curve 120 | -- 121 | e = d ^+^ v ^* (offset * cVal) 122 | f = g ^+^ v ^* (offset * cVal) 123 | 124 | lineFromTo :: Point -> Point -> Primitive 125 | lineFromTo a b = LinePrim (Line a b) 126 | 127 | miterJoin :: Float -> Float -> Point -> Vector -> Vector 128 | -> Container Primitive 129 | miterJoin offset l point u v 130 | | uDotW > l / max 1 l && uDotW > 0.01 = 131 | pure (a `lineFromTo` m) <> pure (m `lineFromTo` c) 132 | -- A simple straight junction 133 | | otherwise = pure $ a `lineFromTo` c 134 | where -- X m 135 | -- /\ 136 | -- /|w\ 137 | -- a X---X c 138 | -- \ / 139 | -- Xp 140 | -- ^ / \ ^ 141 | -- u\/ \/v 142 | -- / \ . 143 | a = point ^+^ u ^* offset 144 | c = point ^+^ v ^* offset 145 | w = (a `normal` c) `ifZero` u 146 | 147 | uDotW = u `dot` w 148 | 149 | -- Calculate the maximum distance on the 150 | -- u axis 151 | p = offset / uDotW 152 | -- middle point for "straight joining" 153 | m = point + w ^* p 154 | 155 | joinPrimitives :: StrokeWidth -> Join -> Primitive -> Primitive 156 | -> Container Primitive 157 | joinPrimitives offset join prim1 prim2 = 158 | case join of 159 | JoinRound | nearZero u || nearZero v -> miterJoin offset 0 p u v 160 | JoinRound -> roundJoin offset p u v 161 | JoinMiter l -> miterJoin offset l p u v 162 | where (p, u) = lastPointAndNormal prim1 163 | (_, v) = firstPointAndNormal prim2 164 | 165 | offsetPrimitives :: Float -> Primitive -> Container Primitive 166 | offsetPrimitives offset (LinePrim l) = offsetLine offset l 167 | offsetPrimitives offset (BezierPrim b) = offsetBezier offset b 168 | offsetPrimitives offset (CubicBezierPrim c) = offsetCubicBezier offset c 169 | 170 | offsetAndJoin :: Float -> Join -> Cap -> [Primitive] 171 | -> Container Primitive 172 | offsetAndJoin _ _ _ [] = mempty 173 | offsetAndJoin offset join caping (firstShape:rest) = go firstShape rest 174 | where joiner = joinPrimitives offset join 175 | offseter = offsetPrimitives offset 176 | (firstPoint, _) = firstPointAndNormal firstShape 177 | 178 | go prev [] 179 | | firstPoint `isNearby` lastPoint prev = offseter prev <> joiner prev firstShape 180 | | otherwise = offseter prev <> cap offset caping prev 181 | go prev (x:xs) = 182 | offseter prev <> joiner prev x <> go x xs 183 | 184 | approximateLength :: Primitive -> Float 185 | approximateLength (LinePrim l) = lineLength l 186 | approximateLength (BezierPrim b) = bezierLengthApproximation b 187 | approximateLength (CubicBezierPrim c) = cubicBezierLengthApproximation c 188 | 189 | 190 | sanitize :: Primitive -> Container Primitive 191 | sanitize (LinePrim l) = sanitizeLine l 192 | sanitize (BezierPrim b) = sanitizeBezier b 193 | sanitize (CubicBezierPrim c) = sanitizeCubicBezier c 194 | 195 | -- | Sanitizing that don't cull really small elements, only 196 | -- Degenerate case, to allow them to participate to the correct 197 | -- coverage, even if really small. 198 | sanitizeFilling :: Primitive -> Container Primitive 199 | sanitizeFilling (LinePrim l) = sanitizeLineFilling l 200 | sanitizeFilling (BezierPrim b) = sanitizeBezierFilling b 201 | sanitizeFilling (CubicBezierPrim c) = sanitizeCubicBezierFilling c 202 | 203 | strokize :: Geometry geom 204 | => StrokeWidth -> Join -> (Cap, Cap) -> geom 205 | -> Container Primitive 206 | strokize width join (capStart, capEnd) geom = foldMap pathOffseter sanitized 207 | where 208 | sanitized = foldMap (listOfContainer . sanitize) <$> resplit (toPrimitives geom) 209 | offseter = offsetAndJoin (width / 2) join 210 | pathOffseter v = 211 | offseter capEnd v <> offseter capStart (reverse $ reversePrimitive <$> v) 212 | 213 | flattenPrimitive :: Primitive -> Container Primitive 214 | flattenPrimitive (BezierPrim bezier) = flattenBezier bezier 215 | flattenPrimitive (CubicBezierPrim bezier) = flattenCubicBezier bezier 216 | flattenPrimitive (LinePrim line) = flattenLine line 217 | 218 | breakPrimitiveAt :: Primitive -> Float -> (Primitive, Primitive) 219 | breakPrimitiveAt (BezierPrim bezier) at = (BezierPrim a, BezierPrim b) 220 | where (a, b) = bezierBreakAt bezier at 221 | breakPrimitiveAt (CubicBezierPrim bezier) at = (CubicBezierPrim a, CubicBezierPrim b) 222 | where (a, b) = cubicBezierBreakAt bezier at 223 | breakPrimitiveAt (LinePrim line) at = (LinePrim a, LinePrim b) 224 | where (a, b) = lineBreakAt line at 225 | 226 | 227 | flatten :: Container Primitive -> Container Primitive 228 | flatten = foldMap flattenPrimitive 229 | 230 | splitPrimitiveUntil :: Float -> [Primitive] -> ([Primitive], [Primitive]) 231 | splitPrimitiveUntil = go 232 | where 233 | go _ [] = ([], []) 234 | go left lst 235 | | left <= 0 = ([], lst) 236 | go left (x : xs) 237 | | left > primLength = (x : inInterval, afterInterval) 238 | | otherwise = ([beforeStop], afterStop : xs) 239 | where 240 | primLength = approximateLength x 241 | (inInterval, afterInterval) = go (left - primLength) xs 242 | 243 | (beforeStop, afterStop) = 244 | breakPrimitiveAt x $ left / primLength 245 | 246 | dropPattern :: Float -> DashPattern -> DashPattern 247 | dropPattern = go 248 | where 249 | go _ [] = [] 250 | go offset (x:xs) 251 | | x < 0 = x:xs -- sanitizing 252 | | offset < x = x - offset : xs 253 | | otherwise {- offset >= x -} = go (offset - x) xs 254 | 255 | -- | Don't make them completly flat, but suficiently 256 | -- to assume they are. 257 | linearizePrimitives :: [Primitive] -> [Primitive] 258 | linearizePrimitives = 259 | listOfContainer . foldMap flattenPrimitive . foldMap sanitize 260 | 261 | -- | Return an approximation of the length of a given path. 262 | -- It's results is not precise but should be enough for 263 | -- rough calculations 264 | approximatePathLength :: Path -> Float 265 | approximatePathLength = approximatePrimitivesLength . pathToPrimitives 266 | 267 | approximatePrimitivesLength :: [Primitive] -> Float 268 | approximatePrimitivesLength prims = 269 | sum $ approximateLength <$> linearizePrimitives prims 270 | 271 | dashize :: Float -> DashPattern -> [Primitive] -> [[Primitive]] 272 | dashize offset pattern = taker infinitePattern . linearizePrimitives 273 | where 274 | realOffset | offset >= 0 = offset 275 | | otherwise = offset + sum pattern 276 | 277 | infinitePattern = 278 | dropPattern realOffset . cycle $ filter (> 0) pattern 279 | 280 | taker _ [] = [] 281 | taker [] _ = [] -- Impossible by construction, pattern is infinite 282 | taker (atValue:atRest) stream = toKeep : droper atRest next 283 | where (toKeep, next) = splitPrimitiveUntil atValue stream 284 | 285 | droper _ [] = [] 286 | droper [] _ = [] -- Impossible by construction, pattern is infinite 287 | droper (atValue:atRest) stream = taker atRest next 288 | where (_toKeep, next) = splitPrimitiveUntil atValue stream 289 | 290 | -- | Create a list of outlines corresponding to all the 291 | -- dashed elements. They can be then stroked 292 | -- 293 | -- > mapM_ (stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0)) $ 294 | -- > dashedStrokize 0 [10, 5] 295 | -- > 40 JoinRound (CapStraight 0, CapStraight 0) $ 296 | -- > CubicBezier (V2 40 160) (V2 40 40) (V2 160 40) (V2 160 160) 297 | -- 298 | -- <> 299 | -- 300 | dashedStrokize :: Geometry geom 301 | => Float -- ^ Starting offset 302 | -> DashPattern -- ^ Dashing pattern to use for stroking 303 | -> StrokeWidth -- ^ Stroke width 304 | -> Join -- ^ Which kind of join will be used 305 | -> (Cap, Cap) -- ^ Start and end capping. 306 | -> geom -- ^ Elements to transform 307 | -> [[Primitive]] 308 | dashedStrokize offset dashPattern width join capping geom = 309 | listOfContainer . strokize width join capping 310 | <$> dashize offset dashPattern (toPrimitives geom) 311 | 312 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/Linear.hs: -------------------------------------------------------------------------------- 1 | -- | This module is a reduction of the `Linear` package 2 | -- from Edward Kmett to match just the need of Rasterific. 3 | -- 4 | -- If the flag `embed_linear` is disabled, this module is 5 | -- just a reexport from the real linear package. 6 | -- 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE CPP #-} 9 | module Graphics.Rasterific.Linear 10 | ( V1( .. ) 11 | , V2( .. ) 12 | , V3( .. ) 13 | , V4( .. ) 14 | , R1( .. ) 15 | , R2( .. ) 16 | , Additive( .. ) 17 | , Epsilon( .. ) 18 | , Metric( .. ) 19 | , (^*) 20 | , (^/) 21 | , normalize 22 | ) where 23 | 24 | #ifdef EXTERNAL_LINEAR 25 | -- We just reexport 26 | import Linear 27 | #else 28 | 29 | import Graphics.Rasterific.MiniLens 30 | 31 | infixl 6 ^+^, ^-^ 32 | infixl 7 ^*, ^/ 33 | 34 | -- | A 2-dimensional vector 35 | -- 36 | -- >>> pure 1 :: V2 Int 37 | -- V2 1 1 38 | -- 39 | -- >>> V2 1 2 + V2 3 4 40 | -- V2 4 6 41 | -- 42 | -- >>> V2 1 2 * V2 3 4 43 | -- V2 3 8 44 | -- 45 | -- >>> sum (V2 1 2) 46 | -- 3 47 | data V2 a = V2 !a !a 48 | deriving (Eq, Show) 49 | 50 | -- | A 3-dimensional vector 51 | data V3 a = V3 !a !a !a 52 | deriving (Eq, Show) 53 | 54 | -- | A 4-dimensional vector 55 | data V4 a = V4 !a !a !a !a 56 | deriving (Eq, Show) 57 | 58 | class R1 t where 59 | _x :: Lens' (t a) a 60 | 61 | class R2 t where 62 | _y :: Lens' (t a) a 63 | 64 | instance R1 V1 where 65 | _x = lens (\(V1 a) -> a) (\_ -> V1) 66 | 67 | instance R1 V2 where 68 | _x = lens (\(V2 x _) -> x) (\(V2 _ y) x -> V2 x y) 69 | 70 | instance R2 V2 where 71 | _y = lens (\(V2 _ y) -> y) (\(V2 x _) y -> V2 x y) 72 | 73 | instance R1 V3 where 74 | _x = lens (\(V3 x _ _) -> x) (\(V3 _ y z) x -> V3 x y z) 75 | 76 | instance R2 V3 where 77 | _y = lens (\(V3 _ y _) -> y) (\(V3 x _ z) y -> V3 x y z) 78 | 79 | instance R1 V4 where 80 | _x = lens (\(V4 x _ _ _) -> x) (\(V4 _ y z w) x -> V4 x y z w) 81 | 82 | instance R2 V4 where 83 | _y = lens (\(V4 _ y _ _) -> y) (\(V4 x _ z w) y -> V4 x y z w) 84 | 85 | -- | A 1-dimensional vector 86 | newtype V1 a = V1 a 87 | deriving (Eq, Show, Num) 88 | 89 | instance Functor V1 where 90 | {-# INLINE fmap #-} 91 | fmap f (V1 a) = V1 $ f a 92 | 93 | instance Functor V2 where 94 | {-# INLINE fmap #-} 95 | fmap f (V2 a b) = V2 (f a) (f b) 96 | 97 | instance Functor V3 where 98 | {-# INLINE fmap #-} 99 | fmap f (V3 a b c) = V3 (f a) (f b) (f c) 100 | 101 | instance Functor V4 where 102 | {-# INLINE fmap #-} 103 | fmap f (V4 a b c d) = V4 (f a) (f b) (f c) (f d) 104 | 105 | instance Foldable V3 where 106 | foldMap f (V3 a b c) = f a `mappend` f b `mappend` f c 107 | {-# INLINE foldMap #-} 108 | 109 | instance Traversable V3 where 110 | traverse f (V3 a b c) = V3 <$> f a <*> f b <*> f c 111 | {-# INLINE traverse #-} 112 | 113 | instance Foldable V2 where 114 | foldMap f (V2 a b) = f a `mappend` f b 115 | {-# INLINE foldMap #-} 116 | 117 | instance Traversable V2 where 118 | traverse f (V2 a b) = V2 <$> f a <*> f b 119 | {-# INLINE traverse #-} 120 | 121 | instance Foldable V4 where 122 | foldMap f (V4 a b c d) = f a `mappend` f b `mappend` f c `mappend` f d 123 | {-# INLINE foldMap #-} 124 | 125 | instance Traversable V4 where 126 | traverse f (V4 a b c d) = V4 <$> f a <*> f b <*> f c <*> f d 127 | {-# INLINE traverse #-} 128 | 129 | instance Foldable V1 where 130 | foldMap f (V1 a) = f a 131 | {-# INLINE foldMap #-} 132 | 133 | instance Traversable V1 where 134 | traverse f (V1 a) = V1 <$> f a 135 | {-# INLINE traverse #-} 136 | 137 | instance Num a => Num (V2 a) where 138 | (V2 a b) + (V2 a' b') = V2 (a + a') (b + b') 139 | {-# INLINE (+) #-} 140 | (V2 a b) - (V2 a' b') = V2 (a - a') (b - b') 141 | {-# INLINE (-) #-} 142 | (V2 a b) * (V2 a' b') = V2 (a * a') (b * b') 143 | {-# INLINE (*) #-} 144 | negate (V2 a b) = V2 (negate a) (negate b) 145 | {-# INLINE negate #-} 146 | abs (V2 a b) = V2 (abs a) (abs b) 147 | {-# INLINE abs #-} 148 | signum (V2 a b) = V2 (signum a) (signum b) 149 | {-# INLINE signum #-} 150 | fromInteger = pure . fromInteger 151 | {-# INLINE fromInteger #-} 152 | 153 | instance Num a => Num (V3 a) where 154 | (V3 a b c) + (V3 a' b' c') = V3 (a + a') (b + b') (c + c') 155 | {-# INLINE (+) #-} 156 | (V3 a b c) - (V3 a' b' c') = V3 (a - a') (b - b') (c - c') 157 | {-# INLINE (-) #-} 158 | (V3 a b c) * (V3 a' b' c') = V3 (a * a') (b * b') (c * c') 159 | {-# INLINE (*) #-} 160 | negate (V3 a b c) = V3 (negate a) (negate b) (negate c) 161 | {-# INLINE negate #-} 162 | abs (V3 a b c) = V3 (abs a) (abs b) (abs c) 163 | {-# INLINE abs #-} 164 | signum (V3 a b c) = V3 (signum a) (signum b) (signum c) 165 | {-# INLINE signum #-} 166 | fromInteger = pure . fromInteger 167 | {-# INLINE fromInteger #-} 168 | 169 | instance Num a => Num (V4 a) where 170 | (V4 a b c d) + (V4 a' b' c' d') = V4 (a + a') (b + b') (c + c') (d + d') 171 | {-# INLINE (+) #-} 172 | (V4 a b c d) - (V4 a' b' c' d') = V4 (a - a') (b - b') (c - c') (d - d') 173 | {-# INLINE (-) #-} 174 | (V4 a b c d) * (V4 a' b' c' d') = V4 (a * a') (b * b') (c * c') (d * d') 175 | {-# INLINE (*) #-} 176 | negate (V4 a b c d) = V4 (negate a) (negate b) (negate c) (negate d) 177 | {-# INLINE negate #-} 178 | abs (V4 a b c d) = V4 (abs a) (abs b) (abs c) (abs d) 179 | {-# INLINE abs #-} 180 | signum (V4 a b c d) = V4 (signum a) (signum b) (signum c) (signum d) 181 | {-# INLINE signum #-} 182 | fromInteger = pure . fromInteger 183 | {-# INLINE fromInteger #-} 184 | 185 | instance Applicative V4 where 186 | {-# INLINE pure #-} 187 | pure a = V4 a a a a 188 | {-# INLINE (<*>) #-} 189 | (V4 f1 f2 f3 f4) <*> (V4 a b c d) = V4 (f1 a) (f2 b) (f3 c) (f4 d) 190 | 191 | instance Applicative V3 where 192 | {-# INLINE pure #-} 193 | pure a = V3 a a a 194 | {-# INLINE (<*>) #-} 195 | (V3 f1 f2 f3) <*> (V3 a b c) = V3 (f1 a) (f2 b) (f3 c) 196 | 197 | instance Applicative V2 where 198 | {-# INLINE pure #-} 199 | pure a = V2 a a 200 | {-# INLINE (<*>) #-} 201 | (V2 f1 f2) <*> (V2 a b) = V2 (f1 a) (f2 b) 202 | 203 | instance Applicative V1 where 204 | {-# INLINE pure #-} 205 | pure = V1 206 | {-# INLINE (<*>) #-} 207 | (V1 f) <*> (V1 v) = V1 $ f v 208 | 209 | -- | A vector is an additive group with additional structure. 210 | class Functor f => Additive f where 211 | -- | The zero vector 212 | zero :: Num a => f a 213 | -- | Compute the sum of two vectors 214 | -- 215 | -- >>> V2 1 2 ^+^ V2 3 4 216 | -- V2 4 6 217 | (^+^) :: Num a => f a -> f a -> f a 218 | 219 | -- | Compute the difference between two vectors 220 | -- 221 | -- >>> V2 4 5 - V2 3 1 222 | -- V2 1 4 223 | (^-^) :: Num a => f a -> f a -> f a 224 | 225 | -- | Linearly interpolate between two vectors. 226 | lerp :: Num a => a -> f a -> f a -> f a 227 | 228 | -- | Provides a fairly subjective test to see if a quantity is near zero. 229 | -- 230 | -- >>> nearZero (1e-11 :: Double) 231 | -- False 232 | -- 233 | -- >>> nearZero (1e-17 :: Double) 234 | -- True 235 | -- 236 | -- >>> nearZero (1e-5 :: Float) 237 | -- False 238 | -- 239 | -- >>> nearZero (1e-7 :: Float) 240 | -- True 241 | class Num a => Epsilon a where 242 | -- | Determine if a quantity is near zero. 243 | nearZero :: a -> Bool 244 | 245 | -- | @'abs' a '<=' 1e-6@ 246 | instance Epsilon Float where 247 | nearZero a = abs a <= 1e-6 248 | {-# INLINE nearZero #-} 249 | 250 | -- | @'abs' a '<=' 1e-12@ 251 | instance Epsilon Double where 252 | nearZero a = abs a <= 1e-12 253 | {-# INLINE nearZero #-} 254 | 255 | instance Epsilon a => Epsilon (V4 a) where 256 | nearZero = nearZero . quadrance 257 | {-# INLINE nearZero #-} 258 | 259 | instance Epsilon a => Epsilon (V3 a) where 260 | nearZero = nearZero . quadrance 261 | {-# INLINE nearZero #-} 262 | 263 | instance Epsilon a => Epsilon (V2 a) where 264 | nearZero = nearZero . quadrance 265 | {-# INLINE nearZero #-} 266 | 267 | instance Epsilon a => Epsilon (V1 a) where 268 | nearZero (V1 a) = nearZero a 269 | {-# INLINE nearZero #-} 270 | 271 | instance Additive V4 where 272 | zero = V4 0 0 0 0 273 | {-# INLINE zero #-} 274 | 275 | (V4 a b c d) ^+^ (V4 a' b' c' d') = V4 (a + a') (b + b') (c + c') (d + d') 276 | {-# INLINE (^+^) #-} 277 | 278 | (V4 a b c d) ^-^ (V4 a' b' c' d') = V4 (a - a') (b - b') (c + c') (d + d') 279 | {-# INLINE (^-^) #-} 280 | lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha) 281 | {-# INLINE lerp #-} 282 | 283 | instance Additive V3 where 284 | zero = V3 0 0 0 285 | {-# INLINE zero #-} 286 | 287 | (V3 a b c) ^+^ (V3 a' b' c') = V3 (a + a') (b + b') (c + c') 288 | {-# INLINE (^+^) #-} 289 | 290 | (V3 a b c) ^-^ (V3 a' b' c') = V3 (a - a') (b - b') (c + c') 291 | {-# INLINE (^-^) #-} 292 | 293 | lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha) 294 | {-# INLINE lerp #-} 295 | 296 | instance Additive V2 where 297 | zero = V2 0 0 298 | {-# INLINE zero #-} 299 | 300 | (V2 a b) ^+^ (V2 a' b') = V2 (a + a') (b + b') 301 | {-# INLINE (^+^) #-} 302 | 303 | (V2 a b) ^-^ (V2 a' b') = V2 (a - a') (b - b') 304 | {-# INLINE (^-^) #-} 305 | 306 | lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha) 307 | {-# INLINE lerp #-} 308 | 309 | instance Additive V1 where 310 | zero = V1 0 311 | {-# INLINE zero #-} 312 | 313 | (V1 a) ^+^ (V1 a') = V1 (a + a') 314 | {-# INLINE (^+^) #-} 315 | 316 | (V1 a) ^-^ (V1 a') = V1 (a - a') 317 | {-# INLINE (^-^) #-} 318 | 319 | lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha) 320 | {-# INLINE lerp #-} 321 | 322 | -- | Free and sparse inner product/metric spaces. 323 | class Additive f => Metric f where 324 | -- | Compute the inner product of two vectors or (equivalently) 325 | -- convert a vector @f a@ into a covector @f a -> a@. 326 | -- 327 | -- >>> V2 1 2 `dot` V2 3 4 328 | -- 11 329 | dot :: Num a => f a -> f a -> a 330 | 331 | -- | Compute the squared norm. The name quadrance arises from 332 | -- Norman J. Wildberger's rational trigonometry. 333 | quadrance :: Num a => f a -> a 334 | {-# INLINE quadrance #-} 335 | quadrance v = dot v v 336 | 337 | -- | Compute the quadrance of the difference 338 | qd :: Num a => f a -> f a -> a 339 | {-# INLINE qd #-} 340 | qd f g = quadrance (f ^-^ g) 341 | 342 | -- | Compute the distance between two vectors in a metric space 343 | distance :: Floating a => f a -> f a -> a 344 | {-# INLINE distance #-} 345 | distance f g = norm (f ^-^ g) 346 | 347 | -- | Compute the norm of a vector in a metric space 348 | norm :: Floating a => f a -> a 349 | {-# INLINE norm #-} 350 | norm v = sqrt (quadrance v) 351 | 352 | -- | Convert a non-zero vector to unit vector. 353 | signorm :: Floating a => f a -> f a 354 | signorm v = fmap (/ m) v where 355 | m = norm v 356 | 357 | instance Metric V4 where 358 | dot (V4 a b c d) (V4 a' b' c' d') = a * a' + b * b' + c * c' + d * d' 359 | {-# INLINE dot #-} 360 | 361 | quadrance (V4 a b c d) = a * a + b * b + c * c + d * d 362 | {-# INLINE quadrance #-} 363 | 364 | norm v = sqrt (quadrance v) 365 | {-# INLINE norm #-} 366 | 367 | instance Metric V3 where 368 | dot (V3 a b c) (V3 a' b' c') = a * a' + b * b' + c * c' 369 | {-# INLINE dot #-} 370 | 371 | quadrance (V3 a b c) = a * a + b * b + c * c 372 | {-# INLINE quadrance #-} 373 | 374 | norm v = sqrt (quadrance v) 375 | {-# INLINE norm #-} 376 | 377 | instance Metric V2 where 378 | dot (V2 a b) (V2 a' b') = a * a' + b * b' 379 | {-# INLINE dot #-} 380 | 381 | quadrance (V2 a b) = a * a + b * b 382 | {-# INLINE quadrance #-} 383 | 384 | norm v = sqrt (quadrance v) 385 | {-# INLINE norm #-} 386 | 387 | -- | Compute the right scalar product 388 | -- 389 | -- >>> V2 3 4 ^* 2 390 | -- V2 6 8 391 | (^*) :: (Functor f, Num a) => f a -> a -> f a 392 | {-# INLINE (^*) #-} 393 | (^*) f n = fmap (* n) f 394 | 395 | -- | Compute division by a scalar on the right. 396 | (^/) :: (Functor f, Floating a) => f a -> a -> f a 397 | {-# INLINE (^/) #-} 398 | (^/) f n = fmap (/ n) f 399 | 400 | -- | Normalize a 'Metric' functor to have unit 'norm'. This function 401 | -- does not change the functor if its 'norm' is 0 or 1. 402 | normalize :: (Floating a, Metric f, Epsilon a) => f a -> f a 403 | {-# INLINE normalize #-} 404 | normalize v = if nearZero l || nearZero (1-l) then v 405 | else fmap (/ sqrt l) v 406 | where l = quadrance v 407 | 408 | #endif 409 | 410 | -------------------------------------------------------------------------------- /exec-src/snowflake.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad( replicateM ) 2 | import Data.Monoid( (<>) ) 3 | import qualified Data.Vector as V 4 | import Codec.Picture 5 | ( Image 6 | , PixelRGBA8( .. ) 7 | , writePng 8 | ) 9 | import Graphics.Rasterific 10 | ( Drawing 11 | , Bezier( .. ) 12 | , V2( .. ) 13 | , Point 14 | , fill 15 | , withTransformation 16 | , withTexture 17 | , renderDrawing 18 | ) 19 | import Graphics.Rasterific.Transformations 20 | ( Transformation 21 | , translate 22 | , scale 23 | , rotate 24 | ) 25 | 26 | import Graphics.Rasterific.Texture( uniformTexture ) 27 | import System.Random( randomRIO ) 28 | import Criterion( whnf, bench ) 29 | import Criterion.Main( defaultMain ) 30 | 31 | snowflakeColor :: PixelRGBA8 32 | snowflakeColor = PixelRGBA8 255 229 255 178 33 | 34 | snowflake :: [Bezier] 35 | snowflake = 36 | let b x1 y1 x2 y2 x3 y3 = Bezier (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) in 37 | [b 16.8063 (-26.3434) 17.7989 (-25.3508) 16.8009 (-22.7501), 38 | b 16.8009 (-22.7501) 16.3070 (-21.4629) 16.5456 (-21.1093), 39 | b 16.5456 (-21.1093) 16.6644 (-20.9332) 16.9645 (-20.9931), 40 | b 16.9645 (-20.9931) 17.2654 (-21.0532) 17.7455 (-21.3499), 41 | b 17.7455 (-21.3499) 18.6092 (-21.8837) 19.1487 (-21.5293), 42 | b 19.1487 (-21.5293) 19.6882 (-21.1749) 19.6882 (-20.0737), 43 | b 19.6882 (-20.0737) 19.6882 (-17.5969) 16.1479 (-16.4732), 44 | b 16.1479 (-16.4732) 14.0548 (-15.8089) 13.8003 (-15.2770), 45 | b 13.8003 (-15.2770) 13.6623 (-14.9887) 13.9414 (-14.6446), 46 | b 13.9414 (-14.6446) 14.2041 (-14.3207) 14.9025 (-13.8707), 47 | b 14.9025 (-13.8707) 16.3494 (-12.9382) 16.3133 (-12.3628), 48 | b 16.3133 (-12.3628) 16.2771 (-11.7875) 14.7068 (-10.7566), 49 | b 14.7068 (-10.7566) 12.2161 (-9.1216) 10.3181 (-9.0962), 50 | b 10.3181 (-9.0962) 8.4202 (-9.0707) 7.4644 (-6.5800), 51 | b 7.4644 (-6.5800) 7.0056 (-5.3844) 7.6667 (-4.7020), 52 | b 7.6667 (-4.7020) 8.2718 (-4.0775) 9.5712 (-4.0812), 53 | b 9.5712 (-4.0812) 12.6401 (-4.0898) 14.7238 (-6.6005), 54 | b 14.7238 (-6.6005) 15.9127 (-8.0330) 16.8479 (-8.1677), 55 | b 16.8479 (-8.1677) 17.7831 (-8.3023) 19.0783 (-7.2274), 56 | b 19.0783 (-7.2274) 20.3558 (-6.1671) 21.3969 (-6.2071), 57 | b 21.3969 (-6.2071) 22.4379 (-6.2471) 23.8394 (-7.4103), 58 | b 23.8394 (-7.4103) 24.8668 (-8.2629) 25.5985 (-8.5665), 59 | b 25.5985 (-8.5665) 25.9438 (-8.7099) 26.1336 (-8.6820), 60 | b 26.1336 (-8.6820) 26.2297 (-8.6679) 26.2793 (-8.6092), 61 | b 26.2793 (-8.6092) 26.3301 (-8.5490) 26.3301 (-8.4438), 62 | b 26.3301 (-8.4438) 26.3301 (-5.0516) 28.9388 (-3.5917), 63 | b 28.9388 (-3.5917) 31.2406 (-2.3035) 31.1691 (-0.4840), 64 | b 31.1691 (-0.4840) 31.0976 1.3355 28.5951 5.1548, 65 | b 28.5951 5.1548 26.7219 8.0136 25.8517 8.2511, 66 | b 25.8517 8.2511 24.9814 8.4887 22.9886 6.6852, 67 | b 22.9886 6.6852 21.0119 4.8963 20.3861 4.9237, 68 | b 20.3861 4.9237 19.7603 4.9510 19.0285 6.8582, 69 | b 19.0285 6.8582 18.2849 8.7960 17.6638 8.8069, 70 | b 17.6638 8.8069 17.0427 8.8178 14.9565 6.9298, 71 | b 14.9565 6.9298 11.9546 4.2131 8.9762 4.2131, 72 | b 8.9762 4.2131 7.1317 4.2131 6.9583 4.6873, 73 | b 6.9583 4.6873 6.7848 5.1614 8.0649 6.7038, 74 | b 8.0649 6.7038 10.1320 9.1945 12.3214 9.1945, 75 | b 12.3214 9.1945 14.7027 9.1945 15.6210 11.1190, 76 | b 15.6210 11.1190 16.0194 11.9541 15.8094 12.7617, 77 | b 15.8094 12.7617 15.5824 13.6348 14.7001 14.1801, 78 | b 14.7001 14.1801 14.1325 14.5309 13.9378 14.8353, 79 | b 13.9378 14.8353 13.7389 15.1460 13.9115 15.4341, 80 | b 13.9115 15.4341 14.2467 15.9936 16.1479 16.5970, 81 | b 16.1479 16.5970 18.7443 17.4211 19.5750 19.1195, 82 | b 19.5750 19.1195 19.9313 19.8481 19.6103 20.3129, 83 | b 19.6103 20.3129 19.2615 20.8179 18.2122 20.8179, 84 | b 18.2122 20.8179 17.6034 20.8179 17.2376 21.6705, 85 | b 17.2376 21.6705 16.8717 22.5231 16.9669 23.7204, 86 | b 16.9669 23.7204 17.1008 25.4064 15.8033 26.0897, 87 | b 15.8033 26.0897 14.5057 26.7730 10.7752 26.9810, 88 | b 10.7752 26.9810 6.0003 27.2472 5.2937 26.6088, 89 | b 5.2937 26.6088 4.5872 25.9703 5.2663 22.0029, 90 | b 5.2663 22.0029 5.6431 19.8017 5.6598 18.8439, 91 | b 5.6598 18.8439 5.6678 18.3914 5.5838 18.3574, 92 | b 5.5838 18.3574 5.5413 18.3400 5.4768 18.4343, 93 | b 5.4768 18.4343 5.4106 18.5310 5.3234 18.7423, 94 | b 5.3234 18.7423 4.7144 20.2184 4.0071 20.6781, 95 | b 4.0071 20.6781 3.3408 21.1112 2.7449 20.5553, 96 | b 2.7449 20.5553 1.4230 19.3223 1.4230 15.1042, 97 | b 1.4230 15.1042 1.4230 9.3905 (-0.2375) 8.3643, 98 | b (-0.2375) 8.3643 (-0.9317) 7.9353 (-1.3335) 8.1224, 99 | b (-1.3335) 8.1224 (-1.7565) 8.3193 (-1.9463) 9.2332, 100 | b (-1.9463) 9.2332 (-2.3005) 10.9392 (-1.9242) 16.4867, 101 | b (-1.9242) 16.4867 (-1.7256) 19.4124 (-2.2139) 20.1385, 102 | b (-2.2139) 20.1385 (-2.7021) 20.8646 (-4.4236) 20.2040, 103 | b (-4.4236) 20.2040 (-5.3338) 19.8547 (-5.8063) 19.8228, 104 | b (-5.8063) 19.8228 (-6.3221) 19.7879 (-6.5134) 20.1092, 105 | b (-6.5134) 20.1092 (-6.8561) 20.6848 (-6.2197) 23.2205, 106 | b (-6.2197) 23.2205 (-5.4941) 26.1115 (-6.2628) 26.6654, 107 | b (-6.2628) 26.6654 (-7.0315) 27.2192 (-11.4315) 26.9754, 108 | b (-11.4315) 26.9754 (-14.6467) 26.7972 (-16.1596) 26.1096, 109 | b (-16.1596) 26.1096 (-17.6725) 25.4220 (-17.6725) 24.1388, 110 | b (-17.6725) 24.1388 (-17.6725) 21.6481 (-20.1399) 20.1010, 111 | b (-20.1399) 20.1010 (-20.9108) 19.6177 (-21.1498) 19.2429, 112 | b (-21.1498) 19.2429 (-21.4069) 18.8398 (-21.1359) 18.4415, 113 | b (-21.1359) 18.4415 (-20.6423) 17.7160 (-17.6492) 16.4398, 114 | b (-17.6492) 16.4398 (-15.6040) 15.5678 (-14.7573) 14.9247, 115 | b (-14.7573) 14.9247 (-14.3575) 14.6212 (-14.3520) 14.4467, 116 | b (-14.3520) 14.4467 (-14.3492) 14.3583 (-14.4510) 14.3090, 117 | b (-14.4510) 14.3090 (-14.5554) 14.2584 (-14.7667) 14.2508, 118 | b (-14.7667) 14.2508 (-16.0660) 14.2039 (-16.5691) 13.6374, 119 | b (-16.5691) 13.6374 (-17.0373) 13.1100 (-16.7011) 12.2910, 120 | b (-16.7011) 12.2910 (-15.9365) 10.4285 (-12.6911) 9.1945, 121 | b (-12.6911) 9.1945 (-8.5399) 7.6163 (-8.5399) 5.9147, 122 | b (-8.5399) 5.9147 (-8.5399) 4.9917 (-9.2468) 4.5611, 123 | b (-9.2468) 4.5611 (-9.9051) 4.1601 (-10.9785) 4.2876, 124 | b (-10.9785) 4.2876 (-13.4170) 4.5773 (-15.1818) 6.7038, 125 | b (-15.1818) 6.7038 (-17.2242) 9.1648 (-18.6937) 9.0888, 126 | b (-18.6937) 9.0888 (-19.3865) 9.0531 (-19.7678) 8.3917, 127 | b (-19.7678) 8.3917 (-20.1632) 7.7061 (-20.1632) 6.4465, 128 | b (-20.1632) 6.4465 (-20.1632) 5.4062 (-20.2449) 5.0202, 129 | b (-20.2449) 5.0202 (-20.2958) 4.7792 (-20.3888) 4.6657, 130 | b (-20.3888) 4.6657 (-20.4850) 4.5484 (-20.6388) 4.5510, 131 | b (-20.6388) 4.5510 (-21.1144) 4.5592 (-23.2585) 6.4995, 132 | b (-23.2585) 6.4995 (-25.4562) 8.4884 (-26.3237) 8.2555, 133 | b (-26.3237) 8.2555 (-27.1911) 8.0226 (-29.2418) 4.8929, 134 | b (-29.2418) 4.8929 (-32.8702) (-0.6449) (-27.2854) (-8.9222), 135 | b (-27.2854) (-8.9222) (-27.1923) (-9.0603) (-26.8440) (-8.9490), 136 | b (-26.8440) (-8.9490) (-26.5078) (-8.8416) (-25.9821) (-8.5181), 137 | b (-25.9821) (-8.5181) (-24.8684) (-7.8328) (-23.4944) (-6.5892), 138 | b (-23.4944) (-6.5892) (-21.2502) (-4.5582) (-20.7067) (-4.5148), 139 | b (-20.7067) (-4.5148) (-20.5369) (-4.5012) (-20.4282) (-4.6082), 140 | b (-20.4282) (-4.6082) (-20.3227) (-4.7121) (-20.2629) (-4.9421), 141 | b (-20.2629) (-4.9421) (-20.1632) (-5.3259) (-20.1632) (-6.3227), 142 | b (-20.1632) (-6.3227) (-20.1632) (-7.5823) (-19.7678) (-8.2679), 143 | b (-19.7678) (-8.2679) (-19.3865) (-8.9293) (-18.6937) (-8.9650), 144 | b (-18.6937) (-8.9650) (-17.2242) (-9.0410) (-15.1818) (-6.5800), 145 | b (-15.1818) (-6.5800) (-13.1147) (-4.0893) (-9.5819) (-4.1446), 146 | b (-9.5819) (-4.1446) (-8.0423) (-4.1686) (-7.6019) (-4.2262), 147 | b (-7.6019) (-4.2262) (-7.2663) (-4.2701) (-7.1145) (-4.3531), 148 | b (-7.1145) (-4.3531) (-6.9551) (-4.4401) (-6.9655) (-4.5868), 149 | b (-6.9655) (-4.5868) (-6.9938) (-4.9877) (-9.8075) (-7.3346), 150 | b (-9.8075) (-7.3346) (-13.5659) (-10.4694) (-15.6191) (-11.3041), 151 | b (-15.6191) (-11.3041) (-16.7771) (-11.7748) (-16.7006) (-12.3216), 152 | b (-16.7006) (-12.3216) (-16.6241) (-12.8683) (-15.2684) (-13.8117), 153 | b (-15.2684) (-13.8117) (-14.5195) (-14.3327) (-14.2754) (-14.6893), 154 | b (-14.2754) (-14.6893) (-14.0134) (-15.0721) (-14.2475) (-15.3790), 155 | b (-14.2475) (-15.3790) (-14.6746) (-15.9388) (-17.4163) (-16.6270), 156 | b (-17.4163) (-16.6270) (-20.4849) (-17.3971) (-21.2071) (-19.6020), 157 | b (-21.2071) (-19.6020) (-21.5026) (-20.5042) (-20.9491) (-20.9641), 158 | b (-20.9491) (-20.9641) (-20.3358) (-21.4736) (-18.9057) (-21.1743), 159 | b (-18.9057) (-21.1743) (-18.2157) (-21.0299) (-17.7889) (-21.7606), 160 | b (-17.7889) (-21.7606) (-17.3621) (-22.4913) (-17.4528) (-23.6617), 161 | b (-17.4528) (-23.6617) (-17.5781) (-25.2795) (-16.2840) (-25.9644), 162 | b (-16.2840) (-25.9644) (-14.9899) (-26.6492) (-11.4315) (-26.8483), 163 | b (-11.4315) (-26.8483) (-7.0311) (-27.0944) (-6.2625) (-26.5413), 164 | b (-6.2625) (-26.5413) (-5.4940) (-25.9880) (-6.2197) (-23.0967), 165 | b (-6.2197) (-23.0967) (-6.8550) (-20.5656) (-6.5137) (-19.9873), 166 | b (-6.5137) (-19.9873) (-6.3235) (-19.6650) (-5.8107) (-19.6981), 167 | b (-5.8107) (-19.6981) (-5.3404) (-19.7284) (-4.4364) (-20.0753), 168 | b (-4.4364) (-20.0753) (-3.5146) (-20.4290) (-3.0272) (-20.4124), 169 | b (-3.0272) (-20.4124) (-2.4901) (-20.3941) (-2.2523) (-19.9329), 170 | b (-2.2523) (-19.9329) (-1.8302) (-19.1144) (-2.1761) (-15.6924), 171 | b (-2.1761) (-15.6924) (-2.7282) (-10.2301) (-0.6526) (-9.5121), 172 | b (-0.6526) (-9.5121) (-0.1235) (-9.3290) 0.2656 (-9.5565), 173 | b 0.2656 (-9.5565) 0.6565 (-9.7850) 0.9131 (-10.4319), 174 | b 0.9131 (-10.4319) 1.4230 (-11.7170) 1.4230 (-14.7440), 175 | b 1.4230 (-14.7440) 1.4230 (-19.1388) 2.7236 (-20.4008), 176 | b 2.7236 (-20.4008) 3.3172 (-20.9767) 4.0093 (-20.5495), 177 | b 4.0093 (-20.5495) 4.7393 (-20.0988) 5.4162 (-18.6185), 178 | b 5.4162 (-18.6185) 5.5129 (-18.4072) 5.5876 (-18.3117), 179 | b 5.5876 (-18.3117) 5.6605 (-18.2187) 5.7104 (-18.2384), 180 | b 5.7104 (-18.2384) 5.8087 (-18.2773) 5.8096 (-18.7378), 181 | b 5.8096 (-18.7378) 5.8115 (-19.7142) 5.4227 (-21.9394), 182 | b 5.4227 (-21.9394) 4.7390 (-25.8532) 5.3881 (-26.5946), 183 | b 5.3881 (-26.5946) 6.0371 (-27.3360) 10.1469 (-27.3360), 184 | b 10.1469 (-27.3360) 15.8137 (-27.3360) 16.8063 (-26.3434)] 185 | 186 | data Box = Box 187 | { _position :: !Point 188 | , _dy :: !Float 189 | , _scale :: !Float 190 | , _angle :: !Float 191 | , _dangle :: !Float 192 | } 193 | 194 | randomBox :: Float -> Float -> IO Box 195 | randomBox w h = Box 196 | <$> pos 197 | <*> randomRIO (0.5 , 2.2) 198 | <*> randomRIO (0.2 , 1.7) 199 | <*> randomRIO (0.0 , 4.0) 200 | <*> randomRIO (- 0.1 , 0.1) 201 | where 202 | pos = V2 203 | <$> randomRIO (0.0 , w) 204 | <*> randomRIO (0.0 , h) 205 | 206 | toTransform :: Float -> Float -> Float -> Box -> Transformation 207 | toTransform ww wh zoom box = 208 | translate (V2 (ww / 2) (wh / 2)) <> 209 | scale zoom zoom <> 210 | translate (V2 (-ww / 2) (-wh / 2)) <> 211 | translate (_position box) <> 212 | rotate (_angle box) <> 213 | scale (_scale box) (_scale box) 214 | 215 | renderFlake :: Float -> Float -> Float -> Box -> Drawing PixelRGBA8 () 216 | renderFlake w h zoom box = 217 | withTexture (uniformTexture snowflakeColor) . 218 | withTransformation (toTransform w h zoom box) $ 219 | fill snowflake 220 | 221 | renderFlakes :: Foldable f => Float -> Float -> Float -> f Box -> Image PixelRGBA8 222 | renderFlakes width height zoom boxes = 223 | renderDrawing (floor width) (floor height) background $ 224 | foldMap (renderFlake width height zoom) boxes 225 | where 226 | background = PixelRGBA8 0 0 0 255 227 | -- background = PixelRGBA8 255 255 255 255 228 | 229 | benchFlakes :: Foldable f => Float -> Float -> Float -> f Box -> Image PixelRGBA8 230 | benchFlakes width height zoom boxes = 231 | renderDrawing (floor width) (floor height) background $ 232 | foldMap (renderFlake width height zoom) boxes 233 | where 234 | background = PixelRGBA8 0 0 0 255 235 | 236 | main :: IO () 237 | main = do 238 | let width = 800 239 | height = 600 240 | zoom = 1 241 | boxes <- V.fromListN 500 <$> replicateM 1000 (randomBox width height) 242 | writePng "flakes.png" $ 243 | renderFlakes width height zoom boxes 244 | -- benching 245 | defaultMain [bench "flake draw" $ whnf (benchFlakes width height zoom) boxes] 246 | 247 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/Immediate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | -- | This module implements drawing primitives to draw directly into 8 | -- the output texture, without generating an intermediate scene 9 | -- representation. 10 | -- 11 | -- If you need to draw complex scenes or plot an important set of 12 | -- data, this is the module you should use. The downside is that 13 | -- you must specify everything you need at each draw call, there 14 | -- is no API to help you propagate constants. 15 | -- 16 | -- The "stroking" must be done using the functions of the 17 | -- `Graphics.Rasterific.Outline` module. 18 | module Graphics.Rasterific.Immediate 19 | ( DrawContext 20 | , DrawOrder( .. ) 21 | , orderToDrawing 22 | 23 | , runDrawContext 24 | , fillWithTextureAndMask 25 | , fillWithTexture 26 | , fillWithTextureNoAA 27 | , fillOrder 28 | 29 | , textToDrawOrders 30 | , transformOrder 31 | 32 | , meshToImage 33 | ) where 34 | 35 | 36 | import Control.Monad.ST( ST, runST ) 37 | import Data.Maybe( fromMaybe ) 38 | import qualified Data.Foldable as F 39 | import Control.Monad.Free( liftF ) 40 | import Control.Monad.State( evalStateT, execStateT, lift ) 41 | import Control.Monad.Trans.State( get ) 42 | import Codec.Picture.Types( Image( .. ) 43 | , Pixel( .. ) 44 | , MutableImage( .. ) 45 | , unsafeFreezeImage 46 | , fillImageWith ) 47 | 48 | import Control.Monad.Primitive( PrimMonad, primToPrim ) 49 | import qualified Data.Vector.Storable.Mutable as M 50 | import Graphics.Rasterific.Compositor 51 | import Graphics.Rasterific.Linear( V2( .. ) ) 52 | import Graphics.Rasterific.Rasterize 53 | import Graphics.Rasterific.Shading 54 | import Graphics.Rasterific.QuadraticBezier 55 | import Graphics.Rasterific.Types 56 | import Graphics.Rasterific.PatchTypes 57 | import Graphics.Rasterific.CubicBezier.FastForwardDifference 58 | import Graphics.Rasterific.Transformations 59 | import Graphics.Rasterific.MeshPatch 60 | import Graphics.Rasterific.ComplexPrimitive 61 | import Graphics.Rasterific.Command 62 | import Graphics.Rasterific.PlaneBoundable 63 | 64 | import qualified Data.Vector.Unboxed as VU 65 | import Graphics.Text.TrueType( Dpi, getStringCurveAtPoint ) 66 | 67 | -- | Reify a filling function call, to be able to manipulate 68 | -- them in a simpler fashion. 69 | data DrawOrder px = DrawOrder 70 | { -- | Primitives to be filled. 71 | _orderPrimitives :: ![[Primitive]] 72 | -- | Texture for the filled primitives. 73 | , _orderTexture :: !(Texture px) 74 | -- | How to fill the primitives. 75 | , _orderFillMethod :: !FillMethod 76 | -- | Optional mask used for clipping. 77 | , _orderMask :: !(Maybe (Texture (PixelBaseComponent px))) 78 | -- | Function to perform direct drawing 79 | , _orderDirect :: !(forall s. DrawContext (ST s) px ()) 80 | } 81 | 82 | instance PlaneBoundable (DrawOrder px) where 83 | planeBounds = 84 | foldMap (foldMap planeBounds) . _orderPrimitives 85 | 86 | transformOrder :: (Point -> Point) -> DrawOrder px -> DrawOrder px 87 | transformOrder f order = 88 | order { _orderPrimitives = transform f $ _orderPrimitives order } 89 | 90 | transformOrderM :: Monad m => (Point -> m Point) -> DrawOrder px -> m (DrawOrder px) 91 | transformOrderM f order = do 92 | v <- transformM f $ _orderPrimitives order 93 | return $ order { _orderPrimitives = v} 94 | 95 | instance Transformable (DrawOrder px) where 96 | transform = transformOrder 97 | transformM = transformOrderM 98 | 99 | -- | Transform back a low level drawing order to a more 100 | -- high level Drawing 101 | orderToDrawing :: DrawOrder px -> Drawing px () 102 | orderToDrawing order = 103 | usingTexture . mapM_ filler $ _orderPrimitives order 104 | where 105 | usingTexture sub = 106 | liftF $ SetTexture (_orderTexture order) sub () 107 | filler prims = 108 | liftF $ Fill (_orderFillMethod order) prims () 109 | 110 | -- | Render the drawing orders on the canvas. 111 | fillOrder :: (PrimMonad m, RenderablePixel px) 112 | => DrawOrder px -> DrawContext m px () 113 | fillOrder o@DrawOrder { _orderMask = Nothing } = do 114 | F.forM_ (_orderPrimitives o) $ 115 | fillWithTexture (_orderFillMethod o) (_orderTexture o) 116 | img <- get 117 | lift $ primToPrim $ flip evalStateT img $ _orderDirect o 118 | 119 | fillOrder o@DrawOrder { _orderMask = Just mask } = do 120 | F.forM_ (_orderPrimitives o) $ 121 | fillWithTextureAndMask (_orderFillMethod o) (_orderTexture o) mask 122 | img <- get 123 | lift $ primToPrim $ flip evalStateT img $ _orderDirect o 124 | 125 | -- | Start an image rendering. See `fillWithTexture` for 126 | -- an usage example. This function can work with either 127 | -- `IO` or `ST`. 128 | runDrawContext :: forall m px . (PrimMonad m, RenderablePixel px) 129 | => Int -- ^ Rendering width 130 | -> Int -- ^ Rendering height 131 | -> px -- ^ Background color 132 | -> DrawContext m px () -- ^ Actual drawing computation 133 | -> m (Image px) 134 | runDrawContext width height background drawing = do 135 | buff <- M.new (width * height * componentCount background) 136 | let mutable = MutableImage width height buff 137 | fillImageWith mutable background 138 | img <- execStateT drawing mutable 139 | unsafeFreezeImage img 140 | 141 | mapExec :: Monad m => (a -> m ()) -> [a] -> m () 142 | mapExec f = foldr ((>>) . f) (return ()) 143 | 144 | isCoverageDrawable :: MutableImage s px -> CoverageSpan -> Bool 145 | isCoverageDrawable img coverage = 146 | _coverageVal coverage > 0 && x >= 0 && y >= 0 && x < imgWidth && y < imgHeight 147 | where 148 | !imgWidth = fromIntegral $ mutableImageWidth img 149 | !imgHeight = fromIntegral $ mutableImageHeight img 150 | x = _coverageX coverage 151 | y = _coverageY coverage 152 | 153 | -- | Fill some geometry. 154 | -- 155 | -- > immediateDrawExample :: Image PixelRGBA8 156 | -- > immediateDrawExample = runST $ 157 | -- > runDrawContext 200 200 (PixelRGBA8 0 0 0 0) $ 158 | -- > fillWithTexture FillWinding texture geometry 159 | -- > where 160 | -- > circlePrimitives = circle (V2 100 100) 50 161 | -- > geometry = strokize 4 JoinRound (CapRound, CapRound) circlePrimitives 162 | -- > texture = uniformTexture (PixelRGBA8 255 255 255 255) 163 | -- 164 | -- <> 165 | -- 166 | fillWithTexture :: (PrimMonad m, RenderablePixel px) 167 | => FillMethod 168 | -> Texture px -- ^ Color/Texture used for the filling 169 | -> [Primitive] -- ^ Primitives to fill 170 | -> DrawContext m px () 171 | fillWithTexture fillMethod texture els = do 172 | img@(MutableImage width height _) <- get 173 | let !mini = V2 0 0 174 | !maxi = V2 (fromIntegral width) (fromIntegral height) 175 | !filler = primToPrim . transformTextureToFiller meshToImage texture img 176 | clipped = foldMap (clip mini maxi) els 177 | spans = rasterize fillMethod clipped 178 | lift . mapExec filler $ filter (isCoverageDrawable img) spans 179 | 180 | -- | Function identical to 'fillWithTexture' but with anti-aliasing 181 | -- (and transparency) disabled. 182 | fillWithTextureNoAA :: (PrimMonad m, RenderablePixel px) 183 | => FillMethod 184 | -> Texture px -- ^ Color/Texture used for the filling 185 | -> [Primitive] -- ^ Primitives to fill 186 | -> DrawContext m px () 187 | fillWithTextureNoAA fillMethod texture els = do 188 | img@(MutableImage width height _) <- get 189 | let !mini = V2 0 0 190 | !maxi = V2 (fromIntegral width) (fromIntegral height) 191 | !filler = primToPrim . transformTextureToFiller meshToImage texture img 192 | clipped = foldMap (clip mini maxi) els 193 | spans = rasterize fillMethod clipped 194 | lift . mapExec (filler . toOpaqueCoverage) $ filter (isCoverageDrawable img) spans 195 | 196 | -- | Fill some geometry using a composition mask for visibility. 197 | -- 198 | -- > immediateDrawMaskExample :: Image PixelRGBA8 199 | -- > immediateDrawMaskExample = runST $ 200 | -- > runDrawContext 200 200 (PixelRGBA8 0 0 0 255) $ 201 | -- > forM_ [1 .. 10] $ \ix -> 202 | -- > fillWithTextureAndMask FillWinding texture mask $ 203 | -- > rectangle (V2 10 (ix * 18 - 5)) 180 13 204 | -- > where 205 | -- > texture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255 206 | -- > mask = sampledImageTexture 207 | -- > $ runST 208 | -- > $ runDrawContext 200 200 0 209 | -- > $ fillWithTexture FillWinding (uniformTexture 255) maskGeometry 210 | -- > 211 | -- > maskGeometry = strokize 15 JoinRound (CapRound, CapRound) 212 | -- > $ circle (V2 100 100) 80 213 | -- 214 | -- <> 215 | -- 216 | fillWithTextureAndMask 217 | :: (PrimMonad m, RenderablePixel px) 218 | => FillMethod 219 | -> Texture px -- ^ Color/Texture used for the filling of the geometry 220 | -> Texture (PixelBaseComponent px) -- ^ Texture used for the mask. 221 | -> [Primitive] -- ^ Primitives to fill 222 | -> DrawContext m px () 223 | fillWithTextureAndMask fillMethod texture mask els = do 224 | img@(MutableImage width height _) <- get 225 | let !mini = V2 0 0 226 | !maxi = V2 (fromIntegral width) (fromIntegral height) 227 | spans = rasterize fillMethod $ foldMap (clip mini maxi) els 228 | !shader = primToPrim 229 | . transformTextureToFiller meshToImage (ModulateTexture texture mask) img 230 | lift . mapM_ shader $ filter (isCoverageDrawable img) spans 231 | 232 | -- | Helper function transforming text range to draw order. 233 | textToDrawOrders :: Dpi -- ^ Current output device resolution 234 | -> Texture px -- ^ Texture to use if no texture is defined in the range 235 | -> Point -- ^ Baseline position 236 | -> [TextRange px] -- ^ Text description. 237 | -> [DrawOrder px] 238 | textToDrawOrders dpi defaultTexture (V2 x y) descriptions = 239 | toOrder <$> zip floatCurves linearDescriptions where 240 | 241 | toOrder (curve, d) = DrawOrder 242 | { _orderPrimitives = [beziersOfChar curve] 243 | , _orderFillMethod = FillWinding 244 | , _orderMask = Nothing 245 | , _orderTexture = fromMaybe defaultTexture $ _textTexture d 246 | , _orderDirect = return () 247 | } 248 | 249 | floatCurves = 250 | getStringCurveAtPoint dpi (x, y) 251 | [(_textFont d, _textSize d, _text d) | d <- descriptions] 252 | 253 | linearDescriptions = 254 | concat [map (const d) $ _text d | d <- descriptions] 255 | 256 | beziersOfChar curves = concat 257 | [fmap BezierPrim . bezierFromPath . fmap (uncurry V2) $ VU.toList c | c <- curves] 258 | 259 | 260 | meshToImage :: forall px. (RenderablePixel px) 261 | => Maybe Transformation -> Int-> Int 262 | -> PatchInterpolation -> MeshPatch px 263 | -> Image px 264 | meshToImage mayTrans width height i baseMesh 265 | | not hasTransparency = rendering 266 | | otherwise = runST $ runDrawContext width height background $ fillOrder order 267 | where 268 | mesh = case mayTrans >>= inverseTransformation of 269 | Nothing -> baseMesh 270 | Just trans -> 271 | transform (applyTransformation trans) baseMesh 272 | 273 | background = emptyPx :: px 274 | clipBackground = emptyValue :: PixelBaseComponent px 275 | 276 | rendering = runST $ runDrawContext width height background $ case i of 277 | PatchBilinear -> mapM_ rasterizeCoonPatch $ coonPatchesOf opaqueMesh 278 | PatchBicubic -> 279 | mapM_ rasterizeCoonPatch 280 | . cubicCoonPatchesOf 281 | $ calculateMeshColorDerivative opaqueMesh 282 | 283 | hasTransparency = 284 | F.any ((/= fullValue) . pixelOpacity) $ _meshColors mesh 285 | 286 | opacifier px = mixWithAlpha (\_ _ a -> a) (\_ _ -> fullValue) px px 287 | 288 | opaqueMesh = opacifier <$> mesh 289 | transparencyMesh = pixelOpacity <$> mesh 290 | 291 | clipPath = 292 | runST $ runDrawContext width height clipBackground $ case i of 293 | PatchBilinear -> mapM_ rasterizeCoonPatch $ coonPatchesOf transparencyMesh 294 | PatchBicubic -> 295 | mapM_ rasterizeCoonPatch 296 | . cubicCoonPatchesOf 297 | $ calculateMeshColorDerivative transparencyMesh 298 | 299 | order = DrawOrder 300 | { _orderPrimitives = [rectangle (V2 0 0) (fromIntegral width) (fromIntegral height)] 301 | , _orderTexture = AlphaModulateTexture (RawTexture rendering) (RawTexture clipPath) 302 | , _orderFillMethod = FillWinding 303 | , _orderMask = Nothing 304 | , _orderDirect = return () 305 | } 306 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/PatchTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | module Graphics.Rasterific.PatchTypes 11 | ( -- * New geometry 12 | CoonPatch( .. ) 13 | , TensorPatch( .. ) 14 | , MeshPatch( .. ) 15 | , InterBezier( .. ) 16 | 17 | -- * Types 18 | , CoonColorWeight 19 | , PatchInterpolation( .. ) 20 | , ParametricValues( .. ) 21 | , Derivative( .. ) 22 | , Derivatives( .. ) 23 | , UV 24 | , UVPatch 25 | , CubicCoefficient( .. ) 26 | , ImageMesh( .. ) 27 | 28 | -- * Helper functions 29 | , transposeParametricValues 30 | , coonPointAt 31 | , toTensorPatch 32 | , foldMeshPoints 33 | , isVerticalOrientation 34 | 35 | -- * Lenses 36 | , xDerivative 37 | , yDerivative 38 | ) where 39 | 40 | import qualified Data.Vector as V 41 | 42 | import Codec.Picture( Image ) 43 | 44 | import Graphics.Rasterific.CubicBezier 45 | import Graphics.Rasterific.MiniLens 46 | import Graphics.Rasterific.Linear 47 | import Graphics.Rasterific.Types 48 | import Graphics.Rasterific.Compositor 49 | import Graphics.Rasterific.Transformations 50 | 51 | -- | Type of coordinate interpolation 52 | type CoonColorWeight = Float 53 | 54 | -- | How do we want to perform color/image interpolation 55 | -- within the patch. 56 | data PatchInterpolation 57 | = -- | Bilinear interpolation 58 | -- 59 | -- @ 60 | -- import qualified Data.Vector as V 61 | -- let colorCycle = cycle 62 | -- [ PixelRGBA8 0 0x86 0xc1 255 63 | -- , PixelRGBA8 0xff 0xf4 0xc1 255 64 | -- , PixelRGBA8 0xFF 0x53 0x73 255 65 | -- , PixelRGBA8 0xff 0xf4 0xc1 255 66 | -- , PixelRGBA8 0 0x86 0xc1 255] 67 | -- colors = V.fromListN (4 * 4) colorCycle 68 | -- renderMeshPatch PatchBilinear $ generateLinearGrid 3 3 (V2 10 10) (V2 60 60) colors 69 | -- @ 70 | -- 71 | -- <> 72 | -- 73 | PatchBilinear 74 | -- | Bicubic interpolation 75 | -- 76 | -- @ 77 | -- import qualified Data.Vector as V 78 | -- let colorCycle = cycle 79 | -- [ PixelRGBA8 0 0x86 0xc1 255 80 | -- , PixelRGBA8 0xff 0xf4 0xc1 255 81 | -- , PixelRGBA8 0xFF 0x53 0x73 255 82 | -- , PixelRGBA8 0xff 0xf4 0xc1 255 83 | -- , PixelRGBA8 0 0x86 0xc1 255] 84 | -- colors = V.fromListN (4 * 4) colorCycle 85 | -- renderMeshPatch PatchBicubic $ generateLinearGrid 3 3 (V2 10 10) (V2 60 60) colors 86 | -- @ 87 | -- 88 | -- <> 89 | -- 90 | | PatchBicubic 91 | deriving (Eq, Show) 92 | 93 | -- | Values associated to the corner of a patch 94 | -- 95 | -- @ 96 | -- North East 97 | -- +--------------+ 98 | -- |0 1| 99 | -- | | 100 | -- | | 101 | -- | | 102 | -- |3 2| 103 | -- +--------------+ 104 | -- West South 105 | -- @ 106 | -- 107 | data ParametricValues a = ParametricValues 108 | { _northValue :: !a 109 | , _eastValue :: !a 110 | , _southValue :: !a 111 | , _westValue :: !a 112 | } 113 | deriving (Functor, Show) 114 | 115 | -- | Store the derivative necessary for cubic interpolation in 116 | -- the gradient mesh. 117 | data Derivative px = Derivative 118 | { _derivValues :: !(Holder px Float) 119 | , _xDerivative :: !(Holder px Float) 120 | , _yDerivative :: !(Holder px Float) 121 | , _xyDerivative :: !(Holder px Float) 122 | } 123 | 124 | deriving instance Show (Holder px Float) => Show (Derivative px) 125 | 126 | -- | Helping lens 127 | xDerivative :: Lens' (Derivative px) (Holder px Float) 128 | xDerivative = lens _xDerivative setter where 129 | setter o v = o { _xDerivative = v } 130 | 131 | -- | Help lens 132 | yDerivative :: Lens' (Derivative px) (Holder px Float) 133 | yDerivative = lens _yDerivative setter where 134 | setter o v = o { _yDerivative = v } 135 | 136 | instance Applicative ParametricValues where 137 | pure a = ParametricValues a a a a 138 | ParametricValues n e s w <*> ParametricValues n' e' s' w' = 139 | ParametricValues (n n') (e e') (s s') (w w') 140 | 141 | instance Foldable ParametricValues where 142 | foldMap f (ParametricValues n e s w) = f n <> f e <> f s <> f w 143 | 144 | -- | Transpose (switch vertical/horizontal orientation) of values. 145 | transposeParametricValues :: ParametricValues a -> ParametricValues a 146 | transposeParametricValues (ParametricValues n e s w) = ParametricValues n w s e 147 | 148 | -- | Describe a tensor patch 149 | data TensorPatch weight = TensorPatch 150 | { _curve0 :: !CubicBezier 151 | , _curve1 :: !CubicBezier 152 | , _curve2 :: !CubicBezier 153 | , _curve3 :: !CubicBezier 154 | , _tensorValues :: !weight 155 | } 156 | 157 | isVerticalOrientation :: TensorPatch a -> Bool 158 | isVerticalOrientation p = dy > dx where 159 | CubicBezier a _ _ d = _curve0 p 160 | V2 dx dy = abs <$> (d ^-^ a) 161 | 162 | instance Transformable (TensorPatch px) where 163 | transform f (TensorPatch c0 c1 c2 c3 v) = 164 | TensorPatch 165 | (transform f c0) 166 | (transform f c1) 167 | (transform f c2) 168 | (transform f c3) 169 | v 170 | transformM f (TensorPatch c0 c1 c2 c3 v) = 171 | TensorPatch 172 | <$> transformM f c0 173 | <*> transformM f c1 174 | <*> transformM f c2 175 | <*> transformM f c3 176 | <*> return v 177 | 178 | 179 | instance {-# OVERLAPPING #-} PointFoldable (TensorPatch px) where 180 | foldPoints f acc (TensorPatch c0 c1 c2 c3 _) = g c3 . g c2 . g c1 $ g c0 acc 181 | where g v a = foldPoints f a v 182 | 183 | -- | Define the boundary and interpolated values of a coon patch. 184 | -- 185 | -- @ 186 | -- -----> 187 | -- North _____----------------+ 188 | -- ^ +------------// // . 189 | -- | // // | 190 | -- | // // | 191 | -- | // // east | 192 | -- | west | / | 193 | -- | | v 194 | -- \\ \\ . 195 | -- \\ __-------------+ 196 | -- +----------------/ 197 | -- South 198 | -- <----- 199 | -- @ 200 | -- 201 | data CoonPatch weight = CoonPatch 202 | { _north :: !CubicBezier -- ^ North border, from left to right at top 203 | , _east :: !CubicBezier -- ^ East obrder, from top to bottom 204 | , _south :: !CubicBezier -- ^ South border from right to left 205 | , _west :: !CubicBezier -- ^ West border from bottom to top 206 | , _coonValues :: !weight -- ^ The patch values 207 | } 208 | deriving Show 209 | 210 | instance {-# OVERLAPPING #-} Transformable (CoonPatch px) where 211 | transformM = transformCoonM 212 | transform = transformCoon 213 | 214 | instance {-# OVERLAPPING #-} PointFoldable (CoonPatch px) where 215 | foldPoints f acc (CoonPatch n e s w _) = g n . g e . g s $ g w acc 216 | where g v a = foldPoints f a v 217 | 218 | transformCoonM :: Monad m => (Point -> m Point) -> CoonPatch px -> m (CoonPatch px) 219 | transformCoonM f (CoonPatch n e s w v) = 220 | CoonPatch <$> transformM f n <*> transformM f e <*> transformM f s <*> transformM f w 221 | <*> return v 222 | 223 | transformCoon :: (Point -> Point) -> CoonPatch px -> CoonPatch px 224 | transformCoon f (CoonPatch n e s w v) = 225 | CoonPatch 226 | (transform f n) 227 | (transform f e) 228 | (transform f s) 229 | (transform f w) 230 | v 231 | 232 | -- | Define a mesh patch grid, the grid is conceptually 233 | -- a regular grid of _meshPatchWidth * _meshPatchHeight 234 | -- patches but with shared edges 235 | data MeshPatch px = MeshPatch 236 | { -- | Count of horizontal of *patch* 237 | _meshPatchWidth :: !Int 238 | -- | Count of vertical of *patch* 239 | , _meshPatchHeight :: !Int 240 | -- | Main points defining the patch, of size 241 | -- (_meshPatchWidth + 1) * (_meshPatchHeight + 1) 242 | , _meshPrimaryVertices :: !(V.Vector Point) 243 | -- | For each line, store the points in between each 244 | -- vertex. There is two points between each vertex, so 245 | -- _meshPatchWidth * (_meshPatchHeight + 1) points 246 | , _meshHorizontalSecondary :: !(V.Vector InterBezier) 247 | -- | For each colun, store the points in between each 248 | -- vertex. Two points between each vertex, so 249 | -- _meshPatchHeight * (_meshPatchWidth + 1) 250 | , _meshVerticalSecondary :: !(V.Vector InterBezier) 251 | -- | Colors for each vertex points 252 | , _meshColors :: !(V.Vector px) 253 | -- | Points used to define tensor patch, if not define, 254 | -- the rest of the data structure describes a Coon patch. 255 | -- size must be equal to `_meshPatchWidth*_meshPatchHeight` 256 | , _meshTensorDerivatives :: !(Maybe (V.Vector Derivatives)) 257 | } 258 | deriving (Eq, Show, Functor) 259 | 260 | -- | Store the two bezier control points of a bezier. 261 | data InterBezier = InterBezier 262 | { _inter0 :: !Point 263 | , _inter1 :: !Point 264 | } 265 | deriving (Eq, Show) 266 | 267 | instance Transformable InterBezier where 268 | transform f (InterBezier a b) = InterBezier (f a) (f b) 269 | transformM f (InterBezier a b) = InterBezier <$> f a <*> f b 270 | 271 | instance PointFoldable InterBezier where 272 | foldPoints f acc (InterBezier a b) = f (f acc a) b 273 | 274 | transformMeshM :: Monad m => (Point -> m Point) -> MeshPatch px -> m (MeshPatch px) 275 | transformMeshM f MeshPatch { .. } = do 276 | vertices <- mapM f _meshPrimaryVertices 277 | hSecondary <- mapM (transformM f) _meshHorizontalSecondary 278 | vSecondary <- mapM (transformM f) _meshVerticalSecondary 279 | return $ MeshPatch 280 | { _meshPatchWidth = _meshPatchWidth 281 | , _meshPatchHeight = _meshPatchHeight 282 | , _meshPrimaryVertices = vertices 283 | , _meshHorizontalSecondary = hSecondary 284 | , _meshVerticalSecondary = vSecondary 285 | , _meshColors = _meshColors 286 | , _meshTensorDerivatives = Nothing 287 | } 288 | 289 | instance {-# OVERLAPPING #-} Transformable (MeshPatch px) where 290 | transformM = transformMeshM 291 | 292 | instance {-# OVERLAPPING #-} PointFoldable (MeshPatch px) where 293 | foldPoints = foldMeshPoints 294 | 295 | foldMeshPoints :: (a -> Point -> a) -> a -> MeshPatch px -> a 296 | foldMeshPoints f acc m = acc4 where 297 | acc1 = V.foldl' f acc (_meshPrimaryVertices m) 298 | acc2 = foldPoints f acc1 (_meshHorizontalSecondary m) 299 | acc3 = foldPoints f acc2 (_meshVerticalSecondary m) 300 | acc4 = case _meshTensorDerivatives m of 301 | Nothing -> acc3 302 | Just v -> foldPoints f acc3 v 303 | 304 | -- | Store the inner points of a tensor patch. 305 | data Derivatives = Derivatives 306 | { _interNorthWest :: !Point 307 | , _interNorthEast :: !Point 308 | , _interSouthWest :: !Point 309 | , _interSouthEast :: !Point 310 | } 311 | deriving (Eq, Show) 312 | 313 | instance Transformable Derivatives where 314 | transform f (Derivatives a b c d) = 315 | Derivatives (f a) (f b) (f c) (f d) 316 | transformM f (Derivatives a b c d) = 317 | Derivatives <$> f a <*> f b <*> f c <*> f d 318 | 319 | instance PointFoldable Derivatives where 320 | foldPoints f acc (Derivatives a b c d) = f (f (f (f acc a) b) c) d 321 | 322 | -- | Represent a point in the paramaetric U,V space 323 | -- from [0, 1]^2 324 | type UV = V2 CoonColorWeight 325 | 326 | -- | Define a rectangle in the U,V parametric space. 327 | type UVPatch = ParametricValues UV 328 | 329 | -- | Store information for cubic interpolation in a patch. 330 | newtype CubicCoefficient px = CubicCoefficient 331 | { getCubicCoefficients :: ParametricValues (V4 (Holder px Float)) 332 | } 333 | 334 | -- | Type storing the information to be able to interpolate 335 | -- part of an image in a patch. 336 | data ImageMesh px = ImageMesh 337 | { _meshImage :: !(Image px) 338 | , _meshTransform :: !Transformation 339 | } 340 | 341 | -- C1: top _north 342 | -- C2: bottom _south 343 | -- D1: left _west 344 | -- D2: right _east 345 | 346 | -- | Return a postion of a point in the coon patch. 347 | coonPointAt :: CoonPatch a -> UV -> Point 348 | coonPointAt CoonPatch { .. } (V2 u v) = sc ^+^ sd ^-^ sb 349 | where 350 | CubicBezier c10 _ _ c11 = _north 351 | CubicBezier c21 _ _ c20 = _south 352 | 353 | sc = lerp v c2 c1 354 | sd = lerp u d2 d1 355 | sb = lerp v (lerp u c21 c20) 356 | (lerp u c11 c10) 357 | 358 | CubicBezier _ _ _ c1 = fst $ cubicBezierBreakAt _north u 359 | CubicBezier _ _ _ c2 = fst $ cubicBezierBreakAt _south (1 - u) 360 | 361 | CubicBezier _ _ _ d2 = fst $ cubicBezierBreakAt _east v 362 | CubicBezier _ _ _ d1 = fst $ cubicBezierBreakAt _west (1 - v) 363 | 364 | -- | Convert a coon patch in 365 | toTensorPatch :: CoonPatch a -> TensorPatch a 366 | toTensorPatch CoonPatch { .. } = TensorPatch 367 | { _curve0 = _north 368 | , _curve1 = CubicBezier wt p11 p21 et 369 | , _curve2 = CubicBezier wb p12 p22 eb 370 | , _curve3 = CubicBezier sd sc sb sa 371 | , _tensorValues = _coonValues 372 | } 373 | where 374 | formula a b c d e f g h = 375 | (a ^* (-4) ^+^ 376 | (b ^+^ c) ^* 6 ^-^ 377 | (d ^+^ e) ^* 2 ^+^ 378 | (f ^+^ g) ^* 3 ^-^ 379 | h) ^* (1/9) 380 | 381 | p11 = formula p00 p10 p01 p30 p03 p13 p31 p33 382 | p21 = formula p30 p20 p31 p00 p33 p23 p01 p03 383 | p12 = formula p03 p13 p02 p33 p00 p10 p32 p30 384 | p22 = formula p33 p23 p32 p03 p30 p20 p02 p00 385 | 386 | CubicBezier p00 p10 p20 p30 = _north 387 | CubicBezier _ p02 p01 _ = _west 388 | CubicBezier _ p31 p32 _ = _east 389 | CubicBezier p33 p23 p13 p03 = _south 390 | 391 | CubicBezier sa sb sc sd = _south 392 | CubicBezier _ et eb _ = _east 393 | CubicBezier _ wb wt _ = _west 394 | 395 | 396 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/CubicBezier.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | module Graphics.Rasterific.CubicBezier 6 | ( cubicBezierCircle 7 | , cubicBezierFromPath 8 | , cubicBezierBreakAt 9 | , divideCubicBezier 10 | , clipCubicBezier 11 | , decomposeCubicBeziers 12 | , sanitizeCubicBezier 13 | , sanitizeCubicBezierFilling 14 | , offsetCubicBezier 15 | , flattenCubicBezier 16 | , cubicBezierLengthApproximation 17 | , cubicBezierBounds 18 | , cubicFromQuadraticBezier 19 | , isCubicBezierPoint 20 | ) where 21 | 22 | import Prelude hiding( or ) 23 | 24 | import Control.Applicative( liftA2 ) 25 | import Graphics.Rasterific.Linear 26 | ( V2( .. ) 27 | , (^-^) 28 | , (^+^) 29 | , (^*) 30 | , norm 31 | , lerp 32 | ) 33 | import Data.List( nub ) 34 | import Graphics.Rasterific.Operators 35 | import Graphics.Rasterific.Types 36 | import Graphics.Rasterific.QuadraticFormula 37 | 38 | -- | Create a list of cubic bezier patch from a list of points. 39 | -- 40 | -- > cubicBezierFromPath [a, b, c, d, e] = [CubicBezier a b c d] 41 | -- > cubicBezierFromPath [a, b, c, d, e, f, g] = 42 | -- > [CubicBezier a b c d, CubicBezier d e f g] 43 | -- 44 | cubicBezierFromPath :: [Point] -> [CubicBezier] 45 | cubicBezierFromPath (a:b:c:rest@(d:_)) = 46 | CubicBezier a b c d : cubicBezierFromPath rest 47 | cubicBezierFromPath _ = [] 48 | 49 | cubicBezierLengthApproximation :: CubicBezier -> Float 50 | cubicBezierLengthApproximation (CubicBezier a _ _ d) = 51 | norm $ d ^-^ a 52 | 53 | -- | Represent a circle of radius 1 centered on 0 of 54 | -- a cubic bezier curve. 55 | cubicBezierCircle :: [CubicBezier] 56 | cubicBezierCircle = 57 | [ CubicBezier (V2 0 1) (V2 c 1) (V2 1 c) (V2 1 0) 58 | , CubicBezier (V2 1 0) (V2 1 (-c)) (V2 c (-1)) (V2 0 (-1)) 59 | , CubicBezier (V2 0 (-1)) (V2 (-c) (-1)) (V2 (-1) (-c)) (V2 (-1) 0) 60 | , CubicBezier (V2 (-1) 0) (V2 (-1) c) (V2 (-c) 1) (V2 0 1) 61 | ] 62 | where c = 0.551915024494 -- magic constant? magic constant. 63 | 64 | straightLine :: Point -> Point -> CubicBezier 65 | straightLine a b = CubicBezier a p p b 66 | where p = a `midPoint` b 67 | 68 | isSufficientlyFlat :: Float -- ^ Tolerance 69 | -> CubicBezier 70 | -> Bool 71 | isSufficientlyFlat tol (CubicBezier a b c d) = 72 | x + y <= tolerance 73 | where u = (b ^* 3) ^-^ (a ^* 2) ^-^ d 74 | v = (c ^* 3) ^-^ (d ^* 2) ^-^ a 75 | (^*^) = liftA2 (*) 76 | V2 x y = vmax (u ^*^ u) (v ^*^ v) 77 | tolerance = 16 * tol * tol 78 | 79 | splitCubicBezier :: CubicBezier -> (Point, Point, Point, Point, Point, Point) 80 | {-# INLINE splitCubicBezier #-} 81 | splitCubicBezier (CubicBezier a b c d) = (ab, bc, cd, abbc, bccd, abbcbccd) 82 | where 83 | -- BC 84 | -- B X----------X---------X C 85 | -- ^ / ___/ \___ \ ^ 86 | -- u \ / __X------X------X_ \ / v 87 | -- \ /___/ ABBC BCCD \___\ / 88 | -- AB X/ \X CD 89 | -- / \ 90 | -- / \ 91 | -- / \ 92 | -- A X X D 93 | ab = a `midPoint` b 94 | bc = b `midPoint` c 95 | cd = c `midPoint` d 96 | 97 | abbc = ab `midPoint` bc 98 | bccd = bc `midPoint` cd 99 | abbcbccd = abbc `midPoint` bccd 100 | 101 | flattenCubicBezier :: CubicBezier -> Container Primitive 102 | flattenCubicBezier bezier@(CubicBezier a _ _ d) 103 | | isSufficientlyFlat 1 bezier = pure $ CubicBezierPrim bezier 104 | | otherwise = 105 | flattenCubicBezier (CubicBezier a ab abbc abbcbccd) <> 106 | flattenCubicBezier (CubicBezier abbcbccd bccd cd d) 107 | where 108 | (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier 109 | 110 | -- 3 2 2 3 111 | -- x(t) = (1 - t) ∙x + 3∙t∙(1 - t) ∙x + 3∙t ∙(1 - t)∙x + t ∙x 112 | -- 0 1 2 3 113 | -- 114 | -- 3 2 2 3 115 | -- y(t) = (1 - t) ∙y + 3∙t∙(1 - t) ∙y + 3∙t ∙(1 - t)∙y + t ∙y 116 | -- 0 1 2 3 117 | 118 | -- Other representation: 119 | -- 3 2 2 3 120 | -- B(t) = x(1 - t) + 3∙y∙t∙(1 - t) + 3∙z∙t ∙(1 - t) + w∙t 121 | 122 | 123 | -- | Represent the cubic bezier curve as a vector ready 124 | -- for matrix multiplication 125 | data CachedBezier = CachedBezier 126 | { _cachedA :: {-# UNPACK #-} !Float 127 | , _cachedB :: {-# UNPACK #-} !Float 128 | , _cachedC :: {-# UNPACK #-} !Float 129 | , _cachedD :: {-# UNPACK #-} !Float 130 | } 131 | 132 | cacheBezier :: CubicBezier -> (CachedBezier, CachedBezier) 133 | cacheBezier (CubicBezier p0@(V2 x0 y0) p1 p2 p3) = 134 | (CachedBezier x0 bX cX dX, CachedBezier y0 bY cY dY) 135 | where 136 | V2 bX bY = p1 ^* 3 ^-^ p0 ^* 3 137 | V2 cX cY = p2 ^* 3 ^-^ p1 ^* 6 + p0 ^* 3 138 | V2 dX dY = p3 ^-^ p2 ^* 3 ^+^ p1 ^* 3 ^-^ p0 139 | 140 | cachedBezierAt :: CachedBezier -> Float -> Float 141 | cachedBezierAt (CachedBezier a b c d) t = 142 | a + b * t + c * tSquare + tCube * d 143 | where 144 | tSquare = t * t 145 | tCube = tSquare * t 146 | 147 | cachedBezierDerivative :: CachedBezier -> QuadraticFormula Float 148 | cachedBezierDerivative (CachedBezier _ b c d) = 149 | QuadraticFormula (3 * d) (2 * c) b 150 | 151 | -- | Find the coefficient of the extremum points 152 | extremums :: CachedBezier -> [Float] 153 | extremums cached = 154 | [ root | root <- formulaRoots $ cachedBezierDerivative cached 155 | , 0 <= root && root <= 1.0 ] 156 | 157 | extremumPoints :: (CachedBezier, CachedBezier) -> [Point] 158 | extremumPoints (onX, onY) = toPoints <$> nub (extremums onX <> extremums onY) 159 | where toPoints at = V2 (cachedBezierAt onX at) (cachedBezierAt onY at) 160 | 161 | cubicBezierBounds :: CubicBezier -> [Point] 162 | cubicBezierBounds bez@(CubicBezier p0 _ _ p3) = 163 | p0 : p3 : extremumPoints (cacheBezier bez) 164 | 165 | offsetCubicBezier :: Float -> CubicBezier -> Container Primitive 166 | offsetCubicBezier offset bezier@(CubicBezier a b c d) 167 | | isSufficientlyFlat 1 bezier = 168 | pure . CubicBezierPrim $ CubicBezier shiftedA shiftedB shiftedC shiftedD 169 | | otherwise = 170 | recurse (CubicBezier a ab abbc abbcbccd) <> 171 | recurse (CubicBezier abbcbccd bccd cd d) 172 | where 173 | recurse = offsetCubicBezier offset 174 | 175 | u = a `normal` b 176 | v = c `normal` d 177 | 178 | -- BC 179 | -- B X----------X---------X C 180 | -- ^ / ___/ \___ \ ^ 181 | -- u \ / __X------X------X_ \ / v 182 | -- \ /___/ ABBC BCCD \___\ / 183 | -- AB X/ \X CD 184 | -- / \ 185 | -- / \ 186 | -- / \ 187 | -- A X X D 188 | (ab, bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier 189 | 190 | w = ab `normal` bc 191 | x = bc `normal` cd 192 | 193 | shiftedA = a ^+^ (u ^* offset) 194 | shiftedD = d ^+^ (v ^* offset) 195 | 196 | {-shiftedABBCBCCD = abbcbccd ^+^ (w ^* offset)-} 197 | shiftedB = b ^+^ (w ^* offset) 198 | shiftedC = c ^+^ (x ^* offset) 199 | 200 | -- | Clamp the cubic bezier curve inside a rectangle 201 | -- given in parameter. 202 | clipCubicBezier 203 | :: Point -- ^ Point representing the "minimal" point for cliping 204 | -> Point -- ^ Point representing the "maximal" point for cliping 205 | -> CubicBezier -- ^ The cubic bezier curve to be clamped 206 | -> Container Primitive 207 | clipCubicBezier mini maxi bezier@(CubicBezier a b c d) 208 | -- If we are in the range bound, return the curve 209 | -- unaltered 210 | | insideX && insideY = pure $ CubicBezierPrim bezier 211 | -- If one of the component is outside, clamp 212 | -- the components on the boundaries and output a 213 | -- straight line on this boundary. Useful for the 214 | -- filing case, to clamp the polygon drawing on 215 | -- the edge 216 | | outsideX || outsideY = 217 | pure . CubicBezierPrim $ clampedA `straightLine` clampedD 218 | -- Not completly inside nor outside, just divide 219 | -- and conquer. 220 | | otherwise = 221 | recurse (CubicBezier a ab abbc m) <> 222 | recurse (CubicBezier m bccd cd d) 223 | where -- Minimal & maximal dimension of the bezier curve 224 | bmin = vmin a . vmin b $ vmin c d 225 | bmax = vmax a . vmax b $ vmax c d 226 | 227 | recurse = clipCubicBezier mini maxi 228 | 229 | clamper = clampPoint mini maxi 230 | clampedA = clamper a 231 | clampedD = clamper d 232 | 233 | V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi 234 | V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin 235 | 236 | -- BC 237 | -- B X----------X---------X C 238 | -- / ___/ \___ \ 239 | -- / __X------X------X_ \ 240 | -- /___/ ABBC BCCD \___\ 241 | -- AB X/ \X CD 242 | -- / \ 243 | -- / \ 244 | -- / \ 245 | -- A X X D 246 | (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier 247 | 248 | edgeSeparator = vabs (abbcbccd ^-^ mini) ^<^ vabs (abbcbccd ^-^ maxi) 249 | edge = vpartition edgeSeparator mini maxi 250 | m = vpartition (vabs (abbcbccd ^-^ edge) ^< 0.1) edge abbcbccd 251 | 252 | divideCubicBezier :: CubicBezier -> (CubicBezier, CubicBezier) 253 | divideCubicBezier bezier@(CubicBezier a _ _ d) = (left, right) where 254 | left = CubicBezier a ab abbc abbcbccd 255 | right = CubicBezier abbcbccd bccd cd d 256 | (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier 257 | 258 | -- | Will subdivide the bezier from 0 to coeff and coeff to 1 259 | cubicBezierBreakAt :: CubicBezier -> Float 260 | -> (CubicBezier, CubicBezier) 261 | cubicBezierBreakAt (CubicBezier a b c d) val = 262 | (CubicBezier a ab abbc abbcbccd, CubicBezier abbcbccd bccd cd d) 263 | where 264 | ab = lerp val b a 265 | bc = lerp val c b 266 | cd = lerp val d c 267 | 268 | abbc = lerp val bc ab 269 | bccd = lerp val cd bc 270 | abbcbccd = lerp val bccd abbc 271 | 272 | decomposeCubicBeziers :: CubicBezier -> Producer EdgeSample 273 | decomposeCubicBeziers cb@(CubicBezier a b c d) 274 | -- handle case of self closed bezier curve 275 | | not (a `isDistingableFrom` d) && ((a `isDistingableFrom` b) || (a `isDistingableFrom` c)) = 276 | let (l, r) = cubicBezierBreakAt cb 0.5 in 277 | decomposeCubicBeziers l . decomposeCubicBeziers r 278 | decomposeCubicBeziers (CubicBezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy) (V2 dRx dRy)) = 279 | go aRx aRy bRx bRy cRx cRy dRx dRy where 280 | go ax ay _bx _by _cx _cy dx dy cont | insideX && insideY = 281 | let !px = fromIntegral $ min floorAx floorDx 282 | !py = fromIntegral $ min floorAy floorDy 283 | !w = px + 1 - (dx `middle` ax) 284 | !h = dy - ay 285 | in 286 | EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont 287 | where 288 | floorAx, floorAy :: Int 289 | !floorAx = floor ax 290 | !floorAy = floor ay 291 | 292 | !floorDx = floor dx 293 | !floorDy = floor dy 294 | 295 | !insideX = 296 | floorAx == floorDx || ceiling ax == (ceiling dx :: Int) 297 | !insideY = 298 | floorAy == floorDy || ceiling ay == (ceiling dy :: Int) 299 | 300 | 301 | go !ax !ay !bx !by !cx !cy !dx !dy cont = 302 | go ax ay abx aby abbcx abbcy mx my $ 303 | go mx my bccdx bccdy cdx cdy dx dy cont 304 | where 305 | -- BC 306 | -- B X----------X---------X C 307 | -- / ___/ \___ \ 308 | -- / __X------X------X_ \ 309 | -- /___/ ABBC BCCD \___\ 310 | -- AB X/ \X CD 311 | -- / \ 312 | -- / \ 313 | -- / \ 314 | -- A X X D 315 | !abx = ax `middle` bx 316 | !aby = ay `middle` by 317 | !bcx = bx `middle` cx 318 | !bcy = by `middle` cy 319 | !cdx = cx `middle` dx 320 | !cdy = cy `middle` dy 321 | !abbcx = abx `middle` bcx 322 | !abbcy = aby `middle` bcy 323 | !bccdx = bcx `middle` cdx 324 | !bccdy = bcy `middle` cdy 325 | 326 | !abbcbccdx = abbcx `middle` bccdx 327 | !abbcbccdy = abbcy `middle` bccdy 328 | 329 | !mx | abs (abbcbccdx - mini) < 0.1 = mini 330 | | abs (abbcbccdx - maxi) < 0.1 = maxi 331 | | otherwise = abbcbccdx 332 | where !mini = fromIntegral (floor abbcbccdx :: Int) 333 | !maxi = fromIntegral (ceiling abbcbccdx :: Int) 334 | 335 | !my | abs (abbcbccdy - mini) < 0.1 = mini 336 | | abs (abbcbccdy - maxi) < 0.1 = maxi 337 | | otherwise = abbcbccdy 338 | where !mini = fromIntegral (floor abbcbccdy :: Int) 339 | !maxi = fromIntegral (ceiling abbcbccdy :: Int) 340 | 341 | isCubicBezierPoint :: CubicBezier -> Bool 342 | isCubicBezierPoint (CubicBezier a b c d) = 343 | not $ a `isDistingableFrom` b || 344 | b `isDistingableFrom` c || 345 | c `isDistingableFrom` d 346 | 347 | sanitizeCubicBezier :: CubicBezier -> Container Primitive 348 | sanitizeCubicBezier bezier@(CubicBezier a b c d) 349 | | a `isDistingableFrom` b && 350 | c `isDistingableFrom` d = 351 | pure . CubicBezierPrim $ bezier 352 | | ac `isDistingableFrom` b && 353 | bd `isDistingableFrom` c = 354 | pure . CubicBezierPrim $ bezier 355 | | ac `isDistingableFrom` b = 356 | pure . CubicBezierPrim $ CubicBezier a ac c d 357 | | bd `isDistingableFrom` c = 358 | pure . CubicBezierPrim $ CubicBezier a b bd d 359 | | otherwise = mempty 360 | where ac = a `midPoint` c 361 | bd = a `midPoint` d 362 | 363 | sanitizeCubicBezierFilling :: CubicBezier -> Container Primitive 364 | sanitizeCubicBezierFilling bezier@(CubicBezier a b c d) 365 | | isDegenerate a || isDegenerate b || 366 | isDegenerate c || isDegenerate d = mempty 367 | | otherwise = pure $ CubicBezierPrim bezier 368 | 369 | cubicFromQuadraticBezier :: Bezier -> CubicBezier 370 | cubicFromQuadraticBezier (Bezier p0 p1 p2) = CubicBezier p0 pa pb p2 where 371 | pa = p0 ^+^ (p1 ^-^ p0) ^* (2 / 3) 372 | pb = p2 ^+^ (p1 ^-^ p2) ^* (2 / 3) 373 | 374 | -------------------------------------------------------------------------------- /src/Graphics/Rasterific/Shading.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE ConstraintKinds #-} 6 | module Graphics.Rasterific.Shading 7 | ( transformTextureToFiller 8 | , sampledImageShader 9 | , plotOpaquePixel 10 | , unsafePlotOpaquePixel 11 | ) where 12 | 13 | import Control.Monad.ST( ST ) 14 | import Control.Monad.Primitive( PrimState 15 | -- one day (GHC >= 7.10 ?) 16 | , PrimMonad 17 | ) 18 | import Data.Fixed( mod' ) 19 | import Graphics.Rasterific.Command 20 | import Graphics.Rasterific.BiSampleable 21 | import Graphics.Rasterific.Linear 22 | ( V2( .. ) 23 | , (^-^) 24 | , (^/) 25 | , dot 26 | , norm 27 | ) 28 | 29 | import qualified Data.Vector as V 30 | 31 | import Codec.Picture.Types( Pixel( .. ) 32 | , Image( .. ) 33 | , MutableImage( .. ) 34 | , Pixel8 35 | , PixelRGBA8 36 | , unsafeWritePixelBetweenAt 37 | , readPackedPixelAt 38 | , writePackedPixelAt 39 | ) 40 | 41 | import Graphics.Rasterific.Types( Point 42 | , Vector 43 | , Line( .. ) 44 | , SamplerRepeat( .. ) ) 45 | import Graphics.Rasterific.Transformations 46 | import Graphics.Rasterific.Rasterize 47 | import Graphics.Rasterific.PatchTypes 48 | import Graphics.Rasterific.Compositor( Modulable( .. ) 49 | , ModulablePixel 50 | , RenderablePixel 51 | , compositionAlpha ) 52 | 53 | 54 | data TextureSpaceInfo = TextureSpaceInfo 55 | { _tsStart :: {-# UNPACK #-} !Point 56 | , _tsDelta :: {-# UNPACK #-} !Vector 57 | , _tsCoverage :: {-# UNPACK #-} !Float 58 | , _tsRepeat :: {-# UNPACK #-} !Int 59 | , _tsBaseIndex :: {-# UNPACK #-} !Int 60 | } 61 | deriving (Eq, Show) 62 | 63 | type CoverageFiller m px = 64 | MutableImage (PrimState m) px -> CoverageSpan -> m () 65 | 66 | type Filler m = 67 | TextureSpaceInfo -> m () 68 | 69 | -- | Right now, we must stick to ST, due to the fact that 70 | -- we can't specialize with parameterized monad :( 71 | solidColor :: forall s px . (ModulablePixel px) 72 | => px -> MutableImage s px -> Filler (ST s) 73 | {-# SPECIALIZE solidColor :: PixelRGBA8 -> MutableImage s PixelRGBA8 74 | -> TextureSpaceInfo -> ST s () #-} 75 | {-# SPECIALIZE solidColor :: Pixel8 -> MutableImage s Pixel8 76 | -> TextureSpaceInfo -> ST s () #-} 77 | solidColor color _ tsInfo 78 | | pixelOpacity color == emptyValue || _tsCoverage tsInfo <= 0 = 79 | return () 80 | solidColor color img tsInfo 81 | -- We are in the case fully opaque, so we can 82 | -- just overwrite what was there before 83 | | pixelOpacity color == fullOpacity && _tsCoverage tsInfo >= 1 = 84 | unsafeWritePixelBetweenAt img color (_tsBaseIndex tsInfo) maxi 85 | {-go 0 $ _tsBaseIndex tsInfo-} 86 | where 87 | !fullOpacity = fullValue :: PixelBaseComponent px 88 | !maxi = _tsRepeat tsInfo 89 | 90 | -- We can be transparent, so perform alpha blending. 91 | solidColor color img tsInfo = go 0 $ _tsBaseIndex tsInfo 92 | where 93 | !opacity = pixelOpacity color 94 | !(scanCoverage,_) = clampCoverage $_tsCoverage tsInfo 95 | !(cov, icov) = coverageModulate scanCoverage opacity 96 | !maxi = _tsRepeat tsInfo 97 | !compCount = componentCount (undefined :: px) 98 | 99 | go count _ | count >= maxi = return () 100 | go !count !idx = do 101 | oldPixel <- readPackedPixelAt img idx 102 | writePackedPixelAt img idx 103 | $ compositionAlpha cov icov oldPixel color 104 | go (count + 1) $ idx + compCount 105 | 106 | 107 | -- | Plot a single pixel on the resulting image. 108 | plotOpaquePixel :: forall m px. (ModulablePixel px, PrimMonad m) 109 | => MutableImage (PrimState m) px -> px -> Int -> Int 110 | -> m () 111 | {-# INLINE plotOpaquePixel #-} 112 | plotOpaquePixel img _color x y 113 | | x < 0 || y < 0 || 114 | x >= mutableImageWidth img || y >= mutableImageHeight img = return () 115 | plotOpaquePixel img color x y = do 116 | let !idx = (y * mutableImageWidth img + x) * (componentCount (undefined :: px)) 117 | writePackedPixelAt img idx color 118 | 119 | -- | Plot a single pixel on the resulting image, no bounds check are 120 | -- performed, ensure index is correct! 121 | unsafePlotOpaquePixel :: forall m px. (ModulablePixel px, PrimMonad m) 122 | => MutableImage (PrimState m) px -> px -> Int -> Int 123 | -> m () 124 | {-# INLINE unsafePlotOpaquePixel #-} 125 | unsafePlotOpaquePixel img color x y = do 126 | let !idx = (y * mutableImageWidth img + x) * (componentCount (undefined :: px)) 127 | writePackedPixelAt img idx color 128 | 129 | shaderFiller :: forall s px . (ModulablePixel px) 130 | => ShaderFunction px -> MutableImage s px 131 | -> Filler (ST s) 132 | {-# SPECIALIZE shaderFiller :: ShaderFunction PixelRGBA8 133 | -> MutableImage s PixelRGBA8 134 | -> Filler (ST s) #-} 135 | {-# SPECIALIZE shaderFiller :: ShaderFunction Pixel8 136 | -> MutableImage s Pixel8 137 | -> Filler (ST s) #-} 138 | shaderFiller shader img tsInfo = 139 | go 0 (_tsBaseIndex tsInfo) xStart yStart 140 | where 141 | !(scanCoverage,_) = clampCoverage $_tsCoverage tsInfo 142 | !maxi = _tsRepeat tsInfo 143 | !compCount = componentCount (undefined :: px) 144 | (V2 xStart yStart) = _tsStart tsInfo 145 | (V2 dx dy) = _tsDelta tsInfo 146 | 147 | go count _ _ _ | count >= maxi = return () 148 | go !count !idx !x !y = do 149 | let !color = shader x y 150 | !opacity = pixelOpacity color 151 | (cov, icov) = coverageModulate scanCoverage opacity 152 | oldPixel <- readPackedPixelAt img idx 153 | writePackedPixelAt img idx 154 | $ compositionAlpha cov icov oldPixel color 155 | go (count + 1) (idx + compCount) (x + dx) (y + dy) 156 | 157 | prepareInfoNoTransform :: (Pixel px) 158 | => MutableImage s px -> CoverageSpan 159 | -> TextureSpaceInfo 160 | prepareInfoNoTransform img coverage = TextureSpaceInfo 161 | { _tsStart = V2 (_coverageX coverage) (_coverageY coverage) 162 | , _tsDelta = V2 1 0 163 | , _tsCoverage = _coverageVal coverage 164 | , _tsRepeat = floor $ _coverageLength coverage 165 | , _tsBaseIndex = 166 | mutablePixelBaseIndex img (floor $ _coverageX coverage) 167 | (floor $ _coverageY coverage) 168 | } 169 | 170 | prepareInfo :: (Pixel px) 171 | => Maybe Transformation -> MutableImage s px -> CoverageSpan 172 | -> TextureSpaceInfo 173 | prepareInfo Nothing img covSpan = prepareInfoNoTransform img covSpan 174 | prepareInfo (Just t) img covSpan = TextureSpaceInfo 175 | { _tsStart = applyTransformation t 176 | $ V2 (_coverageX covSpan) (_coverageY covSpan) 177 | , _tsDelta = applyVectorTransformation t $ V2 1 0 178 | , _tsCoverage = _coverageVal covSpan 179 | , _tsRepeat = floor $ _coverageLength covSpan 180 | , _tsBaseIndex = 181 | mutablePixelBaseIndex img (floor $ _coverageX covSpan) 182 | (floor $ _coverageY covSpan) 183 | } 184 | 185 | combineTransform :: Maybe Transformation -> Transformation 186 | -> Maybe Transformation 187 | combineTransform Nothing a = Just a 188 | combineTransform (Just v) a = Just $ v <> a 189 | 190 | withTrans :: Maybe Transformation -> ShaderFunction px 191 | -> ShaderFunction px 192 | withTrans Nothing shader = shader 193 | withTrans (Just v) shader = \x y -> 194 | let V2 x' y' = applyTransformation v (V2 x y) in 195 | shader x' y' 196 | 197 | -- | The intent of shader texture is to provide ease of implementation 198 | -- If possible providing a custom filler will be more efficient, 199 | -- like already done for the solid colors. 200 | shaderOfTexture :: forall px . RenderablePixel px 201 | => Maybe Transformation -> SamplerRepeat -> Texture px 202 | -> ShaderFunction px 203 | {-# SPECIALIZE 204 | shaderOfTexture :: Maybe Transformation -> SamplerRepeat -> Texture PixelRGBA8 205 | -> ShaderFunction PixelRGBA8 #-} 206 | {-# SPECIALIZE 207 | shaderOfTexture :: Maybe Transformation -> SamplerRepeat -> Texture Pixel8 208 | -> ShaderFunction Pixel8 #-} 209 | shaderOfTexture _ _ (SolidTexture px) = \_ _ -> px 210 | shaderOfTexture _ _ (MeshPatchTexture _ _) = error "MeshPatch should be precomputed" 211 | shaderOfTexture trans sampling (LinearGradientTexture grad (Line a b)) = 212 | withTrans trans $ linearGradientShader grad a b sampling 213 | shaderOfTexture trans sampling (RadialGradientTexture grad center radius) = 214 | withTrans trans $ radialGradientShader grad center radius sampling 215 | shaderOfTexture trans sampling (RadialGradientWithFocusTexture grad center 216 | radius focus) = 217 | withTrans trans 218 | $ radialGradientWithFocusShader grad center radius focus 219 | sampling 220 | shaderOfTexture trans _ (WithSampler sampler sub) = 221 | shaderOfTexture trans sampler sub 222 | shaderOfTexture trans sampling (WithTextureTransform transform sub) = 223 | shaderOfTexture (combineTransform trans transform) sampling sub 224 | shaderOfTexture trans sampling (SampledTexture img) = 225 | withTrans trans $ sampledImageShader img sampling 226 | shaderOfTexture trans _ (ShaderTexture func) = 227 | withTrans trans func 228 | shaderOfTexture trans _ (RawTexture img) = 229 | withTrans trans $ imageShader img 230 | shaderOfTexture trans _sampling (PatternTexture _ _ _ _ img) = 231 | shaderOfTexture trans SamplerRepeat $ SampledTexture img 232 | shaderOfTexture trans sampling (ModulateTexture texture modulation) = 233 | modulateTexture (shaderOfTexture trans sampling texture) 234 | (shaderOfTexture trans sampling modulation) 235 | shaderOfTexture trans sampling (AlphaModulateTexture texture modulation) = 236 | alphaModulateTexture 237 | (shaderOfTexture trans sampling texture) 238 | (shaderOfTexture trans sampling modulation) 239 | 240 | 241 | -- | This function will interpret the texture description, helping 242 | -- prepare and optimize the real calculation 243 | transformTextureToFiller 244 | :: (RenderablePixel px) 245 | => (Maybe Transformation -> Int -> Int -> PatchInterpolation -> MeshPatch px -> Image px) 246 | -> Texture px -> CoverageFiller (ST s) px 247 | transformTextureToFiller renderMesh = go Nothing SamplerPad 248 | where 249 | go _ _ (SolidTexture px) = 250 | \img -> solidColor px img . prepareInfoNoTransform img 251 | go trans sampling (WithTextureTransform transform sub) = 252 | go (combineTransform trans transform) sampling sub 253 | go trans _ (WithSampler sampler sub) = 254 | go trans sampler sub 255 | go trans sampling (MeshPatchTexture i m) = \img -> 256 | let newImg = renderMesh 257 | trans 258 | (mutableImageWidth img) 259 | (mutableImageHeight img) 260 | i 261 | m 262 | in 263 | go Nothing sampling (RawTexture newImg) img 264 | 265 | go trans sampling tex = 266 | \img -> shaderFiller shader img . prepareInfo trans img 267 | where shader = shaderOfTexture Nothing sampling tex 268 | 269 | type GradientArray px = V.Vector (Float, px) 270 | 271 | repeatGradient :: Float -> Float 272 | repeatGradient s = s - fromIntegral (floor s :: Int) 273 | 274 | reflectGradient :: Float -> Float 275 | reflectGradient s = 276 | abs (abs (s - 1) `mod'` 2 - 1) 277 | 278 | gradientColorAt :: ModulablePixel px 279 | => GradientArray px -> Float -> px 280 | {-# SPECIALIZE 281 | gradientColorAt :: GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-} 282 | {-# SPECIALIZE 283 | gradientColorAt :: GradientArray Pixel8 -> Float -> Pixel8 #-} 284 | gradientColorAt grad at 285 | | at <= 0 = snd $ V.head grad 286 | | at >= 1.0 = snd $ V.last grad 287 | | otherwise = go (0, snd $ V.head grad) 0 288 | where 289 | !maxi = V.length grad 290 | go (prevCoeff, prevValue) ix 291 | | ix >= maxi = snd $ V.last grad 292 | | at < coeff = mixWith (\_ -> alphaOver cov icov) prevValue px 293 | | otherwise = go value $ ix + 1 294 | where value@(coeff, px) = grad `V.unsafeIndex` ix 295 | zeroToOne = (at - prevCoeff) / (coeff - prevCoeff) 296 | (cov, icov) = clampCoverage zeroToOne 297 | 298 | gradientColorAtRepeat :: ModulablePixel px 299 | => SamplerRepeat -> GradientArray px -> Float -> px 300 | {-# SPECIALIZE INLINE 301 | gradientColorAtRepeat :: 302 | SamplerRepeat -> GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-} 303 | {-# SPECIALIZE INLINE 304 | gradientColorAtRepeat :: 305 | SamplerRepeat -> GradientArray Pixel8 -> Float -> Pixel8 #-} 306 | gradientColorAtRepeat SamplerPad grad = gradientColorAt grad 307 | gradientColorAtRepeat SamplerRepeat grad = 308 | gradientColorAt grad . repeatGradient 309 | gradientColorAtRepeat SamplerReflect grad = 310 | gradientColorAt grad . reflectGradient 311 | 312 | linearGradientShader :: ModulablePixel px 313 | => Gradient px -- ^ Gradient description. 314 | -> Point -- ^ Linear gradient start point. 315 | -> Point -- ^ Linear gradient end point. 316 | -> SamplerRepeat 317 | -> ShaderFunction px 318 | {-# SPECIALIZE linearGradientShader 319 | :: Gradient PixelRGBA8 -> Point -> Point -> SamplerRepeat 320 | -> ShaderFunction PixelRGBA8 #-} 321 | {-# SPECIALIZE linearGradientShader 322 | :: Gradient Pixel8 -> Point -> Point -> SamplerRepeat 323 | -> ShaderFunction Pixel8 #-} 324 | linearGradientShader gradient start end repeating = 325 | \x y -> colorAt $ (V2 x y `dot` d) - s00 326 | where 327 | colorAt = gradientColorAtRepeat repeating gradArray 328 | gradArray = V.fromList gradient 329 | vector = end ^-^ start 330 | d = vector ^/ (vector `dot` vector) 331 | s00 = start `dot` d 332 | 333 | -- | Use another image as a texture for the filling. 334 | -- This texture use the "nearest" filtering, AKA no 335 | -- filtering at all. 336 | imageShader :: forall px. (Pixel px) => Image px -> ShaderFunction px 337 | {-# SPECIALIZE 338 | imageShader :: Image PixelRGBA8 -> ShaderFunction PixelRGBA8 #-} 339 | {-# SPECIALIZE 340 | imageShader :: Image Pixel8 -> ShaderFunction Pixel8 #-} 341 | imageShader img x y = 342 | unsafePixelAt rawData $ (clampedY * w + clampedX) * compCount 343 | where 344 | clampedX = min (w - 1) . max 0 $ floor x 345 | clampedY = min (h - 1) . max 0 $ floor y 346 | !compCount = componentCount (undefined :: px) 347 | !w = imageWidth img 348 | !h = imageHeight img 349 | !rawData = imageData img 350 | 351 | radialGradientShader :: ModulablePixel px 352 | => Gradient px -- ^ Gradient description 353 | -> Point -- ^ Radial gradient center 354 | -> Float -- ^ Radial gradient radius 355 | -> SamplerRepeat 356 | -> ShaderFunction px 357 | {-# SPECIALIZE 358 | radialGradientShader 359 | :: Gradient PixelRGBA8 -> Point -> Float -> SamplerRepeat 360 | -> ShaderFunction PixelRGBA8 #-} 361 | {-# SPECIALIZE 362 | radialGradientShader 363 | :: Gradient Pixel8 -> Point -> Float -> SamplerRepeat 364 | -> ShaderFunction Pixel8 #-} 365 | radialGradientShader gradient center radius repeating = 366 | \x y -> colorAt $ norm (V2 x y ^-^ center) / radius 367 | where 368 | !colorAt = gradientColorAtRepeat repeating gradArray 369 | !gradArray = V.fromList gradient 370 | 371 | radialGradientWithFocusShader 372 | :: ModulablePixel px 373 | => Gradient px -- ^ Gradient description 374 | -> Point -- ^ Radial gradient center 375 | -> Float -- ^ Radial gradient radius 376 | -> Point -- ^ Radial gradient focus point 377 | -> SamplerRepeat 378 | -> ShaderFunction px 379 | {-# SPECIALIZE 380 | radialGradientWithFocusShader 381 | :: Gradient PixelRGBA8 -> Point -> Float -> Point 382 | -> SamplerRepeat -> ShaderFunction PixelRGBA8 #-} 383 | {-# SPECIALIZE 384 | radialGradientWithFocusShader 385 | :: Gradient Pixel8 -> Point -> Float -> Point 386 | -> SamplerRepeat -> ShaderFunction Pixel8 #-} 387 | radialGradientWithFocusShader gradient center radius focusScreen repeating = 388 | \x y -> colorAt . go $ V2 x y ^-^ center 389 | where 390 | focus@(V2 origFocusX origFocusY) = focusScreen ^-^ center 391 | colorAt = gradientColorAtRepeat repeating gradArray 392 | gradArray = V.fromList gradient 393 | radiusSquared = radius * radius 394 | dist = sqrt $ focus `dot` focus 395 | clampedFocus@(V2 focusX focusY) 396 | | dist <= r = focus 397 | | otherwise = V2 (r * cos a) (r * sin a) 398 | where a = atan2 origFocusY origFocusX 399 | r = radius * 0.99 400 | trivial = sqrt $ radiusSquared - origFocusX * origFocusX 401 | 402 | solutionOf (V2 x y) | x == focusX = 403 | V2 focusX (if y > focusY then trivial else negate trivial) 404 | solutionOf (V2 x y) = V2 xSolution $ slope * xSolution + yint 405 | where 406 | slope = (y - focusY) / (x - focusX) 407 | yint = y - (slope * x) 408 | 409 | a = slope * slope + 1 410 | b = 2 * slope * yint 411 | c = yint * yint - radiusSquared 412 | det = sqrt $ b * b - 4 * a * c 413 | xSolution = (-b + (if x < focusX then negate det else det)) / (2 * a) 414 | 415 | go pos = sqrt $ curToFocus / distSquared 416 | where 417 | solution = solutionOf pos ^-^ clampedFocus 418 | toFocus = pos ^-^ clampedFocus 419 | distSquared = solution `dot` solution 420 | curToFocus = toFocus `dot` toFocus 421 | 422 | -- | Perform a multiplication operation between a full color texture 423 | -- and a greyscale one, used for clip-path implementation. 424 | modulateTexture :: ModulablePixel px 425 | => ShaderFunction px 426 | -> ShaderFunction (PixelBaseComponent px) 427 | -> ShaderFunction px 428 | {-# INLINE modulateTexture #-} 429 | modulateTexture fullTexture modulator x y = 430 | colorMap (modulate $ modulator x y) $ fullTexture x y 431 | 432 | -- | Perform a multiplication operation between a full color texture 433 | -- and a greyscale one, used for clip-path implementation. 434 | alphaModulateTexture :: ModulablePixel px 435 | => ShaderFunction px 436 | -> ShaderFunction (PixelBaseComponent px) 437 | -> ShaderFunction px 438 | {-# INLINE alphaModulateTexture #-} 439 | alphaModulateTexture fullTexture modulator x y = 440 | let px = fullTexture x y in 441 | mixWithAlpha (\_ _ a -> a) (\_ _ -> modulator x y) px px 442 | 443 | --------------------------------------------------------------------------------