diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +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. diff --git a/Rasterific.cabal b/Rasterific.cabal new file mode 100644 --- /dev/null +++ b/Rasterific.cabal @@ -0,0 +1,63 @@ +-- Initial Rasterific.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ +name: Rasterific +version: 0.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.1 + +library + hs-source-dirs: src + exposed-modules: Graphics.Rasterific + , Graphics.Rasterific.Texture + + 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.4 && < 3.2 + , linear >= 1.3.1 && < 1.4 + , free >= 4.5 && < 4.6 + , FontyFruity >= 0.1.0.2 && < 0.2 + , vector >= 0.9 + , mtl >= 2.1 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,5 @@ +-*-change-log-*- + +v0.1 February 2014 + * Initial version + diff --git a/docimages/cap_round.png b/docimages/cap_round.png new file mode 100644 Binary files /dev/null and b/docimages/cap_round.png differ diff --git a/docimages/cap_straight.png b/docimages/cap_straight.png new file mode 100644 Binary files /dev/null and b/docimages/cap_straight.png differ diff --git a/docimages/cap_straight_1.png b/docimages/cap_straight_1.png new file mode 100644 Binary files /dev/null and b/docimages/cap_straight_1.png differ diff --git a/docimages/coordinate.png b/docimages/coordinate.png new file mode 100644 Binary files /dev/null and b/docimages/coordinate.png differ diff --git a/docimages/cubic_bezier.png b/docimages/cubic_bezier.png new file mode 100644 Binary files /dev/null and b/docimages/cubic_bezier.png differ diff --git a/docimages/dashed_stroke.png b/docimages/dashed_stroke.png new file mode 100644 Binary files /dev/null and b/docimages/dashed_stroke.png differ diff --git a/docimages/fill_circle.png b/docimages/fill_circle.png new file mode 100644 Binary files /dev/null and b/docimages/fill_circle.png differ diff --git a/docimages/fill_rect.png b/docimages/fill_rect.png new file mode 100644 Binary files /dev/null and b/docimages/fill_rect.png differ diff --git a/docimages/join_miter.png b/docimages/join_miter.png new file mode 100644 Binary files /dev/null and b/docimages/join_miter.png differ diff --git a/docimages/join_miter_5.png b/docimages/join_miter_5.png new file mode 100644 Binary files /dev/null and b/docimages/join_miter_5.png differ diff --git a/docimages/join_round.png b/docimages/join_round.png new file mode 100644 Binary files /dev/null and b/docimages/join_round.png differ diff --git a/docimages/linear_gradient.png b/docimages/linear_gradient.png new file mode 100644 Binary files /dev/null and b/docimages/linear_gradient.png differ diff --git a/docimages/logo.png b/docimages/logo.png new file mode 100644 Binary files /dev/null and b/docimages/logo.png differ diff --git a/docimages/module_example.png b/docimages/module_example.png new file mode 100644 Binary files /dev/null and b/docimages/module_example.png differ diff --git a/docimages/path_example.png b/docimages/path_example.png new file mode 100644 Binary files /dev/null and b/docimages/path_example.png differ diff --git a/docimages/primitive_mixed.png b/docimages/primitive_mixed.png new file mode 100644 Binary files /dev/null and b/docimages/primitive_mixed.png differ diff --git a/docimages/quadratic_bezier.png b/docimages/quadratic_bezier.png new file mode 100644 Binary files /dev/null and b/docimages/quadratic_bezier.png differ diff --git a/docimages/radial_gradient.png b/docimages/radial_gradient.png new file mode 100644 Binary files /dev/null and b/docimages/radial_gradient.png differ diff --git a/docimages/radial_gradient_focus.png b/docimages/radial_gradient_focus.png new file mode 100644 Binary files /dev/null and b/docimages/radial_gradient_focus.png differ diff --git a/docimages/sampler_pad.png b/docimages/sampler_pad.png new file mode 100644 Binary files /dev/null and b/docimages/sampler_pad.png differ diff --git a/docimages/sampler_reflect.png b/docimages/sampler_reflect.png new file mode 100644 Binary files /dev/null and b/docimages/sampler_reflect.png differ diff --git a/docimages/sampler_repeat.png b/docimages/sampler_repeat.png new file mode 100644 Binary files /dev/null and b/docimages/sampler_repeat.png differ diff --git a/docimages/simple_line.png b/docimages/simple_line.png new file mode 100644 Binary files /dev/null and b/docimages/simple_line.png differ diff --git a/docimages/stroke_circle.png b/docimages/stroke_circle.png new file mode 100644 Binary files /dev/null and b/docimages/stroke_circle.png differ diff --git a/docimages/stroke_line.png b/docimages/stroke_line.png new file mode 100644 Binary files /dev/null and b/docimages/stroke_line.png differ diff --git a/docimages/text_example.png b/docimages/text_example.png new file mode 100644 Binary files /dev/null and b/docimages/text_example.png differ diff --git a/docimages/with_clipping.png b/docimages/with_clipping.png new file mode 100644 Binary files /dev/null and b/docimages/with_clipping.png differ diff --git a/docimages/with_texture.png b/docimages/with_texture.png new file mode 100644 Binary files /dev/null and b/docimages/with_texture.png differ diff --git a/src/Graphics/Rasterific.hs b/src/Graphics/Rasterific.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific.hs @@ -0,0 +1,485 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +-- | 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 +-- > +-- > 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 + , withTexture + , withClipping + , stroke + , dashedStroke + , printTextAt + + , strokeDebug + , renderDrawing + , pathToPrimitives + + -- * Rasterization types + , Texture + , Drawing + , Modulable + + -- * Geometry description + , V2( .. ) + , Point + , Vector + , CubicBezier( .. ) + , Line( .. ) + , Bezier( .. ) + , Primitive( .. ) + , Path( .. ) + , PathCommand( .. ) + , Transformable( .. ) + + -- * Helpers + , line + , rectangle + , circle + + -- ** Geometry Helpers + , clip + , bezierFromPath + , lineFromPath + , cubicBezierFromPath + + -- * Rasterization control + , Join( .. ) + , Cap( .. ) + , SamplerRepeat( .. ) + , DashPattern + + ) 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 Codec.Picture.Types( Image( .. ) + , Pixel( .. ) + , 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.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 a = Free (DrawCommand px) a + +data DrawCommand px next + = Fill [Primitive] next + | TextFill Font PointSize Point String next + | SetTexture (Texture px) + (Drawing px ()) next + | WithCliping (forall innerPixel. Drawing innerPixel ()) + (Drawing px ()) next + +instance Functor (DrawCommand px) where + fmap f (TextFill font size pos str next) = + TextFill font size pos str $ f next + fmap f (Fill prims next) = Fill 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) + +-- | 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 () + +-- | 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 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 = fill . strokize width join caping + +-- | 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 +-- > +-- > 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 () + +-- | 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 Nothing stupidDefaultTexture drawing) + >>= unsafeFreezeImage + where + clipBackground = emptyValue :: PixelBaseComponent px + clipForeground = fullValue :: PixelBaseComponent px + stupidDefaultTexture = + uniformTexture $ colorMap (const clipBackground) background + + clipRender = + renderDrawing width height clipBackground + . withTexture (uniformTexture clipForeground) + + + go :: Maybe (Texture (PixelBaseComponent px)) + -> Texture px + -> Drawing px () + -> DrawContext s px () + go _ _ (Pure ()) = return () + go Nothing texture (Free (Fill prims next)) = + fillWithTexture texture prims >> go Nothing texture next + go mo@(Just moduler) texture (Free (Fill prims next)) = + fillWithTextureAndMask texture moduler prims >> go mo texture next + go moduler texture (Free (SetTexture tx sub next)) = + go moduler tx sub >> go moduler texture next + go moduler texture (Free (TextFill font size (V2 x y) str next)) = + forM_ drawCalls (go moduler texture) >> go moduler texture next + where + drawCalls = beziersOfChar <$> getStringCurveAtPoint 90 (x, y) [(font, size, str)] + + beziersOfChar curves = liftF $ Fill bezierCurves () + where + bezierCurves = concat + [map BezierPrim . bezierFromPath . map (uncurry V2) + $ VU.toList c | c <- curves] + + go moduler texture (Free (WithCliping clipPath path next)) = + go newModuler texture path >> go moduler texture next + where + modulationTexture :: Texture (PixelBaseComponent px) + modulationTexture = imageTexture $ clipRender clipPath + + newModuler = Just $ subModuler moduler + + 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 dashing width join caping = + mapM_ fill . dashedStrokize dashing width join caping + +-- | Internal debug function +strokeDebug :: ( Pixel px, Modulable (PixelBaseComponent px)) + => Texture px -> Texture px + -> Float -> Join -> (Cap, Cap) + -> [Primitive] -> Drawing px () +strokeDebug debugPair debugImpair width join caping elems = do + fill stroked + forM_ (zip debugColor stroked) subStroke + where stroked = strokize width join caping elems + -- | Infinite list repeating color pattern + debugColor = debugPair : debugImpair : debugColor + subStroke (color, el) = + withTexture color $ stroke 2 (JoinMiter 0) + (CapStraight 0, CapStraight 0) [el] + +-- | 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)) + => Texture px -- ^ Color/Texture used for the filling + -> [Primitive] -- ^ Primitives to fill + -> DrawContext s px () +fillWithTexture texture els = do + img@(MutableImage width height _) <- get + let mini = V2 0 0 + maxi = V2 (fromIntegral width) (fromIntegral height) + spans = rasterize $ els >>= clip mini maxi + lift $ mapM_ (composeCoverageSpan texture img) spans + +fillWithTextureAndMask + :: ( Pixel px + , Pixel (PixelBaseComponent px) + , Modulable (PixelBaseComponent px)) + => Texture px -- ^ Color/Texture used for the filling + -> Texture (PixelBaseComponent px) + -> [Primitive] -- ^ Primitives to fill + -> DrawContext s px () +fillWithTextureAndMask texture mask els = do + img@(MutableImage width height _) <- get + let mini = V2 0 0 + maxi = V2 (fromIntegral width) (fromIntegral height) + spans = rasterize $ 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 () +{-# INLINE composeCoverageSpan #-} +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 . scaleMove <$> cubicBezierCircle + where + mv p = (p ^* radius) ^+^ center + scaleMove (CubicBezier p1 p2 p3 p4) = + CubicBezier (mv p1) (mv p2) (mv p3) (mv p4) + +-- | 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 ] + +-- | 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 new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/Compositor.hs @@ -0,0 +1,66 @@ +{-# 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 => Modulable a where + emptyValue :: a + fullValue :: a + clampCoverage :: Float -> (a, a) + modulate :: a -> a -> a + alphaOver :: 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 `unsafeShiftR` 8 + where fi :: Word8 -> Word32 + fi = fromIntegral + v = fi c * fi a + + coverageModulate c a = (clamped, fullValue - clamped) + where + v = fromIntegral c * fromIntegral a :: Word32 + clamped = fromIntegral $ (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 + + alphaOver c ic b a = fromIntegral $ (v + (v `unsafeShiftR` 8)) `unsafeShiftR` 8 + where fi :: Word8 -> Word32 + fi = fromIntegral + v = fi c * fi a + fi b * fi ic + 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 +compositionAlpha c ic + | c == emptyValue = const + | c == fullValue = \_ n -> n + | otherwise = mixWith (\_ -> alphaOver c ic) + diff --git a/src/Graphics/Rasterific/CubicBezier.hs b/src/Graphics/Rasterific/CubicBezier.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/CubicBezier.hs @@ -0,0 +1,285 @@ +{-# 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 + +-- | 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 abbc + +-- | 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) + | norm (a ^-^ b) > 0.0001 && + norm (b ^-^ c) > 0.0001 && + norm (c ^-^ d) > 0.0001 = + pure . CubicBezierPrim $ bezier + | ac /= b && bd /= c = + pure . CubicBezierPrim $ CubicBezier a ac bd d + | ac /= b = + pure . CubicBezierPrim $ CubicBezier a ac c d + | bd /= 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 new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/Line.hs @@ -0,0 +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 == 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 new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/Operators.hs @@ -0,0 +1,146 @@ +-- | 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 + ) where + +import Control.Applicative( Applicative + , liftA2 + , liftA3 + , (<$>) + ) + +import Linear( V2( .. ) + , Additive( .. ) + {-, Metric( .. )-} + , Epsilon( nearZero ) + , (^+^) + {-, (^/)-} + , (^*) + , 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 + diff --git a/src/Graphics/Rasterific/QuadraticBezier.hs b/src/Graphics/Rasterific/QuadraticBezier.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/QuadraticBezier.hs @@ -0,0 +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) + | norm (a ^-^ b) > 0.0001 && norm (b ^-^ c) > 0.0001 = + pure . BezierPrim $ bezier + + -- if b is to nearby a or c, take the midpoint as new reference. + | ac /= 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 new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/Rasterize.hs @@ -0,0 +1,40 @@ +module Graphics.Rasterific.Rasterize + ( CoverageSpan( .. ) + , rasterize + ) where + +import Data.List( mapAccumL, sortBy ) +import Graphics.Rasterific.Types +import Graphics.Rasterific.QuadraticBezier +import Graphics.Rasterific.CubicBezier + +data CoverageSpan = CoverageSpan + { _coverageX :: !Float + , _coverageY :: !Float + , _coverageVal :: !Float + , _coverageLength :: !Float + } + deriving Show + +combineEdgeSamples :: [EdgeSample] -> [CoverageSpan] +combineEdgeSamples = append . mapAccumL go (0, 0, 0, 0) + where append ((x, y, a, _), lst) = + concat lst ++ [CoverageSpan x y (min 1 $ abs 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 (min 1 $ abs a) 1]) + where p1 = CoverageSpan x y (min 1 $ abs a) 1 + p2 = CoverageSpan (x + 1) y (min 1 $ abs 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 :: [Primitive] -> [CoverageSpan] +rasterize = combineEdgeSamples . sortBy xy . concatMap decompose + where xy a b = compare (_sampleY a, _sampleX a) (_sampleY b, _sampleX b) + diff --git a/src/Graphics/Rasterific/Stroke.hs b/src/Graphics/Rasterific/Stroke.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/Stroke.hs @@ -0,0 +1,244 @@ +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 + | u `dot` w >= l / max 1 l = + 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 + + -- Calculate the maximum distance on the + -- u axis + p = offset / (u `dot` w) + -- 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 == 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 + + +dashize :: DashPattern -> [Primitive] -> [[Primitive]] +dashize pattern = taker infinitePattern + . concatMap flattenPrimitive + . concatMap sanitize + where + infinitePattern = cycle 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 :: DashPattern -> StrokeWidth -> Join -> (Cap, Cap) -> [Primitive] + -> [[Primitive]] +dashedStrokize dashPattern width join capping beziers = + strokize width join capping <$> dashize dashPattern beziers + diff --git a/src/Graphics/Rasterific/Texture.hs b/src/Graphics/Rasterific/Texture.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/Texture.hs @@ -0,0 +1,231 @@ +{-# 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 + , linearGradientTexture + , radialGradientTexture + , radialGradientWithFocusTexture + , imageTexture + , sampledImageTexture + , modulateTexture + ) where + +import Data.Fixed( mod' ) +import Linear( V2( .. ) + , (^-^) + , (^/) + , dot + , norm + ) + +import qualified Data.Vector as V + +import Codec.Picture.Types( Pixel( .. ) + , Image( .. ) + ) +import Graphics.Rasterific.Types( Point, SamplerRepeat( .. ) ) +import Graphics.Rasterific.Compositor + ( Modulable( clampCoverage, modulate ), 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). +withSampler :: SamplerRepeat -> Texture px -> Texture px +withSampler repeating texture _ = texture repeating + +-- | 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 +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 +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 +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. +imageTexture :: forall px. (Pixel px) => Image px -> Texture px +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 + +-- | Use another image as a texture for the filling, +-- but allow repeating and reflecting alongside with +-- padding. +sampledImageTexture :: (Pixel px) => Image px -> Texture px +sampledImageTexture img SamplerPad = imageTexture img SamplerPad +sampledImageTexture img SamplerReflect = imageTexture img SamplerPad +sampledImageTexture img SamplerRepeat = \x y -> texture (x `mod'` w) (y `mod'` h) + where + texture = imageTexture img SamplerPad + w = fromIntegral $ imageWidth img + h = fromIntegral $ imageHeight 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 - focusX * focusY + + 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/Types.hs b/src/Graphics/Rasterific/Types.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rasterific/Types.hs @@ -0,0 +1,254 @@ +{-# 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( .. ) + + -- * Rasterization control types + , Cap( .. ) + , Join( .. ) + , SamplerRepeat( .. ) + , DashPattern + , StrokeWidth + + -- * Internal type + , EdgeSample( .. ) + , pathToPrimitives + ) where + +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) + +-- | 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, 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 + +-- | 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, Show) + +instance Transformable Line where + {-# INLINE transform #-} + transform f (Line a b) = Line (f a) $ f b + +-- | 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, Show) + +instance Transformable Bezier where + {-# INLINE transform #-} + transform f (Bezier a b c) = Bezier (f a) (f b) $ f 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, Show) + +instance Transformable CubicBezier where + {-# INLINE transform #-} + transform f (CubicBezier a b c d) = + CubicBezier (f a) (f b) (f c) $ f 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 + +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) + +-- | 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) + +-- | 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 +