diff --git a/Rasterific.cabal b/Rasterific.cabal --- a/Rasterific.cabal +++ b/Rasterific.cabal @@ -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 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -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 ------ diff --git a/docimages/logo.png b/docimages/logo.png Binary files a/docimages/logo.png and b/docimages/logo.png differ diff --git a/docimages/sampled_texture_reflect.png b/docimages/sampled_texture_reflect.png Binary files a/docimages/sampled_texture_reflect.png and b/docimages/sampled_texture_reflect.png differ diff --git a/docimages/strokize_dashed_path.png b/docimages/strokize_dashed_path.png Binary files a/docimages/strokize_dashed_path.png and b/docimages/strokize_dashed_path.png differ diff --git a/exec-src/docImageGenerator.hs b/exec-src/docImageGenerator.hs --- a/exec-src/docImageGenerator.hs +++ b/exec-src/docImageGenerator.hs @@ -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( (<>) ) diff --git a/src/Graphics/Rasterific.hs b/src/Graphics/Rasterific.hs --- a/src/Graphics/Rasterific.hs +++ b/src/Graphics/Rasterific.hs @@ -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 = diff --git a/src/Graphics/Rasterific/BiSampleable.hs b/src/Graphics/Rasterific/BiSampleable.hs --- a/src/Graphics/Rasterific/BiSampleable.hs +++ b/src/Graphics/Rasterific/BiSampleable.hs @@ -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) + diff --git a/src/Graphics/Rasterific/Command.hs b/src/Graphics/Rasterific/Command.hs --- a/src/Graphics/Rasterific/Command.hs +++ b/src/Graphics/Rasterific/Command.hs @@ -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 " -dumpTexture (RawTexture _) = "" -dumpTexture (ShaderTexture _) = "shaderFunction " -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 " +dumpTexture (RawTexture _) = "" +dumpTexture (ShaderTexture _) = "shaderFunction " +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 + diff --git a/src/Graphics/Rasterific/ComplexPrimitive.hs b/src/Graphics/Rasterific/ComplexPrimitive.hs --- a/src/Graphics/Rasterific/ComplexPrimitive.hs +++ b/src/Graphics/Rasterific/ComplexPrimitive.hs @@ -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 --- --- <> --- -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 --- --- <> --- -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 --- --- <> --- -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 --- --- <> --- -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 +-- +-- <> +-- +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 +-- +-- <> +-- +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 +-- +-- <> +-- +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 +-- +-- <> +-- +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 + diff --git a/src/Graphics/Rasterific/Compositor.hs b/src/Graphics/Rasterific/Compositor.hs --- a/src/Graphics/Rasterific/Compositor.hs +++ b/src/Graphics/Rasterific/Compositor.hs @@ -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 + diff --git a/src/Graphics/Rasterific/CubicBezier.hs b/src/Graphics/Rasterific/CubicBezier.hs --- a/src/Graphics/Rasterific/CubicBezier.hs +++ b/src/Graphics/Rasterific/CubicBezier.hs @@ -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) + diff --git a/src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs b/src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs --- a/src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs +++ b/src/Graphics/Rasterific/CubicBezier/FastForwardDifference.hs @@ -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 diff --git a/src/Graphics/Rasterific/Immediate.hs b/src/Graphics/Rasterific/Immediate.hs --- a/src/Graphics/Rasterific/Immediate.hs +++ b/src/Graphics/Rasterific/Immediate.hs @@ -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) --- --- <> --- -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 --- --- <> --- -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) +-- +-- <> +-- +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 +-- +-- <> +-- +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 () + } diff --git a/src/Graphics/Rasterific/Lenses.hs b/src/Graphics/Rasterific/Lenses.hs --- a/src/Graphics/Rasterific/Lenses.hs +++ b/src/Graphics/Rasterific/Lenses.hs @@ -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 + diff --git a/src/Graphics/Rasterific/Line.hs b/src/Graphics/Rasterific/Line.hs --- a/src/Graphics/Rasterific/Line.hs +++ b/src/Graphics/Rasterific/Line.hs @@ -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) + diff --git a/src/Graphics/Rasterific/Linear.hs b/src/Graphics/Rasterific/Linear.hs --- a/src/Graphics/Rasterific/Linear.hs +++ b/src/Graphics/Rasterific/Linear.hs @@ -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 + diff --git a/src/Graphics/Rasterific/MicroPdf.hs b/src/Graphics/Rasterific/MicroPdf.hs --- a/src/Graphics/Rasterific/MicroPdf.hs +++ b/src/Graphics/Rasterific/MicroPdf.hs @@ -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) + diff --git a/src/Graphics/Rasterific/MiniLens.hs b/src/Graphics/Rasterific/MiniLens.hs --- a/src/Graphics/Rasterific/MiniLens.hs +++ b/src/Graphics/Rasterific/MiniLens.hs @@ -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) + diff --git a/src/Graphics/Rasterific/Operators.hs b/src/Graphics/Rasterific/Operators.hs --- a/src/Graphics/Rasterific/Operators.hs +++ b/src/Graphics/Rasterific/Operators.hs @@ -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 + diff --git a/src/Graphics/Rasterific/Patch.hs b/src/Graphics/Rasterific/Patch.hs --- a/src/Graphics/Rasterific/Patch.hs +++ b/src/Graphics/Rasterific/Patch.hs @@ -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_ ) diff --git a/src/Graphics/Rasterific/PathWalker.hs b/src/Graphics/Rasterific/PathWalker.hs --- a/src/Graphics/Rasterific/PathWalker.hs +++ b/src/Graphics/Rasterific/PathWalker.hs @@ -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 + diff --git a/src/Graphics/Rasterific/PlaneBoundable.hs b/src/Graphics/Rasterific/PlaneBoundable.hs --- a/src/Graphics/Rasterific/PlaneBoundable.hs +++ b/src/Graphics/Rasterific/PlaneBoundable.hs @@ -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 + diff --git a/src/Graphics/Rasterific/QuadraticBezier.hs b/src/Graphics/Rasterific/QuadraticBezier.hs --- a/src/Graphics/Rasterific/QuadraticBezier.hs +++ b/src/Graphics/Rasterific/QuadraticBezier.hs @@ -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) + diff --git a/src/Graphics/Rasterific/QuadraticFormula.hs b/src/Graphics/Rasterific/QuadraticFormula.hs --- a/src/Graphics/Rasterific/QuadraticFormula.hs +++ b/src/Graphics/Rasterific/QuadraticFormula.hs @@ -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) + diff --git a/src/Graphics/Rasterific/Rasterize.hs b/src/Graphics/Rasterific/Rasterize.hs --- a/src/Graphics/Rasterific/Rasterize.hs +++ b/src/Graphics/Rasterific/Rasterize.hs @@ -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 + diff --git a/src/Graphics/Rasterific/Shading.hs b/src/Graphics/Rasterific/Shading.hs --- a/src/Graphics/Rasterific/Shading.hs +++ b/src/Graphics/Rasterific/Shading.hs @@ -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 + diff --git a/src/Graphics/Rasterific/StrokeInternal.hs b/src/Graphics/Rasterific/StrokeInternal.hs --- a/src/Graphics/Rasterific/StrokeInternal.hs +++ b/src/Graphics/Rasterific/StrokeInternal.hs @@ -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) --- --- <> --- -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) +-- +-- <> +-- +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) + diff --git a/src/Graphics/Rasterific/Transformations.hs b/src/Graphics/Rasterific/Transformations.hs --- a/src/Graphics/Rasterific/Transformations.hs +++ b/src/Graphics/Rasterific/Transformations.hs @@ -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 --- --- <> --- -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 --- --- <> --- -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 --- --- <> --- -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 --- --- <> --- -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 --- --- <> --- -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 --- --- <> --- -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 +-- +-- <> +-- +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 +-- +-- <> +-- +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 +-- +-- <> +-- +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 +-- +-- <> +-- +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 +-- +-- <> +-- +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 +-- +-- <> +-- +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 + diff --git a/src/Graphics/Rasterific/Types.hs b/src/Graphics/Rasterific/Types.hs --- a/src/Graphics/Rasterific/Types.hs +++ b/src/Graphics/Rasterific/Types.hs @@ -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 : <> - -- - -- * cap straight with param 1 : <> - -- - = CapStraight Float - - -- | Create a rounded caping on the stroke. - -- <> - | CapRound - deriving (Eq, Show) - --- | Describe how to display the join of broken lines --- while stroking. -data Join - -- | Make a curved join. - -- <> - = JoinRound - -- | Make a mitter join. Value must be positive or null. - -- Seems to make sense in [0;1] only - -- - -- * Miter join with 0 : <> - -- - -- * Miter join with 5 : <> - -- - | 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. - -- - -- <> - = 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. - -- - -- <> - | 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 - -- <> - = SamplerPad - -- | Will loop on it's definition domain - -- <> - | SamplerRepeat - -- | Will loop inverting axises - -- <> - | 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)] --- --- <> --- -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)] --- --- <> --- -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) --- --- <> --- -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) ] --- --- <> --- -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) ] --- --- <> --- -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 : <> + -- + -- * cap straight with param 1 : <> + -- + = CapStraight Float + + -- | Create a rounded caping on the stroke. + -- <> + | CapRound + deriving (Eq, Show) + +-- | Describe how to display the join of broken lines +-- while stroking. +data Join + -- | Make a curved join. + -- <> + = JoinRound + -- | Make a mitter join. Value must be positive or null. + -- Seems to make sense in [0;1] only + -- + -- * Miter join with 0 : <> + -- + -- * Miter join with 5 : <> + -- + | 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. + -- + -- <> + = 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. + -- + -- <> + | 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 + -- <> + = SamplerPad + -- | Will loop on it's definition domain + -- <> + | SamplerRepeat + -- | Will loop inverting axises + -- <> + | 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)] +-- +-- <> +-- +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)] +-- +-- <> +-- +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) +-- +-- <> +-- +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) ] +-- +-- <> +-- +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) ] +-- +-- <> +-- +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 +