brush-strokes-0.1.0.0: src/cusps/bench/Bench/Types.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}

module Bench.Types
  ( BrushStroke(..)
  , TestCase(..)
  , Point(..)
  , Params(..)
  , brushStrokeFunctions
  ) where

-- base
import Data.Coerce
  ( coerce )
import Data.Proxy
  ( Proxy(..) )
import Data.Type.Equality
  ( (:~:)(Refl) )
import GHC.Generics
  ( Generic )
import GHC.TypeNats
  ( sameNat )

-- containers
import Data.Sequence
  ( Seq )

-- brush-strokes
import Calligraphy.Brushes
import Math.Algebra.Dual
import Math.Bezier.Spline
import Math.Bezier.Stroke
import Math.Bezier.Stroke.EnvelopeEquation
import Math.Differentiable
import Math.Interval
import Math.Linear
import Math.Module
import Math.Ring
  ( Transcendental )
import Math.Root.Isolation

--------------------------------------------------------------------------------

data BrushStroke =
  forall nbParams. ParamsCt nbParams =>
  BrushStroke
  { brush  :: !( Brush nbParams )
  , stroke :: !( Point nbParams, Curve Open () ( Point nbParams ) )
  }

data TestCase =
  TestCase
  { testDescription :: String
  , testBrushStroke :: BrushStroke
  , testCuspOptions :: RootIsolationOptions N 3
  , testStartBoxes  :: [ ( Int, [ Box 2 ] ) ]
  }

--------------------------------------------------------------------------------

type ParamsCt nbParams
  = ( Show ( ℝ nbParams )
    , HasChainRule Double 2 ( ℝ nbParams )
    , HasChainRule 𝕀 3 ( 𝕀ℝ nbParams )
    , Applicative ( D 2 nbParams )
    , Applicative ( D 3 nbParams )
    , Traversable ( D 2 nbParams )
    , Traversable ( D 3 nbParams )
    , Representable Double ( ℝ nbParams )
    , Representable 𝕀 ( 𝕀ℝ nbParams )
    , Module Double ( T ( ℝ nbParams ) )
    , Module 𝕀 ( T ( 𝕀ℝ nbParams ) )
    , Module ( D 2 nbParams Double ) ( D 2 nbParams ( ℝ 2 ) )
    , Module ( D 3 nbParams 𝕀 ) ( D 3 nbParams ( 𝕀ℝ 2 ) )
    , Transcendental ( D 2 nbParams Double )
    , Transcendental ( D 3 nbParams 𝕀 )
    )

newtype Params nbParams = Params { getParams :: ( ℝ nbParams ) }
deriving newtype instance Show ( ℝ nbParams ) => Show ( Params nbParams )

data Point nbParams =
  Point
    { pointCoords :: !( ℝ 2 )
    , pointParams :: !( Params nbParams ) }
  deriving stock Generic
deriving stock instance Show ( ℝ nbParams ) => Show ( Point nbParams )

getStrokeFunctions
  :: forall nbParams
  .  ParamsCt nbParams
  => Brush nbParams
      -- ^ brush shape
  -> Point nbParams
      -- ^ start point
  -> Curve Open () ( Point nbParams )
      -- ^ curve points
  -> ( ℝ 1 -> ( Seq ( CornerStrokeDatum 2 NonIV )
              , Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) )
     , 𝕀ℝ 1 -> ( Seq ( CornerStrokeDatum 3 IsIV )
               , Seq ( 𝕀ℝ 1  -> StrokeDatum 3 IsIV )
               )
     )
getStrokeFunctions
  ( Brush { brushBaseShape
          , brushBaseShapeI
          , brushCorners
          , brushCornersI
          , mbRotation
          } )
  sp0 crv =
  let
    usedParams :: C 2 ( ℝ 1 ) ( ℝ nbParams )
    path :: C 2 ( ℝ 1 ) ( ℝ 2 )
    ( path, usedParams ) =
      pathAndUsedParams @2 @NonIV @nbParams coerce id id ( getParams . pointParams )
        sp0 crv
    usedParamsI :: C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ nbParams )
    pathI :: C 3 ( 𝕀ℝ 1 ) ( 𝕀ℝ 2 )
    ( pathI, usedParamsI ) =
      pathAndUsedParams @3 @IsIV @nbParams coerce point point ( getParams . pointParams )
        sp0 crv
  in ( brushStrokeData @2 @nbParams SNonIV
        path usedParams
        brushBaseShape
        brushCorners
        mbRotation
     , brushStrokeData @3 @nbParams SIsIV
        pathI usedParamsI
        brushBaseShapeI
        brushCornersI
        ( fmap ( \ rot -> un𝕀ℝ1 . nonDecreasing ( ℝ1 . rot ) ) mbRotation )
     )
{-# INLINEABLE getStrokeFunctions #-}
{-# SPECIALISE getStrokeFunctions @0 #-}
{-# SPECIALISE getStrokeFunctions @1 #-}
{-# SPECIALISE getStrokeFunctions @2 #-}
{-# SPECIALISE getStrokeFunctions @3 #-}
{-# SPECIALISE getStrokeFunctions @4 #-}

brushStrokeFunctions
  :: BrushStroke
  -> ( ℝ 1 -> ( Seq ( CornerStrokeDatum 2 NonIV )
              , Seq ( ℝ 1 -> StrokeDatum 2 NonIV ) )
     , 𝕀ℝ 1 -> ( Seq ( CornerStrokeDatum 3 IsIV )
               , Seq ( 𝕀ℝ 1  -> StrokeDatum 3 IsIV )
               )
     )
brushStrokeFunctions ( BrushStroke { stroke = ( sp0, crv ), brush = brush :: Brush nbParams } )
  -- Trick for triggering specialisation... TODO improve this.
  | Just Refl <- sameNat @nbParams @1 Proxy Proxy
  = getStrokeFunctions @1 brush sp0 crv
  | Just Refl <- sameNat @nbParams @2 Proxy Proxy
  = getStrokeFunctions @2 brush sp0 crv
  | Just Refl <- sameNat @nbParams @3 Proxy Proxy
  = getStrokeFunctions @3 brush sp0 crv
  | Just Refl <- sameNat @nbParams @4 Proxy Proxy
  = getStrokeFunctions @4 brush sp0 crv
  | otherwise
  = getStrokeFunctions @nbParams brush sp0 crv