Rasterific 0.7.1 → 0.7.2.1
raw patch · 30 files changed
+5635/−5661 lines, 30 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Graphics.Rasterific.BiSampleable: sampledImageShader :: forall px. RenderablePixel px => Image px -> SamplerRepeat -> ShaderFunction px
+ Graphics.Rasterific.Immediate: meshToImage :: forall px. (RenderablePixel px) => Maybe Transformation -> Int -> Int -> PatchInterpolation -> MeshPatch px -> Image px
Files
- Rasterific.cabal +3/−3
- changelog +11/−0
- docimages/logo.png binary
- docimages/sampled_texture_reflect.png binary
- docimages/strokize_dashed_path.png binary
- exec-src/docImageGenerator.hs +0/−7
- src/Graphics/Rasterific.hs +3/−8
- src/Graphics/Rasterific/BiSampleable.hs +148/−91
- src/Graphics/Rasterific/Command.hs +221/−226
- src/Graphics/Rasterific/ComplexPrimitive.hs +112/−93
- src/Graphics/Rasterific/Compositor.hs +211/−211
- src/Graphics/Rasterific/CubicBezier.hs +362/−368
- src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs +1/−1
- src/Graphics/Rasterific/Immediate.hs +305/−258
- src/Graphics/Rasterific/Lenses.hs +140/−146
- src/Graphics/Rasterific/Line.hs +173/−179
- src/Graphics/Rasterific/Linear.hs +409/−416
- src/Graphics/Rasterific/MicroPdf.hs +1144/−1156
- src/Graphics/Rasterific/MiniLens.hs +89/−100
- src/Graphics/Rasterific/Operators.hs +160/−164
- src/Graphics/Rasterific/Patch.hs +0/−6
- src/Graphics/Rasterific/PathWalker.hs +122/−128
- src/Graphics/Rasterific/PlaneBoundable.hs +79/−87
- src/Graphics/Rasterific/QuadraticBezier.hs +292/−297
- src/Graphics/Rasterific/QuadraticFormula.hs +49/−54
- src/Graphics/Rasterific/Rasterize.hs +92/−97
- src/Graphics/Rasterific/Shading.hs +443/−482
- src/Graphics/Rasterific/StrokeInternal.hs +299/−306
- src/Graphics/Rasterific/Transformations.hs +185/−189
- src/Graphics/Rasterific/Types.hs +582/−588
Rasterific.cabal view
@@ -1,7 +1,7 @@ -- Initial Rasterific.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ name: Rasterific -version: 0.7.1 +version: 0.7.2.1 synopsis: A pure haskell drawing engine. -- A longer description of the package. description: @@ -40,7 +40,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Rasterific.git - Tag: v0.7.1 + Tag: v0.7.2.1 flag embed_linear description: Embed a reduced version of Linear avoiding a (huge) dep @@ -82,7 +82,7 @@ ghc-options: -O3 -Wall -- -ddump-simpl -ddump-to-file -dsuppress-module-prefixes -dsuppress-uniques default-language: Haskell2010 - build-depends: base >= 4.5 && < 5 + build-depends: base >= 4.8 && < 5 , free >= 4.7 , JuicyPixels >= 3.2 , FontyFruity >= 0.5.3.2 && < 0.6
changelog view
@@ -1,6 +1,17 @@ Change log ========== +v0.7.2.1 +-------- + + * Fix: sampling empty image + +v0.7.2 +------ + + * Fix: handling infinity/NaN in geometry helpers + * Enhancement: better grandient mesh as texture handling. + v0.7.1 ------
docimages/logo.png view
binary file changed (21143 → 20436 bytes)
docimages/sampled_texture_reflect.png view
binary file changed (64952 → 64929 bytes)
docimages/strokize_dashed_path.png view
binary file changed (10104 → 10031 bytes)
exec-src/docImageGenerator.hs view
@@ -1,10 +1,3 @@-{-# LANGUAGE CPP #-} - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>), (<$>) ) -#endif - - import Control.Monad( forM_ ) import Control.Monad.ST( runST ) import Data.Monoid( (<>) )
src/Graphics/Rasterific.hs view
@@ -5,7 +5,6 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -- | Main module of Rasterific, an Haskell rasterization engine. -- @@ -145,12 +144,6 @@ , dumpDrawing ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>) ) -import Data.Foldable( foldMap ) -import Data.Monoid( Monoid( .. ) ) -#endif - import Data.Monoid( (<>) ) import Control.Monad.Free( Free( .. ), liftF ) @@ -507,6 +500,7 @@ cacheDrawing maxWidth maxHeight dpi sub = cacheOrders Nothing $ drawOrdersOfDrawing maxWidth maxHeight dpi emptyPx sub +{- preComputeTexture :: (RenderablePixel px) => Int -> Int -> Texture px -> Texture px preComputeTexture w h = go where @@ -526,6 +520,7 @@ AlphaModulateTexture i m -> AlphaModulateTexture (go i) (go m) MeshPatchTexture i m -> RawTexture $ renderDrawing w h emptyPx $ renderMeshPatch i m +-- -} -- | Transform a drawing into a serie of low-level drawing orders. drawOrdersOfDrawing @@ -679,7 +674,7 @@ where prim' = listOfContainer $ strokize w j cap prims go ctxt (Free (SetTexture tx sub next)) rest = - go (ctxt { currentTexture = preComputeTexture width height tx }) (fromF sub) $ + go (ctxt { currentTexture = tx }) (fromF sub) $ go ctxt next rest go ctxt (Free (DashedStroke o d w j cap prims next)) rest =
src/Graphics/Rasterific/BiSampleable.hs view
@@ -1,91 +1,148 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FunctionalDependencies #-}--- | Module to describe bi-sampleable types-module Graphics.Rasterific.BiSampleable- ( BiSampleable( .. )- , bilinearInterpolation- ) where--import Codec.Picture( PixelRGBA8( .. ) )--import Graphics.Rasterific.Linear-import Graphics.Rasterific.Types-import Graphics.Rasterific.Compositor-import Graphics.Rasterific.Shading-import Graphics.Rasterific.PatchTypes-import Graphics.Rasterific.Transformations--import Codec.Picture( Pixel( .. ) )---- | Interpolate a 2D point in a given type-class BiSampleable sampled px | sampled -> px where- -- | The interpolation function- interpolate :: sampled -> Float -> Float -> px---- | Basic bilinear interpolator-instance (Pixel px, Modulable (PixelBaseComponent px))- => BiSampleable (ParametricValues px) px where- {-# INLINE interpolate #-}- interpolate = bilinearPixelInterpolation---- | Bicubic interpolator-instance ( InterpolablePixel px- , Num (Holder px Float)- ) => BiSampleable (CubicCoefficient px) px where- {-# INLINE interpolate #-}- interpolate = bicubicInterpolation---- | Bilinear interpolation of an image-instance BiSampleable (ImageMesh PixelRGBA8) PixelRGBA8 where- {-# INLINE interpolate #-}- interpolate imesh xb yb = sampledImageShader (_meshImage imesh) SamplerPad x y- where (V2 x y) = applyTransformation (_meshTransform imesh) (V2 xb yb)--bilinearPixelInterpolation :: (Pixel px, Modulable (PixelBaseComponent px))- => ParametricValues px -> Float -> Float -> px-{-# SPECIALIZE INLINE- bilinearPixelInterpolation :: ParametricValues PixelRGBA8 -> Float -> Float -> PixelRGBA8- #-}-bilinearPixelInterpolation (ParametricValues { .. }) !dx !dy = - mixWith (const $ alphaOver covY icovY)- (mixWith (const $ alphaOver covX icovX) _northValue _eastValue)- (mixWith (const $ alphaOver covX icovX) _westValue _southValue)- where- (!covX, !icovX) = clampCoverage dx- (!covY, !icovY) = clampCoverage dy--bilinearInterpolation :: InterpolablePixel px- => ParametricValues px -> Float -> Float -> px-{-# INLINE bilinearInterpolation #-}-bilinearInterpolation ParametricValues { .. } u v = fromFloatPixel $ lerp v uBottom uTop where- -- The arguments are flipped, because the lerp function from Linear is...- -- inversed in u v- !uTop = lerp u (toFloatPixel _eastValue) (toFloatPixel _northValue)- !uBottom = lerp u (toFloatPixel _southValue) (toFloatPixel _westValue)---bicubicInterpolation :: forall px . (InterpolablePixel px, Num (Holder px Float))- => CubicCoefficient px -> Float -> Float -> px-bicubicInterpolation params x y =- fromFloatPixel . fmap clamp $ af ^+^ bf ^+^ cf ^+^ df- where- ParametricValues a b c d = getCubicCoefficients params- maxi = maxRepresentable (Proxy :: Proxy px)- clamp = max 0 . min maxi- xv, vy, vyy, vyyy :: V4 Float- xv = V4 1 x (x*x) (x*x*x)- vy = xv ^* y- vyy = vy ^* y- vyyy = vyy ^* y-- v1 ^^*^ v2 = (^*) <$> v1 <*> v2-- V4 af bf cf df = (a ^^*^ xv) ^+^ (b ^^*^ vy) ^+^ (c ^^*^ vyy) ^+^ (d ^^*^ vyyy)-+{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +-- | Module to describe bi-sampleable types +module Graphics.Rasterific.BiSampleable + ( BiSampleable( .. ) + , bilinearInterpolation + , sampledImageShader + ) where + +import Data.Fixed( mod' ) +import Codec.Picture + ( Image( .. ) + , Pixel8 + , Pixel( .. ) + , PixelRGBA8( .. ) ) + +import Graphics.Rasterific.Linear +import Graphics.Rasterific.Types +import Graphics.Rasterific.Compositor +import Graphics.Rasterific.Command +import Graphics.Rasterific.PatchTypes +import Graphics.Rasterific.Transformations + +-- | Interpolate a 2D point in a given type +class BiSampleable sampled px | sampled -> px where + -- | The interpolation function + interpolate :: sampled -> Float -> Float -> px + +-- | Basic bilinear interpolator +instance (Pixel px, Modulable (PixelBaseComponent px)) + => BiSampleable (ParametricValues px) px where + {-# INLINE interpolate #-} + interpolate = bilinearPixelInterpolation + +-- | Bicubic interpolator +instance ( InterpolablePixel px + , Num (Holder px Float) + ) => BiSampleable (CubicCoefficient px) px where + {-# INLINE interpolate #-} + interpolate = bicubicInterpolation + +-- | Bilinear interpolation of an image +instance BiSampleable (ImageMesh PixelRGBA8) PixelRGBA8 where + {-# INLINE interpolate #-} + interpolate imesh xb yb = sampledImageShader (_meshImage imesh) SamplerPad x y + where (V2 x y) = applyTransformation (_meshTransform imesh) (V2 xb yb) + +-- | Use another image as a texture for the filling. +-- Contrary to `imageTexture`, this function perform a bilinear +-- filtering on the texture. +-- +sampledImageShader :: forall px. RenderablePixel px + => Image px -> SamplerRepeat -> ShaderFunction px +{-# SPECIALIZE + sampledImageShader :: Image Pixel8 -> SamplerRepeat + -> ShaderFunction Pixel8 #-} +{-# SPECIALIZE + sampledImageShader :: Image PixelRGBA8 -> SamplerRepeat + -> ShaderFunction PixelRGBA8 #-} +sampledImageShader img _ _ _ + | imageWidth img == 0 || imageHeight img == 0 = emptyPx +sampledImageShader img sampling x y = + (at px py `interpX` at pxn py) + `interpY` + (at px pyn `interpX` at pxn pyn) + where + coordSampler SamplerPad maxi v = min (maxi - 1) . max 0 $ floor v + coordSampler SamplerReflect maxi v = + floor $ abs (abs (v - maxif - 1) `mod'` (2 * maxif) - maxif - 1) + where maxif = fromIntegral maxi + coordSampler SamplerRepeat maxi v = floor v `mod` maxi + + w = fromIntegral $ imageWidth img + h = fromIntegral $ imageHeight img + + clampedX = coordSampler sampling w + clampedY = coordSampler sampling h + + px = clampedX x + pxn = clampedX $ x + 1 + py = clampedY y + pyn = clampedY $ y + 1 + + dx, dy :: Float + !dx = x - fromIntegral (floor x :: Int) + !dy = y - fromIntegral (floor y :: Int) + + at :: Int -> Int -> px + at !xx !yy = + unsafePixelAt rawData $ (yy * w + xx) * compCount + + (covX, icovX) = clampCoverage dx + (covY, icovY) = clampCoverage dy + + interpX = mixWith (const $ alphaOver covX icovX) + interpY = mixWith (const $ alphaOver covY icovY) + + compCount = componentCount (undefined :: px) + rawData = imageData img + +bilinearPixelInterpolation :: (Pixel px, Modulable (PixelBaseComponent px)) + => ParametricValues px -> Float -> Float -> px +{-# SPECIALIZE INLINE + bilinearPixelInterpolation :: ParametricValues PixelRGBA8 -> Float -> Float -> PixelRGBA8 + #-} +bilinearPixelInterpolation (ParametricValues { .. }) !dx !dy = + mixWith (const $ alphaOver covY icovY) + (mixWith (const $ alphaOver covX icovX) _northValue _eastValue) + (mixWith (const $ alphaOver covX icovX) _westValue _southValue) + where + (!covX, !icovX) = clampCoverage dx + (!covY, !icovY) = clampCoverage dy + +bilinearInterpolation :: InterpolablePixel px + => ParametricValues px -> Float -> Float -> px +{-# INLINE bilinearInterpolation #-} +bilinearInterpolation ParametricValues { .. } u v = fromFloatPixel $ lerp v uBottom uTop where + -- The arguments are flipped, because the lerp function from Linear is... + -- inversed in u v + !uTop = lerp u (toFloatPixel _eastValue) (toFloatPixel _northValue) + !uBottom = lerp u (toFloatPixel _southValue) (toFloatPixel _westValue) + + +bicubicInterpolation :: forall px . (InterpolablePixel px, Num (Holder px Float)) + => CubicCoefficient px -> Float -> Float -> px +bicubicInterpolation params x y = + fromFloatPixel . fmap clamp $ af ^+^ bf ^+^ cf ^+^ df + where + ParametricValues a b c d = getCubicCoefficients params + maxi = maxRepresentable (Proxy :: Proxy px) + clamp = max 0 . min maxi + xv, vy, vyy, vyyy :: V4 Float + xv = V4 1 x (x*x) (x*x*x) + vy = xv ^* y + vyy = vy ^* y + vyyy = vyy ^* y + + v1 ^^*^ v2 = (^*) <$> v1 <*> v2 + + V4 af bf cf df = (a ^^*^ xv) ^+^ (b ^^*^ vy) ^+^ (c ^^*^ vyy) ^+^ (d ^^*^ vyyy) +
src/Graphics/Rasterific/Command.hs view
@@ -1,226 +1,221 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE CPP #-}-module Graphics.Rasterific.Command ( Drawing- , DrawCommand( .. )- , DrawContext- , TextRange( .. )- , dumpDrawing- , Texture( .. )- , Gradient- , ShaderFunction- , ImageTransformer- , dumpTexture- ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid( Monoid( .. ) )-#endif--import Control.Monad.ST( ST )-import Control.Monad.State( StateT )-import Control.Monad.Primitive( PrimState )-import Control.Monad.Free( Free( .. ), liftF )-import Control.Monad.Free.Church( F, fromF )-import Codec.Picture.Types( Image, Pixel( .. ), Pixel8 )--import Codec.Picture.Types( MutableImage )-import Graphics.Rasterific.Types-import Graphics.Rasterific.Transformations-import Graphics.Rasterific.PatchTypes--import Graphics.Text.TrueType( Font, PointSize )---- | Monad used to record the drawing actions.-type Drawing px = F (DrawCommand px)---- | Monad used to describe the drawing context.-type DrawContext m px =- StateT (MutableImage (PrimState m) px) m---- | Structure defining how to render a text range-data TextRange px = TextRange- { _textFont :: Font -- ^ Font used during the rendering- , _textSize :: PointSize -- ^ Size of the text (in pixels)- , _text :: String -- ^ Text to draw- -- | Texture to use for drawing, if Nothing, the currently- -- active texture is used.- , _textTexture :: Maybe (Texture px)- }--type ShaderFunction px = Float -> Float -> px--type ImageTransformer px = Int -> Int -> px -> px---- | A gradient definition is just a list of stop--- and pixel values. For instance for a simple gradient--- of black to white, the finition would be :------ > [(0, PixelRGBA8 0 0 0 255), (1, PixelRGBA8 255 255 255 255)]--- --- the first stop value must be zero and the last, one.----type Gradient px = [(Float, px)]---- | Reification of texture type-data Texture (px :: *)- = SolidTexture !px- | LinearGradientTexture !(Gradient px) !Line - | RadialGradientTexture !(Gradient px) !Point !Float- | RadialGradientWithFocusTexture !(Gradient px) !Point !Float !Point- | WithSampler !SamplerRepeat (Texture px)- | WithTextureTransform !Transformation (Texture px)- | SampledTexture !(Image px)- | RawTexture !(Image px)- | ShaderTexture !(ShaderFunction px)- | ModulateTexture (Texture px) (Texture (PixelBaseComponent px))- | AlphaModulateTexture (Texture px) (Texture (PixelBaseComponent px))- | PatternTexture !Int !Int !px (Drawing px ()) (Image px)- | MeshPatchTexture !PatchInterpolation !(MeshPatch px)---data DrawCommand px next- = Fill FillMethod [Primitive] next- | CustomRender (forall s. DrawContext (ST s) px ()) next- | MeshPatchRender !PatchInterpolation (MeshPatch px) next- | Stroke Float Join (Cap, Cap) [Primitive] next- | DashedStroke Float DashPattern Float Join (Cap, Cap) [Primitive] next- | TextFill Point [TextRange px] next- | SetTexture (Texture px)- (Drawing px ()) next- | WithGlobalOpacity (PixelBaseComponent px) (Drawing px ()) next- | WithImageEffect (Image px -> ImageTransformer px) (Drawing px ()) next- | WithCliping (forall innerPixel. Drawing innerPixel ())- (Drawing px ()) next- | WithTransform Transformation (Drawing px ()) next- | WithPathOrientation Path Float (Drawing px ()) next---- | This function will spit out drawing instructions to--- help debugging.------ The outputted code looks like Haskell, but there is no--- guarantee that it is compilable.-dumpDrawing :: ( Show px- , Show (PixelBaseComponent px)- , PixelBaseComponent (PixelBaseComponent px)- ~ (PixelBaseComponent px)-- ) => Drawing px () -> String-dumpDrawing = go . fromF where- go ::- ( Show px- , Show (PixelBaseComponent px)- , PixelBaseComponent (PixelBaseComponent px)- ~ (PixelBaseComponent px)-- ) => Free (DrawCommand px) () -> String- go (Pure ()) = "return ()"- go (Free (MeshPatchRender i m next)) =- "renderMeshPatch (" ++ show i ++ ") (" ++ show m ++ ") >>= " ++ go next- go (Free (CustomRender _r next)) =- "customRender _ >>= " ++ go next- go (Free (WithImageEffect _effect sub next)) =- "withImageEffect ({- fun -}) (" ++ go (fromF sub) ++ ") >>= " ++ go next- go (Free (WithGlobalOpacity opa sub next)) =- "withGlobalOpacity " ++ show opa ++ " (" ++ go (fromF sub) ++ ") >>= " ++ go next- go (Free (WithPathOrientation path point drawing next)) =- "withPathOrientation (" ++ show path ++ ") ("- ++ show point ++ ") ("- ++ go (fromF drawing) ++ ") >>= "- ++ go next- go (Free (Fill _ prims next)) =- "fill " ++ show prims ++ " >>=\n" ++ go next- go (Free (TextFill _ texts next)) =- concat ["-- Text : " ++ _text t ++ "\n" | t <- texts] ++ go next- go (Free (SetTexture tx drawing next)) =- "withTexture (" ++ dumpTexture tx ++ ") (" ++- go (fromF drawing) ++ ") >>=\n" ++ go next- go (Free (DashedStroke o pat w j cap prims next)) =- "dashedStrokeWithOffset "- ++ show o ++ " "- ++ show pat ++ " "- ++ show w ++ " ("- ++ show j ++ ") "- ++ show cap ++ " "- ++ show prims ++ " >>=\n" ++ go next- go (Free (Stroke w j cap prims next)) =- "stroke " ++ show w ++ " ("- ++ show j ++ ") "- ++ show cap ++ " "- ++ show prims ++ " >>=\n" ++ go next- go (Free (WithTransform trans sub next)) =- "withTransform (" ++ show trans ++ ") ("- ++ go (fromF sub) ++ ") >>=\n "- ++ go next- go (Free (WithCliping clipping draw next)) =- "withClipping (" ++ go (fromF $ withTexture clipTexture clipping)- ++ ")\n" ++- " (" ++ go (fromF draw) ++ ")\n >>= " ++- go next- where clipTexture = SolidTexture (0xFF :: Pixel8)- withTexture texture subActions =- liftF $ SetTexture texture subActions ()--dumpTexture :: ( Show px- , Show (PixelBaseComponent px)- , PixelBaseComponent (PixelBaseComponent px)- ~ (PixelBaseComponent px)- ) => Texture px -> String-dumpTexture (SolidTexture px) = "uniformTexture (" ++ show px ++ ")"-dumpTexture (MeshPatchTexture i mpx) = "meshTexture (" ++ show i ++ ") (" ++ show mpx ++ ")"-dumpTexture (LinearGradientTexture grad (Line a b)) =- "linearGradientTexture " ++ show grad ++ " (" ++ show a ++ ") (" ++ show b ++ ")"-dumpTexture (RadialGradientTexture grad p rad) =- "radialGradientTexture " ++ show grad ++ " (" ++ show p ++ ") " ++ show rad-dumpTexture (RadialGradientWithFocusTexture grad center rad focus) =- "radialGradientWithFocusTexture " ++ show grad ++ " (" ++ show center - ++ ") " ++ show rad ++ " (" ++ show focus ++ ")"-dumpTexture (WithSampler sampler sub) =- "withSampler " ++ show sampler ++ " (" ++ dumpTexture sub ++ ")"-dumpTexture (WithTextureTransform trans sub) =- "transformTexture (" ++ show trans ++ ") (" ++ dumpTexture sub ++ ")"-dumpTexture (SampledTexture _) = "sampledImageTexture <IMG>"-dumpTexture (RawTexture _) = "<RAWTEXTURE>"-dumpTexture (ShaderTexture _) = "shaderFunction <FUNCTION>"-dumpTexture (ModulateTexture sub mask) =- "modulateTexture (" ++ dumpTexture sub ++ ") ("- ++ dumpTexture mask ++ ")"-dumpTexture (AlphaModulateTexture sub mask) =- "alphaModulate (" ++ dumpTexture sub ++ ") ("- ++ dumpTexture mask ++ ")"-dumpTexture (PatternTexture w h px sub _) =- "patternTexture " ++ show w ++ " " ++ show h ++ " " ++ show px- ++ " (" ++ dumpDrawing sub ++ ")"---instance Functor (DrawCommand px) where- fmap f (WithImageEffect effect sub next) =- WithImageEffect effect sub $ f next- fmap f (TextFill pos texts next) =- TextFill pos texts $ f next- fmap f (CustomRender m next) =- CustomRender m $ f next- fmap f (WithGlobalOpacity opa sub next) =- WithGlobalOpacity opa sub $ f next- fmap f (Fill method prims next) = Fill method prims $ f next- fmap f (SetTexture t sub next) = SetTexture t sub $ f next- fmap f (WithCliping sub com next) =- WithCliping sub com $ f next- fmap f (Stroke w j caps prims next) =- Stroke w j caps prims $ f next- fmap f (DashedStroke st pat w j caps prims next) =- DashedStroke st pat w j caps prims $ f next- fmap f (WithTransform trans draw next) =- WithTransform trans draw $ f next- fmap f (WithPathOrientation path point draw next) =- WithPathOrientation path point draw $ f next- fmap f (MeshPatchRender i mesh next) =- MeshPatchRender i mesh $ f next--instance Monoid (Drawing px ()) where- mempty = return ()- mappend a b = a >> b-+{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +module Graphics.Rasterific.Command ( Drawing + , DrawCommand( .. ) + , DrawContext + , TextRange( .. ) + , dumpDrawing + , Texture( .. ) + , Gradient + , ShaderFunction + , ImageTransformer + , dumpTexture + ) where + +import Control.Monad.ST( ST ) +import Control.Monad.State( StateT ) +import Control.Monad.Primitive( PrimState ) +import Control.Monad.Free( Free( .. ), liftF ) +import Control.Monad.Free.Church( F, fromF ) +import Codec.Picture.Types( Image, Pixel( .. ), Pixel8 ) + +import Codec.Picture.Types( MutableImage ) +import Graphics.Rasterific.Types +import Graphics.Rasterific.Transformations +import Graphics.Rasterific.PatchTypes + +import Graphics.Text.TrueType( Font, PointSize ) + +-- | Monad used to record the drawing actions. +type Drawing px = F (DrawCommand px) + +-- | Monad used to describe the drawing context. +type DrawContext m px = + StateT (MutableImage (PrimState m) px) m + +-- | Structure defining how to render a text range +data TextRange px = TextRange + { _textFont :: Font -- ^ Font used during the rendering + , _textSize :: PointSize -- ^ Size of the text (in pixels) + , _text :: String -- ^ Text to draw + -- | Texture to use for drawing, if Nothing, the currently + -- active texture is used. + , _textTexture :: Maybe (Texture px) + } + +type ShaderFunction px = Float -> Float -> px + +type ImageTransformer px = Int -> Int -> px -> px + +-- | A gradient definition is just a list of stop +-- and pixel values. For instance for a simple gradient +-- of black to white, the finition would be : +-- +-- > [(0, PixelRGBA8 0 0 0 255), (1, PixelRGBA8 255 255 255 255)] +-- +-- the first stop value must be zero and the last, one. +-- +type Gradient px = [(Float, px)] + +-- | Reification of texture type +data Texture (px :: *) + = SolidTexture !px + | LinearGradientTexture !(Gradient px) !Line + | RadialGradientTexture !(Gradient px) !Point !Float + | RadialGradientWithFocusTexture !(Gradient px) !Point !Float !Point + | WithSampler !SamplerRepeat (Texture px) + | WithTextureTransform !Transformation (Texture px) + | SampledTexture !(Image px) + | RawTexture !(Image px) + | ShaderTexture !(ShaderFunction px) + | ModulateTexture (Texture px) (Texture (PixelBaseComponent px)) + | AlphaModulateTexture (Texture px) (Texture (PixelBaseComponent px)) + | PatternTexture !Int !Int !px (Drawing px ()) (Image px) + | MeshPatchTexture !PatchInterpolation !(MeshPatch px) + + +data DrawCommand px next + = Fill FillMethod [Primitive] next + | CustomRender (forall s. DrawContext (ST s) px ()) next + | MeshPatchRender !PatchInterpolation (MeshPatch px) next + | Stroke Float Join (Cap, Cap) [Primitive] next + | DashedStroke Float DashPattern Float Join (Cap, Cap) [Primitive] next + | TextFill Point [TextRange px] next + | SetTexture (Texture px) + (Drawing px ()) next + | WithGlobalOpacity (PixelBaseComponent px) (Drawing px ()) next + | WithImageEffect (Image px -> ImageTransformer px) (Drawing px ()) next + | WithCliping (forall innerPixel. Drawing innerPixel ()) + (Drawing px ()) next + | WithTransform Transformation (Drawing px ()) next + | WithPathOrientation Path Float (Drawing px ()) next + +-- | This function will spit out drawing instructions to +-- help debugging. +-- +-- The outputted code looks like Haskell, but there is no +-- guarantee that it is compilable. +dumpDrawing :: ( Show px + , Show (PixelBaseComponent px) + , PixelBaseComponent (PixelBaseComponent px) + ~ (PixelBaseComponent px) + + ) => Drawing px () -> String +dumpDrawing = go . fromF where + go :: + ( Show px + , Show (PixelBaseComponent px) + , PixelBaseComponent (PixelBaseComponent px) + ~ (PixelBaseComponent px) + + ) => Free (DrawCommand px) () -> String + go (Pure ()) = "return ()" + go (Free (MeshPatchRender i m next)) = + "renderMeshPatch (" ++ show i ++ ") (" ++ show m ++ ") >>= " ++ go next + go (Free (CustomRender _r next)) = + "customRender _ >>= " ++ go next + go (Free (WithImageEffect _effect sub next)) = + "withImageEffect ({- fun -}) (" ++ go (fromF sub) ++ ") >>= " ++ go next + go (Free (WithGlobalOpacity opa sub next)) = + "withGlobalOpacity " ++ show opa ++ " (" ++ go (fromF sub) ++ ") >>= " ++ go next + go (Free (WithPathOrientation path point drawing next)) = + "withPathOrientation (" ++ show path ++ ") (" + ++ show point ++ ") (" + ++ go (fromF drawing) ++ ") >>= " + ++ go next + go (Free (Fill _ prims next)) = + "fill " ++ show prims ++ " >>=\n" ++ go next + go (Free (TextFill _ texts next)) = + concat ["-- Text : " ++ _text t ++ "\n" | t <- texts] ++ go next + go (Free (SetTexture tx drawing next)) = + "withTexture (" ++ dumpTexture tx ++ ") (" ++ + go (fromF drawing) ++ ") >>=\n" ++ go next + go (Free (DashedStroke o pat w j cap prims next)) = + "dashedStrokeWithOffset " + ++ show o ++ " " + ++ show pat ++ " " + ++ show w ++ " (" + ++ show j ++ ") " + ++ show cap ++ " " + ++ show prims ++ " >>=\n" ++ go next + go (Free (Stroke w j cap prims next)) = + "stroke " ++ show w ++ " (" + ++ show j ++ ") " + ++ show cap ++ " " + ++ show prims ++ " >>=\n" ++ go next + go (Free (WithTransform trans sub next)) = + "withTransform (" ++ show trans ++ ") (" + ++ go (fromF sub) ++ ") >>=\n " + ++ go next + go (Free (WithCliping clipping draw next)) = + "withClipping (" ++ go (fromF $ withTexture clipTexture clipping) + ++ ")\n" ++ + " (" ++ go (fromF draw) ++ ")\n >>= " ++ + go next + where clipTexture = SolidTexture (0xFF :: Pixel8) + withTexture texture subActions = + liftF $ SetTexture texture subActions () + +dumpTexture :: ( Show px + , Show (PixelBaseComponent px) + , PixelBaseComponent (PixelBaseComponent px) + ~ (PixelBaseComponent px) + ) => Texture px -> String +dumpTexture (SolidTexture px) = "uniformTexture (" ++ show px ++ ")" +dumpTexture (MeshPatchTexture i mpx) = "meshTexture (" ++ show i ++ ") (" ++ show mpx ++ ")" +dumpTexture (LinearGradientTexture grad (Line a b)) = + "linearGradientTexture " ++ show grad ++ " (" ++ show a ++ ") (" ++ show b ++ ")" +dumpTexture (RadialGradientTexture grad p rad) = + "radialGradientTexture " ++ show grad ++ " (" ++ show p ++ ") " ++ show rad +dumpTexture (RadialGradientWithFocusTexture grad center rad focus) = + "radialGradientWithFocusTexture " ++ show grad ++ " (" ++ show center + ++ ") " ++ show rad ++ " (" ++ show focus ++ ")" +dumpTexture (WithSampler sampler sub) = + "withSampler " ++ show sampler ++ " (" ++ dumpTexture sub ++ ")" +dumpTexture (WithTextureTransform trans sub) = + "transformTexture (" ++ show trans ++ ") (" ++ dumpTexture sub ++ ")" +dumpTexture (SampledTexture _) = "sampledImageTexture <IMG>" +dumpTexture (RawTexture _) = "<RAWTEXTURE>" +dumpTexture (ShaderTexture _) = "shaderFunction <FUNCTION>" +dumpTexture (ModulateTexture sub mask) = + "modulateTexture (" ++ dumpTexture sub ++ ") (" + ++ dumpTexture mask ++ ")" +dumpTexture (AlphaModulateTexture sub mask) = + "alphaModulate (" ++ dumpTexture sub ++ ") (" + ++ dumpTexture mask ++ ")" +dumpTexture (PatternTexture w h px sub _) = + "patternTexture " ++ show w ++ " " ++ show h ++ " " ++ show px + ++ " (" ++ dumpDrawing sub ++ ")" + + +instance Functor (DrawCommand px) where + fmap f (WithImageEffect effect sub next) = + WithImageEffect effect sub $ f next + fmap f (TextFill pos texts next) = + TextFill pos texts $ f next + fmap f (CustomRender m next) = + CustomRender m $ f next + fmap f (WithGlobalOpacity opa sub next) = + WithGlobalOpacity opa sub $ f next + fmap f (Fill method prims next) = Fill method prims $ f next + fmap f (SetTexture t sub next) = SetTexture t sub $ f next + fmap f (WithCliping sub com next) = + WithCliping sub com $ f next + fmap f (Stroke w j caps prims next) = + Stroke w j caps prims $ f next + fmap f (DashedStroke st pat w j caps prims next) = + DashedStroke st pat w j caps prims $ f next + fmap f (WithTransform trans draw next) = + WithTransform trans draw $ f next + fmap f (WithPathOrientation path point draw next) = + WithPathOrientation path point draw $ f next + fmap f (MeshPatchRender i mesh next) = + MeshPatchRender i mesh $ f next + +instance Monoid (Drawing px ()) where + mempty = return () + mappend a b = a >> b +
src/Graphics/Rasterific/ComplexPrimitive.hs view
@@ -1,93 +1,112 @@-{-# LANGUAGE CPP #-}--- | Provide definition for some higher level objects (only slightly)-module Graphics.Rasterific.ComplexPrimitive( rectangle- , roundedRectangle- , circle- , ellipse- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<$>) )-#endif--import Graphics.Rasterific.Linear( V2( .. ), (^+^), (^*) )-import Graphics.Rasterific.Line-import Graphics.Rasterific.CubicBezier-import Graphics.Rasterific.Types---- | Generate a list of primitive representing a circle.------ > fill $ circle (V2 100 100) 75------ <<docimages/fill_circle.png>>----circle :: Point -- ^ Circle center in pixels- -> Float -- ^ Circle radius in pixels- -> [Primitive]-circle center radius =- CubicBezierPrim . transform mv <$> cubicBezierCircle- where- mv p = (p ^* radius) ^+^ center---- | Generate a list of primitive representing an ellipse.------ > fill $ ellipse (V2 100 100) 75 30------ <<docimages/fill_ellipse.png>>----ellipse :: Point -> Float -> Float -> [Primitive]-ellipse center rx ry =- CubicBezierPrim . transform mv <$> cubicBezierCircle- where- mv (V2 x y) = V2 (x * rx) (y * ry) ^+^ center---- | Generate a list of primitive representing a--- rectangle------ > fill $ rectangle (V2 30 30) 150 100------ <<docimages/fill_rect.png>>----rectangle :: Point -- ^ Corner upper left- -> Float -- ^ Width in pixel- -> Float -- ^ Height in pixel- -> [Primitive]-rectangle p@(V2 px py) w h =- LinePrim <$> lineFromPath- [ p, V2 (px + w) py, V2 (px + w) (py + h), V2 px (py + h), p ]---- | Generate a list of primitive representing a rectangle--- with rounded corner.------ > fill $ roundedRectangle (V2 10 10) 150 150 20 10------ <<docimages/fill_roundedRectangle.png>>----roundedRectangle :: Point -- ^ Corner upper left- -> Float -- ^ Width in pixel- -> Float -- ^ Height in pixel.- -> Float -- ^ Radius along the x axis of the rounded corner. In pixel.- -> Float -- ^ Radius along the y axis of the rounded corner. In pixel.- -> [Primitive]-roundedRectangle (V2 px py) w h rx ry =- [ CubicBezierPrim . transform (^+^ V2 xFar yNear) $ cornerTopR- , LinePrim $ Line (V2 xFar py) (V2 xNear py)- , CubicBezierPrim . transform (^+^ V2 (px + rx) (py + ry)) $ cornerTopL- , LinePrim $ Line (V2 px yNear) (V2 px yFar)- , CubicBezierPrim . transform (^+^ V2 (px + rx) yFar) $ cornerBottomL- , LinePrim $ Line (V2 xNear (py + h)) (V2 xFar (py + h))- , CubicBezierPrim . transform (^+^ V2 xFar yFar) $ cornerBottomR- , LinePrim $ Line (V2 (px + w) yFar) (V2 (px + w) yNear)- ]- where- xNear = px + rx- xFar = px + w - rx-- yNear = py + ry- yFar = py + h - ry-- (cornerBottomR :- cornerTopR :- cornerTopL :- cornerBottomL:_) = transform (\(V2 x y) -> V2 (x * rx) (y * ry)) <$> cubicBezierCircle-+-- | Provide definition for some higher level objects (only slightly) +module Graphics.Rasterific.ComplexPrimitive( rectangle + , roundedRectangle + , circle + , ellipse + ) where + +import Control.Applicative( empty, (<|>) ) +import Control.Exception( throw, ArithException( .. ) ) + +import Graphics.Rasterific.Linear( V2( .. ), (^+^), (^*) ) +import Graphics.Rasterific.Line +import Graphics.Rasterific.CubicBezier +import Graphics.Rasterific.Types + +isCoordValid :: RealFloat a => a -> Maybe ArithException +isCoordValid v + | isInfinite v = pure Overflow + | isNaN v || isDenormalized v = pure Denormal + | otherwise = empty + +isPointValid :: RealFloat a => V2 a -> Maybe ArithException +isPointValid (V2 x y) = isCoordValid x <|> isCoordValid y + +-- | Generate a list of primitive representing a circle. +-- +-- > fill $ circle (V2 100 100) 75 +-- +-- <<docimages/fill_circle.png>> +-- +circle :: Point -- ^ Circle center in pixels + -> Float -- ^ Circle radius in pixels + -> [Primitive] +circle p r + | Just ex <- isCoordValid r <|> isPointValid p = throw ex +circle center radius = + CubicBezierPrim . transform mv <$> cubicBezierCircle + where + mv p = (p ^* radius) ^+^ center + +-- | Generate a list of primitive representing an ellipse. +-- +-- > fill $ ellipse (V2 100 100) 75 30 +-- +-- <<docimages/fill_ellipse.png>> +-- +ellipse :: Point -> Float -> Float -> [Primitive] +ellipse c rx ry + | Just ex <- isCoordValid rx <|> isCoordValid ry <|> isPointValid c = throw ex +ellipse center rx ry = + CubicBezierPrim . transform mv <$> cubicBezierCircle + where + mv (V2 x y) = V2 (x * rx) (y * ry) ^+^ center + +-- | Generate a list of primitive representing a +-- rectangle +-- +-- > fill $ rectangle (V2 30 30) 150 100 +-- +-- <<docimages/fill_rect.png>> +-- +rectangle :: Point -- ^ Corner upper left + -> Float -- ^ Width in pixel + -> Float -- ^ Height in pixel + -> [Primitive] +rectangle p w h + | Just ex <- isCoordValid w <|> isCoordValid h <|> isPointValid p = throw ex +rectangle p@(V2 px py) w h = + LinePrim <$> lineFromPath + [ p, V2 (px + w) py, V2 (px + w) (py + h), V2 px (py + h), p ] + +-- | Generate a list of primitive representing a rectangle +-- with rounded corner. +-- +-- > fill $ roundedRectangle (V2 10 10) 150 150 20 10 +-- +-- <<docimages/fill_roundedRectangle.png>> +-- +roundedRectangle :: Point -- ^ Corner upper left + -> Float -- ^ Width in pixel + -> Float -- ^ Height in pixel. + -> Float -- ^ Radius along the x axis of the rounded corner. In pixel. + -> Float -- ^ Radius along the y axis of the rounded corner. In pixel. + -> [Primitive] +roundedRectangle p w h rx ry + | Just ex <- isCoordValid w + <|> isCoordValid h + <|> isCoordValid rx + <|> isCoordValid ry + <|> isPointValid p = throw ex +roundedRectangle (V2 px py) w h rx ry = + [ CubicBezierPrim . transform (^+^ V2 xFar yNear) $ cornerTopR + , LinePrim $ Line (V2 xFar py) (V2 xNear py) + , CubicBezierPrim . transform (^+^ V2 (px + rx) (py + ry)) $ cornerTopL + , LinePrim $ Line (V2 px yNear) (V2 px yFar) + , CubicBezierPrim . transform (^+^ V2 (px + rx) yFar) $ cornerBottomL + , LinePrim $ Line (V2 xNear (py + h)) (V2 xFar (py + h)) + , CubicBezierPrim . transform (^+^ V2 xFar yFar) $ cornerBottomR + , LinePrim $ Line (V2 (px + w) yFar) (V2 (px + w) yNear) + ] + where + xNear = px + rx + xFar = px + w - rx + + yNear = py + ry + yFar = py + h - ry + + (cornerBottomR : + cornerTopR : + cornerTopL : + cornerBottomL:_) = transform (\(V2 x y) -> V2 (x * rx) (y * ry)) <$> cubicBezierCircle +
src/Graphics/Rasterific/Compositor.hs view
@@ -1,211 +1,211 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}--- | Compositor handle the pixel composition, which--- leads to texture composition.--- Very much a work in progress-module Graphics.Rasterific.Compositor- ( Compositor- , Modulable( .. )- , InterpolablePixel( .. )- , maxDistance- , RenderablePixel- , ModulablePixel- , compositionDestination- , compositionAlpha- , emptyPx- ) where--import Foreign.Storable( Storable )-import Data.Bits( unsafeShiftR )-import Data.Word( Word8, Word32 )--import Codec.Picture.Types- ( Pixel( .. )- , PixelRGB8( .. )- , PixelRGBA8( .. )- , PackeablePixel( .. ) )--import Graphics.Rasterific.Linear-import Graphics.Rasterific.Types--type Compositor px =- PixelBaseComponent px ->- PixelBaseComponent px -> px -> px -> px---- | Used for Coon patch rendering-class ( Applicative (Holder a)- , Functor (Holder a)- , Foldable (Holder a)- , Additive (Holder a) ) => InterpolablePixel a where- type Holder a :: * -> *- toFloatPixel :: a -> Holder a Float- fromFloatPixel :: Holder a Float -> a- maxRepresentable :: Proxy a -> Float--maxDistance :: InterpolablePixel a => a -> a -> Float-maxDistance p1 p2 = maximum $ abs <$> (toFloatPixel p1 ^-^ toFloatPixel p2)--instance InterpolablePixel Float where- type Holder Float = V1- toFloatPixel = V1- fromFloatPixel (V1 f) = f- maxRepresentable Proxy = 1--instance InterpolablePixel Word8 where- type Holder Word8 = V1- toFloatPixel = V1 . fromIntegral- fromFloatPixel (V1 f) = floor f- maxRepresentable Proxy = 255--instance InterpolablePixel PixelRGB8 where- type Holder PixelRGB8 = V3- toFloatPixel (PixelRGB8 r g b) = V3 (to r) (to g) (to b) where to n = fromIntegral n- fromFloatPixel (V3 r g b) = PixelRGB8 (to r) (to g) (to b) where to = floor- maxRepresentable Proxy = 255--instance InterpolablePixel PixelRGBA8 where- type Holder PixelRGBA8 = V4- toFloatPixel (PixelRGBA8 r g b a) = V4 (to r) (to g) (to b) (to a)- where to n = fromIntegral n- fromFloatPixel (V4 r g b a) = PixelRGBA8 (to r) (to g) (to b) (to a)- where to = floor- maxRepresentable Proxy = 255---- | This constraint ensure that a type is a pixel--- and we're allowed to modulate it's color components--- generically.-type ModulablePixel px =- ( Pixel px- , PackeablePixel px- , InterpolablePixel px- , InterpolablePixel (PixelBaseComponent px)- , Storable (PackedRepresentation px)- , Modulable (PixelBaseComponent px))---- | This constraint tells us that pixel component--- must also be pixel and be the "bottom" of component,--- we cannot go further than a PixelBaseComponent level.------ All pixel instances of JuicyPixels should be usable.-type RenderablePixel px =- ( ModulablePixel px- , Pixel (PixelBaseComponent px)- , PackeablePixel (PixelBaseComponent px)- , Num (PackedRepresentation px)- , Num (PackedRepresentation (PixelBaseComponent px))- , Num (Holder px Float)- , Num (Holder (PixelBaseComponent px) Float)- , Storable (PackedRepresentation (PixelBaseComponent px))- , PixelBaseComponent (PixelBaseComponent px)- ~ (PixelBaseComponent px)- )---- | Typeclass intented at pixel value modulation.--- May be throwed out soon.-class (Ord a, Num a) => Modulable a where- -- | Empty value representing total transparency for the given type.- emptyValue :: a- -- | Full value representing total opacity for a given type.- fullValue :: a- -- | Given a Float in [0; 1], return the coverage in [emptyValue; fullValue]- -- The second value is the inverse coverage- clampCoverage :: Float -> (a, a)-- -- | Modulate two elements, staying in the [emptyValue; fullValue] range.- modulate :: a -> a -> a-- -- | Implement a division between two elements.- modiv :: a -> a -> a-- alphaOver :: a -- ^ coverage- -> a -- ^ inverse coverage- -> a -- ^ background- -> a -- ^ foreground- -> a- alphaCompose :: a -> a -> a -> a -> a-- -- | Like modulate but also return the inverse coverage.- coverageModulate :: a -> a -> (a, a)- {-# INLINE coverageModulate #-}- coverageModulate c a = (clamped, fullValue - clamped)- where clamped = modulate a c--instance Modulable Float where- emptyValue = 0- fullValue = 1- clampCoverage f = (f, 1 - f)- modulate = (*)- modiv = (/)- alphaCompose coverage inverseCoverage backAlpha _ =- coverage + backAlpha * inverseCoverage- alphaOver coverage inverseCoverage background painted =- coverage * painted + background * inverseCoverage--div255 :: Word32 -> Word32-{-# INLINE div255 #-}-div255 v = (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8--instance Modulable Word8 where- {-# INLINE emptyValue #-}- emptyValue = 0- {-# INLINE fullValue #-}- fullValue = 255- {-# INLINE clampCoverage #-}- clampCoverage f = (fromIntegral c, fromIntegral $ 255 - c)- where c = toWord8 f-- {-# INLINE modulate #-}- modulate c a = fromIntegral . div255 $ fi c * fi a + 128- where fi :: Word8 -> Word32- fi = fromIntegral-- {-# INLINE modiv #-}- modiv c 0 = c- modiv c a = fromIntegral . min 255 $ (fi c * 255) `div` fi a- where fi :: Word8 -> Word32- fi = fromIntegral-- {-# INLINE alphaCompose #-}- alphaCompose coverage inverseCoverage backgroundAlpha _ =- fromIntegral $ div255 v- where fi :: Word8 -> Word32- fi = fromIntegral- v = fi coverage * 255- + fi backgroundAlpha * fi inverseCoverage + 128-- {-# INLINE alphaOver #-}- alphaOver coverage inverseCoverage background painted =- fromIntegral $ div255 v- where fi :: Word8 -> Word32- fi = fromIntegral- v = fi coverage * fi painted + fi background * fi inverseCoverage + 128---toWord8 :: Float -> Int-{-# INLINE toWord8 #-}-toWord8 r = floor $ r * 255 + 0.5--compositionDestination :: (Pixel px, Modulable (PixelBaseComponent px))- => Compositor px-compositionDestination c _ _ = colorMap (modulate c)--compositionAlpha :: (Pixel px, Modulable (PixelBaseComponent px))- => Compositor px-{-# INLINE compositionAlpha #-}-compositionAlpha c ic- | c == emptyValue = const- | c == fullValue = \_ n -> n- | otherwise = \bottom top ->- let bottomOpacity = pixelOpacity bottom- alphaOut = alphaCompose c ic bottomOpacity (pixelOpacity top)- colorComposer _ back fore =- alphaOver c ic (back `modulate` bottomOpacity) fore- `modiv` alphaOut- in- mixWithAlpha colorComposer (\_ _ -> alphaOut) bottom top--emptyPx :: (RenderablePixel px) => px--- | Really need a "builder" function for pixel-emptyPx = colorMap (const emptyValue) $ unpackPixel 0-+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +-- | Compositor handle the pixel composition, which +-- leads to texture composition. +-- Very much a work in progress +module Graphics.Rasterific.Compositor + ( Compositor + , Modulable( .. ) + , InterpolablePixel( .. ) + , maxDistance + , RenderablePixel + , ModulablePixel + , compositionDestination + , compositionAlpha + , emptyPx + ) where + +import Foreign.Storable( Storable ) +import Data.Bits( unsafeShiftR ) +import Data.Word( Word8, Word32 ) + +import Codec.Picture.Types + ( Pixel( .. ) + , PixelRGB8( .. ) + , PixelRGBA8( .. ) + , PackeablePixel( .. ) ) + +import Graphics.Rasterific.Linear +import Graphics.Rasterific.Types + +type Compositor px = + PixelBaseComponent px -> + PixelBaseComponent px -> px -> px -> px + +-- | Used for Coon patch rendering +class ( Applicative (Holder a) + , Functor (Holder a) + , Foldable (Holder a) + , Additive (Holder a) ) => InterpolablePixel a where + type Holder a :: * -> * + toFloatPixel :: a -> Holder a Float + fromFloatPixel :: Holder a Float -> a + maxRepresentable :: Proxy a -> Float + +maxDistance :: InterpolablePixel a => a -> a -> Float +maxDistance p1 p2 = maximum $ abs <$> (toFloatPixel p1 ^-^ toFloatPixel p2) + +instance InterpolablePixel Float where + type Holder Float = V1 + toFloatPixel = V1 + fromFloatPixel (V1 f) = f + maxRepresentable Proxy = 1 + +instance InterpolablePixel Word8 where + type Holder Word8 = V1 + toFloatPixel = V1 . fromIntegral + fromFloatPixel (V1 f) = floor f + maxRepresentable Proxy = 255 + +instance InterpolablePixel PixelRGB8 where + type Holder PixelRGB8 = V3 + toFloatPixel (PixelRGB8 r g b) = V3 (to r) (to g) (to b) where to n = fromIntegral n + fromFloatPixel (V3 r g b) = PixelRGB8 (to r) (to g) (to b) where to = floor + maxRepresentable Proxy = 255 + +instance InterpolablePixel PixelRGBA8 where + type Holder PixelRGBA8 = V4 + toFloatPixel (PixelRGBA8 r g b a) = V4 (to r) (to g) (to b) (to a) + where to n = fromIntegral n + fromFloatPixel (V4 r g b a) = PixelRGBA8 (to r) (to g) (to b) (to a) + where to = floor + maxRepresentable Proxy = 255 + +-- | This constraint ensure that a type is a pixel +-- and we're allowed to modulate it's color components +-- generically. +type ModulablePixel px = + ( Pixel px + , PackeablePixel px + , InterpolablePixel px + , InterpolablePixel (PixelBaseComponent px) + , Storable (PackedRepresentation px) + , Modulable (PixelBaseComponent px)) + +-- | This constraint tells us that pixel component +-- must also be pixel and be the "bottom" of component, +-- we cannot go further than a PixelBaseComponent level. +-- +-- Tested pixel types are PixelRGBA8 & Pixel8 +type RenderablePixel px = + ( ModulablePixel px + , Pixel (PixelBaseComponent px) + , PackeablePixel (PixelBaseComponent px) + , Num (PackedRepresentation px) + , Num (PackedRepresentation (PixelBaseComponent px)) + , Num (Holder px Float) + , Num (Holder (PixelBaseComponent px) Float) + , Storable (PackedRepresentation (PixelBaseComponent px)) + , PixelBaseComponent (PixelBaseComponent px) + ~ (PixelBaseComponent px) + ) + +-- | Typeclass intented at pixel value modulation. +-- May be throwed out soon. +class (Ord a, Num a) => Modulable a where + -- | Empty value representing total transparency for the given type. + emptyValue :: a + -- | Full value representing total opacity for a given type. + fullValue :: a + -- | Given a Float in [0; 1], return the coverage in [emptyValue; fullValue] + -- The second value is the inverse coverage + clampCoverage :: Float -> (a, a) + + -- | Modulate two elements, staying in the [emptyValue; fullValue] range. + modulate :: a -> a -> a + + -- | Implement a division between two elements. + modiv :: a -> a -> a + + alphaOver :: a -- ^ coverage + -> a -- ^ inverse coverage + -> a -- ^ background + -> a -- ^ foreground + -> a + alphaCompose :: a -> a -> a -> a -> a + + -- | Like modulate but also return the inverse coverage. + coverageModulate :: a -> a -> (a, a) + {-# INLINE coverageModulate #-} + coverageModulate c a = (clamped, fullValue - clamped) + where clamped = modulate a c + +instance Modulable Float where + emptyValue = 0 + fullValue = 1 + clampCoverage f = (f, 1 - f) + modulate = (*) + modiv = (/) + alphaCompose coverage inverseCoverage backAlpha _ = + coverage + backAlpha * inverseCoverage + alphaOver coverage inverseCoverage background painted = + coverage * painted + background * inverseCoverage + +div255 :: Word32 -> Word32 +{-# INLINE div255 #-} +div255 v = (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 + +instance Modulable Word8 where + {-# INLINE emptyValue #-} + emptyValue = 0 + {-# INLINE fullValue #-} + fullValue = 255 + {-# INLINE clampCoverage #-} + clampCoverage f = (fromIntegral c, fromIntegral $ 255 - c) + where c = toWord8 f + + {-# INLINE modulate #-} + modulate c a = fromIntegral . div255 $ fi c * fi a + 128 + where fi :: Word8 -> Word32 + fi = fromIntegral + + {-# INLINE modiv #-} + modiv c 0 = c + modiv c a = fromIntegral . min 255 $ (fi c * 255) `div` fi a + where fi :: Word8 -> Word32 + fi = fromIntegral + + {-# INLINE alphaCompose #-} + alphaCompose coverage inverseCoverage backgroundAlpha _ = + fromIntegral $ div255 v + where fi :: Word8 -> Word32 + fi = fromIntegral + v = fi coverage * 255 + + fi backgroundAlpha * fi inverseCoverage + 128 + + {-# INLINE alphaOver #-} + alphaOver coverage inverseCoverage background painted = + fromIntegral $ div255 v + where fi :: Word8 -> Word32 + fi = fromIntegral + v = fi coverage * fi painted + fi background * fi inverseCoverage + 128 + + +toWord8 :: Float -> Int +{-# INLINE toWord8 #-} +toWord8 r = floor $ r * 255 + 0.5 + +compositionDestination :: (Pixel px, Modulable (PixelBaseComponent px)) + => Compositor px +compositionDestination c _ _ = colorMap (modulate c) + +compositionAlpha :: (Pixel px, Modulable (PixelBaseComponent px)) + => Compositor px +{-# INLINE compositionAlpha #-} +compositionAlpha c ic + | c == emptyValue = const + | c == fullValue = \_ n -> n + | otherwise = \bottom top -> + let bottomOpacity = pixelOpacity bottom + alphaOut = alphaCompose c ic bottomOpacity (pixelOpacity top) + colorComposer _ back fore = + alphaOver c ic (back `modulate` bottomOpacity) fore + `modiv` alphaOut + in + mixWithAlpha colorComposer (\_ _ -> alphaOut) bottom top + +emptyPx :: (RenderablePixel px) => px +-- | Really need a "builder" function for pixel +emptyPx = colorMap (const emptyValue) $ unpackPixel 0 +
src/Graphics/Rasterific/CubicBezier.hs view
@@ -1,368 +1,362 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Graphics.Rasterific.CubicBezier- ( cubicBezierCircle- , cubicBezierFromPath- , cubicBezierBreakAt- , divideCubicBezier- , clipCubicBezier- , decomposeCubicBeziers- , sanitizeCubicBezier- , offsetCubicBezier- , flattenCubicBezier- , cubicBezierLengthApproximation- , cubicBezierBounds- , cubicFromQuadraticBezier- , isCubicBezierPoint- ) where--import Prelude hiding( or )--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<$>), pure )-import Data.Monoid( mempty )-#endif--import Data.Monoid( (<>) )-import Control.Applicative( liftA2 )-import Graphics.Rasterific.Linear- ( V2( .. )- , (^-^)- , (^+^)- , (^*)- , norm- , lerp- )-import Data.List( nub )-import Graphics.Rasterific.Operators-import Graphics.Rasterific.Types-import Graphics.Rasterific.QuadraticFormula---- | Create a list of cubic bezier patch from a list of points.------ > cubicBezierFromPath [a, b, c, d, e] = [CubicBezier a b c d]--- > cubicBezierFromPath [a, b, c, d, e, f, g] =--- > [CubicBezier a b c d, CubicBezier d e f g]----cubicBezierFromPath :: [Point] -> [CubicBezier]-cubicBezierFromPath (a:b:c:rest@(d:_)) =- CubicBezier a b c d : cubicBezierFromPath rest-cubicBezierFromPath _ = []--cubicBezierLengthApproximation :: CubicBezier -> Float-cubicBezierLengthApproximation (CubicBezier a _ _ d) =- norm $ d ^-^ a---- | Represent a circle of radius 1 centered on 0 of--- a cubic bezier curve.-cubicBezierCircle :: [CubicBezier]-cubicBezierCircle =- [ CubicBezier (V2 0 1) (V2 c 1) (V2 1 c) (V2 1 0)- , CubicBezier (V2 1 0) (V2 1 (-c)) (V2 c (-1)) (V2 0 (-1))- , CubicBezier (V2 0 (-1)) (V2 (-c) (-1)) (V2 (-1) (-c)) (V2 (-1) 0)- , CubicBezier (V2 (-1) 0) (V2 (-1) c) (V2 (-c) 1) (V2 0 1)- ]- where c = 0.551915024494 -- magic constant? magic constant.--straightLine :: Point -> Point -> CubicBezier-straightLine a b = CubicBezier a p p b- where p = a `midPoint` b--isSufficientlyFlat :: Float -- ^ Tolerance- -> CubicBezier- -> Bool-isSufficientlyFlat tol (CubicBezier a b c d) =- x + y <= tolerance- where u = (b ^* 3) ^-^ (a ^* 2) ^-^ d- v = (c ^* 3) ^-^ (d ^* 2) ^-^ a- (^*^) = liftA2 (*)- V2 x y = vmax (u ^*^ u) (v ^*^ v)- tolerance = 16 * tol * tol--splitCubicBezier :: CubicBezier -> (Point, Point, Point, Point, Point, Point)-{-# INLINE splitCubicBezier #-}-splitCubicBezier (CubicBezier a b c d) = (ab, bc, cd, abbc, bccd, abbcbccd)- where- -- BC- -- B X----------X---------X C- -- ^ / ___/ \___ \ ^- -- u \ / __X------X------X_ \ / v- -- \ /___/ ABBC BCCD \___\ /- -- AB X/ \X CD- -- / \- -- / \- -- / \- -- A X X D- ab = a `midPoint` b- bc = b `midPoint` c- cd = c `midPoint` d-- abbc = ab `midPoint` bc- bccd = bc `midPoint` cd- abbcbccd = abbc `midPoint` bccd--flattenCubicBezier :: CubicBezier -> Container Primitive-flattenCubicBezier bezier@(CubicBezier a _ _ d)- | isSufficientlyFlat 1 bezier = pure $ CubicBezierPrim bezier- | otherwise =- flattenCubicBezier (CubicBezier a ab abbc abbcbccd) <>- flattenCubicBezier (CubicBezier abbcbccd bccd cd d)- where- (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier---- 3 2 2 3--- x(t) = (1 - t) ∙x + 3∙t∙(1 - t) ∙x + 3∙t ∙(1 - t)∙x + t ∙x--- 0 1 2 3------ 3 2 2 3--- y(t) = (1 - t) ∙y + 3∙t∙(1 - t) ∙y + 3∙t ∙(1 - t)∙y + t ∙y--- 0 1 2 3---- Other representation:--- 3 2 2 3--- B(t) = x(1 - t) + 3∙y∙t∙(1 - t) + 3∙z∙t ∙(1 - t) + w∙t----- | Represent the cubic bezier curve as a vector ready--- for matrix multiplication-data CachedBezier = CachedBezier- { _cachedA :: {-# UNPACK #-} !Float- , _cachedB :: {-# UNPACK #-} !Float- , _cachedC :: {-# UNPACK #-} !Float- , _cachedD :: {-# UNPACK #-} !Float- }--cacheBezier :: CubicBezier -> (CachedBezier, CachedBezier)-cacheBezier (CubicBezier p0@(V2 x0 y0) p1 p2 p3) =- (CachedBezier x0 bX cX dX, CachedBezier y0 bY cY dY)- where- V2 bX bY = p1 ^* 3 ^-^ p0 ^* 3- V2 cX cY = p2 ^* 3 ^-^ p1 ^* 6 + p0 ^* 3- V2 dX dY = p3 ^-^ p2 ^* 3 ^+^ p1 ^* 3 ^-^ p0--cachedBezierAt :: CachedBezier -> Float -> Float-cachedBezierAt (CachedBezier a b c d) t =- a + b * t + c * tSquare + tCube * d- where- tSquare = t * t- tCube = tSquare * t--cachedBezierDerivative :: CachedBezier -> QuadraticFormula Float-cachedBezierDerivative (CachedBezier _ b c d) =- QuadraticFormula (3 * d) (2 * c) b---- | Find the coefficient of the extremum points-extremums :: CachedBezier -> [Float]-extremums cached =- [ root | root <- formulaRoots $ cachedBezierDerivative cached- , 0 <= root && root <= 1.0 ]--extremumPoints :: (CachedBezier, CachedBezier) -> [Point]-extremumPoints (onX, onY) = toPoints <$> nub (extremums onX <> extremums onY)- where toPoints at = V2 (cachedBezierAt onX at) (cachedBezierAt onY at)--cubicBezierBounds :: CubicBezier -> [Point]-cubicBezierBounds bez@(CubicBezier p0 _ _ p3) =- p0 : p3 : extremumPoints (cacheBezier bez)--offsetCubicBezier :: Float -> CubicBezier -> Container Primitive-offsetCubicBezier offset bezier@(CubicBezier a b c d)- | isSufficientlyFlat 1 bezier =- pure . CubicBezierPrim $ CubicBezier shiftedA shiftedB shiftedC shiftedD- | otherwise =- recurse (CubicBezier a ab abbc abbcbccd) <>- recurse (CubicBezier abbcbccd bccd cd d)- where- recurse = offsetCubicBezier offset-- u = a `normal` b- v = c `normal` d-- -- BC- -- B X----------X---------X C- -- ^ / ___/ \___ \ ^- -- u \ / __X------X------X_ \ / v- -- \ /___/ ABBC BCCD \___\ /- -- AB X/ \X CD- -- / \- -- / \- -- / \- -- A X X D- (ab, bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier-- w = ab `normal` bc- x = bc `normal` cd-- shiftedA = a ^+^ (u ^* offset)- shiftedD = d ^+^ (v ^* offset)-- {-shiftedABBCBCCD = abbcbccd ^+^ (w ^* offset)-}- shiftedB = b ^+^ (w ^* offset)- shiftedC = c ^+^ (x ^* offset)---- | Clamp the cubic bezier curve inside a rectangle--- given in parameter.-clipCubicBezier- :: Point -- ^ Point representing the "minimal" point for cliping- -> Point -- ^ Point representing the "maximal" point for cliping- -> CubicBezier -- ^ The cubic bezier curve to be clamped- -> Container Primitive-clipCubicBezier mini maxi bezier@(CubicBezier a b c d)- -- If we are in the range bound, return the curve- -- unaltered- | insideX && insideY = pure $ CubicBezierPrim bezier- -- If one of the component is outside, clamp- -- the components on the boundaries and output a- -- straight line on this boundary. Useful for the- -- filing case, to clamp the polygon drawing on- -- the edge- | outsideX || outsideY =- pure . CubicBezierPrim $ clampedA `straightLine` clampedD- -- Not completly inside nor outside, just divide- -- and conquer.- | otherwise =- recurse (CubicBezier a ab abbc m) <>- recurse (CubicBezier m bccd cd d)- where -- Minimal & maximal dimension of the bezier curve- bmin = vmin a . vmin b $ vmin c d- bmax = vmax a . vmax b $ vmax c d-- recurse = clipCubicBezier mini maxi-- clamper = clampPoint mini maxi- clampedA = clamper a- clampedD = clamper d-- V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi- V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin-- -- BC- -- B X----------X---------X C- -- / ___/ \___ \- -- / __X------X------X_ \- -- /___/ ABBC BCCD \___\- -- AB X/ \X CD- -- / \- -- / \- -- / \- -- A X X D- (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier-- edgeSeparator = vabs (abbcbccd ^-^ mini) ^<^ vabs (abbcbccd ^-^ maxi)- edge = vpartition edgeSeparator mini maxi- m = vpartition (vabs (abbcbccd ^-^ edge) ^< 0.1) edge abbcbccd--divideCubicBezier :: CubicBezier -> (CubicBezier, CubicBezier)-divideCubicBezier bezier@(CubicBezier a _ _ d) = (left, right) where- left = CubicBezier a ab abbc abbcbccd- right = CubicBezier abbcbccd bccd cd d- (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier---- | Will subdivide the bezier from 0 to coeff and coeff to 1-cubicBezierBreakAt :: CubicBezier -> Float- -> (CubicBezier, CubicBezier)-cubicBezierBreakAt (CubicBezier a b c d) val =- (CubicBezier a ab abbc abbcbccd, CubicBezier abbcbccd bccd cd d)- where- ab = lerp val b a- bc = lerp val c b- cd = lerp val d c-- abbc = lerp val bc ab- bccd = lerp val cd bc- abbcbccd = lerp val bccd abbc--decomposeCubicBeziers :: CubicBezier -> Producer EdgeSample-decomposeCubicBeziers (CubicBezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy) (V2 dRx dRy)) =- go aRx aRy bRx bRy cRx cRy dRx dRy where- go ax ay _bx _by _cx _cy dx dy cont | insideX && insideY =- let !px = fromIntegral $ min floorAx floorDx- !py = fromIntegral $ min floorAy floorDy- !w = px + 1 - (dx `middle` ax)- !h = dy - ay- in- EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont- where- floorAx, floorAy :: Int- !floorAx = floor ax- !floorAy = floor ay-- !floorDx = floor dx- !floorDy = floor dy-- !insideX =- floorAx == floorDx || ceiling ax == (ceiling dx :: Int)- !insideY =- floorAy == floorDy || ceiling ay == (ceiling dy :: Int)--- go !ax !ay !bx !by !cx !cy !dx !dy cont =- go ax ay abx aby abbcx abbcy mx my $- go mx my bccdx bccdy cdx cdy dx dy cont- where- -- BC- -- B X----------X---------X C- -- / ___/ \___ \- -- / __X------X------X_ \- -- /___/ ABBC BCCD \___\- -- AB X/ \X CD- -- / \- -- / \- -- / \- -- A X X D- !abx = ax `middle` bx- !aby = ay `middle` by- !bcx = bx `middle` cx- !bcy = by `middle` cy- !cdx = cx `middle` dx- !cdy = cy `middle` dy- !abbcx = abx `middle` bcx- !abbcy = aby `middle` bcy- !bccdx = bcx `middle` cdx- !bccdy = bcy `middle` cdy-- !abbcbccdx = abbcx `middle` bccdx- !abbcbccdy = abbcy `middle` bccdy-- !mx | abs (abbcbccdx - mini) < 0.1 = mini- | abs (abbcbccdx - maxi) < 0.1 = maxi- | otherwise = abbcbccdx- where !mini = fromIntegral (floor abbcbccdx :: Int)- !maxi = fromIntegral (ceiling abbcbccdx :: Int)-- !my | abs (abbcbccdy - mini) < 0.1 = mini- | abs (abbcbccdy - maxi) < 0.1 = maxi- | otherwise = abbcbccdy- where !mini = fromIntegral (floor abbcbccdy :: Int)- !maxi = fromIntegral (ceiling abbcbccdy :: Int)--isCubicBezierPoint :: CubicBezier -> Bool-isCubicBezierPoint (CubicBezier a b c d) =- not $ a `isDistingableFrom` b || - b `isDistingableFrom` c ||- c `isDistingableFrom` d--sanitizeCubicBezier :: CubicBezier -> Container Primitive-sanitizeCubicBezier bezier@(CubicBezier a b c d)- | a `isDistingableFrom` b &&- c `isDistingableFrom` d =- pure . CubicBezierPrim $ bezier- | ac `isDistingableFrom` b &&- bd `isDistingableFrom` c =- pure . CubicBezierPrim $ bezier- | ac `isDistingableFrom` b =- pure . CubicBezierPrim $ CubicBezier a ac c d- | bd `isDistingableFrom` c =- pure . CubicBezierPrim $ CubicBezier a b bd d- | otherwise = mempty- where ac = a `midPoint` c- bd = a `midPoint` d--cubicFromQuadraticBezier :: Bezier -> CubicBezier-cubicFromQuadraticBezier (Bezier p0 p1 p2) = CubicBezier p0 pa pb p2 where- pa = p0 ^+^ (p1 ^-^ p0) ^* (2 / 3)- pb = p2 ^+^ (p1 ^-^ p2) ^* (2 / 3)-+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Graphics.Rasterific.CubicBezier + ( cubicBezierCircle + , cubicBezierFromPath + , cubicBezierBreakAt + , divideCubicBezier + , clipCubicBezier + , decomposeCubicBeziers + , sanitizeCubicBezier + , offsetCubicBezier + , flattenCubicBezier + , cubicBezierLengthApproximation + , cubicBezierBounds + , cubicFromQuadraticBezier + , isCubicBezierPoint + ) where + +import Prelude hiding( or ) + +import Data.Monoid( (<>) ) +import Control.Applicative( liftA2 ) +import Graphics.Rasterific.Linear + ( V2( .. ) + , (^-^) + , (^+^) + , (^*) + , norm + , lerp + ) +import Data.List( nub ) +import Graphics.Rasterific.Operators +import Graphics.Rasterific.Types +import Graphics.Rasterific.QuadraticFormula + +-- | Create a list of cubic bezier patch from a list of points. +-- +-- > cubicBezierFromPath [a, b, c, d, e] = [CubicBezier a b c d] +-- > cubicBezierFromPath [a, b, c, d, e, f, g] = +-- > [CubicBezier a b c d, CubicBezier d e f g] +-- +cubicBezierFromPath :: [Point] -> [CubicBezier] +cubicBezierFromPath (a:b:c:rest@(d:_)) = + CubicBezier a b c d : cubicBezierFromPath rest +cubicBezierFromPath _ = [] + +cubicBezierLengthApproximation :: CubicBezier -> Float +cubicBezierLengthApproximation (CubicBezier a _ _ d) = + norm $ d ^-^ a + +-- | Represent a circle of radius 1 centered on 0 of +-- a cubic bezier curve. +cubicBezierCircle :: [CubicBezier] +cubicBezierCircle = + [ CubicBezier (V2 0 1) (V2 c 1) (V2 1 c) (V2 1 0) + , CubicBezier (V2 1 0) (V2 1 (-c)) (V2 c (-1)) (V2 0 (-1)) + , CubicBezier (V2 0 (-1)) (V2 (-c) (-1)) (V2 (-1) (-c)) (V2 (-1) 0) + , CubicBezier (V2 (-1) 0) (V2 (-1) c) (V2 (-c) 1) (V2 0 1) + ] + where c = 0.551915024494 -- magic constant? magic constant. + +straightLine :: Point -> Point -> CubicBezier +straightLine a b = CubicBezier a p p b + where p = a `midPoint` b + +isSufficientlyFlat :: Float -- ^ Tolerance + -> CubicBezier + -> Bool +isSufficientlyFlat tol (CubicBezier a b c d) = + x + y <= tolerance + where u = (b ^* 3) ^-^ (a ^* 2) ^-^ d + v = (c ^* 3) ^-^ (d ^* 2) ^-^ a + (^*^) = liftA2 (*) + V2 x y = vmax (u ^*^ u) (v ^*^ v) + tolerance = 16 * tol * tol + +splitCubicBezier :: CubicBezier -> (Point, Point, Point, Point, Point, Point) +{-# INLINE splitCubicBezier #-} +splitCubicBezier (CubicBezier a b c d) = (ab, bc, cd, abbc, bccd, abbcbccd) + where + -- BC + -- B X----------X---------X C + -- ^ / ___/ \___ \ ^ + -- u \ / __X------X------X_ \ / v + -- \ /___/ ABBC BCCD \___\ / + -- AB X/ \X CD + -- / \ + -- / \ + -- / \ + -- A X X D + ab = a `midPoint` b + bc = b `midPoint` c + cd = c `midPoint` d + + abbc = ab `midPoint` bc + bccd = bc `midPoint` cd + abbcbccd = abbc `midPoint` bccd + +flattenCubicBezier :: CubicBezier -> Container Primitive +flattenCubicBezier bezier@(CubicBezier a _ _ d) + | isSufficientlyFlat 1 bezier = pure $ CubicBezierPrim bezier + | otherwise = + flattenCubicBezier (CubicBezier a ab abbc abbcbccd) <> + flattenCubicBezier (CubicBezier abbcbccd bccd cd d) + where + (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier + +-- 3 2 2 3 +-- x(t) = (1 - t) ∙x + 3∙t∙(1 - t) ∙x + 3∙t ∙(1 - t)∙x + t ∙x +-- 0 1 2 3 +-- +-- 3 2 2 3 +-- y(t) = (1 - t) ∙y + 3∙t∙(1 - t) ∙y + 3∙t ∙(1 - t)∙y + t ∙y +-- 0 1 2 3 + +-- Other representation: +-- 3 2 2 3 +-- B(t) = x(1 - t) + 3∙y∙t∙(1 - t) + 3∙z∙t ∙(1 - t) + w∙t + + +-- | Represent the cubic bezier curve as a vector ready +-- for matrix multiplication +data CachedBezier = CachedBezier + { _cachedA :: {-# UNPACK #-} !Float + , _cachedB :: {-# UNPACK #-} !Float + , _cachedC :: {-# UNPACK #-} !Float + , _cachedD :: {-# UNPACK #-} !Float + } + +cacheBezier :: CubicBezier -> (CachedBezier, CachedBezier) +cacheBezier (CubicBezier p0@(V2 x0 y0) p1 p2 p3) = + (CachedBezier x0 bX cX dX, CachedBezier y0 bY cY dY) + where + V2 bX bY = p1 ^* 3 ^-^ p0 ^* 3 + V2 cX cY = p2 ^* 3 ^-^ p1 ^* 6 + p0 ^* 3 + V2 dX dY = p3 ^-^ p2 ^* 3 ^+^ p1 ^* 3 ^-^ p0 + +cachedBezierAt :: CachedBezier -> Float -> Float +cachedBezierAt (CachedBezier a b c d) t = + a + b * t + c * tSquare + tCube * d + where + tSquare = t * t + tCube = tSquare * t + +cachedBezierDerivative :: CachedBezier -> QuadraticFormula Float +cachedBezierDerivative (CachedBezier _ b c d) = + QuadraticFormula (3 * d) (2 * c) b + +-- | Find the coefficient of the extremum points +extremums :: CachedBezier -> [Float] +extremums cached = + [ root | root <- formulaRoots $ cachedBezierDerivative cached + , 0 <= root && root <= 1.0 ] + +extremumPoints :: (CachedBezier, CachedBezier) -> [Point] +extremumPoints (onX, onY) = toPoints <$> nub (extremums onX <> extremums onY) + where toPoints at = V2 (cachedBezierAt onX at) (cachedBezierAt onY at) + +cubicBezierBounds :: CubicBezier -> [Point] +cubicBezierBounds bez@(CubicBezier p0 _ _ p3) = + p0 : p3 : extremumPoints (cacheBezier bez) + +offsetCubicBezier :: Float -> CubicBezier -> Container Primitive +offsetCubicBezier offset bezier@(CubicBezier a b c d) + | isSufficientlyFlat 1 bezier = + pure . CubicBezierPrim $ CubicBezier shiftedA shiftedB shiftedC shiftedD + | otherwise = + recurse (CubicBezier a ab abbc abbcbccd) <> + recurse (CubicBezier abbcbccd bccd cd d) + where + recurse = offsetCubicBezier offset + + u = a `normal` b + v = c `normal` d + + -- BC + -- B X----------X---------X C + -- ^ / ___/ \___ \ ^ + -- u \ / __X------X------X_ \ / v + -- \ /___/ ABBC BCCD \___\ / + -- AB X/ \X CD + -- / \ + -- / \ + -- / \ + -- A X X D + (ab, bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier + + w = ab `normal` bc + x = bc `normal` cd + + shiftedA = a ^+^ (u ^* offset) + shiftedD = d ^+^ (v ^* offset) + + {-shiftedABBCBCCD = abbcbccd ^+^ (w ^* offset)-} + shiftedB = b ^+^ (w ^* offset) + shiftedC = c ^+^ (x ^* offset) + +-- | Clamp the cubic bezier curve inside a rectangle +-- given in parameter. +clipCubicBezier + :: Point -- ^ Point representing the "minimal" point for cliping + -> Point -- ^ Point representing the "maximal" point for cliping + -> CubicBezier -- ^ The cubic bezier curve to be clamped + -> Container Primitive +clipCubicBezier mini maxi bezier@(CubicBezier a b c d) + -- If we are in the range bound, return the curve + -- unaltered + | insideX && insideY = pure $ CubicBezierPrim bezier + -- If one of the component is outside, clamp + -- the components on the boundaries and output a + -- straight line on this boundary. Useful for the + -- filing case, to clamp the polygon drawing on + -- the edge + | outsideX || outsideY = + pure . CubicBezierPrim $ clampedA `straightLine` clampedD + -- Not completly inside nor outside, just divide + -- and conquer. + | otherwise = + recurse (CubicBezier a ab abbc m) <> + recurse (CubicBezier m bccd cd d) + where -- Minimal & maximal dimension of the bezier curve + bmin = vmin a . vmin b $ vmin c d + bmax = vmax a . vmax b $ vmax c d + + recurse = clipCubicBezier mini maxi + + clamper = clampPoint mini maxi + clampedA = clamper a + clampedD = clamper d + + V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi + V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin + + -- BC + -- B X----------X---------X C + -- / ___/ \___ \ + -- / __X------X------X_ \ + -- /___/ ABBC BCCD \___\ + -- AB X/ \X CD + -- / \ + -- / \ + -- / \ + -- A X X D + (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier + + edgeSeparator = vabs (abbcbccd ^-^ mini) ^<^ vabs (abbcbccd ^-^ maxi) + edge = vpartition edgeSeparator mini maxi + m = vpartition (vabs (abbcbccd ^-^ edge) ^< 0.1) edge abbcbccd + +divideCubicBezier :: CubicBezier -> (CubicBezier, CubicBezier) +divideCubicBezier bezier@(CubicBezier a _ _ d) = (left, right) where + left = CubicBezier a ab abbc abbcbccd + right = CubicBezier abbcbccd bccd cd d + (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier + +-- | Will subdivide the bezier from 0 to coeff and coeff to 1 +cubicBezierBreakAt :: CubicBezier -> Float + -> (CubicBezier, CubicBezier) +cubicBezierBreakAt (CubicBezier a b c d) val = + (CubicBezier a ab abbc abbcbccd, CubicBezier abbcbccd bccd cd d) + where + ab = lerp val b a + bc = lerp val c b + cd = lerp val d c + + abbc = lerp val bc ab + bccd = lerp val cd bc + abbcbccd = lerp val bccd abbc + +decomposeCubicBeziers :: CubicBezier -> Producer EdgeSample +decomposeCubicBeziers (CubicBezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy) (V2 dRx dRy)) = + go aRx aRy bRx bRy cRx cRy dRx dRy where + go ax ay _bx _by _cx _cy dx dy cont | insideX && insideY = + let !px = fromIntegral $ min floorAx floorDx + !py = fromIntegral $ min floorAy floorDy + !w = px + 1 - (dx `middle` ax) + !h = dy - ay + in + EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont + where + floorAx, floorAy :: Int + !floorAx = floor ax + !floorAy = floor ay + + !floorDx = floor dx + !floorDy = floor dy + + !insideX = + floorAx == floorDx || ceiling ax == (ceiling dx :: Int) + !insideY = + floorAy == floorDy || ceiling ay == (ceiling dy :: Int) + + + go !ax !ay !bx !by !cx !cy !dx !dy cont = + go ax ay abx aby abbcx abbcy mx my $ + go mx my bccdx bccdy cdx cdy dx dy cont + where + -- BC + -- B X----------X---------X C + -- / ___/ \___ \ + -- / __X------X------X_ \ + -- /___/ ABBC BCCD \___\ + -- AB X/ \X CD + -- / \ + -- / \ + -- / \ + -- A X X D + !abx = ax `middle` bx + !aby = ay `middle` by + !bcx = bx `middle` cx + !bcy = by `middle` cy + !cdx = cx `middle` dx + !cdy = cy `middle` dy + !abbcx = abx `middle` bcx + !abbcy = aby `middle` bcy + !bccdx = bcx `middle` cdx + !bccdy = bcy `middle` cdy + + !abbcbccdx = abbcx `middle` bccdx + !abbcbccdy = abbcy `middle` bccdy + + !mx | abs (abbcbccdx - mini) < 0.1 = mini + | abs (abbcbccdx - maxi) < 0.1 = maxi + | otherwise = abbcbccdx + where !mini = fromIntegral (floor abbcbccdx :: Int) + !maxi = fromIntegral (ceiling abbcbccdx :: Int) + + !my | abs (abbcbccdy - mini) < 0.1 = mini + | abs (abbcbccdy - maxi) < 0.1 = maxi + | otherwise = abbcbccdy + where !mini = fromIntegral (floor abbcbccdy :: Int) + !maxi = fromIntegral (ceiling abbcbccdy :: Int) + +isCubicBezierPoint :: CubicBezier -> Bool +isCubicBezierPoint (CubicBezier a b c d) = + not $ a `isDistingableFrom` b || + b `isDistingableFrom` c || + c `isDistingableFrom` d + +sanitizeCubicBezier :: CubicBezier -> Container Primitive +sanitizeCubicBezier bezier@(CubicBezier a b c d) + | a `isDistingableFrom` b && + c `isDistingableFrom` d = + pure . CubicBezierPrim $ bezier + | ac `isDistingableFrom` b && + bd `isDistingableFrom` c = + pure . CubicBezierPrim $ bezier + | ac `isDistingableFrom` b = + pure . CubicBezierPrim $ CubicBezier a ac c d + | bd `isDistingableFrom` c = + pure . CubicBezierPrim $ CubicBezier a b bd d + | otherwise = mempty + where ac = a `midPoint` c + bd = a `midPoint` d + +cubicFromQuadraticBezier :: Bezier -> CubicBezier +cubicFromQuadraticBezier (Bezier p0 p1 p2) = CubicBezier p0 pa pb p2 where + pa = p0 ^+^ (p1 ^-^ p0) ^* (2 / 3) + pb = p2 ^+^ (p1 ^-^ p2) ^* (2 / 3) +
src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs view
@@ -19,7 +19,7 @@ import Codec.Picture.Types( MutableImage( .. ) ) import Graphics.Rasterific.Compositor -import Graphics.Rasterific.Immediate +import Graphics.Rasterific.Command import Graphics.Rasterific.Types import Graphics.Rasterific.Linear import Graphics.Rasterific.BiSampleable
src/Graphics/Rasterific/Immediate.hs view
@@ -1,258 +1,305 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE CPP #-}--- | This module implements drawing primitives to draw directly into--- the output texture, without generating an intermediate scene--- representation.------ If you need to draw complex scenes or plot an important set of--- data, this is the module you should use. The downside is that--- you must specify everything you need at each draw call, there--- is no API to help you propagate constants.------ The "stroking" must be done using the functions of the--- `Graphics.Rasterific.Outline` module.-module Graphics.Rasterific.Immediate- ( DrawContext- , DrawOrder( .. )- , orderToDrawing-- , runDrawContext- , fillWithTextureAndMask- , fillWithTexture- , fillWithTextureNoAA- , fillOrder-- , textToDrawOrders- , transformOrder- ) where---#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<$>) )-import Data.Foldable( foldMap )-#endif--import Control.Monad.ST( ST )-import Data.Maybe( fromMaybe )-import qualified Data.Foldable as F-import Control.Monad.Free( liftF )-import Control.Monad.State( evalStateT, execStateT, lift )-import Control.Monad.Trans.State( get )-import Codec.Picture.Types( Image( .. )- , Pixel( .. )- , MutableImage( .. )- , unsafeFreezeImage- , fillImageWith )--import Control.Monad.Primitive( PrimMonad, primToPrim )-import qualified Data.Vector.Storable.Mutable as M-import Graphics.Rasterific.Compositor-import Graphics.Rasterific.Linear( V2( .. ) )-import Graphics.Rasterific.Rasterize-import Graphics.Rasterific.Shading-import Graphics.Rasterific.QuadraticBezier-import Graphics.Rasterific.Types-import Graphics.Rasterific.Command-import Graphics.Rasterific.PlaneBoundable--import qualified Data.Vector.Unboxed as VU-import Graphics.Text.TrueType( Dpi, getStringCurveAtPoint )---- | Reify a filling function call, to be able to manipulate--- them in a simpler fashion.-data DrawOrder px = DrawOrder- { -- | Primitives to be filled.- _orderPrimitives :: ![[Primitive]]- -- | Texture for the filled primitives.- , _orderTexture :: !(Texture px)- -- | How to fill the primitives.- , _orderFillMethod :: !FillMethod- -- | Optional mask used for clipping.- , _orderMask :: !(Maybe (Texture (PixelBaseComponent px)))- -- | Function to perform direct drawing- , _orderDirect :: !(forall s. DrawContext (ST s) px ())- }--instance PlaneBoundable (DrawOrder px) where- planeBounds =- foldMap (foldMap planeBounds) . _orderPrimitives--transformOrder :: (Point -> Point) -> DrawOrder px -> DrawOrder px-transformOrder f order =- order { _orderPrimitives = transform f $ _orderPrimitives order }--transformOrderM :: Monad m => (Point -> m Point) -> DrawOrder px -> m (DrawOrder px)-transformOrderM f order = do- v <- transformM f $ _orderPrimitives order - return $ order { _orderPrimitives = v}--instance Transformable (DrawOrder px) where- transform = transformOrder- transformM = transformOrderM---- | Transform back a low level drawing order to a more--- high level Drawing-orderToDrawing :: DrawOrder px -> Drawing px ()-orderToDrawing order =- usingTexture . mapM_ filler $ _orderPrimitives order- where- usingTexture sub =- liftF $ SetTexture (_orderTexture order) sub ()- filler prims =- liftF $ Fill (_orderFillMethod order) prims ()---- | Render the drawing orders on the canvas.-fillOrder :: (PrimMonad m, RenderablePixel px)- => DrawOrder px -> DrawContext m px ()-fillOrder o@DrawOrder { _orderMask = Nothing } = do- F.forM_ (_orderPrimitives o) $- fillWithTexture (_orderFillMethod o) (_orderTexture o)- img <- get- lift $ primToPrim $ flip evalStateT img $ _orderDirect o--fillOrder o@DrawOrder { _orderMask = Just mask } = do- F.forM_ (_orderPrimitives o) $- fillWithTextureAndMask (_orderFillMethod o) (_orderTexture o) mask- img <- get- lift $ primToPrim $ flip evalStateT img $ _orderDirect o---- | Start an image rendering. See `fillWithTexture` for--- an usage example. This function can work with either--- `IO` or `ST`.-runDrawContext :: forall m px . (PrimMonad m, RenderablePixel px)- => Int -- ^ Rendering width- -> Int -- ^ Rendering height- -> px -- ^ Background color- -> DrawContext m px () -- ^ Actual drawing computation- -> m (Image px)-runDrawContext width height background drawing = do- buff <- M.new (width * height * componentCount background)- let mutable = MutableImage width height buff- fillImageWith mutable background- img <- execStateT drawing mutable- unsafeFreezeImage img--mapExec :: Monad m => (a -> m ()) -> [a] -> m ()-mapExec f = foldr ((>>) . f) (return ())--isCoverageDrawable :: MutableImage s px -> CoverageSpan -> Bool-isCoverageDrawable img coverage =- _coverageVal coverage > 0 && x >= 0 && y >= 0 && x < imgWidth && y < imgHeight- where- !imgWidth = fromIntegral $ mutableImageWidth img- !imgHeight = fromIntegral $ mutableImageHeight img- x = _coverageX coverage- y = _coverageY coverage---- | Fill some geometry.------ > immediateDrawExample :: Image PixelRGBA8--- > immediateDrawExample = runST $--- > runDrawContext 200 200 (PixelRGBA8 0 0 0 0) $--- > fillWithTexture FillWinding texture geometry--- > where--- > circlePrimitives = circle (V2 100 100) 50--- > geometry = strokize 4 JoinRound (CapRound, CapRound) circlePrimitives--- > texture = uniformTexture (PixelRGBA8 255 255 255 255)------ <<docimages/immediate_fill.png>>----fillWithTexture :: (PrimMonad m, RenderablePixel px)- => FillMethod- -> Texture px -- ^ Color/Texture used for the filling- -> [Primitive] -- ^ Primitives to fill- -> DrawContext m px ()-fillWithTexture fillMethod texture els = do- img@(MutableImage width height _) <- get- let !mini = V2 0 0- !maxi = V2 (fromIntegral width) (fromIntegral height)- !filler = primToPrim . transformTextureToFiller texture img- clipped = foldMap (clip mini maxi) els- spans = rasterize fillMethod clipped- lift . mapExec filler $ filter (isCoverageDrawable img) spans---- | Function identical to 'fillWithTexture' but with anti-aliasing--- (and transparency) disabled.-fillWithTextureNoAA :: (PrimMonad m, RenderablePixel px)- => FillMethod- -> Texture px -- ^ Color/Texture used for the filling- -> [Primitive] -- ^ Primitives to fill- -> DrawContext m px ()-fillWithTextureNoAA fillMethod texture els = do- img@(MutableImage width height _) <- get- let !mini = V2 0 0- !maxi = V2 (fromIntegral width) (fromIntegral height)- !filler = primToPrim . transformTextureToFiller texture img- clipped = foldMap (clip mini maxi) els- spans = rasterize fillMethod clipped- lift . mapExec (filler . toOpaqueCoverage) $ filter (isCoverageDrawable img) spans---- | Fill some geometry using a composition mask for visibility.------ > immediateDrawMaskExample :: Image PixelRGBA8--- > immediateDrawMaskExample = runST $--- > runDrawContext 200 200 (PixelRGBA8 0 0 0 255) $--- > forM_ [1 .. 10] $ \ix ->--- > fillWithTextureAndMask FillWinding texture mask $--- > rectangle (V2 10 (ix * 18 - 5)) 180 13--- > where--- > texture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255--- > mask = sampledImageTexture--- > $ runST--- > $ runDrawContext 200 200 0--- > $ fillWithTexture FillWinding (uniformTexture 255) maskGeometry--- > --- > maskGeometry = strokize 15 JoinRound (CapRound, CapRound)--- > $ circle (V2 100 100) 80------ <<docimages/immediate_mask.png>>----fillWithTextureAndMask- :: (PrimMonad m, RenderablePixel px)- => FillMethod- -> Texture px -- ^ Color/Texture used for the filling of the geometry- -> Texture (PixelBaseComponent px) -- ^ Texture used for the mask.- -> [Primitive] -- ^ Primitives to fill- -> DrawContext m px ()-fillWithTextureAndMask fillMethod texture mask els = do- img@(MutableImage width height _) <- get- let !mini = V2 0 0- !maxi = V2 (fromIntegral width) (fromIntegral height)- spans = rasterize fillMethod $ foldMap (clip mini maxi) els- !shader = primToPrim- . transformTextureToFiller (ModulateTexture texture mask) img- lift . mapM_ shader $ filter (isCoverageDrawable img) spans---- | Helper function transforming text range to draw order.-textToDrawOrders :: Dpi -- ^ Current output device resolution- -> Texture px -- ^ Texture to use if no texture is defined in the range- -> Point -- ^ Baseline position- -> [TextRange px] -- ^ Text description.- -> [DrawOrder px]-textToDrawOrders dpi defaultTexture (V2 x y) descriptions = - toOrder <$> zip floatCurves linearDescriptions where-- toOrder (curve, d) = DrawOrder - { _orderPrimitives = [beziersOfChar curve]- , _orderFillMethod = FillWinding- , _orderMask = Nothing- , _orderTexture = fromMaybe defaultTexture $ _textTexture d- , _orderDirect = return ()- }-- floatCurves =- getStringCurveAtPoint dpi (x, y)- [(_textFont d, _textSize d, _text d) | d <- descriptions]-- linearDescriptions =- concat [map (const d) $ _text d | d <- descriptions]-- beziersOfChar curves = concat- [fmap BezierPrim . bezierFromPath . fmap (uncurry V2) $ VU.toList c | c <- curves]--+{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +-- | This module implements drawing primitives to draw directly into +-- the output texture, without generating an intermediate scene +-- representation. +-- +-- If you need to draw complex scenes or plot an important set of +-- data, this is the module you should use. The downside is that +-- you must specify everything you need at each draw call, there +-- is no API to help you propagate constants. +-- +-- The "stroking" must be done using the functions of the +-- `Graphics.Rasterific.Outline` module. +module Graphics.Rasterific.Immediate + ( DrawContext + , DrawOrder( .. ) + , orderToDrawing + + , runDrawContext + , fillWithTextureAndMask + , fillWithTexture + , fillWithTextureNoAA + , fillOrder + + , textToDrawOrders + , transformOrder + + , meshToImage + ) where + + +import Control.Monad.ST( ST, runST ) +import Data.Maybe( fromMaybe ) +import qualified Data.Foldable as F +import Control.Monad.Free( liftF ) +import Control.Monad.State( evalStateT, execStateT, lift ) +import Control.Monad.Trans.State( get ) +import Codec.Picture.Types( Image( .. ) + , Pixel( .. ) + , MutableImage( .. ) + , unsafeFreezeImage + , fillImageWith ) + +import Control.Monad.Primitive( PrimMonad, primToPrim ) +import qualified Data.Vector.Storable.Mutable as M +import Graphics.Rasterific.Compositor +import Graphics.Rasterific.Linear( V2( .. ) ) +import Graphics.Rasterific.Rasterize +import Graphics.Rasterific.Shading +import Graphics.Rasterific.QuadraticBezier +import Graphics.Rasterific.Types +import Graphics.Rasterific.PatchTypes +import Graphics.Rasterific.CubicBezier.FastForwardDifference +import Graphics.Rasterific.Transformations +import Graphics.Rasterific.MeshPatch +import Graphics.Rasterific.ComplexPrimitive +import Graphics.Rasterific.Command +import Graphics.Rasterific.PlaneBoundable + +import qualified Data.Vector.Unboxed as VU +import Graphics.Text.TrueType( Dpi, getStringCurveAtPoint ) + +-- | Reify a filling function call, to be able to manipulate +-- them in a simpler fashion. +data DrawOrder px = DrawOrder + { -- | Primitives to be filled. + _orderPrimitives :: ![[Primitive]] + -- | Texture for the filled primitives. + , _orderTexture :: !(Texture px) + -- | How to fill the primitives. + , _orderFillMethod :: !FillMethod + -- | Optional mask used for clipping. + , _orderMask :: !(Maybe (Texture (PixelBaseComponent px))) + -- | Function to perform direct drawing + , _orderDirect :: !(forall s. DrawContext (ST s) px ()) + } + +instance PlaneBoundable (DrawOrder px) where + planeBounds = + foldMap (foldMap planeBounds) . _orderPrimitives + +transformOrder :: (Point -> Point) -> DrawOrder px -> DrawOrder px +transformOrder f order = + order { _orderPrimitives = transform f $ _orderPrimitives order } + +transformOrderM :: Monad m => (Point -> m Point) -> DrawOrder px -> m (DrawOrder px) +transformOrderM f order = do + v <- transformM f $ _orderPrimitives order + return $ order { _orderPrimitives = v} + +instance Transformable (DrawOrder px) where + transform = transformOrder + transformM = transformOrderM + +-- | Transform back a low level drawing order to a more +-- high level Drawing +orderToDrawing :: DrawOrder px -> Drawing px () +orderToDrawing order = + usingTexture . mapM_ filler $ _orderPrimitives order + where + usingTexture sub = + liftF $ SetTexture (_orderTexture order) sub () + filler prims = + liftF $ Fill (_orderFillMethod order) prims () + +-- | Render the drawing orders on the canvas. +fillOrder :: (PrimMonad m, RenderablePixel px) + => DrawOrder px -> DrawContext m px () +fillOrder o@DrawOrder { _orderMask = Nothing } = do + F.forM_ (_orderPrimitives o) $ + fillWithTexture (_orderFillMethod o) (_orderTexture o) + img <- get + lift $ primToPrim $ flip evalStateT img $ _orderDirect o + +fillOrder o@DrawOrder { _orderMask = Just mask } = do + F.forM_ (_orderPrimitives o) $ + fillWithTextureAndMask (_orderFillMethod o) (_orderTexture o) mask + img <- get + lift $ primToPrim $ flip evalStateT img $ _orderDirect o + +-- | Start an image rendering. See `fillWithTexture` for +-- an usage example. This function can work with either +-- `IO` or `ST`. +runDrawContext :: forall m px . (PrimMonad m, RenderablePixel px) + => Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> px -- ^ Background color + -> DrawContext m px () -- ^ Actual drawing computation + -> m (Image px) +runDrawContext width height background drawing = do + buff <- M.new (width * height * componentCount background) + let mutable = MutableImage width height buff + fillImageWith mutable background + img <- execStateT drawing mutable + unsafeFreezeImage img + +mapExec :: Monad m => (a -> m ()) -> [a] -> m () +mapExec f = foldr ((>>) . f) (return ()) + +isCoverageDrawable :: MutableImage s px -> CoverageSpan -> Bool +isCoverageDrawable img coverage = + _coverageVal coverage > 0 && x >= 0 && y >= 0 && x < imgWidth && y < imgHeight + where + !imgWidth = fromIntegral $ mutableImageWidth img + !imgHeight = fromIntegral $ mutableImageHeight img + x = _coverageX coverage + y = _coverageY coverage + +-- | Fill some geometry. +-- +-- > immediateDrawExample :: Image PixelRGBA8 +-- > immediateDrawExample = runST $ +-- > runDrawContext 200 200 (PixelRGBA8 0 0 0 0) $ +-- > fillWithTexture FillWinding texture geometry +-- > where +-- > circlePrimitives = circle (V2 100 100) 50 +-- > geometry = strokize 4 JoinRound (CapRound, CapRound) circlePrimitives +-- > texture = uniformTexture (PixelRGBA8 255 255 255 255) +-- +-- <<docimages/immediate_fill.png>> +-- +fillWithTexture :: (PrimMonad m, RenderablePixel px) + => FillMethod + -> Texture px -- ^ Color/Texture used for the filling + -> [Primitive] -- ^ Primitives to fill + -> DrawContext m px () +fillWithTexture fillMethod texture els = do + img@(MutableImage width height _) <- get + let !mini = V2 0 0 + !maxi = V2 (fromIntegral width) (fromIntegral height) + !filler = primToPrim . transformTextureToFiller meshToImage texture img + clipped = foldMap (clip mini maxi) els + spans = rasterize fillMethod clipped + lift . mapExec filler $ filter (isCoverageDrawable img) spans + +-- | Function identical to 'fillWithTexture' but with anti-aliasing +-- (and transparency) disabled. +fillWithTextureNoAA :: (PrimMonad m, RenderablePixel px) + => FillMethod + -> Texture px -- ^ Color/Texture used for the filling + -> [Primitive] -- ^ Primitives to fill + -> DrawContext m px () +fillWithTextureNoAA fillMethod texture els = do + img@(MutableImage width height _) <- get + let !mini = V2 0 0 + !maxi = V2 (fromIntegral width) (fromIntegral height) + !filler = primToPrim . transformTextureToFiller meshToImage texture img + clipped = foldMap (clip mini maxi) els + spans = rasterize fillMethod clipped + lift . mapExec (filler . toOpaqueCoverage) $ filter (isCoverageDrawable img) spans + +-- | Fill some geometry using a composition mask for visibility. +-- +-- > immediateDrawMaskExample :: Image PixelRGBA8 +-- > immediateDrawMaskExample = runST $ +-- > runDrawContext 200 200 (PixelRGBA8 0 0 0 255) $ +-- > forM_ [1 .. 10] $ \ix -> +-- > fillWithTextureAndMask FillWinding texture mask $ +-- > rectangle (V2 10 (ix * 18 - 5)) 180 13 +-- > where +-- > texture = uniformTexture $ PixelRGBA8 0 0x86 0xc1 255 +-- > mask = sampledImageTexture +-- > $ runST +-- > $ runDrawContext 200 200 0 +-- > $ fillWithTexture FillWinding (uniformTexture 255) maskGeometry +-- > +-- > maskGeometry = strokize 15 JoinRound (CapRound, CapRound) +-- > $ circle (V2 100 100) 80 +-- +-- <<docimages/immediate_mask.png>> +-- +fillWithTextureAndMask + :: (PrimMonad m, RenderablePixel px) + => FillMethod + -> Texture px -- ^ Color/Texture used for the filling of the geometry + -> Texture (PixelBaseComponent px) -- ^ Texture used for the mask. + -> [Primitive] -- ^ Primitives to fill + -> DrawContext m px () +fillWithTextureAndMask fillMethod texture mask els = do + img@(MutableImage width height _) <- get + let !mini = V2 0 0 + !maxi = V2 (fromIntegral width) (fromIntegral height) + spans = rasterize fillMethod $ foldMap (clip mini maxi) els + !shader = primToPrim + . transformTextureToFiller meshToImage (ModulateTexture texture mask) img + lift . mapM_ shader $ filter (isCoverageDrawable img) spans + +-- | Helper function transforming text range to draw order. +textToDrawOrders :: Dpi -- ^ Current output device resolution + -> Texture px -- ^ Texture to use if no texture is defined in the range + -> Point -- ^ Baseline position + -> [TextRange px] -- ^ Text description. + -> [DrawOrder px] +textToDrawOrders dpi defaultTexture (V2 x y) descriptions = + toOrder <$> zip floatCurves linearDescriptions where + + toOrder (curve, d) = DrawOrder + { _orderPrimitives = [beziersOfChar curve] + , _orderFillMethod = FillWinding + , _orderMask = Nothing + , _orderTexture = fromMaybe defaultTexture $ _textTexture d + , _orderDirect = return () + } + + floatCurves = + getStringCurveAtPoint dpi (x, y) + [(_textFont d, _textSize d, _text d) | d <- descriptions] + + linearDescriptions = + concat [map (const d) $ _text d | d <- descriptions] + + beziersOfChar curves = concat + [fmap BezierPrim . bezierFromPath . fmap (uncurry V2) $ VU.toList c | c <- curves] + + +meshToImage :: forall px. (RenderablePixel px) + => Maybe Transformation -> Int-> Int + -> PatchInterpolation -> MeshPatch px + -> Image px +meshToImage mayTrans width height i baseMesh + | not hasTransparency = rendering + | otherwise = runST $ runDrawContext width height background $ fillOrder order + where + mesh = case mayTrans >>= inverseTransformation of + Nothing -> baseMesh + Just trans -> + transform (applyTransformation trans) baseMesh + + background = emptyPx :: px + clipBackground = emptyValue :: PixelBaseComponent px + + rendering = runST $ runDrawContext width height background $ case i of + PatchBilinear -> mapM_ rasterizeCoonPatch $ coonPatchesOf opaqueMesh + PatchBicubic -> + mapM_ rasterizeCoonPatch + . cubicCoonPatchesOf + $ calculateMeshColorDerivative opaqueMesh + + hasTransparency = + F.any ((/= fullValue) . pixelOpacity) $ _meshColors mesh + + opacifier px = mixWithAlpha (\_ _ a -> a) (\_ _ -> fullValue) px px + + opaqueMesh = opacifier <$> mesh + transparencyMesh = pixelOpacity <$> mesh + + clipPath = + runST $ runDrawContext width height clipBackground $ case i of + PatchBilinear -> mapM_ rasterizeCoonPatch $ coonPatchesOf transparencyMesh + PatchBicubic -> + mapM_ rasterizeCoonPatch + . cubicCoonPatchesOf + $ calculateMeshColorDerivative transparencyMesh + + order = DrawOrder + { _orderPrimitives = [rectangle (V2 0 0) (fromIntegral width) (fromIntegral height)] + , _orderTexture = AlphaModulateTexture (RawTexture rendering) (RawTexture clipPath) + , _orderFillMethod = FillWinding + , _orderMask = Nothing + , _orderDirect = return () + }
src/Graphics/Rasterific/Lenses.hs view
@@ -1,146 +1,140 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE CPP #-}--- | This module provide lenses compatible with the `lens`--- module but without the dependency to it.-module Graphics.Rasterific.Lenses- ( -- * Line lenses- lineX0- , lineX1- , linePoints-- -- * Quadratic bezier curve- , bezX0- , bezX1- , bezX2- , bezierPoints-- -- * Cubic bezier lenses- , cbezX0- , cbezX1- , cbezX2- , cbezX3- , cubicBezierPoints-- -- * Primitive lenses- , primitivePoints-- -- * Path oriented lenses- , pathCommandPoints- , pathPoints-- -- * Type definition to match Lens- , Lens- , Lens'- , Traversal- , Traversal'- ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Traversable( traverse )-import Control.Applicative( Applicative, (<*>), (<$>), pure )-#endif--import Graphics.Rasterific.Types---- | Does it look familiar? yes it's the official--- Lens type.-type Lens s t a b =- forall f. Functor f => (a -> f b) -> s -> f t---- | Try to match the Lens' type alias.-type Lens' s a = Lens s s a a---- | Traversal type, matched to the one of the lens--- package.-type Traversal s t a b =- forall f. Applicative f => (a -> f b) -> s -> f t--type Traversal' s a = Traversal s s a a---- | Create a full lens out of setter and getter-lens :: (s -> a)- -> (s -> b -> t)- -> Lens s t a b-{-# INLINE lens #-}-lens accessor setter = \f src ->- fmap (setter src) $ f (accessor src)---- | Traverse all the points of a line.-linePoints :: Traversal' Line Point-linePoints f (Line p0 p1) = Line <$> f p0 <*> f p1---- | Line origin point.-lineX0 :: Lens' Line Point-lineX0 = lens _lineX0 setter where- setter a b = a { _lineX0 = b }---- | Line end point.-lineX1 :: Lens' Line Point-lineX1 = lens _lineX1 setter where- setter a b = a { _lineX1 = b }---- | Quadratic bezier starting point.-bezX0 :: Lens' Bezier Point-bezX0 = lens _bezierX0 setter where- setter a b = a { _bezierX0 = b }---- | bezier control point.-bezX1 :: Lens' Bezier Point-bezX1 = lens _bezierX1 setter where- setter a b = a { _bezierX1 = b }---- | bezier end point.-bezX2 :: Lens' Bezier Point-bezX2 = lens _bezierX2 setter where- setter a b = a { _bezierX2 = b }---- | Traversal of all the bezier's points.-bezierPoints :: Traversal' Bezier Point-bezierPoints f (Bezier p0 p1 p2) =- Bezier <$> f p0 <*> f p1 <*> f p2---- | Cubic bezier first point-cbezX0 :: Lens' CubicBezier Point-cbezX0 = lens _cBezierX0 setter where- setter a b = a { _cBezierX0 = b }---- | Cubic bezier first control point.-cbezX1 :: Lens' CubicBezier Point-cbezX1 = lens _cBezierX1 setter where- setter a b = a { _cBezierX1 = b }---- | Cubic bezier second control point.-cbezX2 :: Lens' CubicBezier Point-cbezX2 = lens _cBezierX2 setter where- setter a b = a { _cBezierX2 = b }---- | Cubic bezier last point.-cbezX3 :: Lens' CubicBezier Point-cbezX3 = lens _cBezierX2 setter where- setter a b = a { _cBezierX3 = b }---- | Traversal of all the points of the cubic bezier.-cubicBezierPoints :: Traversal' CubicBezier Point-cubicBezierPoints f (CubicBezier p0 p1 p2 p3) =- CubicBezier <$> f p0 <*> f p1 <*> f p2 <*> f p3---- | Traverse all the points defined in the primitive.-primitivePoints :: Traversal' Primitive Point-primitivePoints f (LinePrim l) = LinePrim <$> linePoints f l-primitivePoints f (BezierPrim b) = BezierPrim <$> bezierPoints f b-primitivePoints f (CubicBezierPrim c) =- CubicBezierPrim <$> cubicBezierPoints f c---- | Traversal of all the points of a path-pathCommandPoints :: Traversal' PathCommand Point-pathCommandPoints f (PathLineTo p) = PathLineTo <$> f p-pathCommandPoints f (PathQuadraticBezierCurveTo p1 p2) =- PathQuadraticBezierCurveTo <$> f p1 <*> f p2-pathCommandPoints f (PathCubicBezierCurveTo p1 p2 p3) =- PathCubicBezierCurveTo <$> f p1 <*> f p2 <*> f p3---- | Traversal of all the points in a path.-pathPoints :: Traversal' Path Point-pathPoints f (Path p0 yn comms) =- Path <$> f p0 <*> pure yn <*> traverse (pathCommandPoints f) comms-+{-# LANGUAGE RankNTypes #-} +-- | This module provide lenses compatible with the `lens` +-- module but without the dependency to it. +module Graphics.Rasterific.Lenses + ( -- * Line lenses + lineX0 + , lineX1 + , linePoints + + -- * Quadratic bezier curve + , bezX0 + , bezX1 + , bezX2 + , bezierPoints + + -- * Cubic bezier lenses + , cbezX0 + , cbezX1 + , cbezX2 + , cbezX3 + , cubicBezierPoints + + -- * Primitive lenses + , primitivePoints + + -- * Path oriented lenses + , pathCommandPoints + , pathPoints + + -- * Type definition to match Lens + , Lens + , Lens' + , Traversal + , Traversal' + ) where + +import Graphics.Rasterific.Types + +-- | Does it look familiar? yes it's the official +-- Lens type. +type Lens s t a b = + forall f. Functor f => (a -> f b) -> s -> f t + +-- | Try to match the Lens' type alias. +type Lens' s a = Lens s s a a + +-- | Traversal type, matched to the one of the lens +-- package. +type Traversal s t a b = + forall f. Applicative f => (a -> f b) -> s -> f t + +type Traversal' s a = Traversal s s a a + +-- | Create a full lens out of setter and getter +lens :: (s -> a) + -> (s -> b -> t) + -> Lens s t a b +{-# INLINE lens #-} +lens accessor setter = \f src -> + fmap (setter src) $ f (accessor src) + +-- | Traverse all the points of a line. +linePoints :: Traversal' Line Point +linePoints f (Line p0 p1) = Line <$> f p0 <*> f p1 + +-- | Line origin point. +lineX0 :: Lens' Line Point +lineX0 = lens _lineX0 setter where + setter a b = a { _lineX0 = b } + +-- | Line end point. +lineX1 :: Lens' Line Point +lineX1 = lens _lineX1 setter where + setter a b = a { _lineX1 = b } + +-- | Quadratic bezier starting point. +bezX0 :: Lens' Bezier Point +bezX0 = lens _bezierX0 setter where + setter a b = a { _bezierX0 = b } + +-- | bezier control point. +bezX1 :: Lens' Bezier Point +bezX1 = lens _bezierX1 setter where + setter a b = a { _bezierX1 = b } + +-- | bezier end point. +bezX2 :: Lens' Bezier Point +bezX2 = lens _bezierX2 setter where + setter a b = a { _bezierX2 = b } + +-- | Traversal of all the bezier's points. +bezierPoints :: Traversal' Bezier Point +bezierPoints f (Bezier p0 p1 p2) = + Bezier <$> f p0 <*> f p1 <*> f p2 + +-- | Cubic bezier first point +cbezX0 :: Lens' CubicBezier Point +cbezX0 = lens _cBezierX0 setter where + setter a b = a { _cBezierX0 = b } + +-- | Cubic bezier first control point. +cbezX1 :: Lens' CubicBezier Point +cbezX1 = lens _cBezierX1 setter where + setter a b = a { _cBezierX1 = b } + +-- | Cubic bezier second control point. +cbezX2 :: Lens' CubicBezier Point +cbezX2 = lens _cBezierX2 setter where + setter a b = a { _cBezierX2 = b } + +-- | Cubic bezier last point. +cbezX3 :: Lens' CubicBezier Point +cbezX3 = lens _cBezierX2 setter where + setter a b = a { _cBezierX3 = b } + +-- | Traversal of all the points of the cubic bezier. +cubicBezierPoints :: Traversal' CubicBezier Point +cubicBezierPoints f (CubicBezier p0 p1 p2 p3) = + CubicBezier <$> f p0 <*> f p1 <*> f p2 <*> f p3 + +-- | Traverse all the points defined in the primitive. +primitivePoints :: Traversal' Primitive Point +primitivePoints f (LinePrim l) = LinePrim <$> linePoints f l +primitivePoints f (BezierPrim b) = BezierPrim <$> bezierPoints f b +primitivePoints f (CubicBezierPrim c) = + CubicBezierPrim <$> cubicBezierPoints f c + +-- | Traversal of all the points of a path +pathCommandPoints :: Traversal' PathCommand Point +pathCommandPoints f (PathLineTo p) = PathLineTo <$> f p +pathCommandPoints f (PathQuadraticBezierCurveTo p1 p2) = + PathQuadraticBezierCurveTo <$> f p1 <*> f p2 +pathCommandPoints f (PathCubicBezierCurveTo p1 p2 p3) = + PathCubicBezierCurveTo <$> f p1 <*> f p2 <*> f p3 + +-- | Traversal of all the points in a path. +pathPoints :: Traversal' Path Point +pathPoints f (Path p0 yn comms) = + Path <$> f p0 <*> pure yn <*> traverse (pathCommandPoints f) comms +
src/Graphics/Rasterific/Line.hs view
@@ -1,179 +1,173 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}--- | Handle straight lines polygon.-module Graphics.Rasterific.Line- ( lineFromPath- , decomposeLine- , clipLine- , sanitizeLine- , lineBreakAt- , flattenLine- , lineLength- , offsetLine- , isLinePoint- , extendLine- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( pure, (<$>) )-import Data.Monoid( mempty )-#endif--import Data.Monoid( (<>) )--import Graphics.Rasterific.Linear- ( V2( .. )- , (^-^)- , (^+^)- , (^*)- , lerp- , norm )--import Graphics.Rasterific.Operators-import Graphics.Rasterific.Types---- | Transform a list a point to a list of lines------ > lineFromPath [a, b, c, d] = [Line a b, Line b c, Line c d]----lineFromPath :: [Point] -> [Line]-lineFromPath [] = []-lineFromPath lst@(_:rest) =- uncurry Line <$> zip lst rest--isLinePoint :: Line -> Bool-isLinePoint (Line a b) = not $ a `isDistingableFrom` b--lineLength :: Line -> Float-lineLength (Line a b) = norm (b ^-^ a)--sanitizeLine :: Line -> Container Primitive-sanitizeLine l@(Line p1 p2)- | p1 `isNearby` p2 = mempty- | otherwise = pure $ LinePrim l--lineBreakAt :: Line -> Float -> (Line, Line)-lineBreakAt (Line a b) t = (Line a ab, Line ab b)- where ab = lerp t b a--flattenLine :: Line -> Container Primitive-flattenLine = pure . LinePrim--offsetLine :: Float -> Line -> Container Primitive-offsetLine offset (Line a b) = pure . LinePrim $ Line shiftedA shiftedB- where- u = a `normal` b- shiftedA = a ^+^ (u ^* offset)- shiftedB = b ^+^ (u ^* offset)---- | Clamp the bezier curve inside a rectangle--- given in parameter.-clipLine :: Point -- ^ Point representing the "minimal" point for cliping- -> Point -- ^ Point representing the "maximal" point for cliping- -> Line -- ^ The line- -> Container Primitive-clipLine mini maxi poly@(Line a b)- -- If we are in the range bound, return the curve- -- unaltered- | insideX && insideY = pure . LinePrim $ poly- -- If one of the component is outside, clamp- -- the components on the boundaries and output a- -- straight line on this boundary. Useful for the- -- filing case, to clamp the polygon drawing on- -- the edge- | outsideX || outsideY = pure . LinePrim $ Line clampedA clampedB-- -- Not completly inside nor outside, just divide- -- and conquer.- | otherwise = recurse (Line a m) <> recurse (Line m b)- where -- Minimal & maximal dimension of the bezier curve- bmin = vmin a b- bmax = vmax a b-- recurse = clipLine mini maxi-- clamper = clampPoint mini maxi- clampedA = clamper a- clampedB = clamper b-- V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi- V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin-- -- A X-----X-----X B- -- AB- ab = a `midPoint` b-- -- mini- -- +-------------+- -- | |- -- | |- -- | |- -- +-------------+- -- maxi- -- the edgeSeparator vector encode which edge- -- is te nearest to the midpoint.- -- if True then it's the 'min' edges which are- -- the nearest, otherwise it's the maximum edge- edgeSeparator =- vabs (ab ^-^ mini) ^<^ vabs (ab ^-^ maxi)-- -- So here we 'solidify' the nearest edge position- -- in an edge vector.- edge = vpartition edgeSeparator mini maxi-- -- If we're near an edge, snap the component to the- -- edge.- m = vpartition (vabs (ab ^-^ edge) ^< 0.1) edge ab---- TODO: implement better algorithm for lines, should--- be doable.-decomposeLine :: Line -> Producer EdgeSample-decomposeLine (Line (V2 aRx aRy) (V2 bRx bRy)) = go aRx aRy bRx bRy where- go !ax !ay !bx !by cont- | insideX && insideY =- let !px = fromIntegral $ min floorAx floorBx- !py = fromIntegral $ min floorAy floorBy- !w = px + 1 - (bx `middle` ax)- !h = by - ay- in- EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont- where- floorAx, floorAy :: Int- !floorAx = floor ax- !floorAy = floor ay-- !floorBx = floor bx- !floorBy = floor by-- !insideX = floorAx == floorBx || ceiling ax == (ceiling bx :: Int)- !insideY = floorAy == floorBy || ceiling ay == (ceiling by :: Int)--- go !ax !ay !bx !by cont = go ax ay mx my $ go mx my bx by cont- where- !abx = ax `middle` bx- !aby = ay `middle` by-- !mx | abs (abx - mini) < 0.1 = mini- | abs (abx - maxi) < 0.1 = maxi- | otherwise = abx- where !mini = fromIntegral (floor abx :: Int)- !maxi = fromIntegral (ceiling abx :: Int)-- !my | abs (aby - mini) < 0.1 = mini- | abs (aby - maxi) < 0.1 = maxi- | otherwise = aby- where !mini = fromIntegral (floor aby :: Int)- !maxi = fromIntegral (ceiling aby :: Int)---- | Extend a line by two coefficient, giving a line that's a--- linear extension of the original line.------ law: extendLine 0 1 = id-extendLine :: Float -- ^ Begin extension coefficient- -> Float -- ^ End extension coefficient- -> Line -- ^ Line to transform- -> Line-extendLine beg end (Line p1 p2) =- Line (lerp beg p2 p1) (lerp end p2 p1)-+{-# LANGUAGE BangPatterns #-} +-- | Handle straight lines polygon. +module Graphics.Rasterific.Line + ( lineFromPath + , decomposeLine + , clipLine + , sanitizeLine + , lineBreakAt + , flattenLine + , lineLength + , offsetLine + , isLinePoint + , extendLine + ) where + +import Data.Monoid( (<>) ) + +import Graphics.Rasterific.Linear + ( V2( .. ) + , (^-^) + , (^+^) + , (^*) + , lerp + , norm ) + +import Graphics.Rasterific.Operators +import Graphics.Rasterific.Types + +-- | Transform a list a point to a list of lines +-- +-- > lineFromPath [a, b, c, d] = [Line a b, Line b c, Line c d] +-- +lineFromPath :: [Point] -> [Line] +lineFromPath [] = [] +lineFromPath lst@(_:rest) = + uncurry Line <$> zip lst rest + +isLinePoint :: Line -> Bool +isLinePoint (Line a b) = not $ a `isDistingableFrom` b + +lineLength :: Line -> Float +lineLength (Line a b) = norm (b ^-^ a) + +sanitizeLine :: Line -> Container Primitive +sanitizeLine l@(Line p1 p2) + | p1 `isNearby` p2 = mempty + | otherwise = pure $ LinePrim l + +lineBreakAt :: Line -> Float -> (Line, Line) +lineBreakAt (Line a b) t = (Line a ab, Line ab b) + where ab = lerp t b a + +flattenLine :: Line -> Container Primitive +flattenLine = pure . LinePrim + +offsetLine :: Float -> Line -> Container Primitive +offsetLine offset (Line a b) = pure . LinePrim $ Line shiftedA shiftedB + where + u = a `normal` b + shiftedA = a ^+^ (u ^* offset) + shiftedB = b ^+^ (u ^* offset) + +-- | Clamp the bezier curve inside a rectangle +-- given in parameter. +clipLine :: Point -- ^ Point representing the "minimal" point for cliping + -> Point -- ^ Point representing the "maximal" point for cliping + -> Line -- ^ The line + -> Container Primitive +clipLine mini maxi poly@(Line a b) + -- If we are in the range bound, return the curve + -- unaltered + | insideX && insideY = pure . LinePrim $ poly + -- If one of the component is outside, clamp + -- the components on the boundaries and output a + -- straight line on this boundary. Useful for the + -- filing case, to clamp the polygon drawing on + -- the edge + | outsideX || outsideY = pure . LinePrim $ Line clampedA clampedB + + -- Not completly inside nor outside, just divide + -- and conquer. + | otherwise = recurse (Line a m) <> recurse (Line m b) + where -- Minimal & maximal dimension of the bezier curve + bmin = vmin a b + bmax = vmax a b + + recurse = clipLine mini maxi + + clamper = clampPoint mini maxi + clampedA = clamper a + clampedB = clamper b + + V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi + V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin + + -- A X-----X-----X B + -- AB + ab = a `midPoint` b + + -- mini + -- +-------------+ + -- | | + -- | | + -- | | + -- +-------------+ + -- maxi + -- the edgeSeparator vector encode which edge + -- is te nearest to the midpoint. + -- if True then it's the 'min' edges which are + -- the nearest, otherwise it's the maximum edge + edgeSeparator = + vabs (ab ^-^ mini) ^<^ vabs (ab ^-^ maxi) + + -- So here we 'solidify' the nearest edge position + -- in an edge vector. + edge = vpartition edgeSeparator mini maxi + + -- If we're near an edge, snap the component to the + -- edge. + m = vpartition (vabs (ab ^-^ edge) ^< 0.1) edge ab + +-- TODO: implement better algorithm for lines, should +-- be doable. +decomposeLine :: Line -> Producer EdgeSample +decomposeLine (Line (V2 aRx aRy) (V2 bRx bRy)) = go aRx aRy bRx bRy where + go !ax !ay !bx !by cont + | insideX && insideY = + let !px = fromIntegral $ min floorAx floorBx + !py = fromIntegral $ min floorAy floorBy + !w = px + 1 - (bx `middle` ax) + !h = by - ay + in + EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont + where + floorAx, floorAy :: Int + !floorAx = floor ax + !floorAy = floor ay + + !floorBx = floor bx + !floorBy = floor by + + !insideX = floorAx == floorBx || ceiling ax == (ceiling bx :: Int) + !insideY = floorAy == floorBy || ceiling ay == (ceiling by :: Int) + + + go !ax !ay !bx !by cont = go ax ay mx my $ go mx my bx by cont + where + !abx = ax `middle` bx + !aby = ay `middle` by + + !mx | abs (abx - mini) < 0.1 = mini + | abs (abx - maxi) < 0.1 = maxi + | otherwise = abx + where !mini = fromIntegral (floor abx :: Int) + !maxi = fromIntegral (ceiling abx :: Int) + + !my | abs (aby - mini) < 0.1 = mini + | abs (aby - maxi) < 0.1 = maxi + | otherwise = aby + where !mini = fromIntegral (floor aby :: Int) + !maxi = fromIntegral (ceiling aby :: Int) + +-- | Extend a line by two coefficient, giving a line that's a +-- linear extension of the original line. +-- +-- law: extendLine 0 1 = id +extendLine :: Float -- ^ Begin extension coefficient + -> Float -- ^ End extension coefficient + -> Line -- ^ Line to transform + -> Line +extendLine beg end (Line p1 p2) = + Line (lerp beg p2 p1) (lerp end p2 p1) +
src/Graphics/Rasterific/Linear.hs view
@@ -1,416 +1,409 @@--- | This module is a reduction of the `Linear` package--- from Edward Kmett to match just the need of Rasterific.------ If the flag `embed_linear` is disabled, this module is--- just a reexport from the real linear package.----{-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Graphics.Rasterific.Linear- ( V1( .. )- , V2( .. )- , V3( .. )- , V4( .. )- , R1( .. )- , R2( .. )- , Additive( .. )- , Epsilon( .. )- , Metric( .. )- , (^*)- , (^/)- , normalize- ) where--#ifdef EXTERNAL_LINEAR--- We just reexport-import Linear-#else--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( Applicative, pure, (<$>), (<*>) )-import Data.Monoid( mappend )-import Data.Foldable( Foldable( .. ) )-import Data.Traversable( Traversable( .. ) )-#endif--import Graphics.Rasterific.MiniLens--infixl 6 ^+^, ^-^-infixl 7 ^*, ^/---- | A 2-dimensional vector------ >>> pure 1 :: V2 Int--- V2 1 1------ >>> V2 1 2 + V2 3 4--- V2 4 6------ >>> V2 1 2 * V2 3 4--- V2 3 8------ >>> sum (V2 1 2)--- 3-data V2 a = V2 !a !a- deriving (Eq, Show)---- | A 3-dimensional vector-data V3 a = V3 !a !a !a- deriving (Eq, Show)---- | A 4-dimensional vector-data V4 a = V4 !a !a !a !a- deriving (Eq, Show)--class R1 t where- _x :: Lens' (t a) a--class R2 t where- _y :: Lens' (t a) a--instance R1 V1 where- _x = lens (\(V1 a) -> a) (\_ -> V1)--instance R1 V2 where- _x = lens (\(V2 x _) -> x) (\(V2 _ y) x -> V2 x y)--instance R2 V2 where- _y = lens (\(V2 _ y) -> y) (\(V2 x _) y -> V2 x y)--instance R1 V3 where- _x = lens (\(V3 x _ _) -> x) (\(V3 _ y z) x -> V3 x y z)--instance R2 V3 where- _y = lens (\(V3 _ y _) -> y) (\(V3 x _ z) y -> V3 x y z)--instance R1 V4 where- _x = lens (\(V4 x _ _ _) -> x) (\(V4 _ y z w) x -> V4 x y z w)--instance R2 V4 where- _y = lens (\(V4 _ y _ _) -> y) (\(V4 x _ z w) y -> V4 x y z w)---- | A 1-dimensional vector-newtype V1 a = V1 a- deriving (Eq, Show, Num)--instance Functor V1 where- {-# INLINE fmap #-}- fmap f (V1 a) = V1 $ f a--instance Functor V2 where- {-# INLINE fmap #-}- fmap f (V2 a b) = V2 (f a) (f b)--instance Functor V3 where- {-# INLINE fmap #-}- fmap f (V3 a b c) = V3 (f a) (f b) (f c)--instance Functor V4 where- {-# INLINE fmap #-}- fmap f (V4 a b c d) = V4 (f a) (f b) (f c) (f d)--instance Foldable V3 where- foldMap f (V3 a b c) = f a `mappend` f b `mappend` f c- {-# INLINE foldMap #-}--instance Traversable V3 where- traverse f (V3 a b c) = V3 <$> f a <*> f b <*> f c- {-# INLINE traverse #-}--instance Foldable V2 where- foldMap f (V2 a b) = f a `mappend` f b- {-# INLINE foldMap #-}--instance Traversable V2 where- traverse f (V2 a b) = V2 <$> f a <*> f b- {-# INLINE traverse #-}--instance Foldable V4 where- foldMap f (V4 a b c d) = f a `mappend` f b `mappend` f c `mappend` f d- {-# INLINE foldMap #-}--instance Traversable V4 where- traverse f (V4 a b c d) = V4 <$> f a <*> f b <*> f c <*> f d- {-# INLINE traverse #-}--instance Foldable V1 where- foldMap f (V1 a) = f a- {-# INLINE foldMap #-}--instance Traversable V1 where- traverse f (V1 a) = V1 <$> f a- {-# INLINE traverse #-}--instance Num a => Num (V2 a) where- (V2 a b) + (V2 a' b') = V2 (a + a') (b + b')- {-# INLINE (+) #-}- (V2 a b) - (V2 a' b') = V2 (a - a') (b - b')- {-# INLINE (-) #-}- (V2 a b) * (V2 a' b') = V2 (a * a') (b * b')- {-# INLINE (*) #-}- negate (V2 a b) = V2 (negate a) (negate b)- {-# INLINE negate #-}- abs (V2 a b) = V2 (abs a) (abs b)- {-# INLINE abs #-}- signum (V2 a b) = V2 (signum a) (signum b)- {-# INLINE signum #-}- fromInteger = pure . fromInteger- {-# INLINE fromInteger #-}--instance Num a => Num (V3 a) where- (V3 a b c) + (V3 a' b' c') = V3 (a + a') (b + b') (c + c')- {-# INLINE (+) #-}- (V3 a b c) - (V3 a' b' c') = V3 (a - a') (b - b') (c - c')- {-# INLINE (-) #-}- (V3 a b c) * (V3 a' b' c') = V3 (a * a') (b * b') (c * c')- {-# INLINE (*) #-}- negate (V3 a b c) = V3 (negate a) (negate b) (negate c)- {-# INLINE negate #-}- abs (V3 a b c) = V3 (abs a) (abs b) (abs c)- {-# INLINE abs #-}- signum (V3 a b c) = V3 (signum a) (signum b) (signum c)- {-# INLINE signum #-}- fromInteger = pure . fromInteger- {-# INLINE fromInteger #-}--instance Num a => Num (V4 a) where- (V4 a b c d) + (V4 a' b' c' d') = V4 (a + a') (b + b') (c + c') (d + d')- {-# INLINE (+) #-}- (V4 a b c d) - (V4 a' b' c' d') = V4 (a - a') (b - b') (c - c') (d - d')- {-# INLINE (-) #-}- (V4 a b c d) * (V4 a' b' c' d') = V4 (a * a') (b * b') (c * c') (d * d')- {-# INLINE (*) #-}- negate (V4 a b c d) = V4 (negate a) (negate b) (negate c) (negate d)- {-# INLINE negate #-}- abs (V4 a b c d) = V4 (abs a) (abs b) (abs c) (abs d)- {-# INLINE abs #-}- signum (V4 a b c d) = V4 (signum a) (signum b) (signum c) (signum d)- {-# INLINE signum #-}- fromInteger = pure . fromInteger- {-# INLINE fromInteger #-}--instance Applicative V4 where- {-# INLINE pure #-}- pure a = V4 a a a a- {-# INLINE (<*>) #-}- (V4 f1 f2 f3 f4) <*> (V4 a b c d) = V4 (f1 a) (f2 b) (f3 c) (f4 d)--instance Applicative V3 where- {-# INLINE pure #-}- pure a = V3 a a a- {-# INLINE (<*>) #-}- (V3 f1 f2 f3) <*> (V3 a b c) = V3 (f1 a) (f2 b) (f3 c)--instance Applicative V2 where- {-# INLINE pure #-}- pure a = V2 a a- {-# INLINE (<*>) #-}- (V2 f1 f2) <*> (V2 a b) = V2 (f1 a) (f2 b)--instance Applicative V1 where- {-# INLINE pure #-}- pure = V1 - {-# INLINE (<*>) #-}- (V1 f) <*> (V1 v) = V1 $ f v---- | A vector is an additive group with additional structure.-class Functor f => Additive f where- -- | The zero vector- zero :: Num a => f a- -- | Compute the sum of two vectors- --- -- >>> V2 1 2 ^+^ V2 3 4- -- V2 4 6- (^+^) :: Num a => f a -> f a -> f a-- -- | Compute the difference between two vectors- --- -- >>> V2 4 5 - V2 3 1- -- V2 1 4- (^-^) :: Num a => f a -> f a -> f a-- -- | Linearly interpolate between two vectors.- lerp :: Num a => a -> f a -> f a -> f a---- | Provides a fairly subjective test to see if a quantity is near zero.------ >>> nearZero (1e-11 :: Double)--- False------ >>> nearZero (1e-17 :: Double)--- True------ >>> nearZero (1e-5 :: Float)--- False------ >>> nearZero (1e-7 :: Float)--- True-class Num a => Epsilon a where- -- | Determine if a quantity is near zero.- nearZero :: a -> Bool---- | @'abs' a '<=' 1e-6@-instance Epsilon Float where- nearZero a = abs a <= 1e-6- {-# INLINE nearZero #-}---- | @'abs' a '<=' 1e-12@-instance Epsilon Double where- nearZero a = abs a <= 1e-12- {-# INLINE nearZero #-}--instance Epsilon a => Epsilon (V4 a) where- nearZero = nearZero . quadrance- {-# INLINE nearZero #-}--instance Epsilon a => Epsilon (V3 a) where- nearZero = nearZero . quadrance- {-# INLINE nearZero #-}--instance Epsilon a => Epsilon (V2 a) where- nearZero = nearZero . quadrance- {-# INLINE nearZero #-}--instance Epsilon a => Epsilon (V1 a) where- nearZero (V1 a) = nearZero a- {-# INLINE nearZero #-}--instance Additive V4 where- zero = V4 0 0 0 0- {-# INLINE zero #-}-- (V4 a b c d) ^+^ (V4 a' b' c' d') = V4 (a + a') (b + b') (c + c') (d + d')- {-# INLINE (^+^) #-}-- (V4 a b c d) ^-^ (V4 a' b' c' d') = V4 (a - a') (b - b') (c + c') (d + d')- {-# INLINE (^-^) #-}- lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha)- {-# INLINE lerp #-}--instance Additive V3 where- zero = V3 0 0 0- {-# INLINE zero #-}-- (V3 a b c) ^+^ (V3 a' b' c') = V3 (a + a') (b + b') (c + c')- {-# INLINE (^+^) #-}-- (V3 a b c) ^-^ (V3 a' b' c') = V3 (a - a') (b - b') (c + c')- {-# INLINE (^-^) #-}-- lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha)- {-# INLINE lerp #-}--instance Additive V2 where- zero = V2 0 0- {-# INLINE zero #-}-- (V2 a b) ^+^ (V2 a' b') = V2 (a + a') (b + b')- {-# INLINE (^+^) #-}-- (V2 a b) ^-^ (V2 a' b') = V2 (a - a') (b - b')- {-# INLINE (^-^) #-}-- lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha)- {-# INLINE lerp #-}--instance Additive V1 where- zero = V1 0- {-# INLINE zero #-}-- (V1 a) ^+^ (V1 a') = V1 (a + a')- {-# INLINE (^+^) #-}-- (V1 a) ^-^ (V1 a') = V1 (a - a')- {-# INLINE (^-^) #-}-- lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha)- {-# INLINE lerp #-}---- | Free and sparse inner product/metric spaces.-class Additive f => Metric f where- -- | Compute the inner product of two vectors or (equivalently)- -- convert a vector @f a@ into a covector @f a -> a@.- --- -- >>> V2 1 2 `dot` V2 3 4- -- 11- dot :: Num a => f a -> f a -> a-- -- | Compute the squared norm. The name quadrance arises from- -- Norman J. Wildberger's rational trigonometry.- quadrance :: Num a => f a -> a- {-# INLINE quadrance #-}- quadrance v = dot v v-- -- | Compute the quadrance of the difference- qd :: Num a => f a -> f a -> a- {-# INLINE qd #-}- qd f g = quadrance (f ^-^ g)-- -- | Compute the distance between two vectors in a metric space- distance :: Floating a => f a -> f a -> a- {-# INLINE distance #-}- distance f g = norm (f ^-^ g)-- -- | Compute the norm of a vector in a metric space- norm :: Floating a => f a -> a- {-# INLINE norm #-}- norm v = sqrt (quadrance v)-- -- | Convert a non-zero vector to unit vector.- signorm :: Floating a => f a -> f a- signorm v = fmap (/ m) v where- m = norm v--instance Metric V4 where- dot (V4 a b c d) (V4 a' b' c' d') = a * a' + b * b' + c * c' + d * d'- {-# INLINE dot #-}-- quadrance (V4 a b c d) = a * a + b * b + c * c + d * d- {-# INLINE quadrance #-}-- norm v = sqrt (quadrance v)- {-# INLINE norm #-}--instance Metric V3 where- dot (V3 a b c) (V3 a' b' c') = a * a' + b * b' + c * c'- {-# INLINE dot #-}-- quadrance (V3 a b c) = a * a + b * b + c * c- {-# INLINE quadrance #-}-- norm v = sqrt (quadrance v)- {-# INLINE norm #-}--instance Metric V2 where- dot (V2 a b) (V2 a' b') = a * a' + b * b'- {-# INLINE dot #-}-- quadrance (V2 a b) = a * a + b * b- {-# INLINE quadrance #-}-- norm v = sqrt (quadrance v)- {-# INLINE norm #-}---- | Compute the right scalar product------ >>> V2 3 4 ^* 2--- V2 6 8-(^*) :: (Functor f, Num a) => f a -> a -> f a-{-# INLINE (^*) #-}-(^*) f n = fmap (* n) f---- | Compute division by a scalar on the right.-(^/) :: (Functor f, Floating a) => f a -> a -> f a-{-# INLINE (^/) #-}-(^/) f n = fmap (/ n) f---- | Normalize a 'Metric' functor to have unit 'norm'. This function--- does not change the functor if its 'norm' is 0 or 1.-normalize :: (Floating a, Metric f, Epsilon a) => f a -> f a-{-# INLINE normalize #-}-normalize v = if nearZero l || nearZero (1-l) then v- else fmap (/ sqrt l) v- where l = quadrance v--#endif-+-- | This module is a reduction of the `Linear` package +-- from Edward Kmett to match just the need of Rasterific. +-- +-- If the flag `embed_linear` is disabled, this module is +-- just a reexport from the real linear package. +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +module Graphics.Rasterific.Linear + ( V1( .. ) + , V2( .. ) + , V3( .. ) + , V4( .. ) + , R1( .. ) + , R2( .. ) + , Additive( .. ) + , Epsilon( .. ) + , Metric( .. ) + , (^*) + , (^/) + , normalize + ) where + +#ifdef EXTERNAL_LINEAR +-- We just reexport +import Linear +#else + +import Graphics.Rasterific.MiniLens + +infixl 6 ^+^, ^-^ +infixl 7 ^*, ^/ + +-- | A 2-dimensional vector +-- +-- >>> pure 1 :: V2 Int +-- V2 1 1 +-- +-- >>> V2 1 2 + V2 3 4 +-- V2 4 6 +-- +-- >>> V2 1 2 * V2 3 4 +-- V2 3 8 +-- +-- >>> sum (V2 1 2) +-- 3 +data V2 a = V2 !a !a + deriving (Eq, Show) + +-- | A 3-dimensional vector +data V3 a = V3 !a !a !a + deriving (Eq, Show) + +-- | A 4-dimensional vector +data V4 a = V4 !a !a !a !a + deriving (Eq, Show) + +class R1 t where + _x :: Lens' (t a) a + +class R2 t where + _y :: Lens' (t a) a + +instance R1 V1 where + _x = lens (\(V1 a) -> a) (\_ -> V1) + +instance R1 V2 where + _x = lens (\(V2 x _) -> x) (\(V2 _ y) x -> V2 x y) + +instance R2 V2 where + _y = lens (\(V2 _ y) -> y) (\(V2 x _) y -> V2 x y) + +instance R1 V3 where + _x = lens (\(V3 x _ _) -> x) (\(V3 _ y z) x -> V3 x y z) + +instance R2 V3 where + _y = lens (\(V3 _ y _) -> y) (\(V3 x _ z) y -> V3 x y z) + +instance R1 V4 where + _x = lens (\(V4 x _ _ _) -> x) (\(V4 _ y z w) x -> V4 x y z w) + +instance R2 V4 where + _y = lens (\(V4 _ y _ _) -> y) (\(V4 x _ z w) y -> V4 x y z w) + +-- | A 1-dimensional vector +newtype V1 a = V1 a + deriving (Eq, Show, Num) + +instance Functor V1 where + {-# INLINE fmap #-} + fmap f (V1 a) = V1 $ f a + +instance Functor V2 where + {-# INLINE fmap #-} + fmap f (V2 a b) = V2 (f a) (f b) + +instance Functor V3 where + {-# INLINE fmap #-} + fmap f (V3 a b c) = V3 (f a) (f b) (f c) + +instance Functor V4 where + {-# INLINE fmap #-} + fmap f (V4 a b c d) = V4 (f a) (f b) (f c) (f d) + +instance Foldable V3 where + foldMap f (V3 a b c) = f a `mappend` f b `mappend` f c + {-# INLINE foldMap #-} + +instance Traversable V3 where + traverse f (V3 a b c) = V3 <$> f a <*> f b <*> f c + {-# INLINE traverse #-} + +instance Foldable V2 where + foldMap f (V2 a b) = f a `mappend` f b + {-# INLINE foldMap #-} + +instance Traversable V2 where + traverse f (V2 a b) = V2 <$> f a <*> f b + {-# INLINE traverse #-} + +instance Foldable V4 where + foldMap f (V4 a b c d) = f a `mappend` f b `mappend` f c `mappend` f d + {-# INLINE foldMap #-} + +instance Traversable V4 where + traverse f (V4 a b c d) = V4 <$> f a <*> f b <*> f c <*> f d + {-# INLINE traverse #-} + +instance Foldable V1 where + foldMap f (V1 a) = f a + {-# INLINE foldMap #-} + +instance Traversable V1 where + traverse f (V1 a) = V1 <$> f a + {-# INLINE traverse #-} + +instance Num a => Num (V2 a) where + (V2 a b) + (V2 a' b') = V2 (a + a') (b + b') + {-# INLINE (+) #-} + (V2 a b) - (V2 a' b') = V2 (a - a') (b - b') + {-# INLINE (-) #-} + (V2 a b) * (V2 a' b') = V2 (a * a') (b * b') + {-# INLINE (*) #-} + negate (V2 a b) = V2 (negate a) (negate b) + {-# INLINE negate #-} + abs (V2 a b) = V2 (abs a) (abs b) + {-# INLINE abs #-} + signum (V2 a b) = V2 (signum a) (signum b) + {-# INLINE signum #-} + fromInteger = pure . fromInteger + {-# INLINE fromInteger #-} + +instance Num a => Num (V3 a) where + (V3 a b c) + (V3 a' b' c') = V3 (a + a') (b + b') (c + c') + {-# INLINE (+) #-} + (V3 a b c) - (V3 a' b' c') = V3 (a - a') (b - b') (c - c') + {-# INLINE (-) #-} + (V3 a b c) * (V3 a' b' c') = V3 (a * a') (b * b') (c * c') + {-# INLINE (*) #-} + negate (V3 a b c) = V3 (negate a) (negate b) (negate c) + {-# INLINE negate #-} + abs (V3 a b c) = V3 (abs a) (abs b) (abs c) + {-# INLINE abs #-} + signum (V3 a b c) = V3 (signum a) (signum b) (signum c) + {-# INLINE signum #-} + fromInteger = pure . fromInteger + {-# INLINE fromInteger #-} + +instance Num a => Num (V4 a) where + (V4 a b c d) + (V4 a' b' c' d') = V4 (a + a') (b + b') (c + c') (d + d') + {-# INLINE (+) #-} + (V4 a b c d) - (V4 a' b' c' d') = V4 (a - a') (b - b') (c - c') (d - d') + {-# INLINE (-) #-} + (V4 a b c d) * (V4 a' b' c' d') = V4 (a * a') (b * b') (c * c') (d * d') + {-# INLINE (*) #-} + negate (V4 a b c d) = V4 (negate a) (negate b) (negate c) (negate d) + {-# INLINE negate #-} + abs (V4 a b c d) = V4 (abs a) (abs b) (abs c) (abs d) + {-# INLINE abs #-} + signum (V4 a b c d) = V4 (signum a) (signum b) (signum c) (signum d) + {-# INLINE signum #-} + fromInteger = pure . fromInteger + {-# INLINE fromInteger #-} + +instance Applicative V4 where + {-# INLINE pure #-} + pure a = V4 a a a a + {-# INLINE (<*>) #-} + (V4 f1 f2 f3 f4) <*> (V4 a b c d) = V4 (f1 a) (f2 b) (f3 c) (f4 d) + +instance Applicative V3 where + {-# INLINE pure #-} + pure a = V3 a a a + {-# INLINE (<*>) #-} + (V3 f1 f2 f3) <*> (V3 a b c) = V3 (f1 a) (f2 b) (f3 c) + +instance Applicative V2 where + {-# INLINE pure #-} + pure a = V2 a a + {-# INLINE (<*>) #-} + (V2 f1 f2) <*> (V2 a b) = V2 (f1 a) (f2 b) + +instance Applicative V1 where + {-# INLINE pure #-} + pure = V1 + {-# INLINE (<*>) #-} + (V1 f) <*> (V1 v) = V1 $ f v + +-- | A vector is an additive group with additional structure. +class Functor f => Additive f where + -- | The zero vector + zero :: Num a => f a + -- | Compute the sum of two vectors + -- + -- >>> V2 1 2 ^+^ V2 3 4 + -- V2 4 6 + (^+^) :: Num a => f a -> f a -> f a + + -- | Compute the difference between two vectors + -- + -- >>> V2 4 5 - V2 3 1 + -- V2 1 4 + (^-^) :: Num a => f a -> f a -> f a + + -- | Linearly interpolate between two vectors. + lerp :: Num a => a -> f a -> f a -> f a + +-- | Provides a fairly subjective test to see if a quantity is near zero. +-- +-- >>> nearZero (1e-11 :: Double) +-- False +-- +-- >>> nearZero (1e-17 :: Double) +-- True +-- +-- >>> nearZero (1e-5 :: Float) +-- False +-- +-- >>> nearZero (1e-7 :: Float) +-- True +class Num a => Epsilon a where + -- | Determine if a quantity is near zero. + nearZero :: a -> Bool + +-- | @'abs' a '<=' 1e-6@ +instance Epsilon Float where + nearZero a = abs a <= 1e-6 + {-# INLINE nearZero #-} + +-- | @'abs' a '<=' 1e-12@ +instance Epsilon Double where + nearZero a = abs a <= 1e-12 + {-# INLINE nearZero #-} + +instance Epsilon a => Epsilon (V4 a) where + nearZero = nearZero . quadrance + {-# INLINE nearZero #-} + +instance Epsilon a => Epsilon (V3 a) where + nearZero = nearZero . quadrance + {-# INLINE nearZero #-} + +instance Epsilon a => Epsilon (V2 a) where + nearZero = nearZero . quadrance + {-# INLINE nearZero #-} + +instance Epsilon a => Epsilon (V1 a) where + nearZero (V1 a) = nearZero a + {-# INLINE nearZero #-} + +instance Additive V4 where + zero = V4 0 0 0 0 + {-# INLINE zero #-} + + (V4 a b c d) ^+^ (V4 a' b' c' d') = V4 (a + a') (b + b') (c + c') (d + d') + {-# INLINE (^+^) #-} + + (V4 a b c d) ^-^ (V4 a' b' c' d') = V4 (a - a') (b - b') (c + c') (d + d') + {-# INLINE (^-^) #-} + lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha) + {-# INLINE lerp #-} + +instance Additive V3 where + zero = V3 0 0 0 + {-# INLINE zero #-} + + (V3 a b c) ^+^ (V3 a' b' c') = V3 (a + a') (b + b') (c + c') + {-# INLINE (^+^) #-} + + (V3 a b c) ^-^ (V3 a' b' c') = V3 (a - a') (b - b') (c + c') + {-# INLINE (^-^) #-} + + lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha) + {-# INLINE lerp #-} + +instance Additive V2 where + zero = V2 0 0 + {-# INLINE zero #-} + + (V2 a b) ^+^ (V2 a' b') = V2 (a + a') (b + b') + {-# INLINE (^+^) #-} + + (V2 a b) ^-^ (V2 a' b') = V2 (a - a') (b - b') + {-# INLINE (^-^) #-} + + lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha) + {-# INLINE lerp #-} + +instance Additive V1 where + zero = V1 0 + {-# INLINE zero #-} + + (V1 a) ^+^ (V1 a') = V1 (a + a') + {-# INLINE (^+^) #-} + + (V1 a) ^-^ (V1 a') = V1 (a - a') + {-# INLINE (^-^) #-} + + lerp alpha u v = u ^* alpha ^+^ v ^* (1 - alpha) + {-# INLINE lerp #-} + +-- | Free and sparse inner product/metric spaces. +class Additive f => Metric f where + -- | Compute the inner product of two vectors or (equivalently) + -- convert a vector @f a@ into a covector @f a -> a@. + -- + -- >>> V2 1 2 `dot` V2 3 4 + -- 11 + dot :: Num a => f a -> f a -> a + + -- | Compute the squared norm. The name quadrance arises from + -- Norman J. Wildberger's rational trigonometry. + quadrance :: Num a => f a -> a + {-# INLINE quadrance #-} + quadrance v = dot v v + + -- | Compute the quadrance of the difference + qd :: Num a => f a -> f a -> a + {-# INLINE qd #-} + qd f g = quadrance (f ^-^ g) + + -- | Compute the distance between two vectors in a metric space + distance :: Floating a => f a -> f a -> a + {-# INLINE distance #-} + distance f g = norm (f ^-^ g) + + -- | Compute the norm of a vector in a metric space + norm :: Floating a => f a -> a + {-# INLINE norm #-} + norm v = sqrt (quadrance v) + + -- | Convert a non-zero vector to unit vector. + signorm :: Floating a => f a -> f a + signorm v = fmap (/ m) v where + m = norm v + +instance Metric V4 where + dot (V4 a b c d) (V4 a' b' c' d') = a * a' + b * b' + c * c' + d * d' + {-# INLINE dot #-} + + quadrance (V4 a b c d) = a * a + b * b + c * c + d * d + {-# INLINE quadrance #-} + + norm v = sqrt (quadrance v) + {-# INLINE norm #-} + +instance Metric V3 where + dot (V3 a b c) (V3 a' b' c') = a * a' + b * b' + c * c' + {-# INLINE dot #-} + + quadrance (V3 a b c) = a * a + b * b + c * c + {-# INLINE quadrance #-} + + norm v = sqrt (quadrance v) + {-# INLINE norm #-} + +instance Metric V2 where + dot (V2 a b) (V2 a' b') = a * a' + b * b' + {-# INLINE dot #-} + + quadrance (V2 a b) = a * a + b * b + {-# INLINE quadrance #-} + + norm v = sqrt (quadrance v) + {-# INLINE norm #-} + +-- | Compute the right scalar product +-- +-- >>> V2 3 4 ^* 2 +-- V2 6 8 +(^*) :: (Functor f, Num a) => f a -> a -> f a +{-# INLINE (^*) #-} +(^*) f n = fmap (* n) f + +-- | Compute division by a scalar on the right. +(^/) :: (Functor f, Floating a) => f a -> a -> f a +{-# INLINE (^/) #-} +(^/) f n = fmap (/ n) f + +-- | Normalize a 'Metric' functor to have unit 'norm'. This function +-- does not change the functor if its 'norm' is 0 or 1. +normalize :: (Floating a, Metric f, Epsilon a) => f a -> f a +{-# INLINE normalize #-} +normalize v = if nearZero l || nearZero (1-l) then v + else fmap (/ sqrt l) v + where l = quadrance v + +#endif +
src/Graphics/Rasterific/MicroPdf.hs view
@@ -1,1156 +1,1144 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TupleSections #-}-module Graphics.Rasterific.MicroPdf( renderDrawingToPdf- , renderOrdersToPdf- ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable( Foldable, foldMap )-import Data.Monoid( mempty )-import Control.Applicative( (<$>), (<*>), pure )-#endif--import Control.Monad.Free( liftF, Free( .. ) )-import Control.Monad.Free.Church( fromF )-import Control.Monad.State( StateT, get, put, runStateT, modify, execState )-import Control.Monad.Reader( Reader, local, asks, runReader )--import Numeric( showFFloat )-import Data.Monoid( (<>) )-import qualified Data.Foldable as F-import Data.Word( Word32 )-import Data.ByteString.Builder( byteString- , intDec- , toLazyByteString- , word32BE- , word8- , Builder )-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as LB-import Codec.Picture( PixelRGBA8( PixelRGBA8 )- , Pixel8- , Pixel- , PixelBaseComponent- , pixelOpacity- , mixWithAlpha- )--import Graphics.Rasterific.MiniLens( Lens', use, (.^), (.=), (+=), (%=) )-import Graphics.Rasterific.Types-import Graphics.Rasterific.Linear-import Graphics.Rasterific.Compositor-import Graphics.Rasterific.Command-import Graphics.Rasterific.CubicBezier-import Graphics.Rasterific.PlaneBoundable-import Graphics.Rasterific.Line-import Graphics.Rasterific.Immediate-import Graphics.Rasterific.Operators-import Graphics.Rasterific.Transformations-import Graphics.Rasterific.PathWalker-import Graphics.Rasterific.ComplexPrimitive-import Graphics.Rasterific.Patch-import Graphics.Rasterific.PatchTypes-import Graphics.Rasterific.MeshPatch-import Graphics.Text.TrueType( Dpi )-import Text.Printf-{-import Debug.Trace-}--#if !MIN_VERSION_base(4,8,0)-glength :: Foldable f => f a -> Int-glength = F.foldl' (\acc _ -> acc + 1) 0-#else-glength :: Foldable f => f a -> Int-glength = F.length-#endif--type PdfCommand = B.ByteString-type PdfId = Int--data PdfObject = PdfObject- { _pdfId :: !PdfId- , _pdfRevision :: !PdfId- , _pdfAnnot :: !Resources- , _pdfStream :: !B.ByteString- }--instance Eq PdfObject where- obj1 == obj2 =- (_pdfAnnot obj1, _pdfStream obj1) == (_pdfAnnot obj2, _pdfStream obj2)--instance Ord PdfObject where- compare obj1 obj2 =- compare (_pdfAnnot obj1, _pdfStream obj1) (_pdfAnnot obj2, _pdfStream obj2)--type InnerRenderer =- forall px . PdfColorable px => Drawing px () -> [DrawOrder px]--data PdfConfiguration = PdfConfiguration- { _pdfConfDpi :: !Dpi- , _pdfWidth :: !Int- , _pdfHeight :: !Int- , _pdfConfToOrder :: InnerRenderer- }--domainOfCircle :: Point -> Float -> (Point, Point) -> Domain-domainOfCircle center radius (mini, maxi) = (0, max d1 d2 / radius)- where- d1 = distance maxi center- d2 = distance mini center--domainOfLinearGradient :: Line -> (Point, Point) -> (Float, Float)-domainOfLinearGradient (Line p1 p2) (mini, maxi) =- (t0 + xxAdd + yxAdd, t0 + xyAdd + yyAdd)- where- {-- * Linear gradients are othrogonal to the line passing through- * their extremes. Because of convexity, the parameter range can- * be computed as the convex hull (one the real line) of the- * parameter values of the 4 corners of the box.- *- * The parameter value t for a point (x,y) can be computed as:- *- * t = (p2 - p1) . (x,y) / |p2 - p1|^2- *- * t0 is the t value for the top left corner- * tdx is the difference between left and right corners- * tdy is the difference between top and bottom corners- -}- delta = p2 ^-^ p1- invSquareNorm = 1 / quadrance delta-- normDelta = delta ^* invSquareNorm-- t0 = (mini ^-^ p1) `dot` normDelta- V2 tdx tdy = (maxi ^-^ mini) * normDelta-- (xxAdd, xyAdd) | tdx < 0 = (tdx, 0)- | otherwise = (0, tdx)- (yxAdd, yyAdd) | tdy < 0 = (tdy, 0)- | otherwise = (0, tdy)--------------------------------------------------------- Monadic generation types----------------------------------------------------type PdfEnv = StateT PdfContext (Reader PdfConfiguration)--runPdfEnv :: PdfConfiguration -> PdfId -> PdfEnv a -> (a, PdfContext)-runPdfEnv conf firstFreeId producer =- runReader (runStateT producer $ emptyContext firstFreeId) conf --type Resources = [(B.ByteString, B.ByteString)]--data PdfResourceAssoc = PdfResourceAssoc- { _resFreeIndex :: !Int- , _resAssoc :: !Resources- }--resFreeIndex :: Lens' PdfResourceAssoc Int-resFreeIndex f v = setter <$> f (_resFreeIndex v) where- setter new = v { _resFreeIndex = new }--resAssoc :: Lens' PdfResourceAssoc Resources-resAssoc f v = setter <$> f (_resAssoc v) where- setter new = v { _resAssoc = new }--data PdfContext = PdfContext- { _pdfFreeIndex :: !Int- , _generatedPdfObjects :: ![PdfObject]- , _pdfPatterns :: !PdfResourceAssoc- , _pdfShadings :: !PdfResourceAssoc- , _pdfGraphicStates :: !PdfResourceAssoc- , _pdfXObjects :: !PdfResourceAssoc- }--pdfXObjects :: Lens' PdfContext PdfResourceAssoc-pdfXObjects f v = setter <$> f (_pdfXObjects v) where- setter new = v { _pdfXObjects = new }--pdfPatterns :: Lens' PdfContext PdfResourceAssoc-pdfPatterns f v = setter <$> f (_pdfPatterns v) where- setter new = v { _pdfPatterns = new }--pdfShadings :: Lens' PdfContext PdfResourceAssoc-pdfShadings f v = setter <$> f (_pdfShadings v) where- setter new = v { _pdfShadings = new }--pdfGraphicStates :: Lens' PdfContext PdfResourceAssoc-pdfGraphicStates f v = setter <$> f (_pdfGraphicStates v) where- setter new = v { _pdfGraphicStates = new }--isPixelTransparent :: (Modulable (PixelBaseComponent px), Pixel px) => px -> Bool-isPixelTransparent p = pixelOpacity p < fullValue--isGradientTransparent :: (Modulable (PixelBaseComponent px), Pixel px) => Gradient px -> Bool-isGradientTransparent = F.any (isPixelTransparent . snd)--toAlphaGradient :: Pixel px => Gradient px -> Gradient (PixelBaseComponent px)-toAlphaGradient = fmap extractOpacity where- extractOpacity (o, p) = (o, pixelOpacity p)- -toOpaqueGradient :: RenderablePixel px => Gradient px -> Gradient px-toOpaqueGradient = fmap (\(o, p) -> (o, mixWithAlpha pxId pxOpaq p p)) where- pxId _ _ v = v- pxOpaq _ _ = fullValue--withLocalSubcontext :: PdfEnv a -> PdfEnv (a, PdfId)-withLocalSubcontext sub = do- oldShadings <- reset (pdfShadings.resAssoc) []- oldPatterns <- reset (pdfPatterns.resAssoc) []- oldStates <- reset (pdfGraphicStates.resAssoc) []- oldXObjects <- reset (pdfXObjects.resAssoc) []-- result <- sub-- newShadings <- reset (pdfShadings.resAssoc) oldShadings- newStates <- reset (pdfGraphicStates.resAssoc) oldStates- newPatterns <- reset (pdfPatterns.resAssoc) oldPatterns- newXObjects <- reset (pdfXObjects.resAssoc) oldXObjects -- (result,) <$> generateObject (resourceObject newShadings newStates newPatterns newXObjects)- where- reset :: Lens' PdfContext a -> a -> PdfEnv a- reset l old = do- v <- use l- l .= old- return v--nameObject :: B.ByteString -> Lens' PdfContext PdfResourceAssoc -> B.ByteString -> PdfEnv Builder-nameObject prefix lens info = do- idx <- use (lens.resFreeIndex)- lens.resFreeIndex += 1- let key = buildToStrict $ tp prefix <> intDec idx- lens.resAssoc %= ((key, info) :)- return . tp $ "/" <> key--nameStateObject :: PdfId -> PdfEnv Builder-nameStateObject = nameObject "gs" pdfGraphicStates . refOf--nameOpacityObject :: Float -> PdfEnv Builder-nameOpacityObject opa = nameObject "gs" pdfGraphicStates opac where- opb = toPdf opa- opac = buildToStrict $ "<< /ca " <> opb <> " /CA " <> opb <> ">> "--nameXObject :: PdfId -> PdfEnv Builder-nameXObject = nameObject "x" pdfXObjects . refOf--{-nameShadingObject :: PdfId -> PdfEnv Builder-}-{-nameShadingObject = nameObject "Sh" pdfShadings . refOf-}--namePatternObject :: B.ByteString -> PdfEnv Builder-namePatternObject = nameObject "P" pdfPatterns--generateObject :: (PdfId -> PdfObject) -> PdfEnv PdfId-generateObject f = do- ctxt <- get- let idx = _pdfFreeIndex ctxt- put $ ctxt- { _pdfFreeIndex = idx + 1- , _generatedPdfObjects = f idx : _generatedPdfObjects ctxt- }- return idx--emptyContext :: PdfId -> PdfContext-emptyContext idx = PdfContext- { _pdfFreeIndex = idx- , _generatedPdfObjects = mempty- , _pdfPatterns = emptyAssoc- , _pdfShadings = emptyAssoc- , _pdfGraphicStates = emptyAssoc- , _pdfXObjects = emptyAssoc- }- where- emptyAssoc = PdfResourceAssoc- { _resFreeIndex = 1- , _resAssoc = mempty- }----------------------------------------------------------- ToPdf class & instances----------------------------------------------------class ToPdf a where- toPdf :: a -> Builder--instance ToPdf Float where- toPdf v = toPdf . B.pack $ showFFloat (Just 4) v ""--instance ToPdf B.ByteString where- toPdf = byteString--newtype Matrix = Matrix Transformation--instance ToPdf Transformation where- toPdf (Transformation a c e b d f) =- foldMap t [a, b, c, d, e, f] <> tp " cm\n"- where- t v = toPdf v <> tp " "--instance ToPdf Matrix where- toPdf (Matrix (Transformation a c e b d f)) =- arrayOf $ foldMap t [a, b, c, d, e, f]- where- t v = toPdf v <> tp " "--instance ToPdf Resources where- toPdf [] = mempty- toPdf dic = tp "<< " <> foldMap dicToPdf dic <> tp ">> "- where- dicToPdf (_, el) | B.null el = mempty- dicToPdf (k, el) =- tp "/" <> toPdf k <> tp " " <> toPdf el <> tp "\n"--instance ToPdf PdfObject where- toPdf obj = intDec (_pdfId obj)- <> tp " "- <> intDec (_pdfRevision obj)- <> tp " obj\n"- <> toPdf dic <> tp "\n"- <> stream- <> tp "endobj\n"- where- bSize = buildToStrict . intDec . B.length $ _pdfStream obj- hasntStream = B.null $ _pdfStream obj-- dic- | hasntStream = _pdfAnnot obj- | otherwise = _pdfAnnot obj <> [("Length", bSize)]-- stream- | hasntStream = mempty- | otherwise = tp "stream\n"- <> toPdf (_pdfStream obj)- <> tp "\nendstream\n"--instance ToPdf Point where- toPdf (V2 x y) = toPdf x <> tp " " <> toPdf y--instance ToPdf Bezier where- toPdf = toPdf . cubicFromQuadraticBezier --instance ToPdf CubicBezier where- toPdf (CubicBezier _p0 p1 p2 p3) =- toPdf p1 <> tp " " <> toPdf p2 <> tp " " <> toPdf p3 <> tp " c\n"--instance ToPdf Line where- toPdf (Line _p0 p1) = toPdf p1 <> tp " l\n"--instance ToPdf Primitive where- toPdf p = case p of- LinePrim l -> toPdf l- BezierPrim b -> toPdf b- CubicBezierPrim c -> toPdf c--instance PdfColorable px => ToPdf (V2 Double, V2 Float, V2 Float, TensorPatch (ParametricValues px)) where- toPdf (V2 sx sy, V2 dx dy, V2 _tx ty, patch) = word8 0 <> coords <> foldMap colorToBinaryPdf [c00, c03, c33, c30] where- fx x = floor . max 0 . min maxi $ realToFrac (x + dx) * sx- fy y = floor . max 0 . min maxi $ realToFrac (ty - (y + dy)) * sy-- maxi = fromIntegral (maxBound :: Word32)-- coords = foldMap word32BE- [ fx x00, fy y00, fx x01, fy y01, fx x02, fy y02, fx x03, fy y03- , fx x13, fy y13, fx x23, fy y23, fx x33, fy y33, fx x32, fy y32- , fx x31, fy y31, fx x30, fy y30, fx x20, fy y20, fx x10, fy y10- , fx x11, fy y11, fx x12, fy y12, fx x22, fy y22, fx x21, fy y21 ]-- CubicBezier (V2 x00 y00) (V2 x10 y10) (V2 x20 y20) (V2 x30 y30) = _curve0 patch- CubicBezier (V2 x01 y01) (V2 x11 y11) (V2 x21 y21) (V2 x31 y31) = _curve1 patch- CubicBezier (V2 x02 y02) (V2 x12 y12) (V2 x22 y22) (V2 x32 y32) = _curve2 patch- CubicBezier (V2 x03 y03) (V2 x13 y13) (V2 x23 y23) (V2 x33 y33) = _curve3 patch- param = _tensorValues patch-- c00 = _northValue param- c30 = _eastValue param- c33 = _southValue param- c03 = _westValue param--------------------------------------------------------- Helper functions----------------------------------------------------buildToStrict :: Builder -> B.ByteString-buildToStrict = LB.toStrict . toLazyByteString--tp :: B.ByteString -> Builder-tp = toPdf--pdfSignature :: B.ByteString-pdfSignature = "%PDF-1.4\n%\xBF\xF7\xA2\xFE\n"--refOf :: PdfId -> B.ByteString-refOf i = buildToStrict $ intDec i <> " 0 R"--arrayOf :: Builder -> Builder-arrayOf a = tp "[ " <> a <> tp " ]"--localGraphicState :: Builder -> Builder-localGraphicState sub = tp "q\n" <> sub <> tp "Q\n"--dicObj :: [(B.ByteString, B.ByteString)] -> PdfId -> PdfObject-dicObj annots pid = PdfObject- { _pdfId = pid- , _pdfRevision = 0- , _pdfAnnot = annots- , _pdfStream = mempty- }--------------------------------------------------------- PDF object helper----------------------------------------------------outlinesObject :: Foldable f => f PdfCommand -> PdfId -> PdfObject-outlinesObject outlines = dicObj- [ ("Type", "/Outlines")- , ("Count", buildToStrict . intDec $ glength outlines)- ]--pagesObject :: Foldable f => f PdfId -> PdfId -> PdfObject-pagesObject pages = dicObj- [ ("Type", "/Pages")- , ("Kids", buildToStrict . arrayOf $ foldMap (toPdf . refOf) pages)- , ("Count", buildToStrict . intDec $ glength pages)- ]---catalogObject :: PdfId -> PdfId -> PdfId -> PdfObject-catalogObject pagesId outlineId = dicObj- [ ("Type", "/Catalog")- , ("Outlines", refOf outlineId)- , ("Pages", refOf pagesId)- ]--pageObject :: PdfColorable px- => Proxy px -> Int -> Int -> PdfId -> PdfId -> PdfId -> PdfId -> PdfObject-pageObject px width height parentId contentId resourceId = dicObj- [ ("Type", "/Page")- , ("Parent", refOf parentId)- , ("MediaBox", buildToStrict box)- , ("Contents", refOf contentId)- , ("Resources", refOf resourceId)- , ("Group", buildToStrict . toPdf $ groupDic px)- ]- where- box = tp "[0 0 " <> intDec width <> tp " " <> intDec height <> tp "]"--gradientPatternObject :: Transformation -> PdfId -> PdfId -> PdfObject-gradientPatternObject trans gradientId = dicObj- [ ("Type", "/Pattern")- , ("PatternType", "2")- , ("Matrix", it)- , ("Shading", refOf gradientId)- ]- where- it = buildToStrict . toPdf $ Matrix trans--linearGradientObject :: Line -> Domain -> B.ByteString -> PdfId -> PdfId -> PdfObject-linearGradientObject (Line p1 p2) (beg, end) colorSpace funId = dicObj- [ ("ShadingType", "2")- , ("ColorSpace", colorSpace)- , ("Coords", buildToStrict coords)- , ("Function", refOf funId)- , ("Domain", buildToStrict . arrayOf $ toPdf beg <> tp " " <> toPdf end)- , ("Extend", "[true true]")- ]- where- coords = arrayOf $ toPdf p1 <> tp " " <> toPdf p2--radialGradientObject :: Domain -> Point -> Point -> Float -> B.ByteString -> PdfId- -> PdfId -> PdfObject-radialGradientObject (beg, end) center focus radius colorSpace funId = dicObj- [ ("ShadingType", "3")- , ("ColorSpace", colorSpace)- , ("Coords", buildToStrict coords)- , ("Function", refOf funId)- , ("Domain", buildToStrict . arrayOf $ toPdf beg <> tp " " <> toPdf end)- , ("Extend", "[true true]")- ]- where- coords = arrayOf $ toPdf center <> tp " " <> toPdf radius- <> " " <> toPdf focus <> tp " 0"--meshGradientObject :: PdfColorable px => MeshPatch px -> Int -> PdfId -> PdfObject-meshGradientObject mesh height pid = PdfObject- { _pdfId = pid- , _pdfRevision = 0- , _pdfAnnot =- [ ("ShadingType", "7")- , ("ColorSpace", "/DeviceRGB")- , ("BitsPerComponent", "8")- , ("BitsPerCoordinate", "32")- , ("BitsPerFlag", "8")- , ("Decode", B.pack $ printf "[%g %g %g %g 0 1 0 1 0 1]" - x0 x1 (fromIntegral height - y1)- (fromIntegral height - y0))- ]- , _pdfStream = buildToStrict- . foldMap (\patch -> toPdf (scal, transl, fullSize, patch))- $ tensorPatchesOf mesh- }- where- maxi = fromIntegral (maxBound :: Word32)- scaleOf :: Float -> Float -> Double- scaleOf a b | nearZero $ a - b = 0- | otherwise = maxi / (realToFrac b - realToFrac a)-- fullSize = V2 (x1 - x0) (y1 - y0)- transl = V2 (-x0) (-y0)- scal = V2 (scaleOf x0 x1) (scaleOf y0 y1)- PlaneBound (V2 x0 y0) (V2 x1 y1) =- foldMeshPoints (\v -> mappend v . planeBounds) mempty mesh--createMeshGradient :: forall px. PdfBaseColorable px- => Builder -> MeshPatch px -> PdfEnv (Either String Builder)-createMeshGradient inner mesh = do- height <- asks _pdfHeight - meshId <- generateObject $ meshGradientObject mesh height - patId <- generateObject (gradientPatternObject mempty meshId)- pat <- namePatternObject $ refOf patId- pure . pure $- "/Pattern cs\n" <> pat <> " scn\n" <>- "/Pattern CS\n" <> pat <> " SCN\n" <> inner---contentObject :: B.ByteString -> PdfId -> PdfObject-contentObject content pid = PdfObject- { _pdfId = pid- , _pdfRevision = 0- , _pdfAnnot = []- , _pdfStream = content- }--pathToPdf :: [Primitive] -> Builder-pathToPdf ps = case ps of- [] -> mempty- p:_ ->- toPdf (firstPointOf p) <> tp " m\n" <> foldMap toPdf ps <> "\n"--class RenderablePixel px => PdfColorable px where- pdfColorSpace :: Proxy px -> B.ByteString- colorToPdf :: px -> Builder- colorToBinaryPdf :: px -> Builder--instance PdfColorable Pixel8 where- pdfColorSpace _ = "/DeviceGray"- colorToPdf c = toPdf (fromIntegral c / 255 :: Float)- colorToBinaryPdf = word8--instance PdfColorable PixelRGBA8 where- pdfColorSpace _ = "/DeviceRGB"- colorToPdf (PixelRGBA8 r g b _a) = - colorToPdf r <> tp " " <> colorToPdf g <> tp " " <> colorToPdf b- colorToBinaryPdf (PixelRGBA8 r g b _a) = - colorToBinaryPdf r <> colorToBinaryPdf g <> colorToBinaryPdf b---maskObject :: PdfId -> PdfId -> PdfObject-maskObject maskId = dicObj- [ ("Type", "/Mask")- , ("S", "/Luminosity")- , ("G", refOf maskId)- ]--alphaMaskObject :: PdfId -> PdfId -> PdfObject-alphaMaskObject maskId = dicObj- [ ("Type", "/Mask")- , ("S", "/Alpha")- , ("G", refOf maskId)- ]---opaState :: Float -> PdfId -> PdfObject-opaState opa = dicObj- [ ("Type", "/ExtGState")- , ("ca", v)- , ("CA", v)- ]- where v = buildToStrict $ toPdf opa--maskState :: PdfId -> PdfId -> PdfObject-maskState maskObj = dicObj- [ ("Type", "/ExtGState")- , ("SMask", refOf maskObj)- , ("ca", "1")- , ("CA", "1")- , ("AIS", "false")- ]--colorInterpolationFunction :: PdfColorable px => px -> px -> PdfId -> PdfObject-colorInterpolationFunction c0 c1 = dicObj- [ ("FunctionType", "2")- , ("Domain", "[ 0 1 ]")- , ("C0", buildToStrict . arrayOf $ colorToPdf c0)- , ("C1", buildToStrict . arrayOf $ colorToPdf c1)- , ("N", "1")- ]--resourceObject :: Resources -> Resources -> Resources -> Resources- -> PdfId -> PdfObject-resourceObject shadings extStates patterns xobjects= dicObj $- ("ProcSet", buildToStrict . arrayOf $ tp "/PDF /Text") :- genExt "ExtGState" (("ao", "<< /ca 1 /CA 1 >>") : extStates)- <> genExt "Pattern" patterns- <> genExt "Shading" shadings- <> genExt "XObject" xobjects- where- genExt _ [] = []- genExt k lst = [(k, buildToStrict $ toPdf lst)]--stitchingFunction :: [PdfId] -> [(Float, Float)] -> PdfId -> PdfObject-stitchingFunction interpolations bounds = dicObj- [ ("FunctionType", "3")- , ("Domain", "[ 0 1 ]")- , ("Functions", buildToStrict interpIds)- , ("Bounds", buildToStrict boundsId)- , ("Encode", buildToStrict . arrayOf . F.fold $ map (const $ tp "0 1 ") interpolations)- ]- where- interpIds =- arrayOf $ foldMap (\i -> toPdf (refOf i) <> tp " ") interpolations- boundsId = arrayOf . foldMap ((<> " ") . toPdf . snd) $ init bounds--repeatingFunction :: Bool -> Float -> Float -> PdfId -> PdfId -> PdfObject-repeatingFunction reflect begin end fun = dicObj- [ ("FunctionType", "3")- , ("Domain", buildToStrict . arrayOf $ intDec ibegin <> tp " " <> intDec iend)- , ("Functions", buildToStrict interpIds)- , ("Bounds", buildToStrict $ arrayOf boundsIds)- , ("Encode", buildToStrict . arrayOf $ foldMap encoding [ibegin .. iend - 1])- ]- where- ibegin = floor begin- iend = ceiling end- interpIds =- arrayOf $ foldMap (\_ -> toPdf (refOf fun) <> tp " ") [ibegin .. iend - 1]- boundsIds =- foldMap ((<> tp " ") . intDec) [ibegin + 1 .. iend - 1]- encoding i | i `mod` 2 /= 0 && reflect = tp "1 0 "- | otherwise = tp "0 1 "--tillingPattern :: Transformation -> Int -> Int -> Builder -> PdfId -> PdfId -> PdfObject-tillingPattern trans w h content res pid = PdfObject - { _pdfId = pid- , _pdfRevision = 0- , _pdfStream = buildToStrict content- , _pdfAnnot =- [ ("Type", "/Pattern")- , ("PatternType", "1")- , ("PaintType", "1")- , ("TilingType", "1")- , ("BBox", buildToStrict $ "[0 0 " <> intDec w <> tp " " <> intDec h <> "]")- , ("XStep", buildToStrict $ intDec w)- , ("YStep", buildToStrict $ intDec h)- , ("Resources", refOf res)- , ("Matrix", buildToStrict . toPdf $ Matrix trans)- ]- }--groupDic :: PdfColorable px => Proxy px -> [(B.ByteString, B.ByteString)]-groupDic px =- [ ("Type", "/Group")- , ("S", "/Transparency")- , ("I", "true")- , ("CS", pdfColorSpace px)- ]---formObject :: PdfColorable px- => Resources -> Proxy px -> B.ByteString -> PdfId- -> PdfEnv (PdfId -> PdfObject)-formObject aditionalAttributes px content res = do- width <- intDec <$> asks _pdfWidth- height <- intDec <$> asks _pdfHeight- pure $ \pid -> PdfObject- { _pdfId = pid- , _pdfRevision = 0- , _pdfStream = content- , _pdfAnnot =- [ ("Type", "/XObject")- , ("Subtype", "/Form")- , ("BBox", buildToStrict $ "[0 0 " <> width <> tp " " <> height <> "]")- , ("XStep", buildToStrict width)- , ("YStep", buildToStrict height)- , ("Resources", refOf res)- , ("Group", buildToStrict . toPdf $ groupDic px)- ] <> aditionalAttributes- }--gradientToPdf :: PdfColorable px => Gradient px -> PdfEnv PdfId-gradientToPdf [] = return 0-gradientToPdf [(_, a), (_, b)] = generateObject (colorInterpolationFunction a b)-gradientToPdf lst@(_:rest) = do- interpolations <-- mapM generateObject [colorInterpolationFunction a b- | ((_, a), (_, b)) <- zip lst rest]- let bounds = zip (map fst lst) (map fst rest)- generateObject (stitchingFunction interpolations bounds)--repeatFunction :: SamplerRepeat -> Float -> Float -> PdfId -> PdfEnv PdfId-repeatFunction sampler beg end fun = case sampler of- SamplerPad -> pure fun- _ | abs (ceiling end - floor beg) <= (1 :: Int) -> pure fun- SamplerRepeat -> generateObject $ repeatingFunction False beg end fun- SamplerReflect -> generateObject $ repeatingFunction True beg end fun--type Domain = (Float, Float)--createGradientFunction :: PdfColorable px- => Transformation -> Domain -> SamplerRepeat -> Gradient px- -> (PdfId -> PdfId -> PdfObject)- -> PdfEnv PdfId-createGradientFunction trans (beg, end) sampler grad generator = do- shaderId <- gradientToPdf grad- stitched <- repeatFunction sampler beg end shaderId- gradId <- generateObject (generator stitched)- generateObject (gradientPatternObject trans gradId)--type PdfBaseColorable px =- ( PdfColorable px- , PdfColorable (PixelBaseComponent px)- , Integral (PixelBaseComponent px)- , PixelBaseComponent (PixelBaseComponent px) ~ (PixelBaseComponent px))--fullPageFill :: PdfEnv Builder-fullPageFill = do- w <- asks _pdfWidth- h <- asks _pdfHeight- pure $ "0 0 " <> intDec w <> " " <> intDec h <> " re f\n"--{- -+------------+-| Color {c}|<---------\-| interp n | |-+------------+ |- |- * * * |- |-+------------+ +-+---------+ +------------+ +------------+ /-------------\-| Color {c}|<-------+ Stitching |<---+ Repeat {c}|<---+ Gradient |<----+ Page {r}|-| interp n | | fun {c}| | function | | {c}| | resources |-+------------+ +-----------+ +------------+ +------------+ \-----+-------/- |- v- Gradient with alpha PDF generation +-------------+- (yes this is quite complex) | ExtGState |- | SMask {a}|- +-----+-------+- |- v- +-------------+- | Mask |- | {a}|- +-----+-------+- |- v-+------------+ +-----------+ +------------+ +------------+ +--------------+-| Color {a}|<-------+ Stitching |<---+ Repeat {a}|<---+ Gradient |<----+ Form with |-| interp 0 | | fun {a}| | function | | {a}| | transparency |-+------------+ +-+---------+ +------------+ +------------+ | group {a}|- | +--------------+- * * * |- |-+------------+ |-| Color {a}|<---------/-| interp n |-+------------+--::: .a { fill: white; }-::: .r { fill: rgb(128, 200, 128); }--}-gradientObjectGenerator :: forall px. PdfBaseColorable px- => Builder -> Transformation- -> Domain -> SamplerRepeat -> Gradient px- -> (B.ByteString -> PdfId -> PdfId -> PdfObject)- -> PdfEnv (Either String Builder)-gradientObjectGenerator inner rootTrans dom sampler rootGrad generator- | isGradientTransparent rootGrad = goAlpha rootGrad- | otherwise = go rootTrans rootGrad- where- alphaPxProxy = Proxy :: Proxy (PixelBaseComponent px)- alphaColorspace = pdfColorSpace alphaPxProxy- pxFullProxy = Proxy :: Proxy px- colorSpace = pdfColorSpace pxFullProxy-- go trans grad = do- patternId <- createGradientFunction trans dom sampler grad $ generator colorSpace- pat <- namePatternObject $ refOf patternId- pure . pure $- "/Pattern cs\n" <> pat <> " scn\n" <>- "/Pattern CS\n" <> pat <> " SCN\n" <> inner-- goAlpha grad = do- let alphaGrad = toAlphaGradient grad- (colorGradCom, xObjectRes) <-- withLocalSubcontext . go mempty $ toOpaqueGradient grad- alphaId <- createGradientFunction mempty dom sampler alphaGrad $ generator alphaColorspace-- (command, resourceId) <- withLocalSubcontext $ do- alphaShadingName <- namePatternObject $ refOf alphaId- opaDicId <- generateObject $ opaState 1- gsName <- nameStateObject opaDicId- fullFill <- fullPageFill- pure . buildToStrict $ gsName <> " gs /Pattern cs " <> alphaShadingName <> " scn\n"- <> fullFill- let subInfo = either (const mempty) buildToStrict colorGradCom- formId <- generateObject =<< formObject [("FormType", "1")] alphaPxProxy command resourceId- xObjectGenerator <- formObject [] pxFullProxy subInfo xObjectRes- xObjName <- nameXObject =<< generateObject xObjectGenerator- maskId <- generateObject $ maskObject formId- maskGraphicStateId <- generateObject $ maskState maskId- stateName <- nameStateObject maskGraphicStateId- pure . pure . localGraphicState $ stateName <> " gs\n" <> xObjName <> " Do\n"--alphaLayerGenerator :: forall px. PdfBaseColorable px- => Proxy px -> (Builder, PdfId) -> Float -> PdfEnv Builder-alphaLayerGenerator pxFullProxy (inner, innerResource) alpha = go where- generateFill = withLocalSubcontext $do- fill <- fullPageFill - shade <- nameOpacityObject alpha- let co = colorToPdf (emptyPx :: px)- pure . buildToStrict $ co <> " rg\n" <> co <> " RG\n" <> shade <> " gs " <> fill <> " " -- go = do- (transpCall, layerRes) <- generateFill- formId <- generateObject =<< formObject mempty pxFullProxy transpCall layerRes- maskId <- generateObject $ alphaMaskObject formId- maskName <- nameStateObject =<< generateObject (maskState maskId)-- xObjId <- generateObject =<< formObject [] pxFullProxy (buildToStrict inner) innerResource- xObjName <- nameXObject xObjId- pure . localGraphicState $ maskName <> tp " gs\n" <> xObjName <> tp " Do\n"--sampledDomainOf :: SamplerRepeat -> Domain -> Domain -sampledDomainOf _ (beg, end) | abs (beg - end) <= 1 = (0, 1)-sampledDomainOf sampler (beg, end) = case sampler of- SamplerPad -> (0, 1)- SamplerRepeat -> (beg, end)- SamplerReflect -> (beg, end)--currentViewBox :: Transformation -> PdfEnv (Point, Point)-currentViewBox trans = do- width <- asks $ fromIntegral . _pdfWidth- height <- asks $ fromIntegral . _pdfHeight- let pMin = V2 0 0- pMax = V2 width height- fitBounds t = (applyTransformation t pMin, applyTransformation t pMax)- pure . maybe (pMin, pMax) fitBounds $ inverseTransformation trans--createLinearGradient :: forall px. PdfBaseColorable px- => Builder -> Transformation -> SamplerRepeat -> Gradient px -> Line- -> PdfEnv (Either String Builder)-createLinearGradient inner trans sampler grad line = do- baseDomain <- domainOfLinearGradient line <$> currentViewBox trans- let dom@(beg, end) = sampledDomainOf sampler baseDomain- sampledLine = extendLine beg end line- gradientObjectGenerator inner trans dom sampler grad $- linearGradientObject sampledLine dom--createRadialGradient :: forall px. PdfBaseColorable px- => Builder -> Transformation -> SamplerRepeat -> Gradient px- -> Point -> Point -> Float- -> PdfEnv (Either String Builder)-createRadialGradient inner trans sampler grad center focus radius = do- baseDomain <- domainOfCircle center radius <$> currentViewBox trans- let dom@(beg, end) = sampledDomainOf sampler baseDomain- radius' = radius * max (abs beg) (abs end)- gradientObjectGenerator inner trans dom sampler grad $- radialGradientObject dom center focus radius'--opacityToPdf :: forall n. (Integral n, Modulable n) => n -> Float-opacityToPdf comp = fromIntegral comp / fromIntegral fv where- fv = fullValue :: n---textureToPdf :: forall px. PdfBaseColorable px- => Transformation -> Builder -> Texture px- -> PdfEnv (Either String Builder)-textureToPdf rootTrans inner = go rootTrans SamplerPad where- go currTrans sampler tex = case tex of- SampledTexture _img -> return $ Left "Unsupported raw image in PDF output."- ShaderTexture _f -> return $ Left "Unsupported shader function in PDF output."- ModulateTexture _tx _modulation -> return $ Left "Unsupported modulation in PDF output."- AlphaModulateTexture _tx _modulation -> return $ Left "Unsupported alpha modulation in PDF output."- RawTexture img -> go currTrans sampler (SampledTexture img)- WithSampler newSampler tx -> go currTrans newSampler tx- SolidTexture px | isPixelTransparent px -> do- localState <- nameOpacityObject . opacityToPdf $ pixelOpacity px- pure . pure . localGraphicState $- localState <> " gs\n" <> co <> " rg\n" <> co <> " RG\n" <> inner- where co = colorToPdf px- SolidTexture px ->- pure . pure $ "/ao gs " <> co <> " rg\n" <> co <> " RG\n" <> inner- where co = colorToPdf px- MeshPatchTexture _ mesh -> createMeshGradient inner mesh- LinearGradientTexture grad line -> createLinearGradient inner currTrans sampler grad line- RadialGradientTexture grad center radius ->- go currTrans sampler $ RadialGradientWithFocusTexture grad center radius center- RadialGradientWithFocusTexture grad center rad focus -> do- let invGrad = reverse [(1 - o, c) | (o, c) <- grad]- createRadialGradient inner currTrans sampler invGrad center focus rad- WithTextureTransform trans tx ->- go tt sampler tx- where tt = case inverseTransformation trans of- Nothing -> currTrans- Just v -> currTrans <> v- PatternTexture w h px draw _img -> do- let withPatternSize conf = conf { _pdfWidth = w, _pdfHeight = h }- baseTexture = SolidTexture px- backRect = rectangle (V2 0 0) (fromIntegral w) (fromIntegral h)- backDraw =- liftF $ SetTexture baseTexture- (liftF $ Fill FillWinding backRect ()) ()- (content, resId) <-- local withPatternSize . withLocalSubcontext $ pdfProducer baseTexture (backDraw >> draw)- tillingId <- generateObject $ tillingPattern rootTrans w h (content) resId- pat <- namePatternObject $ refOf tillingId- return . Right $ "/Pattern cs\n" <> pat <> " scn\n" <> inner--reClose :: [Primitive] -> Builder-reClose [] = mempty-reClose lst@(x:_)- | lastPointOf (last lst) `isDistingableFrom` firstPointOf x = mempty- | otherwise = tp " h\n"--fillCommandOf :: FillMethod -> Builder-fillCommandOf m = tp $ case m of- FillWinding -> "f\n"- FillEvenOdd -> "f*\n"--clipCommandOf :: FillMethod -> Builder-clipCommandOf m = tp $ case m of- FillWinding -> "W n\n"- FillEvenOdd -> "W* n\n"--lineCapOf :: Cap -> Builder-lineCapOf c = tp $ case c of- CapStraight 0 -> "0 J "- CapStraight _g -> "2 J "- CapRound -> "1 J "--lineJoinOf :: Join -> Builder-lineJoinOf j = case j of- JoinRound -> tp "1 j "- JoinMiter 0 -> tp "8 M 0 j "- JoinMiter n -> toPdf n <> tp " M 0 j "--orderToPdf :: PdfBaseColorable px => Transformation -> DrawOrder px- -> PdfEnv Builder-orderToPdf trans order = do- let processPath = foldMap pathToPdf . resplit -- . removeDegeneratePrimitive- geometryCode = foldMap processPath $ _orderPrimitives order- etx <- textureToPdf trans geometryCode $ _orderTexture order- case etx of- Left _ -> pure mempty- Right tx -> pure $ tx <> geometryCode <> fillCommandOf (_orderFillMethod order)--buildXRefTable :: [Int] -> Builder-buildXRefTable lst = tp "xref\n0 " <> intDec (glength lst) <> tp "\n"- <> foldMap build lst where- build 0 = "0000000000 65535 f \n"- build ix = toPdf . B.pack $ printf "%010d 00000 n \n" ix--buildTrailer :: Foldable f => f a -> PdfId -> Builder-buildTrailer objs startId = tp "trailer\n" <> toPdf- [("Size" :: B.ByteString, buildToStrict . intDec $ glength objs + 1)- ,("Root", refOf startId)- ]--toPdfSpace :: Float -> Transformation-toPdfSpace h = translate (V2 0 h) <> scale 1 (-1)--pdfFromProducer :: PdfBaseColorable px- => Proxy px -> PdfConfiguration -> PdfEnv Builder -> LB.ByteString-pdfFromProducer px conf producer = toLazyByteString $- foldMap byteString objs- <> xref- <> buildTrailer objects catalogId- <> xrefPosition - <> tp "%%EOF"- where- height = _pdfHeight conf- (catalogId : outlineId : pagesId : pageId : contentId : endObjId : firstFreeId : _) = [1..]- (content, endContext) = runPdfEnv conf firstFreeId producer- initialTransform = toPdf . toPdfSpace $ fromIntegral height-- objects =- [ catalogObject pagesId outlineId catalogId - , outlinesObject [] outlineId- , pagesObject [pageId] pagesId- , pageObject px (_pdfWidth conf) height pagesId contentId endObjId pageId- , contentObject (buildToStrict $ initialTransform <> content) contentId- , resourceObject- (endContext .^ pdfShadings.resAssoc)- (endContext .^ pdfGraphicStates.resAssoc)- (endContext .^ pdfPatterns.resAssoc)- (endContext .^ pdfXObjects.resAssoc)- endObjId- ]- <> reverse (_generatedPdfObjects endContext)-- (indexes, objs) = unzip $ prepareObjects objects- lastIndex = last indexes- xrefIndex = lastIndex + B.length (last objs)-- xrefPosition = "startxref\n" <> intDec xrefIndex <> tp "\n"-- xref = buildXRefTable indexes--renderDrawingToPdf :: (forall px . PdfColorable px => Drawing px () -> [DrawOrder px])- -> Int -> Int -> Dpi -> Drawing PixelRGBA8 ()- -> LB.ByteString-renderDrawingToPdf toOrders width height dpi =- pdfFromProducer px conf . pdfProducer baseTexture- where- px = Proxy :: Proxy PixelRGBA8- baseTexture = SolidTexture emptyPx - conf = PdfConfiguration- { _pdfConfDpi = dpi- , _pdfWidth = width- , _pdfHeight = height- , _pdfConfToOrder = toOrders- }--pdfProducer :: forall pixel . PdfBaseColorable pixel- => Texture pixel -> Drawing pixel () -> PdfEnv Builder-pdfProducer baseTexture draw = do- initTrans <- asks (toPdfSpace . fromIntegral . _pdfHeight)- goNext False initTrans fillCommandOf baseTexture $ fromF draw where-- goNext :: forall px. PdfBaseColorable px- => Bool -> Transformation -> (FillMethod -> Builder) -> Texture px- -> Free (DrawCommand px) ()- -> PdfEnv Builder- goNext forceInverse activeTrans filler prevTexture f = case f of- Free c -> go forceInverse activeTrans filler prevTexture c- Pure () -> pure mempty-- go :: forall px. PdfBaseColorable px- => Bool -> Transformation -> (FillMethod -> Builder) -> Texture px- -> DrawCommand px (Free (DrawCommand px) ()) -> PdfEnv Builder- go forceInverse activeTrans filler prevTexture com = case com of- CustomRender _mesh next -> recurse next- MeshPatchRender i m next -> do- w <- asks $ fromIntegral . _pdfWidth- h <- asks $ fromIntegral . _pdfHeight- let rect = rectangle (V2 0 0) w h- go forceInverse activeTrans filler prevTexture $- SetTexture (MeshPatchTexture i m) (liftF $ Fill FillWinding rect ()) next- - Fill method prims next -> do- after <- recurse next- pure $ foldMap pathToPdf (resplit prims)- <> filler method- <> after- Stroke w j (c, _) prims next -> do- after <- recurse next- let output p = pathToPdf p <> reClose p- pure $ toPdf w <> tp " w "- <> lineJoinOf j- <> lineCapOf c <> "\n"- <> foldMap output (resplit prims)- <> tp "S\n"- <> after- - DashedStroke o pat w j (c, _) prims next -> do- sub <- go forceInverse activeTrans filler prevTexture $ Stroke w j (c, c) prims (Pure ())- after <- recurse next- pure $ arrayOf (foldMap coords pat) - <> toPdf o <> tp " d "- <> sub- <> "[] 0 d "- <> after- where- coords co = toPdf co <> tp " "- - -- Opacity is ignored for now- WithGlobalOpacity opacity sub next | opacity >= fullValue ->- (<>) <$> recurse (fromF sub) <*> recurse next- WithGlobalOpacity opacity sub next -> do- inner <- withLocalSubcontext . recurse $ fromF sub- after <- recurse next- let alpha = opacityToPdf opacity- proxy = Proxy :: Proxy px- (<> after) <$> alphaLayerGenerator proxy inner alpha-- WithImageEffect _f sub next ->- (<>) <$> recurse (fromF sub) <*> recurse next-- WithTransform trans sub next | forceInverse -> do- after <- recurse next- let subTrans = (activeTrans <> trans)- inner <- goNext forceInverse subTrans filler prevTexture $ fromF sub- let inv = foldMap toPdf $ inverseTransformation trans- pure $ toPdf trans <> inner <> inv <> after-- WithTransform trans sub next -> do- after <- recurse next- let subTrans = activeTrans <> trans- inner <- goNext forceInverse subTrans filler prevTexture $ fromF sub- pure $ localGraphicState (toPdf trans <> inner) <> after-- SetTexture tx sub next -> do- innerCode <- goNext forceInverse activeTrans filler tx $ fromF sub- after <- recurse next- tex <- textureToPdf activeTrans innerCode tx- pure $ case tex of- Left _ -> innerCode <> after- Right texCode -> localGraphicState texCode <> after-- WithCliping clipping sub next -> do- after <- recurse next- let draw8 = clipping :: Drawing px ()- localClip | forceInverse = id- | otherwise = localGraphicState- clipPath <- goNext True activeTrans clipCommandOf prevTexture $ fromF draw8- drawing <- recurse (fromF sub)- pure $ localClip (clipPath <> tp "\n" <> drawing)- <> after-- TextFill p ranges next -> do- dpi <- asks _pdfConfDpi- after <- recurse next- let orders = textToDrawOrders dpi prevTexture p ranges- textPrint <- mapM (orderToPdf activeTrans) orders- pure $ F.fold textPrint <> after-- WithPathOrientation path base subDrawings next -> do- toOrders <- asks _pdfConfToOrder- let orders :: [DrawOrder px]- orders = toOrders . liftF $ SetTexture prevTexture subDrawings ()-- drawer trans _ order =- modify (liftF (WithTransform trans (orderToDrawing order) ()) :)-- placedDrawings :: [Drawing px ()]- placedDrawings =- reverse $ execState (drawOrdersOnPath drawer 0 base path orders) []- after <- recurse next- this <- recurse . fromF $ F.fold placedDrawings- pure $ this <> after-- where- recurse = goNext forceInverse activeTrans filler prevTexture--renderOrdersToPdf :: InnerRenderer -> Int -> Int -> Dpi -> [DrawOrder PixelRGBA8]- -> LB.ByteString-renderOrdersToPdf toOrders width height dpi orders =- pdfFromProducer (Proxy :: Proxy PixelRGBA8) conf $- F.fold <$> mapM (orderToPdf rootTrans) orders- where- rootTrans = toPdfSpace $ fromIntegral height- conf = PdfConfiguration- { _pdfConfDpi = dpi- , _pdfWidth = width- , _pdfHeight = height- , _pdfConfToOrder = toOrders- }--prepareObjects :: [PdfObject] -> [(Int, B.ByteString)]-prepareObjects = scanl go (0, pdfSignature) where- go (ix, prev) obj = (ix + B.length prev, buildToStrict $ toPdf obj)-+{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TupleSections #-} +module Graphics.Rasterific.MicroPdf( renderDrawingToPdf + , renderOrdersToPdf + ) where + +import Control.Monad.Free( liftF, Free( .. ) ) +import Control.Monad.Free.Church( fromF ) +import Control.Monad.State( StateT, get, put, runStateT, modify, execState ) +import Control.Monad.Reader( Reader, local, asks, runReader ) + +import Numeric( showFFloat ) +import Data.Monoid( (<>) ) +import qualified Data.Foldable as F +import Data.Word( Word32 ) +import Data.ByteString.Builder( byteString + , intDec + , toLazyByteString + , word32BE + , word8 + , Builder ) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB +import Codec.Picture( PixelRGBA8( PixelRGBA8 ) + , Pixel8 + , Pixel + , PixelBaseComponent + , pixelOpacity + , mixWithAlpha + ) + +import Graphics.Rasterific.MiniLens( Lens', use, (.^), (.=), (+=), (%=) ) +import Graphics.Rasterific.Types +import Graphics.Rasterific.Linear +import Graphics.Rasterific.Compositor +import Graphics.Rasterific.Command +import Graphics.Rasterific.CubicBezier +import Graphics.Rasterific.PlaneBoundable +import Graphics.Rasterific.Line +import Graphics.Rasterific.Immediate +import Graphics.Rasterific.Operators +import Graphics.Rasterific.Transformations +import Graphics.Rasterific.PathWalker +import Graphics.Rasterific.ComplexPrimitive +import Graphics.Rasterific.Patch +import Graphics.Rasterific.PatchTypes +import Graphics.Rasterific.MeshPatch +import Graphics.Text.TrueType( Dpi ) +import Text.Printf +{-import Debug.Trace-} + +glength :: Foldable f => f a -> Int +glength = F.length + +type PdfCommand = B.ByteString +type PdfId = Int + +data PdfObject = PdfObject + { _pdfId :: !PdfId + , _pdfRevision :: !PdfId + , _pdfAnnot :: !Resources + , _pdfStream :: !B.ByteString + } + +instance Eq PdfObject where + obj1 == obj2 = + (_pdfAnnot obj1, _pdfStream obj1) == (_pdfAnnot obj2, _pdfStream obj2) + +instance Ord PdfObject where + compare obj1 obj2 = + compare (_pdfAnnot obj1, _pdfStream obj1) (_pdfAnnot obj2, _pdfStream obj2) + +type InnerRenderer = + forall px . PdfColorable px => Drawing px () -> [DrawOrder px] + +data PdfConfiguration = PdfConfiguration + { _pdfConfDpi :: !Dpi + , _pdfWidth :: !Int + , _pdfHeight :: !Int + , _pdfConfToOrder :: InnerRenderer + } + +domainOfCircle :: Point -> Float -> (Point, Point) -> Domain +domainOfCircle center radius (mini, maxi) = (0, max d1 d2 / radius) + where + d1 = distance maxi center + d2 = distance mini center + +domainOfLinearGradient :: Line -> (Point, Point) -> (Float, Float) +domainOfLinearGradient (Line p1 p2) (mini, maxi) = + (t0 + xxAdd + yxAdd, t0 + xyAdd + yyAdd) + where + {- + * Linear gradients are othrogonal to the line passing through + * their extremes. Because of convexity, the parameter range can + * be computed as the convex hull (one the real line) of the + * parameter values of the 4 corners of the box. + * + * The parameter value t for a point (x,y) can be computed as: + * + * t = (p2 - p1) . (x,y) / |p2 - p1|^2 + * + * t0 is the t value for the top left corner + * tdx is the difference between left and right corners + * tdy is the difference between top and bottom corners + -} + delta = p2 ^-^ p1 + invSquareNorm = 1 / quadrance delta + + normDelta = delta ^* invSquareNorm + + t0 = (mini ^-^ p1) `dot` normDelta + V2 tdx tdy = (maxi ^-^ mini) * normDelta + + (xxAdd, xyAdd) | tdx < 0 = (tdx, 0) + | otherwise = (0, tdx) + (yxAdd, yyAdd) | tdy < 0 = (tdy, 0) + | otherwise = (0, tdy) + +-------------------------------------------------- +---- Monadic generation types +-------------------------------------------------- +type PdfEnv = StateT PdfContext (Reader PdfConfiguration) + +runPdfEnv :: PdfConfiguration -> PdfId -> PdfEnv a -> (a, PdfContext) +runPdfEnv conf firstFreeId producer = + runReader (runStateT producer $ emptyContext firstFreeId) conf + +type Resources = [(B.ByteString, B.ByteString)] + +data PdfResourceAssoc = PdfResourceAssoc + { _resFreeIndex :: !Int + , _resAssoc :: !Resources + } + +resFreeIndex :: Lens' PdfResourceAssoc Int +resFreeIndex f v = setter <$> f (_resFreeIndex v) where + setter new = v { _resFreeIndex = new } + +resAssoc :: Lens' PdfResourceAssoc Resources +resAssoc f v = setter <$> f (_resAssoc v) where + setter new = v { _resAssoc = new } + +data PdfContext = PdfContext + { _pdfFreeIndex :: !Int + , _generatedPdfObjects :: ![PdfObject] + , _pdfPatterns :: !PdfResourceAssoc + , _pdfShadings :: !PdfResourceAssoc + , _pdfGraphicStates :: !PdfResourceAssoc + , _pdfXObjects :: !PdfResourceAssoc + } + +pdfXObjects :: Lens' PdfContext PdfResourceAssoc +pdfXObjects f v = setter <$> f (_pdfXObjects v) where + setter new = v { _pdfXObjects = new } + +pdfPatterns :: Lens' PdfContext PdfResourceAssoc +pdfPatterns f v = setter <$> f (_pdfPatterns v) where + setter new = v { _pdfPatterns = new } + +pdfShadings :: Lens' PdfContext PdfResourceAssoc +pdfShadings f v = setter <$> f (_pdfShadings v) where + setter new = v { _pdfShadings = new } + +pdfGraphicStates :: Lens' PdfContext PdfResourceAssoc +pdfGraphicStates f v = setter <$> f (_pdfGraphicStates v) where + setter new = v { _pdfGraphicStates = new } + +isPixelTransparent :: (Modulable (PixelBaseComponent px), Pixel px) => px -> Bool +isPixelTransparent p = pixelOpacity p < fullValue + +isGradientTransparent :: (Modulable (PixelBaseComponent px), Pixel px) => Gradient px -> Bool +isGradientTransparent = F.any (isPixelTransparent . snd) + +toAlphaGradient :: Pixel px => Gradient px -> Gradient (PixelBaseComponent px) +toAlphaGradient = fmap extractOpacity where + extractOpacity (o, p) = (o, pixelOpacity p) + +toOpaqueGradient :: RenderablePixel px => Gradient px -> Gradient px +toOpaqueGradient = fmap (\(o, p) -> (o, mixWithAlpha pxId pxOpaq p p)) where + pxId _ _ v = v + pxOpaq _ _ = fullValue + +withLocalSubcontext :: PdfEnv a -> PdfEnv (a, PdfId) +withLocalSubcontext sub = do + oldShadings <- reset (pdfShadings.resAssoc) [] + oldPatterns <- reset (pdfPatterns.resAssoc) [] + oldStates <- reset (pdfGraphicStates.resAssoc) [] + oldXObjects <- reset (pdfXObjects.resAssoc) [] + + result <- sub + + newShadings <- reset (pdfShadings.resAssoc) oldShadings + newStates <- reset (pdfGraphicStates.resAssoc) oldStates + newPatterns <- reset (pdfPatterns.resAssoc) oldPatterns + newXObjects <- reset (pdfXObjects.resAssoc) oldXObjects + + (result,) <$> generateObject (resourceObject newShadings newStates newPatterns newXObjects) + where + reset :: Lens' PdfContext a -> a -> PdfEnv a + reset l old = do + v <- use l + l .= old + return v + +nameObject :: B.ByteString -> Lens' PdfContext PdfResourceAssoc -> B.ByteString -> PdfEnv Builder +nameObject prefix lens info = do + idx <- use (lens.resFreeIndex) + lens.resFreeIndex += 1 + let key = buildToStrict $ tp prefix <> intDec idx + lens.resAssoc %= ((key, info) :) + return . tp $ "/" <> key + +nameStateObject :: PdfId -> PdfEnv Builder +nameStateObject = nameObject "gs" pdfGraphicStates . refOf + +nameOpacityObject :: Float -> PdfEnv Builder +nameOpacityObject opa = nameObject "gs" pdfGraphicStates opac where + opb = toPdf opa + opac = buildToStrict $ "<< /ca " <> opb <> " /CA " <> opb <> ">> " + +nameXObject :: PdfId -> PdfEnv Builder +nameXObject = nameObject "x" pdfXObjects . refOf + +{-nameShadingObject :: PdfId -> PdfEnv Builder-} +{-nameShadingObject = nameObject "Sh" pdfShadings . refOf-} + +namePatternObject :: B.ByteString -> PdfEnv Builder +namePatternObject = nameObject "P" pdfPatterns + +generateObject :: (PdfId -> PdfObject) -> PdfEnv PdfId +generateObject f = do + ctxt <- get + let idx = _pdfFreeIndex ctxt + put $ ctxt + { _pdfFreeIndex = idx + 1 + , _generatedPdfObjects = f idx : _generatedPdfObjects ctxt + } + return idx + +emptyContext :: PdfId -> PdfContext +emptyContext idx = PdfContext + { _pdfFreeIndex = idx + , _generatedPdfObjects = mempty + , _pdfPatterns = emptyAssoc + , _pdfShadings = emptyAssoc + , _pdfGraphicStates = emptyAssoc + , _pdfXObjects = emptyAssoc + } + where + emptyAssoc = PdfResourceAssoc + { _resFreeIndex = 1 + , _resAssoc = mempty + } + + + +-------------------------------------------------- +---- ToPdf class & instances +-------------------------------------------------- +class ToPdf a where + toPdf :: a -> Builder + +instance ToPdf Float where + toPdf v = toPdf . B.pack $ showFFloat (Just 4) v "" + +instance ToPdf B.ByteString where + toPdf = byteString + +newtype Matrix = Matrix Transformation + +instance ToPdf Transformation where + toPdf (Transformation a c e b d f) = + foldMap t [a, b, c, d, e, f] <> tp " cm\n" + where + t v = toPdf v <> tp " " + +instance ToPdf Matrix where + toPdf (Matrix (Transformation a c e b d f)) = + arrayOf $ foldMap t [a, b, c, d, e, f] + where + t v = toPdf v <> tp " " + +instance ToPdf Resources where + toPdf [] = mempty + toPdf dic = tp "<< " <> foldMap dicToPdf dic <> tp ">> " + where + dicToPdf (_, el) | B.null el = mempty + dicToPdf (k, el) = + tp "/" <> toPdf k <> tp " " <> toPdf el <> tp "\n" + +instance ToPdf PdfObject where + toPdf obj = intDec (_pdfId obj) + <> tp " " + <> intDec (_pdfRevision obj) + <> tp " obj\n" + <> toPdf dic <> tp "\n" + <> stream + <> tp "endobj\n" + where + bSize = buildToStrict . intDec . B.length $ _pdfStream obj + hasntStream = B.null $ _pdfStream obj + + dic + | hasntStream = _pdfAnnot obj + | otherwise = _pdfAnnot obj <> [("Length", bSize)] + + stream + | hasntStream = mempty + | otherwise = tp "stream\n" + <> toPdf (_pdfStream obj) + <> tp "\nendstream\n" + +instance ToPdf Point where + toPdf (V2 x y) = toPdf x <> tp " " <> toPdf y + +instance ToPdf Bezier where + toPdf = toPdf . cubicFromQuadraticBezier + +instance ToPdf CubicBezier where + toPdf (CubicBezier _p0 p1 p2 p3) = + toPdf p1 <> tp " " <> toPdf p2 <> tp " " <> toPdf p3 <> tp " c\n" + +instance ToPdf Line where + toPdf (Line _p0 p1) = toPdf p1 <> tp " l\n" + +instance ToPdf Primitive where + toPdf p = case p of + LinePrim l -> toPdf l + BezierPrim b -> toPdf b + CubicBezierPrim c -> toPdf c + +instance PdfColorable px => ToPdf (V2 Double, V2 Float, V2 Float, TensorPatch (ParametricValues px)) where + toPdf (V2 sx sy, V2 dx dy, V2 _tx ty, patch) = word8 0 <> coords <> foldMap colorToBinaryPdf [c00, c03, c33, c30] where + fx x = floor . max 0 . min maxi $ realToFrac (x + dx) * sx + fy y = floor . max 0 . min maxi $ realToFrac (ty - (y + dy)) * sy + + maxi = fromIntegral (maxBound :: Word32) + + coords = foldMap word32BE + [ fx x00, fy y00, fx x01, fy y01, fx x02, fy y02, fx x03, fy y03 + , fx x13, fy y13, fx x23, fy y23, fx x33, fy y33, fx x32, fy y32 + , fx x31, fy y31, fx x30, fy y30, fx x20, fy y20, fx x10, fy y10 + , fx x11, fy y11, fx x12, fy y12, fx x22, fy y22, fx x21, fy y21 ] + + CubicBezier (V2 x00 y00) (V2 x10 y10) (V2 x20 y20) (V2 x30 y30) = _curve0 patch + CubicBezier (V2 x01 y01) (V2 x11 y11) (V2 x21 y21) (V2 x31 y31) = _curve1 patch + CubicBezier (V2 x02 y02) (V2 x12 y12) (V2 x22 y22) (V2 x32 y32) = _curve2 patch + CubicBezier (V2 x03 y03) (V2 x13 y13) (V2 x23 y23) (V2 x33 y33) = _curve3 patch + param = _tensorValues patch + + c00 = _northValue param + c30 = _eastValue param + c33 = _southValue param + c03 = _westValue param + +-------------------------------------------------- +---- Helper functions +-------------------------------------------------- +buildToStrict :: Builder -> B.ByteString +buildToStrict = LB.toStrict . toLazyByteString + +tp :: B.ByteString -> Builder +tp = toPdf + +pdfSignature :: B.ByteString +pdfSignature = "%PDF-1.4\n%\xBF\xF7\xA2\xFE\n" + +refOf :: PdfId -> B.ByteString +refOf i = buildToStrict $ intDec i <> " 0 R" + +arrayOf :: Builder -> Builder +arrayOf a = tp "[ " <> a <> tp " ]" + +localGraphicState :: Builder -> Builder +localGraphicState sub = tp "q\n" <> sub <> tp "Q\n" + +dicObj :: [(B.ByteString, B.ByteString)] -> PdfId -> PdfObject +dicObj annots pid = PdfObject + { _pdfId = pid + , _pdfRevision = 0 + , _pdfAnnot = annots + , _pdfStream = mempty + } + +-------------------------------------------------- +---- PDF object helper +-------------------------------------------------- +outlinesObject :: Foldable f => f PdfCommand -> PdfId -> PdfObject +outlinesObject outlines = dicObj + [ ("Type", "/Outlines") + , ("Count", buildToStrict . intDec $ glength outlines) + ] + +pagesObject :: Foldable f => f PdfId -> PdfId -> PdfObject +pagesObject pages = dicObj + [ ("Type", "/Pages") + , ("Kids", buildToStrict . arrayOf $ foldMap (toPdf . refOf) pages) + , ("Count", buildToStrict . intDec $ glength pages) + ] + + +catalogObject :: PdfId -> PdfId -> PdfId -> PdfObject +catalogObject pagesId outlineId = dicObj + [ ("Type", "/Catalog") + , ("Outlines", refOf outlineId) + , ("Pages", refOf pagesId) + ] + +pageObject :: PdfColorable px + => Proxy px -> Int -> Int -> PdfId -> PdfId -> PdfId -> PdfId -> PdfObject +pageObject px width height parentId contentId resourceId = dicObj + [ ("Type", "/Page") + , ("Parent", refOf parentId) + , ("MediaBox", buildToStrict box) + , ("Contents", refOf contentId) + , ("Resources", refOf resourceId) + , ("Group", buildToStrict . toPdf $ groupDic px) + ] + where + box = tp "[0 0 " <> intDec width <> tp " " <> intDec height <> tp "]" + +gradientPatternObject :: Transformation -> PdfId -> PdfId -> PdfObject +gradientPatternObject trans gradientId = dicObj + [ ("Type", "/Pattern") + , ("PatternType", "2") + , ("Matrix", it) + , ("Shading", refOf gradientId) + ] + where + it = buildToStrict . toPdf $ Matrix trans + +linearGradientObject :: Line -> Domain -> B.ByteString -> PdfId -> PdfId -> PdfObject +linearGradientObject (Line p1 p2) (beg, end) colorSpace funId = dicObj + [ ("ShadingType", "2") + , ("ColorSpace", colorSpace) + , ("Coords", buildToStrict coords) + , ("Function", refOf funId) + , ("Domain", buildToStrict . arrayOf $ toPdf beg <> tp " " <> toPdf end) + , ("Extend", "[true true]") + ] + where + coords = arrayOf $ toPdf p1 <> tp " " <> toPdf p2 + +radialGradientObject :: Domain -> Point -> Point -> Float -> B.ByteString -> PdfId + -> PdfId -> PdfObject +radialGradientObject (beg, end) center focus radius colorSpace funId = dicObj + [ ("ShadingType", "3") + , ("ColorSpace", colorSpace) + , ("Coords", buildToStrict coords) + , ("Function", refOf funId) + , ("Domain", buildToStrict . arrayOf $ toPdf beg <> tp " " <> toPdf end) + , ("Extend", "[true true]") + ] + where + coords = arrayOf $ toPdf center <> tp " " <> toPdf radius + <> " " <> toPdf focus <> tp " 0" + +meshGradientObject :: PdfColorable px => MeshPatch px -> Int -> PdfId -> PdfObject +meshGradientObject mesh height pid = PdfObject + { _pdfId = pid + , _pdfRevision = 0 + , _pdfAnnot = + [ ("ShadingType", "7") + , ("ColorSpace", "/DeviceRGB") + , ("BitsPerComponent", "8") + , ("BitsPerCoordinate", "32") + , ("BitsPerFlag", "8") + , ("Decode", B.pack $ printf "[%g %g %g %g 0 1 0 1 0 1]" + x0 x1 (fromIntegral height - y1) + (fromIntegral height - y0)) + ] + , _pdfStream = buildToStrict + . foldMap (\patch -> toPdf (scal, transl, fullSize, patch)) + $ tensorPatchesOf mesh + } + where + maxi = fromIntegral (maxBound :: Word32) + scaleOf :: Float -> Float -> Double + scaleOf a b | nearZero $ a - b = 0 + | otherwise = maxi / (realToFrac b - realToFrac a) + + fullSize = V2 (x1 - x0) (y1 - y0) + transl = V2 (-x0) (-y0) + scal = V2 (scaleOf x0 x1) (scaleOf y0 y1) + PlaneBound (V2 x0 y0) (V2 x1 y1) = + foldMeshPoints (\v -> mappend v . planeBounds) mempty mesh + +createMeshGradient :: forall px. PdfBaseColorable px + => Builder -> MeshPatch px -> PdfEnv (Either String Builder) +createMeshGradient inner mesh = do + height <- asks _pdfHeight + meshId <- generateObject $ meshGradientObject mesh height + patId <- generateObject (gradientPatternObject mempty meshId) + pat <- namePatternObject $ refOf patId + pure . pure $ + "/Pattern cs\n" <> pat <> " scn\n" <> + "/Pattern CS\n" <> pat <> " SCN\n" <> inner + + +contentObject :: B.ByteString -> PdfId -> PdfObject +contentObject content pid = PdfObject + { _pdfId = pid + , _pdfRevision = 0 + , _pdfAnnot = [] + , _pdfStream = content + } + +pathToPdf :: [Primitive] -> Builder +pathToPdf ps = case ps of + [] -> mempty + p:_ -> + toPdf (firstPointOf p) <> tp " m\n" <> foldMap toPdf ps <> "\n" + +class RenderablePixel px => PdfColorable px where + pdfColorSpace :: Proxy px -> B.ByteString + colorToPdf :: px -> Builder + colorToBinaryPdf :: px -> Builder + +instance PdfColorable Pixel8 where + pdfColorSpace _ = "/DeviceGray" + colorToPdf c = toPdf (fromIntegral c / 255 :: Float) + colorToBinaryPdf = word8 + +instance PdfColorable PixelRGBA8 where + pdfColorSpace _ = "/DeviceRGB" + colorToPdf (PixelRGBA8 r g b _a) = + colorToPdf r <> tp " " <> colorToPdf g <> tp " " <> colorToPdf b + colorToBinaryPdf (PixelRGBA8 r g b _a) = + colorToBinaryPdf r <> colorToBinaryPdf g <> colorToBinaryPdf b + + +maskObject :: PdfId -> PdfId -> PdfObject +maskObject maskId = dicObj + [ ("Type", "/Mask") + , ("S", "/Luminosity") + , ("G", refOf maskId) + ] + +alphaMaskObject :: PdfId -> PdfId -> PdfObject +alphaMaskObject maskId = dicObj + [ ("Type", "/Mask") + , ("S", "/Alpha") + , ("G", refOf maskId) + ] + + +opaState :: Float -> PdfId -> PdfObject +opaState opa = dicObj + [ ("Type", "/ExtGState") + , ("ca", v) + , ("CA", v) + ] + where v = buildToStrict $ toPdf opa + +maskState :: PdfId -> PdfId -> PdfObject +maskState maskObj = dicObj + [ ("Type", "/ExtGState") + , ("SMask", refOf maskObj) + , ("ca", "1") + , ("CA", "1") + , ("AIS", "false") + ] + +colorInterpolationFunction :: PdfColorable px => px -> px -> PdfId -> PdfObject +colorInterpolationFunction c0 c1 = dicObj + [ ("FunctionType", "2") + , ("Domain", "[ 0 1 ]") + , ("C0", buildToStrict . arrayOf $ colorToPdf c0) + , ("C1", buildToStrict . arrayOf $ colorToPdf c1) + , ("N", "1") + ] + +resourceObject :: Resources -> Resources -> Resources -> Resources + -> PdfId -> PdfObject +resourceObject shadings extStates patterns xobjects= dicObj $ + ("ProcSet", buildToStrict . arrayOf $ tp "/PDF /Text") : + genExt "ExtGState" (("ao", "<< /ca 1 /CA 1 >>") : extStates) + <> genExt "Pattern" patterns + <> genExt "Shading" shadings + <> genExt "XObject" xobjects + where + genExt _ [] = [] + genExt k lst = [(k, buildToStrict $ toPdf lst)] + +stitchingFunction :: [PdfId] -> [(Float, Float)] -> PdfId -> PdfObject +stitchingFunction interpolations bounds = dicObj + [ ("FunctionType", "3") + , ("Domain", "[ 0 1 ]") + , ("Functions", buildToStrict interpIds) + , ("Bounds", buildToStrict boundsId) + , ("Encode", buildToStrict . arrayOf . F.fold $ map (const $ tp "0 1 ") interpolations) + ] + where + interpIds = + arrayOf $ foldMap (\i -> toPdf (refOf i) <> tp " ") interpolations + boundsId = arrayOf . foldMap ((<> " ") . toPdf . snd) $ init bounds + +repeatingFunction :: Bool -> Float -> Float -> PdfId -> PdfId -> PdfObject +repeatingFunction reflect begin end fun = dicObj + [ ("FunctionType", "3") + , ("Domain", buildToStrict . arrayOf $ intDec ibegin <> tp " " <> intDec iend) + , ("Functions", buildToStrict interpIds) + , ("Bounds", buildToStrict $ arrayOf boundsIds) + , ("Encode", buildToStrict . arrayOf $ foldMap encoding [ibegin .. iend - 1]) + ] + where + ibegin = floor begin + iend = ceiling end + interpIds = + arrayOf $ foldMap (\_ -> toPdf (refOf fun) <> tp " ") [ibegin .. iend - 1] + boundsIds = + foldMap ((<> tp " ") . intDec) [ibegin + 1 .. iend - 1] + encoding i | i `mod` 2 /= 0 && reflect = tp "1 0 " + | otherwise = tp "0 1 " + +tillingPattern :: Transformation -> Int -> Int -> Builder -> PdfId -> PdfId -> PdfObject +tillingPattern trans w h content res pid = PdfObject + { _pdfId = pid + , _pdfRevision = 0 + , _pdfStream = buildToStrict content + , _pdfAnnot = + [ ("Type", "/Pattern") + , ("PatternType", "1") + , ("PaintType", "1") + , ("TilingType", "1") + , ("BBox", buildToStrict $ "[0 0 " <> intDec w <> tp " " <> intDec h <> "]") + , ("XStep", buildToStrict $ intDec w) + , ("YStep", buildToStrict $ intDec h) + , ("Resources", refOf res) + , ("Matrix", buildToStrict . toPdf $ Matrix trans) + ] + } + +groupDic :: PdfColorable px => Proxy px -> [(B.ByteString, B.ByteString)] +groupDic px = + [ ("Type", "/Group") + , ("S", "/Transparency") + , ("I", "true") + , ("CS", pdfColorSpace px) + ] + + +formObject :: PdfColorable px + => Resources -> Proxy px -> B.ByteString -> PdfId + -> PdfEnv (PdfId -> PdfObject) +formObject aditionalAttributes px content res = do + width <- intDec <$> asks _pdfWidth + height <- intDec <$> asks _pdfHeight + pure $ \pid -> PdfObject + { _pdfId = pid + , _pdfRevision = 0 + , _pdfStream = content + , _pdfAnnot = + [ ("Type", "/XObject") + , ("Subtype", "/Form") + , ("BBox", buildToStrict $ "[0 0 " <> width <> tp " " <> height <> "]") + , ("XStep", buildToStrict width) + , ("YStep", buildToStrict height) + , ("Resources", refOf res) + , ("Group", buildToStrict . toPdf $ groupDic px) + ] <> aditionalAttributes + } + +gradientToPdf :: PdfColorable px => Gradient px -> PdfEnv PdfId +gradientToPdf [] = return 0 +gradientToPdf [(_, a), (_, b)] = generateObject (colorInterpolationFunction a b) +gradientToPdf lst@(_:rest) = do + interpolations <- + mapM generateObject [colorInterpolationFunction a b + | ((_, a), (_, b)) <- zip lst rest] + let bounds = zip (map fst lst) (map fst rest) + generateObject (stitchingFunction interpolations bounds) + +repeatFunction :: SamplerRepeat -> Float -> Float -> PdfId -> PdfEnv PdfId +repeatFunction sampler beg end fun = case sampler of + SamplerPad -> pure fun + _ | abs (ceiling end - floor beg) <= (1 :: Int) -> pure fun + SamplerRepeat -> generateObject $ repeatingFunction False beg end fun + SamplerReflect -> generateObject $ repeatingFunction True beg end fun + +type Domain = (Float, Float) + +createGradientFunction :: PdfColorable px + => Transformation -> Domain -> SamplerRepeat -> Gradient px + -> (PdfId -> PdfId -> PdfObject) + -> PdfEnv PdfId +createGradientFunction trans (beg, end) sampler grad generator = do + shaderId <- gradientToPdf grad + stitched <- repeatFunction sampler beg end shaderId + gradId <- generateObject (generator stitched) + generateObject (gradientPatternObject trans gradId) + +type PdfBaseColorable px = + ( PdfColorable px + , PdfColorable (PixelBaseComponent px) + , Integral (PixelBaseComponent px) + , PixelBaseComponent (PixelBaseComponent px) ~ (PixelBaseComponent px)) + +fullPageFill :: PdfEnv Builder +fullPageFill = do + w <- asks _pdfWidth + h <- asks _pdfHeight + pure $ "0 0 " <> intDec w <> " " <> intDec h <> " re f\n" + +{- ++------------+ +| Color {c}|<---------\ +| interp n | | ++------------+ | + | + * * * | + | ++------------+ +-+---------+ +------------+ +------------+ /-------------\ +| Color {c}|<-------+ Stitching |<---+ Repeat {c}|<---+ Gradient |<----+ Page {r}| +| interp n | | fun {c}| | function | | {c}| | resources | ++------------+ +-----------+ +------------+ +------------+ \-----+-------/ + | + v + Gradient with alpha PDF generation +-------------+ + (yes this is quite complex) | ExtGState | + | SMask {a}| + +-----+-------+ + | + v + +-------------+ + | Mask | + | {a}| + +-----+-------+ + | + v ++------------+ +-----------+ +------------+ +------------+ +--------------+ +| Color {a}|<-------+ Stitching |<---+ Repeat {a}|<---+ Gradient |<----+ Form with | +| interp 0 | | fun {a}| | function | | {a}| | transparency | ++------------+ +-+---------+ +------------+ +------------+ | group {a}| + | +--------------+ + * * * | + | ++------------+ | +| Color {a}|<---------/ +| interp n | ++------------+ + +::: .a { fill: white; } +::: .r { fill: rgb(128, 200, 128); } +-} +gradientObjectGenerator :: forall px. PdfBaseColorable px + => Builder -> Transformation + -> Domain -> SamplerRepeat -> Gradient px + -> (B.ByteString -> PdfId -> PdfId -> PdfObject) + -> PdfEnv (Either String Builder) +gradientObjectGenerator inner rootTrans dom sampler rootGrad generator + | isGradientTransparent rootGrad = goAlpha rootGrad + | otherwise = go rootTrans rootGrad + where + alphaPxProxy = Proxy :: Proxy (PixelBaseComponent px) + alphaColorspace = pdfColorSpace alphaPxProxy + pxFullProxy = Proxy :: Proxy px + colorSpace = pdfColorSpace pxFullProxy + + go trans grad = do + patternId <- createGradientFunction trans dom sampler grad $ generator colorSpace + pat <- namePatternObject $ refOf patternId + pure . pure $ + "/Pattern cs\n" <> pat <> " scn\n" <> + "/Pattern CS\n" <> pat <> " SCN\n" <> inner + + goAlpha grad = do + let alphaGrad = toAlphaGradient grad + (colorGradCom, xObjectRes) <- + withLocalSubcontext . go mempty $ toOpaqueGradient grad + alphaId <- createGradientFunction mempty dom sampler alphaGrad $ generator alphaColorspace + + (command, resourceId) <- withLocalSubcontext $ do + alphaShadingName <- namePatternObject $ refOf alphaId + opaDicId <- generateObject $ opaState 1 + gsName <- nameStateObject opaDicId + fullFill <- fullPageFill + pure . buildToStrict $ gsName <> " gs /Pattern cs " <> alphaShadingName <> " scn\n" + <> fullFill + let subInfo = either (const mempty) buildToStrict colorGradCom + formId <- generateObject =<< formObject [("FormType", "1")] alphaPxProxy command resourceId + xObjectGenerator <- formObject [] pxFullProxy subInfo xObjectRes + xObjName <- nameXObject =<< generateObject xObjectGenerator + maskId <- generateObject $ maskObject formId + maskGraphicStateId <- generateObject $ maskState maskId + stateName <- nameStateObject maskGraphicStateId + pure . pure . localGraphicState $ stateName <> " gs\n" <> xObjName <> " Do\n" + +alphaLayerGenerator :: forall px. PdfBaseColorable px + => Proxy px -> (Builder, PdfId) -> Float -> PdfEnv Builder +alphaLayerGenerator pxFullProxy (inner, innerResource) alpha = go where + generateFill = withLocalSubcontext $do + fill <- fullPageFill + shade <- nameOpacityObject alpha + let co = colorToPdf (emptyPx :: px) + pure . buildToStrict $ co <> " rg\n" <> co <> " RG\n" <> shade <> " gs " <> fill <> " " + + go = do + (transpCall, layerRes) <- generateFill + formId <- generateObject =<< formObject mempty pxFullProxy transpCall layerRes + maskId <- generateObject $ alphaMaskObject formId + maskName <- nameStateObject =<< generateObject (maskState maskId) + + xObjId <- generateObject =<< formObject [] pxFullProxy (buildToStrict inner) innerResource + xObjName <- nameXObject xObjId + pure . localGraphicState $ maskName <> tp " gs\n" <> xObjName <> tp " Do\n" + +sampledDomainOf :: SamplerRepeat -> Domain -> Domain +sampledDomainOf _ (beg, end) | abs (beg - end) <= 1 = (0, 1) +sampledDomainOf sampler (beg, end) = case sampler of + SamplerPad -> (0, 1) + SamplerRepeat -> (beg, end) + SamplerReflect -> (beg, end) + +currentViewBox :: Transformation -> PdfEnv (Point, Point) +currentViewBox trans = do + width <- asks $ fromIntegral . _pdfWidth + height <- asks $ fromIntegral . _pdfHeight + let pMin = V2 0 0 + pMax = V2 width height + fitBounds t = (applyTransformation t pMin, applyTransformation t pMax) + pure . maybe (pMin, pMax) fitBounds $ inverseTransformation trans + +createLinearGradient :: forall px. PdfBaseColorable px + => Builder -> Transformation -> SamplerRepeat -> Gradient px -> Line + -> PdfEnv (Either String Builder) +createLinearGradient inner trans sampler grad line = do + baseDomain <- domainOfLinearGradient line <$> currentViewBox trans + let dom@(beg, end) = sampledDomainOf sampler baseDomain + sampledLine = extendLine beg end line + gradientObjectGenerator inner trans dom sampler grad $ + linearGradientObject sampledLine dom + +createRadialGradient :: forall px. PdfBaseColorable px + => Builder -> Transformation -> SamplerRepeat -> Gradient px + -> Point -> Point -> Float + -> PdfEnv (Either String Builder) +createRadialGradient inner trans sampler grad center focus radius = do + baseDomain <- domainOfCircle center radius <$> currentViewBox trans + let dom@(beg, end) = sampledDomainOf sampler baseDomain + radius' = radius * max (abs beg) (abs end) + gradientObjectGenerator inner trans dom sampler grad $ + radialGradientObject dom center focus radius' + +opacityToPdf :: forall n. (Integral n, Modulable n) => n -> Float +opacityToPdf comp = fromIntegral comp / fromIntegral fv where + fv = fullValue :: n + + +textureToPdf :: forall px. PdfBaseColorable px + => Transformation -> Builder -> Texture px + -> PdfEnv (Either String Builder) +textureToPdf rootTrans inner = go rootTrans SamplerPad where + go currTrans sampler tex = case tex of + SampledTexture _img -> return $ Left "Unsupported raw image in PDF output." + ShaderTexture _f -> return $ Left "Unsupported shader function in PDF output." + ModulateTexture _tx _modulation -> return $ Left "Unsupported modulation in PDF output." + AlphaModulateTexture _tx _modulation -> return $ Left "Unsupported alpha modulation in PDF output." + RawTexture img -> go currTrans sampler (SampledTexture img) + WithSampler newSampler tx -> go currTrans newSampler tx + SolidTexture px | isPixelTransparent px -> do + localState <- nameOpacityObject . opacityToPdf $ pixelOpacity px + pure . pure . localGraphicState $ + localState <> " gs\n" <> co <> " rg\n" <> co <> " RG\n" <> inner + where co = colorToPdf px + SolidTexture px -> + pure . pure $ "/ao gs " <> co <> " rg\n" <> co <> " RG\n" <> inner + where co = colorToPdf px + MeshPatchTexture _ mesh -> createMeshGradient inner mesh + LinearGradientTexture grad line -> createLinearGradient inner currTrans sampler grad line + RadialGradientTexture grad center radius -> + go currTrans sampler $ RadialGradientWithFocusTexture grad center radius center + RadialGradientWithFocusTexture grad center rad focus -> do + let invGrad = reverse [(1 - o, c) | (o, c) <- grad] + createRadialGradient inner currTrans sampler invGrad center focus rad + WithTextureTransform trans tx -> + go tt sampler tx + where tt = case inverseTransformation trans of + Nothing -> currTrans + Just v -> currTrans <> v + PatternTexture w h px draw _img -> do + let withPatternSize conf = conf { _pdfWidth = w, _pdfHeight = h } + baseTexture = SolidTexture px + backRect = rectangle (V2 0 0) (fromIntegral w) (fromIntegral h) + backDraw = + liftF $ SetTexture baseTexture + (liftF $ Fill FillWinding backRect ()) () + (content, resId) <- + local withPatternSize . withLocalSubcontext $ pdfProducer baseTexture (backDraw >> draw) + tillingId <- generateObject $ tillingPattern rootTrans w h (content) resId + pat <- namePatternObject $ refOf tillingId + return . Right $ "/Pattern cs\n" <> pat <> " scn\n" <> inner + +reClose :: [Primitive] -> Builder +reClose [] = mempty +reClose lst@(x:_) + | lastPointOf (last lst) `isDistingableFrom` firstPointOf x = mempty + | otherwise = tp " h\n" + +fillCommandOf :: FillMethod -> Builder +fillCommandOf m = tp $ case m of + FillWinding -> "f\n" + FillEvenOdd -> "f*\n" + +clipCommandOf :: FillMethod -> Builder +clipCommandOf m = tp $ case m of + FillWinding -> "W n\n" + FillEvenOdd -> "W* n\n" + +lineCapOf :: Cap -> Builder +lineCapOf c = tp $ case c of + CapStraight 0 -> "0 J " + CapStraight _g -> "2 J " + CapRound -> "1 J " + +lineJoinOf :: Join -> Builder +lineJoinOf j = case j of + JoinRound -> tp "1 j " + JoinMiter 0 -> tp "8 M 0 j " + JoinMiter n -> toPdf n <> tp " M 0 j " + +orderToPdf :: PdfBaseColorable px => Transformation -> DrawOrder px + -> PdfEnv Builder +orderToPdf trans order = do + let processPath = foldMap pathToPdf . resplit -- . removeDegeneratePrimitive + geometryCode = foldMap processPath $ _orderPrimitives order + etx <- textureToPdf trans geometryCode $ _orderTexture order + case etx of + Left _ -> pure mempty + Right tx -> pure $ tx <> geometryCode <> fillCommandOf (_orderFillMethod order) + +buildXRefTable :: [Int] -> Builder +buildXRefTable lst = tp "xref\n0 " <> intDec (glength lst) <> tp "\n" + <> foldMap build lst where + build 0 = "0000000000 65535 f \n" + build ix = toPdf . B.pack $ printf "%010d 00000 n \n" ix + +buildTrailer :: Foldable f => f a -> PdfId -> Builder +buildTrailer objs startId = tp "trailer\n" <> toPdf + [("Size" :: B.ByteString, buildToStrict . intDec $ glength objs + 1) + ,("Root", refOf startId) + ] + +toPdfSpace :: Float -> Transformation +toPdfSpace h = translate (V2 0 h) <> scale 1 (-1) + +pdfFromProducer :: PdfBaseColorable px + => Proxy px -> PdfConfiguration -> PdfEnv Builder -> LB.ByteString +pdfFromProducer px conf producer = toLazyByteString $ + foldMap byteString objs + <> xref + <> buildTrailer objects catalogId + <> xrefPosition + <> tp "%%EOF" + where + height = _pdfHeight conf + (catalogId : outlineId : pagesId : pageId : contentId : endObjId : firstFreeId : _) = [1..] + (content, endContext) = runPdfEnv conf firstFreeId producer + initialTransform = toPdf . toPdfSpace $ fromIntegral height + + objects = + [ catalogObject pagesId outlineId catalogId + , outlinesObject [] outlineId + , pagesObject [pageId] pagesId + , pageObject px (_pdfWidth conf) height pagesId contentId endObjId pageId + , contentObject (buildToStrict $ initialTransform <> content) contentId + , resourceObject + (endContext .^ pdfShadings.resAssoc) + (endContext .^ pdfGraphicStates.resAssoc) + (endContext .^ pdfPatterns.resAssoc) + (endContext .^ pdfXObjects.resAssoc) + endObjId + ] + <> reverse (_generatedPdfObjects endContext) + + (indexes, objs) = unzip $ prepareObjects objects + lastIndex = last indexes + xrefIndex = lastIndex + B.length (last objs) + + xrefPosition = "startxref\n" <> intDec xrefIndex <> tp "\n" + + xref = buildXRefTable indexes + +renderDrawingToPdf :: (forall px . PdfColorable px => Drawing px () -> [DrawOrder px]) + -> Int -> Int -> Dpi -> Drawing PixelRGBA8 () + -> LB.ByteString +renderDrawingToPdf toOrders width height dpi = + pdfFromProducer px conf . pdfProducer baseTexture + where + px = Proxy :: Proxy PixelRGBA8 + baseTexture = SolidTexture emptyPx + conf = PdfConfiguration + { _pdfConfDpi = dpi + , _pdfWidth = width + , _pdfHeight = height + , _pdfConfToOrder = toOrders + } + +pdfProducer :: forall pixel . PdfBaseColorable pixel + => Texture pixel -> Drawing pixel () -> PdfEnv Builder +pdfProducer baseTexture draw = do + initTrans <- asks (toPdfSpace . fromIntegral . _pdfHeight) + goNext False initTrans fillCommandOf baseTexture $ fromF draw where + + goNext :: forall px. PdfBaseColorable px + => Bool -> Transformation -> (FillMethod -> Builder) -> Texture px + -> Free (DrawCommand px) () + -> PdfEnv Builder + goNext forceInverse activeTrans filler prevTexture f = case f of + Free c -> go forceInverse activeTrans filler prevTexture c + Pure () -> pure mempty + + go :: forall px. PdfBaseColorable px + => Bool -> Transformation -> (FillMethod -> Builder) -> Texture px + -> DrawCommand px (Free (DrawCommand px) ()) -> PdfEnv Builder + go forceInverse activeTrans filler prevTexture com = case com of + CustomRender _mesh next -> recurse next + MeshPatchRender i m next -> do + w <- asks $ fromIntegral . _pdfWidth + h <- asks $ fromIntegral . _pdfHeight + let rect = rectangle (V2 0 0) w h + go forceInverse activeTrans filler prevTexture $ + SetTexture (MeshPatchTexture i m) (liftF $ Fill FillWinding rect ()) next + + Fill method prims next -> do + after <- recurse next + pure $ foldMap pathToPdf (resplit prims) + <> filler method + <> after + Stroke w j (c, _) prims next -> do + after <- recurse next + let output p = pathToPdf p <> reClose p + pure $ toPdf w <> tp " w " + <> lineJoinOf j + <> lineCapOf c <> "\n" + <> foldMap output (resplit prims) + <> tp "S\n" + <> after + + DashedStroke o pat w j (c, _) prims next -> do + sub <- go forceInverse activeTrans filler prevTexture $ Stroke w j (c, c) prims (Pure ()) + after <- recurse next + pure $ arrayOf (foldMap coords pat) + <> toPdf o <> tp " d " + <> sub + <> "[] 0 d " + <> after + where + coords co = toPdf co <> tp " " + + -- Opacity is ignored for now + WithGlobalOpacity opacity sub next | opacity >= fullValue -> + (<>) <$> recurse (fromF sub) <*> recurse next + WithGlobalOpacity opacity sub next -> do + inner <- withLocalSubcontext . recurse $ fromF sub + after <- recurse next + let alpha = opacityToPdf opacity + proxy = Proxy :: Proxy px + (<> after) <$> alphaLayerGenerator proxy inner alpha + + WithImageEffect _f sub next -> + (<>) <$> recurse (fromF sub) <*> recurse next + + WithTransform trans sub next | forceInverse -> do + after <- recurse next + let subTrans = (activeTrans <> trans) + inner <- goNext forceInverse subTrans filler prevTexture $ fromF sub + let inv = foldMap toPdf $ inverseTransformation trans + pure $ toPdf trans <> inner <> inv <> after + + WithTransform trans sub next -> do + after <- recurse next + let subTrans = activeTrans <> trans + inner <- goNext forceInverse subTrans filler prevTexture $ fromF sub + pure $ localGraphicState (toPdf trans <> inner) <> after + + SetTexture tx sub next -> do + innerCode <- goNext forceInverse activeTrans filler tx $ fromF sub + after <- recurse next + tex <- textureToPdf activeTrans innerCode tx + pure $ case tex of + Left _ -> innerCode <> after + Right texCode -> localGraphicState texCode <> after + + WithCliping clipping sub next -> do + after <- recurse next + let draw8 = clipping :: Drawing px () + localClip | forceInverse = id + | otherwise = localGraphicState + clipPath <- goNext True activeTrans clipCommandOf prevTexture $ fromF draw8 + drawing <- recurse (fromF sub) + pure $ localClip (clipPath <> tp "\n" <> drawing) + <> after + + TextFill p ranges next -> do + dpi <- asks _pdfConfDpi + after <- recurse next + let orders = textToDrawOrders dpi prevTexture p ranges + textPrint <- mapM (orderToPdf activeTrans) orders + pure $ F.fold textPrint <> after + + WithPathOrientation path base subDrawings next -> do + toOrders <- asks _pdfConfToOrder + let orders :: [DrawOrder px] + orders = toOrders . liftF $ SetTexture prevTexture subDrawings () + + drawer trans _ order = + modify (liftF (WithTransform trans (orderToDrawing order) ()) :) + + placedDrawings :: [Drawing px ()] + placedDrawings = + reverse $ execState (drawOrdersOnPath drawer 0 base path orders) [] + after <- recurse next + this <- recurse . fromF $ F.fold placedDrawings + pure $ this <> after + + where + recurse = goNext forceInverse activeTrans filler prevTexture + +renderOrdersToPdf :: InnerRenderer -> Int -> Int -> Dpi -> [DrawOrder PixelRGBA8] + -> LB.ByteString +renderOrdersToPdf toOrders width height dpi orders = + pdfFromProducer (Proxy :: Proxy PixelRGBA8) conf $ + F.fold <$> mapM (orderToPdf rootTrans) orders + where + rootTrans = toPdfSpace $ fromIntegral height + conf = PdfConfiguration + { _pdfConfDpi = dpi + , _pdfWidth = width + , _pdfHeight = height + , _pdfConfToOrder = toOrders + } + +prepareObjects :: [PdfObject] -> [(Int, B.ByteString)] +prepareObjects = scanl go (0, pdfSignature) where + go (ix, prev) obj = (ix + B.length prev, buildToStrict $ toPdf obj) +
src/Graphics/Rasterific/MiniLens.hs view
@@ -1,100 +1,89 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE CPP #-}-module Graphics.Rasterific.MiniLens- ( -- * Types- Lens- , Lens'- , Traversal- , Traversal'- , lens-- -- * Getter- , (.^)- , view- , use-- -- * Setter- , (.~)- , (.=)- , (%=)- , (+=)- , set-- -- * Helper- , (&)- ) where--import Control.Monad.Identity-import Control.Applicative-import Control.Monad.State as State--#if MIN_VERSION_base(4,8,0)-import Data.Function( (&) )-#endif--infixl 8 .^-infixr 4 .~-infix 4 .=,%=,+=--#if !MIN_VERSION_base(4,8,0)-infixl 1 &--(&) :: a -> (a -> b) -> b-x & f = f x-#endif---- | Does it look familiar? yes it's the official--- Lens type.-type Lens s t a b =- forall f. Functor f => (a -> f b) -> s -> f t---- | Try to match the Lens' type alias.-type Lens' s a = Lens s s a a---- | Traversal type, matched to the one of the lens--- package.-type Traversal s t a b =- forall f. Applicative f => (a -> f b) -> s -> f t--type Traversal' s a = Traversal s s a a---- | Create a full lens out of setter and getter-lens :: (s -> a)- -> (s -> b -> t)- -> Lens s t a b-{-# INLINE lens #-}-lens accessor setter = \f src ->- fmap (setter src) $ f (accessor src)--view :: s -> Lens s t a b -> a-{-# INLINE view #-}-view v l = getConst (l Const v)--(.^) :: s -> Lens s t a b -> a-{-# INLINE (.^) #-}-(.^) = view--set :: Lens' s a -> a -> s -> s-{-# INLINE set #-}-set l new v = runIdentity $ l (\_ -> Identity new) v--(.~) :: Lens' s a -> a -> s -> s-{-# INLINE (.~) #-}-(.~) = set--(.=) :: MonadState s m => Lens' s a -> a -> m ()-{-# INLINE (.=) #-}-(.=) l v = State.modify (l .~ v)--(%=) :: MonadState s m => Lens' s a -> (a -> a) -> m ()-{-# INLINE (%=) #-}-(%=) l f = State.modify $ \s -> s & l .~ f (s .^ l)--(+=) :: (Num a, MonadState s m) => Lens' s a -> a -> m ()-{-# INLINE (+=) #-}-(+=) l n = l %= (+ n)--use :: MonadState s m => Lens s t a b -> m a-{-# INLINE use #-}-use l = State.gets (.^ l)-+{-# LANGUAGE RankNTypes #-} +module Graphics.Rasterific.MiniLens + ( -- * Types + Lens + , Lens' + , Traversal + , Traversal' + , lens + + -- * Getter + , (.^) + , view + , use + + -- * Setter + , (.~) + , (.=) + , (%=) + , (+=) + , set + + -- * Helper + , (&) + ) where + +import Control.Monad.Identity +import Control.Applicative +import Control.Monad.State as State +import Data.Function( (&) ) + +infixl 8 .^ +infixr 4 .~ +infix 4 .=,%=,+= + +-- | Does it look familiar? yes it's the official +-- Lens type. +type Lens s t a b = + forall f. Functor f => (a -> f b) -> s -> f t + +-- | Try to match the Lens' type alias. +type Lens' s a = Lens s s a a + +-- | Traversal type, matched to the one of the lens +-- package. +type Traversal s t a b = + forall f. Applicative f => (a -> f b) -> s -> f t + +type Traversal' s a = Traversal s s a a + +-- | Create a full lens out of setter and getter +lens :: (s -> a) + -> (s -> b -> t) + -> Lens s t a b +{-# INLINE lens #-} +lens accessor setter = \f src -> + fmap (setter src) $ f (accessor src) + +view :: s -> Lens s t a b -> a +{-# INLINE view #-} +view v l = getConst (l Const v) + +(.^) :: s -> Lens s t a b -> a +{-# INLINE (.^) #-} +(.^) = view + +set :: Lens' s a -> a -> s -> s +{-# INLINE set #-} +set l new v = runIdentity $ l (\_ -> Identity new) v + +(.~) :: Lens' s a -> a -> s -> s +{-# INLINE (.~) #-} +(.~) = set + +(.=) :: MonadState s m => Lens' s a -> a -> m () +{-# INLINE (.=) #-} +(.=) l v = State.modify (l .~ v) + +(%=) :: MonadState s m => Lens' s a -> (a -> a) -> m () +{-# INLINE (%=) #-} +(%=) l f = State.modify $ \s -> s & l .~ f (s .^ l) + +(+=) :: (Num a, MonadState s m) => Lens' s a -> a -> m () +{-# INLINE (+=) #-} +(+=) l n = l %= (+ n) + +use :: MonadState s m => Lens s t a b -> m a +{-# INLINE use #-} +use l = State.gets (.^ l) +
src/Graphics/Rasterific/Operators.hs view
@@ -1,164 +1,160 @@-{-# LANGUAGE CPP #-}--- | Module providing basic helper functions to help--- build vector/point calculations.-module Graphics.Rasterific.Operators- ( Point- -- * Lifted operators- , (^&&^)- , (^||^)- , (^==^)- , (^/=^)- , (^<=^)- , (^<^)- , (^<)-- -- * Lifted functions- , vmin- , vmax- , vabs- , vfloor- , vceil- , clampPoint- , midPoint- , middle- , vpartition - , normal- , ifZero- , isNearby- , isDistingableFrom- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( Applicative, (<$>) )-#endif-import Control.Applicative( liftA2, liftA3 )--import Graphics.Rasterific.Linear- ( V2( .. )- , Additive( .. )- , Epsilon( nearZero )- , (^+^)- , (^*)- , dot- , normalize- )--infix 4 ^<, ^<=^, ^<^, ^==^, ^/=^-infixr 3 ^&&^-infixr 2 ^||^---- | Represent a point-type Point = V2 Float---- | Pairwise boolean and operator-(^&&^) :: (Applicative a) => a Bool -> a Bool -> a Bool-{-# INLINE (^&&^) #-}-(^&&^) = liftA2 (&&)---- | Pairwise boolean or operator-(^||^) :: (Applicative a) => a Bool -> a Bool -> a Bool-{-# INLINE (^||^) #-}-(^||^) = liftA2 (||)---- | Pairwise vector/point equal operator-(^==^) :: (Eq v, Applicative a) => a v -> a v -> a Bool-{-# INLINE (^==^) #-}-(^==^) = liftA2 (==)---- | Pairwise vector/point lower than or equal operator-(^<=^) :: (Ord v, Applicative a) => a v -> a v -> a Bool-{-# INLINE (^<=^) #-}-(^<=^) = liftA2 (<=)---- | Pairwise vector/point lower than operator-(^<^) :: (Ord v, Applicative a) => a v -> a v -> a Bool-{-# INLINE (^<^) #-}-(^<^) = liftA2 (<)---- | Component/scalar lower than operator.-(^<) :: (Applicative a, Ord v) => a v -> v -> a Bool-{-# INLINE (^<) #-}-(^<) vec v = (< v) <$> vec---- | Pairwise vector/point difference operator.-(^/=^) :: (Applicative a, Eq v) => a v -> a v -> a Bool-{-# INLINE (^/=^) #-}-(^/=^) = liftA2 (/=)---- | Min function between two vector/points.--- Work on every component separately.-vmin :: (Ord n, Applicative a) => a n -> a n -> a n-{-# INLINE vmin #-}-vmin = liftA2 min---- | Max function between to vector/point.--- Work on every component separatly.-vmax :: (Ord n, Applicative a) => a n -> a n -> a n-{-# INLINE vmax #-}-vmax = liftA2 max---- | Abs function for every component of the vector/point.-vabs :: (Num n, Functor a) => a n -> a n-{-# INLINE vabs #-}-vabs = fmap abs---- | Floor function for every component of the vector/point.-vfloor :: (Functor a) => a Float -> a Int-{-# INLINE vfloor #-}-vfloor = fmap floor---- | ceil function for every component of the vector/point.-vceil :: (Functor a) => a Float -> a Int-{-# INLINE vceil #-}-vceil = fmap ceiling---- | Given a point, clamp every coordinates between--- a given minimum and maximum.-clampPoint :: Point -> Point -> Point -> Point-{-# INLINE clampPoint #-}-clampPoint mini maxi v = vmin maxi $ vmax mini v---- | Given two points, return a point in the middle--- of them.-midPoint :: (Additive a, Fractional coord) => a coord -> a coord -> a coord-{-# INLINE midPoint #-}-midPoint a b = (a ^+^ b) ^* 0.5--middle :: (Fractional a) => a -> a -> a-{-# INLINE middle #-}-middle a b = (a + b) * 0.5---- | Given a boolean choice vector, return elements of--- the first one if true, of the second one otherwise.-vpartition :: (Applicative a) => a Bool -> a v -> a v -> a v-{-# INLINE vpartition #-}-vpartition = liftA3 choose- where choose True a _ = a- choose False _ b = b---- | Calculate a normal vector-normal :: (Floating v, Epsilon v) => V2 v -> V2 v -> V2 v-{-# INLINE normal #-}-normal (V2 ax ay) (V2 bx by) = normalize $ V2 (ay - by) (bx - ax)---- | Return the second operand if the vector is--- nearly null-ifZero :: (Epsilon v) => v -> v -> v-{-# INLINE ifZero #-}-ifZero u v | nearZero u = v- | otherwise = u---- | Tell if two points are nearly indistinguishable.--- If indistinguishable, we can treat them as the same--- point.-isNearby :: Point -> Point -> Bool-{-# INLINE isNearby #-}-isNearby p1 p2 = squareDist < 0.0001- where vec = p1 ^-^ p2- squareDist = vec `dot` vec---- | simply `not (a `isNearby` b)`-isDistingableFrom :: Point -> Point -> Bool-{-# INLINE isDistingableFrom #-}-isDistingableFrom a b = not $ isNearby a b-+-- | Module providing basic helper functions to help +-- build vector/point calculations. +module Graphics.Rasterific.Operators + ( Point + -- * Lifted operators + , (^&&^) + , (^||^) + , (^==^) + , (^/=^) + , (^<=^) + , (^<^) + , (^<) + + -- * Lifted functions + , vmin + , vmax + , vabs + , vfloor + , vceil + , clampPoint + , midPoint + , middle + , vpartition + , normal + , ifZero + , isNearby + , isDistingableFrom + ) where + +import Control.Applicative( liftA2, liftA3 ) + +import Graphics.Rasterific.Linear + ( V2( .. ) + , Additive( .. ) + , Epsilon( nearZero ) + , (^+^) + , (^*) + , dot + , normalize + ) + +infix 4 ^<, ^<=^, ^<^, ^==^, ^/=^ +infixr 3 ^&&^ +infixr 2 ^||^ + +-- | Represent a point +type Point = V2 Float + +-- | Pairwise boolean and operator +(^&&^) :: (Applicative a) => a Bool -> a Bool -> a Bool +{-# INLINE (^&&^) #-} +(^&&^) = liftA2 (&&) + +-- | Pairwise boolean or operator +(^||^) :: (Applicative a) => a Bool -> a Bool -> a Bool +{-# INLINE (^||^) #-} +(^||^) = liftA2 (||) + +-- | Pairwise vector/point equal operator +(^==^) :: (Eq v, Applicative a) => a v -> a v -> a Bool +{-# INLINE (^==^) #-} +(^==^) = liftA2 (==) + +-- | Pairwise vector/point lower than or equal operator +(^<=^) :: (Ord v, Applicative a) => a v -> a v -> a Bool +{-# INLINE (^<=^) #-} +(^<=^) = liftA2 (<=) + +-- | Pairwise vector/point lower than operator +(^<^) :: (Ord v, Applicative a) => a v -> a v -> a Bool +{-# INLINE (^<^) #-} +(^<^) = liftA2 (<) + +-- | Component/scalar lower than operator. +(^<) :: (Applicative a, Ord v) => a v -> v -> a Bool +{-# INLINE (^<) #-} +(^<) vec v = (< v) <$> vec + +-- | Pairwise vector/point difference operator. +(^/=^) :: (Applicative a, Eq v) => a v -> a v -> a Bool +{-# INLINE (^/=^) #-} +(^/=^) = liftA2 (/=) + +-- | Min function between two vector/points. +-- Work on every component separately. +vmin :: (Ord n, Applicative a) => a n -> a n -> a n +{-# INLINE vmin #-} +vmin = liftA2 min + +-- | Max function between to vector/point. +-- Work on every component separatly. +vmax :: (Ord n, Applicative a) => a n -> a n -> a n +{-# INLINE vmax #-} +vmax = liftA2 max + +-- | Abs function for every component of the vector/point. +vabs :: (Num n, Functor a) => a n -> a n +{-# INLINE vabs #-} +vabs = fmap abs + +-- | Floor function for every component of the vector/point. +vfloor :: (Functor a) => a Float -> a Int +{-# INLINE vfloor #-} +vfloor = fmap floor + +-- | ceil function for every component of the vector/point. +vceil :: (Functor a) => a Float -> a Int +{-# INLINE vceil #-} +vceil = fmap ceiling + +-- | Given a point, clamp every coordinates between +-- a given minimum and maximum. +clampPoint :: Point -> Point -> Point -> Point +{-# INLINE clampPoint #-} +clampPoint mini maxi v = vmin maxi $ vmax mini v + +-- | Given two points, return a point in the middle +-- of them. +midPoint :: (Additive a, Fractional coord) => a coord -> a coord -> a coord +{-# INLINE midPoint #-} +midPoint a b = (a ^+^ b) ^* 0.5 + +middle :: (Fractional a) => a -> a -> a +{-# INLINE middle #-} +middle a b = (a + b) * 0.5 + +-- | Given a boolean choice vector, return elements of +-- the first one if true, of the second one otherwise. +vpartition :: (Applicative a) => a Bool -> a v -> a v -> a v +{-# INLINE vpartition #-} +vpartition = liftA3 choose + where choose True a _ = a + choose False _ b = b + +-- | Calculate a normal vector +normal :: (Floating v, Epsilon v) => V2 v -> V2 v -> V2 v +{-# INLINE normal #-} +normal (V2 ax ay) (V2 bx by) = normalize $ V2 (ay - by) (bx - ax) + +-- | Return the second operand if the vector is +-- nearly null +ifZero :: (Epsilon v) => v -> v -> v +{-# INLINE ifZero #-} +ifZero u v | nearZero u = v + | otherwise = u + +-- | Tell if two points are nearly indistinguishable. +-- If indistinguishable, we can treat them as the same +-- point. +isNearby :: Point -> Point -> Bool +{-# INLINE isNearby #-} +isNearby p1 p2 = squareDist < 0.2 + where vec = p1 ^-^ p2 + squareDist = vec `dot` vec + +-- | simply `not (a `isNearby` b)` +isDistingableFrom :: Point -> Point -> Bool +{-# INLINE isDistingableFrom #-} +isDistingableFrom a b = not $ isNearby a b +
src/Graphics/Rasterific/Patch.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} @@ -52,11 +51,6 @@ , horizontalTensorSubdivide , transposePatch ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( Applicative( pure, (<*>) ), (<$>) ) -import Data.Foldable( Foldable( foldMap ) ) -#endif import Control.Monad.Free( liftF ) import Control.Monad( when, forM_ )
src/Graphics/Rasterific/PathWalker.hs view
@@ -1,128 +1,122 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP #-}--- | This module help the walking of path of any shape,--- being able to return the current position and the--- actual orientation.-module Graphics.Rasterific.PathWalker( PathWalkerT- , PathWalker- , PathDrawer- , runPathWalking- , advanceBy- , currentPosition- , currentTangeant- , drawOrdersOnPath- ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid( mempty )-import Control.Applicative( Applicative, (<*>), (<$>) )-#endif--import Data.Monoid( (<>) )--import Control.Monad.Identity( Identity )-import Control.Monad.State( StateT- , MonadTrans- , lift- , evalStateT- , modify- , gets )-import Data.Maybe( fromMaybe )--import Graphics.Rasterific.Types-import Graphics.Rasterific.Linear-import Graphics.Rasterific.Transformations-import Graphics.Rasterific.StrokeInternal-import Graphics.Rasterific.PlaneBoundable-import Graphics.Rasterific.Immediate---- | The walking transformer monad.-newtype PathWalkerT m a = PathWalkerT (StateT WalkerState m a)- deriving (Monad, Applicative, Functor, MonadTrans)---- | Simpler alias if monad transformers are not--- needed.-type PathWalker a = PathWalkerT Identity a---- | State of the path walker, just a bunch of primitives--- with continuity guarantee. The continuity is guaranteed--- by the Path used to derive this primitives.-data WalkerState = WalkerState- { _walkerPrims :: ![Primitive]- }---- | Create a path walker from a given path-runPathWalking :: (Monad m) => Path -> PathWalkerT m a -> m a-runPathWalking path (PathWalkerT walker) = evalStateT walker initialState- where- initialState = WalkerState primsOfPath- primsOfPath = listOfContainer- . flatten- . containerOfList- $ pathToPrimitives path---- | Advance by the given amount of pixels on the path.-advanceBy :: Monad m => Float -> PathWalkerT m ()-advanceBy by = PathWalkerT . modify $ \s ->- let (_, leftPrimitives) = splitPrimitiveUntil by $ _walkerPrims s in- s { _walkerPrims = leftPrimitives }---- | Obtain the current position if we are still on the--- path, if not, return Nothing.-currentPosition :: (Monad m) => PathWalkerT m (Maybe Point)-currentPosition = PathWalkerT $ gets (currPos . _walkerPrims)- where- currPos [] = Nothing- currPos (prim:_) = Just $ firstPointOf prim---- | Obtain the current tangeant of the path if we're still--- on it. Return Nothing otherwise.-currentTangeant :: (Monad m) => PathWalkerT m (Maybe Vector)-currentTangeant = PathWalkerT $ gets (currTangeant . _walkerPrims)- where- currTangeant [] = Nothing- currTangeant (prim:_) = Just . normalize $ firstTangeantOf prim---- | Callback function in charge to transform the DrawOrder--- given the transformation to place it on the path.-type PathDrawer m px =- Transformation -> PlaneBound -> DrawOrder px -> m ()---- | This function is the workhorse of the placement, it will--- walk the path and calculate the appropriate transformation--- for every order.-drawOrdersOnPath :: Monad m- => PathDrawer m px -- ^ Function handling the placement of the order.- -> Float -- ^ Starting offset- -> Float -- ^ Baseline vertical position in the orders.- -> Path -- ^ Path on which to place the orders.- -> [DrawOrder px] -- ^ Orders to place on a path.- -> m ()-drawOrdersOnPath drawer startOffset baseline path orders =- runPathWalking path $ advanceBy startOffset >> go Nothing orders where- go _ [] = return ()- go prevX (img : rest) = do- let bounds = planeBounds img- width = boundWidth bounds- cx = fromMaybe startX prevX- V2 startX _ = boundLowerLeftCorner bounds- V2 endX _ = _planeMaxBound bounds- halfWidth = width / 2- spaceWidth = abs $ startX - cx- translation = V2 (negate startX - halfWidth) (- baseline)-- if bounds == mempty then go prevX rest- else do- advanceBy (halfWidth + spaceWidth)- mayPos <- currentPosition- mayDir <- currentTangeant- case (,) <$> mayPos <*> mayDir of- Nothing -> return () -- out of path, stop drawing- Just (pos, dir) -> do- let imageTransform =- translate pos <> toNewXBase dir- <> translate translation- lift $ drawer imageTransform bounds img- advanceBy halfWidth- go (Just endX) rest-+{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | This module help the walking of path of any shape, +-- being able to return the current position and the +-- actual orientation. +module Graphics.Rasterific.PathWalker( PathWalkerT + , PathWalker + , PathDrawer + , runPathWalking + , advanceBy + , currentPosition + , currentTangeant + , drawOrdersOnPath + ) where + +import Data.Monoid( (<>) ) + +import Control.Monad.Identity( Identity ) +import Control.Monad.State( StateT + , MonadTrans + , lift + , evalStateT + , modify + , gets ) +import Data.Maybe( fromMaybe ) + +import Graphics.Rasterific.Types +import Graphics.Rasterific.Linear +import Graphics.Rasterific.Transformations +import Graphics.Rasterific.StrokeInternal +import Graphics.Rasterific.PlaneBoundable +import Graphics.Rasterific.Immediate + +-- | The walking transformer monad. +newtype PathWalkerT m a = PathWalkerT (StateT WalkerState m a) + deriving (Monad, Applicative, Functor, MonadTrans) + +-- | Simpler alias if monad transformers are not +-- needed. +type PathWalker a = PathWalkerT Identity a + +-- | State of the path walker, just a bunch of primitives +-- with continuity guarantee. The continuity is guaranteed +-- by the Path used to derive this primitives. +data WalkerState = WalkerState + { _walkerPrims :: ![Primitive] + } + +-- | Create a path walker from a given path +runPathWalking :: (Monad m) => Path -> PathWalkerT m a -> m a +runPathWalking path (PathWalkerT walker) = evalStateT walker initialState + where + initialState = WalkerState primsOfPath + primsOfPath = listOfContainer + . flatten + . containerOfList + $ pathToPrimitives path + +-- | Advance by the given amount of pixels on the path. +advanceBy :: Monad m => Float -> PathWalkerT m () +advanceBy by = PathWalkerT . modify $ \s -> + let (_, leftPrimitives) = splitPrimitiveUntil by $ _walkerPrims s in + s { _walkerPrims = leftPrimitives } + +-- | Obtain the current position if we are still on the +-- path, if not, return Nothing. +currentPosition :: (Monad m) => PathWalkerT m (Maybe Point) +currentPosition = PathWalkerT $ gets (currPos . _walkerPrims) + where + currPos [] = Nothing + currPos (prim:_) = Just $ firstPointOf prim + +-- | Obtain the current tangeant of the path if we're still +-- on it. Return Nothing otherwise. +currentTangeant :: (Monad m) => PathWalkerT m (Maybe Vector) +currentTangeant = PathWalkerT $ gets (currTangeant . _walkerPrims) + where + currTangeant [] = Nothing + currTangeant (prim:_) = Just . normalize $ firstTangeantOf prim + +-- | Callback function in charge to transform the DrawOrder +-- given the transformation to place it on the path. +type PathDrawer m px = + Transformation -> PlaneBound -> DrawOrder px -> m () + +-- | This function is the workhorse of the placement, it will +-- walk the path and calculate the appropriate transformation +-- for every order. +drawOrdersOnPath :: Monad m + => PathDrawer m px -- ^ Function handling the placement of the order. + -> Float -- ^ Starting offset + -> Float -- ^ Baseline vertical position in the orders. + -> Path -- ^ Path on which to place the orders. + -> [DrawOrder px] -- ^ Orders to place on a path. + -> m () +drawOrdersOnPath drawer startOffset baseline path orders = + runPathWalking path $ advanceBy startOffset >> go Nothing orders where + go _ [] = return () + go prevX (img : rest) = do + let bounds = planeBounds img + width = boundWidth bounds + cx = fromMaybe startX prevX + V2 startX _ = boundLowerLeftCorner bounds + V2 endX _ = _planeMaxBound bounds + halfWidth = width / 2 + spaceWidth = abs $ startX - cx + translation = V2 (negate startX - halfWidth) (- baseline) + + if bounds == mempty then go prevX rest + else do + advanceBy (halfWidth + spaceWidth) + mayPos <- currentPosition + mayDir <- currentTangeant + case (,) <$> mayPos <*> mayDir of + Nothing -> return () -- out of path, stop drawing + Just (pos, dir) -> do + let imageTransform = + translate pos <> toNewXBase dir + <> translate translation + lift $ drawer imageTransform bounds img + advanceBy halfWidth + go (Just endX) rest +
src/Graphics/Rasterific/PlaneBoundable.hs view
@@ -1,87 +1,79 @@-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE CPP #-}--- | Module implementing types used for geometry--- bound calculations.-module Graphics.Rasterific.PlaneBoundable ( PlaneBound( .. )- , PlaneBoundable( .. )- , boundWidth- , boundHeight- , boundLowerLeftCorner- ) where--#if !MIN_VERSION_base(4,8,0)--- to be removed with GHC 7.12 ?-import Control.Applicative( (<$>), (<*>) )-import Data.Monoid( Monoid( .. ) )-import Data.Foldable( Foldable( foldMap ) )-#endif--import Data.Monoid( (<>) )--import Graphics.Rasterific.Linear( V2( .. ) )-import Graphics.Rasterific.Types-import Graphics.Rasterific.CubicBezier---- | Represent the minimal axis aligned rectangle--- in which some primitives can be drawn. Should--- fit to bezier curve and not use directly their--- control points.-data PlaneBound = PlaneBound- { -- | Corner upper left of the bounding box of- -- the considered primitives.- _planeMinBound :: !Point- -- | Corner lower right of the bounding box of- -- the considered primitives.- , _planeMaxBound :: !Point- }- deriving (Eq, Show)---- | Extract the width of the bounds-boundWidth :: PlaneBound -> Float-boundWidth (PlaneBound (V2 x0 _) (V2 x1 _)) = x1 - x0---- | Extract the height of the bound-boundHeight :: PlaneBound -> Float-boundHeight (PlaneBound (V2 _ y0) (V2 _ y1)) = y1 - y0---- | Extract the position of the lower left corner of the--- bounds.-boundLowerLeftCorner :: PlaneBound -> Point-boundLowerLeftCorner (PlaneBound (V2 x _) (V2 _ y)) = V2 x y--instance Monoid PlaneBound where- mempty = PlaneBound infPoint negInfPoint- where- infPoint = V2 (1 / 0) (1 / 0)- negInfPoint = V2 (negate 1 / 0) (negate 1 / 0)-- mappend (PlaneBound mini1 maxi1) (PlaneBound mini2 maxi2) =- PlaneBound (min <$> mini1 <*> mini2)- (max <$> maxi1 <*> maxi2)---- | Class used to calculate bounds of various geometrical--- primitives. The calculated is precise, the bounding should--- be minimal with respect with drawn curve.-class PlaneBoundable a where- -- | Given a graphical elements, calculate it's bounds.- planeBounds :: a -> PlaneBound--instance PlaneBoundable Point where- planeBounds a = PlaneBound a a--instance PlaneBoundable Line where- planeBounds (Line p1 p2) = planeBounds p1 <> planeBounds p2--instance PlaneBoundable Bezier where- planeBounds (Bezier p0 p1 p2) =- planeBounds (CubicBezier p0 p1 p1 p2)--instance PlaneBoundable CubicBezier where- planeBounds = foldMap planeBounds . cubicBezierBounds--instance PlaneBoundable Primitive where- planeBounds (LinePrim l) = planeBounds l- planeBounds (BezierPrim b) = planeBounds b- planeBounds (CubicBezierPrim c) = planeBounds c-+{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +-- | Module implementing types used for geometry +-- bound calculations. +module Graphics.Rasterific.PlaneBoundable ( PlaneBound( .. ) + , PlaneBoundable( .. ) + , boundWidth + , boundHeight + , boundLowerLeftCorner + ) where + +import Data.Monoid( (<>) ) + +import Graphics.Rasterific.Linear( V2( .. ) ) +import Graphics.Rasterific.Types +import Graphics.Rasterific.CubicBezier + +-- | Represent the minimal axis aligned rectangle +-- in which some primitives can be drawn. Should +-- fit to bezier curve and not use directly their +-- control points. +data PlaneBound = PlaneBound + { -- | Corner upper left of the bounding box of + -- the considered primitives. + _planeMinBound :: !Point + -- | Corner lower right of the bounding box of + -- the considered primitives. + , _planeMaxBound :: !Point + } + deriving (Eq, Show) + +-- | Extract the width of the bounds +boundWidth :: PlaneBound -> Float +boundWidth (PlaneBound (V2 x0 _) (V2 x1 _)) = x1 - x0 + +-- | Extract the height of the bound +boundHeight :: PlaneBound -> Float +boundHeight (PlaneBound (V2 _ y0) (V2 _ y1)) = y1 - y0 + +-- | Extract the position of the lower left corner of the +-- bounds. +boundLowerLeftCorner :: PlaneBound -> Point +boundLowerLeftCorner (PlaneBound (V2 x _) (V2 _ y)) = V2 x y + +instance Monoid PlaneBound where + mempty = PlaneBound infPoint negInfPoint + where + infPoint = V2 (1 / 0) (1 / 0) + negInfPoint = V2 (negate 1 / 0) (negate 1 / 0) + + mappend (PlaneBound mini1 maxi1) (PlaneBound mini2 maxi2) = + PlaneBound (min <$> mini1 <*> mini2) + (max <$> maxi1 <*> maxi2) + +-- | Class used to calculate bounds of various geometrical +-- primitives. The calculated is precise, the bounding should +-- be minimal with respect with drawn curve. +class PlaneBoundable a where + -- | Given a graphical elements, calculate it's bounds. + planeBounds :: a -> PlaneBound + +instance PlaneBoundable Point where + planeBounds a = PlaneBound a a + +instance PlaneBoundable Line where + planeBounds (Line p1 p2) = planeBounds p1 <> planeBounds p2 + +instance PlaneBoundable Bezier where + planeBounds (Bezier p0 p1 p2) = + planeBounds (CubicBezier p0 p1 p1 p2) + +instance PlaneBoundable CubicBezier where + planeBounds = foldMap planeBounds . cubicBezierBounds + +instance PlaneBoundable Primitive where + planeBounds (LinePrim l) = planeBounds l + planeBounds (BezierPrim b) = planeBounds b + planeBounds (CubicBezierPrim c) = planeBounds c +
src/Graphics/Rasterific/QuadraticBezier.hs view
@@ -1,297 +1,292 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}--- | Module handling math regarding the handling of quadratic--- and cubic bezier curve.-module Graphics.Rasterific.QuadraticBezier- ( -- * Helper functions- straightLine- , bezierFromPath- , decomposeBeziers- , clipBezier- , sanitizeBezier- , offsetBezier- , flattenBezier- , bezierBreakAt- , bezierLengthApproximation- , isBezierPoint- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( pure )-import Data.Monoid( Monoid( mempty ) )-#endif-import Graphics.Rasterific.Linear- ( V2( .. )- , (^-^)- , (^+^)- , (^*)- , dot- , norm- , lerp- )--import Data.Monoid( (<>) )-import Graphics.Rasterific.Operators-import Graphics.Rasterific.Types---- | Create a list of bezier patch from a list of points,------ > bezierFromPath [a, b, c, d, e] == [Bezier a b c, Bezier c d e]--- > bezierFromPath [a, b, c, d, e, f] == [Bezier a b c, Bezier c d e]--- > bezierFromPath [a, b, c, d, e, f, g] ==--- > [Bezier a b c, Bezier c d e, Bezier e f g]----bezierFromPath :: [Point] -> [Bezier]-bezierFromPath (a:b:rest@(c:_)) = Bezier a b c : bezierFromPath rest-bezierFromPath _ = []--isBezierPoint :: Bezier -> Bool-isBezierPoint (Bezier a b c) =- not $ a `isDistingableFrom` b || - b `isDistingableFrom` c---- | Only work if the quadratic bezier curve--- is nearly flat-bezierLengthApproximation :: Bezier -> Float-bezierLengthApproximation (Bezier a _ c) =- norm $ c ^-^ a--decomposeBeziers :: Bezier -> Producer EdgeSample-decomposeBeziers (Bezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy)) =- go aRx aRy bRx bRy cRx cRy where- go ax ay _bx _by cx cy cont- | insideX && insideY =- let !px = fromIntegral $ min floorAx floorCx- !py = fromIntegral $ min floorAy floorCy- !w = px + 1 - cx `middle` ax- !h = cy - ay- in- EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont- where- floorAx, floorAy :: Int- !floorAx = floor ax- !floorAy = floor ay-- !floorCx = floor cx- !floorCy = floor cy-- !insideX = floorAx == floorCx || ceiling ax == (ceiling cx :: Int)- !insideY = floorAy == floorCy || ceiling ay == (ceiling cy :: Int)--- go !ax !ay !bx !by !cx !cy cont =- go ax ay abx aby mx my $ go mx my bcx bcy cx cy cont- where- !abx = ax `middle` bx- !aby = ay `middle` by-- !bcx = bx `middle` cx- !bcy = by `middle` cy-- !abbcx = abx `middle` bcx- !abbcy = aby `middle` bcy-- !mx | abs (abbcx - mini) < 0.1 = mini- | abs (abbcx - maxi) < 0.1 = maxi- | otherwise = abbcx- where !mini = fromIntegral (floor abbcx :: Int)- !maxi = fromIntegral (ceiling abbcx :: Int)-- !my | abs (abbcy - mini) < 0.1 = mini- | abs (abbcy - maxi) < 0.1 = maxi- | otherwise = abbcy- where !mini = fromIntegral (floor abbcy :: Int)- !maxi = fromIntegral (ceiling abbcy :: Int)----- | Create a quadratic bezier curve representing--- a straight line.-straightLine :: Point -> Point -> Bezier-straightLine a c = Bezier a (a `midPoint` c) c---- | Clamp the bezier curve inside a rectangle--- given in parameter.-clipBezier :: Point -- ^ Point representing the "minimal" point for cliping- -> Point -- ^ Point representing the "maximal" point for cliping- -> Bezier -- ^ The quadratic bezier curve to be clamped- -> Container Primitive-clipBezier mini maxi bezier@(Bezier a b c)- -- If we are in the range bound, return the curve- -- unaltered- | insideX && insideY = pure $ BezierPrim bezier- -- If one of the component is outside, clamp- -- the components on the boundaries and output a- -- straight line on this boundary. Useful for the- -- filing case, to clamp the polygon drawing on- -- the edge- | outsideX || outsideY =- pure . BezierPrim $ clampedA `straightLine` clampedC- -- Not completly inside nor outside, just divide- -- and conquer.- | otherwise =- recurse (Bezier a ab m) <>- recurse (Bezier m bc c)- where -- Minimal & maximal dimension of the bezier curve- bmin = vmin a $ vmin b c- bmax = vmax a $ vmax b c-- recurse = clipBezier mini maxi-- clamper = clampPoint mini maxi- clampedA = clamper a- clampedC = clamper c-- V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi- V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin-- --- -- X B- -- / \- -- / \- -- ab X--X--X bc- -- / abbc \- -- / \- -- A X X C- --- (ab, bc, abbc) = splitBezier bezier-- -- mini- -- +-------------+- -- | |- -- | |- -- | |- -- +-------------+- -- maxi- -- the edgeSeparator vector encode which edge- -- is te nearest to the midpoint.- -- if True then it's the 'min' edges which are- -- the nearest, otherwise it's the maximum edge- edgeSeparator =- vabs (abbc ^-^ mini) ^<^ vabs (abbc ^-^ maxi)-- -- So here we 'solidify' the nearest edge position- -- in an edge vector.- edge = vpartition edgeSeparator mini maxi-- -- If we're near an edge, snap the component to the- -- edge.- m = vpartition (vabs (abbc ^-^ edge) ^< 0.1) edge abbc----- | Rewrite the bezier curve to avoid degenerate cases.-sanitizeBezier :: Bezier -> Container Primitive-sanitizeBezier bezier@(Bezier a b c)- -- If the two normals vector are far apart (cos nearly -1)- --- -- u v- -- <---------- ------------>- -- because u dot v = ||u|| * ||v|| * cos(uv)- --- -- This imply that AB and BC are nearly parallel- | u `dot` v < -0.9999 =- -- divide in to halves with- sanitizeBezier (Bezier a (a `midPoint` abbc) abbc) <>- sanitizeBezier (Bezier abbc (abbc `midPoint` c) c)-- -- b is far enough of b and c, (it's not a point)- | a `isDistingableFrom` b && b `isDistingableFrom` c =- pure . BezierPrim $ bezier-- -- if b is to nearby a or c, take the midpoint as new reference.- | ac `isDistingableFrom` b = sanitizeBezier (Bezier a ac c)- | otherwise = mempty- where u = a `normal` b- v = b `normal` c- ac = a `midPoint` c- abbc = (a `midPoint` b) `midPoint` (b `midPoint` c)--bezierBreakAt :: Bezier -> Float -> (Bezier, Bezier)-bezierBreakAt (Bezier a b c) t = (Bezier a ab abbc, Bezier abbc bc c)- where- -- X B- -- / \- -- / \- -- ab X--X--X bc- -- / abbc \- -- / \- -- A X X C- ab = lerp t b a- bc = lerp t c b- abbc = lerp t bc ab--splitBezier :: Bezier -> (Point, Point, Point)-{-# INLINE splitBezier #-}-splitBezier (Bezier a b c) = (ab, bc, abbc)- where- --- -- X B- -- / \- -- / \- -- ab X--X--X bc- -- / abbc \- -- / \- -- A X X C- --- ab = a `midPoint` b- bc = b `midPoint` c- abbc = ab `midPoint` bc--flattenBezier :: Bezier -> Container Primitive-flattenBezier bezier@(Bezier a b c)- -- If the spline is not too curvy, just return the- -- shifted component- | u `dot` v >= 0.9 = pure $ BezierPrim bezier- -- Otherwise, divide and conquer- | a /= b && b /= c =- flattenBezier (Bezier a ab abbc) <>- flattenBezier (Bezier abbc bc c)- | otherwise = mempty- where --- -- X B - -- ^ /^\ ^- -- u \ /w| \ / v- -- X-----X- -- / \- -- / \- -- A X X C- --- u = a `normal` b- v = b `normal` c-- (ab, bc, abbc) = splitBezier bezier---- | Move the bezier to a new position with an offset.-offsetBezier :: Float -> Bezier -> Container Primitive-offsetBezier offset bezier@(Bezier a b c)- -- If the spline is not too curvy, just return the- -- shifted component- | u `dot` v >= 0.9 =- pure . BezierPrim $ Bezier shiftedA mergedB shiftedC- -- Otherwise, divide and conquer- | a /= b && b /= c =- offsetBezier offset (Bezier a ab abbc) <>- offsetBezier offset (Bezier abbc bc c)- | otherwise = mempty- where --- -- X B - -- ^ /^\ ^- -- u \ /w| \ / v- -- X-----X- -- / \- -- / \- -- A X X C- --- u = a `normal` b- v = b `normal` c- w = ab `normal` bc-- (ab, bc, abbc) = splitBezier bezier-- shiftedA = a ^+^ (u ^* offset)- shiftedC = c ^+^ (v ^* offset)- shiftedABBC = abbc ^+^ (w ^* offset)- mergedB =- (shiftedABBC ^* 2.0) ^-^ (shiftedA `midPoint` shiftedC)-+{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} +-- | Module handling math regarding the handling of quadratic +-- and cubic bezier curve. +module Graphics.Rasterific.QuadraticBezier + ( -- * Helper functions + straightLine + , bezierFromPath + , decomposeBeziers + , clipBezier + , sanitizeBezier + , offsetBezier + , flattenBezier + , bezierBreakAt + , bezierLengthApproximation + , isBezierPoint + ) where + +import Graphics.Rasterific.Linear + ( V2( .. ) + , (^-^) + , (^+^) + , (^*) + , dot + , norm + , lerp + ) + +import Data.Monoid( (<>) ) +import Graphics.Rasterific.Operators +import Graphics.Rasterific.Types + +-- | Create a list of bezier patch from a list of points, +-- +-- > bezierFromPath [a, b, c, d, e] == [Bezier a b c, Bezier c d e] +-- > bezierFromPath [a, b, c, d, e, f] == [Bezier a b c, Bezier c d e] +-- > bezierFromPath [a, b, c, d, e, f, g] == +-- > [Bezier a b c, Bezier c d e, Bezier e f g] +-- +bezierFromPath :: [Point] -> [Bezier] +bezierFromPath (a:b:rest@(c:_)) = Bezier a b c : bezierFromPath rest +bezierFromPath _ = [] + +isBezierPoint :: Bezier -> Bool +isBezierPoint (Bezier a b c) = + not $ a `isDistingableFrom` b || + b `isDistingableFrom` c + +-- | Only work if the quadratic bezier curve +-- is nearly flat +bezierLengthApproximation :: Bezier -> Float +bezierLengthApproximation (Bezier a _ c) = + norm $ c ^-^ a + +decomposeBeziers :: Bezier -> Producer EdgeSample +decomposeBeziers (Bezier (V2 aRx aRy) (V2 bRx bRy) (V2 cRx cRy)) = + go aRx aRy bRx bRy cRx cRy where + go ax ay _bx _by cx cy cont + | insideX && insideY = + let !px = fromIntegral $ min floorAx floorCx + !py = fromIntegral $ min floorAy floorCy + !w = px + 1 - cx `middle` ax + !h = cy - ay + in + EdgeSample (px + 0.5) (py + 0.5) (w * h) h : cont + where + floorAx, floorAy :: Int + !floorAx = floor ax + !floorAy = floor ay + + !floorCx = floor cx + !floorCy = floor cy + + !insideX = floorAx == floorCx || ceiling ax == (ceiling cx :: Int) + !insideY = floorAy == floorCy || ceiling ay == (ceiling cy :: Int) + + + go !ax !ay !bx !by !cx !cy cont = + go ax ay abx aby mx my $ go mx my bcx bcy cx cy cont + where + !abx = ax `middle` bx + !aby = ay `middle` by + + !bcx = bx `middle` cx + !bcy = by `middle` cy + + !abbcx = abx `middle` bcx + !abbcy = aby `middle` bcy + + !mx | abs (abbcx - mini) < 0.1 = mini + | abs (abbcx - maxi) < 0.1 = maxi + | otherwise = abbcx + where !mini = fromIntegral (floor abbcx :: Int) + !maxi = fromIntegral (ceiling abbcx :: Int) + + !my | abs (abbcy - mini) < 0.1 = mini + | abs (abbcy - maxi) < 0.1 = maxi + | otherwise = abbcy + where !mini = fromIntegral (floor abbcy :: Int) + !maxi = fromIntegral (ceiling abbcy :: Int) + + +-- | Create a quadratic bezier curve representing +-- a straight line. +straightLine :: Point -> Point -> Bezier +straightLine a c = Bezier a (a `midPoint` c) c + +-- | Clamp the bezier curve inside a rectangle +-- given in parameter. +clipBezier :: Point -- ^ Point representing the "minimal" point for cliping + -> Point -- ^ Point representing the "maximal" point for cliping + -> Bezier -- ^ The quadratic bezier curve to be clamped + -> Container Primitive +clipBezier mini maxi bezier@(Bezier a b c) + -- If we are in the range bound, return the curve + -- unaltered + | insideX && insideY = pure $ BezierPrim bezier + -- If one of the component is outside, clamp + -- the components on the boundaries and output a + -- straight line on this boundary. Useful for the + -- filing case, to clamp the polygon drawing on + -- the edge + | outsideX || outsideY = + pure . BezierPrim $ clampedA `straightLine` clampedC + -- Not completly inside nor outside, just divide + -- and conquer. + | otherwise = + recurse (Bezier a ab m) <> + recurse (Bezier m bc c) + where -- Minimal & maximal dimension of the bezier curve + bmin = vmin a $ vmin b c + bmax = vmax a $ vmax b c + + recurse = clipBezier mini maxi + + clamper = clampPoint mini maxi + clampedA = clamper a + clampedC = clamper c + + V2 insideX insideY = mini ^<=^ bmin ^&&^ bmax ^<=^ maxi + V2 outsideX outsideY = bmax ^<=^ mini ^||^ maxi ^<=^ bmin + + -- + -- X B + -- / \ + -- / \ + -- ab X--X--X bc + -- / abbc \ + -- / \ + -- A X X C + -- + (ab, bc, abbc) = splitBezier bezier + + -- mini + -- +-------------+ + -- | | + -- | | + -- | | + -- +-------------+ + -- maxi + -- the edgeSeparator vector encode which edge + -- is te nearest to the midpoint. + -- if True then it's the 'min' edges which are + -- the nearest, otherwise it's the maximum edge + edgeSeparator = + vabs (abbc ^-^ mini) ^<^ vabs (abbc ^-^ maxi) + + -- So here we 'solidify' the nearest edge position + -- in an edge vector. + edge = vpartition edgeSeparator mini maxi + + -- If we're near an edge, snap the component to the + -- edge. + m = vpartition (vabs (abbc ^-^ edge) ^< 0.1) edge abbc + + +-- | Rewrite the bezier curve to avoid degenerate cases. +sanitizeBezier :: Bezier -> Container Primitive +sanitizeBezier bezier@(Bezier a b c) + -- If the two normals vector are far apart (cos nearly -1) + -- + -- u v + -- <---------- ------------> + -- because u dot v = ||u|| * ||v|| * cos(uv) + -- + -- This imply that AB and BC are nearly parallel + | u `dot` v < -0.9999 = + -- divide in to halves with + sanitizeBezier (Bezier a (a `midPoint` abbc) abbc) <> + sanitizeBezier (Bezier abbc (abbc `midPoint` c) c) + + -- b is far enough of b and c, (it's not a point) + | a `isDistingableFrom` b && b `isDistingableFrom` c = + pure . BezierPrim $ bezier + + -- if b is to nearby a or c, take the midpoint as new reference. + | ac `isDistingableFrom` b = sanitizeBezier (Bezier a ac c) + | otherwise = mempty + where u = a `normal` b + v = b `normal` c + ac = a `midPoint` c + abbc = (a `midPoint` b) `midPoint` (b `midPoint` c) + +bezierBreakAt :: Bezier -> Float -> (Bezier, Bezier) +bezierBreakAt (Bezier a b c) t = (Bezier a ab abbc, Bezier abbc bc c) + where + -- X B + -- / \ + -- / \ + -- ab X--X--X bc + -- / abbc \ + -- / \ + -- A X X C + ab = lerp t b a + bc = lerp t c b + abbc = lerp t bc ab + +splitBezier :: Bezier -> (Point, Point, Point) +{-# INLINE splitBezier #-} +splitBezier (Bezier a b c) = (ab, bc, abbc) + where + -- + -- X B + -- / \ + -- / \ + -- ab X--X--X bc + -- / abbc \ + -- / \ + -- A X X C + -- + ab = a `midPoint` b + bc = b `midPoint` c + abbc = ab `midPoint` bc + +flattenBezier :: Bezier -> Container Primitive +flattenBezier bezier@(Bezier a b c) + -- If the spline is not too curvy, just return the + -- shifted component + | u `dot` v >= 0.9 = pure $ BezierPrim bezier + -- Otherwise, divide and conquer + | a /= b && b /= c = + flattenBezier (Bezier a ab abbc) <> + flattenBezier (Bezier abbc bc c) + | otherwise = mempty + where -- + -- X B + -- ^ /^\ ^ + -- u \ /w| \ / v + -- X-----X + -- / \ + -- / \ + -- A X X C + -- + u = a `normal` b + v = b `normal` c + + (ab, bc, abbc) = splitBezier bezier + +-- | Move the bezier to a new position with an offset. +offsetBezier :: Float -> Bezier -> Container Primitive +offsetBezier offset bezier@(Bezier a b c) + -- If the spline is not too curvy, just return the + -- shifted component + | u `dot` v >= 0.9 = + pure . BezierPrim $ Bezier shiftedA mergedB shiftedC + -- Otherwise, divide and conquer + | a /= b && b /= c = + offsetBezier offset (Bezier a ab abbc) <> + offsetBezier offset (Bezier abbc bc c) + | otherwise = mempty + where -- + -- X B + -- ^ /^\ ^ + -- u \ /w| \ / v + -- X-----X + -- / \ + -- / \ + -- A X X C + -- + u = a `normal` b + v = b `normal` c + w = ab `normal` bc + + (ab, bc, abbc) = splitBezier bezier + + shiftedA = a ^+^ (u ^* offset) + shiftedC = c ^+^ (v ^* offset) + shiftedABBC = abbc ^+^ (w ^* offset) + mergedB = + (shiftedABBC ^* 2.0) ^-^ (shiftedA `midPoint` shiftedC) +
src/Graphics/Rasterific/QuadraticFormula.hs view
@@ -1,54 +1,49 @@-{-# LANGUAGE CPP #-}-module Graphics.Rasterific.QuadraticFormula( QuadraticFormula( .. )- , discriminant- , formulaRoots- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( Applicative( .. ) )-#endif---- | Represent an equation `a * x^2 + b * x + c = 0`-data QuadraticFormula a = QuadraticFormula- { _coeffA :: !a -- ^ Coefficient for the square part (x^2)- , _coeffB :: !a -- ^ Coefficient the linear part (x)- , _coeffC :: !a -- ^ Constant- }--instance Functor QuadraticFormula where- {-# INLINE fmap #-}- fmap f (QuadraticFormula a b c) =- QuadraticFormula (f a) (f b) (f c)--instance Applicative QuadraticFormula where- pure a = QuadraticFormula a a a- {-# INLINE pure #-}-- QuadraticFormula a b c <*> QuadraticFormula d e f =- QuadraticFormula (a d) (b e) (c f)- {-# INLINE (<*>) #-}---- | Discriminant equation, if the result is:------ * Below 0, then the formula doesn't have any solution------ * Equal to 0, then the formula has an unique root.------ * Above 0, the formula has two solutions----discriminant :: Num a => QuadraticFormula a -> a-discriminant (QuadraticFormula a b c) = b * b - 4 * a *c---- | Extract all the roots of the formula ie. where the--- unknown gives a result of 0-formulaRoots :: (Ord a, Floating a) => QuadraticFormula a -> [a]-formulaRoots formula@(QuadraticFormula a b _)- | disc < 0 = []- | disc == 0 = [positiveResult]- | otherwise = [positiveResult, negativeResult]- where- disc = discriminant formula- squarePart = sqrt disc- positiveResult = (negate b + squarePart) / (2 * a)- negativeResult = (negate b - squarePart) / (2 * a)-+module Graphics.Rasterific.QuadraticFormula( QuadraticFormula( .. ) + , discriminant + , formulaRoots + ) where + +-- | Represent an equation `a * x^2 + b * x + c = 0` +data QuadraticFormula a = QuadraticFormula + { _coeffA :: !a -- ^ Coefficient for the square part (x^2) + , _coeffB :: !a -- ^ Coefficient the linear part (x) + , _coeffC :: !a -- ^ Constant + } + +instance Functor QuadraticFormula where + {-# INLINE fmap #-} + fmap f (QuadraticFormula a b c) = + QuadraticFormula (f a) (f b) (f c) + +instance Applicative QuadraticFormula where + pure a = QuadraticFormula a a a + {-# INLINE pure #-} + + QuadraticFormula a b c <*> QuadraticFormula d e f = + QuadraticFormula (a d) (b e) (c f) + {-# INLINE (<*>) #-} + +-- | Discriminant equation, if the result is: +-- +-- * Below 0, then the formula doesn't have any solution +-- +-- * Equal to 0, then the formula has an unique root. +-- +-- * Above 0, the formula has two solutions +-- +discriminant :: Num a => QuadraticFormula a -> a +discriminant (QuadraticFormula a b c) = b * b - 4 * a *c + +-- | Extract all the roots of the formula ie. where the +-- unknown gives a result of 0 +formulaRoots :: (Ord a, Floating a) => QuadraticFormula a -> [a] +formulaRoots formula@(QuadraticFormula a b _) + | disc < 0 = [] + | disc == 0 = [positiveResult] + | otherwise = [positiveResult, negativeResult] + where + disc = discriminant formula + squarePart = sqrt disc + positiveResult = (negate b + squarePart) / (2 * a) + negativeResult = (negate b - squarePart) / (2 * a) +
src/Graphics/Rasterific/Rasterize.hs view
@@ -1,97 +1,92 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-module Graphics.Rasterific.Rasterize- ( CoverageSpan( .. )- , rasterize- , toOpaqueCoverage- , clip- ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable( foldMap )-#endif--import Control.Monad.ST( runST )-import Data.Fixed( mod' )-import Data.Monoid( Endo( Endo, appEndo ) )-import Graphics.Rasterific.Types-import Graphics.Rasterific.QuadraticBezier-import Graphics.Rasterific.CubicBezier-import Graphics.Rasterific.Line-import qualified Data.Vector as V-import qualified Data.Vector.Algorithms.Intro as VS--data CoverageSpan = CoverageSpan- { _coverageX :: {-# UNPACK #-} !Float- , _coverageY :: {-# UNPACK #-} !Float- , _coverageVal :: {-# UNPACK #-} !Float- , _coverageLength :: {-# UNPACK #-} !Float- }- deriving Show--toOpaqueCoverage :: CoverageSpan -> CoverageSpan-{-# INLINE toOpaqueCoverage #-}-toOpaqueCoverage coverage = coverage { _coverageVal = 1 }--combineEdgeSamples :: (Float -> Float) -> V.Vector EdgeSample- -> [CoverageSpan]-{-# INLINE combineEdgeSamples #-}-combineEdgeSamples prepareCoverage vec = go 0 0 0 0 0- where- !maxi = V.length vec- go !ix !x !y !a !_h | ix >= maxi = [CoverageSpan x y (prepareCoverage a) 1]- go !ix !x !y !a !h = sub (vec `V.unsafeIndex` ix) where- sub (EdgeSample x' y' a' h')- | y == y' && x == x' = go (ix + 1) x' y' (a + a') (h + h')- | y == y' = p1 : p2 : go (ix + 1) x' y' (h + a') (h + h')- | otherwise =- CoverageSpan x y (prepareCoverage a) 1 : go (ix + 1) x' y' a' h'- where p1 = CoverageSpan x y (prepareCoverage a) 1- p2 = CoverageSpan (x + 1) y (prepareCoverage h) (x' - x - 1)---- | Clip the geometry to a rectangle.-clip :: Point -- ^ Minimum point (corner upper left)- -> Point -- ^ Maximum point (corner bottom right)- -> Primitive -- ^ Primitive to be clipped- -> Container Primitive-clip mini maxi (LinePrim l) = clipLine mini maxi l-clip mini maxi (BezierPrim b) = clipBezier mini maxi b-clip mini maxi (CubicBezierPrim c) = clipCubicBezier mini maxi c--decompose :: Primitive -> Producer EdgeSample-decompose (LinePrim l) = decomposeLine l-decompose (BezierPrim b) = decomposeBeziers b-decompose (CubicBezierPrim c) =- {-decomposeCubicBezierForwardDifference c-}- decomposeCubicBeziers c--xyCompare :: EdgeSample -> EdgeSample -> Ordering-{-# INLINE xyCompare #-}-xyCompare !(EdgeSample { _sampleY = ay, _sampleX = ax })- !(EdgeSample { _sampleY = by, _sampleX = bx }) =- case compare ay by of- EQ -> compare ax bx- c -> c--sortEdgeSamples :: [EdgeSample] -> V.Vector EdgeSample-sortEdgeSamples samples = runST $ do- -- Resist the urge to make this a storable vector,- -- it is actually a pessimisation.- mutableVector <- V.unsafeThaw $ V.fromList samples- VS.sortBy xyCompare mutableVector- V.unsafeFreeze mutableVector--rasterize :: FillMethod -> Container Primitive -> [CoverageSpan]-rasterize method = - case method of- FillWinding -> combineEdgeSamples combineWinding - . sortEdgeSamples- . (($ []) . appEndo)- . foldMap (Endo . decompose)- FillEvenOdd -> combineEdgeSamples combineEvenOdd- . sortEdgeSamples- . (($ []) . appEndo)- . foldMap (Endo . decompose)- where combineWinding = min 1 . abs- combineEvenOdd cov = abs $ abs (cov - 1) `mod'` 2 - 1-+{-# LANGUAGE BangPatterns #-} +module Graphics.Rasterific.Rasterize + ( CoverageSpan( .. ) + , rasterize + , toOpaqueCoverage + , clip + ) where + +import Control.Monad.ST( runST ) +import Data.Fixed( mod' ) +import Data.Monoid( Endo( Endo, appEndo ) ) +import Graphics.Rasterific.Types +import Graphics.Rasterific.QuadraticBezier +import Graphics.Rasterific.CubicBezier +import Graphics.Rasterific.Line +import qualified Data.Vector as V +import qualified Data.Vector.Algorithms.Intro as VS + +data CoverageSpan = CoverageSpan + { _coverageX :: {-# UNPACK #-} !Float + , _coverageY :: {-# UNPACK #-} !Float + , _coverageVal :: {-# UNPACK #-} !Float + , _coverageLength :: {-# UNPACK #-} !Float + } + deriving Show + +toOpaqueCoverage :: CoverageSpan -> CoverageSpan +{-# INLINE toOpaqueCoverage #-} +toOpaqueCoverage coverage = coverage { _coverageVal = 1 } + +combineEdgeSamples :: (Float -> Float) -> V.Vector EdgeSample + -> [CoverageSpan] +{-# INLINE combineEdgeSamples #-} +combineEdgeSamples prepareCoverage vec = go 0 0 0 0 0 + where + !maxi = V.length vec + go !ix !x !y !a !_h | ix >= maxi = [CoverageSpan x y (prepareCoverage a) 1] + go !ix !x !y !a !h = sub (vec `V.unsafeIndex` ix) where + sub (EdgeSample x' y' a' h') + | y == y' && x == x' = go (ix + 1) x' y' (a + a') (h + h') + | y == y' = p1 : p2 : go (ix + 1) x' y' (h + a') (h + h') + | otherwise = + CoverageSpan x y (prepareCoverage a) 1 : go (ix + 1) x' y' a' h' + where p1 = CoverageSpan x y (prepareCoverage a) 1 + p2 = CoverageSpan (x + 1) y (prepareCoverage h) (x' - x - 1) + +-- | Clip the geometry to a rectangle. +clip :: Point -- ^ Minimum point (corner upper left) + -> Point -- ^ Maximum point (corner bottom right) + -> Primitive -- ^ Primitive to be clipped + -> Container Primitive +clip mini maxi (LinePrim l) = clipLine mini maxi l +clip mini maxi (BezierPrim b) = clipBezier mini maxi b +clip mini maxi (CubicBezierPrim c) = clipCubicBezier mini maxi c + +decompose :: Primitive -> Producer EdgeSample +decompose (LinePrim l) = decomposeLine l +decompose (BezierPrim b) = decomposeBeziers b +decompose (CubicBezierPrim c) = + {-decomposeCubicBezierForwardDifference c-} + decomposeCubicBeziers c + +xyCompare :: EdgeSample -> EdgeSample -> Ordering +{-# INLINE xyCompare #-} +xyCompare !(EdgeSample { _sampleY = ay, _sampleX = ax }) + !(EdgeSample { _sampleY = by, _sampleX = bx }) = + case compare ay by of + EQ -> compare ax bx + c -> c + +sortEdgeSamples :: [EdgeSample] -> V.Vector EdgeSample +sortEdgeSamples samples = runST $ do + -- Resist the urge to make this a storable vector, + -- it is actually a pessimisation. + mutableVector <- V.unsafeThaw $ V.fromList samples + VS.sortBy xyCompare mutableVector + V.unsafeFreeze mutableVector + +rasterize :: FillMethod -> Container Primitive -> [CoverageSpan] +rasterize method = + case method of + FillWinding -> combineEdgeSamples combineWinding + . sortEdgeSamples + . (($ []) . appEndo) + . foldMap (Endo . decompose) + FillEvenOdd -> combineEdgeSamples combineEvenOdd + . sortEdgeSamples + . (($ []) . appEndo) + . foldMap (Endo . decompose) + where combineWinding = min 1 . abs + combineEvenOdd cov = abs $ abs (cov - 1) `mod'` 2 - 1 +
src/Graphics/Rasterific/Shading.hs view
@@ -1,482 +1,443 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}-module Graphics.Rasterific.Shading- ( transformTextureToFiller- , sampledImageShader- , plotOpaquePixel- , unsafePlotOpaquePixel- ) where--import Control.Monad.ST( ST )-import Control.Monad.Primitive( PrimState- -- one day (GHC >= 7.10 ?)- , PrimMonad- )-import Data.Fixed( mod' )-import Data.Monoid( (<>) )-import Graphics.Rasterific.Command-import Graphics.Rasterific.Linear- ( V2( .. )- , (^-^)- , (^/)- , dot- , norm- )--import qualified Data.Vector as V--import Codec.Picture.Types( Pixel( .. )- , Image( .. )- , MutableImage( .. )- , Pixel8- , PixelRGBA8- , unsafeWritePixelBetweenAt- , readPackedPixelAt- , writePackedPixelAt- )--import Graphics.Rasterific.Types( Point- , Vector- , Line( .. )- , SamplerRepeat( .. ) )-import Graphics.Rasterific.Transformations-import Graphics.Rasterific.Rasterize-import Graphics.Rasterific.Compositor( Modulable( .. )- , ModulablePixel- , RenderablePixel- , compositionAlpha )---data TextureSpaceInfo = TextureSpaceInfo- { _tsStart :: {-# UNPACK #-} !Point- , _tsDelta :: {-# UNPACK #-} !Vector- , _tsCoverage :: {-# UNPACK #-} !Float- , _tsRepeat :: {-# UNPACK #-} !Int- , _tsBaseIndex :: {-# UNPACK #-} !Int- }- deriving (Eq, Show)--type CoverageFiller m px =- MutableImage (PrimState m) px -> CoverageSpan -> m ()--type Filler m =- TextureSpaceInfo -> m ()---- | Right now, we must stick to ST, due to the fact that--- we can't specialize with parameterized monad :(-solidColor :: forall s px . (ModulablePixel px)- => px -> MutableImage s px -> Filler (ST s)-{-# SPECIALIZE solidColor :: PixelRGBA8 -> MutableImage s PixelRGBA8- -> TextureSpaceInfo -> ST s () #-}-{-# SPECIALIZE solidColor :: Pixel8 -> MutableImage s Pixel8- -> TextureSpaceInfo -> ST s () #-}-solidColor color _ tsInfo- | pixelOpacity color == emptyValue || _tsCoverage tsInfo <= 0 =- return ()-solidColor color img tsInfo- -- We are in the case fully opaque, so we can- -- just overwrite what was there before- | pixelOpacity color == fullOpacity && _tsCoverage tsInfo >= 1 =- unsafeWritePixelBetweenAt img color (_tsBaseIndex tsInfo) maxi- {-go 0 $ _tsBaseIndex tsInfo-}- where- !fullOpacity = fullValue :: PixelBaseComponent px- !maxi = _tsRepeat tsInfo---- We can be transparent, so perform alpha blending.-solidColor color img tsInfo = go 0 $ _tsBaseIndex tsInfo- where- !opacity = pixelOpacity color- !(scanCoverage,_) = clampCoverage $_tsCoverage tsInfo- !(cov, icov) = coverageModulate scanCoverage opacity- !maxi = _tsRepeat tsInfo- !compCount = componentCount (undefined :: px)-- go count _ | count >= maxi = return ()- go !count !idx = do- oldPixel <- readPackedPixelAt img idx- writePackedPixelAt img idx- $ compositionAlpha cov icov oldPixel color- go (count + 1) $ idx + compCount----- | Plot a single pixel on the resulting image.-plotOpaquePixel :: forall m px. (ModulablePixel px, PrimMonad m)- => MutableImage (PrimState m) px -> px -> Int -> Int- -> m ()-{-# INLINE plotOpaquePixel #-}-plotOpaquePixel img _color x y- | x < 0 || y < 0 || - x >= mutableImageWidth img || y >= mutableImageHeight img = return ()-plotOpaquePixel img color x y = do- let !idx = (y * mutableImageWidth img + x) * (componentCount (undefined :: px))- writePackedPixelAt img idx color---- | Plot a single pixel on the resulting image, no bounds check are--- performed, ensure index is correct!-unsafePlotOpaquePixel :: forall m px. (ModulablePixel px, PrimMonad m)- => MutableImage (PrimState m) px -> px -> Int -> Int- -> m ()-{-# INLINE unsafePlotOpaquePixel #-}-unsafePlotOpaquePixel img color x y = do- let !idx = (y * mutableImageWidth img + x) * (componentCount (undefined :: px))- writePackedPixelAt img idx color--shaderFiller :: forall s px . (ModulablePixel px)- => ShaderFunction px -> MutableImage s px- -> Filler (ST s)-{-# SPECIALIZE shaderFiller :: ShaderFunction PixelRGBA8- -> MutableImage s PixelRGBA8- -> Filler (ST s) #-}-{-# SPECIALIZE shaderFiller :: ShaderFunction Pixel8- -> MutableImage s Pixel8- -> Filler (ST s) #-}-shaderFiller shader img tsInfo =- go 0 (_tsBaseIndex tsInfo) xStart yStart- where- !(scanCoverage,_) = clampCoverage $_tsCoverage tsInfo- !maxi = _tsRepeat tsInfo- !compCount = componentCount (undefined :: px)- (V2 xStart yStart) = _tsStart tsInfo- (V2 dx dy) = _tsDelta tsInfo-- go count _ _ _ | count >= maxi = return ()- go !count !idx !x !y = do- let !color = shader x y- !opacity = pixelOpacity color- (cov, icov) = coverageModulate scanCoverage opacity- oldPixel <- readPackedPixelAt img idx- writePackedPixelAt img idx- $ compositionAlpha cov icov oldPixel color- go (count + 1) (idx + compCount) (x + dx) (y + dy)--prepareInfoNoTransform :: (Pixel px)- => MutableImage s px -> CoverageSpan- -> TextureSpaceInfo-prepareInfoNoTransform img coverage = TextureSpaceInfo- { _tsStart = V2 (_coverageX coverage) (_coverageY coverage)- , _tsDelta = V2 1 0- , _tsCoverage = _coverageVal coverage- , _tsRepeat = floor $ _coverageLength coverage- , _tsBaseIndex =- mutablePixelBaseIndex img (floor $ _coverageX coverage)- (floor $ _coverageY coverage)- }--prepareInfo :: (Pixel px)- => Maybe Transformation -> MutableImage s px -> CoverageSpan- -> TextureSpaceInfo-prepareInfo Nothing img covSpan = prepareInfoNoTransform img covSpan-prepareInfo (Just t) img covSpan = TextureSpaceInfo- { _tsStart = applyTransformation t- $ V2 (_coverageX covSpan) (_coverageY covSpan)- , _tsDelta = applyVectorTransformation t $ V2 1 0- , _tsCoverage = _coverageVal covSpan- , _tsRepeat = floor $ _coverageLength covSpan- , _tsBaseIndex =- mutablePixelBaseIndex img (floor $ _coverageX covSpan)- (floor $ _coverageY covSpan)- }--combineTransform :: Maybe Transformation -> Transformation- -> Maybe Transformation-combineTransform Nothing a = Just a-combineTransform (Just v) a = Just $ v <> a--withTrans :: Maybe Transformation -> ShaderFunction px- -> ShaderFunction px-withTrans Nothing shader = shader-withTrans (Just v) shader = \x y ->- let V2 x' y' = applyTransformation v (V2 x y) in- shader x' y'---- | The intent of shader texture is to provide ease of implementation--- If possible providing a custom filler will be more efficient,--- like already done for the solid colors.-shaderOfTexture :: forall px . RenderablePixel px- => Maybe Transformation -> SamplerRepeat -> Texture px- -> ShaderFunction px-{-# SPECIALIZE- shaderOfTexture :: Maybe Transformation -> SamplerRepeat -> Texture PixelRGBA8- -> ShaderFunction PixelRGBA8 #-}-{-# SPECIALIZE- shaderOfTexture :: Maybe Transformation -> SamplerRepeat -> Texture Pixel8- -> ShaderFunction Pixel8 #-}-shaderOfTexture _ _ (SolidTexture px) = \_ _ -> px-shaderOfTexture _ _ (MeshPatchTexture _ _) = error "MeshPatch should be precomputed"-shaderOfTexture trans sampling (LinearGradientTexture grad (Line a b)) =- withTrans trans $ linearGradientShader grad a b sampling-shaderOfTexture trans sampling (RadialGradientTexture grad center radius) =- withTrans trans $ radialGradientShader grad center radius sampling-shaderOfTexture trans sampling (RadialGradientWithFocusTexture grad center - radius focus) =- withTrans trans- $ radialGradientWithFocusShader grad center radius focus- sampling-shaderOfTexture trans _ (WithSampler sampler sub) =- shaderOfTexture trans sampler sub-shaderOfTexture trans sampling (WithTextureTransform transform sub) =- shaderOfTexture (combineTransform trans transform) sampling sub-shaderOfTexture trans sampling (SampledTexture img) =- withTrans trans $ sampledImageShader img sampling-shaderOfTexture trans _ (ShaderTexture func) =- withTrans trans func-shaderOfTexture trans _ (RawTexture img) =- withTrans trans $ imageShader img-shaderOfTexture trans _sampling (PatternTexture _ _ _ _ img) =- shaderOfTexture trans SamplerRepeat $ SampledTexture img-shaderOfTexture trans sampling (ModulateTexture texture modulation) =- modulateTexture (shaderOfTexture trans sampling texture)- (shaderOfTexture trans sampling modulation)-shaderOfTexture trans sampling (AlphaModulateTexture texture modulation) =- alphaModulateTexture- (shaderOfTexture trans sampling texture)- (shaderOfTexture trans sampling modulation)----- | This function will interpret the texture description, helping--- prepare and optimize the real calculation-transformTextureToFiller- :: (RenderablePixel px)- => Texture px -> CoverageFiller (ST s) px-transformTextureToFiller = go Nothing SamplerPad- where- go _ _ (SolidTexture px) =- \img -> solidColor px img . prepareInfoNoTransform img- go trans sampling (WithTextureTransform transform sub) =- go (combineTransform trans transform) sampling sub- go trans _ (WithSampler sampler sub) =- go trans sampler sub- go trans sampling tex =- \img -> shaderFiller shader img . prepareInfo trans img- where shader = shaderOfTexture Nothing sampling tex--type GradientArray px = V.Vector (Float, px)--repeatGradient :: Float -> Float-repeatGradient s = s - fromIntegral (floor s :: Int)--reflectGradient :: Float -> Float-reflectGradient s =- abs (abs (s - 1) `mod'` 2 - 1)- -gradientColorAt :: ModulablePixel px- => GradientArray px -> Float -> px-{-# SPECIALIZE- gradientColorAt :: GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-}-{-# SPECIALIZE- gradientColorAt :: GradientArray Pixel8 -> Float -> Pixel8 #-}-gradientColorAt grad at- | at <= 0 = snd $ V.head grad- | at >= 1.0 = snd $ V.last grad- | otherwise = go (0, snd $ V.head grad) 0- where- !maxi = V.length grad- go (prevCoeff, prevValue) ix- | ix >= maxi = snd $ V.last grad- | at < coeff = mixWith (\_ -> alphaOver cov icov) prevValue px- | otherwise = go value $ ix + 1- where value@(coeff, px) = grad `V.unsafeIndex` ix- zeroToOne = (at - prevCoeff) / (coeff - prevCoeff)- (cov, icov) = clampCoverage zeroToOne--gradientColorAtRepeat :: ModulablePixel px- => SamplerRepeat -> GradientArray px -> Float -> px-{-# SPECIALIZE INLINE- gradientColorAtRepeat ::- SamplerRepeat -> GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-}-{-# SPECIALIZE INLINE- gradientColorAtRepeat ::- SamplerRepeat -> GradientArray Pixel8 -> Float -> Pixel8 #-}-gradientColorAtRepeat SamplerPad grad = gradientColorAt grad-gradientColorAtRepeat SamplerRepeat grad =- gradientColorAt grad . repeatGradient-gradientColorAtRepeat SamplerReflect grad =- gradientColorAt grad . reflectGradient--linearGradientShader :: ModulablePixel px- => Gradient px -- ^ Gradient description.- -> Point -- ^ Linear gradient start point.- -> Point -- ^ Linear gradient end point.- -> SamplerRepeat- -> ShaderFunction px-{-# SPECIALIZE linearGradientShader- :: Gradient PixelRGBA8 -> Point -> Point -> SamplerRepeat- -> ShaderFunction PixelRGBA8 #-}-{-# SPECIALIZE linearGradientShader- :: Gradient Pixel8 -> Point -> Point -> SamplerRepeat- -> ShaderFunction Pixel8 #-}-linearGradientShader gradient start end repeating =- \x y -> colorAt $ (V2 x y `dot` d) - s00- where- colorAt = gradientColorAtRepeat repeating gradArray- gradArray = V.fromList gradient- vector = end ^-^ start- d = vector ^/ (vector `dot` vector)- s00 = start `dot` d---- | Use another image as a texture for the filling.--- Contrary to `imageTexture`, this function perform a bilinear--- filtering on the texture.----sampledImageShader :: forall px. ModulablePixel px- => Image px -> SamplerRepeat -> ShaderFunction px-{-# SPECIALIZE- sampledImageShader :: Image Pixel8 -> SamplerRepeat- -> ShaderFunction Pixel8 #-}-{-# SPECIALIZE- sampledImageShader :: Image PixelRGBA8 -> SamplerRepeat- -> ShaderFunction PixelRGBA8 #-}-sampledImageShader img sampling x y =- (at px py `interpX` at pxn py)- `interpY`- (at px pyn `interpX` at pxn pyn)- where- coordSampler SamplerPad maxi v =- min (maxi - 1) . max 0 $ floor v- coordSampler SamplerReflect maxi v =- floor $ abs (abs (v - maxif - 1) `mod'` (2 * maxif) - maxif - 1)- where maxif = fromIntegral maxi- coordSampler SamplerRepeat maxi v = floor v `mod` maxi-- w = fromIntegral $ imageWidth img- h = fromIntegral $ imageHeight img-- clampedX = coordSampler sampling w- clampedY = coordSampler sampling h-- px = clampedX x- pxn = clampedX $ x + 1- py = clampedY y- pyn = clampedY $ y + 1-- dx, dy :: Float- !dx = x - fromIntegral (floor x :: Int)- !dy = y - fromIntegral (floor y :: Int)-- at :: Int -> Int -> px- at !xx !yy =- unsafePixelAt rawData $ (yy * w + xx) * compCount-- (covX, icovX) = clampCoverage dx- (covY, icovY) = clampCoverage dy-- interpX = mixWith (const $ alphaOver covX icovX)- interpY = mixWith (const $ alphaOver covY icovY)-- compCount = componentCount (undefined :: px)- rawData = imageData img---- | Use another image as a texture for the filling.--- This texture use the "nearest" filtering, AKA no--- filtering at all.-imageShader :: forall px. (Pixel px) => Image px -> ShaderFunction px-{-# SPECIALIZE- imageShader :: Image PixelRGBA8 -> ShaderFunction PixelRGBA8 #-}-{-# SPECIALIZE- imageShader :: Image Pixel8 -> ShaderFunction Pixel8 #-}-imageShader img x y =- unsafePixelAt rawData $ (clampedY * w + clampedX) * compCount- where- clampedX = min (w - 1) . max 0 $ floor x- clampedY = min (h - 1) . max 0 $ floor y- !compCount = componentCount (undefined :: px)- !w = imageWidth img- !h = imageHeight img- !rawData = imageData img--radialGradientShader :: ModulablePixel px- => Gradient px -- ^ Gradient description- -> Point -- ^ Radial gradient center- -> Float -- ^ Radial gradient radius- -> SamplerRepeat- -> ShaderFunction px-{-# SPECIALIZE - radialGradientShader- :: Gradient PixelRGBA8 -> Point -> Float -> SamplerRepeat- -> ShaderFunction PixelRGBA8 #-}-{-# SPECIALIZE - radialGradientShader- :: Gradient Pixel8 -> Point -> Float -> SamplerRepeat- -> ShaderFunction Pixel8 #-}-radialGradientShader gradient center radius repeating =- \x y -> colorAt $ norm (V2 x y ^-^ center) / radius- where- !colorAt = gradientColorAtRepeat repeating gradArray- !gradArray = V.fromList gradient--radialGradientWithFocusShader- :: ModulablePixel px- => Gradient px -- ^ Gradient description- -> Point -- ^ Radial gradient center- -> Float -- ^ Radial gradient radius- -> Point -- ^ Radial gradient focus point- -> SamplerRepeat- -> ShaderFunction px-{-# SPECIALIZE- radialGradientWithFocusShader- :: Gradient PixelRGBA8 -> Point -> Float -> Point- -> SamplerRepeat -> ShaderFunction PixelRGBA8 #-}-{-# SPECIALIZE- radialGradientWithFocusShader- :: Gradient Pixel8 -> Point -> Float -> Point- -> SamplerRepeat -> ShaderFunction Pixel8 #-}-radialGradientWithFocusShader gradient center radius focusScreen repeating =- \x y -> colorAt . go $ V2 x y ^-^ center- where- focus@(V2 origFocusX origFocusY) = focusScreen ^-^ center- colorAt = gradientColorAtRepeat repeating gradArray- gradArray = V.fromList gradient- radiusSquared = radius * radius- dist = sqrt $ focus `dot` focus- clampedFocus@(V2 focusX focusY)- | dist <= r = focus- | otherwise = V2 (r * cos a) (r * sin a)- where a = atan2 origFocusY origFocusX- r = radius * 0.99- trivial = sqrt $ radiusSquared - origFocusX * origFocusX-- solutionOf (V2 x y) | x == focusX =- V2 focusX (if y > focusY then trivial else negate trivial)- solutionOf (V2 x y) = V2 xSolution $ slope * xSolution + yint- where- slope = (y - focusY) / (x - focusX)- yint = y - (slope * x)-- a = slope * slope + 1- b = 2 * slope * yint- c = yint * yint - radiusSquared- det = sqrt $ b * b - 4 * a * c- xSolution = (-b + (if x < focusX then negate det else det)) / (2 * a)-- go pos = sqrt $ curToFocus / distSquared- where- solution = solutionOf pos ^-^ clampedFocus- toFocus = pos ^-^ clampedFocus- distSquared = solution `dot` solution- curToFocus = toFocus `dot` toFocus---- | Perform a multiplication operation between a full color texture--- and a greyscale one, used for clip-path implementation.-modulateTexture :: ModulablePixel px- => ShaderFunction px- -> ShaderFunction (PixelBaseComponent px)- -> ShaderFunction px-{-# INLINE modulateTexture #-}-modulateTexture fullTexture modulator x y =- colorMap (modulate $ modulator x y) $ fullTexture x y---- | Perform a multiplication operation between a full color texture--- and a greyscale one, used for clip-path implementation.-alphaModulateTexture :: ModulablePixel px- => ShaderFunction px- -> ShaderFunction (PixelBaseComponent px)- -> ShaderFunction px-{-# INLINE alphaModulateTexture #-}-alphaModulateTexture fullTexture modulator x y =- let px = fullTexture x y in- mixWithAlpha (\_ _ a -> a) (\_ _ -> modulator x y) px px-+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +module Graphics.Rasterific.Shading + ( transformTextureToFiller + , sampledImageShader + , plotOpaquePixel + , unsafePlotOpaquePixel + ) where + +import Control.Monad.ST( ST ) +import Control.Monad.Primitive( PrimState + -- one day (GHC >= 7.10 ?) + , PrimMonad + ) +import Data.Fixed( mod' ) +import Data.Monoid( (<>) ) +import Graphics.Rasterific.Command +import Graphics.Rasterific.BiSampleable +import Graphics.Rasterific.Linear + ( V2( .. ) + , (^-^) + , (^/) + , dot + , norm + ) + +import qualified Data.Vector as V + +import Codec.Picture.Types( Pixel( .. ) + , Image( .. ) + , MutableImage( .. ) + , Pixel8 + , PixelRGBA8 + , unsafeWritePixelBetweenAt + , readPackedPixelAt + , writePackedPixelAt + ) + +import Graphics.Rasterific.Types( Point + , Vector + , Line( .. ) + , SamplerRepeat( .. ) ) +import Graphics.Rasterific.Transformations +import Graphics.Rasterific.Rasterize +import Graphics.Rasterific.PatchTypes +import Graphics.Rasterific.Compositor( Modulable( .. ) + , ModulablePixel + , RenderablePixel + , compositionAlpha ) + + +data TextureSpaceInfo = TextureSpaceInfo + { _tsStart :: {-# UNPACK #-} !Point + , _tsDelta :: {-# UNPACK #-} !Vector + , _tsCoverage :: {-# UNPACK #-} !Float + , _tsRepeat :: {-# UNPACK #-} !Int + , _tsBaseIndex :: {-# UNPACK #-} !Int + } + deriving (Eq, Show) + +type CoverageFiller m px = + MutableImage (PrimState m) px -> CoverageSpan -> m () + +type Filler m = + TextureSpaceInfo -> m () + +-- | Right now, we must stick to ST, due to the fact that +-- we can't specialize with parameterized monad :( +solidColor :: forall s px . (ModulablePixel px) + => px -> MutableImage s px -> Filler (ST s) +{-# SPECIALIZE solidColor :: PixelRGBA8 -> MutableImage s PixelRGBA8 + -> TextureSpaceInfo -> ST s () #-} +{-# SPECIALIZE solidColor :: Pixel8 -> MutableImage s Pixel8 + -> TextureSpaceInfo -> ST s () #-} +solidColor color _ tsInfo + | pixelOpacity color == emptyValue || _tsCoverage tsInfo <= 0 = + return () +solidColor color img tsInfo + -- We are in the case fully opaque, so we can + -- just overwrite what was there before + | pixelOpacity color == fullOpacity && _tsCoverage tsInfo >= 1 = + unsafeWritePixelBetweenAt img color (_tsBaseIndex tsInfo) maxi + {-go 0 $ _tsBaseIndex tsInfo-} + where + !fullOpacity = fullValue :: PixelBaseComponent px + !maxi = _tsRepeat tsInfo + +-- We can be transparent, so perform alpha blending. +solidColor color img tsInfo = go 0 $ _tsBaseIndex tsInfo + where + !opacity = pixelOpacity color + !(scanCoverage,_) = clampCoverage $_tsCoverage tsInfo + !(cov, icov) = coverageModulate scanCoverage opacity + !maxi = _tsRepeat tsInfo + !compCount = componentCount (undefined :: px) + + go count _ | count >= maxi = return () + go !count !idx = do + oldPixel <- readPackedPixelAt img idx + writePackedPixelAt img idx + $ compositionAlpha cov icov oldPixel color + go (count + 1) $ idx + compCount + + +-- | Plot a single pixel on the resulting image. +plotOpaquePixel :: forall m px. (ModulablePixel px, PrimMonad m) + => MutableImage (PrimState m) px -> px -> Int -> Int + -> m () +{-# INLINE plotOpaquePixel #-} +plotOpaquePixel img _color x y + | x < 0 || y < 0 || + x >= mutableImageWidth img || y >= mutableImageHeight img = return () +plotOpaquePixel img color x y = do + let !idx = (y * mutableImageWidth img + x) * (componentCount (undefined :: px)) + writePackedPixelAt img idx color + +-- | Plot a single pixel on the resulting image, no bounds check are +-- performed, ensure index is correct! +unsafePlotOpaquePixel :: forall m px. (ModulablePixel px, PrimMonad m) + => MutableImage (PrimState m) px -> px -> Int -> Int + -> m () +{-# INLINE unsafePlotOpaquePixel #-} +unsafePlotOpaquePixel img color x y = do + let !idx = (y * mutableImageWidth img + x) * (componentCount (undefined :: px)) + writePackedPixelAt img idx color + +shaderFiller :: forall s px . (ModulablePixel px) + => ShaderFunction px -> MutableImage s px + -> Filler (ST s) +{-# SPECIALIZE shaderFiller :: ShaderFunction PixelRGBA8 + -> MutableImage s PixelRGBA8 + -> Filler (ST s) #-} +{-# SPECIALIZE shaderFiller :: ShaderFunction Pixel8 + -> MutableImage s Pixel8 + -> Filler (ST s) #-} +shaderFiller shader img tsInfo = + go 0 (_tsBaseIndex tsInfo) xStart yStart + where + !(scanCoverage,_) = clampCoverage $_tsCoverage tsInfo + !maxi = _tsRepeat tsInfo + !compCount = componentCount (undefined :: px) + (V2 xStart yStart) = _tsStart tsInfo + (V2 dx dy) = _tsDelta tsInfo + + go count _ _ _ | count >= maxi = return () + go !count !idx !x !y = do + let !color = shader x y + !opacity = pixelOpacity color + (cov, icov) = coverageModulate scanCoverage opacity + oldPixel <- readPackedPixelAt img idx + writePackedPixelAt img idx + $ compositionAlpha cov icov oldPixel color + go (count + 1) (idx + compCount) (x + dx) (y + dy) + +prepareInfoNoTransform :: (Pixel px) + => MutableImage s px -> CoverageSpan + -> TextureSpaceInfo +prepareInfoNoTransform img coverage = TextureSpaceInfo + { _tsStart = V2 (_coverageX coverage) (_coverageY coverage) + , _tsDelta = V2 1 0 + , _tsCoverage = _coverageVal coverage + , _tsRepeat = floor $ _coverageLength coverage + , _tsBaseIndex = + mutablePixelBaseIndex img (floor $ _coverageX coverage) + (floor $ _coverageY coverage) + } + +prepareInfo :: (Pixel px) + => Maybe Transformation -> MutableImage s px -> CoverageSpan + -> TextureSpaceInfo +prepareInfo Nothing img covSpan = prepareInfoNoTransform img covSpan +prepareInfo (Just t) img covSpan = TextureSpaceInfo + { _tsStart = applyTransformation t + $ V2 (_coverageX covSpan) (_coverageY covSpan) + , _tsDelta = applyVectorTransformation t $ V2 1 0 + , _tsCoverage = _coverageVal covSpan + , _tsRepeat = floor $ _coverageLength covSpan + , _tsBaseIndex = + mutablePixelBaseIndex img (floor $ _coverageX covSpan) + (floor $ _coverageY covSpan) + } + +combineTransform :: Maybe Transformation -> Transformation + -> Maybe Transformation +combineTransform Nothing a = Just a +combineTransform (Just v) a = Just $ v <> a + +withTrans :: Maybe Transformation -> ShaderFunction px + -> ShaderFunction px +withTrans Nothing shader = shader +withTrans (Just v) shader = \x y -> + let V2 x' y' = applyTransformation v (V2 x y) in + shader x' y' + +-- | The intent of shader texture is to provide ease of implementation +-- If possible providing a custom filler will be more efficient, +-- like already done for the solid colors. +shaderOfTexture :: forall px . RenderablePixel px + => Maybe Transformation -> SamplerRepeat -> Texture px + -> ShaderFunction px +{-# SPECIALIZE + shaderOfTexture :: Maybe Transformation -> SamplerRepeat -> Texture PixelRGBA8 + -> ShaderFunction PixelRGBA8 #-} +{-# SPECIALIZE + shaderOfTexture :: Maybe Transformation -> SamplerRepeat -> Texture Pixel8 + -> ShaderFunction Pixel8 #-} +shaderOfTexture _ _ (SolidTexture px) = \_ _ -> px +shaderOfTexture _ _ (MeshPatchTexture _ _) = error "MeshPatch should be precomputed" +shaderOfTexture trans sampling (LinearGradientTexture grad (Line a b)) = + withTrans trans $ linearGradientShader grad a b sampling +shaderOfTexture trans sampling (RadialGradientTexture grad center radius) = + withTrans trans $ radialGradientShader grad center radius sampling +shaderOfTexture trans sampling (RadialGradientWithFocusTexture grad center + radius focus) = + withTrans trans + $ radialGradientWithFocusShader grad center radius focus + sampling +shaderOfTexture trans _ (WithSampler sampler sub) = + shaderOfTexture trans sampler sub +shaderOfTexture trans sampling (WithTextureTransform transform sub) = + shaderOfTexture (combineTransform trans transform) sampling sub +shaderOfTexture trans sampling (SampledTexture img) = + withTrans trans $ sampledImageShader img sampling +shaderOfTexture trans _ (ShaderTexture func) = + withTrans trans func +shaderOfTexture trans _ (RawTexture img) = + withTrans trans $ imageShader img +shaderOfTexture trans _sampling (PatternTexture _ _ _ _ img) = + shaderOfTexture trans SamplerRepeat $ SampledTexture img +shaderOfTexture trans sampling (ModulateTexture texture modulation) = + modulateTexture (shaderOfTexture trans sampling texture) + (shaderOfTexture trans sampling modulation) +shaderOfTexture trans sampling (AlphaModulateTexture texture modulation) = + alphaModulateTexture + (shaderOfTexture trans sampling texture) + (shaderOfTexture trans sampling modulation) + + +-- | This function will interpret the texture description, helping +-- prepare and optimize the real calculation +transformTextureToFiller + :: (RenderablePixel px) + => (Maybe Transformation -> Int -> Int -> PatchInterpolation -> MeshPatch px -> Image px) + -> Texture px -> CoverageFiller (ST s) px +transformTextureToFiller renderMesh = go Nothing SamplerPad + where + go _ _ (SolidTexture px) = + \img -> solidColor px img . prepareInfoNoTransform img + go trans sampling (WithTextureTransform transform sub) = + go (combineTransform trans transform) sampling sub + go trans _ (WithSampler sampler sub) = + go trans sampler sub + go trans sampling (MeshPatchTexture i m) = \img -> + let newImg = renderMesh + trans + (mutableImageWidth img) + (mutableImageHeight img) + i + m + in + go Nothing sampling (RawTexture newImg) img + + go trans sampling tex = + \img -> shaderFiller shader img . prepareInfo trans img + where shader = shaderOfTexture Nothing sampling tex + +type GradientArray px = V.Vector (Float, px) + +repeatGradient :: Float -> Float +repeatGradient s = s - fromIntegral (floor s :: Int) + +reflectGradient :: Float -> Float +reflectGradient s = + abs (abs (s - 1) `mod'` 2 - 1) + +gradientColorAt :: ModulablePixel px + => GradientArray px -> Float -> px +{-# SPECIALIZE + gradientColorAt :: GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-} +{-# SPECIALIZE + gradientColorAt :: GradientArray Pixel8 -> Float -> Pixel8 #-} +gradientColorAt grad at + | at <= 0 = snd $ V.head grad + | at >= 1.0 = snd $ V.last grad + | otherwise = go (0, snd $ V.head grad) 0 + where + !maxi = V.length grad + go (prevCoeff, prevValue) ix + | ix >= maxi = snd $ V.last grad + | at < coeff = mixWith (\_ -> alphaOver cov icov) prevValue px + | otherwise = go value $ ix + 1 + where value@(coeff, px) = grad `V.unsafeIndex` ix + zeroToOne = (at - prevCoeff) / (coeff - prevCoeff) + (cov, icov) = clampCoverage zeroToOne + +gradientColorAtRepeat :: ModulablePixel px + => SamplerRepeat -> GradientArray px -> Float -> px +{-# SPECIALIZE INLINE + gradientColorAtRepeat :: + SamplerRepeat -> GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-} +{-# SPECIALIZE INLINE + gradientColorAtRepeat :: + SamplerRepeat -> GradientArray Pixel8 -> Float -> Pixel8 #-} +gradientColorAtRepeat SamplerPad grad = gradientColorAt grad +gradientColorAtRepeat SamplerRepeat grad = + gradientColorAt grad . repeatGradient +gradientColorAtRepeat SamplerReflect grad = + gradientColorAt grad . reflectGradient + +linearGradientShader :: ModulablePixel px + => Gradient px -- ^ Gradient description. + -> Point -- ^ Linear gradient start point. + -> Point -- ^ Linear gradient end point. + -> SamplerRepeat + -> ShaderFunction px +{-# SPECIALIZE linearGradientShader + :: Gradient PixelRGBA8 -> Point -> Point -> SamplerRepeat + -> ShaderFunction PixelRGBA8 #-} +{-# SPECIALIZE linearGradientShader + :: Gradient Pixel8 -> Point -> Point -> SamplerRepeat + -> ShaderFunction Pixel8 #-} +linearGradientShader gradient start end repeating = + \x y -> colorAt $ (V2 x y `dot` d) - s00 + where + colorAt = gradientColorAtRepeat repeating gradArray + gradArray = V.fromList gradient + vector = end ^-^ start + d = vector ^/ (vector `dot` vector) + s00 = start `dot` d + +-- | Use another image as a texture for the filling. +-- This texture use the "nearest" filtering, AKA no +-- filtering at all. +imageShader :: forall px. (Pixel px) => Image px -> ShaderFunction px +{-# SPECIALIZE + imageShader :: Image PixelRGBA8 -> ShaderFunction PixelRGBA8 #-} +{-# SPECIALIZE + imageShader :: Image Pixel8 -> ShaderFunction Pixel8 #-} +imageShader img x y = + unsafePixelAt rawData $ (clampedY * w + clampedX) * compCount + where + clampedX = min (w - 1) . max 0 $ floor x + clampedY = min (h - 1) . max 0 $ floor y + !compCount = componentCount (undefined :: px) + !w = imageWidth img + !h = imageHeight img + !rawData = imageData img + +radialGradientShader :: ModulablePixel px + => Gradient px -- ^ Gradient description + -> Point -- ^ Radial gradient center + -> Float -- ^ Radial gradient radius + -> SamplerRepeat + -> ShaderFunction px +{-# SPECIALIZE + radialGradientShader + :: Gradient PixelRGBA8 -> Point -> Float -> SamplerRepeat + -> ShaderFunction PixelRGBA8 #-} +{-# SPECIALIZE + radialGradientShader + :: Gradient Pixel8 -> Point -> Float -> SamplerRepeat + -> ShaderFunction Pixel8 #-} +radialGradientShader gradient center radius repeating = + \x y -> colorAt $ norm (V2 x y ^-^ center) / radius + where + !colorAt = gradientColorAtRepeat repeating gradArray + !gradArray = V.fromList gradient + +radialGradientWithFocusShader + :: ModulablePixel px + => Gradient px -- ^ Gradient description + -> Point -- ^ Radial gradient center + -> Float -- ^ Radial gradient radius + -> Point -- ^ Radial gradient focus point + -> SamplerRepeat + -> ShaderFunction px +{-# SPECIALIZE + radialGradientWithFocusShader + :: Gradient PixelRGBA8 -> Point -> Float -> Point + -> SamplerRepeat -> ShaderFunction PixelRGBA8 #-} +{-# SPECIALIZE + radialGradientWithFocusShader + :: Gradient Pixel8 -> Point -> Float -> Point + -> SamplerRepeat -> ShaderFunction Pixel8 #-} +radialGradientWithFocusShader gradient center radius focusScreen repeating = + \x y -> colorAt . go $ V2 x y ^-^ center + where + focus@(V2 origFocusX origFocusY) = focusScreen ^-^ center + colorAt = gradientColorAtRepeat repeating gradArray + gradArray = V.fromList gradient + radiusSquared = radius * radius + dist = sqrt $ focus `dot` focus + clampedFocus@(V2 focusX focusY) + | dist <= r = focus + | otherwise = V2 (r * cos a) (r * sin a) + where a = atan2 origFocusY origFocusX + r = radius * 0.99 + trivial = sqrt $ radiusSquared - origFocusX * origFocusX + + solutionOf (V2 x y) | x == focusX = + V2 focusX (if y > focusY then trivial else negate trivial) + solutionOf (V2 x y) = V2 xSolution $ slope * xSolution + yint + where + slope = (y - focusY) / (x - focusX) + yint = y - (slope * x) + + a = slope * slope + 1 + b = 2 * slope * yint + c = yint * yint - radiusSquared + det = sqrt $ b * b - 4 * a * c + xSolution = (-b + (if x < focusX then negate det else det)) / (2 * a) + + go pos = sqrt $ curToFocus / distSquared + where + solution = solutionOf pos ^-^ clampedFocus + toFocus = pos ^-^ clampedFocus + distSquared = solution `dot` solution + curToFocus = toFocus `dot` toFocus + +-- | Perform a multiplication operation between a full color texture +-- and a greyscale one, used for clip-path implementation. +modulateTexture :: ModulablePixel px + => ShaderFunction px + -> ShaderFunction (PixelBaseComponent px) + -> ShaderFunction px +{-# INLINE modulateTexture #-} +modulateTexture fullTexture modulator x y = + colorMap (modulate $ modulator x y) $ fullTexture x y + +-- | Perform a multiplication operation between a full color texture +-- and a greyscale one, used for clip-path implementation. +alphaModulateTexture :: ModulablePixel px + => ShaderFunction px + -> ShaderFunction (PixelBaseComponent px) + -> ShaderFunction px +{-# INLINE alphaModulateTexture #-} +alphaModulateTexture fullTexture modulator x y = + let px = fullTexture x y in + mixWithAlpha (\_ _ a -> a) (\_ _ -> modulator x y) px px +
src/Graphics/Rasterific/StrokeInternal.hs view
@@ -1,306 +1,299 @@-{-# LANGUAGE CPP #-}-module Graphics.Rasterific.StrokeInternal- ( flatten- , dashize- , strokize- , dashedStrokize- , splitPrimitiveUntil- , approximatePathLength- , isPrimitivePoint- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<$>), pure )-import Data.Monoid( mempty )-import Data.Foldable( foldMap )-#endif--import Data.Monoid( (<>) )--import Graphics.Rasterific.Linear- ( V2( .. )- , (^-^)- , (^+^)- , (^*)- , dot- )--import Graphics.Rasterific.Operators-import Graphics.Rasterific.Types-import Graphics.Rasterific.QuadraticBezier-import Graphics.Rasterific.CubicBezier-import Graphics.Rasterific.Line--lastPoint :: Primitive -> Point-lastPoint (LinePrim (Line _ x1)) = x1-lastPoint (BezierPrim (Bezier _ _ x2)) = x2-lastPoint (CubicBezierPrim (CubicBezier _ _ _ x3)) = x3--lastPointAndNormal :: Primitive -> (Point, Vector)-lastPointAndNormal (LinePrim (Line a b)) = (b, a `normal` b)-lastPointAndNormal (BezierPrim (Bezier _ b c)) = (c, b `normal` c)-lastPointAndNormal (CubicBezierPrim (CubicBezier _ _ c d)) = (d, c `normal` d)--firstPointAndNormal :: Primitive -> (Point, Vector)-firstPointAndNormal (LinePrim (Line a b)) = (a, a `normal` b)-firstPointAndNormal (BezierPrim (Bezier a b _)) = (a, a `normal` b)-firstPointAndNormal (CubicBezierPrim (CubicBezier a b _ _)) = (a, a `normal` b)--isPrimitivePoint :: Primitive -> Bool-isPrimitivePoint p = case p of- LinePrim l -> isLinePoint l- BezierPrim b -> isBezierPoint b- CubicBezierPrim c -> isCubicBezierPoint c--reversePrimitive :: Primitive -> Primitive-reversePrimitive (LinePrim (Line a b)) = LinePrim (Line b a)-reversePrimitive (BezierPrim (Bezier a b c)) =- BezierPrim (Bezier c b a)-reversePrimitive (CubicBezierPrim (CubicBezier a b c d)) =- CubicBezierPrim (CubicBezier d c b a)---- | Create a "rounded" join or cap-roundJoin :: Float -> Point -> Vector -> Vector -> Container Primitive-roundJoin offset p = go- where go u v- -- If we're already on a nice curvature,- -- don't bother doing anything- | u `dot` w >= 0.9 = pure . BezierPrim $ Bezier a b c- | otherwise = go u w <> go w v- where -- ^- -- |w- -- a X---X c- -- \ /- -- Xp- -- ^ / \ ^- -- u\/ \/v- -- / \ .- a = p ^+^ u ^* offset- c = p ^+^ v ^* offset-- w = (a `normal` c) `ifZero` u-- -- Same as offseting- n = p ^+^ w ^* offset- b = n ^* 2 ^-^ (a `midPoint` c)---- | Put a cap at the end of a bezier curve, depending--- on the kind of cap wanted.-cap :: Float -> Cap -> Primitive -> Container Primitive-cap offset CapRound prim = roundJoin offset p u (- u)- where (p, u) = lastPointAndNormal prim--cap offset (CapStraight cVal) prim =- pure (d `lineFromTo` e) <> pure (e `lineFromTo` f)- <> pure (f `lineFromTo` g)- where -- The usual "normal"- (p, u@(V2 ux uy)) = lastPointAndNormal prim- -- Vector pointing in the direction of the curve- -- of norm 1- v = V2 uy $ negate ux-- -- Finishing points around the edge- -- -u*offset u*offset- -- <-><->- -- d/ / /g- -- / / /- -- / / /- -- /- -- / curve- --- d = p ^+^ u ^* offset- g = p ^-^ u ^* offset-- -- Create the "far" points- --- -- e f- -- / / ^- -- / / / v * offset * cVal- -- d/ / /g- -- / / /- -- / / /- -- /- -- / curve- --- e = d ^+^ v ^* (offset * cVal)- f = g ^+^ v ^* (offset * cVal)--lineFromTo :: Point -> Point -> Primitive-lineFromTo a b = LinePrim (Line a b)--miterJoin :: Float -> Float -> Point -> Vector -> Vector- -> Container Primitive-miterJoin offset l point u v- | uDotW > l / max 1 l && uDotW > 0.01 =- pure (a `lineFromTo` m) <> pure (m `lineFromTo` c)- -- A simple straight junction- | otherwise = pure $ a `lineFromTo` c- where -- X m- -- /\- -- /|w\- -- a X---X c- -- \ /- -- Xp- -- ^ / \ ^- -- u\/ \/v- -- / \ .- a = point ^+^ u ^* offset- c = point ^+^ v ^* offset- w = (a `normal` c) `ifZero` u-- uDotW = u `dot` w-- -- Calculate the maximum distance on the- -- u axis- p = offset / uDotW- -- middle point for "straight joining"- m = point + w ^* p--joinPrimitives :: StrokeWidth -> Join -> Primitive -> Primitive- -> Container Primitive-joinPrimitives offset join prim1 prim2 =- case join of- JoinRound -> roundJoin offset p u v- JoinMiter l -> miterJoin offset l p u v- where (p, u) = lastPointAndNormal prim1- (_, v) = firstPointAndNormal prim2--offsetPrimitives :: Float -> Primitive -> Container Primitive-offsetPrimitives offset (LinePrim l) = offsetLine offset l-offsetPrimitives offset (BezierPrim b) = offsetBezier offset b-offsetPrimitives offset (CubicBezierPrim c) = offsetCubicBezier offset c--offsetAndJoin :: Float -> Join -> Cap -> [Primitive]- -> Container Primitive-offsetAndJoin _ _ _ [] = mempty-offsetAndJoin offset join caping (firstShape:rest) = go firstShape rest- where joiner = joinPrimitives offset join- offseter = offsetPrimitives offset- (firstPoint, _) = firstPointAndNormal firstShape-- go prev []- | firstPoint `isNearby` lastPoint prev = offseter prev <> joiner prev firstShape- | otherwise = offseter prev <> cap offset caping prev- go prev (x:xs) =- offseter prev <> joiner prev x <> go x xs--approximateLength :: Primitive -> Float-approximateLength (LinePrim l) = lineLength l-approximateLength (BezierPrim b) = bezierLengthApproximation b-approximateLength (CubicBezierPrim c) = cubicBezierLengthApproximation c---sanitize :: Primitive -> Container Primitive-sanitize (LinePrim l) = sanitizeLine l-sanitize (BezierPrim b) = sanitizeBezier b-sanitize (CubicBezierPrim c) = sanitizeCubicBezier c--strokize :: Geometry geom- => StrokeWidth -> Join -> (Cap, Cap) -> geom- -> Container Primitive-strokize width join (capStart, capEnd) geom = foldMap pathOffseter sanitized- where - sanitized = foldMap (listOfContainer . sanitize) <$> resplit (toPrimitives geom)- offseter = offsetAndJoin (width / 2) join- pathOffseter v =- offseter capEnd v <> offseter capStart (reverse $ reversePrimitive <$> v)--flattenPrimitive :: Primitive -> Container Primitive-flattenPrimitive (BezierPrim bezier) = flattenBezier bezier-flattenPrimitive (CubicBezierPrim bezier) = flattenCubicBezier bezier-flattenPrimitive (LinePrim line) = flattenLine line--breakPrimitiveAt :: Primitive -> Float -> (Primitive, Primitive)-breakPrimitiveAt (BezierPrim bezier) at = (BezierPrim a, BezierPrim b)- where (a, b) = bezierBreakAt bezier at-breakPrimitiveAt (CubicBezierPrim bezier) at = (CubicBezierPrim a, CubicBezierPrim b)- where (a, b) = cubicBezierBreakAt bezier at-breakPrimitiveAt (LinePrim line) at = (LinePrim a, LinePrim b)- where (a, b) = lineBreakAt line at---flatten :: Container Primitive -> Container Primitive-flatten = foldMap flattenPrimitive--splitPrimitiveUntil :: Float -> [Primitive] -> ([Primitive], [Primitive])-splitPrimitiveUntil = go- where- go _ [] = ([], [])- go left lst- | left <= 0 = ([], lst)- go left (x : xs)- | left > primLength = (x : inInterval, afterInterval)- | otherwise = ([beforeStop], afterStop : xs)- where- primLength = approximateLength x- (inInterval, afterInterval) = go (left - primLength) xs-- (beforeStop, afterStop) =- breakPrimitiveAt x $ left / primLength--dropPattern :: Float -> DashPattern -> DashPattern-dropPattern = go- where- go _ [] = []- go offset (x:xs)- | x < 0 = x:xs -- sanitizing- | offset < x = x - offset : xs- | otherwise {- offset >= x -} = go (offset - x) xs---- | Don't make them completly flat, but suficiently--- to assume they are.-linearizePrimitives :: [Primitive] -> [Primitive]-linearizePrimitives =- listOfContainer . foldMap flattenPrimitive . foldMap sanitize---- | Return an approximation of the length of a given path.--- It's results is not precise but should be enough for--- rough calculations-approximatePathLength :: Path -> Float-approximatePathLength = approximatePrimitivesLength . pathToPrimitives--approximatePrimitivesLength :: [Primitive] -> Float-approximatePrimitivesLength prims =- sum $ approximateLength <$> linearizePrimitives prims--dashize :: Float -> DashPattern -> [Primitive] -> [[Primitive]]-dashize offset pattern = taker infinitePattern . linearizePrimitives - where- realOffset | offset >= 0 = offset- | otherwise = offset + sum pattern-- infinitePattern =- dropPattern realOffset . cycle $ filter (> 0) pattern-- taker _ [] = []- taker [] _ = [] -- Impossible by construction, pattern is infinite- taker (atValue:atRest) stream = toKeep : droper atRest next- where (toKeep, next) = splitPrimitiveUntil atValue stream-- droper _ [] = []- droper [] _ = [] -- Impossible by construction, pattern is infinite- droper (atValue:atRest) stream = taker atRest next- where (_toKeep, next) = splitPrimitiveUntil atValue stream---- | Create a list of outlines corresponding to all the--- dashed elements. They can be then stroked------ > mapM_ (stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0)) $--- > dashedStrokize 0 [10, 5]--- > 40 JoinRound (CapStraight 0, CapStraight 0) $--- > CubicBezier (V2 40 160) (V2 40 40) (V2 160 40) (V2 160 160)------ <<docimages/strokize_dashed_path.png>>----dashedStrokize :: Geometry geom- => Float -- ^ Starting offset- -> DashPattern -- ^ Dashing pattern to use for stroking- -> StrokeWidth -- ^ Stroke width- -> Join -- ^ Which kind of join will be used- -> (Cap, Cap) -- ^ Start and end capping.- -> geom -- ^ Elements to transform- -> [[Primitive]]-dashedStrokize offset dashPattern width join capping geom =- listOfContainer . strokize width join capping- <$> dashize offset dashPattern (toPrimitives geom)-+module Graphics.Rasterific.StrokeInternal + ( flatten + , dashize + , strokize + , dashedStrokize + , splitPrimitiveUntil + , approximatePathLength + , isPrimitivePoint + ) where + +import Data.Monoid( (<>) ) + +import Graphics.Rasterific.Linear + ( V2( .. ) + , (^-^) + , (^+^) + , (^*) + , dot + ) + +import Graphics.Rasterific.Operators +import Graphics.Rasterific.Types +import Graphics.Rasterific.QuadraticBezier +import Graphics.Rasterific.CubicBezier +import Graphics.Rasterific.Line + +lastPoint :: Primitive -> Point +lastPoint (LinePrim (Line _ x1)) = x1 +lastPoint (BezierPrim (Bezier _ _ x2)) = x2 +lastPoint (CubicBezierPrim (CubicBezier _ _ _ x3)) = x3 + +lastPointAndNormal :: Primitive -> (Point, Vector) +lastPointAndNormal (LinePrim (Line a b)) = (b, a `normal` b) +lastPointAndNormal (BezierPrim (Bezier _ b c)) = (c, b `normal` c) +lastPointAndNormal (CubicBezierPrim (CubicBezier _ _ c d)) = (d, c `normal` d) + +firstPointAndNormal :: Primitive -> (Point, Vector) +firstPointAndNormal (LinePrim (Line a b)) = (a, a `normal` b) +firstPointAndNormal (BezierPrim (Bezier a b _)) = (a, a `normal` b) +firstPointAndNormal (CubicBezierPrim (CubicBezier a b _ _)) = (a, a `normal` b) + +isPrimitivePoint :: Primitive -> Bool +isPrimitivePoint p = case p of + LinePrim l -> isLinePoint l + BezierPrim b -> isBezierPoint b + CubicBezierPrim c -> isCubicBezierPoint c + +reversePrimitive :: Primitive -> Primitive +reversePrimitive (LinePrim (Line a b)) = LinePrim (Line b a) +reversePrimitive (BezierPrim (Bezier a b c)) = + BezierPrim (Bezier c b a) +reversePrimitive (CubicBezierPrim (CubicBezier a b c d)) = + CubicBezierPrim (CubicBezier d c b a) + +-- | Create a "rounded" join or cap +roundJoin :: Float -> Point -> Vector -> Vector -> Container Primitive +roundJoin offset p = go + where go u v + -- If we're already on a nice curvature, + -- don't bother doing anything + | u `dot` w >= 0.9 = pure . BezierPrim $ Bezier a b c + | otherwise = go u w <> go w v + where -- ^ + -- |w + -- a X---X c + -- \ / + -- Xp + -- ^ / \ ^ + -- u\/ \/v + -- / \ . + a = p ^+^ u ^* offset + c = p ^+^ v ^* offset + + w = (a `normal` c) `ifZero` u + + -- Same as offseting + n = p ^+^ w ^* offset + b = n ^* 2 ^-^ (a `midPoint` c) + +-- | Put a cap at the end of a bezier curve, depending +-- on the kind of cap wanted. +cap :: Float -> Cap -> Primitive -> Container Primitive +cap offset CapRound prim = roundJoin offset p u (- u) + where (p, u) = lastPointAndNormal prim + +cap offset (CapStraight cVal) prim = + pure (d `lineFromTo` e) <> pure (e `lineFromTo` f) + <> pure (f `lineFromTo` g) + where -- The usual "normal" + (p, u@(V2 ux uy)) = lastPointAndNormal prim + -- Vector pointing in the direction of the curve + -- of norm 1 + v = V2 uy $ negate ux + + -- Finishing points around the edge + -- -u*offset u*offset + -- <-><-> + -- d/ / /g + -- / / / + -- / / / + -- / + -- / curve + -- + d = p ^+^ u ^* offset + g = p ^-^ u ^* offset + + -- Create the "far" points + -- + -- e f + -- / / ^ + -- / / / v * offset * cVal + -- d/ / /g + -- / / / + -- / / / + -- / + -- / curve + -- + e = d ^+^ v ^* (offset * cVal) + f = g ^+^ v ^* (offset * cVal) + +lineFromTo :: Point -> Point -> Primitive +lineFromTo a b = LinePrim (Line a b) + +miterJoin :: Float -> Float -> Point -> Vector -> Vector + -> Container Primitive +miterJoin offset l point u v + | uDotW > l / max 1 l && uDotW > 0.01 = + pure (a `lineFromTo` m) <> pure (m `lineFromTo` c) + -- A simple straight junction + | otherwise = pure $ a `lineFromTo` c + where -- X m + -- /\ + -- /|w\ + -- a X---X c + -- \ / + -- Xp + -- ^ / \ ^ + -- u\/ \/v + -- / \ . + a = point ^+^ u ^* offset + c = point ^+^ v ^* offset + w = (a `normal` c) `ifZero` u + + uDotW = u `dot` w + + -- Calculate the maximum distance on the + -- u axis + p = offset / uDotW + -- middle point for "straight joining" + m = point + w ^* p + +joinPrimitives :: StrokeWidth -> Join -> Primitive -> Primitive + -> Container Primitive +joinPrimitives offset join prim1 prim2 = + case join of + JoinRound -> roundJoin offset p u v + JoinMiter l -> miterJoin offset l p u v + where (p, u) = lastPointAndNormal prim1 + (_, v) = firstPointAndNormal prim2 + +offsetPrimitives :: Float -> Primitive -> Container Primitive +offsetPrimitives offset (LinePrim l) = offsetLine offset l +offsetPrimitives offset (BezierPrim b) = offsetBezier offset b +offsetPrimitives offset (CubicBezierPrim c) = offsetCubicBezier offset c + +offsetAndJoin :: Float -> Join -> Cap -> [Primitive] + -> Container Primitive +offsetAndJoin _ _ _ [] = mempty +offsetAndJoin offset join caping (firstShape:rest) = go firstShape rest + where joiner = joinPrimitives offset join + offseter = offsetPrimitives offset + (firstPoint, _) = firstPointAndNormal firstShape + + go prev [] + | firstPoint `isNearby` lastPoint prev = offseter prev <> joiner prev firstShape + | otherwise = offseter prev <> cap offset caping prev + go prev (x:xs) = + offseter prev <> joiner prev x <> go x xs + +approximateLength :: Primitive -> Float +approximateLength (LinePrim l) = lineLength l +approximateLength (BezierPrim b) = bezierLengthApproximation b +approximateLength (CubicBezierPrim c) = cubicBezierLengthApproximation c + + +sanitize :: Primitive -> Container Primitive +sanitize (LinePrim l) = sanitizeLine l +sanitize (BezierPrim b) = sanitizeBezier b +sanitize (CubicBezierPrim c) = sanitizeCubicBezier c + +strokize :: Geometry geom + => StrokeWidth -> Join -> (Cap, Cap) -> geom + -> Container Primitive +strokize width join (capStart, capEnd) geom = foldMap pathOffseter sanitized + where + sanitized = foldMap (listOfContainer . sanitize) <$> resplit (toPrimitives geom) + offseter = offsetAndJoin (width / 2) join + pathOffseter v = + offseter capEnd v <> offseter capStart (reverse $ reversePrimitive <$> v) + +flattenPrimitive :: Primitive -> Container Primitive +flattenPrimitive (BezierPrim bezier) = flattenBezier bezier +flattenPrimitive (CubicBezierPrim bezier) = flattenCubicBezier bezier +flattenPrimitive (LinePrim line) = flattenLine line + +breakPrimitiveAt :: Primitive -> Float -> (Primitive, Primitive) +breakPrimitiveAt (BezierPrim bezier) at = (BezierPrim a, BezierPrim b) + where (a, b) = bezierBreakAt bezier at +breakPrimitiveAt (CubicBezierPrim bezier) at = (CubicBezierPrim a, CubicBezierPrim b) + where (a, b) = cubicBezierBreakAt bezier at +breakPrimitiveAt (LinePrim line) at = (LinePrim a, LinePrim b) + where (a, b) = lineBreakAt line at + + +flatten :: Container Primitive -> Container Primitive +flatten = foldMap flattenPrimitive + +splitPrimitiveUntil :: Float -> [Primitive] -> ([Primitive], [Primitive]) +splitPrimitiveUntil = go + where + go _ [] = ([], []) + go left lst + | left <= 0 = ([], lst) + go left (x : xs) + | left > primLength = (x : inInterval, afterInterval) + | otherwise = ([beforeStop], afterStop : xs) + where + primLength = approximateLength x + (inInterval, afterInterval) = go (left - primLength) xs + + (beforeStop, afterStop) = + breakPrimitiveAt x $ left / primLength + +dropPattern :: Float -> DashPattern -> DashPattern +dropPattern = go + where + go _ [] = [] + go offset (x:xs) + | x < 0 = x:xs -- sanitizing + | offset < x = x - offset : xs + | otherwise {- offset >= x -} = go (offset - x) xs + +-- | Don't make them completly flat, but suficiently +-- to assume they are. +linearizePrimitives :: [Primitive] -> [Primitive] +linearizePrimitives = + listOfContainer . foldMap flattenPrimitive . foldMap sanitize + +-- | Return an approximation of the length of a given path. +-- It's results is not precise but should be enough for +-- rough calculations +approximatePathLength :: Path -> Float +approximatePathLength = approximatePrimitivesLength . pathToPrimitives + +approximatePrimitivesLength :: [Primitive] -> Float +approximatePrimitivesLength prims = + sum $ approximateLength <$> linearizePrimitives prims + +dashize :: Float -> DashPattern -> [Primitive] -> [[Primitive]] +dashize offset pattern = taker infinitePattern . linearizePrimitives + where + realOffset | offset >= 0 = offset + | otherwise = offset + sum pattern + + infinitePattern = + dropPattern realOffset . cycle $ filter (> 0) pattern + + taker _ [] = [] + taker [] _ = [] -- Impossible by construction, pattern is infinite + taker (atValue:atRest) stream = toKeep : droper atRest next + where (toKeep, next) = splitPrimitiveUntil atValue stream + + droper _ [] = [] + droper [] _ = [] -- Impossible by construction, pattern is infinite + droper (atValue:atRest) stream = taker atRest next + where (_toKeep, next) = splitPrimitiveUntil atValue stream + +-- | Create a list of outlines corresponding to all the +-- dashed elements. They can be then stroked +-- +-- > mapM_ (stroke 3 (JoinMiter 0) (CapStraight 0, CapStraight 0)) $ +-- > dashedStrokize 0 [10, 5] +-- > 40 JoinRound (CapStraight 0, CapStraight 0) $ +-- > CubicBezier (V2 40 160) (V2 40 40) (V2 160 40) (V2 160 160) +-- +-- <<docimages/strokize_dashed_path.png>> +-- +dashedStrokize :: Geometry geom + => Float -- ^ Starting offset + -> DashPattern -- ^ Dashing pattern to use for stroking + -> StrokeWidth -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> geom -- ^ Elements to transform + -> [[Primitive]] +dashedStrokize offset dashPattern width join capping geom = + listOfContainer . strokize width join capping + <$> dashize offset dashPattern (toPrimitives geom) +
src/Graphics/Rasterific/Transformations.hs view
@@ -1,189 +1,185 @@--- | This module provide some helpers in order--- to perform basic geometric transformation on--- the drawable primitives.------ You can combine the transformation is `mappend` or--- the `(\<\>)` operator from "Data.Monoid" .-{-# LANGUAGE CPP #-}-module Graphics.Rasterific.Transformations- ( Transformation( .. )- , applyTransformation- , applyVectorTransformation- , translate- , scale- , rotate- , rotateCenter- , skewX- , skewY- , toNewXBase- , inverseTransformation- ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid( Monoid( .. ) )-#endif-import Data.Monoid( (<>) )-import Graphics.Rasterific.Types-import Graphics.Rasterific.Linear( V2( .. ), normalize )---- | Represent a 3*3 matrix for homogenous coordinates.------ > | A C E |--- > | B D F |--- > | 0 0 1 |----data Transformation = Transformation- { _transformA :: {-# UNPACK #-} !Float- , _transformC :: {-# UNPACK #-} !Float- , _transformE :: {-# UNPACK #-} !Float -- ^ X translation-- , _transformB :: {-# UNPACK #-} !Float- , _transformD :: {-# UNPACK #-} !Float- , _transformF :: {-# UNPACK #-} !Float -- ^ Y translation- }- deriving (Eq, Show)--transformCombine :: Transformation -> Transformation -> Transformation-transformCombine (Transformation a c e- b d f)-- (Transformation a' c' e'- b' d' f') =- Transformation (a * a' + c * b' {- below b' is zero -})- (a * c' + c * d' {- below d' is zero -})- (a * e' + c * f' + e {- below f' is one -})-- (b * a' + d * b' {- below b' is zero -})- (b * c' + d * d' {- below d' is zero -})- (b * e' + d * f' + f {- below f' is one -})--instance Monoid Transformation where- mappend = transformCombine- mempty = Transformation 1 0 0- 0 1 0---- | Effectively transform a point given a transformation.-applyTransformation :: Transformation -> Point -> Point-applyTransformation (Transformation a c e- b d f) (V2 x y) =- V2 (a * x + y * c + e) (b * x + d * y + f)---- | Effectively transform a vector given a transformation.--- The translation part won't be applied.-applyVectorTransformation :: Transformation -> Vector -> Vector-applyVectorTransformation- (Transformation a c _e- b d _f) (V2 x y) =- V2 (a * x + y * c) (b * x + d * y)----- | Create a transformation representing a rotation--- on the plane.------ > fill . transform (applyTransformation $ rotate 0.2)--- > $ rectangle (V2 40 40) 120 120------ <<docimages/transform_rotate.png>>----rotate :: Float -- ^ Rotation angle in radian.- -> Transformation-rotate angle = Transformation ca (-sa) 0- sa ca 0- where ca = cos angle- sa = sin angle---- | Create a transformation representing a rotation--- on the plane. The rotation center is given in parameter------ > fill . transform (applyTransformation $ rotateCenter 0.2 (V2 200 200))--- > $ rectangle (V2 40 40) 120 120------ <<docimages/transform_rotate_center.png>>----rotateCenter :: Float -- ^ Rotation angle in radian- -> Point -- ^ Rotation center- -> Transformation-rotateCenter angle p =- translate p <> rotate angle <> translate (negate p)----- | Perform a scaling of the given primitives.------ > fill . transform (applyTransformation $ scale 2 2)--- > $ rectangle (V2 40 40) 40 40------ <<docimages/transform_scale.png>>----scale :: Float -> Float -> Transformation-scale scaleX scaleY =- Transformation scaleX 0 0- 0 scaleY 0---- | Perform a translation of the given primitives.------ > fill . transform (applyTransformation $ translate (V2 100 100))--- > $ rectangle (V2 40 40) 40 40------ <<docimages/transform_translate.png>>----translate :: Vector -> Transformation-translate (V2 x y) =- Transformation 1 0 x- 0 1 y---- | Skew transformation along the--- X axis.------ > fill . transform (applyTransformation $ skewX 0.3)--- > $ rectangle (V2 50 50) 80 80------ <<docimages/transform_skewx.png>>----skewX :: Float -> Transformation-skewX v =- Transformation 1 t 0- 0 1 0- where t = tan v---- | Skew transformation along the Y axis.------ > fill . transform (applyTransformation $ skewY 0.3)--- > $ rectangle (V2 50 50) 80 80------ <<docimages/transform_skewy.png>>----skewY :: Float -> Transformation-skewY v =- Transformation 1 0 0- t 1 0- where t = tan v---- | Given a new X-acis vector, create a rotation matrix--- to get into this new base, assuming an Y basis orthonormal--- to the X one.-toNewXBase :: Vector -> Transformation-toNewXBase vec =- Transformation dx (-dy) 0- dy dx 0- where V2 dx dy = normalize vec--transformationDeterminant :: Transformation -> Float-transformationDeterminant (Transformation a c _e- b d _f) = a * d - c * b---- | Inverse a transformation (if possible)-inverseTransformation :: Transformation -> Maybe Transformation-inverseTransformation trans- | transformationDeterminant trans == 0 = Nothing-inverseTransformation (Transformation a c e- b d f) =- Just $ Transformation a' c' e' b' d' f'- where det = a * d - b * c- a' = d / det- c' = (- c) / det- e' = (c * f - e * d) / det-- b' = (- b) / det- d' = a / det- f' = (e * b - a * f) / det-+-- | This module provide some helpers in order +-- to perform basic geometric transformation on +-- the drawable primitives. +-- +-- You can combine the transformation is `mappend` or +-- the `(\<\>)` operator from "Data.Monoid" . +module Graphics.Rasterific.Transformations + ( Transformation( .. ) + , applyTransformation + , applyVectorTransformation + , translate + , scale + , rotate + , rotateCenter + , skewX + , skewY + , toNewXBase + , inverseTransformation + ) where + +import Data.Monoid( (<>) ) +import Graphics.Rasterific.Types +import Graphics.Rasterific.Linear( V2( .. ), normalize ) + +-- | Represent a 3*3 matrix for homogenous coordinates. +-- +-- > | A C E | +-- > | B D F | +-- > | 0 0 1 | +-- +data Transformation = Transformation + { _transformA :: {-# UNPACK #-} !Float + , _transformC :: {-# UNPACK #-} !Float + , _transformE :: {-# UNPACK #-} !Float -- ^ X translation + + , _transformB :: {-# UNPACK #-} !Float + , _transformD :: {-# UNPACK #-} !Float + , _transformF :: {-# UNPACK #-} !Float -- ^ Y translation + } + deriving (Eq, Show) + +transformCombine :: Transformation -> Transformation -> Transformation +transformCombine (Transformation a c e + b d f) + + (Transformation a' c' e' + b' d' f') = + Transformation (a * a' + c * b' {- below b' is zero -}) + (a * c' + c * d' {- below d' is zero -}) + (a * e' + c * f' + e {- below f' is one -}) + + (b * a' + d * b' {- below b' is zero -}) + (b * c' + d * d' {- below d' is zero -}) + (b * e' + d * f' + f {- below f' is one -}) + +instance Monoid Transformation where + mappend = transformCombine + mempty = Transformation 1 0 0 + 0 1 0 + +-- | Effectively transform a point given a transformation. +applyTransformation :: Transformation -> Point -> Point +applyTransformation (Transformation a c e + b d f) (V2 x y) = + V2 (a * x + y * c + e) (b * x + d * y + f) + +-- | Effectively transform a vector given a transformation. +-- The translation part won't be applied. +applyVectorTransformation :: Transformation -> Vector -> Vector +applyVectorTransformation + (Transformation a c _e + b d _f) (V2 x y) = + V2 (a * x + y * c) (b * x + d * y) + + +-- | Create a transformation representing a rotation +-- on the plane. +-- +-- > fill . transform (applyTransformation $ rotate 0.2) +-- > $ rectangle (V2 40 40) 120 120 +-- +-- <<docimages/transform_rotate.png>> +-- +rotate :: Float -- ^ Rotation angle in radian. + -> Transformation +rotate angle = Transformation ca (-sa) 0 + sa ca 0 + where ca = cos angle + sa = sin angle + +-- | Create a transformation representing a rotation +-- on the plane. The rotation center is given in parameter +-- +-- > fill . transform (applyTransformation $ rotateCenter 0.2 (V2 200 200)) +-- > $ rectangle (V2 40 40) 120 120 +-- +-- <<docimages/transform_rotate_center.png>> +-- +rotateCenter :: Float -- ^ Rotation angle in radian + -> Point -- ^ Rotation center + -> Transformation +rotateCenter angle p = + translate p <> rotate angle <> translate (negate p) + + +-- | Perform a scaling of the given primitives. +-- +-- > fill . transform (applyTransformation $ scale 2 2) +-- > $ rectangle (V2 40 40) 40 40 +-- +-- <<docimages/transform_scale.png>> +-- +scale :: Float -> Float -> Transformation +scale scaleX scaleY = + Transformation scaleX 0 0 + 0 scaleY 0 + +-- | Perform a translation of the given primitives. +-- +-- > fill . transform (applyTransformation $ translate (V2 100 100)) +-- > $ rectangle (V2 40 40) 40 40 +-- +-- <<docimages/transform_translate.png>> +-- +translate :: Vector -> Transformation +translate (V2 x y) = + Transformation 1 0 x + 0 1 y + +-- | Skew transformation along the +-- X axis. +-- +-- > fill . transform (applyTransformation $ skewX 0.3) +-- > $ rectangle (V2 50 50) 80 80 +-- +-- <<docimages/transform_skewx.png>> +-- +skewX :: Float -> Transformation +skewX v = + Transformation 1 t 0 + 0 1 0 + where t = tan v + +-- | Skew transformation along the Y axis. +-- +-- > fill . transform (applyTransformation $ skewY 0.3) +-- > $ rectangle (V2 50 50) 80 80 +-- +-- <<docimages/transform_skewy.png>> +-- +skewY :: Float -> Transformation +skewY v = + Transformation 1 0 0 + t 1 0 + where t = tan v + +-- | Given a new X-acis vector, create a rotation matrix +-- to get into this new base, assuming an Y basis orthonormal +-- to the X one. +toNewXBase :: Vector -> Transformation +toNewXBase vec = + Transformation dx (-dy) 0 + dy dx 0 + where V2 dx dy = normalize vec + +transformationDeterminant :: Transformation -> Float +transformationDeterminant (Transformation a c _e + b d _f) = a * d - c * b + +-- | Inverse a transformation (if possible) +inverseTransformation :: Transformation -> Maybe Transformation +inverseTransformation trans + | transformationDeterminant trans == 0 = Nothing +inverseTransformation (Transformation a c e + b d f) = + Just $ Transformation a' c' e' b' d' f' + where det = a * d - b * c + a' = d / det + c' = (- c) / det + e' = (c * f - e * d) / det + + b' = (- b) / det + d' = a / det + f' = (e * b - a * f) / det +
src/Graphics/Rasterific/Types.hs view
@@ -1,588 +1,582 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE CPP #-}--- | Gather all the types used in the rasterization engine.-module Graphics.Rasterific.Types- ( -- * Geometry description- Vector- , Point- , Line( .. )- , Bezier( .. )- , CubicBezier( .. )- , Primitive( .. )-- , Primitivable( .. )- , Geometry( .. )-- , Producer- , Container- , containerOfList- , listOfContainer- , containerOfFunction- , PathCommand( .. )- , Path( .. )- , Transformable( .. )- , PointFoldable( .. )-- -- * Rasterization control types- , Cap( .. )- , Join( .. )- , FillMethod( .. )- , SamplerRepeat( .. )- , DashPattern- , StrokeWidth-- -- * Internal type- , EdgeSample( .. )- , pathToPrimitives-- -- * Little geometry helpers- , firstTangeantOf- , lastTangeantOf- , firstPointOf- , lastPointOf- , resplit-- -- * RankNType helper- , Proxy( Proxy )- ) where--import Data.DList( DList, fromList )--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable( Foldable )-import Data.Traversable( Traversable )-import Control.Applicative( (<$>), (<*>), pure )-#endif-import Control.Monad.Identity( runIdentity )-import Data.Foldable( foldl', toList )-import qualified Data.Foldable as F-import Graphics.Rasterific.Linear( V2( .. ), (^-^), nearZero )-import Graphics.Rasterific.Operators-import Foreign.Ptr( castPtr )-import Foreign.Storable( Storable( sizeOf- , alignment- , peek- , poke- , peekElemOff- , pokeElemOff ) )---- | Represent a vector-type Vector = V2 Float---- | Type alias just to get more meaningful--- type signatures-type StrokeWidth = Float---- | Dash pattern to use-type DashPattern = [Float]--data Proxy p = Proxy---- | Describe how we will "finish" the stroking--- that don't loop.-data Cap- -- | Create a straight caping on the stroke.- -- Cap value should be positive and represent- -- the distance from the end of curve to the actual cap- --- -- * cap straight with param 0 : <<docimages/cap_straight.png>>- --- -- * cap straight with param 1 : <<docimages/cap_straight_1.png>>- --- = CapStraight Float-- -- | Create a rounded caping on the stroke.- -- <<docimages/cap_round.png>>- | CapRound- deriving (Eq, Show)---- | Describe how to display the join of broken lines--- while stroking.-data Join- -- | Make a curved join.- -- <<docimages/join_round.png>>- = JoinRound- -- | Make a mitter join. Value must be positive or null.- -- Seems to make sense in [0;1] only- --- -- * Miter join with 0 : <<docimages/join_miter.png>>- --- -- * Miter join with 5 : <<docimages/join_miter_5.png>>- --- | JoinMiter Float- deriving (Eq, Show)---- | Tell how to fill complex shapes when there is self --- intersections. If the filling mode is not specified,--- then it's the `FillWinding` method which is used.------ The examples used are produced with the following--- function:--------- > fillingSample :: FillMethod -> Drawing px ()--- > fillingSample fillMethod = fillWithMethod fillMethod geometry where--- > geometry = transform (applyTransformation $ scale 0.35 0.4--- > <> translate (V2 (-80) (-180)))--- > [ Path (V2 484 499) True--- > [ PathCubicBezierCurveTo (V2 681 452) (V2 639 312) (V2 541 314)--- > , PathCubicBezierCurveTo (V2 327 337) (V2 224 562) (V2 484 499)--- > ]--- > , Path (V2 136 377) True--- > [ PathCubicBezierCurveTo (V2 244 253) (V2 424 420) (V2 357 489)--- > , PathCubicBezierCurveTo (V2 302 582) (V2 47 481) (V2 136 377)--- > ]--- > , Path (V2 340 265) True--- > [ PathCubicBezierCurveTo (V2 64 371) (V2 128 748) (V2 343 536)--- > , PathCubicBezierCurveTo (V2 668 216) (V2 17 273) (V2 367 575)--- > , PathCubicBezierCurveTo (V2 589 727) (V2 615 159) (V2 340 265)--- > ]--- > ]-data FillMethod- -- | Also known as nonzero rule.- -- To determine if a point falls inside the curve, you draw - -- an imaginary line through that point. Next you will count- -- how many times that line crosses the curve before it reaches- -- that point. For every clockwise rotation, you subtract 1 and- -- for every counter-clockwise rotation you add 1.- --- -- <<docimages/fill_winding.png>>- = FillWinding-- -- | This rule determines the insideness of a point on - -- the canvas by drawing a ray from that point to infinity- -- in any direction and counting the number of path segments- -- from the given shape that the ray crosses. If this number- -- is odd, the point is inside; if even, the point is outside.- --- -- <<docimages/fill_evenodd.png>>- | FillEvenOdd- deriving (Eq, Enum, Show)---- | Describe the behaviour of samplers and texturers--- when they are out of the bounds of image and/or gradient.-data SamplerRepeat- -- | Will clamp (ie. repeat the last pixel) when- -- out of bound- -- <<docimages/sampler_pad.png>>- = SamplerPad- -- | Will loop on it's definition domain- -- <<docimages/sampler_repeat.png>>- | SamplerRepeat- -- | Will loop inverting axises- -- <<docimages/sampler_reflect.png>>- | SamplerReflect- deriving (Eq, Enum, Show)---- | Represent a raster line-data EdgeSample = EdgeSample- { _sampleX :: {-# UNPACK #-} !Float -- ^ Horizontal position- , _sampleY :: {-# UNPACK #-} !Float -- ^ Vertical position- , _sampleAlpha :: {-# UNPACK #-} !Float -- ^ Alpha- , _sampleH :: {-# UNPACK #-} !Float -- ^ Height- }- deriving Show---- | Just to get faster sorting-instance Storable EdgeSample where- sizeOf _ = 4 * sizeOf (0 :: Float)- alignment = sizeOf-- {-# INLINE peek #-}- peek ptr = do- let q = castPtr ptr- sx <- peekElemOff q 0- sy <- peekElemOff q 1- sa <- peekElemOff q 2- sh <- peekElemOff q 3- return $ EdgeSample sx sy sa sh- - {-# INLINE poke #-}- poke ptr (EdgeSample sx sy sa sh) = do- let q = castPtr ptr- pokeElemOff q 0 sx- pokeElemOff q 1 sy- pokeElemOff q 2 sa- pokeElemOff q 3 sh---- | This typeclass is there to help transform the geometry,--- by applying a transformation on every point of a geometric--- element.-class Transformable a where- -- | Apply a transformation function for every- -- point in the element.- transform :: (Point -> Point) -> a -> a- transform f = runIdentity . transformM (return . f)-- -- | Transform but monadic- transformM :: Monad m => (Point -> m Point) -> a -> m a---- | Typeclass helper gathering all the points of a given--- geometry.-class PointFoldable a where- -- | Fold an accumulator on all the points of- -- the primitive.- foldPoints :: (b -> Point -> b) -> b -> a -> b---- | Just apply the function-instance Transformable Point where- {-# INLINE transform #-}- transform f = f- {-# INLINE transformM #-}- transformM f = f---- | Just apply the function-instance PointFoldable Point where- {-# INLINE foldPoints #-}- foldPoints f = f---- | Describe a simple 2D line between two points.------ > fill [ Line (V2 10 10) (V2 190 10)--- > , Line (V2 190 10) (V2 95 170)--- > , Line (V2 95 170) (V2 10 10)]------ <<docimages/simple_line.png>>----data Line = Line- { _lineX0 :: {-# UNPACK #-} !Point -- ^ Origin point- , _lineX1 :: {-# UNPACK #-} !Point -- ^ End point- }- deriving Eq--instance Show Line where- show (Line a b) =- "Line (" ++ show a ++ ") ("- ++ show b ++ ")"--instance Transformable Line where- {-# INLINE transformM #-}- transformM f (Line a b) = Line <$> f a <*> f b--instance PointFoldable Line where- {-# INLINE foldPoints #-}- foldPoints f acc (Line a b) = f (f acc b) a---- | Describe a quadratic bezier spline, described--- using 3 points.------ > fill [Bezier (V2 10 10) (V2 200 50) (V2 200 100)--- > ,Bezier (V2 200 100) (V2 150 200) (V2 120 175)--- > ,Bezier (V2 120 175) (V2 30 100) (V2 10 10)]------ <<docimages/quadratic_bezier.png>>----data Bezier = Bezier- { -- | Origin points, the spline will pass through it.- _bezierX0 :: {-# UNPACK #-} !Point- -- | Control point, the spline won't pass on it.- , _bezierX1 :: {-# UNPACK #-} !Point- -- | End point, the spline will pass through it.- , _bezierX2 :: {-# UNPACK #-} !Point- }- deriving Eq--instance Show Bezier where- show (Bezier a b c) =- "Bezier (" ++ show a ++ ") ("- ++ show b ++ ") ("- ++ show c ++ ")"--instance Transformable Bezier where- {-# INLINE transform #-}- transform f (Bezier a b c) = Bezier (f a) (f b) $ f c- {-# INLINE transformM #-}- transformM f (Bezier a b c) = Bezier <$> f a <*> f b <*> f c--instance PointFoldable Bezier where- {-# INLINE foldPoints #-}- foldPoints f acc (Bezier a b c) =- foldl' f acc [a, b, c]---- | Describe a cubic bezier spline, described--- using 4 points.------ > stroke 4 JoinRound (CapRound, CapRound) $--- > CubicBezier (V2 0 10) (V2 205 250) (V2 (-10) 250) (V2 160 35)------ <<docimages/cubic_bezier.png>>----data CubicBezier = CubicBezier- { -- | Origin point, the spline will pass through it.- _cBezierX0 :: {-# UNPACK #-} !Point- -- | First control point of the cubic bezier curve.- , _cBezierX1 :: {-# UNPACK #-} !Point- -- | Second control point of the cubic bezier curve.- , _cBezierX2 :: {-# UNPACK #-} !Point- -- | End point of the cubic bezier curve- , _cBezierX3 :: {-# UNPACK #-} !Point- }- deriving Eq--instance Show CubicBezier where- show (CubicBezier a b c d) =- "CubicBezier (" ++ show a ++ ") ("- ++ show b ++ ") ("- ++ show c ++ ") ("- ++ show d ++ ")"--instance Transformable CubicBezier where- {-# INLINE transform #-}- transform f (CubicBezier a b c d) =- CubicBezier (f a) (f b) (f c) $ f d- transformM f (CubicBezier a b c d) =- CubicBezier <$> f a <*> f b <*> f c <*> f d--instance PointFoldable CubicBezier where- {-# INLINE foldPoints #-}- foldPoints f acc (CubicBezier a b c d) =- foldl' f acc [a, b, c, d]---- | This datatype gather all the renderable primitives,--- they are kept separated otherwise to allow specialization--- on some specific algorithms. You can mix the different--- primitives in a single call :------ > fill [ toPrim $ CubicBezier (V2 50 20) (V2 90 60)--- > (V2 5 100) (V2 50 140)--- > , toPrim $ Line (V2 50 140) (V2 120 80)--- > , toPrim $ Line (V2 120 80) (V2 50 20) ]------ <<docimages/primitive_mixed.png>>----data Primitive- = LinePrim !Line -- ^ Primitive used for lines- | BezierPrim !Bezier -- ^ Primitive used for quadratic beziers curves- | CubicBezierPrim !CubicBezier -- ^ Primitive used for cubic bezier curve- deriving (Eq, Show)---- | Generalizing constructors of the `Primitive` type to work--- generically.-class Primitivable a where- toPrim :: a -> Primitive---- | @toPrim = id@-instance Primitivable Primitive where toPrim = id---- | @toPrim = LinePrim@-instance Primitivable Line where toPrim = LinePrim---- | @toPrim = BezierPrim@-instance Primitivable Bezier where toPrim = BezierPrim---- | @toPrim = CubicBezierPrim@-instance Primitivable CubicBezier where toPrim = CubicBezierPrim---- | All the rasterization works on lists of primitives,--- in order to ease the use of the library, the Geometry--- type class provides conversion facility, which help--- generalising the geometry definition and avoid applying--- Primitive constructor.------ Also streamline the Path conversion.-class Geometry a where- -- | Convert an element to a list of primitives- -- to be rendered.- toPrimitives :: a -> [Primitive]-- -- | Helper method to avoid overlaping instances.- -- You shouldn't use it directly.- listToPrims :: (Foldable f) => f a -> [Primitive]- {-# INLINE listToPrims #-}- listToPrims = F.concatMap toPrimitives . F.toList--instance Geometry Path where- {-# INLINE toPrimitives #-}- toPrimitives = pathToPrimitives--instance Geometry Primitive where- toPrimitives e = [e]- {-# INLINE listToPrims #-}- listToPrims = F.toList -- Open question, is it optimised as `id`?--instance Geometry Line where- {-# INLINE toPrimitives #-}- toPrimitives e = [toPrim e]--instance Geometry Bezier where- {-# INLINE toPrimitives #-}- toPrimitives e = [toPrim e]--instance Geometry CubicBezier where- {-# INLINE toPrimitives #-}- toPrimitives e = [toPrim e]---- | Generalize the geometry to any foldable container,--- so you can throw any container to the the 'fill' or--- 'stroke' function.-instance (Foldable f, Geometry a) => Geometry (f a) where- {-# INLINE toPrimitives #-}- toPrimitives = listToPrims---instance Transformable Primitive where- {-# INLINE transform #-}- transform f (LinePrim l) = LinePrim $ transform f l- transform f (BezierPrim b) = BezierPrim $ transform f b- transform f (CubicBezierPrim c) = CubicBezierPrim $ transform f c-- transformM f (LinePrim l) = LinePrim <$> transformM f l- transformM f (BezierPrim b) = BezierPrim <$> transformM f b- transformM f (CubicBezierPrim c) = CubicBezierPrim <$> transformM f c--instance PointFoldable Primitive where- {-# INLINE foldPoints #-}- foldPoints f acc = go- where go (LinePrim l) = foldPoints f acc l- go (BezierPrim b) = foldPoints f acc b- go (CubicBezierPrim c) = foldPoints f acc c--instance {-# OVERLAPPABLE #-} (Traversable f, Transformable a)- => Transformable (f a) where- transform f = fmap (transform f)- transformM f = mapM (transformM f)--instance {-# OVERLAPPABLE #-} (Foldable f, PointFoldable a)- => PointFoldable (f a) where- foldPoints f = foldl' (foldPoints f)--type Producer a = [a] -> [a]--type Container a = DList a--containerOfFunction :: ([a] -> [a]) -> Container a-containerOfFunction f = fromList $ f []--containerOfList :: [a] -> Container a-containerOfList = fromList--listOfContainer :: Container a -> [a]-listOfContainer = toList---- | Describe a path in a way similar to many graphical--- packages, using a "pen" position in memory and reusing--- it for the next "move"--- For example the example from Primitive could be rewritten:------ > fill $ Path (V2 50 20) True--- > [ PathCubicBezierCurveTo (V2 90 60) (V2 5 100) (V2 50 140)--- > , PathLineTo (V2 120 80) ]------ <<docimages/path_example.png>>----data Path = Path- { -- | Origin of the point, equivalent to the- -- first "move" command.- _pathOriginPoint :: Point- -- | Tell if we must close the path.- , _pathClose :: Bool- -- | List of commands in the path- , _pathCommand :: [PathCommand]- }- deriving (Eq, Show)--instance Transformable Path where- {-# INLINE transform #-}- transform f (Path orig close rest) =- Path (f orig) close (transform f rest)-- transformM f (Path orig close rest) =- Path <$> f orig <*> pure close <*> transformM f rest---instance PointFoldable Path where- {-# INLINE foldPoints #-}- foldPoints f acc (Path o _ rest) =- foldPoints f (f acc o) rest---- | Actions to create a path-data PathCommand- = -- | Draw a line from the current point to another point- PathLineTo Point- -- | Draw a quadratic bezier curve from the current point- -- through the control point to the end point.- | PathQuadraticBezierCurveTo Point Point-- -- | Draw a cubic bezier curve using 2 control points.- | PathCubicBezierCurveTo Point Point Point- deriving (Eq, Show)--instance Transformable PathCommand where- transform f (PathLineTo p) = PathLineTo $ f p- transform f (PathQuadraticBezierCurveTo p1 p2) =- PathQuadraticBezierCurveTo (f p1) $ f p2- transform f (PathCubicBezierCurveTo p1 p2 p3) =- PathCubicBezierCurveTo (f p1) (f p2) $ f p3-- transformM f (PathLineTo p) = PathLineTo <$> f p- transformM f (PathQuadraticBezierCurveTo p1 p2) =- PathQuadraticBezierCurveTo <$> f p1 <*> f p2- transformM f (PathCubicBezierCurveTo p1 p2 p3) =- PathCubicBezierCurveTo <$> f p1 <*> f p2 <*> f p3--instance PointFoldable PathCommand where- foldPoints f acc (PathLineTo p) = f acc p- foldPoints f acc (PathQuadraticBezierCurveTo p1 p2) =- f (f acc p1) p2- foldPoints f acc (PathCubicBezierCurveTo p1 p2 p3) =- foldl' f acc [p1, p2, p3]---- | Transform a path description into a list of renderable--- primitives.-pathToPrimitives :: Path -> [Primitive]-pathToPrimitives (Path origin needClosing commands) = go origin commands- where- go prev [] | prev /= origin && needClosing = [LinePrim $ Line prev origin]- go _ [] = []- go prev (PathLineTo to : xs) =- LinePrim (Line prev to) : go to xs- go prev (PathQuadraticBezierCurveTo c1 to : xs) =- BezierPrim (Bezier prev c1 to) : go to xs- go prev (PathCubicBezierCurveTo c1 c2 to : xs) =- CubicBezierPrim (CubicBezier prev c1 c2 to) : go to xs---- | Gives the orientation vector for the start of the--- primitive.-firstTangeantOf :: Primitive -> Vector-firstTangeantOf p = case p of- LinePrim (Line p0 p1) -> p1 ^-^ p0- BezierPrim (Bezier p0 p1 p2) ->- (p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1)- CubicBezierPrim (CubicBezier p0 p1 p2 _) -> - (p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1)- where- ifBigEnough a b | nearZero a = b- | otherwise = a---- | Gives the orientation vector at the end of the--- primitive.-lastTangeantOf :: Primitive -> Vector-lastTangeantOf p = case p of- LinePrim (Line p0 p1) -> p1 ^-^ p0- BezierPrim (Bezier _ p1 p2) -> p2 ^-^ p1- CubicBezierPrim (CubicBezier _ _ p2 p3) -> p3 ^-^ p2---- | Extract the first point of the primitive.-firstPointOf :: Primitive -> Point-firstPointOf p = case p of- LinePrim (Line p0 _) -> p0- BezierPrim (Bezier p0 _ _) -> p0- CubicBezierPrim (CubicBezier p0 _ _ _) -> p0---- | Return the last point of a given primitive.-lastPointOf :: Primitive -> Point-lastPointOf p = case p of- LinePrim (Line _ p0) -> p0- BezierPrim (Bezier _ _ p0) -> p0- CubicBezierPrim (CubicBezier _ _ _ p0) -> p0--resplit :: [Primitive] -> [[Primitive]]-resplit = uncurry (:) . go where- go [] = ([], [])- go (x:xs@(y:_)) | lastPointOf x `isDistingableFrom` firstPointOf y =- ([x], after:rest) where (after, rest) = go xs- go (x:xs) = (x:curr, rest) where (curr, rest) = go xs-+{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +-- | Gather all the types used in the rasterization engine. +module Graphics.Rasterific.Types + ( -- * Geometry description + Vector + , Point + , Line( .. ) + , Bezier( .. ) + , CubicBezier( .. ) + , Primitive( .. ) + + , Primitivable( .. ) + , Geometry( .. ) + + , Producer + , Container + , containerOfList + , listOfContainer + , containerOfFunction + , PathCommand( .. ) + , Path( .. ) + , Transformable( .. ) + , PointFoldable( .. ) + + -- * Rasterization control types + , Cap( .. ) + , Join( .. ) + , FillMethod( .. ) + , SamplerRepeat( .. ) + , DashPattern + , StrokeWidth + + -- * Internal type + , EdgeSample( .. ) + , pathToPrimitives + + -- * Little geometry helpers + , firstTangeantOf + , lastTangeantOf + , firstPointOf + , lastPointOf + , resplit + + -- * RankNType helper + , Proxy( Proxy ) + ) where + +import Data.DList( DList, fromList ) + +import Control.Monad.Identity( runIdentity ) +import Data.Foldable( foldl', toList ) +import qualified Data.Foldable as F +import Graphics.Rasterific.Linear( V2( .. ), (^-^), nearZero ) +import Graphics.Rasterific.Operators +import Foreign.Ptr( castPtr ) +import Foreign.Storable( Storable( sizeOf + , alignment + , peek + , poke + , peekElemOff + , pokeElemOff ) ) + +-- | Represent a vector +type Vector = V2 Float + +-- | Type alias just to get more meaningful +-- type signatures +type StrokeWidth = Float + +-- | Dash pattern to use +type DashPattern = [Float] + +data Proxy p = Proxy + +-- | Describe how we will "finish" the stroking +-- that don't loop. +data Cap + -- | Create a straight caping on the stroke. + -- Cap value should be positive and represent + -- the distance from the end of curve to the actual cap + -- + -- * cap straight with param 0 : <<docimages/cap_straight.png>> + -- + -- * cap straight with param 1 : <<docimages/cap_straight_1.png>> + -- + = CapStraight Float + + -- | Create a rounded caping on the stroke. + -- <<docimages/cap_round.png>> + | CapRound + deriving (Eq, Show) + +-- | Describe how to display the join of broken lines +-- while stroking. +data Join + -- | Make a curved join. + -- <<docimages/join_round.png>> + = JoinRound + -- | Make a mitter join. Value must be positive or null. + -- Seems to make sense in [0;1] only + -- + -- * Miter join with 0 : <<docimages/join_miter.png>> + -- + -- * Miter join with 5 : <<docimages/join_miter_5.png>> + -- + | JoinMiter Float + deriving (Eq, Show) + +-- | Tell how to fill complex shapes when there is self +-- intersections. If the filling mode is not specified, +-- then it's the `FillWinding` method which is used. +-- +-- The examples used are produced with the following +-- function: +-- +-- +-- > fillingSample :: FillMethod -> Drawing px () +-- > fillingSample fillMethod = fillWithMethod fillMethod geometry where +-- > geometry = transform (applyTransformation $ scale 0.35 0.4 +-- > <> translate (V2 (-80) (-180))) +-- > [ Path (V2 484 499) True +-- > [ PathCubicBezierCurveTo (V2 681 452) (V2 639 312) (V2 541 314) +-- > , PathCubicBezierCurveTo (V2 327 337) (V2 224 562) (V2 484 499) +-- > ] +-- > , Path (V2 136 377) True +-- > [ PathCubicBezierCurveTo (V2 244 253) (V2 424 420) (V2 357 489) +-- > , PathCubicBezierCurveTo (V2 302 582) (V2 47 481) (V2 136 377) +-- > ] +-- > , Path (V2 340 265) True +-- > [ PathCubicBezierCurveTo (V2 64 371) (V2 128 748) (V2 343 536) +-- > , PathCubicBezierCurveTo (V2 668 216) (V2 17 273) (V2 367 575) +-- > , PathCubicBezierCurveTo (V2 589 727) (V2 615 159) (V2 340 265) +-- > ] +-- > ] +data FillMethod + -- | Also known as nonzero rule. + -- To determine if a point falls inside the curve, you draw + -- an imaginary line through that point. Next you will count + -- how many times that line crosses the curve before it reaches + -- that point. For every clockwise rotation, you subtract 1 and + -- for every counter-clockwise rotation you add 1. + -- + -- <<docimages/fill_winding.png>> + = FillWinding + + -- | This rule determines the insideness of a point on + -- the canvas by drawing a ray from that point to infinity + -- in any direction and counting the number of path segments + -- from the given shape that the ray crosses. If this number + -- is odd, the point is inside; if even, the point is outside. + -- + -- <<docimages/fill_evenodd.png>> + | FillEvenOdd + deriving (Eq, Enum, Show) + +-- | Describe the behaviour of samplers and texturers +-- when they are out of the bounds of image and/or gradient. +data SamplerRepeat + -- | Will clamp (ie. repeat the last pixel) when + -- out of bound + -- <<docimages/sampler_pad.png>> + = SamplerPad + -- | Will loop on it's definition domain + -- <<docimages/sampler_repeat.png>> + | SamplerRepeat + -- | Will loop inverting axises + -- <<docimages/sampler_reflect.png>> + | SamplerReflect + deriving (Eq, Enum, Show) + +-- | Represent a raster line +data EdgeSample = EdgeSample + { _sampleX :: {-# UNPACK #-} !Float -- ^ Horizontal position + , _sampleY :: {-# UNPACK #-} !Float -- ^ Vertical position + , _sampleAlpha :: {-# UNPACK #-} !Float -- ^ Alpha + , _sampleH :: {-# UNPACK #-} !Float -- ^ Height + } + deriving Show + +-- | Just to get faster sorting +instance Storable EdgeSample where + sizeOf _ = 4 * sizeOf (0 :: Float) + alignment = sizeOf + + {-# INLINE peek #-} + peek ptr = do + let q = castPtr ptr + sx <- peekElemOff q 0 + sy <- peekElemOff q 1 + sa <- peekElemOff q 2 + sh <- peekElemOff q 3 + return $ EdgeSample sx sy sa sh + + {-# INLINE poke #-} + poke ptr (EdgeSample sx sy sa sh) = do + let q = castPtr ptr + pokeElemOff q 0 sx + pokeElemOff q 1 sy + pokeElemOff q 2 sa + pokeElemOff q 3 sh + +-- | This typeclass is there to help transform the geometry, +-- by applying a transformation on every point of a geometric +-- element. +class Transformable a where + -- | Apply a transformation function for every + -- point in the element. + transform :: (Point -> Point) -> a -> a + transform f = runIdentity . transformM (return . f) + + -- | Transform but monadic + transformM :: Monad m => (Point -> m Point) -> a -> m a + +-- | Typeclass helper gathering all the points of a given +-- geometry. +class PointFoldable a where + -- | Fold an accumulator on all the points of + -- the primitive. + foldPoints :: (b -> Point -> b) -> b -> a -> b + +-- | Just apply the function +instance Transformable Point where + {-# INLINE transform #-} + transform f = f + {-# INLINE transformM #-} + transformM f = f + +-- | Just apply the function +instance PointFoldable Point where + {-# INLINE foldPoints #-} + foldPoints f = f + +-- | Describe a simple 2D line between two points. +-- +-- > fill [ Line (V2 10 10) (V2 190 10) +-- > , Line (V2 190 10) (V2 95 170) +-- > , Line (V2 95 170) (V2 10 10)] +-- +-- <<docimages/simple_line.png>> +-- +data Line = Line + { _lineX0 :: {-# UNPACK #-} !Point -- ^ Origin point + , _lineX1 :: {-# UNPACK #-} !Point -- ^ End point + } + deriving Eq + +instance Show Line where + show (Line a b) = + "Line (" ++ show a ++ ") (" + ++ show b ++ ")" + +instance Transformable Line where + {-# INLINE transformM #-} + transformM f (Line a b) = Line <$> f a <*> f b + +instance PointFoldable Line where + {-# INLINE foldPoints #-} + foldPoints f acc (Line a b) = f (f acc b) a + +-- | Describe a quadratic bezier spline, described +-- using 3 points. +-- +-- > fill [Bezier (V2 10 10) (V2 200 50) (V2 200 100) +-- > ,Bezier (V2 200 100) (V2 150 200) (V2 120 175) +-- > ,Bezier (V2 120 175) (V2 30 100) (V2 10 10)] +-- +-- <<docimages/quadratic_bezier.png>> +-- +data Bezier = Bezier + { -- | Origin points, the spline will pass through it. + _bezierX0 :: {-# UNPACK #-} !Point + -- | Control point, the spline won't pass on it. + , _bezierX1 :: {-# UNPACK #-} !Point + -- | End point, the spline will pass through it. + , _bezierX2 :: {-# UNPACK #-} !Point + } + deriving Eq + +instance Show Bezier where + show (Bezier a b c) = + "Bezier (" ++ show a ++ ") (" + ++ show b ++ ") (" + ++ show c ++ ")" + +instance Transformable Bezier where + {-# INLINE transform #-} + transform f (Bezier a b c) = Bezier (f a) (f b) $ f c + {-# INLINE transformM #-} + transformM f (Bezier a b c) = Bezier <$> f a <*> f b <*> f c + +instance PointFoldable Bezier where + {-# INLINE foldPoints #-} + foldPoints f acc (Bezier a b c) = + foldl' f acc [a, b, c] + +-- | Describe a cubic bezier spline, described +-- using 4 points. +-- +-- > stroke 4 JoinRound (CapRound, CapRound) $ +-- > CubicBezier (V2 0 10) (V2 205 250) (V2 (-10) 250) (V2 160 35) +-- +-- <<docimages/cubic_bezier.png>> +-- +data CubicBezier = CubicBezier + { -- | Origin point, the spline will pass through it. + _cBezierX0 :: {-# UNPACK #-} !Point + -- | First control point of the cubic bezier curve. + , _cBezierX1 :: {-# UNPACK #-} !Point + -- | Second control point of the cubic bezier curve. + , _cBezierX2 :: {-# UNPACK #-} !Point + -- | End point of the cubic bezier curve + , _cBezierX3 :: {-# UNPACK #-} !Point + } + deriving Eq + +instance Show CubicBezier where + show (CubicBezier a b c d) = + "CubicBezier (" ++ show a ++ ") (" + ++ show b ++ ") (" + ++ show c ++ ") (" + ++ show d ++ ")" + +instance Transformable CubicBezier where + {-# INLINE transform #-} + transform f (CubicBezier a b c d) = + CubicBezier (f a) (f b) (f c) $ f d + transformM f (CubicBezier a b c d) = + CubicBezier <$> f a <*> f b <*> f c <*> f d + +instance PointFoldable CubicBezier where + {-# INLINE foldPoints #-} + foldPoints f acc (CubicBezier a b c d) = + foldl' f acc [a, b, c, d] + +-- | This datatype gather all the renderable primitives, +-- they are kept separated otherwise to allow specialization +-- on some specific algorithms. You can mix the different +-- primitives in a single call : +-- +-- > fill [ toPrim $ CubicBezier (V2 50 20) (V2 90 60) +-- > (V2 5 100) (V2 50 140) +-- > , toPrim $ Line (V2 50 140) (V2 120 80) +-- > , toPrim $ Line (V2 120 80) (V2 50 20) ] +-- +-- <<docimages/primitive_mixed.png>> +-- +data Primitive + = LinePrim !Line -- ^ Primitive used for lines + | BezierPrim !Bezier -- ^ Primitive used for quadratic beziers curves + | CubicBezierPrim !CubicBezier -- ^ Primitive used for cubic bezier curve + deriving (Eq, Show) + +-- | Generalizing constructors of the `Primitive` type to work +-- generically. +class Primitivable a where + toPrim :: a -> Primitive + +-- | @toPrim = id@ +instance Primitivable Primitive where toPrim = id + +-- | @toPrim = LinePrim@ +instance Primitivable Line where toPrim = LinePrim + +-- | @toPrim = BezierPrim@ +instance Primitivable Bezier where toPrim = BezierPrim + +-- | @toPrim = CubicBezierPrim@ +instance Primitivable CubicBezier where toPrim = CubicBezierPrim + +-- | All the rasterization works on lists of primitives, +-- in order to ease the use of the library, the Geometry +-- type class provides conversion facility, which help +-- generalising the geometry definition and avoid applying +-- Primitive constructor. +-- +-- Also streamline the Path conversion. +class Geometry a where + -- | Convert an element to a list of primitives + -- to be rendered. + toPrimitives :: a -> [Primitive] + + -- | Helper method to avoid overlaping instances. + -- You shouldn't use it directly. + listToPrims :: (Foldable f) => f a -> [Primitive] + {-# INLINE listToPrims #-} + listToPrims = F.concatMap toPrimitives . F.toList + +instance Geometry Path where + {-# INLINE toPrimitives #-} + toPrimitives = pathToPrimitives + +instance Geometry Primitive where + toPrimitives e = [e] + {-# INLINE listToPrims #-} + listToPrims = F.toList -- Open question, is it optimised as `id`? + +instance Geometry Line where + {-# INLINE toPrimitives #-} + toPrimitives e = [toPrim e] + +instance Geometry Bezier where + {-# INLINE toPrimitives #-} + toPrimitives e = [toPrim e] + +instance Geometry CubicBezier where + {-# INLINE toPrimitives #-} + toPrimitives e = [toPrim e] + +-- | Generalize the geometry to any foldable container, +-- so you can throw any container to the the 'fill' or +-- 'stroke' function. +instance (Foldable f, Geometry a) => Geometry (f a) where + {-# INLINE toPrimitives #-} + toPrimitives = listToPrims + + +instance Transformable Primitive where + {-# INLINE transform #-} + transform f (LinePrim l) = LinePrim $ transform f l + transform f (BezierPrim b) = BezierPrim $ transform f b + transform f (CubicBezierPrim c) = CubicBezierPrim $ transform f c + + transformM f (LinePrim l) = LinePrim <$> transformM f l + transformM f (BezierPrim b) = BezierPrim <$> transformM f b + transformM f (CubicBezierPrim c) = CubicBezierPrim <$> transformM f c + +instance PointFoldable Primitive where + {-# INLINE foldPoints #-} + foldPoints f acc = go + where go (LinePrim l) = foldPoints f acc l + go (BezierPrim b) = foldPoints f acc b + go (CubicBezierPrim c) = foldPoints f acc c + +instance {-# OVERLAPPABLE #-} (Traversable f, Transformable a) + => Transformable (f a) where + transform f = fmap (transform f) + transformM f = mapM (transformM f) + +instance {-# OVERLAPPABLE #-} (Foldable f, PointFoldable a) + => PointFoldable (f a) where + foldPoints f = foldl' (foldPoints f) + +type Producer a = [a] -> [a] + +type Container a = DList a + +containerOfFunction :: ([a] -> [a]) -> Container a +containerOfFunction f = fromList $ f [] + +containerOfList :: [a] -> Container a +containerOfList = fromList + +listOfContainer :: Container a -> [a] +listOfContainer = toList + +-- | Describe a path in a way similar to many graphical +-- packages, using a "pen" position in memory and reusing +-- it for the next "move" +-- For example the example from Primitive could be rewritten: +-- +-- > fill $ Path (V2 50 20) True +-- > [ PathCubicBezierCurveTo (V2 90 60) (V2 5 100) (V2 50 140) +-- > , PathLineTo (V2 120 80) ] +-- +-- <<docimages/path_example.png>> +-- +data Path = Path + { -- | Origin of the point, equivalent to the + -- first "move" command. + _pathOriginPoint :: Point + -- | Tell if we must close the path. + , _pathClose :: Bool + -- | List of commands in the path + , _pathCommand :: [PathCommand] + } + deriving (Eq, Show) + +instance Transformable Path where + {-# INLINE transform #-} + transform f (Path orig close rest) = + Path (f orig) close (transform f rest) + + transformM f (Path orig close rest) = + Path <$> f orig <*> pure close <*> transformM f rest + + +instance PointFoldable Path where + {-# INLINE foldPoints #-} + foldPoints f acc (Path o _ rest) = + foldPoints f (f acc o) rest + +-- | Actions to create a path +data PathCommand + = -- | Draw a line from the current point to another point + PathLineTo Point + -- | Draw a quadratic bezier curve from the current point + -- through the control point to the end point. + | PathQuadraticBezierCurveTo Point Point + + -- | Draw a cubic bezier curve using 2 control points. + | PathCubicBezierCurveTo Point Point Point + deriving (Eq, Show) + +instance Transformable PathCommand where + transform f (PathLineTo p) = PathLineTo $ f p + transform f (PathQuadraticBezierCurveTo p1 p2) = + PathQuadraticBezierCurveTo (f p1) $ f p2 + transform f (PathCubicBezierCurveTo p1 p2 p3) = + PathCubicBezierCurveTo (f p1) (f p2) $ f p3 + + transformM f (PathLineTo p) = PathLineTo <$> f p + transformM f (PathQuadraticBezierCurveTo p1 p2) = + PathQuadraticBezierCurveTo <$> f p1 <*> f p2 + transformM f (PathCubicBezierCurveTo p1 p2 p3) = + PathCubicBezierCurveTo <$> f p1 <*> f p2 <*> f p3 + +instance PointFoldable PathCommand where + foldPoints f acc (PathLineTo p) = f acc p + foldPoints f acc (PathQuadraticBezierCurveTo p1 p2) = + f (f acc p1) p2 + foldPoints f acc (PathCubicBezierCurveTo p1 p2 p3) = + foldl' f acc [p1, p2, p3] + +-- | Transform a path description into a list of renderable +-- primitives. +pathToPrimitives :: Path -> [Primitive] +pathToPrimitives (Path origin needClosing commands) = go origin commands + where + go prev [] | prev /= origin && needClosing = [LinePrim $ Line prev origin] + go _ [] = [] + go prev (PathLineTo to : xs) = + LinePrim (Line prev to) : go to xs + go prev (PathQuadraticBezierCurveTo c1 to : xs) = + BezierPrim (Bezier prev c1 to) : go to xs + go prev (PathCubicBezierCurveTo c1 c2 to : xs) = + CubicBezierPrim (CubicBezier prev c1 c2 to) : go to xs + +-- | Gives the orientation vector for the start of the +-- primitive. +firstTangeantOf :: Primitive -> Vector +firstTangeantOf p = case p of + LinePrim (Line p0 p1) -> p1 ^-^ p0 + BezierPrim (Bezier p0 p1 p2) -> + (p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1) + CubicBezierPrim (CubicBezier p0 p1 p2 _) -> + (p1 ^-^ p0) `ifBigEnough` (p2 ^-^ p1) + where + ifBigEnough a b | nearZero a = b + | otherwise = a + +-- | Gives the orientation vector at the end of the +-- primitive. +lastTangeantOf :: Primitive -> Vector +lastTangeantOf p = case p of + LinePrim (Line p0 p1) -> p1 ^-^ p0 + BezierPrim (Bezier _ p1 p2) -> p2 ^-^ p1 + CubicBezierPrim (CubicBezier _ _ p2 p3) -> p3 ^-^ p2 + +-- | Extract the first point of the primitive. +firstPointOf :: Primitive -> Point +firstPointOf p = case p of + LinePrim (Line p0 _) -> p0 + BezierPrim (Bezier p0 _ _) -> p0 + CubicBezierPrim (CubicBezier p0 _ _ _) -> p0 + +-- | Return the last point of a given primitive. +lastPointOf :: Primitive -> Point +lastPointOf p = case p of + LinePrim (Line _ p0) -> p0 + BezierPrim (Bezier _ _ p0) -> p0 + CubicBezierPrim (CubicBezier _ _ _ p0) -> p0 + +resplit :: [Primitive] -> [[Primitive]] +resplit = uncurry (:) . go where + go [] = ([], []) + go (x:xs@(y:_)) | lastPointOf x `isDistingableFrom` firstPointOf y = + ([x], after:rest) where (after, rest) = go xs + go (x:xs) = (x:curr, rest) where (curr, rest) = go xs +