metabrush/src/metabrushes/MetaBrush/Brush.hs

{-# LANGUAGE AllowAmbiguousTypes #-}

module MetaBrush.Brush
  ( Brush(..), 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(..)
  )

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

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

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

-- MetaBrush
import Math.Bezier.Spline
  ( SplineType(Closed), SplinePts)
import MetaBrush.Records
import MetaBrush.Serialisable
import Math.Linear

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

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

type Brush :: [ Symbol ] -> Type
data Brush brushFields where
  BrushData
    :: forall brushFields
    .  ( KnownSymbols brushFields
       , Representable ( ℝ ( Length brushFields) )
       , Typeable brushFields )
    => { brushName     :: !Text
       , brushFunction :: BrushFunction brushFields
       }
    -> Brush brushFields

data SomeBrush where
  SomeBrush
    :: { someBrush :: !( Brush brushFields ) }
    -> SomeBrush

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

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

type PointFields :: [ Symbol ] -> Constraint
class ( KnownSymbols pointFields, Typeable pointFields
      , Serialisable   ( Record pointFields )
      , Show           ( Record pointFields )
      , NFData         ( Record pointFields )
      , Interpolatable ( Record pointFields )
      , Representable  ( ℝ ( Length pointFields ) )
      )
   => PointFields pointFields where { }
instance ( KnownSymbols pointFields, Typeable pointFields
         , Serialisable   ( Record pointFields )
         , Show           ( Record pointFields )
         , NFData         ( Record pointFields )
         , Interpolatable ( Record pointFields )
         , Representable  ( ℝ ( 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 ] )
    _ -> 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