PatchTypes.hs

{-# 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