metabrush/src/metabrushes/MetaBrush/Brush.hs

{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE UndecidableInstances  #-}

module MetaBrush.Brush
  ( WithParams(..)
  , NamedBrush(..), SomeBrush(..), BrushFunction
  , PointFields, provePointFields, duplicates
  )
  where

-- base
import Data.Kind
  ( Type, Constraint )
import Data.List
  ( nub )
import Data.Typeable
  ( Typeable )
import GHC.Exts
  ( Proxy#, proxy# )
import GHC.TypeLits
  ( Symbol, someSymbolVal
  , SomeSymbol(..)
  )
import GHC.TypeNats
  ( Nat )

-- deepseq
import Control.DeepSeq
  ( NFData(..) )

-- hashable
import Data.Hashable
  ( Hashable(..) )

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

-- brush-strokes
import Calligraphy.Brushes
  ( Brush(..) )
import Math.Differentiable
  ( DiffInterp )
import Math.Interval
  ( 𝕀 )
import Math.Linear

-- MetaBrush
import qualified MetaBrush.Brush.Widget as Brush
  ( Widget )
import MetaBrush.Records
  ( KnownSymbols, Length, Record )
import MetaBrush.Serialisable
  ( Serialisable )

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

-- | A brush, with default parameter values.
type WithParams :: Nat -> Type
data WithParams nbParams =
  WithParams
    { defaultParams :: ℝ nbParams
    , withParams :: Brush nbParams
    }

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

-- | A brush function: a function from a record of parameters to a closed spline.
type BrushFunction :: [ Symbol ] -> Type
type BrushFunction brushFields =
  WithParams ( Length brushFields )

type NamedBrush :: [ Symbol ] -> Type
data NamedBrush brushFields where
  NamedBrush
    :: forall brushFields
    .  ( KnownSymbols brushFields
       , Representable Double ( ℝ ( Length brushFields ) )
       , DiffInterp 2 ℝ ( Length brushFields )
       , DiffInterp 3 𝕀 ( Length brushFields )
       , Show ( ℝ ( Length brushFields ) )
       )
    => { brushName     :: !Text
       , brushFunction :: !( BrushFunction brushFields )
       , brushWidget   :: !( Brush.Widget brushFields )
       }
    -> NamedBrush brushFields

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

instance Show ( NamedBrush brushFields ) where
  show ( NamedBrush { brushName } ) =
    "NamedBrush\n\
    \  { brushName = "  <> Text.unpack brushName <> "\n\
    \  }"

instance NFData ( NamedBrush brushFields ) where
  rnf ( NamedBrush { brushName } )
    = rnf brushName
instance Eq ( NamedBrush brushFields ) where
  NamedBrush { brushName = name1 } == NamedBrush { brushName = name2 }
    = name1 == name2
instance Ord ( NamedBrush brushFields ) where
  compare ( NamedBrush { brushName = name1 } ) ( NamedBrush { brushName = name2 } )
    = compare name1 name2
instance Hashable ( NamedBrush brushFields ) where
  hashWithSalt salt ( NamedBrush { brushName } ) =
    hashWithSalt salt brushName

type PointFields :: [ Symbol ] -> Constraint
class ( KnownSymbols pointFields, Typeable pointFields
      , Serialisable   ( Record pointFields )
      , Show           ( Record pointFields )
      , Show           ( ℝ ( Length pointFields ) )
      , NFData         ( Record pointFields )
      , Representable  Double   ( ℝ ( Length pointFields ) )
      , RepDim ( ℝ ( Length pointFields ) ) ~ Length pointFields
      , DiffInterp 2 ℝ  ( Length pointFields )
      , DiffInterp 3 𝕀  ( Length pointFields )
      )
   => PointFields pointFields where { }
instance ( KnownSymbols pointFields, Typeable pointFields
         , Serialisable   ( Record pointFields )
         , Show           ( Record pointFields )
         , Show           ( ℝ ( Length pointFields ) )
         , NFData         ( Record pointFields )
         , Representable  Double   ( ℝ ( Length pointFields ) )
         , RepDim ( ℝ ( Length pointFields ) ) ~ Length pointFields
         , DiffInterp 2 ℝ ( Length pointFields )
         , DiffInterp 3 𝕀 ( Length pointFields )
         )
      => PointFields pointFields where { }

-- | Assumes the input has no duplicates (doesn't check.)
provePointFields :: [ Text ]
                 -> ( forall pointFields. PointFields pointFields => Proxy# pointFields -> r )
                 -> r
provePointFields fieldNames k =
  case fieldNames of
    []
      -> k ( proxy# @'[] )
    [ f1 ]
      | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 )
      -> k ( proxy# @'[ f1 ] )
    [ f1, f2 ]
      | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 )
      , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 )
      -> k ( proxy# @'[ f1, f2 ] )
    [ f1, f2, f3 ]
      | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 )
      , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 )
      , SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 )
      -> k ( proxy# @'[ f1, f2, f3 ] )
    [ f1, f2, f3, f4 ]
      | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 )
      , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 )
      , SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 )
      , SomeSymbol @f4 _ <- someSymbolVal ( Text.unpack f4 )
      -> k ( proxy# @'[ f1, f2, f3, f4 ] )
    _ -> error $ "I haven't defined ℝ " ++ show ( length fieldNames )
{-# INLINE provePointFields #-}

duplicates :: [ Text ] -> [ Text ]
duplicates = nub . duplicatesAcc [] []
  where
    duplicatesAcc :: [ Text ] -> [ Text ] -> [ Text ] -> [ Text ]
    duplicatesAcc _    dups [] = dups
    duplicatesAcc seen dups ( k : kvs )
      | k `elem` seen
      = duplicatesAcc seen ( k : dups ) kvs
      | otherwise
      = duplicatesAcc ( k : seen ) dups kvs