metabrush/src/metabrushes/MetaBrush/Asset/Brushes.hs

{-# LANGUAGE OverloadedStrings #-}

module MetaBrush.Asset.Brushes where

-- base
import Data.Coerce
  ( coerce )

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

-- text
import Data.Text
  ( Text )

-- unordered-containers
import Data.HashMap.Strict
  ( HashMap )
import qualified Data.HashMap.Strict as HashMap
  ( fromList, lookup )

-- MetaBrush
import Math.Bezier.Spline
import Math.Linear
  ( Point2D(..), ℝ(..), T(..) )
import Math.Linear.Dual
  ( D, type (~>)(..), Var(var), konst )
import Math.Module
  ( Module((^+^), (*^)) )
import MetaBrush.Brush
  ( Brush(..), SomeBrush(..) )
import MetaBrush.Records

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

type CircleBrushFields = '[ "r" ]

lookupBrush :: Text -> Maybe SomeBrush
lookupBrush nm = HashMap.lookup nm brushes

-- | All brushes supported by this application.
brushes :: HashMap Text SomeBrush
brushes = HashMap.fromList
  [ ( nm, b )
  | b@( SomeBrush ( BrushData { brushName = nm } ) )
    <- [ SomeBrush circle, SomeBrush 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 :: (Double -> Double -> ptData) -> Spline 'Closed () ptData
circleSpline p =
  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 ()

circle :: Brush CircleBrushFields
circle = BrushData "circle" (WithParams deflts shape)
  where
    deflts :: Record CircleBrushFields
    deflts = MkR ( ℝ1 1 )
    shape :: Record CircleBrushFields -> SplinePts 'Closed
    shape ( MkR ( ℝ1 r ) ) =
      circleSpline ( \ x y -> Point2D (r * x) (r * y) )

type EllipseBrushFields = '[ "a", "b", "phi" ]

ellipse :: Brush EllipseBrushFields
ellipse = BrushData "ellipse" (WithParams deflts shape)
  where
    deflts :: Record EllipseBrushFields
    deflts = MkR ( ℝ3 1 1 0 )
    shape :: Record EllipseBrushFields -> SplinePts 'Closed
    shape ( MkR ( ℝ3 a b phi ) ) =
      circleSpline ( \ x y -> Point2D (a * x * cos phi - b * y * sin phi)
                                      (b * y * cos phi + a * x * sin phi) )

--------------------------------------------------------------------------------
-- Differentiable brushes.

circleSpline2 :: ( Double -> Double -> D ( ℝ 3 ) ptData ) -> D ( ℝ 3 ) ( Spline 'Closed () ptData )
circleSpline2 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 ()

ellipseBrush :: ℝ 3 ~> Spline 'Closed () ( ℝ 2 )
ellipseBrush =
  D \ params ->
    let a, b, phi :: D ( ℝ 3 ) Double
        a   = runD ( var @1 ) params
        b   = runD ( var @2 ) params
        phi = runD ( var @3 ) params
        mkPt :: Double -> Double -> D ( ℝ 3 ) ( ℝ 2 )
        mkPt ( konst -> x ) ( konst -> y )
          = fmap coerce
          $   ( x * a * cos phi - y * b * sin phi ) *^ e_x
          ^+^ ( y * b * cos phi + x * a * sin phi ) *^ e_y
    in circleSpline2 mkPt
  where
    e_x, e_y :: D ( ℝ 3 ) ( T ( ℝ 2 ) )
    e_x = pure $ T $ ℝ2 1 0
    e_y = pure $ T $ ℝ2 0 1

--ellipseArc :: ℝ 2 ~> ℝ 2
--ellipseArc = brushStroke ( linear myPath ) ( uncurryD $ fmap bezier3 myBrush )

--testing :: Double -> Double -> (# Double, T ( ℝ 2 ) #)
--testing :: Double -> Double -> (# Double, T (ℝ 2) #)
--testing t s = envelopeEquation ellipseArc t s