mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-06 07:13:37 +00:00
133 lines
3.9 KiB
Haskell
133 lines
3.9 KiB
Haskell
{-# 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
|