metabrush/src/metabrushes/MetaBrush/Brush.hs

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

module MetaBrush.Brush
  ( WithParams(..)
  , 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.Algebra.Dual
  ( C )
import Math.Bezier.Spline
  ( SplineType(Closed), Spline )
import Math.Differentiable
  ( DiffInterp, ExtentOrder )
import Math.Interval
  ( type I, Extent(Point, Interval) )
import Math.Linear
import MetaBrush.Records
  ( KnownSymbols, Length, Record )
import MetaBrush.Serialisable
  ( Serialisable )

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

-- | A differentiable function from a given record type,
-- with provided default values that can be overridden.
type WithParams :: Type -> ( Type -> Type ) -> Type
data WithParams params f =
  WithParams
    { defaultParams :: params
    , withParams
        :: forall i
        .  ( DiffInterp i params )
        => Proxy# i
        -> ( forall a. a -> I i a )
        -> C ( ExtentOrder i ) ( I i params ) ( f ( I i ( ℝ 2 ) ) )
    }

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

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

type Brush :: [ Symbol ] -> Type
data Brush brushFields where
  BrushData
    :: forall brushFields
    .  ( KnownSymbols brushFields, Typeable brushFields
       , Representable Double ( ℝ ( Length brushFields ) )
       , DiffInterp Point     ( ℝ ( Length brushFields ) )
       , DiffInterp Interval  ( ℝ ( Length 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 )
      , Representable  Double   ( ℝ ( Length pointFields ) )
      , DiffInterp Point    ( ℝ ( Length pointFields ) )
      , DiffInterp Interval ( ℝ ( Length pointFields ) )
      )
   => PointFields pointFields where { }
instance ( KnownSymbols pointFields, Typeable pointFields
         , Serialisable   ( Record pointFields )
         , Show           ( Record pointFields )
         , NFData         ( Record pointFields )
         , Representable  Double   ( ℝ ( Length pointFields ) )
         , DiffInterp Point    ( ℝ ( Length pointFields ) )
         , DiffInterp Interval ( ℝ ( 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