metabrush/src/metabrushes/MetaBrush/Asset/Brushes.hs

{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}

module MetaBrush.Asset.Brushes where

-- base
import Data.Kind
  ( Type )
import Data.Type.Equality
  ( (:~:)(Refl) )
import GHC.TypeLits
  ( Symbol )

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

-- MetaBrush
import MetaBrush.Brush
  ( Brush(..), BrushFunction )
import MetaBrush.DSL.Types
  ( STypesI(..), eqTys
  )
import MetaBrush.DSL.Driver
  ( SomeBrushFunction(..)
  , interpretBrush
  )
import MetaBrush.Unique
  ( UniqueSupply )

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

type CircleBrushFields = '[ '("r", Double) ]

circle :: UniqueSupply -> IO ( Brush CircleBrushFields )
circle uniqueSupply = mkBrush @CircleBrushFields uniqueSupply name code
  where
    name, code :: Text
    name = "Circle"
    code =
     "with\n\
     \  r = 1\n\
     \satisfying\n\
     \  r > 0\n\
     \define\n\
     \  let c = kappa in\n\
     \  [ (r,0) -- ( r  , r*c) -- ( r*c, r  ) -> ( 0, r)\n\
     \          -- (-r*c, r  ) -- (-r  , r*c) -> (-r, 0)\n\
     \          -- (-r  ,-r*c) -- (-r*c,-r  ) -> ( 0,-r)\n\
     \          -- ( r*c,-r  ) -- ( r  ,-r*c) ->   .   ]"

circleCW :: UniqueSupply -> IO ( Brush CircleBrushFields )
circleCW uniqueSupply = mkBrush @CircleBrushFields uniqueSupply name code
  where
    name, code :: Text
    name = "Circle CW"
    code =
     "with\n\
     \  r = 1\n\
     \satisfying\n\
     \  r > 0\n\
     \define\n\
     \  let c = kappa in\n\
     \  [ (r,0) -- ( r  ,-r*c) -- ( r*c,-r  ) -> ( 0,-r)\n\
     \          -- (-r*c,-r  ) -- (-r  ,-r*c) -> (-r, 0)\n\
     \          -- (-r  , r*c) -- (-r*c, r  ) -> ( 0, r)\n\
     \          -- ( r*c, r  ) -- ( r  , r*c) ->   .   ]"

type EllipseBrushFields = '[ '("a", Double), '("b", Double), '("phi", Double) ]

ellipse :: UniqueSupply -> IO ( Brush EllipseBrushFields )
ellipse uniqueSupply = mkBrush @EllipseBrushFields uniqueSupply name code
  where
    name, code :: Text
    name = "Ellipse"
    code =
     "with\n\
     \  a = 1\n\
     \  b = 1\n\
     \  phi = 0\n\
     \satisfying\n\
     \  a > 0 && b > 0\n\
     \define\n\
     \  let\n\
     \    c = kappa\n\
     \    applyRotation pt = rotate pt CCW by phi\n\
     \  in\n\
     \    map applyRotation over\n\
     \      [ (a,0) -- ( a  , b*c) -- ( a*c, b  ) -> ( 0, b)\n\
     \              -- (-a*c, b  ) -- (-a  , b*c) -> (-a, 0)\n\
     \              -- (-a  ,-b*c) -- (-a*c,-b  ) -> ( 0,-b)\n\
     \              -- ( a*c,-b  ) -- ( a  ,-b*c) ->   .   ]"

{-
rounded
  :: forall roundedBrushFields
  .  ( roundedBrushFields ~ '[ ] ) -- TODO
  => UniqueSupply -> IO ( Brush roundedBrushFields )
rounded uniqueSupply = mkBrush @roundedBrushFields uniqueSupply name code
  where
    name, code :: Text
    name = "Rounded quadrilateral"
    code =
     "with\n\
     \  tr = (1,-2)\n\
     \  rt = (2,-1)\n\
     \  br = (1,2)\n\
     \  rb = (2,1)\n\
     \  bl = (-1,2)\n\
     \  lb = (-2,1)\n\
     \  tl = (-1,-2)\n\
     \  lt = (-2,-1)\n\
     \define\n\
     \  let c = kappa in\n\
     \  [ tr -- lerp c tr ( project rt onto [ tl -> tr ] ) -- lerp c rt ( project tr onto [ rb -> rt ] ) -> rt\n\
     \                                                                                                   -> rb\n\
     \       -- lerp c rb ( project br onto [ rt -> rb ] ) -- lerp c br ( project rb onto [ bl -> br ] ) -> br\n\
     \                                                                                                   -> bl\n\
     \       -- lerp c bl ( project lb onto [ br -> bl ] ) -- lerp c lb ( project bl onto [ lt -> lb ] ) -> lb\n\
     \                                                                                                   -> lt\n\
     \       -- lerp c lt ( project tl onto [ lb -> lt ] ) -- lerp c tl ( project lt onto [ tr -> tl ] ) -> tl\n\
     \                                                                                                   -> .]"
-}

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

mkBrush
  :: forall ( givenBrushFields :: [ ( Symbol, Type ) ] )
  .  STypesI givenBrushFields
  => UniqueSupply -> Text -> Text
  -> IO ( Brush givenBrushFields )
mkBrush uniqSupply brushName brushCode = do
  ( mbBrush, _ ) <- interpretBrush uniqSupply brushCode
  case mbBrush of
    Left err -> error ( "Could not interpret '" <> Text.unpack brushName <> "' brush:\n" <> show err )
    Right ( SomeBrushFunction ( brushFunction :: BrushFunction inferredBrushFields ) ) ->
      case eqTys @givenBrushFields @inferredBrushFields of
        Just Refl -> pure ( BrushData { brushName, brushCode, brushFunction } )
        Nothing   ->
          error
            ( "Incorrect record type for '" <> Text.unpack brushName <> "' brush:\n\
              \Expected: " <> show ( sTypesI @givenBrushFields ) <> "\n\
              \  Actual: " <> show ( sTypesI @inferredBrushFields )
            )