brush-strokes-0.1.0.0: src/lib/Calligraphy/Brushes.hs

{-# LANGUAGE AllowAmbiguousTypes  #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE PolyKinds            #-}
{-# LANGUAGE RebindableSyntax     #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE UndecidableInstances #-}

module Calligraphy.Brushes
  ( BrushFn, Brush(..), Corner(..)
  , Unrotated(..)
  , circleBrush
  , ellipseBrush
  , tearDropBrush, tearDropHeightOffset
  , roundTearDropBrush
  ) where

-- base
import Prelude
  hiding
    ( Num(..), Floating(..), (^), (/), fromInteger, fromRational )
import Data.Kind
  ( Type, Constraint )
import GHC.Exts
  ( Proxy#, proxy# )
import GHC.TypeNats
  ( Nat )

-- acts
import Data.Act
  ( Torsor((-->)) )

-- containers
import Data.Sequence
  ( Seq )
import qualified Data.Sequence as Seq
  ( empty, fromList, singleton )

-- brush-strokes
import Math.Algebra.Dual
import Math.Bezier.Spline
import Math.Differentiable
  ( I, IVness(..), SingIVness (..) )
import Math.Interval
  ( 𝕀ℝ, singleton, point )
import Math.Linear
import Math.Module
import Math.Ring

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

-- | The shape of a brush (before applying any rotation).
type BrushFn :: IVness -> Nat -> Nat -> Type
type BrushFn i k nbBrushParams =
  Unrotated
    ( C k ( I i nbBrushParams ) ( Spline Closed () ( I i 2 ) ) )

-- | A newtype wrapper to enforce applying rotation.
newtype Unrotated a = Unrotated { getUnrotated :: a }
  deriving stock ( Eq, Ord, Show, Functor, Foldable, Traversable )

-- | A corner of a brush.
type Corner :: Type -> Type
data Corner a
  = Corner
  { cornerPoint :: a
  , cornerStartTangent, cornerEndTangent :: T a
  }
  deriving stock ( Eq, Show, Functor, Foldable, Traversable )

instance Applicative Corner where
  pure a = Corner a ( T a ) ( T a )
  Corner f ( T g ) ( T h ) <*> Corner a ( T b ) ( T c ) =
    Corner ( f a ) ( T $ g b ) ( T $ h c )

instance forall r a. ( Ring r, Module r ( T a ) ) => Module r ( T ( Corner a ) ) where
  origin = T $ pure $ unT $ origin @r @( T a )
  ( T f ) ^+^ ( T g ) = T $ liftA2 ( \ x y -> unT $ T x ^+^ T y ) f g
  ( T f ) ^-^ ( T g ) = T $ liftA2 ( \ x y -> unT $ T x ^+^ T y ) f g
  a *^ T f = T $ fmap ( \ x -> unT $ a *^ T x ) f

-- | A brush, described as a base shape + an optional rotation.
data Brush nbBrushParams
  = Brush
  { -- | Base brush shape, before applying rotation (if any).
    brushBaseShape  :: BrushFn NonIV 2 nbBrushParams
  , -- | Base brush shape, before applying rotation (if any).
    brushBaseShape3 :: BrushFn NonIV 3 nbBrushParams
    -- | Base brush shape, before applying rotation (if any).
  , brushBaseShapeI :: BrushFn IsIV  3 nbBrushParams

    -- | Brush corners, before applying rotation (if any).
  , brushCorners   :: Seq ( Unrotated ( C 2 ( ℝ nbBrushParams ) ( Corner ( I NonIV 2 ) ) ) )
    -- | Brush corners, before applying rotation (if any).
  , brushCorners3  :: Seq ( Unrotated ( C 3 ( ℝ nbBrushParams ) ( Corner ( I NonIV 2 ) ) ) )
    -- | Brush corners, before applying rotation (if any).
  , brushCornersI  :: Seq ( Unrotated ( C 3 ( 𝕀ℝ nbBrushParams ) ( Corner ( I IsIV 2 ) ) ) )

    -- | Optional rotation angle function
    -- (assumed to be a linear function).
  , mbRotation     :: Maybe ( ℝ nbBrushParams -> Double )
  }

--------------------------------------------------------------------------------
-- Brushes

-- Some convenience type synonyms for brush types... a bit horrible
type ParamsICt :: Nat -> IVness -> Nat -> Constraint
type ParamsICt k i nbParams =
    ( Module
       ( D k nbParams ( I i Double ) )
       ( D k nbParams ( I i 2 ) )
    , Module ( I i Double ) ( T ( I i Double ) )
    , HasChainRule ( I i Double ) k ( I i nbParams )
    , Representable ( I i Double ) ( I i nbParams )
    , Applicative ( D k nbParams )
    , Dim ( I i nbParams ) ~ nbParams
    )

{-# INLINEABLE circleBrush #-}
circleBrush :: Brush 1
circleBrush =
  Brush
    { brushBaseShape  = Unrotated $ circleBrushFn @2 SNonIV
    , brushBaseShape3 = Unrotated $ circleBrushFn @3 SNonIV
    , brushBaseShapeI = Unrotated $ circleBrushFn @3 SIsIV
    , brushCorners    = Seq.empty
    , brushCorners3   = Seq.empty
    , brushCornersI   = Seq.empty
    , mbRotation      = Nothing
    }

{-# INLINEABLE ellipseBrush #-}
ellipseBrush :: Brush 3
ellipseBrush =
  Brush
    { brushBaseShape  = Unrotated $ ellipseBrushFn @2 SNonIV
    , brushBaseShape3 = Unrotated $ ellipseBrushFn @3 SNonIV
    , brushBaseShapeI = Unrotated $ ellipseBrushFn @3 SIsIV
    , brushCorners    = Seq.empty
    , brushCorners3   = Seq.empty
    , brushCornersI   = Seq.empty
    , mbRotation      = Just ( `index` ( Fin 3 ) )
    }

{-# INLINEABLE tearDropBrush #-}
tearDropBrush :: Brush 3
tearDropBrush =
  Brush
    { brushBaseShape  = Unrotated $ tearDropBrushFn @2 SNonIV
    , brushBaseShape3 = Unrotated $ tearDropBrushFn @3 SNonIV
    , brushBaseShapeI = Unrotated $ tearDropBrushFn @3 SIsIV
    , brushCorners    = Seq.singleton $ Unrotated $ tearDropCorner @2 proxy# SNonIV
    , brushCorners3   = Seq.singleton $ Unrotated $ tearDropCorner @3 proxy# SNonIV
    , brushCornersI   = Seq.singleton $ Unrotated $ tearDropCorner @3 proxy# SIsIV
    , mbRotation      = Just ( `index` ( Fin 3 ) )
    }

tearDropHeightOffset :: Double
tearDropHeightOffset = 2 / 14

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

type SplineFn k i nbParams
  =  SingIVness i
  -> C k ( I i nbParams ) ( Spline 'Closed () ( I i 2 ) )

type CornerFn k i nbParams
  =  Proxy# k
  -> SingIVness i
  -> C k ( I i nbParams ) ( Corner ( I i 2 ) )

--------------------------------------------------------------------------------
-- Circle & ellipse

-- | Root of @(Sqrt[2] (4 + 3 κ) - 16) (2 - 3 κ)^2 - 8 (1 - 3 κ) Sqrt[8 - 24 κ + 12 κ^2 + 8 κ^3 + 3 κ^4]@.
--
-- Used to approximate circles and ellipses with Bézier curves.
κ :: Double
κ = 0.5519150244935105707435627227925

circleSpline :: forall d v
             .  Applicative d
             => ( Double -> Double -> d v )
             -> d ( Spline 'Closed () v )
circleSpline p = sequenceA $
  Spline { splineStart  = p 1 0
         , splineCurves = ClosedCurves crvs lastCrv }
  where
    crvs = Seq.fromList
      [ Bezier3To ( p  1  κ ) ( p  κ  1 ) ( NextPoint ( p  0  1 ) ) ()
      , Bezier3To ( p -κ  1 ) ( p -1  κ ) ( NextPoint ( p -1  0 ) ) ()
      , Bezier3To ( p -1 -κ ) ( p -κ -1 ) ( NextPoint ( p  0 -1 ) ) ()
      ]
    lastCrv =
        Bezier3To ( p  κ -1 ) ( p  1 -κ ) BackToStart ()
{-# INLINE circleSpline #-}

mkI1 :: SingIVness i -> Double -> I i Double
mkI1 = \case
  SNonIV -> id
  SIsIV  -> singleton
{-# INLINE mkI1 #-}

mkI2 :: SingIVness i -> ℝ 2 -> I i 2
mkI2 = \case
  SNonIV -> id
  SIsIV  -> point
{-# INLINE mkI2 #-}

circleBrushFn :: forall k i nbParams
              .  ( nbParams ~ 1
                 , ParamsICt k i nbParams
                 )
              => SplineFn k i nbParams
circleBrushFn ivness =
  D \ params ->
    let r :: D k nbParams ( I i Double )
        r = runD ( var @_ @k $ Fin 1 ) params
        mkPt :: Double -> Double -> D k nbParams ( I i 2 )
        mkPt x y
          =   ( r `scaledBy` x ) *^ e_x
          ^+^ ( r `scaledBy` y ) *^ e_y
    in circleSpline mkPt
  where
    e_x, e_y :: D k nbParams ( I i 2 )
    e_x = pure $ mkI2 ivness $ ℝ2 1 0
    e_y = pure $ mkI2 ivness $ ℝ2 0 1

    scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double )
    scaledBy d x = fmap ( mkI1 ivness x * ) d
{-# SPECIALISE circleBrushFn @2 @NonIV #-}
{-# SPECIALISE circleBrushFn @3 @IsIV  #-}

ellipseBrushFn :: forall k i nbParams
               .  ( nbParams ~ 3
                  , ParamsICt k i nbParams
                  )
               => SplineFn k i nbParams
ellipseBrushFn ivness =
  D \ params ->
    let a, b :: D k nbParams ( I i Double )
        a = runD ( var @_ @k $ Fin 1 ) params
        b = runD ( var @_ @k $ Fin 2 ) params
        mkPt :: Double -> Double -> D k nbParams ( I i 2 )
        mkPt x y
          = let !x' = a `scaledBy` x
                !y' = b `scaledBy` y
            in x' *^ e_x ^+^ y' *^ e_y
    in circleSpline mkPt
  where
    e_x, e_y :: D k nbParams ( I i 2 )
    e_x = pure $ mkI2 ivness $ ℝ2 1 0
    e_y = pure $ mkI2 ivness $ ℝ2 0 1

    scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double )
    scaledBy d x = fmap ( mkI1 ivness x * ) d
{-# SPECIALISE ellipseBrushFn @2 @NonIV #-}
{-# SPECIALISE ellipseBrushFn @3 @IsIV  #-}

--------------------------------------------------------------------------------
-- Tear drop

-- | y-coordinate of the center of mass of the cubic Bézier teardrop
-- with control points at (0,0), (±0.5,√3/2).
tearCenter :: Double
tearCenter = 3 * sqrt 3 / 14

-- | Width of the cubic Bézier teardrop with control points at (0,0), (±0.5,√3/2).
tearWidth :: Double
tearWidth = 1 / ( 2 * sqrt 3 )

-- | Height of the cubic Bézier teardrop with control points at (0,0), (±0.5,√3/2).
tearHeight :: Double
tearHeight = 3 * sqrt 3 / 8

-- √3/2
sqrt3_over_2 :: Double
sqrt3_over_2 = 0.5 * sqrt 3

tearDropBrushFn :: forall k i nbParams
                .  ( nbParams ~ 3
                   , ParamsICt k i nbParams
                   )
                => SplineFn k i nbParams
tearDropBrushFn ivness =
  D \ params ->
    let w, h :: D k nbParams ( I i Double )
        w = 2 * runD ( var @_ @k ( Fin 1 ) ) params
        h = 2 * runD ( var @_ @k ( Fin 2 ) ) params
        mkPt :: Double -> Double -> D k nbParams ( I i 2 )
        mkPt x y
          -- 1. translate the teardrop so that the centre of mass is at the origin
          -- 2. scale the teardrop so that it has the requested width/height
          -- 3. rotate (done separately)
          = let !x' = w `scaledBy` ( x / tearWidth )
                !y' = h `scaledBy` ( ( y - tearCenter ) / tearHeight )
            in x' *^ e_x ^+^ y' *^ e_y

    in sequenceA $
         Spline { splineStart  = mkPt 0 0
                , splineCurves = ClosedCurves Seq.empty $
                  Bezier3To
                    ( mkPt  0.5 sqrt3_over_2 )
                    ( mkPt -0.5 sqrt3_over_2 )
                    BackToStart () }
  where
    e_x, e_y :: D k nbParams ( I i 2 )
    e_x = pure $ mkI2 ivness $ ℝ2 1 0
    e_y = pure $ mkI2 ivness $ ℝ2 0 1

    scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double )
    scaledBy d x = fmap ( mkI1 ivness x * ) d
{-# SPECIALISE tearDropBrushFn @2 @NonIV #-}
{-# SPECIALISE tearDropBrushFn @2 @IsIV  #-}

tearDropCorner :: forall k i nbParams. ( nbParams ~ 3, ParamsICt k i nbParams, Torsor ( T ( I i 2 ) ) ( I i 2 ) ) => CornerFn k i nbParams
tearDropCorner _ ivness =
  D \ params ->
    let w, h :: D k nbParams ( I i Double )
        w = 2 * runD ( var @_ @k ( Fin 1 ) ) params
        h = 2 * runD ( var @_ @k ( Fin 2 ) ) params
        mkPt :: Double -> Double -> D k nbParams ( I i 2 )
        mkPt x y
          -- 1. translate the teardrop so that the centre of mass is at the origin
          -- 2. scale the teardrop so that it has the requested width/height
          -- 3. rotate (done separately)
          = let !x' = w `scaledBy` ( x / tearWidth )
                !y' = h `scaledBy` ( ( y - tearCenter ) / tearHeight )
            in x' *^ e_x ^+^ y' *^ e_y
        !cornerPoint = mkPt 0 0
    in sequenceA $
         Corner
          { cornerPoint
          , cornerStartTangent = T $ liftA2 ( \ x y -> unT $ x --> y ) ( mkPt -0.5 sqrt3_over_2 ) cornerPoint
          , cornerEndTangent   = T $ liftA2 ( \ x y -> unT $ x --> y ) cornerPoint ( mkPt 0.5 sqrt3_over_2 )
          }
  where
    e_x, e_y :: D k nbParams ( I i 2 )
    e_x = pure $ mkI2 ivness $ ℝ2 1 0
    e_y = pure $ mkI2 ivness $ ℝ2 0 1

    scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double )
    scaledBy d x = fmap ( mkI1 ivness x * ) d
{-# SPECIALISE tearDropCorner @2 @NonIV #-}
{-# SPECIALISE tearDropCorner @3 @IsIV  #-}

--------------------------------------------------------------------------------
-- Curl Drop

{-# INLINEABLE roundTearDropBrush #-}
roundTearDropBrush :: Brush 3
roundTearDropBrush =
  Brush
    { brushBaseShape  = Unrotated $ roundTearDropBrushFn @2 SNonIV
    , brushBaseShape3 = Unrotated $ roundTearDropBrushFn @3 SNonIV
    , brushBaseShapeI = Unrotated $ roundTearDropBrushFn @3 SIsIV
    , brushCorners    = Seq.fromList
        [ Unrotated $ roundTearDropCorner @2 proxy# SNonIV
        , Unrotated $ roundTearDropSideCorner @2 proxy# SNonIV True
        , Unrotated $ roundTearDropSideCorner @2 proxy# SNonIV False
        ]
    , brushCorners3   = Seq.fromList
        [ Unrotated $ roundTearDropCorner @3 proxy# SNonIV
        , Unrotated $ roundTearDropSideCorner @3 proxy# SNonIV True
        , Unrotated $ roundTearDropSideCorner @3 proxy# SNonIV False
        ]
    , brushCornersI   = Seq.fromList
        [ Unrotated $ roundTearDropCorner @3 proxy# SIsIV
        , Unrotated $ roundTearDropSideCorner @3 proxy# SIsIV True
        , Unrotated $ roundTearDropSideCorner @3 proxy# SIsIV False
        ]
    , mbRotation      = Just ( `index` ( Fin 3 ) )
    }

roundTearDropBrushFn :: forall k i nbParams
                .  ( nbParams ~ 3
                   , ParamsICt k i nbParams
                   )
                => SplineFn k i nbParams
roundTearDropBrushFn ivness =
  D \ params ->
    let h, r :: D k nbParams ( I i Double )
        h = 2 * runD ( var @_ @k ( Fin 1 ) ) params
        r =     runD ( var @_ @k ( Fin 2 ) ) params

        mkPt :: D k nbParams ( I i Double ) -> D k nbParams ( I i Double ) -> D k nbParams ( I i 2 )
        mkPt x y = ( x - h `scaledBy` 0.5 ) *^ e_x ^+^ y *^ e_y

        curves = Seq.fromList
          [
            Bezier2To
              ( mkPt ( r `scaledBy` 0.5 ) -r )
              ( NextPoint ( mkPt ( h - r ) -r ) )
              ()

          , Bezier3To
              ( mkPt ( h + r `scaledBy` ( κ - 1 ) ) -r )
              ( mkPt h ( -r `scaledBy` κ ) )
              ( NextPoint ( mkPt h 0 ) )
              ()

          , Bezier3To
              ( mkPt h ( r `scaledBy` κ ) )
              ( mkPt ( h + r `scaledBy` ( κ - 1 ) ) r )
              ( NextPoint ( mkPt ( h - r ) r ) )
              ()
          ]

        lastCrv =
          Bezier2To
            ( mkPt ( r `scaledBy` 0.5 ) r )
            BackToStart
            ()

    in sequenceA $
         Spline { splineStart  = mkPt 0 0
                , splineCurves = ClosedCurves curves lastCrv
                }
  where
    e_x, e_y :: D k nbParams ( I i 2 )
    e_x = pure $ mkI2 ivness $ ℝ2 1 0
    e_y = pure $ mkI2 ivness $ ℝ2 0 1

    scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double )
    scaledBy d x = fmap ( mkI1 ivness x * ) d
{-# SPECIALISE roundTearDropBrushFn @2 @NonIV #-}
{-# SPECIALISE roundTearDropBrushFn @2 @IsIV  #-}

-- | Main corner of the round tear-drop.
roundTearDropCorner :: forall k i nbParams. ( nbParams ~ 3, ParamsICt k i nbParams, Torsor ( T ( I i 2 ) ) ( I i 2 ) ) => CornerFn k i nbParams
roundTearDropCorner _ ivness =
  D \ params ->
    let h, r :: D k nbParams ( I i Double )
        h = 2 * runD ( var @_ @k ( Fin 1 ) ) params
        r =     runD ( var @_ @k ( Fin 2 ) ) params

        mkPt :: D k nbParams ( I i Double ) -> D k nbParams ( I i Double ) -> D k nbParams ( I i 2 )
        mkPt x y = ( x - h `scaledBy` 0.5 ) *^ e_x ^+^ y *^ e_y

        -- Corner point at the origin
        cornerPoint = mkPt 0 0

        -- First and last control points as defined in roundTearDropBrushFn
        firstControlPoint = mkPt ( r `scaledBy` 0.5 ) -r
        lastControlPoint  = mkPt ( r `scaledBy` 0.5 )  r

    in sequenceA $
         Corner
          { cornerPoint
          -- Define tangent directions based on the control points
          -- Start tangent: from last control point to corner
          , cornerStartTangent = T $ liftA2 ( \ x y -> unT $ x --> y ) lastControlPoint cornerPoint
          -- End tangent: from corner to first control point
          , cornerEndTangent   = T $ liftA2 ( \ x y -> unT $ x --> y ) cornerPoint firstControlPoint
          }
  where
    e_x, e_y :: D k nbParams ( I i 2 )
    e_x = pure $ mkI2 ivness $ ℝ2 1 0
    e_y = pure $ mkI2 ivness $ ℝ2 0 1

    scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double )
    scaledBy d x = fmap ( mkI1 ivness x * ) d
{-# SPECIALISE roundTearDropCorner @2 @NonIV #-}
{-# SPECIALISE roundTearDropCorner @3 @IsIV  #-}

-- | Corner at the side connection points (h - r, ±r).
-- Takes a Boolean parameter to determine if it's the top (True) or bottom (False) corner.
--
-- Weirdly, this isn't really a corner (as it's flat), but because the derivative
-- is not continuous it can cause cusps in the envelope, so we need to
-- treat it as a corner.
roundTearDropSideCorner :: forall k i nbParams.
                         ( nbParams ~ 3
                         , ParamsICt k i nbParams
                         , Torsor ( T ( I i 2 ) ) ( I i 2 )
                         )
                         => Proxy# k
                         -> SingIVness i
                         -> Bool  -- ^ True for top corner, False for bottom corner
                         -> C k ( I i nbParams ) ( Corner ( I i 2 ) )
roundTearDropSideCorner _ ivness isTop =
  D \ params ->
    let h, r :: D k nbParams ( I i Double )
        h = 2 * runD ( var @_ @k ( Fin 1 ) ) params
        r =     runD ( var @_ @k ( Fin 2 ) ) params

        mkPt :: D k nbParams ( I i Double ) -> D k nbParams ( I i Double ) -> D k nbParams ( I i 2 )
        mkPt x y = ( x - h `scaledBy` 0.5 ) *^ e_x ^+^ y *^ e_y

        -- Sign factor based on whether it's top or bottom
        signFactor = if isTop then 1 else -1

        -- Corner point at (h - r, ±r)
        cornerPoint = mkPt (h - r) (r `scaledBy` signFactor)

        -- Control points for the adjacent curves
        -- For top: prevControlPoint is from cubic, nextControlPoint is from quadratic
        -- For bottom: prevControlPoint is from quadratic, nextControlPoint is from cubic
        (prevControlPoint, nextControlPoint) =
          if isTop
            then
              ( mkPt (h + r `scaledBy` (κ - 1)) (r `scaledBy` signFactor)  -- From cubic Bézier
              , mkPt (r `scaledBy` 0.5) (r `scaledBy` signFactor)          -- From quadratic Bézier
              )
            else
              ( mkPt (r `scaledBy` 0.5) (r `scaledBy` signFactor)          -- From quadratic Bézier
              , mkPt (h + r `scaledBy` (κ - 1)) (r `scaledBy` signFactor)  -- From cubic Bézier
              )

    in sequenceA $
         Corner
          { cornerPoint
          , cornerStartTangent = T $ liftA2 ( \ x y -> unT $ x --> y ) prevControlPoint cornerPoint
          , cornerEndTangent   = T $ liftA2 ( \ x y -> unT $ x --> y ) cornerPoint nextControlPoint
          }
  where
    e_x, e_y :: D k nbParams ( I i 2 )
    e_x = pure $ mkI2 ivness $ ℝ2 1 0
    e_y = pure $ mkI2 ivness $ ℝ2 0 1

    scaledBy :: D k nbParams ( I i Double ) -> Double -> D k nbParams ( I i Double )
    scaledBy d x = fmap ( mkI1 ivness x * ) d
{-# SPECIALISE roundTearDropSideCorner @2 @NonIV #-}
{-# SPECIALISE roundTearDropSideCorner @3 @IsIV  #-}