{-# 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