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

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

module MetaBrush.Asset.Brushes where

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

-- MetaBrush
import MetaBrush.Brush
  ( Brush(..) )
import MetaBrush.MetaParameter.Driver
  ( SomeBrushFunction(..), interpretBrush )
import MetaBrush.Unique
  ( UniqueSupply )

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

circle :: UniqueSupply -> IO Brush
circle uniqueSupply = mkBrush 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) ->   .   ]"

rounded :: UniqueSupply -> IO Brush
rounded uniqueSupply = mkBrush 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 :: UniqueSupply -> Text -> Text -> IO Brush
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 ) ->
      pure ( BrushData { brushName, brushCode, brushFunction } )