Rasterific 0.7.5.3 → 0.7.5.4
raw patch · 18 files changed
+1009/−1041 lines, 18 filesdep ~basePVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: base
API changes (from Hackage documentation)
- Graphics.Rasterific: data Texture (px :: *)
+ Graphics.Rasterific: data Texture (px :: Type)
- Graphics.Rasterific.Texture: data Texture (px :: *)
+ Graphics.Rasterific.Texture: data Texture (px :: Type)
Files
- Rasterific.cabal +4/−4
- exec-src/docImageGenerator.hs +0/−1
- src/Graphics/Rasterific.hs +0/−2
- src/Graphics/Rasterific/Arc.hs +0/−1
- src/Graphics/Rasterific/Command.hs +3/−2
- src/Graphics/Rasterific/Compositor.hs +3/−1
- src/Graphics/Rasterific/CubicBezier.hs +0/−1
- src/Graphics/Rasterific/Line.hs +0/−2
- src/Graphics/Rasterific/MeshPatch.hs +603/−604
- src/Graphics/Rasterific/MicroPdf.hs +1/−6
- src/Graphics/Rasterific/Patch.hs +0/−12
- src/Graphics/Rasterific/PatchTypes.hs +395/−396
- src/Graphics/Rasterific/PathWalker.hs +0/−2
- src/Graphics/Rasterific/PlaneBoundable.hs +0/−2
- src/Graphics/Rasterific/QuadraticBezier.hs +0/−1
- src/Graphics/Rasterific/Shading.hs +0/−1
- src/Graphics/Rasterific/StrokeInternal.hs +0/−2
- src/Graphics/Rasterific/Transformations.hs +0/−1
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.5.3 +version: 0.7.5.4 synopsis: A pure haskell drawing engine. -- A longer description of the package. description: @@ -24,7 +24,7 @@ -- extra-source-files: -cabal-version: >= 1.18 +cabal-version: 1.18 extra-doc-files: docimages/*.png extra-source-files: changelog , README.md @@ -82,12 +82,12 @@ default-language: Haskell2010 if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + ghc-options: -Wcompat -Wnoncanonical-monad-instances else -- 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 && < 6 + build-depends: base >= 4.9 && < 6 , free >= 4.7 , JuicyPixels >= 3.3.2 , FontyFruity >= 0.5.3.4 && < 0.6
exec-src/docImageGenerator.hs view
@@ -1,6 +1,5 @@ import Control.Monad( forM_ ) import Control.Monad.ST( runST ) -import Data.Monoid( (<>) ) import Codec.Picture import Codec.Picture.Types( promoteImage ) import Graphics.Text.TrueType( loadFontFile )
src/Graphics/Rasterific.hs view
@@ -145,8 +145,6 @@ , dumpDrawing ) where -import Data.Monoid( (<>) ) - import Control.Monad.Free( Free( .. ), liftF ) import Control.Monad.Free.Church( fromF ) import Control.Monad.ST( ST, runST )
src/Graphics/Rasterific/Arc.hs view
@@ -2,7 +2,6 @@ module Graphics.Rasterific.Arc( Direction( .. ), arcInDirection ) where import Data.Maybe( fromMaybe ) -import Data.Monoid( (<>) ) import qualified Data.Vector.Unboxed as VU import Graphics.Rasterific.Transformations
src/Graphics/Rasterific/Command.hs view
@@ -15,7 +15,8 @@ , dumpTexture ) where -import Data.Semigroup( Semigroup( .. ) ) +import Data.Kind ( Type ) + import Control.Monad.ST( ST ) import Control.Monad.State( StateT ) import Control.Monad.Primitive( PrimState ) @@ -62,7 +63,7 @@ type Gradient px = [(Float, px)] -- | Reification of texture type -data Texture (px :: *) +data Texture (px :: Type) = SolidTexture !px | LinearGradientTexture !(Gradient px) !Line | RadialGradientTexture !(Gradient px) !Point !Float
src/Graphics/Rasterific/Compositor.hs view
@@ -16,6 +16,8 @@ , emptyPx ) where +import Data.Kind ( Type ) + import Foreign.Storable( Storable ) import Data.Bits( unsafeShiftR ) import Data.Word( Word8, Word32 ) @@ -38,7 +40,7 @@ , Functor (Holder a) , Foldable (Holder a) , Additive (Holder a) ) => InterpolablePixel a where - type Holder a :: * -> * + type Holder a :: Type -> Type toFloatPixel :: a -> Holder a Float fromFloatPixel :: Holder a Float -> a maxRepresentable :: Proxy a -> Float
src/Graphics/Rasterific/CubicBezier.hs view
@@ -21,7 +21,6 @@ import Prelude hiding( or ) -import Data.Monoid( (<>) ) import Control.Applicative( liftA2 ) import Graphics.Rasterific.Linear ( V2( .. )
src/Graphics/Rasterific/Line.hs view
@@ -14,8 +14,6 @@ , extendLine ) where -import Data.Monoid( (<>) ) - import Graphics.Rasterific.Linear ( V2( .. ) , (^-^)
src/Graphics/Rasterific/MeshPatch.hs view
@@ -1,604 +1,603 @@-{-# 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 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/MicroPdf.hs view
@@ -18,7 +18,6 @@ import Numeric( showFFloat ) import Data.List( sortOn ) -import Data.Monoid( (<>) ) import qualified Data.Foldable as F import Data.Word( Word32 ) import Data.ByteString.Builder( byteString @@ -134,10 +133,6 @@ runPdfEnvs conf firstFreeId producers = runReader (runStateT (sequence producers) $ emptyContext firstFreeId) conf -runPdfEnv :: PdfConfiguration -> PdfId -> PdfEnv a -> (a, PdfContext) -runPdfEnv conf firstFreeId producer = - runReader (runStateT producer $ emptyContext firstFreeId) conf - type Resources = [(B.ByteString, B.ByteString)] data PdfResourceAssoc = PdfResourceAssoc @@ -1136,7 +1131,7 @@ pure $ F.fold textPrint <> after WithPathOrientation path base subDrawings next -> do - toOrders <- asks _pdfConfToOrder + toOrders <- asks (\r -> _pdfConfToOrder r) let orders :: [DrawOrder px] orders = toOrders . liftF $ SetTexture prevTexture subDrawings ()
src/Graphics/Rasterific/Patch.hs view
@@ -85,18 +85,6 @@ -- @ --- TODO: find a new way to calculate that... -maxColorDeepness :: forall px. InterpolablePixel px => ParametricValues px -> Int -maxColorDeepness values = ceiling $ log (maxDelta * range) / log 2 where - range = maxRepresentable (Proxy :: Proxy px) - maxDelta = - maximum [ maxDistance north east - , maxDistance east south - , maxDistance south west - , maxDistance west north] - ParametricValues { _westValue = west, _northValue = north - , _southValue = south, _eastValue = east } = values - estimateCoonSubdivision :: CoonPatch px -> Int estimateCoonSubdivision CoonPatch { .. } = min 8 $ maximum $ estimateFDStepCount <$> [_north, _west, _south, _east]
src/Graphics/Rasterific/PatchTypes.hs view
@@ -1,396 +1,395 @@-{-# 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 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/PathWalker.hs view
@@ -12,8 +12,6 @@ , drawOrdersOnPath ) where -import Data.Monoid( (<>) ) - import Control.Monad.Identity( Identity ) import Control.Monad.State( StateT , MonadTrans
src/Graphics/Rasterific/PlaneBoundable.hs view
@@ -9,8 +9,6 @@ , boundLowerLeftCorner ) where -import Data.Semigroup( Semigroup( .. ) ) - import Graphics.Rasterific.Linear( V2( .. ) ) import Graphics.Rasterific.Types import Graphics.Rasterific.CubicBezier
src/Graphics/Rasterific/QuadraticBezier.hs view
@@ -28,7 +28,6 @@ , lerp ) -import Data.Monoid( (<>) ) import Graphics.Rasterific.Operators import Graphics.Rasterific.Types
src/Graphics/Rasterific/Shading.hs view
@@ -16,7 +16,6 @@ , PrimMonad ) import Data.Fixed( mod' ) -import Data.Monoid( (<>) ) import Graphics.Rasterific.Command import Graphics.Rasterific.BiSampleable import Graphics.Rasterific.Linear
src/Graphics/Rasterific/StrokeInternal.hs view
@@ -10,8 +10,6 @@ , sanitizeFilling ) where -import Data.Monoid( (<>) ) - import Graphics.Rasterific.Linear ( V2( .. ) , (^-^)
src/Graphics/Rasterific/Transformations.hs view
@@ -18,7 +18,6 @@ , inverseTransformation ) where -import Data.Semigroup( Semigroup( .. ) ) import Graphics.Rasterific.Types import Graphics.Rasterific.Linear( V2( .. ), normalize )