Brushes.hs

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

module BrushStroking.Asset.Brushes
  ( SomeBrush(..)
  , lookupBrush, brushes, brushesList, brushNames
  ,   CircleBrushFields       , circle
  ,  EllipseBrushFields       , ellipse
  , TearDropBrushFields       , tearDrop
  , RoundedTearDropBrushFields, roundedTearDrop
  ) where

-- base
import Prelude
  hiding
    ( Num(..), Floating(..), (^), (/), fromInteger, fromRational )
import Data.Coerce
  ( coerce )
import Data.Kind
  ( Type )
import GHC.Exts
  ( fromString )

-- text
import Data.Text
  ( Text )
import qualified Data.Text as Text
  ( toLower )

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

-- brush-strokes
import Calligraphy.Brushes
  ( circleBrush, ellipseBrush
  , tearDropBrush
  , roundTearDropBrush )
import Math.Linear
import Math.Ring

-- MetaBrush
import BrushStroking.Brush
  ( BrushName(..), NamedBrush(..), WithParams(..) )
import BrushStroking.Records
  ( KnownSymbols )

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

type SomeBrush :: Type
data SomeBrush where
  SomeBrush
    :: forall brushFields
    .  KnownSymbols brushFields
    => { someBrush :: !( NamedBrush brushFields )
       }
    -> SomeBrush

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

-- | All brushes supported by this application.
brushes :: HashMap Text SomeBrush
brushes =
  HashMap.fromList
    [ ( nm, b )
    | b@( SomeBrush ( NamedBrush { brushName = BrushName nm } ) ) <- brushesList
    ]

-- | Like 'brushes', but in a list (for when order matters).
brushesList :: [ SomeBrush ]
brushesList = [ SomeBrush circle
              , SomeBrush ellipse
              , SomeBrush tearDrop
              , SomeBrush roundedTearDrop ]

brushNames :: [ Text ]
brushNames = map getName brushesList
  where
    getName :: SomeBrush -> Text
    getName ( SomeBrush ( NamedBrush { brushName = BrushName nm } ) ) = nm

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

type CircleBrushFields = '[ "a" ]
-- | A circular brush with the given radius.
circle :: NamedBrush CircleBrushFields
circle =
  NamedBrush
    { brushName     = BrushName "circle"
    , brushFunction = WithParams deflts $ coerce circleBrush
    }
  where
    deflts = ℝ1 10
{-# INLINE circle #-}

type EllipseBrushFields = '[ "a", "b", "phi" ]
-- | An elliptical brush with the given semi-major and semi-minor axes and
-- angle of rotation.
ellipse :: NamedBrush EllipseBrushFields
ellipse =
  NamedBrush
    { brushName     = BrushName "ellipse"
    , brushFunction = WithParams deflts $ coerce ellipseBrush
    }
  where
    deflts = ℝ3 10 7 0
{-# INLINE ellipse #-}

type TearDropBrushFields = '[ "a", "b", "phi" ]
-- | A tear-drop shape with the given half-width, half-height and angle of rotation.
tearDrop :: NamedBrush TearDropBrushFields
tearDrop =
  NamedBrush
    { brushName     = BrushName "tear-drop"
    , brushFunction = WithParams deflts $ coerce tearDropBrush
    }
  where
    deflts = ℝ3 10 7 0
{-# INLINE tearDrop #-}

type RoundedTearDropBrushFields = '[ "a", "b", "phi" ]
-- | A rounded tear-drop shape, inspired by the paper
-- "Calligraphy Brush Trajectory Control of by a Robotic Arm".
roundedTearDrop :: NamedBrush RoundedTearDropBrushFields
roundedTearDrop =
  NamedBrush
    { brushName     = BrushName "rounded tear-drop"
    , brushFunction = WithParams deflts $ coerce roundTearDropBrush
    }
  where
    deflts = ℝ3 14 5 ( 3 * pi / 4 )
{-# INLINE roundedTearDrop #-}