diff --git a/Rasterific.cabal b/Rasterific.cabal --- a/Rasterific.cabal +++ b/Rasterific.cabal @@ -1,7 +1,7 @@ -- Initial Rasterific.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ name: Rasterific -version: 0.7.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 - diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,6 +1,11 @@ Change log ========== +v0.7.4.1 October 2018 +--------------------- + + * Fix: GHC 8.6 compat + v0.7.4 August 2018 ------------------ diff --git a/docimages/linear_gradient_rotated.png b/docimages/linear_gradient_rotated.png new file mode 100644 Binary files /dev/null and b/docimages/linear_gradient_rotated.png differ diff --git a/docimages/sampled_texture_reflect.png b/docimages/sampled_texture_reflect.png Binary files a/docimages/sampled_texture_reflect.png and b/docimages/sampled_texture_reflect.png differ diff --git a/docimages/strokize_dashed_path.png b/docimages/strokize_dashed_path.png Binary files a/docimages/strokize_dashed_path.png and b/docimages/strokize_dashed_path.png differ diff --git a/src/Graphics/Rasterific/MeshPatch.hs b/src/Graphics/Rasterific/MeshPatch.hs --- a/src/Graphics/Rasterific/MeshPatch.hs +++ b/src/Graphics/Rasterific/MeshPatch.hs @@ -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] ] + diff --git a/src/Graphics/Rasterific/PatchTypes.hs b/src/Graphics/Rasterific/PatchTypes.hs --- a/src/Graphics/Rasterific/PatchTypes.hs +++ b/src/Graphics/Rasterific/PatchTypes.hs @@ -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 - -- @ - -- - -- <> - -- - 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 - -- @ - -- - -- <> - -- - | 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 + -- @ + -- + -- <> + -- + 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 + -- @ + -- + -- <> + -- + | 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 + + diff --git a/src/Graphics/Rasterific/Texture.hs b/src/Graphics/Rasterific/Texture.hs --- a/src/Graphics/Rasterific/Texture.hs +++ b/src/Graphics/Rasterific/Texture.hs @@ -1,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 --- --- <> --- --- With repeat: --- --- > withTexture (withSampler SamplerRepeat $ --- > sampledImageTexture textureImage) $ --- > fill $ rectangle (V2 0 0) 200 200 --- --- <> --- --- With reflect: --- --- > withTexture (withSampler SamplerReflect $ --- > sampledImageTexture textureImage) $ --- > fill $ rectangle (V2 0 0) 200 200 --- --- <> --- -withSampler :: SamplerRepeat -> Texture px -> Texture px -withSampler = 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 --- --- <> --- -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 --- --- <> --- -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 --- --- <> --- -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 --- --- <> --- -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 --- --- <> --- -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 +-- +-- <> +-- +-- With repeat: +-- +-- > withTexture (withSampler SamplerRepeat $ +-- > sampledImageTexture textureImage) $ +-- > fill $ rectangle (V2 0 0) 200 200 +-- +-- <> +-- +-- With reflect: +-- +-- > withTexture (withSampler SamplerReflect $ +-- > sampledImageTexture textureImage) $ +-- > fill $ rectangle (V2 0 0) 200 200 +-- +-- <> +-- +withSampler :: SamplerRepeat -> Texture px -> Texture px +withSampler = 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 +-- +-- <> +-- +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 +-- +-- <> +-- +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 +-- +-- <> +-- +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 +-- +-- <> +-- +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 +-- +-- <> +-- +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 +