diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,30 @@ -Copyright (c) 2013, Vincent Berthoux - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Vincent Berthoux nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c) 2013, Vincent Berthoux + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Vincent Berthoux nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Rasterific.cabal b/Rasterific.cabal --- a/Rasterific.cabal +++ b/Rasterific.cabal @@ -1,64 +1,64 @@ --- Initial Rasterific.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ -name: Rasterific -version: 0.2 -synopsis: A pure haskell drawing engine. --- A longer description of the package. -description: - <> - . - Rasterific is a vector drawing library (a rasterizer) - implemented in pure haskell - -license: BSD3 -license-file: LICENSE -author: Vincent Berthoux -maintainer: twinside@gmail.com - --- A copyright notice. --- copyright: -category: Graphics -build-type: Simple - --- extra-source-files: - -cabal-version: >= 1.10 -extra-source-files: changelog, docimages/*.png -extra-doc-files: docimages/*.png - - -Source-Repository head - Type: git - Location: git://github.com/Twinside/Rasterific.git - -Source-Repository this - Type: git - Location: git://github.com/Twinside/Rasterific.git - Tag: v0.2 - -library - hs-source-dirs: src - exposed-modules: Graphics.Rasterific - , Graphics.Rasterific.Texture - , Graphics.Rasterific.Transformations - - other-modules: Graphics.Rasterific.Line - , Graphics.Rasterific.QuadraticBezier - , Graphics.Rasterific.CubicBezier - , Graphics.Rasterific.Stroke - , Graphics.Rasterific.Operators - , Graphics.Rasterific.Rasterize - , Graphics.Rasterific.Types - , Graphics.Rasterific.Compositor - - ghc-options: -O2 -Wall - ghc-prof-options: -Wall -prof -auto-all - default-language: Haskell2010 - build-depends: base >= 4.6 && < 4.9 - , JuicyPixels >= 3.1.5 && < 3.2 - , linear >= 1.3.1 && < 1.9 - , free >= 4.5 && < 4.6 - , FontyFruity >= 0.2 && < 0.3 - , vector >= 0.9 - , mtl >= 2.1 - +-- Initial Rasterific.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ +name: Rasterific +version: 0.2.1 +synopsis: A pure haskell drawing engine. +-- A longer description of the package. +description: + <> + . + Rasterific is a vector drawing library (a rasterizer) + implemented in pure haskell + +license: BSD3 +license-file: LICENSE +author: Vincent Berthoux +maintainer: twinside@gmail.com + +-- A copyright notice. +-- copyright: +category: Graphics +build-type: Simple + +-- extra-source-files: + +cabal-version: >= 1.10 +extra-source-files: changelog, docimages/*.png +extra-doc-files: docimages/*.png + + +Source-Repository head + Type: git + Location: git://github.com/Twinside/Rasterific.git + +Source-Repository this + Type: git + Location: git://github.com/Twinside/Rasterific.git + Tag: v0.2.1 + +library + hs-source-dirs: src + exposed-modules: Graphics.Rasterific + , Graphics.Rasterific.Texture + , Graphics.Rasterific.Transformations + + other-modules: Graphics.Rasterific.Line + , Graphics.Rasterific.QuadraticBezier + , Graphics.Rasterific.CubicBezier + , Graphics.Rasterific.Stroke + , Graphics.Rasterific.Operators + , Graphics.Rasterific.Rasterize + , Graphics.Rasterific.Types + , Graphics.Rasterific.Compositor + + ghc-options: -O2 -Wall + ghc-prof-options: -Wall -prof -auto-all + default-language: Haskell2010 + build-depends: base >= 4.6 && < 4.9 + , JuicyPixels >= 3.1.5 && < 3.2 + , linear >= 1.3.1 && < 1.9 + , free >= 4.5 && < 4.7 + , FontyFruity >= 0.2 && < 0.3 + , vector >= 0.9 + , mtl >= 2.1 + diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,24 +1,29 @@ --*-change-log-*- - -v0.2 April 2014 - * Adding an ellipse helper. - * Adding a polyline helper. - * Adding a polygon helper. - * Adding monoid instance for Drawing. - * Fixing some stroking bug with cubic bezier curve. - * Fixing some documentation snippets. - * Adding a rounded rectangle helper. - * Added a even-odd filling rule. - * Added an offset for dashed stroking. - * Added a transformation module. - * Changed the Transformable typeclass, splitted - it in two. - * Added a dumping function for the constructed - drawing. - * Adding an image texture with bilinear filtering. - * Adding an image helper. - * Made some modest performance enhancements. - -v0.1 February 2014 - * Initial version. - +-*-change-log-*- + +v0.2.1 April 2014 + * Fixing transparency in gradients. + * Fixing alpha composition on top of translucent + background. + +v0.2 April 2014 + * Adding an ellipse helper. + * Adding a polyline helper. + * Adding a polygon helper. + * Adding monoid instance for Drawing. + * Fixing some stroking bug with cubic bezier curve. + * Fixing some documentation snippets. + * Adding a rounded rectangle helper. + * Added a even-odd filling rule. + * Added an offset for dashed stroking. + * Added a transformation module. + * Changed the Transformable typeclass, splitted + it in two. + * Added a dumping function for the constructed + drawing. + * Adding an image texture with bilinear filtering. + * Adding an image helper. + * Made some modest performance enhancements. + +v0.1 February 2014 + * Initial version. + 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/src/Graphics/Rasterific.hs b/src/Graphics/Rasterific.hs --- a/src/Graphics/Rasterific.hs +++ b/src/Graphics/Rasterific.hs @@ -1,753 +1,753 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} --- | Main module of Rasterific, an Haskell rasterization engine. --- --- Creating an image is rather simple, here is a simple example --- of a drawing and saving it in a PNG file: --- --- > import Codec.Picture( PixelRGBA8( .. ), writePng ) --- > import Graphics.Rasterific --- > import Graphics.Rasterific.Texture --- > --- > main :: IO () --- > main = do --- > let white = PixelRGBA8 255 255 255 255 --- > drawColor = PixelRGBA8 0 0x86 0xc1 255 --- > recColor = PixelRGBA8 0xFF 0x53 0x73 255 --- > img = renderDrawing 400 200 white $ --- > withTexture (uniformTexture drawColor) $ do --- > fill $ circle (V2 0 0) 30 --- > stroke 4 JoinRound (CapRound, CapRound) $ --- > circle (V2 400 200) 40 --- > withTexture (uniformTexture recColor) . --- > fill $ rectangle (V2 100 100) 200 100 --- > --- > writePng "yourimage.png" img --- --- <> --- --- The coordinate system is the picture classic one, with the origin in --- the upper left corner; with the y axis growing to the bottom and the --- x axis growing to the right: --- --- <> --- -module Graphics.Rasterific - ( - -- * Rasterization command - fill - , fillWithMethod - , withTexture - , withClipping - , withTransformation - , stroke - , dashedStroke - , dashedStrokeWithOffset - , printTextAt - - , renderDrawing - , pathToPrimitives - - -- * Rasterization types - , Texture - , Drawing - , Modulable - - -- * Geometry description - , V2( .. ) - , Point - , Vector - , CubicBezier( .. ) - , Line( .. ) - , Bezier( .. ) - , Primitive( .. ) - , Path( .. ) - , PathCommand( .. ) - , Transformable( .. ) - , PointFoldable( .. ) - - -- * Helpers - , line - , rectangle - , roundedRectangle - , circle - , ellipse - , polyline - , polygon - , drawImageAtSize - , drawImage - - -- ** Geometry Helpers - , clip - , bezierFromPath - , lineFromPath - , cubicBezierFromPath - - -- * Rasterization control - , Join( .. ) - , Cap( .. ) - , SamplerRepeat( .. ) - , FillMethod( .. ) - , DashPattern - - -- * Debugging helper - , dumpDrawing - - ) where - -import Control.Applicative( (<$>) ) -import Control.Monad( forM_ ) -import Control.Monad.Free( Free( .. ), liftF ) -import Control.Monad.ST( ST, runST ) -import Control.Monad.State( StateT, execStateT, get, lift ) -import Data.Monoid( Monoid( .. ), (<>) ) -import Codec.Picture.Types( Image( .. ) - , Pixel( .. ) - , Pixel8 - , PixelRGBA8 - , MutableImage( .. ) - , createMutableImage - , unsafeFreezeImage ) - -import qualified Data.Vector.Unboxed as VU -import Linear( V2( .. ), (^+^), (^*) ) - -import Graphics.Rasterific.Compositor -{-import Graphics.Rasterific.Operators-} -import Graphics.Rasterific.Rasterize -import Graphics.Rasterific.Texture -import Graphics.Rasterific.Types -import Graphics.Rasterific.Line -import Graphics.Rasterific.QuadraticBezier -import Graphics.Rasterific.CubicBezier -import Graphics.Rasterific.Stroke -import Graphics.Rasterific.Transformations - -import Graphics.Text.TrueType( Font, PointSize, getStringCurveAtPoint ) - -{-import Debug.Trace-} -{-import Text.Printf-} - --- | Monad used to describe the drawing context. -type DrawContext s px a = - StateT (MutableImage s px) (ST s) a - ------------------------------------------------- ----- Free Monad DSL section ------------------------------------------------- - --- | Monad used to record the drawing actions. -type Drawing px = Free (DrawCommand px) - -data DrawCommand px next - = Fill FillMethod [Primitive] next - | Stroke Float Join (Cap, Cap) [Primitive] next - | DashedStroke Float DashPattern Float Join (Cap, Cap) [Primitive] next - | TextFill Font PointSize Point String next - | SetTexture (Texture px) - (Drawing px ()) next - | WithCliping (forall innerPixel. Drawing innerPixel ()) - (Drawing px ()) next - | WithTransform Transformation (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) => Drawing px () -> String -dumpDrawing (Pure ()) = "return ()" -dumpDrawing (Free (Fill _ prims next)) = - "fill " ++ show prims ++ " >>=\n" ++ dumpDrawing next -dumpDrawing (Free (TextFill _ _ _ text next)) = - "-- Text : " ++ text ++ "\n" ++ dumpDrawing next -dumpDrawing (Free (SetTexture _tx drawing next)) = - "withTexture ({- texture -}) (" ++ - dumpDrawing drawing ++ ") >>=\n" ++ dumpDrawing next -dumpDrawing (Free (DashedStroke o pat w j cap prims next)) = - "dashedStrokeWithOffset " - ++ show o ++ " " - ++ show pat ++ " " - ++ show w ++ " (" - ++ show j ++ ") " - ++ show cap ++ " " - ++ show prims ++ " >>=\n" ++ dumpDrawing next -dumpDrawing (Free (Stroke w j cap prims next)) = - "stroke " ++ show w ++ " (" - ++ show j ++ ") " - ++ show cap ++ " " - ++ show prims ++ " >>=\n" ++ dumpDrawing next -dumpDrawing (Free (WithTransform trans sub next)) = - "withTransform (" ++ show trans ++ ") (" - ++ dumpDrawing sub ++ ") >>=\n " - ++ dumpDrawing next -dumpDrawing (Free (WithCliping clipping draw next)) = - "withClipping (" ++ dumpDrawing (withTexture clipTexture clipping) - ++ ")\n" ++ - " (" ++ dumpDrawing draw++ ")\n >>= " ++ - dumpDrawing next - where clipTexture = uniformTexture (0xFF :: Pixel8) - - -instance Functor (DrawCommand px) where - fmap f (TextFill font size pos str next) = - TextFill font size pos str $ 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 - -instance Monoid (Drawing px ()) where - mempty = return () - - mappend (Pure ()) b = b - mappend a (Pure ()) = a - mappend a b = a >> b - --- | Define the texture applyied to all the children --- draw call. --- --- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 255) $ do --- > fill $ circle (V2 50 50) 20 --- > fill $ circle (V2 100 100) 20 --- > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) --- > $ circle (V2 150 150) 20 --- --- <> --- -withTexture :: Texture px -> Drawing px () -> Drawing px () -withTexture texture subActions = - liftF $ SetTexture texture subActions () - --- | Draw all the sub drawing commands using a transformation. -withTransformation :: Transformation -> Drawing px () -> Drawing px () -withTransformation trans sub = - liftF $ WithTransform trans sub () - --- | Fill some geometry. The geometry should be "looping", --- ie. the last point of the last primitive should --- be equal to the first point of the first primitive. --- --- The primitive should be connected. --- --- > fill $ circle (V2 100 100) 75 --- --- <> --- -fill :: [Primitive] -> Drawing px () -fill prims = liftF $ Fill FillWinding prims () - --- | This function let you choose how to fill the primitives --- in case of self intersection. See `FillMethod` documentation --- for more information. -fillWithMethod :: FillMethod -> [Primitive] -> Drawing px () -fillWithMethod method prims = - liftF $ Fill method prims () - --- | Draw some geometry using a clipping path. --- --- > withClipping (fill $ circle (V2 100 100) 75) $ --- > mapM_ (stroke 7 JoinRound (CapRound, CapRound)) --- > [line (V2 0 yf) (V2 200 (yf + 10)) --- > | y <- [5 :: Int, 17 .. 200] --- > , let yf = fromIntegral y ] --- --- <> --- -withClipping - :: (forall innerPixel. Drawing innerPixel ()) -- ^ The clipping path - -> Drawing px () -- ^ The actual geometry to clip - -> Drawing px () -withClipping clipPath drawing = - liftF $ WithCliping clipPath drawing () - --- | Will stroke geometry with a given stroke width. --- The elements should be connected --- --- > stroke 5 JoinRound (CapRound, CapRound) $ circle (V2 100 100) 75 --- --- <> --- -stroke :: Float -- ^ Stroke width - -> Join -- ^ Which kind of join will be used - -> (Cap, Cap) -- ^ Start and end capping. - -> [Primitive] -- ^ List of elements to render - -> Drawing px () -stroke width join caping prims = - liftF $ Stroke width join caping prims () - --- | Draw a string at a given position. --- Text printing imply loading a font, there is no default --- font (yet). Below an example of font rendering using a --- font installed on Microsoft Windows. --- --- > import Graphics.Text.TrueType( loadFontFile ) --- > import Codec.Picture( PixelRGBA8( .. ), writePng ) --- > import Graphics.Rasterific --- > import Graphics.Rasterific.Texture --- > --- > main :: IO () --- > main = do --- > fontErr <- loadFontFile "C:/Windows/Fonts/arial.ttf" --- > case fontErr of --- > Left err -> putStrLn err --- > Right font -> --- > writePng "text_example.png" . --- > renderDrawing 300 70 (PixelRGBA8 255 255 255 255) --- > . withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ --- > printTextAt font 12 (V2 20 40) "A simple text test!" --- --- <> --- --- You can use any texture, like a gradient while rendering text. --- -printTextAt :: Font -- ^ Drawing font - -> Int -- ^ font Point size - -> Point -- ^ Baseline begining position - -> String -- ^ String to print - -> Drawing px () -printTextAt font pointSize point string = - liftF $ TextFill font pointSize point string () - -data RenderContext px = RenderContext - { currentClip :: Maybe (Texture (PixelBaseComponent px)) - , currentTexture :: Texture px - , currentTransformation :: Maybe (Transformation, Transformation) - } - --- | Function to call in order to start the image creation. --- Tested pixels type are PixelRGBA8 and Pixel8, pixel types --- in other colorspace will probably produce weird results. -renderDrawing - :: forall px - . ( Pixel px - , Pixel (PixelBaseComponent px) - , Modulable (PixelBaseComponent px) - , PixelBaseComponent (PixelBaseComponent px) ~ (PixelBaseComponent px) - ) - => Int -- ^ Rendering width - -> Int -- ^ Rendering height - -> px -- ^ Background color - -> Drawing px () -- ^ Rendering action - -> Image px -renderDrawing width height background drawing = runST $ - createMutableImage width height background - >>= execStateT (go initialContext drawing) - >>= unsafeFreezeImage - where - initialContext = RenderContext Nothing stupidDefaultTexture Nothing - clipBackground = emptyValue :: PixelBaseComponent px - clipForeground = fullValue :: PixelBaseComponent px - stupidDefaultTexture = - uniformTexture $ colorMap (const clipBackground) background - - clipRender = - renderDrawing width height clipBackground - . withTexture (uniformTexture clipForeground) - - textureOf ctxt@RenderContext { currentTransformation = Just (_, t) } = - transformTexture t $ currentTexture ctxt - textureOf ctxt = currentTexture ctxt - - geometryOf RenderContext { currentTransformation = Just (trans, _) } = - transform (applyTransformation trans) - geometryOf _ = id - - go :: RenderContext px - -> Drawing px () - -> DrawContext s px () - go _ (Pure ()) = return () - go ctxt (Free (WithTransform trans sub next)) = do - let trans' - | Just (t, _) <- currentTransformation ctxt = t <> trans - | otherwise = trans - go ctxt { currentTransformation = - Just (trans', inverseTransformation trans') } sub - go ctxt next - go ctxt@RenderContext { currentClip = Nothing } - (Free (Fill method prims next)) = do - fillWithTexture method (textureOf ctxt) $ geometryOf ctxt prims - go ctxt next - go ctxt@RenderContext { currentClip = Just moduler } - (Free (Fill method prims next)) = do - fillWithTextureAndMask method (currentTexture ctxt) - moduler $ geometryOf ctxt prims - go ctxt next - - go ctxt (Free (Stroke w j cap prims next)) = - go ctxt . Free $ Fill FillWinding prim' next - where prim' = strokize w j cap prims - go ctxt (Free (SetTexture tx sub next)) = do - go (ctxt { currentTexture = tx }) sub - go ctxt next - go ctxt (Free (DashedStroke o d w j cap prims next)) = do - let recurse sub = - go ctxt . liftF $ Fill FillWinding sub () - mapM_ recurse $ dashedStrokize o d w j cap prims - go ctxt next - - go ctxt (Free (TextFill font size (V2 x y) str next)) = do - forM_ drawCalls (go ctxt) - go ctxt next - where - drawCalls = - beziersOfChar <$> getStringCurveAtPoint 90 (x, y) - [(font, size, str)] - - beziersOfChar curves = liftF $ Fill FillWinding bezierCurves () - where - bezierCurves = concat - [map BezierPrim . bezierFromPath . map (uncurry V2) - $ VU.toList c | c <- curves] - - go ctxt (Free (WithCliping clipPath path next)) = do - go (ctxt { currentClip = newModuler }) path - go ctxt next - where - modulationTexture :: Texture (PixelBaseComponent px) - modulationTexture = imageTexture $ clipRender clipPath - - newModuler = Just . subModuler $ currentClip ctxt - - subModuler Nothing = modulationTexture - subModuler (Just v) = - modulateTexture v modulationTexture - --- | With stroke geometry with a given stroke width, using --- a dash pattern. --- --- > dashedStroke [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) --- > [line (V2 0 100) (V2 200 100)] --- --- <> --- -dashedStroke - :: DashPattern -- ^ Dashing pattern to use for stroking - -> Float -- ^ Stroke width - -> Join -- ^ Which kind of join will be used - -> (Cap, Cap) -- ^ Start and end capping. - -> [Primitive] -- ^ List of elements to render - -> Drawing px () -dashedStroke = dashedStrokeWithOffset 0.0 - --- | With stroke geometry with a given stroke width, using --- a dash pattern. The offset is there to specify the starting --- point into the pattern, the value can be negative. --- --- > dashedStrokeWithOffset 3 [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) --- > [line (V2 0 100) (V2 200 100)] --- --- <> --- -dashedStrokeWithOffset - :: Float -- ^ Starting offset - -> DashPattern -- ^ Dashing pattern to use for stroking - -> Float -- ^ Stroke width - -> Join -- ^ Which kind of join will be used - -> (Cap, Cap) -- ^ Start and end capping. - -> [Primitive] -- ^ List of elements to render - -> Drawing px () -dashedStrokeWithOffset _ [] width join caping prims = - stroke width join caping prims -dashedStrokeWithOffset offset dashing width join caping prims = - liftF $ DashedStroke offset dashing width join caping prims () - --- | Clip the geometry to a rectangle. -clip :: Point -- ^ Minimum point (corner upper left) - -> Point -- ^ Maximum point (corner bottom right) - -> Primitive -- ^ Primitive to be clipped - -> [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 - --- | Fill some geometry. The geometry should be "looping", --- ie. the last point of the last primitive should --- be equal to the first point of the first primitive. --- --- The primitive should be connected. -fillWithTexture :: (Pixel px, Modulable (PixelBaseComponent px)) - => FillMethod - -> Texture px -- ^ Color/Texture used for the filling - -> [Primitive] -- ^ Primitives to fill - -> DrawContext s px () -fillWithTexture fillMethod texture els = do - img@(MutableImage width height _) <- get - let mini = V2 0 0 - maxi = V2 (fromIntegral width) (fromIntegral height) - spans = rasterize fillMethod $ els >>= clip mini maxi - lift $ mapM_ (composeCoverageSpan texture img) spans - -fillWithTextureAndMask - :: ( Pixel px - , Pixel (PixelBaseComponent px) - , Modulable (PixelBaseComponent px)) - => FillMethod - -> Texture px -- ^ Color/Texture used for the filling - -> Texture (PixelBaseComponent px) - -> [Primitive] -- ^ Primitives to fill - -> DrawContext s 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 $ els >>= clip mini maxi - lift $ mapM_ (composeCoverageSpanWithMask texture mask img) spans - -composeCoverageSpan :: forall s px . - ( Pixel px, Modulable (PixelBaseComponent px) ) - => Texture px - -> MutableImage s px - -> CoverageSpan - -> ST s () -{-# SPECIALIZE - composeCoverageSpan - :: forall s. - Texture PixelRGBA8 - -> MutableImage s PixelRGBA8 - -> CoverageSpan -> ST s () #-} -{-# SPECIALIZE - composeCoverageSpan - :: forall s. - Texture Pixel8 - -> MutableImage s Pixel8 - -> CoverageSpan -> ST s () #-} -composeCoverageSpan texture img coverage - | initialCov == 0 || initialX < 0 || y < 0 || imgWidth < initialX || imgHeight < y = return () - | otherwise = go 0 initialX initIndex - where compCount = componentCount (undefined :: px) - maxi = _coverageLength coverage - imgData = mutableImageData img - y = floor $ _coverageY coverage - initialX = floor $ _coverageX coverage - imgWidth = mutableImageWidth img - imgHeight = mutableImageHeight img - initIndex = (initialX + y * imgWidth) * compCount - (initialCov, _) = - clampCoverage $ _coverageVal coverage - - shader = texture SamplerPad - - go count _ _ | count >= maxi = return () - go count x idx = do - oldPixel <- unsafeReadPixel imgData idx - let px = shader (fromIntegral x) (fromIntegral y) - opacity = pixelOpacity px - (cov, icov) = coverageModulate initialCov opacity - unsafeWritePixel imgData idx - $ compositionAlpha cov icov oldPixel px - - go (count + 1) (x + 1) $ idx + compCount - -composeCoverageSpanWithMask - :: forall s px - . ( Pixel px - , Pixel (PixelBaseComponent px) - , Modulable (PixelBaseComponent px) ) - => Texture px - -> Texture (PixelBaseComponent px) - -> MutableImage s px - -> CoverageSpan - -> ST s () -{-# INLINE composeCoverageSpanWithMask #-} -composeCoverageSpanWithMask texture mask img coverage - | initialCov == 0 || initialX < 0 || y < 0 || imgWidth < initialX || imgHeight < y = return () - | otherwise = go 0 initialX initIndex - where compCount = componentCount (undefined :: px) - maxi = _coverageLength coverage - imgData = mutableImageData img - y = floor $ _coverageY coverage - initialX = floor $ _coverageX coverage - imgWidth = mutableImageWidth img - imgHeight = mutableImageHeight img - initIndex = (initialX + y * imgWidth) * compCount - (initialCov, _) = - clampCoverage $ _coverageVal coverage - - maskShader = mask SamplerPad - shader = texture SamplerPad - - go count _ _ | count >= maxi = return () - go count x idx = do - oldPixel <- unsafeReadPixel imgData idx - let fx = fromIntegral x - fy = fromIntegral y - maskValue = maskShader fx fy - px = shader fx fy - (coeffMasked, _) = coverageModulate initialCov maskValue - (cov, icov) = coverageModulate coeffMasked $ pixelOpacity px - unsafeWritePixel imgData idx - $ compositionAlpha cov icov oldPixel px - go (count + 1) (x + 1) $ idx + compCount - - --- | 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 strokable line out of points list. --- Just an helper around `lineFromPath`. --- --- > stroke 4 JoinRound (CapRound, CapRound) $ --- > polyline [V2 10 10, V2 100 70, V2 190 190] --- --- <> --- -polyline :: [Point] -> [Primitive] -polyline = map LinePrim . lineFromPath - --- | Generate a fillable polygon out of points list. --- Similar to the `polyline` function, but close the --- path. --- --- > fill $ polygon [V2 30 30, V2 100 70, V2 80 170] --- --- <> --- -polygon :: [Point] -> [Primitive] -polygon [] = [] -polygon [_] = [] -polygon [_,_] = [] -polygon lst@(p:_) = polyline $ lst ++ [p] - --- | 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 ] - --- | Simply draw an image into the canvas. Take into account --- any previous transformation performed on the geometry. --- --- > drawImage textureImage 0 (V2 30 30) --- --- <> --- -drawImage :: (Pixel px, Modulable (PixelBaseComponent px)) - => Image px -- ^ Image to be drawn - -> StrokeWidth -- ^ Border size, drawn with current texture. - -> Point -- ^ Position of the corner upper left of the image. - -> Drawing px () -drawImage img@Image { imageWidth = w, imageHeight = h } s p = - drawImageAtSize img s p (fromIntegral w) (fromIntegral h) - --- | Draw an image with the desired size --- --- > drawImageAtSize textureImage 2 (V2 30 30) 128 128 --- --- <> --- -drawImageAtSize :: (Pixel px, Modulable (PixelBaseComponent px)) - => Image px -- ^ Image to be drawn - -> StrokeWidth -- ^ Border size, drawn with current texture. - -> Point -- ^ Position of the corner upper left of the image. - -> Float -- ^ Width of the drawn image - -> Float -- ^ Height of the drawn image - -> Drawing px () -drawImageAtSize img@Image { imageWidth = w, imageHeight = h } borderSize p - reqWidth reqHeight - | borderSize <= 0 = - withTransformation (translate p <> scale scaleX scaleY) . - withTexture (sampledImageTexture img) $ fill rect - | otherwise = do - withTransformation (translate p <> scale scaleX scaleY) $ do - withTexture (sampledImageTexture img) $ fill rect - stroke borderSize (JoinMiter 0) - (CapStraight 0, CapStraight 0) rect' - where - rect = rectangle (V2 0 0) rw rh - rect' = rectangle p reqWidth reqHeight - - (rw, rh) = (fromIntegral w, fromIntegral h) - scaleX | reqWidth == 0 = 1 - | otherwise = reqWidth / rw - - scaleY | reqHeight == 0 = 1 - | otherwise = reqHeight / rh - --- | 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 - --- | Return a simple line ready to be stroked. --- --- > stroke 17 JoinRound (CapRound, CapRound) $ --- > line (V2 10 10) (V2 180 170) --- --- <> --- -line :: Point -> Point -> [Primitive] -line p1 p2 = [LinePrim $ Line p1 p2] - +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +-- | Main module of Rasterific, an Haskell rasterization engine. +-- +-- Creating an image is rather simple, here is a simple example +-- of a drawing and saving it in a PNG file: +-- +-- > import Codec.Picture( PixelRGBA8( .. ), writePng ) +-- > import Graphics.Rasterific +-- > import Graphics.Rasterific.Texture +-- > +-- > main :: IO () +-- > main = do +-- > let white = PixelRGBA8 255 255 255 255 +-- > drawColor = PixelRGBA8 0 0x86 0xc1 255 +-- > recColor = PixelRGBA8 0xFF 0x53 0x73 255 +-- > img = renderDrawing 400 200 white $ +-- > withTexture (uniformTexture drawColor) $ do +-- > fill $ circle (V2 0 0) 30 +-- > stroke 4 JoinRound (CapRound, CapRound) $ +-- > circle (V2 400 200) 40 +-- > withTexture (uniformTexture recColor) . +-- > fill $ rectangle (V2 100 100) 200 100 +-- > +-- > writePng "yourimage.png" img +-- +-- <> +-- +-- The coordinate system is the picture classic one, with the origin in +-- the upper left corner; with the y axis growing to the bottom and the +-- x axis growing to the right: +-- +-- <> +-- +module Graphics.Rasterific + ( + -- * Rasterization command + fill + , fillWithMethod + , withTexture + , withClipping + , withTransformation + , stroke + , dashedStroke + , dashedStrokeWithOffset + , printTextAt + + , renderDrawing + , pathToPrimitives + + -- * Rasterization types + , Texture + , Drawing + , Modulable + + -- * Geometry description + , V2( .. ) + , Point + , Vector + , CubicBezier( .. ) + , Line( .. ) + , Bezier( .. ) + , Primitive( .. ) + , Path( .. ) + , PathCommand( .. ) + , Transformable( .. ) + , PointFoldable( .. ) + + -- * Helpers + , line + , rectangle + , roundedRectangle + , circle + , ellipse + , polyline + , polygon + , drawImageAtSize + , drawImage + + -- ** Geometry Helpers + , clip + , bezierFromPath + , lineFromPath + , cubicBezierFromPath + + -- * Rasterization control + , Join( .. ) + , Cap( .. ) + , SamplerRepeat( .. ) + , FillMethod( .. ) + , DashPattern + + -- * Debugging helper + , dumpDrawing + + ) where + +import Control.Applicative( (<$>) ) +import Control.Monad( forM_ ) +import Control.Monad.Free( Free( .. ), liftF ) +import Control.Monad.ST( ST, runST ) +import Control.Monad.State( StateT, execStateT, get, lift ) +import Data.Monoid( Monoid( .. ), (<>) ) +import Codec.Picture.Types( Image( .. ) + , Pixel( .. ) + , Pixel8 + , PixelRGBA8 + , MutableImage( .. ) + , createMutableImage + , unsafeFreezeImage ) + +import qualified Data.Vector.Unboxed as VU +import Linear( V2( .. ), (^+^), (^*) ) + +import Graphics.Rasterific.Compositor +{-import Graphics.Rasterific.Operators-} +import Graphics.Rasterific.Rasterize +import Graphics.Rasterific.Texture +import Graphics.Rasterific.Types +import Graphics.Rasterific.Line +import Graphics.Rasterific.QuadraticBezier +import Graphics.Rasterific.CubicBezier +import Graphics.Rasterific.Stroke +import Graphics.Rasterific.Transformations + +import Graphics.Text.TrueType( Font, PointSize, getStringCurveAtPoint ) + +{-import Debug.Trace-} +{-import Text.Printf-} + +-- | Monad used to describe the drawing context. +type DrawContext s px a = + StateT (MutableImage s px) (ST s) a + +------------------------------------------------ +---- Free Monad DSL section +------------------------------------------------ + +-- | Monad used to record the drawing actions. +type Drawing px = Free (DrawCommand px) + +data DrawCommand px next + = Fill FillMethod [Primitive] next + | Stroke Float Join (Cap, Cap) [Primitive] next + | DashedStroke Float DashPattern Float Join (Cap, Cap) [Primitive] next + | TextFill Font PointSize Point String next + | SetTexture (Texture px) + (Drawing px ()) next + | WithCliping (forall innerPixel. Drawing innerPixel ()) + (Drawing px ()) next + | WithTransform Transformation (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) => Drawing px () -> String +dumpDrawing (Pure ()) = "return ()" +dumpDrawing (Free (Fill _ prims next)) = + "fill " ++ show prims ++ " >>=\n" ++ dumpDrawing next +dumpDrawing (Free (TextFill _ _ _ text next)) = + "-- Text : " ++ text ++ "\n" ++ dumpDrawing next +dumpDrawing (Free (SetTexture _tx drawing next)) = + "withTexture ({- texture -}) (" ++ + dumpDrawing drawing ++ ") >>=\n" ++ dumpDrawing next +dumpDrawing (Free (DashedStroke o pat w j cap prims next)) = + "dashedStrokeWithOffset " + ++ show o ++ " " + ++ show pat ++ " " + ++ show w ++ " (" + ++ show j ++ ") " + ++ show cap ++ " " + ++ show prims ++ " >>=\n" ++ dumpDrawing next +dumpDrawing (Free (Stroke w j cap prims next)) = + "stroke " ++ show w ++ " (" + ++ show j ++ ") " + ++ show cap ++ " " + ++ show prims ++ " >>=\n" ++ dumpDrawing next +dumpDrawing (Free (WithTransform trans sub next)) = + "withTransform (" ++ show trans ++ ") (" + ++ dumpDrawing sub ++ ") >>=\n " + ++ dumpDrawing next +dumpDrawing (Free (WithCliping clipping draw next)) = + "withClipping (" ++ dumpDrawing (withTexture clipTexture clipping) + ++ ")\n" ++ + " (" ++ dumpDrawing draw++ ")\n >>= " ++ + dumpDrawing next + where clipTexture = uniformTexture (0xFF :: Pixel8) + + +instance Functor (DrawCommand px) where + fmap f (TextFill font size pos str next) = + TextFill font size pos str $ 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 + +instance Monoid (Drawing px ()) where + mempty = return () + + mappend (Pure ()) b = b + mappend a (Pure ()) = a + mappend a b = a >> b + +-- | Define the texture applyied to all the children +-- draw call. +-- +-- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 255) $ do +-- > fill $ circle (V2 50 50) 20 +-- > fill $ circle (V2 100 100) 20 +-- > withTexture (uniformTexture $ PixelRGBA8 0xFF 0x53 0x73 255) +-- > $ circle (V2 150 150) 20 +-- +-- <> +-- +withTexture :: Texture px -> Drawing px () -> Drawing px () +withTexture texture subActions = + liftF $ SetTexture texture subActions () + +-- | Draw all the sub drawing commands using a transformation. +withTransformation :: Transformation -> Drawing px () -> Drawing px () +withTransformation trans sub = + liftF $ WithTransform trans sub () + +-- | Fill some geometry. The geometry should be "looping", +-- ie. the last point of the last primitive should +-- be equal to the first point of the first primitive. +-- +-- The primitive should be connected. +-- +-- > fill $ circle (V2 100 100) 75 +-- +-- <> +-- +fill :: [Primitive] -> Drawing px () +fill prims = liftF $ Fill FillWinding prims () + +-- | This function let you choose how to fill the primitives +-- in case of self intersection. See `FillMethod` documentation +-- for more information. +fillWithMethod :: FillMethod -> [Primitive] -> Drawing px () +fillWithMethod method prims = + liftF $ Fill method prims () + +-- | Draw some geometry using a clipping path. +-- +-- > withClipping (fill $ circle (V2 100 100) 75) $ +-- > mapM_ (stroke 7 JoinRound (CapRound, CapRound)) +-- > [line (V2 0 yf) (V2 200 (yf + 10)) +-- > | y <- [5 :: Int, 17 .. 200] +-- > , let yf = fromIntegral y ] +-- +-- <> +-- +withClipping + :: (forall innerPixel. Drawing innerPixel ()) -- ^ The clipping path + -> Drawing px () -- ^ The actual geometry to clip + -> Drawing px () +withClipping clipPath drawing = + liftF $ WithCliping clipPath drawing () + +-- | Will stroke geometry with a given stroke width. +-- The elements should be connected +-- +-- > stroke 5 JoinRound (CapRound, CapRound) $ circle (V2 100 100) 75 +-- +-- <> +-- +stroke :: Float -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> [Primitive] -- ^ List of elements to render + -> Drawing px () +stroke width join caping prims = + liftF $ Stroke width join caping prims () + +-- | Draw a string at a given position. +-- Text printing imply loading a font, there is no default +-- font (yet). Below an example of font rendering using a +-- font installed on Microsoft Windows. +-- +-- > import Graphics.Text.TrueType( loadFontFile ) +-- > import Codec.Picture( PixelRGBA8( .. ), writePng ) +-- > import Graphics.Rasterific +-- > import Graphics.Rasterific.Texture +-- > +-- > main :: IO () +-- > main = do +-- > fontErr <- loadFontFile "C:/Windows/Fonts/arial.ttf" +-- > case fontErr of +-- > Left err -> putStrLn err +-- > Right font -> +-- > writePng "text_example.png" . +-- > renderDrawing 300 70 (PixelRGBA8 255 255 255 255) +-- > . withTexture (uniformTexture $ PixelRGBA8 0 0 0 255) $ +-- > printTextAt font 12 (V2 20 40) "A simple text test!" +-- +-- <> +-- +-- You can use any texture, like a gradient while rendering text. +-- +printTextAt :: Font -- ^ Drawing font + -> Int -- ^ font Point size + -> Point -- ^ Baseline begining position + -> String -- ^ String to print + -> Drawing px () +printTextAt font pointSize point string = + liftF $ TextFill font pointSize point string () + +data RenderContext px = RenderContext + { currentClip :: Maybe (Texture (PixelBaseComponent px)) + , currentTexture :: Texture px + , currentTransformation :: Maybe (Transformation, Transformation) + } + +-- | Function to call in order to start the image creation. +-- Tested pixels type are PixelRGBA8 and Pixel8, pixel types +-- in other colorspace will probably produce weird results. +renderDrawing + :: forall px + . ( Pixel px + , Pixel (PixelBaseComponent px) + , Modulable (PixelBaseComponent px) + , PixelBaseComponent (PixelBaseComponent px) ~ (PixelBaseComponent px) + ) + => Int -- ^ Rendering width + -> Int -- ^ Rendering height + -> px -- ^ Background color + -> Drawing px () -- ^ Rendering action + -> Image px +renderDrawing width height background drawing = runST $ + createMutableImage width height background + >>= execStateT (go initialContext drawing) + >>= unsafeFreezeImage + where + initialContext = RenderContext Nothing stupidDefaultTexture Nothing + clipBackground = emptyValue :: PixelBaseComponent px + clipForeground = fullValue :: PixelBaseComponent px + stupidDefaultTexture = + uniformTexture $ colorMap (const clipBackground) background + + clipRender = + renderDrawing width height clipBackground + . withTexture (uniformTexture clipForeground) + + textureOf ctxt@RenderContext { currentTransformation = Just (_, t) } = + transformTexture t $ currentTexture ctxt + textureOf ctxt = currentTexture ctxt + + geometryOf RenderContext { currentTransformation = Just (trans, _) } = + transform (applyTransformation trans) + geometryOf _ = id + + go :: RenderContext px + -> Drawing px () + -> DrawContext s px () + go _ (Pure ()) = return () + go ctxt (Free (WithTransform trans sub next)) = do + let trans' + | Just (t, _) <- currentTransformation ctxt = t <> trans + | otherwise = trans + go ctxt { currentTransformation = + Just (trans', inverseTransformation trans') } sub + go ctxt next + go ctxt@RenderContext { currentClip = Nothing } + (Free (Fill method prims next)) = do + fillWithTexture method (textureOf ctxt) $ geometryOf ctxt prims + go ctxt next + go ctxt@RenderContext { currentClip = Just moduler } + (Free (Fill method prims next)) = do + fillWithTextureAndMask method (currentTexture ctxt) + moduler $ geometryOf ctxt prims + go ctxt next + + go ctxt (Free (Stroke w j cap prims next)) = + go ctxt . Free $ Fill FillWinding prim' next + where prim' = strokize w j cap prims + go ctxt (Free (SetTexture tx sub next)) = do + go (ctxt { currentTexture = tx }) sub + go ctxt next + go ctxt (Free (DashedStroke o d w j cap prims next)) = do + let recurse sub = + go ctxt . liftF $ Fill FillWinding sub () + mapM_ recurse $ dashedStrokize o d w j cap prims + go ctxt next + + go ctxt (Free (TextFill font size (V2 x y) str next)) = do + forM_ drawCalls (go ctxt) + go ctxt next + where + drawCalls = + beziersOfChar <$> getStringCurveAtPoint 90 (x, y) + [(font, size, str)] + + beziersOfChar curves = liftF $ Fill FillWinding bezierCurves () + where + bezierCurves = concat + [map BezierPrim . bezierFromPath . map (uncurry V2) + $ VU.toList c | c <- curves] + + go ctxt (Free (WithCliping clipPath path next)) = do + go (ctxt { currentClip = newModuler }) path + go ctxt next + where + modulationTexture :: Texture (PixelBaseComponent px) + modulationTexture = imageTexture $ clipRender clipPath + + newModuler = Just . subModuler $ currentClip ctxt + + subModuler Nothing = modulationTexture + subModuler (Just v) = + modulateTexture v modulationTexture + +-- | With stroke geometry with a given stroke width, using +-- a dash pattern. +-- +-- > dashedStroke [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) +-- > [line (V2 0 100) (V2 200 100)] +-- +-- <> +-- +dashedStroke + :: DashPattern -- ^ Dashing pattern to use for stroking + -> Float -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> [Primitive] -- ^ List of elements to render + -> Drawing px () +dashedStroke = dashedStrokeWithOffset 0.0 + +-- | With stroke geometry with a given stroke width, using +-- a dash pattern. The offset is there to specify the starting +-- point into the pattern, the value can be negative. +-- +-- > dashedStrokeWithOffset 3 [5, 10, 5] 3 JoinRound (CapRound, CapStraight 0) +-- > [line (V2 0 100) (V2 200 100)] +-- +-- <> +-- +dashedStrokeWithOffset + :: Float -- ^ Starting offset + -> DashPattern -- ^ Dashing pattern to use for stroking + -> Float -- ^ Stroke width + -> Join -- ^ Which kind of join will be used + -> (Cap, Cap) -- ^ Start and end capping. + -> [Primitive] -- ^ List of elements to render + -> Drawing px () +dashedStrokeWithOffset _ [] width join caping prims = + stroke width join caping prims +dashedStrokeWithOffset offset dashing width join caping prims = + liftF $ DashedStroke offset dashing width join caping prims () + +-- | Clip the geometry to a rectangle. +clip :: Point -- ^ Minimum point (corner upper left) + -> Point -- ^ Maximum point (corner bottom right) + -> Primitive -- ^ Primitive to be clipped + -> [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 + +-- | Fill some geometry. The geometry should be "looping", +-- ie. the last point of the last primitive should +-- be equal to the first point of the first primitive. +-- +-- The primitive should be connected. +fillWithTexture :: (Pixel px, Modulable (PixelBaseComponent px)) + => FillMethod + -> Texture px -- ^ Color/Texture used for the filling + -> [Primitive] -- ^ Primitives to fill + -> DrawContext s px () +fillWithTexture fillMethod texture els = do + img@(MutableImage width height _) <- get + let mini = V2 0 0 + maxi = V2 (fromIntegral width) (fromIntegral height) + spans = rasterize fillMethod $ els >>= clip mini maxi + lift $ mapM_ (composeCoverageSpan texture img) spans + +fillWithTextureAndMask + :: ( Pixel px + , Pixel (PixelBaseComponent px) + , Modulable (PixelBaseComponent px)) + => FillMethod + -> Texture px -- ^ Color/Texture used for the filling + -> Texture (PixelBaseComponent px) + -> [Primitive] -- ^ Primitives to fill + -> DrawContext s 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 $ els >>= clip mini maxi + lift $ mapM_ (composeCoverageSpanWithMask texture mask img) spans + +composeCoverageSpan :: forall s px . + ( Pixel px, Modulable (PixelBaseComponent px) ) + => Texture px + -> MutableImage s px + -> CoverageSpan + -> ST s () +{-# SPECIALIZE + composeCoverageSpan + :: forall s. + Texture PixelRGBA8 + -> MutableImage s PixelRGBA8 + -> CoverageSpan -> ST s () #-} +{-# SPECIALIZE + composeCoverageSpan + :: forall s. + Texture Pixel8 + -> MutableImage s Pixel8 + -> CoverageSpan -> ST s () #-} +composeCoverageSpan texture img coverage + | initialCov == 0 || initialX < 0 || y < 0 || imgWidth < initialX || imgHeight < y = return () + | otherwise = go 0 initialX initIndex + where compCount = componentCount (undefined :: px) + maxi = _coverageLength coverage + imgData = mutableImageData img + y = floor $ _coverageY coverage + initialX = floor $ _coverageX coverage + imgWidth = mutableImageWidth img + imgHeight = mutableImageHeight img + initIndex = (initialX + y * imgWidth) * compCount + (initialCov, _) = + clampCoverage $ _coverageVal coverage + + shader = texture SamplerPad + + go count _ _ | count >= maxi = return () + go count x idx = do + oldPixel <- unsafeReadPixel imgData idx + let px = shader (fromIntegral x) (fromIntegral y) + opacity = pixelOpacity px + (cov, icov) = coverageModulate initialCov opacity + unsafeWritePixel imgData idx + $ compositionAlpha cov icov oldPixel px + + go (count + 1) (x + 1) $ idx + compCount + +composeCoverageSpanWithMask + :: forall s px + . ( Pixel px + , Pixel (PixelBaseComponent px) + , Modulable (PixelBaseComponent px) ) + => Texture px + -> Texture (PixelBaseComponent px) + -> MutableImage s px + -> CoverageSpan + -> ST s () +{-# INLINE composeCoverageSpanWithMask #-} +composeCoverageSpanWithMask texture mask img coverage + | initialCov == 0 || initialX < 0 || y < 0 || imgWidth < initialX || imgHeight < y = return () + | otherwise = go 0 initialX initIndex + where compCount = componentCount (undefined :: px) + maxi = _coverageLength coverage + imgData = mutableImageData img + y = floor $ _coverageY coverage + initialX = floor $ _coverageX coverage + imgWidth = mutableImageWidth img + imgHeight = mutableImageHeight img + initIndex = (initialX + y * imgWidth) * compCount + (initialCov, _) = + clampCoverage $ _coverageVal coverage + + maskShader = mask SamplerPad + shader = texture SamplerPad + + go count _ _ | count >= maxi = return () + go count x idx = do + oldPixel <- unsafeReadPixel imgData idx + let fx = fromIntegral x + fy = fromIntegral y + maskValue = maskShader fx fy + px = shader fx fy + (coeffMasked, _) = coverageModulate initialCov maskValue + (cov, icov) = coverageModulate coeffMasked $ pixelOpacity px + unsafeWritePixel imgData idx + $ compositionAlpha cov icov oldPixel px + go (count + 1) (x + 1) $ idx + compCount + + +-- | 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 strokable line out of points list. +-- Just an helper around `lineFromPath`. +-- +-- > stroke 4 JoinRound (CapRound, CapRound) $ +-- > polyline [V2 10 10, V2 100 70, V2 190 190] +-- +-- <> +-- +polyline :: [Point] -> [Primitive] +polyline = map LinePrim . lineFromPath + +-- | Generate a fillable polygon out of points list. +-- Similar to the `polyline` function, but close the +-- path. +-- +-- > fill $ polygon [V2 30 30, V2 100 70, V2 80 170] +-- +-- <> +-- +polygon :: [Point] -> [Primitive] +polygon [] = [] +polygon [_] = [] +polygon [_,_] = [] +polygon lst@(p:_) = polyline $ lst ++ [p] + +-- | 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 ] + +-- | Simply draw an image into the canvas. Take into account +-- any previous transformation performed on the geometry. +-- +-- > drawImage textureImage 0 (V2 30 30) +-- +-- <> +-- +drawImage :: (Pixel px, Modulable (PixelBaseComponent px)) + => Image px -- ^ Image to be drawn + -> StrokeWidth -- ^ Border size, drawn with current texture. + -> Point -- ^ Position of the corner upper left of the image. + -> Drawing px () +drawImage img@Image { imageWidth = w, imageHeight = h } s p = + drawImageAtSize img s p (fromIntegral w) (fromIntegral h) + +-- | Draw an image with the desired size +-- +-- > drawImageAtSize textureImage 2 (V2 30 30) 128 128 +-- +-- <> +-- +drawImageAtSize :: (Pixel px, Modulable (PixelBaseComponent px)) + => Image px -- ^ Image to be drawn + -> StrokeWidth -- ^ Border size, drawn with current texture. + -> Point -- ^ Position of the corner upper left of the image. + -> Float -- ^ Width of the drawn image + -> Float -- ^ Height of the drawn image + -> Drawing px () +drawImageAtSize img@Image { imageWidth = w, imageHeight = h } borderSize p + reqWidth reqHeight + | borderSize <= 0 = + withTransformation (translate p <> scale scaleX scaleY) . + withTexture (sampledImageTexture img) $ fill rect + | otherwise = do + withTransformation (translate p <> scale scaleX scaleY) $ do + withTexture (sampledImageTexture img) $ fill rect + stroke borderSize (JoinMiter 0) + (CapStraight 0, CapStraight 0) rect' + where + rect = rectangle (V2 0 0) rw rh + rect' = rectangle p reqWidth reqHeight + + (rw, rh) = (fromIntegral w, fromIntegral h) + scaleX | reqWidth == 0 = 1 + | otherwise = reqWidth / rw + + scaleY | reqHeight == 0 = 1 + | otherwise = reqHeight / rh + +-- | 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 + +-- | Return a simple line ready to be stroked. +-- +-- > stroke 17 JoinRound (CapRound, CapRound) $ +-- > line (V2 10 10) (V2 180 170) +-- +-- <> +-- +line :: Point -> Point -> [Primitive] +line p1 p2 = [LinePrim $ Line p1 p2] + 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,75 +1,112 @@ -{-# LANGUAGE FlexibleContexts #-} --- | Compositor handle the pixel composition, which --- leads to texture composition. --- Very much a work in progress -module Graphics.Rasterific.Compositor - ( Compositor - , Modulable( .. ) - , compositionDestination - , compositionAlpha - ) where - -import Data.Bits( unsafeShiftR ) -import Data.Word( Word8, Word32 ) - -import Codec.Picture.Types( Pixel( .. ) ) - -type Compositor px = - (PixelBaseComponent px) -> - (PixelBaseComponent px) -> px -> px -> px - --- | Typeclass intented at pixel value modulation. --- May be throwed out soon. -class (Ord a, Num a) => Modulable a where - emptyValue :: a - fullValue :: a - clampCoverage :: Float -> (a, a) - modulate :: a -> a -> a - alphaOver :: a -> a -> a -> a -> a - alphaCompose :: a -> a -> a -> a -> a - coverageModulate :: a -> a -> (a, a) - -instance Modulable Word8 where - emptyValue = 0 - fullValue = 255 - clampCoverage f = (fromIntegral c, fromIntegral $ 255 - c) - where c = toWord8 f - - modulate c a = fromIntegral $ (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 - where fi :: Word8 -> Word32 - fi = fromIntegral - v = fi c * fi a + 128 - - coverageModulate c a = (clamped, fullValue - clamped) - where clamped = modulate a c - - alphaCompose coverage inverseCoverage backgroundAlpha _ = - fromIntegral $ (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 - where fi :: Word8 -> Word32 - fi = fromIntegral - v = fi coverage * 255 - + fi backgroundAlpha * fi inverseCoverage + 128 - - alphaOver coverage inverseCoverage background painted = - fromIntegral $ (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 - where fi :: Word8 -> Word32 - fi = fromIntegral - v = fi coverage * fi painted + fi background * fi inverseCoverage + 128 - - -toWord8 :: Float -> Int -toWord8 r = floor $ r * 255 + 0.5 - -compositionDestination :: (Pixel px, Modulable (PixelBaseComponent px)) - => Compositor px -compositionDestination c _ _ a = colorMap (modulate c) $ a - -compositionAlpha :: (Pixel px, Modulable (PixelBaseComponent px)) - => Compositor px -{-# INLINE compositionAlpha #-} -compositionAlpha c ic - | c == emptyValue = const - | c == fullValue = \_ n -> n - | otherwise = mixWithAlpha (\_ -> alphaOver c ic) - (alphaCompose c ic) - +{-# LANGUAGE FlexibleContexts #-} +-- | Compositor handle the pixel composition, which +-- leads to texture composition. +-- Very much a work in progress +module Graphics.Rasterific.Compositor + ( Compositor + , Modulable( .. ) + , compositionDestination + , compositionAlpha + ) where + +import Data.Bits( unsafeShiftR ) +import Data.Word( Word8, Word32 ) + +import Codec.Picture.Types( Pixel( .. ) ) + +type Compositor px = + (PixelBaseComponent px) -> + (PixelBaseComponent px) -> px -> px -> 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) + 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 + +instance Modulable Word8 where + emptyValue = 0 + fullValue = 255 + clampCoverage f = (fromIntegral c, fromIntegral $ 255 - c) + where c = toWord8 f + + modulate c a = fromIntegral $ (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 + where fi :: Word8 -> Word32 + fi = fromIntegral + v = fi c * fi a + 128 + + modiv c 0 = c + modiv c a = fromIntegral . min 255 $ (fi c * 255) `div` fi a + where fi :: Word8 -> Word32 + fi = fromIntegral + + alphaCompose coverage inverseCoverage backgroundAlpha _ = + fromIntegral $ (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 + where fi :: Word8 -> Word32 + fi = fromIntegral + v = fi coverage * 255 + + fi backgroundAlpha * fi inverseCoverage + 128 + + alphaOver coverage inverseCoverage background painted = + fromIntegral $ (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 + where fi :: Word8 -> Word32 + fi = fromIntegral + v = fi coverage * fi painted + fi background * fi inverseCoverage + 128 + + +toWord8 :: Float -> Int +toWord8 r = floor $ r * 255 + 0.5 + +compositionDestination :: (Pixel px, Modulable (PixelBaseComponent px)) + => Compositor px +compositionDestination c _ _ a = colorMap (modulate c) $ a + +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 + 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,287 +1,287 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Graphics.Rasterific.CubicBezier - ( cubicBezierCircle - , cubicBezierFromPath - , cubicBezierBreakAt - , clipCubicBezier - , decomposeCubicBeziers - , sanitizeCubicBezier - , offsetCubicBezier - , flattenCubicBezier - , cubicBezierLengthApproximation - ) where - -import Prelude hiding( or ) -import Control.Applicative( Applicative - , liftA2 - , (<$>) - , (<*>) - , pure - ) -import Linear( V1( .. ) - , V2( .. ) - , (^-^) - , (^+^) - , (^*) - , norm - ) -import Data.Monoid( Monoid, mempty, (<>) ) -import Graphics.Rasterific.Operators -import Graphics.Rasterific.Types -import Graphics.Rasterific.QuadraticBezier( sanitizeBezier ) - --- | 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 - -flattenCubicBezier :: CubicBezier -> Container Primitive -flattenCubicBezier bezier@(CubicBezier a b c d) - | isSufficientlyFlat 1 bezier = pure $ CubicBezierPrim bezier - | otherwise = - flattenCubicBezier (CubicBezier a ab abbc abbcbccd) <> - flattenCubicBezier (CubicBezier abbcbccd bccd cd d) - 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 - - --- 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 - -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 = a `midPoint` b - bc = b `midPoint` c - cd = c `midPoint` d - - w = ab `normal` bc - x = bc `normal` cd - - abbc = ab `midPoint` bc - bccd = bc `midPoint` cd - abbcbccd = abbc `midPoint` bccd - - 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 $ vmin 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 = a `midPoint` b - bc = b `midPoint` c - cd = c `midPoint` d - - abbc = ab `midPoint` bc - bccd = bc `midPoint` cd - abbcbccd = abbc `midPoint` bccd - - edgeSeparator = vabs (abbcbccd ^-^ mini) ^<^ vabs (abbcbccd ^-^ maxi) - edge = vpartition edgeSeparator mini maxi - m = vpartition (vabs (abbcbccd ^-^ edge) ^< 0.1) edge abbcbccd - --- | 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 = lerpPoint a b val - bc = lerpPoint b c val - cd = lerpPoint c d val - - abbc = lerpPoint ab bc val - bccd = lerpPoint bc cd val - abbcbccd = lerpPoint abbc bccd val - -decomposeCubicBeziers :: CubicBezier -> Container EdgeSample -decomposeCubicBeziers (CubicBezier a@(V2 ax ay) b c d@(V2 dx dy)) - | insideX && insideY = - pure $ EdgeSample (px + 0.5) (py + 0.5) (w * h) h - | otherwise = - recurse (CubicBezier a ab abbc m) <> - recurse (CubicBezier m bccd cd d) - where recurse = decomposeCubicBeziers - floorA = vfloor a - floorD = vfloor d - V2 px py = fromIntegral <$> vmin floorA floorD - V1 w = (px + 1 -) <$> (V1 dx `midPoint` V1 ax) - h = dy - ay - - V2 insideX insideY = - floorA ^==^ floorD ^||^ vceil a ^==^ vceil d - - -- BC - -- B X----------X---------X C - -- / ___/ \___ \ - -- / __X------X------X_ \ - -- /___/ 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 - - mini = fromIntegral <$> vfloor abbcbccd - maxi = fromIntegral <$> vceil abbcbccd - nearmin = vabs (abbcbccd ^-^ mini) ^< 0.1 - nearmax = vabs (abbcbccd ^-^ maxi) ^< 0.1 - - minMaxing mi nearmi ma nearma p - | nearmi = mi - | nearma = ma - | otherwise = p - - m = minMaxing <$> mini <*> nearmin <*> maxi <*> nearmax - <*> abbcbccd - -sanitizeCubicBezier :: CubicBezier -> Container Primitive -sanitizeCubicBezier bezier@(CubicBezier a b c d) - | b `isNearby` c = sanitizeBezier $ Bezier a c d - | a `isDistingableFrom` b && - c `isDistingableFrom` d = - pure . CubicBezierPrim $ bezier - | ac `isDistingableFrom` b && - bd `isDistingableFrom` c = - pure . CubicBezierPrim $ CubicBezier a ac bd d - | 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 - +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Graphics.Rasterific.CubicBezier + ( cubicBezierCircle + , cubicBezierFromPath + , cubicBezierBreakAt + , clipCubicBezier + , decomposeCubicBeziers + , sanitizeCubicBezier + , offsetCubicBezier + , flattenCubicBezier + , cubicBezierLengthApproximation + ) where + +import Prelude hiding( or ) +import Control.Applicative( Applicative + , liftA2 + , (<$>) + , (<*>) + , pure + ) +import Linear( V1( .. ) + , V2( .. ) + , (^-^) + , (^+^) + , (^*) + , norm + ) +import Data.Monoid( Monoid, mempty, (<>) ) +import Graphics.Rasterific.Operators +import Graphics.Rasterific.Types +import Graphics.Rasterific.QuadraticBezier( sanitizeBezier ) + +-- | 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 + +flattenCubicBezier :: CubicBezier -> Container Primitive +flattenCubicBezier bezier@(CubicBezier a b c d) + | isSufficientlyFlat 1 bezier = pure $ CubicBezierPrim bezier + | otherwise = + flattenCubicBezier (CubicBezier a ab abbc abbcbccd) <> + flattenCubicBezier (CubicBezier abbcbccd bccd cd d) + 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 + + +-- 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 + +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 = a `midPoint` b + bc = b `midPoint` c + cd = c `midPoint` d + + w = ab `normal` bc + x = bc `normal` cd + + abbc = ab `midPoint` bc + bccd = bc `midPoint` cd + abbcbccd = abbc `midPoint` bccd + + 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 $ vmin 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 = a `midPoint` b + bc = b `midPoint` c + cd = c `midPoint` d + + abbc = ab `midPoint` bc + bccd = bc `midPoint` cd + abbcbccd = abbc `midPoint` bccd + + edgeSeparator = vabs (abbcbccd ^-^ mini) ^<^ vabs (abbcbccd ^-^ maxi) + edge = vpartition edgeSeparator mini maxi + m = vpartition (vabs (abbcbccd ^-^ edge) ^< 0.1) edge abbcbccd + +-- | 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 = lerpPoint a b val + bc = lerpPoint b c val + cd = lerpPoint c d val + + abbc = lerpPoint ab bc val + bccd = lerpPoint bc cd val + abbcbccd = lerpPoint abbc bccd val + +decomposeCubicBeziers :: CubicBezier -> Container EdgeSample +decomposeCubicBeziers (CubicBezier a@(V2 ax ay) b c d@(V2 dx dy)) + | insideX && insideY = + pure $ EdgeSample (px + 0.5) (py + 0.5) (w * h) h + | otherwise = + recurse (CubicBezier a ab abbc m) <> + recurse (CubicBezier m bccd cd d) + where recurse = decomposeCubicBeziers + floorA = vfloor a + floorD = vfloor d + V2 px py = fromIntegral <$> vmin floorA floorD + V1 w = (px + 1 -) <$> (V1 dx `midPoint` V1 ax) + h = dy - ay + + V2 insideX insideY = + floorA ^==^ floorD ^||^ vceil a ^==^ vceil d + + -- BC + -- B X----------X---------X C + -- / ___/ \___ \ + -- / __X------X------X_ \ + -- /___/ 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 + + mini = fromIntegral <$> vfloor abbcbccd + maxi = fromIntegral <$> vceil abbcbccd + nearmin = vabs (abbcbccd ^-^ mini) ^< 0.1 + nearmax = vabs (abbcbccd ^-^ maxi) ^< 0.1 + + minMaxing mi nearmi ma nearma p + | nearmi = mi + | nearma = ma + | otherwise = p + + m = minMaxing <$> mini <*> nearmin <*> maxi <*> nearmax + <*> abbcbccd + +sanitizeCubicBezier :: CubicBezier -> Container Primitive +sanitizeCubicBezier bezier@(CubicBezier a b c d) + | b `isNearby` c = sanitizeBezier $ Bezier a c d + | a `isDistingableFrom` b && + c `isDistingableFrom` d = + pure . CubicBezierPrim $ bezier + | ac `isDistingableFrom` b && + bd `isDistingableFrom` c = + pure . CubicBezierPrim $ CubicBezier a ac bd d + | 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 + 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,100 +1,100 @@ --- | Handle straight lines polygon. -module Graphics.Rasterific.Line - ( lineFromPath - , clipLine - , sanitizeLine - , lineBreakAt - , flattenLine - , lineLength - ) where - -import Control.Applicative( Applicative, (<$>), pure ) -import Data.Monoid( Monoid, (<>), mempty ) -import Linear( V2( .. ), (^-^), 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 - -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 = lerpPoint a b t - -flattenLine :: Line -> Container Primitive -flattenLine = pure . LinePrim - --- | 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 - +-- | Handle straight lines polygon. +module Graphics.Rasterific.Line + ( lineFromPath + , clipLine + , sanitizeLine + , lineBreakAt + , flattenLine + , lineLength + ) where + +import Control.Applicative( Applicative, (<$>), pure ) +import Data.Monoid( Monoid, (<>), mempty ) +import Linear( V2( .. ), (^-^), 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 + +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 = lerpPoint a b t + +flattenLine :: Line -> Container Primitive +flattenLine = pure . LinePrim + +-- | 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 + 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,163 +1,163 @@ --- | Module providing basic helper functions to help --- build vector/point calculations. -module Graphics.Rasterific.Operators - ( -- * Lifted operators - (^&&^) - , (^||^) - , (^==^) - , (^/=^) - , (^<=^) - , (^<^) - , (^<) - - -- * Lifted functions - , vmin - , vmax - , vabs - , vfloor - , vceil - , clampPoint - , midPoint - , lerpPoint - , vpartition - , normal - , ifZero - , isNearby - , isDistingableFrom - ) where - -import Control.Applicative( Applicative - , liftA2 - , liftA3 - , (<$>) - ) - -import Linear( V2( .. ) - , Additive( .. ) - {-, Metric( .. )-} - , Epsilon( nearZero ) - , (^+^) - {-, (^/)-} - , (^*) - , dot - , normalize - ) - -import Graphics.Rasterific.Types - -infix 4 ^<, ^<=^, ^<^, ^==^, ^/=^ -infixr 3 ^&&^ -infixr 2 ^||^ - --- | 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) => a Float -> a Float -> a Float -{-# INLINE midPoint #-} -midPoint a b = (a ^+^ b) ^* 0.5 - -lerpPoint :: (Additive a) => a Float -> a Float -> Float -> a Float -{-# INLINE lerpPoint #-} -lerpPoint a b v = a ^+^ (b ^-^ a) ^* v - --- | 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 + ( -- * Lifted operators + (^&&^) + , (^||^) + , (^==^) + , (^/=^) + , (^<=^) + , (^<^) + , (^<) + + -- * Lifted functions + , vmin + , vmax + , vabs + , vfloor + , vceil + , clampPoint + , midPoint + , lerpPoint + , vpartition + , normal + , ifZero + , isNearby + , isDistingableFrom + ) where + +import Control.Applicative( Applicative + , liftA2 + , liftA3 + , (<$>) + ) + +import Linear( V2( .. ) + , Additive( .. ) + {-, Metric( .. )-} + , Epsilon( nearZero ) + , (^+^) + {-, (^/)-} + , (^*) + , dot + , normalize + ) + +import Graphics.Rasterific.Types + +infix 4 ^<, ^<=^, ^<^, ^==^, ^/=^ +infixr 3 ^&&^ +infixr 2 ^||^ + +-- | 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) => a Float -> a Float -> a Float +{-# INLINE midPoint #-} +midPoint a b = (a ^+^ b) ^* 0.5 + +lerpPoint :: (Additive a) => a Float -> a Float -> Float -> a Float +{-# INLINE lerpPoint #-} +lerpPoint a b v = a ^+^ (b ^-^ a) ^* v + +-- | 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 + 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,260 +1,260 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} --- | 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 - ) where - -import Control.Applicative( (<$>) - , (<*>) - , Applicative - , pure ) -import Linear( V2( .. ) - , V1( .. ) - , (^-^) - , (^+^) - , (^*) - , dot - , norm - ) -import Data.Monoid( Monoid( mempty ), (<>) ) -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 _ = [] - --- | Only work if the quadratic bezier curve --- is nearly flat -bezierLengthApproximation :: Bezier -> Float -bezierLengthApproximation (Bezier a _ c) = - norm $ c ^-^ a - -decomposeBeziers :: Bezier -> [EdgeSample] -decomposeBeziers (Bezier a@(V2 ax ay) b c@(V2 cx cy)) - | insideX && insideY = [EdgeSample (px + 0.5) (py + 0.5) (w * h) h] - | otherwise = recurse (Bezier a ab m) <> - recurse (Bezier m bc c) - where floorA = vfloor a - floorC = vfloor c - V2 px py = fromIntegral <$> vmin floorA floorC - V1 w = (px + 1 -) <$> (V1 cx `midPoint` V1 ax) - h = cy - ay - - recurse = decomposeBeziers - - V2 insideX insideY = - floorA ^==^ floorC ^||^ vceil a ^==^ vceil c - - ab = a `midPoint` b - bc = b `midPoint` c - abbc = ab `midPoint` bc - - mini = fromIntegral <$> vfloor abbc - maxi = fromIntegral <$> vceil abbc - nearmin = vabs (abbc ^-^ mini) ^< 0.1 - nearmax = vabs (abbc ^-^ maxi) ^< 0.1 - - minMaxing mi nearmi ma nearma p - | nearmi = mi - | nearma = ma - | otherwise = p - - m = minMaxing <$> mini <*> nearmin <*> maxi <*> nearmax <*> abbc - --- | 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 = a `midPoint` b - bc = b `midPoint` c - abbc = ab `midPoint` bc - - -- 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 = lerpPoint a b t - bc = lerpPoint b c t - abbc = lerpPoint ab bc t - -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 = (a `midPoint` b) - bc = (b `midPoint` c) - abbc = ab `midPoint` bc - --- | Move the bezier to a new position with an offset. -offsetBezier :: Float -> Bezier -> Container Primitive -offsetBezier offset (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 = (a `midPoint` b) - bc = (b `midPoint` c) - abbc = ab `midPoint` bc - - shiftedA = a ^+^ (u ^* offset) - shiftedC = c ^+^ (v ^* offset) - shiftedABBC = abbc ^+^ (w ^* offset) - mergedB = - (shiftedABBC ^* 2.0) ^-^ (shiftedA `midPoint` shiftedC) - +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +-- | 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 + ) where + +import Control.Applicative( (<$>) + , (<*>) + , Applicative + , pure ) +import Linear( V2( .. ) + , V1( .. ) + , (^-^) + , (^+^) + , (^*) + , dot + , norm + ) +import Data.Monoid( Monoid( mempty ), (<>) ) +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 _ = [] + +-- | Only work if the quadratic bezier curve +-- is nearly flat +bezierLengthApproximation :: Bezier -> Float +bezierLengthApproximation (Bezier a _ c) = + norm $ c ^-^ a + +decomposeBeziers :: Bezier -> [EdgeSample] +decomposeBeziers (Bezier a@(V2 ax ay) b c@(V2 cx cy)) + | insideX && insideY = [EdgeSample (px + 0.5) (py + 0.5) (w * h) h] + | otherwise = recurse (Bezier a ab m) <> + recurse (Bezier m bc c) + where floorA = vfloor a + floorC = vfloor c + V2 px py = fromIntegral <$> vmin floorA floorC + V1 w = (px + 1 -) <$> (V1 cx `midPoint` V1 ax) + h = cy - ay + + recurse = decomposeBeziers + + V2 insideX insideY = + floorA ^==^ floorC ^||^ vceil a ^==^ vceil c + + ab = a `midPoint` b + bc = b `midPoint` c + abbc = ab `midPoint` bc + + mini = fromIntegral <$> vfloor abbc + maxi = fromIntegral <$> vceil abbc + nearmin = vabs (abbc ^-^ mini) ^< 0.1 + nearmax = vabs (abbc ^-^ maxi) ^< 0.1 + + minMaxing mi nearmi ma nearma p + | nearmi = mi + | nearma = ma + | otherwise = p + + m = minMaxing <$> mini <*> nearmin <*> maxi <*> nearmax <*> abbc + +-- | 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 = a `midPoint` b + bc = b `midPoint` c + abbc = ab `midPoint` bc + + -- 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 = lerpPoint a b t + bc = lerpPoint b c t + abbc = lerpPoint ab bc t + +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 = (a `midPoint` b) + bc = (b `midPoint` c) + abbc = ab `midPoint` bc + +-- | Move the bezier to a new position with an offset. +offsetBezier :: Float -> Bezier -> Container Primitive +offsetBezier offset (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 = (a `midPoint` b) + bc = (b `midPoint` c) + abbc = ab `midPoint` bc + + 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/Rasterize.hs b/src/Graphics/Rasterific/Rasterize.hs --- a/src/Graphics/Rasterific/Rasterize.hs +++ b/src/Graphics/Rasterific/Rasterize.hs @@ -1,47 +1,47 @@ -module Graphics.Rasterific.Rasterize - ( CoverageSpan( .. ) - , rasterize - ) where - -import Data.Fixed( mod' ) -import Data.List( mapAccumL, sortBy ) -import Graphics.Rasterific.Types -import Graphics.Rasterific.QuadraticBezier -import Graphics.Rasterific.CubicBezier - -data CoverageSpan = CoverageSpan - { _coverageX :: {-# UNPACK #-} !Float - , _coverageY :: {-# UNPACK #-} !Float - , _coverageVal :: {-# UNPACK #-} !Float - , _coverageLength :: {-# UNPACK #-} !Float - } - deriving Show - -combineEdgeSamples :: (Float -> Float) -> [EdgeSample] -> [CoverageSpan] -{-# INLINE combineEdgeSamples #-} -combineEdgeSamples prepareCoverage = append . mapAccumL go (0, 0, 0, 0) - where append ((x, y, a, _), lst) = - concat lst ++ [CoverageSpan x y (prepareCoverage a) 1] - - go (x, y, a, h) (EdgeSample x' y' a' h') - | y == y' && x == x' = ((x', y', a + a', h + h'), []) - | y == y' = ((x', y', h + a', h + h'), [p1, p2]) - | otherwise = - ((x', y', a', h'), [CoverageSpan x y (prepareCoverage a) 1]) - where p1 = CoverageSpan x y (prepareCoverage a) 1 - p2 = CoverageSpan (x + 1) y (prepareCoverage h) (x' - x - 1) - -decompose :: Primitive -> [EdgeSample] -decompose (LinePrim (Line x1 x2)) = decomposeBeziers $ straightLine x1 x2 -decompose (BezierPrim b) = decomposeBeziers b -decompose (CubicBezierPrim c) = decomposeCubicBeziers c - -rasterize :: FillMethod -> [Primitive] -> [CoverageSpan] -rasterize method = - case method of - FillWinding -> combineEdgeSamples combineWinding . sortBy xy . concatMap decompose - FillEvenOdd -> combineEdgeSamples combineEvenOdd . sortBy xy . concatMap decompose - where xy a b = compare (_sampleY a, _sampleX a) (_sampleY b, _sampleX b) - combineWinding = min 1 . abs - combineEvenOdd cov = abs $ abs (cov - 1) `mod'` 2 - 1 - +module Graphics.Rasterific.Rasterize + ( CoverageSpan( .. ) + , rasterize + ) where + +import Data.Fixed( mod' ) +import Data.List( mapAccumL, sortBy ) +import Graphics.Rasterific.Types +import Graphics.Rasterific.QuadraticBezier +import Graphics.Rasterific.CubicBezier + +data CoverageSpan = CoverageSpan + { _coverageX :: {-# UNPACK #-} !Float + , _coverageY :: {-# UNPACK #-} !Float + , _coverageVal :: {-# UNPACK #-} !Float + , _coverageLength :: {-# UNPACK #-} !Float + } + deriving Show + +combineEdgeSamples :: (Float -> Float) -> [EdgeSample] -> [CoverageSpan] +{-# INLINE combineEdgeSamples #-} +combineEdgeSamples prepareCoverage = append . mapAccumL go (0, 0, 0, 0) + where append ((x, y, a, _), lst) = + concat lst ++ [CoverageSpan x y (prepareCoverage a) 1] + + go (x, y, a, h) (EdgeSample x' y' a' h') + | y == y' && x == x' = ((x', y', a + a', h + h'), []) + | y == y' = ((x', y', h + a', h + h'), [p1, p2]) + | otherwise = + ((x', y', a', h'), [CoverageSpan x y (prepareCoverage a) 1]) + where p1 = CoverageSpan x y (prepareCoverage a) 1 + p2 = CoverageSpan (x + 1) y (prepareCoverage h) (x' - x - 1) + +decompose :: Primitive -> [EdgeSample] +decompose (LinePrim (Line x1 x2)) = decomposeBeziers $ straightLine x1 x2 +decompose (BezierPrim b) = decomposeBeziers b +decompose (CubicBezierPrim c) = decomposeCubicBeziers c + +rasterize :: FillMethod -> [Primitive] -> [CoverageSpan] +rasterize method = + case method of + FillWinding -> combineEdgeSamples combineWinding . sortBy xy . concatMap decompose + FillEvenOdd -> combineEdgeSamples combineEvenOdd . sortBy xy . concatMap decompose + where xy a b = compare (_sampleY a, _sampleX a) (_sampleY b, _sampleX b) + combineWinding = min 1 . abs + combineEvenOdd cov = abs $ abs (cov - 1) `mod'` 2 - 1 + diff --git a/src/Graphics/Rasterific/Stroke.hs b/src/Graphics/Rasterific/Stroke.hs --- a/src/Graphics/Rasterific/Stroke.hs +++ b/src/Graphics/Rasterific/Stroke.hs @@ -1,258 +1,258 @@ -module Graphics.Rasterific.Stroke - ( flatten - , dashize - , strokize - , dashedStrokize - ) where - -import Control.Applicative( Applicative, (<$>), pure ) -import Data.Monoid( Monoid, (<>), mempty ) -import Data.Foldable( Foldable, foldMap ) -import 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) - -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 w v <> go u w - 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 = - pure (m `lineFromTo` c) <> pure (a `lineFromTo` m) - -- 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 (Line x1 x2)) = - offsetPrimitives offset . BezierPrim $ straightLine x1 x2 -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 = joiner prev firstShape <> offseter prev - | otherwise = cap offset caping prev <> offseter prev - go prev (x:xs) = - joiner prev x <> offseter prev <> 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 :: StrokeWidth -> Join -> (Cap, Cap) -> [Primitive] - -> [Primitive] -strokize width join (capStart, capEnd) beziers = - offseter capEnd sanitized <> - offseter capStart (reverse $ reversePrimitive <$> sanitized) - where sanitized = foldMap sanitize beziers - offseter = offsetAndJoin (width / 2) join - -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 at = go at - 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 - -dashize :: Float -> DashPattern -> [Primitive] -> [[Primitive]] -dashize offset pattern = - taker infinitePattern . concatMap flattenPrimitive . concatMap sanitize - 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 - -dashedStrokize :: Float -> DashPattern -> StrokeWidth - -> Join -> (Cap, Cap) -> [Primitive] - -> [[Primitive]] -dashedStrokize offset dashPattern width join capping beziers = - strokize width join capping <$> dashize offset dashPattern beziers - +module Graphics.Rasterific.Stroke + ( flatten + , dashize + , strokize + , dashedStrokize + ) where + +import Control.Applicative( Applicative, (<$>), pure ) +import Data.Monoid( Monoid, (<>), mempty ) +import Data.Foldable( Foldable, foldMap ) +import 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) + +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 w v <> go u w + 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 = + pure (m `lineFromTo` c) <> pure (a `lineFromTo` m) + -- 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 (Line x1 x2)) = + offsetPrimitives offset . BezierPrim $ straightLine x1 x2 +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 = joiner prev firstShape <> offseter prev + | otherwise = cap offset caping prev <> offseter prev + go prev (x:xs) = + joiner prev x <> offseter prev <> 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 :: StrokeWidth -> Join -> (Cap, Cap) -> [Primitive] + -> [Primitive] +strokize width join (capStart, capEnd) beziers = + offseter capEnd sanitized <> + offseter capStart (reverse $ reversePrimitive <$> sanitized) + where sanitized = foldMap sanitize beziers + offseter = offsetAndJoin (width / 2) join + +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 at = go at + 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 + +dashize :: Float -> DashPattern -> [Primitive] -> [[Primitive]] +dashize offset pattern = + taker infinitePattern . concatMap flattenPrimitive . concatMap sanitize + 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 + +dashedStrokize :: Float -> DashPattern -> StrokeWidth + -> Join -> (Cap, Cap) -> [Primitive] + -> [[Primitive]] +dashedStrokize offset dashPattern width join capping beziers = + strokize width join capping <$> dashize offset dashPattern beziers + diff --git a/src/Graphics/Rasterific/Texture.hs b/src/Graphics/Rasterific/Texture.hs --- a/src/Graphics/Rasterific/Texture.hs +++ b/src/Graphics/Rasterific/Texture.hs @@ -1,331 +1,330 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | Module describing the various filling method of the --- geometric primitives. --- --- All points coordinate given in this module are expressed --- final image pixel coordinates. -module Graphics.Rasterific.Texture - ( Texture - , Gradient - , withSampler - , uniformTexture - -- * Texture kind - , linearGradientTexture - , radialGradientTexture - , radialGradientWithFocusTexture - , imageTexture - , sampledImageTexture - - -- * Texture manipulation - , modulateTexture - , transformTexture - ) where - -import Data.Fixed( mod' ) -import Linear( V2( .. ) - , (^-^) - , (^/) - , dot - , norm - ) - -import qualified Data.Vector as V - -import Codec.Picture.Types( Pixel( .. ) - , Image( .. ) - , Pixel8 - , PixelRGBA8 - ) -import Graphics.Rasterific.Types( Point, SamplerRepeat( .. ) ) -import Graphics.Rasterific.Transformations -import Graphics.Rasterific.Compositor - ( Modulable( clampCoverage, modulate, alphaOver ), compositionAlpha ) - --- | A texture is just a function which given pixel coordinate --- give back a pixel. --- The float coordinate type allow for transformations --- to happen in the pixel space. -type Texture px = SamplerRepeat -> Float -> Float -> px - --- | Set the repeat pattern of the texture (if any). --- With padding: --- --- > withTexture (sampledImageTexture textureImage) $ --- > fill $ rectangle (V2 0 0) 200 200 --- --- <> --- --- With repeat: --- --- > withTexture (withSampler SamplerRepeat $ --- > sampledImageTexture textureImage) $ --- > fill $ rectangle (V2 0 0) 200 200 --- --- <> --- --- With reflect: --- --- > withTexture (withSampler SamplerReflect $ --- > sampledImageTexture textureImage) $ --- > fill $ rectangle (V2 0 0) 200 200 --- --- <> --- -withSampler :: SamplerRepeat -> Texture px -> Texture px -withSampler repeating texture _ = texture repeating - --- | Transform the coordinates used for texture before applying --- it, allow interesting transformations. --- --- > withTexture (withSampler SamplerRepeat $ --- > transformTexture (rotateCenter 1 (V2 0 0) <> --- > scale 0.5 0.25) --- > $ sampledImageTexture textureImage) $ --- > fill $ rectangle (V2 0 0) 200 200 --- --- <> --- -transformTexture :: Transformation -> Texture px -> Texture px -transformTexture trans tx samp x y = tx samp x' y' - where - (V2 x' y') = applyTransformation trans (V2 x y) - --- | The uniform texture is the simplest texture of all: --- an uniform color. -uniformTexture :: px -- ^ The color used for all the texture. - -> Texture px -uniformTexture 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)] -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 :: (Pixel px, Modulable (PixelBaseComponent px)) - => GradientArray px -> Float -> px -{-# SPECIALIZE - gradientColorAt :: GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-} -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 = compositionAlpha 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 :: (Pixel px, Modulable (PixelBaseComponent px)) - => SamplerRepeat -> GradientArray px -> Float -> px -{-# SPECIALIZE INLINE - gradientColorAtRepeat :: - SamplerRepeat -> GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-} -gradientColorAtRepeat SamplerPad grad = gradientColorAt grad -gradientColorAtRepeat SamplerRepeat grad = - gradientColorAt grad . repeatGradient -gradientColorAtRepeat SamplerReflect grad = - gradientColorAt grad . reflectGradient - --- | Linear gradient texture. --- --- > let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) --- > ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) --- > ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in --- > withTexture (linearGradientTexture SamplerPad gradDef --- > (V2 40 40) (V2 130 130)) $ --- > fill $ circle (V2 100 100) 100 --- --- <> --- -linearGradientTexture :: (Pixel px, Modulable (PixelBaseComponent px)) - => Gradient px -- ^ Gradient description. - -> Point -- ^ Linear gradient start point. - -> Point -- ^ Linear gradient end point. - -> Texture px -{-# SPECIALIZE - linearGradientTexture - :: Gradient PixelRGBA8 -> Point -> Point - -> Texture PixelRGBA8 #-} -linearGradientTexture 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. --- -sampledImageTexture :: forall px. - ( Pixel px, Modulable (PixelBaseComponent px)) - => Image px -> Texture px -{-# SPECIALIZE - sampledImageTexture :: Image Pixel8 -> Texture Pixel8 #-} -{-# SPECIALIZE - sampledImageTexture :: Image PixelRGBA8 -> Texture PixelRGBA8 #-} -sampledImageTexture 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. -imageTexture :: forall px. (Pixel px) => Image px -> Texture px -{-# SPECIALIZE - imageTexture :: Image PixelRGBA8 -> Texture PixelRGBA8 #-} -{-# SPECIALIZE - imageTexture :: Image Pixel8 -> Texture Pixel8 #-} -imageTexture 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 - --- | Radial gradient texture --- --- > let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) --- > ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) --- > ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in --- > withTexture (radialGradientTexture SamplerPad gradDef --- > (V2 100 100) 75) $ --- > fill $ circle (V2 100 100) 100 --- --- <> --- -radialGradientTexture :: (Pixel px, Modulable (PixelBaseComponent px)) - => Gradient px -- ^ Gradient description - -> Point -- ^ Radial gradient center - -> Float -- ^ Radial gradient radius - -> Texture px -radialGradientTexture gradient center radius repeating = - \x y -> colorAt $ norm ((V2 x y) ^-^ center) / radius - where - colorAt = gradientColorAtRepeat repeating gradArray - gradArray = V.fromList gradient - - --- | Radial gradient texture with a focus point. --- --- > let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) --- > ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) --- > ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in --- > withTexture (radialGradientWithFocusTexture SamplerPad gradDef --- > (V2 100 100) 75 (V2 70 70) ) $ --- > fill $ circle (V2 100 100) 100 --- --- <> --- -radialGradientWithFocusTexture - :: (Pixel px, Modulable (PixelBaseComponent px)) - => Gradient px -- ^ Gradient description - -> Point -- ^ Radial gradient center - -> Float -- ^ Radial gradient radius - -> Point -- ^ Radial gradient focus point - -> Texture px -radialGradientWithFocusTexture 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 :: (Pixel px, Modulable (PixelBaseComponent px)) - => Texture px -- ^ The full blown texture. - -> Texture (PixelBaseComponent px) -- ^ A greyscale modulation texture. - -> Texture px -- ^ The resulting texture. -modulateTexture fullTexture modulator repeating = \x y -> - colorMap (modulate $ modulationTexture x y) $ full x y - where modulationTexture = modulator repeating - full = fullTexture repeating - +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Module describing the various filling method of the +-- geometric primitives. +-- +-- All points coordinate given in this module are expressed +-- final image pixel coordinates. +module Graphics.Rasterific.Texture + ( Texture + , Gradient + , withSampler + , uniformTexture + -- * Texture kind + , linearGradientTexture + , radialGradientTexture + , radialGradientWithFocusTexture + , imageTexture + , sampledImageTexture + + -- * Texture manipulation + , modulateTexture + , transformTexture + ) where + +import Data.Fixed( mod' ) +import Linear( V2( .. ) + , (^-^) + , (^/) + , dot + , norm + ) + +import qualified Data.Vector as V + +import Codec.Picture.Types( Pixel( .. ) + , Image( .. ) + , Pixel8 + , PixelRGBA8 + ) +import Graphics.Rasterific.Types( Point, SamplerRepeat( .. ) ) +import Graphics.Rasterific.Transformations +import Graphics.Rasterific.Compositor( Modulable( clampCoverage, modulate, alphaOver ) ) + +-- | A texture is just a function which given pixel coordinate +-- give back a pixel. +-- The float coordinate type allow for transformations +-- to happen in the pixel space. +type Texture px = SamplerRepeat -> Float -> Float -> px + +-- | Set the repeat pattern of the texture (if any). +-- With padding: +-- +-- > withTexture (sampledImageTexture textureImage) $ +-- > fill $ rectangle (V2 0 0) 200 200 +-- +-- <> +-- +-- With repeat: +-- +-- > withTexture (withSampler SamplerRepeat $ +-- > sampledImageTexture textureImage) $ +-- > fill $ rectangle (V2 0 0) 200 200 +-- +-- <> +-- +-- With reflect: +-- +-- > withTexture (withSampler SamplerReflect $ +-- > sampledImageTexture textureImage) $ +-- > fill $ rectangle (V2 0 0) 200 200 +-- +-- <> +-- +withSampler :: SamplerRepeat -> Texture px -> Texture px +withSampler repeating texture _ = texture repeating + +-- | Transform the coordinates used for texture before applying +-- it, allow interesting transformations. +-- +-- > withTexture (withSampler SamplerRepeat $ +-- > transformTexture (rotateCenter 1 (V2 0 0) <> +-- > scale 0.5 0.25) +-- > $ sampledImageTexture textureImage) $ +-- > fill $ rectangle (V2 0 0) 200 200 +-- +-- <> +-- +transformTexture :: Transformation -> Texture px -> Texture px +transformTexture trans tx samp x y = tx samp x' y' + where + (V2 x' y') = applyTransformation trans (V2 x y) + +-- | The uniform texture is the simplest texture of all: +-- an uniform color. +uniformTexture :: px -- ^ The color used for all the texture. + -> Texture px +uniformTexture 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)] +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 :: (Pixel px, Modulable (PixelBaseComponent px)) + => GradientArray px -> Float -> px +{-# SPECIALIZE + gradientColorAt :: GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-} +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 :: (Pixel px, Modulable (PixelBaseComponent px)) + => SamplerRepeat -> GradientArray px -> Float -> px +{-# SPECIALIZE INLINE + gradientColorAtRepeat :: + SamplerRepeat -> GradientArray PixelRGBA8 -> Float -> PixelRGBA8 #-} +gradientColorAtRepeat SamplerPad grad = gradientColorAt grad +gradientColorAtRepeat SamplerRepeat grad = + gradientColorAt grad . repeatGradient +gradientColorAtRepeat SamplerReflect grad = + gradientColorAt grad . reflectGradient + +-- | Linear gradient texture. +-- +-- > let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) +-- > ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) +-- > ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in +-- > withTexture (linearGradientTexture SamplerPad gradDef +-- > (V2 40 40) (V2 130 130)) $ +-- > fill $ circle (V2 100 100) 100 +-- +-- <> +-- +linearGradientTexture :: (Pixel px, Modulable (PixelBaseComponent px)) + => Gradient px -- ^ Gradient description. + -> Point -- ^ Linear gradient start point. + -> Point -- ^ Linear gradient end point. + -> Texture px +{-# SPECIALIZE + linearGradientTexture + :: Gradient PixelRGBA8 -> Point -> Point + -> Texture PixelRGBA8 #-} +linearGradientTexture 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. +-- +sampledImageTexture :: forall px. + ( Pixel px, Modulable (PixelBaseComponent px)) + => Image px -> Texture px +{-# SPECIALIZE + sampledImageTexture :: Image Pixel8 -> Texture Pixel8 #-} +{-# SPECIALIZE + sampledImageTexture :: Image PixelRGBA8 -> Texture PixelRGBA8 #-} +sampledImageTexture 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. +imageTexture :: forall px. (Pixel px) => Image px -> Texture px +{-# SPECIALIZE + imageTexture :: Image PixelRGBA8 -> Texture PixelRGBA8 #-} +{-# SPECIALIZE + imageTexture :: Image Pixel8 -> Texture Pixel8 #-} +imageTexture 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 + +-- | Radial gradient texture +-- +-- > let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) +-- > ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) +-- > ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in +-- > withTexture (radialGradientTexture SamplerPad gradDef +-- > (V2 100 100) 75) $ +-- > fill $ circle (V2 100 100) 100 +-- +-- <> +-- +radialGradientTexture :: (Pixel px, Modulable (PixelBaseComponent px)) + => Gradient px -- ^ Gradient description + -> Point -- ^ Radial gradient center + -> Float -- ^ Radial gradient radius + -> Texture px +radialGradientTexture gradient center radius repeating = + \x y -> colorAt $ norm ((V2 x y) ^-^ center) / radius + where + colorAt = gradientColorAtRepeat repeating gradArray + gradArray = V.fromList gradient + + +-- | Radial gradient texture with a focus point. +-- +-- > let gradDef = [(0, PixelRGBA8 0 0x86 0xc1 255) +-- > ,(0.5, PixelRGBA8 0xff 0xf4 0xc1 255) +-- > ,(1, PixelRGBA8 0xFF 0x53 0x73 255)] in +-- > withTexture (radialGradientWithFocusTexture SamplerPad gradDef +-- > (V2 100 100) 75 (V2 70 70) ) $ +-- > fill $ circle (V2 100 100) 100 +-- +-- <> +-- +radialGradientWithFocusTexture + :: (Pixel px, Modulable (PixelBaseComponent px)) + => Gradient px -- ^ Gradient description + -> Point -- ^ Radial gradient center + -> Float -- ^ Radial gradient radius + -> Point -- ^ Radial gradient focus point + -> Texture px +radialGradientWithFocusTexture 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 :: (Pixel px, Modulable (PixelBaseComponent px)) + => Texture px -- ^ The full blown texture. + -> Texture (PixelBaseComponent px) -- ^ A greyscale modulation texture. + -> Texture px -- ^ The resulting texture. +modulateTexture fullTexture modulator repeating = \x y -> + colorMap (modulate $ modulationTexture x y) $ full x y + where modulationTexture = modulator repeating + full = fullTexture repeating + 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,130 +1,130 @@ --- | 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 - , translate - , scale - , rotate - , rotateCenter - , inverseTransformation - ) where - -import Data.Monoid( Monoid( .. ), (<>) ) -import Graphics.Rasterific.Types -import Linear( V2( .. ) ) - --- | 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) - - --- | 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 - --- | Inverse a transformation (if possible) -inverseTransformation :: Transformation -> Transformation -inverseTransformation (Transformation a c e - b d f) = - 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 + , translate + , scale + , rotate + , rotateCenter + , inverseTransformation + ) where + +import Data.Monoid( Monoid( .. ), (<>) ) +import Graphics.Rasterific.Types +import Linear( V2( .. ) ) + +-- | 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) + + +-- | 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 + +-- | Inverse a transformation (if possible) +inverseTransformation :: Transformation -> Transformation +inverseTransformation (Transformation a c e + b d f) = + 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,392 +1,392 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleInstances #-} --- | Gather all the types used in the rasterization engine. -module Graphics.Rasterific.Types - ( -- * Geometry description - Vector - , Point - , Line( .. ) - , Bezier( .. ) - , CubicBezier( .. ) - , Primitive( .. ) - , Container - , PathCommand( .. ) - , Path( .. ) - , Transformable( .. ) - , PointFoldable( .. ) - - -- * Rasterization control types - , Cap( .. ) - , Join( .. ) - , FillMethod( .. ) - , SamplerRepeat( .. ) - , DashPattern - , StrokeWidth - - -- * Internal type - , EdgeSample( .. ) - , pathToPrimitives - ) where - -import Data.Foldable( Foldable, foldl' ) -import Linear( V2( .. ) ) - --- | Represent a vector -type Vector = V2 Float - --- | Represent a point -type Point = V2 Float - --- | Type alias just to get more meaningful --- type signatures -type StrokeWidth = Float - --- | Dash pattern to use -type DashPattern = [Float] - --- | 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))) --- > $ concatMap pathToPrimitives --- > [ 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 - --- | 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 - --- | 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 - - -instance Transformable Point where - {-# INLINE transform #-} - transform f p = f p - -instance PointFoldable Point where - {-# INLINE foldPoints #-} - foldPoints f acc p = f acc p - --- | Describe a simple 2D line between two points. --- --- > fill $ LinePrim <$> [ 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 transform #-} - transform 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 $ BezierPrim <$> [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 - -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) $ --- > [CubicBezierPrim $ 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 - -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 --- > [ CubicBezierPrim $ CubicBezier (V2 50 20) (V2 90 60) --- > (V2 5 100) (V2 50 140) --- > , LinePrim $ Line (V2 50 140) (V2 120 80) --- > , LinePrim $ 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) - -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 - -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 (Functor f, Transformable a) - => Transformable (f a) where - transform f = fmap (transform f) - -instance (Foldable f, PointFoldable a) - => PointFoldable (f a) where - foldPoints f = foldl' (foldPoints f) - -type Container a = [a] - --- | 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 . pathToPrimitives $ 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) - -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 - -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 - +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +-- | Gather all the types used in the rasterization engine. +module Graphics.Rasterific.Types + ( -- * Geometry description + Vector + , Point + , Line( .. ) + , Bezier( .. ) + , CubicBezier( .. ) + , Primitive( .. ) + , Container + , PathCommand( .. ) + , Path( .. ) + , Transformable( .. ) + , PointFoldable( .. ) + + -- * Rasterization control types + , Cap( .. ) + , Join( .. ) + , FillMethod( .. ) + , SamplerRepeat( .. ) + , DashPattern + , StrokeWidth + + -- * Internal type + , EdgeSample( .. ) + , pathToPrimitives + ) where + +import Data.Foldable( Foldable, foldl' ) +import Linear( V2( .. ) ) + +-- | Represent a vector +type Vector = V2 Float + +-- | Represent a point +type Point = V2 Float + +-- | Type alias just to get more meaningful +-- type signatures +type StrokeWidth = Float + +-- | Dash pattern to use +type DashPattern = [Float] + +-- | 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))) +-- > $ concatMap pathToPrimitives +-- > [ 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 + +-- | 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 + +-- | 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 + + +instance Transformable Point where + {-# INLINE transform #-} + transform f p = f p + +instance PointFoldable Point where + {-# INLINE foldPoints #-} + foldPoints f acc p = f acc p + +-- | Describe a simple 2D line between two points. +-- +-- > fill $ LinePrim <$> [ 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 transform #-} + transform 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 $ BezierPrim <$> [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 + +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) $ +-- > [CubicBezierPrim $ 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 + +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 +-- > [ CubicBezierPrim $ CubicBezier (V2 50 20) (V2 90 60) +-- > (V2 5 100) (V2 50 140) +-- > , LinePrim $ Line (V2 50 140) (V2 120 80) +-- > , LinePrim $ 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) + +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 + +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 (Functor f, Transformable a) + => Transformable (f a) where + transform f = fmap (transform f) + +instance (Foldable f, PointFoldable a) + => PointFoldable (f a) where + foldPoints f = foldl' (foldPoints f) + +type Container a = [a] + +-- | 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 . pathToPrimitives $ 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) + +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 + +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 +