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

{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}

module MetaBrush.Asset.Brushes where

-- 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.Vector2D
import MetaBrush.Brush
  ( Brush(..), SomeBrush(..) )
import MetaBrush.Records
  ( Rec, WithParams(..), I(..) )
import qualified MetaBrush.Records as Rec

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

type CircleBrushFields = '[ '("r", Double) ]

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.
c :: Double
c = 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    c)  (p   c    1 ) (NextPoint (p   0    1 )) ()
      , Bezier3To (p (-c)   1)  (p (-1)   c ) (NextPoint (p (-1)   0 )) ()
      , Bezier3To (p (-1) (-c)) (p (-c) (-1)) (NextPoint (p   0  (-1))) ()
      ]
    lastCrv =
        Bezier3To (p   c  (-1)) (p   1  (-c)) BackToStart ()

circle :: Brush CircleBrushFields
circle = BrushData "circle" (WithParams deflts shape)
  where
    deflts :: Rec CircleBrushFields
    deflts = Rec.insert @"r" (I 1) Rec.empty
    shape :: Rec CircleBrushFields -> SplinePts 'Closed
    shape params =
      let !(I !r) = Rec.lookup @"r" params
      in circleSpline ( \ x y -> Point2D (r * x) (r * y) )

type EllipseBrushFields = '[ '("a", Double), '("b", Double), '("phi", Double) ]

ellipse :: Brush EllipseBrushFields
ellipse = BrushData "ellipse" (WithParams deflts shape)
  where
    deflts :: Rec EllipseBrushFields
    deflts = Rec.insert @"a"   (I 1)
           $ Rec.insert @"b"   (I 1)
           $ Rec.insert @"phi" (I 0)
           $ Rec.empty
    shape :: Rec EllipseBrushFields -> SplinePts 'Closed
    shape params =
      let
        !(I !a  ) = Rec.lookup @"a"   params
        !(I !b  ) = Rec.lookup @"b"   params
        !(I !phi) = Rec.lookup @"phi" params
      in circleSpline ( \ x y -> Point2D (a * x * cos phi - b * y * sin phi)
                                         (b * y * cos phi + a * x * sin phi) )