Rasterific 0.7.4 → 0.7.4.1
raw patch · 8 files changed
+1190/−1186 lines, 8 filesdep ~FontyFruitydep ~basebinary-addedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: FontyFruity, base
API changes (from Hackage documentation)
Files
- Rasterific.cabal +5/−6
- changelog +5/−0
- docimages/linear_gradient_rotated.png binary
- docimages/sampled_texture_reflect.png binary
- docimages/strokize_dashed_path.png binary
- src/Graphics/Rasterific/MeshPatch.hs +604/−604
- src/Graphics/Rasterific/PatchTypes.hs +396/−396
- src/Graphics/Rasterific/Texture.hs +180/−180
Rasterific.cabal view
@@ -1,7 +1,7 @@ -- Initial Rasterific.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ name: Rasterific -version: 0.7.4 +version: 0.7.4.1 synopsis: A pure haskell drawing engine. -- A longer description of the package. description: @@ -38,7 +38,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Rasterific.git - Tag: v0.7.4 + Tag: v0.7.4.1 flag embed_linear description: Embed a reduced version of Linear avoiding a (huge) dep @@ -87,10 +87,10 @@ -- provide/emulate `Control.Monad.Fail` and `Data.Semigroups` API for pre-GHC8 build-depends: fail == 4.9.*, semigroups == 0.18.* - build-depends: base >= 4.8 && < 5 + build-depends: base >= 4.8 && < 6 , free >= 4.7 - , JuicyPixels >= 3.2 - , FontyFruity >= 0.5.3.2 && < 0.6 + , JuicyPixels >= 3.3.2 + , FontyFruity >= 0.5.3.4 && < 0.6 , vector >= 0.9 , mtl >= 1.9 , dlist >= 0.6 @@ -103,4 +103,3 @@ if !flag(embed_linear) build-depends: linear >= 1.3 cpp-options: -DEXTERNAL_LINEAR -
changelog view
@@ -1,6 +1,11 @@ Change log ========== +v0.7.4.1 October 2018 +--------------------- + + * Fix: GHC 8.6 compat + v0.7.4 August 2018 ------------------
+ docimages/linear_gradient_rotated.png view
binary file changed (absent → 5693 bytes)
docimages/sampled_texture_reflect.png view
binary file changed (64849 → 64929 bytes)
docimages/strokize_dashed_path.png view
binary file changed (10032 → 10031 bytes)
src/Graphics/Rasterific/MeshPatch.hs view
@@ -1,604 +1,604 @@-{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -#define SVG_2 --- | Module defining the type of mesh patch grid. -module Graphics.Rasterific.MeshPatch - ( -- * Types - InterBezier( .. ) - , Derivatives( .. ) - , MeshPatch( .. ) - , CubicCoefficient( .. ) - - -- * Functions - , calculateMeshColorDerivative - , verticeAt - , generateLinearGrid - , generateImageMesh - - -- * Extraction functions - -- ** Simple - , coonPatchAt - , tensorPatchAt - , coonImagePatchAt - , tensorImagePatchAt - , coonPatchAtWithDerivative - , tensorPatchAtWithDerivative - - -- ** Multiple - , coonPatchesOf - , tensorPatchesOf - , imagePatchesOf - , tensorImagePatchesOf - , cubicCoonPatchesOf - , cubicTensorPatchesOf - - -- * Mutable mesh - , MutableMesh - , thawMesh - , freezeMesh - - -- * Monadic mesh creation - , withMesh - , setVertice - , getVertice - , setHorizPoints - , setVertPoints - , setColor - ) where - -{-import Debug.Trace-} -{-import Text.Printf-} - -import Data.Monoid( (<>) ) -import Control.Monad.ST( runST ) -import Control.Monad.Reader( runReaderT ) -import Control.Monad.Reader.Class -import Control.Monad.Primitive( PrimMonad, PrimState ) -import Data.Vector( (!) ) -import qualified Data.Vector as V -import qualified Data.Vector.Mutable as MV -import qualified Data.Vector.Generic as VG - -import Codec.Picture( Image( imageWidth, imageHeight ) ) -import Graphics.Rasterific.Linear -import Graphics.Rasterific.MiniLens -import Graphics.Rasterific.Types -import Graphics.Rasterific.Compositor -import Graphics.Rasterific.Transformations -import Graphics.Rasterific.PatchTypes - -#ifdef SVG_2 -slopeOf :: (Additive h, Applicative h) - => h Float -> h Float -> h Float - -> Point -> Point -> Point - -> h Float -slopeOf prevColor thisColor nextColor - prevPoint thisPoint nextPoint - | nearZero distPrev || nearZero distNext = zero - | otherwise = slopeVal <$> slopePrev <*> slope <*> slopeNext - where - distPrev = thisPoint `distance` prevPoint - distNext = thisPoint `distance` nextPoint - - slopePrev | nearZero distPrev = zero - | otherwise = (thisColor ^-^ prevColor) ^/ distPrev - slopeNext | nearZero distNext = zero - | otherwise = (nextColor ^-^ thisColor) ^/ distNext - slope = (slopePrev ^+^ slopeNext) ^* 0.5 - - slopeVal :: Float -> Float -> Float -> Float - slopeVal sp s sn - | signum sp /= signum sn = 0 - | abs s > abs minSlope = minSlope - | otherwise = s - where - minSlope - | abs sp < abs sn = 3 * sp - | otherwise = 3 * sn -#else -slopeBasic :: (Additive h) - => h Float -> h Float - -> Point -> Point - -> h Float -slopeBasic prevColor nextColor prevPoint nextPoint - | nearZero d = zero - | otherwise = (nextColor ^-^ prevColor) ^/ d - where - d = prevPoint `distance` nextPoint -#endif - --- | Prepare a gradient mesh to use cubic color interpolation, see --- renderCubicMesh documentation to see the global use of this function. -calculateMeshColorDerivative :: forall px. (InterpolablePixel px) - => MeshPatch px -> MeshPatch (Derivative px) -calculateMeshColorDerivative mesh = mesh { _meshColors = withEdgesDerivatives } where - withEdgesDerivatives = - colorDerivatives V.// (topDerivative <> bottomDerivative <> leftDerivative <> rightDerivative) - colorDerivatives = - V.fromListN (w * h) [interiorDerivative x y | y <- [0 .. h - 1], x <- [0 .. w - 1]] - - w = _meshPatchWidth mesh + 1 - h = _meshPatchHeight mesh + 1 - clampX = max 0 . min (w - 1) - clampY = max 0 . min (h - 1) - - rawColorAt x y =_meshColors mesh V.! (y * w + x) - atColor x y = toFloatPixel $ rawColorAt (clampX x) (clampY y) -#ifdef SVG_2 - isOnVerticalBorder x = x == 0 || x == w - 1 - isOnHorizontalBorder y = y == 0 || y == h - 1 -#endif - - pointAt x y = verticeAt mesh (clampX x) (clampY y) - derivAt x y = colorDerivatives V.! (y * w + x) - - - topDerivative = - [edgeDerivative yDerivative 0 1 x 0 | x <- [1 .. w - 2]] - bottomDerivative = - [edgeDerivative yDerivative 0 (-1) x (h - 1) | x <- [1 .. w - 2]] - leftDerivative = - [edgeDerivative xDerivative 1 0 0 y | y <- [1 .. h - 2]] - rightDerivative = - [edgeDerivative xDerivative (-1) 0 (w - 1) y | y <- [1 .. h - 2]] - - edgeDerivative :: Lens' (Derivative px) (Holder px Float) -> Int -> Int -> Int -> Int - -> (Int, Derivative px) - edgeDerivative coord dx dy x y - | nearZero d = (ix, oldDeriv) - | otherwise = (ix, oldDeriv & coord .~ otherDeriv) - where - ix = y * w + x - oldDeriv = derivAt x y - derivs = oldDeriv .^ coord - otherDeriv = (c ^/ d) ^-^ derivs - c = (atColor (x+dx) (y+dy) ^-^ atColor x y) ^* 2 - d = pointAt (x+dx) (y+dy) `distance` pointAt x y - - -- General case - interiorDerivative x y -#ifdef SVG_2 - | isOnHorizontalBorder y && isOnVerticalBorder x = Derivative thisColor zero zero zero - | isOnHorizontalBorder y = Derivative thisColor dx zero zero - | isOnVerticalBorder x = Derivative thisColor zero dy zero -#endif - | otherwise = Derivative thisColor dx dy dxy - where -#ifdef SVG_2 - dx = slopeOf - cxPrev thisColor cxNext - xPrev this xNext - - dy = slopeOf - cyPrev thisColor cyNext - yPrev this yNext - -- -} - - dxy = zero -#else - dx = slopeBasic cxPrev cxNext xPrev xNext - dy = slopeBasic cyPrev cyNext yPrev yNext - - dxy | nearZero xyDist = zero - | otherwise = (cxyNext ^-^ cyxPrev ^-^ cyxNext ^+^ cxyPrev) ^/ (xyDist) - xyDist = (xNext `distance` xPrev) * (yNext `distance` yPrev) - - cxyPrev = atColor (x - 1) (y - 1) - xyPrev = pointAt (x - 1) (y - 1) - - cxyNext = atColor (x + 1) (y + 1) - xyNext = pointAt (x + 1) (y + 1) - - cyxPrev = atColor (x - 1) (y + 1) - yxPrev = pointAt (x - 1) (y + 1) - - cyxNext = atColor (x + 1) (y - 1) - yxNext = pointAt (x + 1) (y - 1) -#endif - - cxPrev = atColor (x - 1) y - thisColor = atColor x y - cxNext = atColor (x + 1) y - - cyPrev = atColor x (y - 1) - cyNext = atColor x (y + 1) - - xPrev = pointAt (x - 1) y - this = pointAt x y - xNext = pointAt (x + 1) y - - yPrev = pointAt x (y - 1) - yNext = pointAt x (y + 1) - --- | Mutable version of a MeshPatch -data MutableMesh s px = MutableMesh - { _meshMutWidth :: !Int - , _meshMutHeight :: !Int - , _meshMutPrimaryVertices :: !(MV.MVector s Point) - , _meshMutHorizSecondary :: !(MV.MVector s InterBezier) - , _meshMutVertSecondary :: !(MV.MVector s InterBezier) - , _meshMutColors :: !(MV.MVector s px) - , _meshMutTensorDerivatives :: !(Maybe (MV.MVector s Derivatives)) - } - --- | Normal mesh to mutable mesh -thawMesh :: PrimMonad m => MeshPatch px -> m (MutableMesh (PrimState m) px) -thawMesh MeshPatch { .. } = do - let _meshMutWidth = _meshPatchWidth - _meshMutHeight = _meshPatchHeight - _meshMutPrimaryVertices <- V.thaw _meshPrimaryVertices - _meshMutHorizSecondary <- V.thaw _meshHorizontalSecondary - _meshMutVertSecondary <- V.thaw _meshVerticalSecondary - _meshMutColors <- V.thaw _meshColors - _meshMutTensorDerivatives <- case _meshTensorDerivatives of - Nothing -> return Nothing - Just v -> Just <$> V.thaw v - return MutableMesh { .. } - --- | Mutable mesh to freezed mesh. -freezeMesh :: PrimMonad m => MutableMesh (PrimState m) px -> m (MeshPatch px) -freezeMesh MutableMesh { .. } = do - let _meshPatchWidth = _meshMutWidth - _meshPatchHeight = _meshMutHeight - _meshPrimaryVertices <- V.freeze _meshMutPrimaryVertices - _meshHorizontalSecondary <- V.freeze _meshMutHorizSecondary - _meshVerticalSecondary <- V.freeze _meshMutVertSecondary - _meshTensorDerivatives <- case _meshMutTensorDerivatives of - Nothing -> return Nothing - Just v -> Just <$> V.freeze v - _meshColors <- V.freeze _meshMutColors - return MeshPatch { .. } - --- | Retrieve a mesh primary vertice purely -verticeAt :: MeshPatch px - -> Int -- ^ Between 0 and _meshPatchWidth + 1 (excluded) - -> Int -- ^ Between 0 and _meshPatchHeight + 1 (excluded) - -> Point -verticeAt m x y = _meshPrimaryVertices m ! idx where - idx = y * (_meshPatchWidth m + 1) + x - --- | Given an original MeshPatch, provide context to mutate it through --- modification functions. -withMesh :: MeshPatch px - -> (forall m. (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m) => - m a) - -> (a, MeshPatch px) -withMesh mesh act = runST $ do - mut <- thawMesh mesh - v <- runReaderT act mut - final <- freezeMesh mut - return (v, final) - --- | Set the vertice of a mesh at a given coordinate -setVertice :: (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m) - => Int -- ^ x coordinate in [0, w] - -> Int -- ^ y coordinate in [0, h] - -> Point -- ^ new point value - -> m () -setVertice x y p = do - MutableMesh { .. } <- ask - let idx = y * (_meshMutWidth + 1) + x - MV.write _meshMutPrimaryVertices idx p - --- | Get the position of vertice -getVertice :: (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m) - => Int -> Int -> m Point -getVertice x y = do - p <- ask - let idx = y * (_meshMutWidth p + 1) + x - MV.read (_meshMutPrimaryVertices p) idx - --- | Set the two control bezier points horizontally -setHorizPoints :: (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m) - => Int -> Int -> InterBezier -> m () -setHorizPoints x y p = do - MutableMesh { .. } <- ask - let idx = y * _meshMutWidth + x - MV.write _meshMutHorizSecondary idx p - --- | Set the two control bezier points vertically -setVertPoints :: (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m) - => Int -> Int -> InterBezier -> m () -setVertPoints x y p = do - MutableMesh { .. } <- ask - let idx = y * (_meshMutWidth + 1) + x - MV.write _meshMutVertSecondary idx p - - --- | Set the value associated to a vertex -setColor :: (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m) - => Int -> Int -> px -> m () -setColor x y p = do - MutableMesh { .. } <- ask - let idx = y * (_meshMutWidth + 1) + x - MV.write _meshMutColors idx p - --- | Generate a meshpatch at the size given by the image and --- a number of cell in a mesh -generateImageMesh :: Int -- ^ Horizontal cell count - -> Int -- ^ Vertical cell count - -> Point -- ^ Position of the corner upper left - -> Image px -- ^ Image to transform through a mesh - -> MeshPatch (ImageMesh px) -generateImageMesh w h base img = generateLinearGrid w h base (V2 dx dy) infos where - dx = fromIntegral (imageWidth img) / fromIntegral w - dy = fromIntegral (imageHeight img) / fromIntegral h - infos = V.fromListN ((w + 1) * (h + 1)) - [ImageMesh img $ trans <> scaling - | y <- [0 .. h] - , x <- [0 .. w] - , let fx = fromIntegral x - fy = fromIntegral y - trans = translate (V2 (fx * dx) (fy * dy)) - scaling = scale dx dy] - - --- | Generate a valid gradient with the shape of a simple grid --- using some simple information. You can use `thawMesh` and `freezeMesh` --- to mutate it. -generateLinearGrid :: Int -- ^ Width in patch - -> Int -- ^ Height in patch - -> Point -- ^ Position of the upper left corner - -> V2 Float -- ^ Size of each patch in x adn y - -> V.Vector px -- ^ Vector of values, size must be (width + 1) * (height + 1) - -> MeshPatch px -generateLinearGrid w h base (V2 dx dy) colors = MeshPatch - { _meshPatchWidth = w - , _meshPatchHeight = h - , _meshPrimaryVertices = vertices - , _meshHorizontalSecondary = hSecondary - , _meshVerticalSecondary = vSecondary - , _meshTensorDerivatives = Nothing - , _meshColors = colors - } - where - vertexCount = (w + 1) * (h + 1) - vertices = - V.fromListN vertexCount [base ^+^ V2 (dx * fromIntegral x) (dy * fromIntegral y) - | y <- [0 .. h], x <- [0 .. w]] - at x y = vertices ! (y * (w + 1) + x) - hSecondary = V.fromListN ((h + 1) * w) - [InterBezier (p0 ^+^ delta ^* (1/3)) (p0 ^+^ delta ^* (2/3)) - | y <- [0 .. h], x <- [0 .. w - 1] - , let p0 = at x y - p1 = at (x + 1) y - delta = p1 ^-^ p0 - ] - - vSecondary = V.fromListN ((w + 1) * h) - [InterBezier (p0 ^+^ delta ^* (1/3)) (p0 ^+^ delta ^* (2/3)) - | y <- [0 .. h - 1], x <- [0 .. w] - , let p0 = at x y - p1 = at x (y + 1) - delta = p1 ^-^ p0 - ] - -type ColorPreparator px pxt = ParametricValues px -> pxt - --- | Extract a coon patch at a given position. -coonPatchAt :: MeshPatch px - -> Int -- ^ x - -> Int -- ^ y - -> CoonPatch (ParametricValues px) -coonPatchAt = coonPatchAt' id - --- | Extract a tensor patch at a given position -tensorPatchAt :: MeshPatch px - -> Int -- ^ x - -> Int -- ^ y - -> TensorPatch (ParametricValues px) -tensorPatchAt = tensorPatchAt' id - --- | Extract an image patch out of a mesh at a given position. -coonImagePatchAt :: MeshPatch (ImageMesh px) - -> Int -- ^ x - -> Int -- ^ y - -> CoonPatch (ImageMesh px) -coonImagePatchAt = coonPatchAt' _northValue - - --- | Extract a tensor image patch out of a mesh at --- a given position. -tensorImagePatchAt :: MeshPatch (ImageMesh px) - -> Int -- ^ x - -> Int -- ^ y - -> TensorPatch (ImageMesh px) -tensorImagePatchAt = tensorPatchAt' _northValue - --- | Extract a coon patch for cubic interpolation at a given position --- see `calculateMeshColorDerivative` -coonPatchAtWithDerivative :: (InterpolablePixel px) - => MeshPatch (Derivative px) - -> Int -- ^ x - -> Int -- ^ y - -> CoonPatch (CubicCoefficient px) -coonPatchAtWithDerivative = coonPatchAt' cubicPreparator - --- | Extract a tensor patch for cubic interpolation at a given position --- see `calculateMeshColorDerivative` -tensorPatchAtWithDerivative :: (InterpolablePixel px) - => MeshPatch (Derivative px) - -> Int -- ^ x - -> Int -- ^ y - -> TensorPatch (CubicCoefficient px) -tensorPatchAtWithDerivative = tensorPatchAt' cubicPreparator - -rawMatrix :: V.Vector (V.Vector Float) -rawMatrix = V.fromListN 16 $ V.fromListN 16 <$> - [ [ 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ] - , [ 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ] - , [-3, 3, 0, 0, -2,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ] - , [ 2,-2, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ] - , [ 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0 ] - , [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0 ] - , [ 0, 0, 0, 0, 0, 0, 0, 0, -3, 3, 0, 0, -2,-1, 0, 0 ] - , [ 0, 0, 0, 0, 0, 0, 0, 0, 2,-2, 0, 0, 1, 1, 0, 0 ] - , [-3, 0, 3, 0, 0, 0, 0, 0, -2, 0,-1, 0, 0, 0, 0, 0 ] - , [ 0, 0, 0, 0, -3, 0, 3, 0, 0, 0, 0, 0, -2, 0,-1, 0 ] - , [ 9,-9,-9, 9, 6, 3,-6,-3, 6,-6, 3,-3, 4, 2, 2, 1 ] - , [-6, 6, 6,-6, -3,-3, 3, 3, -4, 4,-2, 2, -2,-2,-1,-1 ] - , [ 2, 0,-2, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0 ] - , [ 0, 0, 0, 0, 2, 0,-2, 0, 0, 0, 0, 0, 1, 0, 1, 0 ] - , [-6, 6, 6,-6, -4,-2, 4, 2, -3, 3,-3, 3, -2,-1,-2,-1 ] - , [ 4,-4,-4, 4, 2, 2,-2,-2, 2,-2, 2,-2, 1, 1, 1, 1 ] - ] - -cubicPreparator :: (InterpolablePixel px) - => ParametricValues (Derivative px) - -> CubicCoefficient px -cubicPreparator ParametricValues { .. } = - CubicCoefficient $ ParametricValues (sliceAt 0) (sliceAt 4) (sliceAt 8) (sliceAt 12) where - Derivative c00 fx00 fy00 fxy00 = _northValue - Derivative c10 fx10 fy10 fxy10 = _eastValue - Derivative c01 fx01 fy01 fxy01 = _westValue - Derivative c11 fx11 fy11 fxy11 = _southValue - - resultVector = mulVec $ V.fromListN 16 - [ c00, c10, c01, c11 - , fx00, fx10, fx01, fx11 - , fy00, fy10, fy01, fy11 - ,fxy00, fxy10, fxy01, fxy11 - ] - - mulVec vec = VG.foldl' (^+^) zero . VG.zipWith (^*) vec <$> rawMatrix - - sliceAt i = V4 - (resultVector V.! i) - (resultVector V.! (i + 1)) - (resultVector V.! (i + 2)) - (resultVector V.! (i + 3)) - -tensorPatchAt' :: ColorPreparator px pxt -> MeshPatch px -> Int -> Int - -> TensorPatch pxt -tensorPatchAt' preparator mesh@MeshPatch { _meshTensorDerivatives = Nothing } x y = - toTensorPatch $ coonPatchAt' preparator mesh x y -tensorPatchAt' preparator mesh x y = TensorPatch - { _curve0 = CubicBezier p00 p01 p02 p03 - , _curve1 = CubicBezier p10 p11 p12 p13 - , _curve2 = CubicBezier p20 p21 p22 p23 - , _curve3 = CubicBezier p30 p31 p32 p33 - , _tensorValues = preparator $ ParametricValues - { _northValue = c00 - , _eastValue = c03 - , _southValue = c33 - , _westValue = c30 - } - } - where - w = _meshPatchWidth mesh - vertices = _meshPrimaryVertices mesh - colors = _meshColors mesh - - hInter = _meshHorizontalSecondary mesh - vInter = _meshVerticalSecondary mesh - - baseIx = (w + 1) * y + x - p00 = vertices ! baseIx - c00 = colors ! baseIx - - p03 = vertices ! (baseIx + 1) - c03 = colors ! (baseIx + 1) - - p30 = vertices ! (baseIx + w + 1) - c30 = colors ! (baseIx + w + 1) - p33 = vertices ! (baseIx + w + 2) - c33 = colors ! (baseIx + w + 2) - - baseH = w * y + x - InterBezier p01 p02 = hInter ! baseH - InterBezier p31 p32 = hInter ! (baseH + w) - - baseV = (w + 1) * y + x - InterBezier p10 p20 = vInter ! baseV - InterBezier p13 p23 = vInter ! (baseV + 1) - - Derivatives p11 p12 p21 p22 = case _meshTensorDerivatives mesh of - Nothing -> error "Not a tensor patch" - Just v -> v ! (w * y + x) - - -coonPatchAt' :: ColorPreparator px pxt - -> MeshPatch px -> Int -> Int -> CoonPatch pxt -coonPatchAt' preparator mesh x y = CoonPatch - { _north = CubicBezier p00 p01 p02 p03 - , _east = CubicBezier p03 p13 p23 p33 - , _south = CubicBezier p33 p32 p31 p30 - , _west = CubicBezier p30 p20 p10 p00 - , _coonValues = preparator $ ParametricValues - { _northValue = c00 - , _eastValue = c03 - , _southValue = c33 - , _westValue = c30 - } - } - where - w = _meshPatchWidth mesh - vertices = _meshPrimaryVertices mesh - colors = _meshColors mesh - - hInter = _meshHorizontalSecondary mesh - vInter = _meshVerticalSecondary mesh - - baseIx = (w + 1) * y + x - p00 = vertices ! baseIx - c00 = colors ! baseIx - - p03 = vertices ! (baseIx + 1) - c03 = colors ! (baseIx + 1) - - p30 = vertices ! (baseIx + w + 1) - c30 = colors ! (baseIx + w + 1) - p33 = vertices ! (baseIx + w + 2) - c33 = colors ! (baseIx + w + 2) - - baseH = w * y + x - InterBezier p01 p02 = hInter ! baseH - InterBezier p31 p32 = hInter ! (baseH + w) - - baseV = (w + 1) * y + x - InterBezier p10 p20 = vInter ! baseV - InterBezier p13 p23 = vInter ! (baseV + 1) - --- | Extract a list of all the coon patches of the mesh. -coonPatchesOf :: MeshPatch px -> [CoonPatch (ParametricValues px)] -coonPatchesOf mesh@MeshPatch { .. } = - [coonPatchAt mesh x y | y <- [0 .. _meshPatchHeight - 1], x <- [0 .. _meshPatchWidth - 1]] - --- | Extract a list of all the tensor patches of the mesh. -tensorPatchesOf :: MeshPatch px -> [TensorPatch (ParametricValues px)] -tensorPatchesOf mesh@MeshPatch { .. } = - [tensorPatchAt mesh x y | y <- [0 .. _meshPatchHeight - 1], x <- [0 .. _meshPatchWidth - 1]] - --- | Extract all the coon patch of a mesh using an image interpolation. -imagePatchesOf :: MeshPatch (ImageMesh px) -> [CoonPatch (ImageMesh px)] -imagePatchesOf mesh@MeshPatch { .. } = - [coonImagePatchAt mesh x y | y <- [0 .. _meshPatchHeight - 1], x <- [0 .. _meshPatchWidth - 1]] - --- | Extract all the tensor patch of a mesh using an image interpolation. -tensorImagePatchesOf :: MeshPatch (ImageMesh px) -> [TensorPatch (ImageMesh px)] -tensorImagePatchesOf mesh@MeshPatch { .. } = - [tensorImagePatchAt mesh x y | y <- [0 .. _meshPatchHeight - 1], x <- [0 .. _meshPatchWidth - 1]] - --- | Extract all the coon patch of a mesh using cubic interpolation. -cubicCoonPatchesOf :: (InterpolablePixel px) - => MeshPatch (Derivative px) - -> [CoonPatch (CubicCoefficient px)] -cubicCoonPatchesOf mesh@MeshPatch { .. } = - [coonPatchAtWithDerivative mesh x y - | y <- [0 .. _meshPatchHeight - 1] - , x <- [0 .. _meshPatchWidth - 1] ] - --- | Extract all the tensor patch of a mesh using cubic interpolation. -cubicTensorPatchesOf :: (InterpolablePixel px) - => MeshPatch (Derivative px) - -> [TensorPatch (CubicCoefficient px)] -cubicTensorPatchesOf mesh@MeshPatch { .. } = - [tensorPatchAtWithDerivative mesh x y - | y <- [0 .. _meshPatchHeight - 1] - , x <- [0 .. _meshPatchWidth - 1] ] - +{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+#define SVG_2+-- | Module defining the type of mesh patch grid.+module Graphics.Rasterific.MeshPatch+ ( -- * Types+ InterBezier( .. )+ , Derivatives( .. )+ , MeshPatch( .. )+ , CubicCoefficient( .. )++ -- * Functions+ , calculateMeshColorDerivative+ , verticeAt+ , generateLinearGrid+ , generateImageMesh++ -- * Extraction functions+ -- ** Simple+ , coonPatchAt+ , tensorPatchAt+ , coonImagePatchAt+ , tensorImagePatchAt+ , coonPatchAtWithDerivative+ , tensorPatchAtWithDerivative++ -- ** Multiple+ , coonPatchesOf+ , tensorPatchesOf+ , imagePatchesOf+ , tensorImagePatchesOf+ , cubicCoonPatchesOf+ , cubicTensorPatchesOf++ -- * Mutable mesh+ , MutableMesh+ , thawMesh+ , freezeMesh++ -- * Monadic mesh creation+ , withMesh+ , setVertice+ , getVertice+ , setHorizPoints+ , setVertPoints+ , setColor+ ) where++{-import Debug.Trace-}+{-import Text.Printf-}++import Data.Monoid( (<>) )+import Control.Monad.ST( runST )+import Control.Monad.Reader( runReaderT )+import Control.Monad.Reader.Class+import Control.Monad.Primitive( PrimMonad, PrimState )+import Data.Vector( (!) )+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import qualified Data.Vector.Generic as VG++import Codec.Picture( Image( imageWidth, imageHeight ) )+import Graphics.Rasterific.Linear+import Graphics.Rasterific.MiniLens+import Graphics.Rasterific.Types+import Graphics.Rasterific.Compositor+import Graphics.Rasterific.Transformations+import Graphics.Rasterific.PatchTypes++#ifdef SVG_2+slopeOf :: (Additive h, Applicative h)+ => h Float -> h Float -> h Float+ -> Point -> Point -> Point+ -> h Float+slopeOf prevColor thisColor nextColor+ prevPoint thisPoint nextPoint + | nearZero distPrev || nearZero distNext = zero+ | otherwise = slopeVal <$> slopePrev <*> slope <*> slopeNext+ where+ distPrev = thisPoint `distance` prevPoint+ distNext = thisPoint `distance` nextPoint++ slopePrev | nearZero distPrev = zero+ | otherwise = (thisColor ^-^ prevColor) ^/ distPrev+ slopeNext | nearZero distNext = zero+ | otherwise = (nextColor ^-^ thisColor) ^/ distNext+ slope = (slopePrev ^+^ slopeNext) ^* 0.5++ slopeVal :: Float -> Float -> Float -> Float+ slopeVal sp s sn+ | signum sp /= signum sn = 0+ | abs s > abs minSlope = minSlope+ | otherwise = s+ where+ minSlope+ | abs sp < abs sn = 3 * sp+ | otherwise = 3 * sn+#else+slopeBasic :: (Additive h)+ => h Float -> h Float+ -> Point -> Point+ -> h Float+slopeBasic prevColor nextColor prevPoint nextPoint + | nearZero d = zero+ | otherwise = (nextColor ^-^ prevColor) ^/ d+ where+ d = prevPoint `distance` nextPoint+#endif++-- | Prepare a gradient mesh to use cubic color interpolation, see+-- renderCubicMesh documentation to see the global use of this function.+calculateMeshColorDerivative :: forall px. (InterpolablePixel px)+ => MeshPatch px -> MeshPatch (Derivative px)+calculateMeshColorDerivative mesh = mesh { _meshColors = withEdgesDerivatives } where+ withEdgesDerivatives =+ colorDerivatives V.// (topDerivative <> bottomDerivative <> leftDerivative <> rightDerivative)+ colorDerivatives =+ V.fromListN (w * h) [interiorDerivative x y | y <- [0 .. h - 1], x <- [0 .. w - 1]]++ w = _meshPatchWidth mesh + 1+ h = _meshPatchHeight mesh + 1+ clampX = max 0 . min (w - 1)+ clampY = max 0 . min (h - 1)++ rawColorAt x y =_meshColors mesh V.! (y * w + x)+ atColor x y = toFloatPixel $ rawColorAt (clampX x) (clampY y)+#ifdef SVG_2+ isOnVerticalBorder x = x == 0 || x == w - 1 + isOnHorizontalBorder y = y == 0 || y == h - 1+#endif++ pointAt x y = verticeAt mesh (clampX x) (clampY y)+ derivAt x y = colorDerivatives V.! (y * w + x)+++ topDerivative = + [edgeDerivative yDerivative 0 1 x 0 | x <- [1 .. w - 2]]+ bottomDerivative = + [edgeDerivative yDerivative 0 (-1) x (h - 1) | x <- [1 .. w - 2]]+ leftDerivative =+ [edgeDerivative xDerivative 1 0 0 y | y <- [1 .. h - 2]]+ rightDerivative = + [edgeDerivative xDerivative (-1) 0 (w - 1) y | y <- [1 .. h - 2]]++ edgeDerivative :: Lens' (Derivative px) (Holder px Float) -> Int -> Int -> Int -> Int+ -> (Int, Derivative px)+ edgeDerivative coord dx dy x y+ | nearZero d = (ix, oldDeriv)+ | otherwise = (ix, oldDeriv & coord .~ otherDeriv)+ where+ ix = y * w + x+ oldDeriv = derivAt x y+ derivs = oldDeriv .^ coord+ otherDeriv = (c ^/ d) ^-^ derivs+ c = (atColor (x+dx) (y+dy) ^-^ atColor x y) ^* 2+ d = pointAt (x+dx) (y+dy) `distance` pointAt x y++ -- General case+ interiorDerivative x y+#ifdef SVG_2+ | isOnHorizontalBorder y && isOnVerticalBorder x = Derivative thisColor zero zero zero+ | isOnHorizontalBorder y = Derivative thisColor dx zero zero+ | isOnVerticalBorder x = Derivative thisColor zero dy zero+#endif+ | otherwise = Derivative thisColor dx dy dxy+ where+#ifdef SVG_2+ dx = slopeOf+ cxPrev thisColor cxNext+ xPrev this xNext+ + dy = slopeOf+ cyPrev thisColor cyNext+ yPrev this yNext+ -- -}+ + dxy = zero+#else+ dx = slopeBasic cxPrev cxNext xPrev xNext+ dy = slopeBasic cyPrev cyNext yPrev yNext++ dxy | nearZero xyDist = zero+ | otherwise = (cxyNext ^-^ cyxPrev ^-^ cyxNext ^+^ cxyPrev) ^/ (xyDist)+ xyDist = (xNext `distance` xPrev) * (yNext `distance` yPrev)++ cxyPrev = atColor (x - 1) (y - 1)+ xyPrev = pointAt (x - 1) (y - 1)++ cxyNext = atColor (x + 1) (y + 1)+ xyNext = pointAt (x + 1) (y + 1)++ cyxPrev = atColor (x - 1) (y + 1)+ yxPrev = pointAt (x - 1) (y + 1)++ cyxNext = atColor (x + 1) (y - 1)+ yxNext = pointAt (x + 1) (y - 1)+#endif++ cxPrev = atColor (x - 1) y+ thisColor = atColor x y+ cxNext = atColor (x + 1) y+ + cyPrev = atColor x (y - 1)+ cyNext = atColor x (y + 1)+ + xPrev = pointAt (x - 1) y+ this = pointAt x y+ xNext = pointAt (x + 1) y+ + yPrev = pointAt x (y - 1)+ yNext = pointAt x (y + 1)++-- | Mutable version of a MeshPatch+data MutableMesh s px = MutableMesh+ { _meshMutWidth :: !Int+ , _meshMutHeight :: !Int+ , _meshMutPrimaryVertices :: !(MV.MVector s Point)+ , _meshMutHorizSecondary :: !(MV.MVector s InterBezier)+ , _meshMutVertSecondary :: !(MV.MVector s InterBezier)+ , _meshMutColors :: !(MV.MVector s px)+ , _meshMutTensorDerivatives :: !(Maybe (MV.MVector s Derivatives))+ }++-- | Normal mesh to mutable mesh+thawMesh :: PrimMonad m => MeshPatch px -> m (MutableMesh (PrimState m) px)+thawMesh MeshPatch { .. } = do+ let _meshMutWidth = _meshPatchWidth+ _meshMutHeight = _meshPatchHeight+ _meshMutPrimaryVertices <- V.thaw _meshPrimaryVertices + _meshMutHorizSecondary <- V.thaw _meshHorizontalSecondary+ _meshMutVertSecondary <- V.thaw _meshVerticalSecondary+ _meshMutColors <- V.thaw _meshColors+ _meshMutTensorDerivatives <- case _meshTensorDerivatives of+ Nothing -> return Nothing+ Just v -> Just <$> V.thaw v+ return MutableMesh { .. }++-- | Mutable mesh to freezed mesh.+freezeMesh :: PrimMonad m => MutableMesh (PrimState m) px -> m (MeshPatch px)+freezeMesh MutableMesh { .. } = do+ let _meshPatchWidth = _meshMutWidth+ _meshPatchHeight = _meshMutHeight+ _meshPrimaryVertices <- V.freeze _meshMutPrimaryVertices + _meshHorizontalSecondary <- V.freeze _meshMutHorizSecondary+ _meshVerticalSecondary <- V.freeze _meshMutVertSecondary+ _meshTensorDerivatives <- case _meshMutTensorDerivatives of+ Nothing -> return Nothing+ Just v -> Just <$> V.freeze v+ _meshColors <- V.freeze _meshMutColors+ return MeshPatch { .. }++-- | Retrieve a mesh primary vertice purely+verticeAt :: MeshPatch px+ -> Int -- ^ Between 0 and _meshPatchWidth + 1 (excluded)+ -> Int -- ^ Between 0 and _meshPatchHeight + 1 (excluded)+ -> Point+verticeAt m x y = _meshPrimaryVertices m ! idx where+ idx = y * (_meshPatchWidth m + 1) + x++-- | Given an original MeshPatch, provide context to mutate it through+-- modification functions.+withMesh :: MeshPatch px+ -> (forall m. (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m) =>+ m a)+ -> (a, MeshPatch px)+withMesh mesh act = runST $ do+ mut <- thawMesh mesh+ v <- runReaderT act mut+ final <- freezeMesh mut+ return (v, final)++-- | Set the vertice of a mesh at a given coordinate+setVertice :: (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m)+ => Int -- ^ x coordinate in [0, w]+ -> Int -- ^ y coordinate in [0, h]+ -> Point -- ^ new point value+ -> m ()+setVertice x y p = do+ MutableMesh { .. } <- ask+ let idx = y * (_meshMutWidth + 1) + x+ MV.write _meshMutPrimaryVertices idx p++-- | Get the position of vertice+getVertice :: (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m)+ => Int -> Int -> m Point+getVertice x y = do+ p <- ask+ let idx = y * (_meshMutWidth p + 1) + x+ MV.read (_meshMutPrimaryVertices p) idx++-- | Set the two control bezier points horizontally+setHorizPoints :: (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m)+ => Int -> Int -> InterBezier -> m ()+setHorizPoints x y p = do+ MutableMesh { .. } <- ask+ let idx = y * _meshMutWidth + x+ MV.write _meshMutHorizSecondary idx p++-- | Set the two control bezier points vertically+setVertPoints :: (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m)+ => Int -> Int -> InterBezier -> m ()+setVertPoints x y p = do+ MutableMesh { .. } <- ask+ let idx = y * (_meshMutWidth + 1) + x+ MV.write _meshMutVertSecondary idx p+++-- | Set the value associated to a vertex+setColor :: (MonadReader (MutableMesh (PrimState m) px) m, PrimMonad m)+ => Int -> Int -> px -> m ()+setColor x y p = do+ MutableMesh { .. } <- ask+ let idx = y * (_meshMutWidth + 1) + x+ MV.write _meshMutColors idx p++-- | Generate a meshpatch at the size given by the image and+-- a number of cell in a mesh+generateImageMesh :: Int -- ^ Horizontal cell count+ -> Int -- ^ Vertical cell count+ -> Point -- ^ Position of the corner upper left+ -> Image px -- ^ Image to transform through a mesh+ -> MeshPatch (ImageMesh px)+generateImageMesh w h base img = generateLinearGrid w h base (V2 dx dy) infos where+ dx = fromIntegral (imageWidth img) / fromIntegral w+ dy = fromIntegral (imageHeight img) / fromIntegral h+ infos = V.fromListN ((w + 1) * (h + 1))+ [ImageMesh img $ trans <> scaling+ | y <- [0 .. h]+ , x <- [0 .. w]+ , let fx = fromIntegral x+ fy = fromIntegral y+ trans = translate (V2 (fx * dx) (fy * dy))+ scaling = scale dx dy]+++-- | Generate a valid gradient with the shape of a simple grid+-- using some simple information. You can use `thawMesh` and `freezeMesh`+-- to mutate it.+generateLinearGrid :: Int -- ^ Width in patch+ -> Int -- ^ Height in patch+ -> Point -- ^ Position of the upper left corner+ -> V2 Float -- ^ Size of each patch in x adn y+ -> V.Vector px -- ^ Vector of values, size must be (width + 1) * (height + 1)+ -> MeshPatch px+generateLinearGrid w h base (V2 dx dy) colors = MeshPatch+ { _meshPatchWidth = w+ , _meshPatchHeight = h+ , _meshPrimaryVertices = vertices + , _meshHorizontalSecondary = hSecondary + , _meshVerticalSecondary = vSecondary+ , _meshTensorDerivatives = Nothing+ , _meshColors = colors+ }+ where+ vertexCount = (w + 1) * (h + 1)+ vertices =+ V.fromListN vertexCount [base ^+^ V2 (dx * fromIntegral x) (dy * fromIntegral y)+ | y <- [0 .. h], x <- [0 .. w]]+ at x y = vertices ! (y * (w + 1) + x)+ hSecondary = V.fromListN ((h + 1) * w)+ [InterBezier (p0 ^+^ delta ^* (1/3)) (p0 ^+^ delta ^* (2/3))+ | y <- [0 .. h], x <- [0 .. w - 1]+ , let p0 = at x y+ p1 = at (x + 1) y+ delta = p1 ^-^ p0+ ]++ vSecondary = V.fromListN ((w + 1) * h)+ [InterBezier (p0 ^+^ delta ^* (1/3)) (p0 ^+^ delta ^* (2/3))+ | y <- [0 .. h - 1], x <- [0 .. w]+ , let p0 = at x y+ p1 = at x (y + 1)+ delta = p1 ^-^ p0+ ]++type ColorPreparator px pxt = ParametricValues px -> pxt++-- | Extract a coon patch at a given position.+coonPatchAt :: MeshPatch px+ -> Int -- ^ x+ -> Int -- ^ y+ -> CoonPatch (ParametricValues px)+coonPatchAt = coonPatchAt' id++-- | Extract a tensor patch at a given position+tensorPatchAt :: MeshPatch px+ -> Int -- ^ x+ -> Int -- ^ y+ -> TensorPatch (ParametricValues px)+tensorPatchAt = tensorPatchAt' id++-- | Extract an image patch out of a mesh at a given position.+coonImagePatchAt :: MeshPatch (ImageMesh px)+ -> Int -- ^ x+ -> Int -- ^ y+ -> CoonPatch (ImageMesh px)+coonImagePatchAt = coonPatchAt' _northValue+++-- | Extract a tensor image patch out of a mesh at+-- a given position.+tensorImagePatchAt :: MeshPatch (ImageMesh px)+ -> Int -- ^ x+ -> Int -- ^ y+ -> TensorPatch (ImageMesh px)+tensorImagePatchAt = tensorPatchAt' _northValue++-- | Extract a coon patch for cubic interpolation at a given position+-- see `calculateMeshColorDerivative`+coonPatchAtWithDerivative :: (InterpolablePixel px)+ => MeshPatch (Derivative px)+ -> Int -- ^ x+ -> Int -- ^ y+ -> CoonPatch (CubicCoefficient px)+coonPatchAtWithDerivative = coonPatchAt' cubicPreparator++-- | Extract a tensor patch for cubic interpolation at a given position+-- see `calculateMeshColorDerivative`+tensorPatchAtWithDerivative :: (InterpolablePixel px)+ => MeshPatch (Derivative px)+ -> Int -- ^ x+ -> Int -- ^ y+ -> TensorPatch (CubicCoefficient px)+tensorPatchAtWithDerivative = tensorPatchAt' cubicPreparator++rawMatrix :: V.Vector (V.Vector Float)+rawMatrix = V.fromListN 16 $ V.fromListN 16 <$>+ [ [ 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ]+ , [ 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ]+ , [-3, 3, 0, 0, -2,-1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ]+ , [ 2,-2, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ]+ , [ 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0 ]+ , [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0 ]+ , [ 0, 0, 0, 0, 0, 0, 0, 0, -3, 3, 0, 0, -2,-1, 0, 0 ]+ , [ 0, 0, 0, 0, 0, 0, 0, 0, 2,-2, 0, 0, 1, 1, 0, 0 ]+ , [-3, 0, 3, 0, 0, 0, 0, 0, -2, 0,-1, 0, 0, 0, 0, 0 ]+ , [ 0, 0, 0, 0, -3, 0, 3, 0, 0, 0, 0, 0, -2, 0,-1, 0 ]+ , [ 9,-9,-9, 9, 6, 3,-6,-3, 6,-6, 3,-3, 4, 2, 2, 1 ]+ , [-6, 6, 6,-6, -3,-3, 3, 3, -4, 4,-2, 2, -2,-2,-1,-1 ]+ , [ 2, 0,-2, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 0, 0, 0 ]+ , [ 0, 0, 0, 0, 2, 0,-2, 0, 0, 0, 0, 0, 1, 0, 1, 0 ]+ , [-6, 6, 6,-6, -4,-2, 4, 2, -3, 3,-3, 3, -2,-1,-2,-1 ]+ , [ 4,-4,-4, 4, 2, 2,-2,-2, 2,-2, 2,-2, 1, 1, 1, 1 ]+ ]++cubicPreparator :: (InterpolablePixel px)+ => ParametricValues (Derivative px)+ -> CubicCoefficient px+cubicPreparator ParametricValues { .. } =+ CubicCoefficient $ ParametricValues (sliceAt 0) (sliceAt 4) (sliceAt 8) (sliceAt 12) where+ Derivative c00 fx00 fy00 fxy00 = _northValue+ Derivative c10 fx10 fy10 fxy10 = _eastValue+ Derivative c01 fx01 fy01 fxy01 = _westValue+ Derivative c11 fx11 fy11 fxy11 = _southValue++ resultVector = mulVec $ V.fromListN 16+ [ c00, c10, c01, c11+ , fx00, fx10, fx01, fx11 + , fy00, fy10, fy01, fy11 + ,fxy00, fxy10, fxy01, fxy11+ ]++ mulVec vec = VG.foldl' (^+^) zero . VG.zipWith (^*) vec <$> rawMatrix++ sliceAt i = V4 + (resultVector V.! i)+ (resultVector V.! (i + 1))+ (resultVector V.! (i + 2))+ (resultVector V.! (i + 3))++tensorPatchAt' :: ColorPreparator px pxt -> MeshPatch px -> Int -> Int+ -> TensorPatch pxt+tensorPatchAt' preparator mesh@MeshPatch { _meshTensorDerivatives = Nothing } x y =+ toTensorPatch $ coonPatchAt' preparator mesh x y+tensorPatchAt' preparator mesh x y = TensorPatch+ { _curve0 = CubicBezier p00 p01 p02 p03+ , _curve1 = CubicBezier p10 p11 p12 p13+ , _curve2 = CubicBezier p20 p21 p22 p23+ , _curve3 = CubicBezier p30 p31 p32 p33+ , _tensorValues = preparator $ ParametricValues+ { _northValue = c00+ , _eastValue = c03+ , _southValue = c33+ , _westValue = c30+ }+ }+ where+ w = _meshPatchWidth mesh+ vertices = _meshPrimaryVertices mesh+ colors = _meshColors mesh+ + hInter = _meshHorizontalSecondary mesh+ vInter = _meshVerticalSecondary mesh+ + baseIx = (w + 1) * y + x+ p00 = vertices ! baseIx+ c00 = colors ! baseIx+ + p03 = vertices ! (baseIx + 1)+ c03 = colors ! (baseIx + 1)+ + p30 = vertices ! (baseIx + w + 1)+ c30 = colors ! (baseIx + w + 1)+ p33 = vertices ! (baseIx + w + 2)+ c33 = colors ! (baseIx + w + 2)+ + baseH = w * y + x+ InterBezier p01 p02 = hInter ! baseH+ InterBezier p31 p32 = hInter ! (baseH + w)++ baseV = (w + 1) * y + x+ InterBezier p10 p20 = vInter ! baseV+ InterBezier p13 p23 = vInter ! (baseV + 1)++ Derivatives p11 p12 p21 p22 = case _meshTensorDerivatives mesh of+ Nothing -> error "Not a tensor patch"+ Just v -> v ! (w * y + x)+++coonPatchAt' :: ColorPreparator px pxt+ -> MeshPatch px -> Int -> Int -> CoonPatch pxt+coonPatchAt' preparator mesh x y = CoonPatch + { _north = CubicBezier p00 p01 p02 p03+ , _east = CubicBezier p03 p13 p23 p33+ , _south = CubicBezier p33 p32 p31 p30+ , _west = CubicBezier p30 p20 p10 p00+ , _coonValues = preparator $ ParametricValues+ { _northValue = c00+ , _eastValue = c03+ , _southValue = c33+ , _westValue = c30+ }+ }+ where+ w = _meshPatchWidth mesh+ vertices = _meshPrimaryVertices mesh+ colors = _meshColors mesh+ + hInter = _meshHorizontalSecondary mesh+ vInter = _meshVerticalSecondary mesh+ + baseIx = (w + 1) * y + x+ p00 = vertices ! baseIx+ c00 = colors ! baseIx+ + p03 = vertices ! (baseIx + 1)+ c03 = colors ! (baseIx + 1)+ + p30 = vertices ! (baseIx + w + 1)+ c30 = colors ! (baseIx + w + 1)+ p33 = vertices ! (baseIx + w + 2)+ c33 = colors ! (baseIx + w + 2)+ + baseH = w * y + x+ InterBezier p01 p02 = hInter ! baseH+ InterBezier p31 p32 = hInter ! (baseH + w)++ baseV = (w + 1) * y + x+ InterBezier p10 p20 = vInter ! baseV+ InterBezier p13 p23 = vInter ! (baseV + 1)++-- | Extract a list of all the coon patches of the mesh.+coonPatchesOf :: MeshPatch px -> [CoonPatch (ParametricValues px)]+coonPatchesOf mesh@MeshPatch { .. } =+ [coonPatchAt mesh x y | y <- [0 .. _meshPatchHeight - 1], x <- [0 .. _meshPatchWidth - 1]]++-- | Extract a list of all the tensor patches of the mesh.+tensorPatchesOf :: MeshPatch px -> [TensorPatch (ParametricValues px)]+tensorPatchesOf mesh@MeshPatch { .. } =+ [tensorPatchAt mesh x y | y <- [0 .. _meshPatchHeight - 1], x <- [0 .. _meshPatchWidth - 1]]++-- | Extract all the coon patch of a mesh using an image interpolation.+imagePatchesOf :: MeshPatch (ImageMesh px) -> [CoonPatch (ImageMesh px)]+imagePatchesOf mesh@MeshPatch { .. } =+ [coonImagePatchAt mesh x y | y <- [0 .. _meshPatchHeight - 1], x <- [0 .. _meshPatchWidth - 1]]++-- | Extract all the tensor patch of a mesh using an image interpolation.+tensorImagePatchesOf :: MeshPatch (ImageMesh px) -> [TensorPatch (ImageMesh px)]+tensorImagePatchesOf mesh@MeshPatch { .. } =+ [tensorImagePatchAt mesh x y | y <- [0 .. _meshPatchHeight - 1], x <- [0 .. _meshPatchWidth - 1]]++-- | Extract all the coon patch of a mesh using cubic interpolation.+cubicCoonPatchesOf :: (InterpolablePixel px)+ => MeshPatch (Derivative px)+ -> [CoonPatch (CubicCoefficient px)]+cubicCoonPatchesOf mesh@MeshPatch { .. } =+ [coonPatchAtWithDerivative mesh x y+ | y <- [0 .. _meshPatchHeight - 1]+ , x <- [0 .. _meshPatchWidth - 1] ]++-- | Extract all the tensor patch of a mesh using cubic interpolation.+cubicTensorPatchesOf :: (InterpolablePixel px)+ => MeshPatch (Derivative px)+ -> [TensorPatch (CubicCoefficient px)]+cubicTensorPatchesOf mesh@MeshPatch { .. } =+ [tensorPatchAtWithDerivative mesh x y+ | y <- [0 .. _meshPatchHeight - 1]+ , x <- [0 .. _meshPatchWidth - 1] ]+
src/Graphics/Rasterific/PatchTypes.hs view
@@ -1,396 +1,396 @@-{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -module Graphics.Rasterific.PatchTypes - ( -- * New geometry - CoonPatch( .. ) - , TensorPatch( .. ) - , MeshPatch( .. ) - , InterBezier( .. ) - - -- * Types - , CoonColorWeight - , PatchInterpolation( .. ) - , ParametricValues( .. ) - , Derivative( .. ) - , Derivatives( .. ) - , UV - , UVPatch - , CubicCoefficient( .. ) - , ImageMesh( .. ) - - -- * Helper functions - , transposeParametricValues - , coonPointAt - , toTensorPatch - , foldMeshPoints - , isVerticalOrientation - - -- * Lenses - , xDerivative - , yDerivative - ) where - -import Data.Monoid( (<>) ) -import qualified Data.Vector as V - -import Codec.Picture( Image ) - -import Graphics.Rasterific.CubicBezier -import Graphics.Rasterific.MiniLens -import Graphics.Rasterific.Linear -import Graphics.Rasterific.Types -import Graphics.Rasterific.Compositor -import Graphics.Rasterific.Transformations - --- | Type of coordinate interpolation -type CoonColorWeight = Float - --- | How do we want to perform color/image interpolation --- within the patch. -data PatchInterpolation - = -- | Bilinear interpolation - -- - -- @ - -- import qualified Data.Vector as V - -- let colorCycle = cycle - -- [ PixelRGBA8 0 0x86 0xc1 255 - -- , PixelRGBA8 0xff 0xf4 0xc1 255 - -- , PixelRGBA8 0xFF 0x53 0x73 255 - -- , PixelRGBA8 0xff 0xf4 0xc1 255 - -- , PixelRGBA8 0 0x86 0xc1 255] - -- colors = V.fromListN (4 * 4) colorCycle - -- renderMeshPatch PatchBilinear $ generateLinearGrid 3 3 (V2 10 10) (V2 60 60) colors - -- @ - -- - -- <<docimages/mesh_patch_interp_bilinear.png>> - -- - PatchBilinear - -- | Bicubic interpolation - -- - -- @ - -- import qualified Data.Vector as V - -- let colorCycle = cycle - -- [ PixelRGBA8 0 0x86 0xc1 255 - -- , PixelRGBA8 0xff 0xf4 0xc1 255 - -- , PixelRGBA8 0xFF 0x53 0x73 255 - -- , PixelRGBA8 0xff 0xf4 0xc1 255 - -- , PixelRGBA8 0 0x86 0xc1 255] - -- colors = V.fromListN (4 * 4) colorCycle - -- renderMeshPatch PatchBicubic $ generateLinearGrid 3 3 (V2 10 10) (V2 60 60) colors - -- @ - -- - -- <<docimages/mesh_patch_interp_bicubic.png>> - -- - | PatchBicubic - deriving (Eq, Show) - --- | Values associated to the corner of a patch --- --- @ --- North East --- +--------------+ --- |0 1| --- | | --- | | --- | | --- |3 2| --- +--------------+ --- West South --- @ --- -data ParametricValues a = ParametricValues - { _northValue :: !a - , _eastValue :: !a - , _southValue :: !a - , _westValue :: !a - } - deriving (Functor, Show) - --- | Store the derivative necessary for cubic interpolation in --- the gradient mesh. -data Derivative px = Derivative - { _derivValues :: !(Holder px Float) - , _xDerivative :: !(Holder px Float) - , _yDerivative :: !(Holder px Float) - , _xyDerivative :: !(Holder px Float) - } - -deriving instance Show (Holder px Float) => Show (Derivative px) - --- | Helping lens -xDerivative :: Lens' (Derivative px) (Holder px Float) -xDerivative = lens _xDerivative setter where - setter o v = o { _xDerivative = v } - --- | Help lens -yDerivative :: Lens' (Derivative px) (Holder px Float) -yDerivative = lens _yDerivative setter where - setter o v = o { _yDerivative = v } - -instance Applicative ParametricValues where - pure a = ParametricValues a a a a - ParametricValues n e s w <*> ParametricValues n' e' s' w' = - ParametricValues (n n') (e e') (s s') (w w') - -instance Foldable ParametricValues where - foldMap f (ParametricValues n e s w) = f n <> f e <> f s <> f w - --- | Transpose (switch vertical/horizontal orientation) of values. -transposeParametricValues :: ParametricValues a -> ParametricValues a -transposeParametricValues (ParametricValues n e s w) = ParametricValues n w s e - --- | Describe a tensor patch -data TensorPatch weight = TensorPatch - { _curve0 :: !CubicBezier - , _curve1 :: !CubicBezier - , _curve2 :: !CubicBezier - , _curve3 :: !CubicBezier - , _tensorValues :: !weight - } - -isVerticalOrientation :: TensorPatch a -> Bool -isVerticalOrientation p = dy > dx where - CubicBezier a _ _ d = _curve0 p - V2 dx dy = abs <$> (d ^-^ a) - -instance Transformable (TensorPatch px) where - transform f (TensorPatch c0 c1 c2 c3 v) = - TensorPatch - (transform f c0) - (transform f c1) - (transform f c2) - (transform f c3) - v - transformM f (TensorPatch c0 c1 c2 c3 v) = - TensorPatch - <$> transformM f c0 - <*> transformM f c1 - <*> transformM f c2 - <*> transformM f c3 - <*> return v - - -instance {-# OVERLAPPING #-} PointFoldable (TensorPatch px) where - foldPoints f acc (TensorPatch c0 c1 c2 c3 _) = g c3 . g c2 . g c1 $ g c0 acc - where g v a = foldPoints f a v - --- | Define the boundary and interpolated values of a coon patch. --- --- @ --- -----> --- North _____----------------+ --- ^ +------------// // . --- | // // | --- | // // | --- | // // east | --- | west | / | --- | | v --- \\ \\ . --- \\ __-------------+ --- +----------------/ --- South --- <----- --- @ --- -data CoonPatch weight = CoonPatch - { _north :: !CubicBezier -- ^ North border, from left to right at top - , _east :: !CubicBezier -- ^ East obrder, from top to bottom - , _south :: !CubicBezier -- ^ South border from right to left - , _west :: !CubicBezier -- ^ West border from bottom to top - , _coonValues :: !weight -- ^ The patch values - } - deriving Show - -instance {-# OVERLAPPING #-} Transformable (CoonPatch px) where - transformM = transformCoonM - transform = transformCoon - -instance {-# OVERLAPPING #-} PointFoldable (CoonPatch px) where - foldPoints f acc (CoonPatch n e s w _) = g n . g e . g s $ g w acc - where g v a = foldPoints f a v - -transformCoonM :: Monad m => (Point -> m Point) -> CoonPatch px -> m (CoonPatch px) -transformCoonM f (CoonPatch n e s w v) = - CoonPatch <$> transformM f n <*> transformM f e <*> transformM f s <*> transformM f w - <*> return v - -transformCoon :: (Point -> Point) -> CoonPatch px -> CoonPatch px -transformCoon f (CoonPatch n e s w v) = - CoonPatch - (transform f n) - (transform f e) - (transform f s) - (transform f w) - v - --- | Define a mesh patch grid, the grid is conceptually --- a regular grid of _meshPatchWidth * _meshPatchHeight --- patches but with shared edges -data MeshPatch px = MeshPatch - { -- | Count of horizontal of *patch* - _meshPatchWidth :: !Int - -- | Count of vertical of *patch* - , _meshPatchHeight :: !Int - -- | Main points defining the patch, of size - -- (_meshPatchWidth + 1) * (_meshPatchHeight + 1) - , _meshPrimaryVertices :: !(V.Vector Point) - -- | For each line, store the points in between each - -- vertex. There is two points between each vertex, so - -- _meshPatchWidth * (_meshPatchHeight + 1) points - , _meshHorizontalSecondary :: !(V.Vector InterBezier) - -- | For each colun, store the points in between each - -- vertex. Two points between each vertex, so - -- _meshPatchHeight * (_meshPatchWidth + 1) - , _meshVerticalSecondary :: !(V.Vector InterBezier) - -- | Colors for each vertex points - , _meshColors :: !(V.Vector px) - -- | Points used to define tensor patch, if not define, - -- the rest of the data structure describes a Coon patch. - -- size must be equal to `_meshPatchWidth*_meshPatchHeight` - , _meshTensorDerivatives :: !(Maybe (V.Vector Derivatives)) - } - deriving (Eq, Show, Functor) - --- | Store the two bezier control points of a bezier. -data InterBezier = InterBezier - { _inter0 :: !Point - , _inter1 :: !Point - } - deriving (Eq, Show) - -instance Transformable InterBezier where - transform f (InterBezier a b) = InterBezier (f a) (f b) - transformM f (InterBezier a b) = InterBezier <$> f a <*> f b - -instance PointFoldable InterBezier where - foldPoints f acc (InterBezier a b) = f (f acc a) b - -transformMeshM :: Monad m => (Point -> m Point) -> MeshPatch px -> m (MeshPatch px) -transformMeshM f MeshPatch { .. } = do - vertices <- mapM f _meshPrimaryVertices - hSecondary <- mapM (transformM f) _meshHorizontalSecondary - vSecondary <- mapM (transformM f) _meshVerticalSecondary - return $ MeshPatch - { _meshPatchWidth = _meshPatchWidth - , _meshPatchHeight = _meshPatchHeight - , _meshPrimaryVertices = vertices - , _meshHorizontalSecondary = hSecondary - , _meshVerticalSecondary = vSecondary - , _meshColors = _meshColors - , _meshTensorDerivatives = Nothing - } - -instance {-# OVERLAPPING #-} Transformable (MeshPatch px) where - transformM = transformMeshM - -instance {-# OVERLAPPING #-} PointFoldable (MeshPatch px) where - foldPoints = foldMeshPoints - -foldMeshPoints :: (a -> Point -> a) -> a -> MeshPatch px -> a -foldMeshPoints f acc m = acc4 where - acc1 = V.foldl' f acc (_meshPrimaryVertices m) - acc2 = foldPoints f acc1 (_meshHorizontalSecondary m) - acc3 = foldPoints f acc2 (_meshVerticalSecondary m) - acc4 = case _meshTensorDerivatives m of - Nothing -> acc3 - Just v -> foldPoints f acc3 v - --- | Store the inner points of a tensor patch. -data Derivatives = Derivatives - { _interNorthWest :: !Point - , _interNorthEast :: !Point - , _interSouthWest :: !Point - , _interSouthEast :: !Point - } - deriving (Eq, Show) - -instance Transformable Derivatives where - transform f (Derivatives a b c d) = - Derivatives (f a) (f b) (f c) (f d) - transformM f (Derivatives a b c d) = - Derivatives <$> f a <*> f b <*> f c <*> f d - -instance PointFoldable Derivatives where - foldPoints f acc (Derivatives a b c d) = f (f (f (f acc a) b) c) d - --- | Represent a point in the paramaetric U,V space --- from [0, 1]^2 -type UV = V2 CoonColorWeight - --- | Define a rectangle in the U,V parametric space. -type UVPatch = ParametricValues UV - --- | Store information for cubic interpolation in a patch. -newtype CubicCoefficient px = CubicCoefficient - { getCubicCoefficients :: ParametricValues (V4 (Holder px Float)) - } - --- | Type storing the information to be able to interpolate --- part of an image in a patch. -data ImageMesh px = ImageMesh - { _meshImage :: !(Image px) - , _meshTransform :: !Transformation - } - --- C1: top _north --- C2: bottom _south --- D1: left _west --- D2: right _east - --- | Return a postion of a point in the coon patch. -coonPointAt :: CoonPatch a -> UV -> Point -coonPointAt CoonPatch { .. } (V2 u v) = sc ^+^ sd ^-^ sb - where - CubicBezier c10 _ _ c11 = _north - CubicBezier c21 _ _ c20 = _south - - sc = lerp v c2 c1 - sd = lerp u d2 d1 - sb = lerp v (lerp u c21 c20) - (lerp u c11 c10) - - CubicBezier _ _ _ c1 = fst $ cubicBezierBreakAt _north u - CubicBezier _ _ _ c2 = fst $ cubicBezierBreakAt _south (1 - u) - - CubicBezier _ _ _ d2 = fst $ cubicBezierBreakAt _east v - CubicBezier _ _ _ d1 = fst $ cubicBezierBreakAt _west (1 - v) - --- | Convert a coon patch in -toTensorPatch :: CoonPatch a -> TensorPatch a -toTensorPatch CoonPatch { .. } = TensorPatch - { _curve0 = _north - , _curve1 = CubicBezier wt p11 p21 et - , _curve2 = CubicBezier wb p12 p22 eb - , _curve3 = CubicBezier sd sc sb sa - , _tensorValues = _coonValues - } - where - formula a b c d e f g h = - (a ^* (-4) ^+^ - (b ^+^ c) ^* 6 ^-^ - (d ^+^ e) ^* 2 ^+^ - (f ^+^ g) ^* 3 ^-^ - h) ^* (1/9) - - p11 = formula p00 p10 p01 p30 p03 p13 p31 p33 - p21 = formula p30 p20 p31 p00 p33 p23 p01 p03 - p12 = formula p03 p13 p02 p33 p00 p10 p32 p30 - p22 = formula p33 p23 p32 p03 p30 p20 p02 p00 - - CubicBezier p00 p10 p20 p30 = _north - CubicBezier _ p02 p01 _ = _west - CubicBezier _ p31 p32 _ = _east - CubicBezier p33 p23 p13 p03 = _south - - CubicBezier sa sb sc sd = _south - CubicBezier _ et eb _ = _east - CubicBezier _ wb wt _ = _west - - +{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+module Graphics.Rasterific.PatchTypes+ ( -- * New geometry+ CoonPatch( .. )+ , TensorPatch( .. )+ , MeshPatch( .. )+ , InterBezier( .. )++ -- * Types+ , CoonColorWeight+ , PatchInterpolation( .. )+ , ParametricValues( .. )+ , Derivative( .. )+ , Derivatives( .. )+ , UV+ , UVPatch+ , CubicCoefficient( .. )+ , ImageMesh( .. )++ -- * Helper functions+ , transposeParametricValues + , coonPointAt+ , toTensorPatch+ , foldMeshPoints+ , isVerticalOrientation++ -- * Lenses+ , xDerivative+ , yDerivative+ ) where++import Data.Monoid( (<>) )+import qualified Data.Vector as V++import Codec.Picture( Image )++import Graphics.Rasterific.CubicBezier+import Graphics.Rasterific.MiniLens+import Graphics.Rasterific.Linear+import Graphics.Rasterific.Types+import Graphics.Rasterific.Compositor+import Graphics.Rasterific.Transformations++-- | Type of coordinate interpolation+type CoonColorWeight = Float++-- | How do we want to perform color/image interpolation+-- within the patch.+data PatchInterpolation+ = -- | Bilinear interpolation+ --+ -- @+ -- import qualified Data.Vector as V+ -- let colorCycle = cycle+ -- [ PixelRGBA8 0 0x86 0xc1 255+ -- , PixelRGBA8 0xff 0xf4 0xc1 255+ -- , PixelRGBA8 0xFF 0x53 0x73 255+ -- , PixelRGBA8 0xff 0xf4 0xc1 255+ -- , PixelRGBA8 0 0x86 0xc1 255]+ -- colors = V.fromListN (4 * 4) colorCycle+ -- renderMeshPatch PatchBilinear $ generateLinearGrid 3 3 (V2 10 10) (V2 60 60) colors+ -- @+ --+ -- <<docimages/mesh_patch_interp_bilinear.png>>+ --+ PatchBilinear+ -- | Bicubic interpolation+ --+ -- @+ -- import qualified Data.Vector as V+ -- let colorCycle = cycle+ -- [ PixelRGBA8 0 0x86 0xc1 255+ -- , PixelRGBA8 0xff 0xf4 0xc1 255+ -- , PixelRGBA8 0xFF 0x53 0x73 255+ -- , PixelRGBA8 0xff 0xf4 0xc1 255+ -- , PixelRGBA8 0 0x86 0xc1 255]+ -- colors = V.fromListN (4 * 4) colorCycle+ -- renderMeshPatch PatchBicubic $ generateLinearGrid 3 3 (V2 10 10) (V2 60 60) colors+ -- @+ --+ -- <<docimages/mesh_patch_interp_bicubic.png>>+ --+ | PatchBicubic+ deriving (Eq, Show)++-- | Values associated to the corner of a patch+--+-- @+-- North East+-- +--------------++-- |0 1|+-- | |+-- | |+-- | |+-- |3 2|+-- +--------------++-- West South+-- @+--+data ParametricValues a = ParametricValues+ { _northValue :: !a+ , _eastValue :: !a+ , _southValue :: !a+ , _westValue :: !a+ }+ deriving (Functor, Show)++-- | Store the derivative necessary for cubic interpolation in+-- the gradient mesh.+data Derivative px = Derivative+ { _derivValues :: !(Holder px Float)+ , _xDerivative :: !(Holder px Float)+ , _yDerivative :: !(Holder px Float)+ , _xyDerivative :: !(Holder px Float)+ }++deriving instance Show (Holder px Float) => Show (Derivative px)++-- | Helping lens+xDerivative :: Lens' (Derivative px) (Holder px Float)+xDerivative = lens _xDerivative setter where+ setter o v = o { _xDerivative = v }++-- | Help lens+yDerivative :: Lens' (Derivative px) (Holder px Float)+yDerivative = lens _yDerivative setter where+ setter o v = o { _yDerivative = v }++instance Applicative ParametricValues where+ pure a = ParametricValues a a a a+ ParametricValues n e s w <*> ParametricValues n' e' s' w' =+ ParametricValues (n n') (e e') (s s') (w w')++instance Foldable ParametricValues where+ foldMap f (ParametricValues n e s w) = f n <> f e <> f s <> f w++-- | Transpose (switch vertical/horizontal orientation) of values.+transposeParametricValues :: ParametricValues a -> ParametricValues a+transposeParametricValues (ParametricValues n e s w) = ParametricValues n w s e++-- | Describe a tensor patch+data TensorPatch weight = TensorPatch+ { _curve0 :: !CubicBezier+ , _curve1 :: !CubicBezier+ , _curve2 :: !CubicBezier+ , _curve3 :: !CubicBezier+ , _tensorValues :: !weight+ }++isVerticalOrientation :: TensorPatch a -> Bool+isVerticalOrientation p = dy > dx where+ CubicBezier a _ _ d = _curve0 p+ V2 dx dy = abs <$> (d ^-^ a)++instance Transformable (TensorPatch px) where+ transform f (TensorPatch c0 c1 c2 c3 v) =+ TensorPatch+ (transform f c0)+ (transform f c1)+ (transform f c2)+ (transform f c3)+ v+ transformM f (TensorPatch c0 c1 c2 c3 v) =+ TensorPatch+ <$> transformM f c0+ <*> transformM f c1+ <*> transformM f c2+ <*> transformM f c3+ <*> return v+++instance {-# OVERLAPPING #-} PointFoldable (TensorPatch px) where+ foldPoints f acc (TensorPatch c0 c1 c2 c3 _) = g c3 . g c2 . g c1 $ g c0 acc+ where g v a = foldPoints f a v++-- | Define the boundary and interpolated values of a coon patch.+--+-- @+-- ----->+-- North _____----------------++-- ^ +------------// // .+-- | // // |+-- | // // |+-- | // // east |+-- | west | / |+-- | | v+-- \\ \\ .+-- \\ __-------------++-- +----------------/+-- South+-- <-----+-- @+--+data CoonPatch weight = CoonPatch+ { _north :: !CubicBezier -- ^ North border, from left to right at top+ , _east :: !CubicBezier -- ^ East obrder, from top to bottom+ , _south :: !CubicBezier -- ^ South border from right to left+ , _west :: !CubicBezier -- ^ West border from bottom to top+ , _coonValues :: !weight -- ^ The patch values+ }+ deriving Show++instance {-# OVERLAPPING #-} Transformable (CoonPatch px) where+ transformM = transformCoonM+ transform = transformCoon ++instance {-# OVERLAPPING #-} PointFoldable (CoonPatch px) where+ foldPoints f acc (CoonPatch n e s w _) = g n . g e . g s $ g w acc+ where g v a = foldPoints f a v++transformCoonM :: Monad m => (Point -> m Point) -> CoonPatch px -> m (CoonPatch px)+transformCoonM f (CoonPatch n e s w v) =+ CoonPatch <$> transformM f n <*> transformM f e <*> transformM f s <*> transformM f w+ <*> return v++transformCoon :: (Point -> Point) -> CoonPatch px -> CoonPatch px+transformCoon f (CoonPatch n e s w v) =+ CoonPatch+ (transform f n)+ (transform f e)+ (transform f s)+ (transform f w)+ v++-- | Define a mesh patch grid, the grid is conceptually+-- a regular grid of _meshPatchWidth * _meshPatchHeight+-- patches but with shared edges+data MeshPatch px = MeshPatch+ { -- | Count of horizontal of *patch*+ _meshPatchWidth :: !Int+ -- | Count of vertical of *patch*+ , _meshPatchHeight :: !Int+ -- | Main points defining the patch, of size+ -- (_meshPatchWidth + 1) * (_meshPatchHeight + 1)+ , _meshPrimaryVertices :: !(V.Vector Point)+ -- | For each line, store the points in between each+ -- vertex. There is two points between each vertex, so+ -- _meshPatchWidth * (_meshPatchHeight + 1) points+ , _meshHorizontalSecondary :: !(V.Vector InterBezier)+ -- | For each colun, store the points in between each+ -- vertex. Two points between each vertex, so+ -- _meshPatchHeight * (_meshPatchWidth + 1)+ , _meshVerticalSecondary :: !(V.Vector InterBezier)+ -- | Colors for each vertex points+ , _meshColors :: !(V.Vector px)+ -- | Points used to define tensor patch, if not define,+ -- the rest of the data structure describes a Coon patch.+ -- size must be equal to `_meshPatchWidth*_meshPatchHeight`+ , _meshTensorDerivatives :: !(Maybe (V.Vector Derivatives))+ }+ deriving (Eq, Show, Functor)++-- | Store the two bezier control points of a bezier.+data InterBezier = InterBezier + { _inter0 :: !Point+ , _inter1 :: !Point+ }+ deriving (Eq, Show)++instance Transformable InterBezier where+ transform f (InterBezier a b) = InterBezier (f a) (f b)+ transformM f (InterBezier a b) = InterBezier <$> f a <*> f b++instance PointFoldable InterBezier where+ foldPoints f acc (InterBezier a b) = f (f acc a) b++transformMeshM :: Monad m => (Point -> m Point) -> MeshPatch px -> m (MeshPatch px)+transformMeshM f MeshPatch { .. } = do+ vertices <- mapM f _meshPrimaryVertices+ hSecondary <- mapM (transformM f) _meshHorizontalSecondary+ vSecondary <- mapM (transformM f) _meshVerticalSecondary+ return $ MeshPatch+ { _meshPatchWidth = _meshPatchWidth + , _meshPatchHeight = _meshPatchHeight+ , _meshPrimaryVertices = vertices + , _meshHorizontalSecondary = hSecondary + , _meshVerticalSecondary = vSecondary+ , _meshColors = _meshColors+ , _meshTensorDerivatives = Nothing+ }++instance {-# OVERLAPPING #-} Transformable (MeshPatch px) where+ transformM = transformMeshM++instance {-# OVERLAPPING #-} PointFoldable (MeshPatch px) where+ foldPoints = foldMeshPoints++foldMeshPoints :: (a -> Point -> a) -> a -> MeshPatch px -> a+foldMeshPoints f acc m = acc4 where+ acc1 = V.foldl' f acc (_meshPrimaryVertices m)+ acc2 = foldPoints f acc1 (_meshHorizontalSecondary m)+ acc3 = foldPoints f acc2 (_meshVerticalSecondary m)+ acc4 = case _meshTensorDerivatives m of+ Nothing -> acc3+ Just v -> foldPoints f acc3 v++-- | Store the inner points of a tensor patch.+data Derivatives = Derivatives+ { _interNorthWest :: !Point+ , _interNorthEast :: !Point+ , _interSouthWest :: !Point+ , _interSouthEast :: !Point+ }+ deriving (Eq, Show)++instance Transformable Derivatives where+ transform f (Derivatives a b c d) =+ Derivatives (f a) (f b) (f c) (f d)+ transformM f (Derivatives a b c d) =+ Derivatives <$> f a <*> f b <*> f c <*> f d++instance PointFoldable Derivatives where+ foldPoints f acc (Derivatives a b c d) = f (f (f (f acc a) b) c) d++-- | Represent a point in the paramaetric U,V space+-- from [0, 1]^2+type UV = V2 CoonColorWeight++-- | Define a rectangle in the U,V parametric space.+type UVPatch = ParametricValues UV++-- | Store information for cubic interpolation in a patch.+newtype CubicCoefficient px = CubicCoefficient+ { getCubicCoefficients :: ParametricValues (V4 (Holder px Float))+ }++-- | Type storing the information to be able to interpolate+-- part of an image in a patch.+data ImageMesh px = ImageMesh+ { _meshImage :: !(Image px)+ , _meshTransform :: !Transformation+ }++-- C1: top _north+-- C2: bottom _south+-- D1: left _west+-- D2: right _east++-- | Return a postion of a point in the coon patch.+coonPointAt :: CoonPatch a -> UV -> Point+coonPointAt CoonPatch { .. } (V2 u v) = sc ^+^ sd ^-^ sb+ where+ CubicBezier c10 _ _ c11 = _north+ CubicBezier c21 _ _ c20 = _south++ sc = lerp v c2 c1+ sd = lerp u d2 d1+ sb = lerp v (lerp u c21 c20)+ (lerp u c11 c10)++ CubicBezier _ _ _ c1 = fst $ cubicBezierBreakAt _north u+ CubicBezier _ _ _ c2 = fst $ cubicBezierBreakAt _south (1 - u)++ CubicBezier _ _ _ d2 = fst $ cubicBezierBreakAt _east v+ CubicBezier _ _ _ d1 = fst $ cubicBezierBreakAt _west (1 - v)++-- | Convert a coon patch in+toTensorPatch :: CoonPatch a -> TensorPatch a+toTensorPatch CoonPatch { .. } = TensorPatch+ { _curve0 = _north+ , _curve1 = CubicBezier wt p11 p21 et+ , _curve2 = CubicBezier wb p12 p22 eb+ , _curve3 = CubicBezier sd sc sb sa+ , _tensorValues = _coonValues+ }+ where+ formula a b c d e f g h =+ (a ^* (-4) ^+^+ (b ^+^ c) ^* 6 ^-^+ (d ^+^ e) ^* 2 ^+^+ (f ^+^ g) ^* 3 ^-^+ h) ^* (1/9)++ p11 = formula p00 p10 p01 p30 p03 p13 p31 p33+ p21 = formula p30 p20 p31 p00 p33 p23 p01 p03+ p12 = formula p03 p13 p02 p33 p00 p10 p32 p30+ p22 = formula p33 p23 p32 p03 p30 p20 p02 p00++ CubicBezier p00 p10 p20 p30 = _north+ CubicBezier _ p02 p01 _ = _west+ CubicBezier _ p31 p32 _ = _east+ CubicBezier p33 p23 p13 p03 = _south++ CubicBezier sa sb sc sd = _south+ CubicBezier _ et eb _ = _east+ CubicBezier _ wb wt _ = _west++
src/Graphics/Rasterific/Texture.hs view
@@ -1,180 +1,180 @@-{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} - --- | 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 - , sampledImageTexture - , patternTexture - , meshPatchTexture - - -- * Texture manipulation - , modulateTexture - , transformTexture - ) where - - -import Codec.Picture.Types( Pixel( .. ), Image( .. ) ) -import Graphics.Text.TrueType( Dpi ) -import Graphics.Rasterific -import Graphics.Rasterific.MeshPatch -import Graphics.Rasterific.Command -import Graphics.Rasterific.Transformations - --- | Set the repeat pattern of the texture (if any). --- With padding: --- --- > withTexture (sampledImageTexture textureImage) $ --- > fill $ rectangle (V2 0 0) 200 200 --- --- <<docimages/sampled_texture_pad.png>> --- --- With repeat: --- --- > withTexture (withSampler SamplerRepeat $ --- > sampledImageTexture textureImage) $ --- > fill $ rectangle (V2 0 0) 200 200 --- --- <<docimages/sampled_texture_repeat.png>> --- --- With reflect: --- --- > withTexture (withSampler SamplerReflect $ --- > sampledImageTexture textureImage) $ --- > fill $ rectangle (V2 0 0) 200 200 --- --- <<docimages/sampled_texture_reflect.png>> --- -withSampler :: SamplerRepeat -> Texture px -> Texture px -withSampler = WithSampler - --- | 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 --- --- <<docimages/sampled_texture_scaled.png>> --- -transformTexture :: Transformation -> Texture px -> Texture px -transformTexture = WithTextureTransform - --- | The uniform texture is the simplest texture of all: --- an uniform color. -uniformTexture :: px -- ^ The color used for all the texture. - -> Texture px -uniformTexture = SolidTexture - - --- | Texture using a mesh patch as definition -meshPatchTexture :: PatchInterpolation -> MeshPatch px -> Texture px -meshPatchTexture = MeshPatchTexture - --- | 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 --- --- <<docimages/linear_gradient.png>> --- -linearGradientTexture :: Gradient px -- ^ Gradient description. - -> Point -- ^ Linear gradient start point. - -> Point -- ^ Linear gradient end point. - -> Texture px -linearGradientTexture gradient start end = - LinearGradientTexture gradient (Line start end) - --- | Use another image as a texture for the filling. --- Contrary to `imageTexture`, this function perform a bilinear --- filtering on the texture. --- -sampledImageTexture :: Image px -> Texture px -sampledImageTexture = SampledTexture - --- | 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 gradDef --- > (V2 100 100) 75) $ --- > fill $ circle (V2 100 100) 100 --- --- <<docimages/radial_gradient.png>> --- -radialGradientTexture :: Gradient px -- ^ Gradient description - -> Point -- ^ Radial gradient center - -> Float -- ^ Radial gradient radius - -> Texture px -radialGradientTexture = RadialGradientTexture - --- | 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 gradDef --- > (V2 100 100) 75 (V2 70 70) ) $ --- > fill $ circle (V2 100 100) 100 --- --- <<docimages/radial_gradient_focus.png>> --- -radialGradientWithFocusTexture - :: Gradient px -- ^ Gradient description - -> Point -- ^ Radial gradient center - -> Float -- ^ Radial gradient radius - -> Point -- ^ Radial gradient focus point - -> Texture px -radialGradientWithFocusTexture = RadialGradientWithFocusTexture - --- | Perform a multiplication operation between a full color texture --- and a greyscale one, used for clip-path implementation. -modulateTexture :: Texture px -- ^ The full blown texture. - -> Texture (PixelBaseComponent px) -- ^ A greyscale modulation texture. - -> Texture px -- ^ The resulting texture. -modulateTexture = ModulateTexture - - --- | Use a drawing as a repeating background pattern. --- --- > let pattern = --- > patternTexture 40 40 96 (PixelRGBA8 0xFF 0x53 0x73 255) . --- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 255) $ --- > fill $ circle (V2 20 20) 13 --- > in --- > withTexture pattern $ --- > fill $ roundedRectangle (V2 20 20) 160 160 20 20 --- --- <<docimages/pattern_texture.png>> --- -patternTexture :: RenderablePixel px - => Int -- ^ Width - -> Int -- ^ Height - -> Dpi -- ^ Dpi if text is present in pattern - -> px -- ^ Pattern background color - -> Drawing px () -- ^ Drawing defining the pattern - -> Texture px -patternTexture w h dpi back drawing = - PatternTexture w h back drawing $ - renderDrawingAtDpi w h dpi back drawing - +{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}++-- | 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+ , sampledImageTexture+ , patternTexture+ , meshPatchTexture++ -- * Texture manipulation+ , modulateTexture+ , transformTexture + ) where+++import Codec.Picture.Types( Pixel( .. ), Image( .. ) )+import Graphics.Text.TrueType( Dpi )+import Graphics.Rasterific+import Graphics.Rasterific.MeshPatch+import Graphics.Rasterific.Command+import Graphics.Rasterific.Transformations++-- | Set the repeat pattern of the texture (if any).+-- With padding:+--+-- > withTexture (sampledImageTexture textureImage) $+-- > fill $ rectangle (V2 0 0) 200 200+--+-- <<docimages/sampled_texture_pad.png>>+--+-- With repeat:+--+-- > withTexture (withSampler SamplerRepeat $+-- > sampledImageTexture textureImage) $+-- > fill $ rectangle (V2 0 0) 200 200+--+-- <<docimages/sampled_texture_repeat.png>>+--+-- With reflect:+--+-- > withTexture (withSampler SamplerReflect $+-- > sampledImageTexture textureImage) $+-- > fill $ rectangle (V2 0 0) 200 200+--+-- <<docimages/sampled_texture_reflect.png>>+--+withSampler :: SamplerRepeat -> Texture px -> Texture px+withSampler = WithSampler++-- | 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+--+-- <<docimages/sampled_texture_scaled.png>>+--+transformTexture :: Transformation -> Texture px -> Texture px+transformTexture = WithTextureTransform++-- | The uniform texture is the simplest texture of all:+-- an uniform color.+uniformTexture :: px -- ^ The color used for all the texture.+ -> Texture px+uniformTexture = SolidTexture+++-- | Texture using a mesh patch as definition+meshPatchTexture :: PatchInterpolation -> MeshPatch px -> Texture px+meshPatchTexture = MeshPatchTexture++-- | 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+--+-- <<docimages/linear_gradient.png>>+--+linearGradientTexture :: Gradient px -- ^ Gradient description.+ -> Point -- ^ Linear gradient start point.+ -> Point -- ^ Linear gradient end point.+ -> Texture px+linearGradientTexture gradient start end =+ LinearGradientTexture gradient (Line start end)++-- | Use another image as a texture for the filling.+-- Contrary to `imageTexture`, this function perform a bilinear+-- filtering on the texture.+--+sampledImageTexture :: Image px -> Texture px+sampledImageTexture = SampledTexture++-- | 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 gradDef+-- > (V2 100 100) 75) $+-- > fill $ circle (V2 100 100) 100+--+-- <<docimages/radial_gradient.png>>+--+radialGradientTexture :: Gradient px -- ^ Gradient description+ -> Point -- ^ Radial gradient center+ -> Float -- ^ Radial gradient radius+ -> Texture px+radialGradientTexture = RadialGradientTexture++-- | 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 gradDef+-- > (V2 100 100) 75 (V2 70 70) ) $+-- > fill $ circle (V2 100 100) 100+--+-- <<docimages/radial_gradient_focus.png>>+--+radialGradientWithFocusTexture+ :: Gradient px -- ^ Gradient description+ -> Point -- ^ Radial gradient center+ -> Float -- ^ Radial gradient radius+ -> Point -- ^ Radial gradient focus point+ -> Texture px+radialGradientWithFocusTexture = RadialGradientWithFocusTexture++-- | Perform a multiplication operation between a full color texture+-- and a greyscale one, used for clip-path implementation.+modulateTexture :: Texture px -- ^ The full blown texture.+ -> Texture (PixelBaseComponent px) -- ^ A greyscale modulation texture.+ -> Texture px -- ^ The resulting texture.+modulateTexture = ModulateTexture+++-- | Use a drawing as a repeating background pattern.+--+-- > let pattern =+-- > patternTexture 40 40 96 (PixelRGBA8 0xFF 0x53 0x73 255) .+-- > withTexture (uniformTexture $ PixelRGBA8 0 0x86 0xc1 255) $+-- > fill $ circle (V2 20 20) 13+-- > in+-- > withTexture pattern $+-- > fill $ roundedRectangle (V2 20 20) 160 160 20 20+--+-- <<docimages/pattern_texture.png>>+--+patternTexture :: RenderablePixel px+ => Int -- ^ Width+ -> Int -- ^ Height+ -> Dpi -- ^ Dpi if text is present in pattern+ -> px -- ^ Pattern background color+ -> Drawing px () -- ^ Drawing defining the pattern+ -> Texture px+patternTexture w h dpi back drawing =+ PatternTexture w h back drawing $+ renderDrawingAtDpi w h dpi back drawing+