From e1c5d266eb0f14a234a11634acf37c3958995d92 Mon Sep 17 00:00:00 2001 From: sheaf Date: Mon, 26 Apr 2021 01:17:27 +0200 Subject: [PATCH] embed brushes inline into strokes --- src/app/MetaBrush/Action.hs | 8 +- src/app/MetaBrush/Application.hs | 33 ++---- src/app/MetaBrush/Asset/Brushes.hs | 54 ++++++++-- src/app/MetaBrush/Brush.hs | 62 +++++------ src/app/MetaBrush/Context.hs | 3 - src/app/MetaBrush/Document.hs | 10 +- src/app/MetaBrush/Document/Draw.hs | 22 ++-- src/app/MetaBrush/Document/Serialise.hs | 136 +++++++++--------------- src/app/MetaBrush/Render/Document.hs | 44 +++----- 9 files changed, 169 insertions(+), 203 deletions(-) diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 960be47..8224af6 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -219,9 +219,7 @@ instance HandleAction OpenFile where GIO.listModelGetItem files ( fromIntegral i ) >>?= ( GI.castTo GIO.File >=?=> GIO.fileGetPath ) for_ fileNames \ filePath -> do - knownBrushes <- STM.atomically $ STM.readTVar brushesTVar - ( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes filePath - STM.atomically ( STM.writeTVar brushesTVar knownBrushes' ) + mbDoc <- loadDocument uniqueSupply filePath case mbDoc of Left errMessage -> warningDialog window filePath errMessage Right doc -> do @@ -276,9 +274,7 @@ instance HandleAction OpenFolder where when exists do filePaths <- listDirectory folderPath for_ filePaths \ filePath -> when ( takeExtension filePath == ".mb" ) do - knownBrushes <- STM.atomically $ STM.readTVar brushesTVar - ( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes ( folderPath filePath ) - STM.atomically ( STM.writeTVar brushesTVar knownBrushes' ) + mbDoc <- loadDocument uniqueSupply ( folderPath filePath ) case mbDoc of Left errMessage -> warningDialog window filePath errMessage Right doc -> do diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index 76625e7..1ce9b5d 100644 --- a/src/app/MetaBrush/Application.hs +++ b/src/app/MetaBrush/Application.hs @@ -69,8 +69,6 @@ import qualified GI.Gtk as GTK -- lens import Control.Lens ( (.~) ) -import Control.Lens.At - ( at ) -- stm import qualified Control.Concurrent.STM as STM @@ -92,12 +90,6 @@ import qualified Data.Text as Text import Control.Monad.Trans.Reader ( runReaderT ) --- unordered-containers -import Data.HashMap.Strict - ( HashMap ) -import qualified Data.HashMap.Strict as HashMap - ( fromList ) - -- MetaBrush import Math.Bezier.Cubic.Fit ( FitParameters(..) ) @@ -116,7 +108,7 @@ import MetaBrush.Asset.Colours import MetaBrush.Asset.Logo ( drawLogo ) import MetaBrush.Brush - ( Brush, newBrushReference ) + ( adaptBrush ) import MetaBrush.Context ( UIElements(..), Variables(..) , Modifier(..) @@ -172,27 +164,22 @@ runApplication application = do uniqueSupply <- newUniqueSupply - circleBrush <- Asset.Brushes.circle uniqueSupply - circleBrushUnique <- runReaderT freshUnique uniqueSupply - docUnique <- runReaderT freshUnique uniqueSupply - strokeUnique <- runReaderT freshUnique uniqueSupply + circleBrush <- Asset.Brushes.circle uniqueSupply + docUnique <- runReaderT freshUnique uniqueSupply + strokeUnique <- runReaderT freshUnique uniqueSupply let - testBrushes :: HashMap Brush Unique - testBrushes = HashMap.fromList - [ ( circleBrush, circleBrushUnique ) ] - testDocuments :: Map Unique DocumentHistory testDocuments = fmap newHistory $ uniqueMapFromList [ emptyDocument "Test" docUnique & ( field' @"documentContent" . field' @"strokes" ) .~ [ Stroke - { strokeName = "Stroke 1" - , strokeVisible = True - , strokeUnique = strokeUnique - , strokeBrushRef = newBrushReference @'[ "r" SuperRecord.:= Double ] circleBrushUnique - , strokeSpline = + { strokeName = "Stroke 1" + , strokeVisible = True + , strokeUnique = strokeUnique + , strokeBrush = Just $ adaptBrush @'[ "r" SuperRecord.:= Double ] circleBrush + , strokeSpline = Spline { splineStart = mkPoint ( Point2D 10 -20 ) 2 , splineCurves = OpenCurves $ Seq.fromList @@ -203,7 +190,6 @@ runApplication application = do } } ] - & ( field' @"documentBrushes" . at circleBrushUnique ) .~ ( Just circleBrush ) ] where mkPoint :: Point2D Double -> Double -> PointData ( Super.Rec '[ "r" SuperRecord.:= Double ] ) @@ -213,7 +199,6 @@ runApplication application = do documentRenderTVar <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () ) activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments - brushesTVar <- STM.newTVarIO @( HashMap Brush Unique ) testBrushes mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty diff --git a/src/app/MetaBrush/Asset/Brushes.hs b/src/app/MetaBrush/Asset/Brushes.hs index 8645368..76c604a 100644 --- a/src/app/MetaBrush/Asset/Brushes.hs +++ b/src/app/MetaBrush/Asset/Brushes.hs @@ -4,9 +4,20 @@ {-# 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) ) + +-- superrecord +import qualified SuperRecord + -- text import Data.Text ( Text ) @@ -16,15 +27,23 @@ import qualified Data.Text as Text -- MetaBrush import MetaBrush.Brush ( Brush(..) ) +import MetaBrush.MetaParameter.AST + ( BrushFunction, STypesI(..), eqTys + ) import MetaBrush.MetaParameter.Driver - ( SomeBrushFunction(..), interpretBrush ) + ( SomeBrushFunction(..) + , interpretBrush + ) import MetaBrush.Unique ( UniqueSupply ) -------------------------------------------------------------------------------- -circle :: UniqueSupply -> IO Brush -circle uniqueSupply = mkBrush uniqueSupply name code +circle + :: forall circleBrushFields + . ( circleBrushFields ~ '[ "r" SuperRecord.:= Double ] ) + => UniqueSupply -> IO ( Brush circleBrushFields ) +circle uniqueSupply = mkBrush @circleBrushFields uniqueSupply name code where name, code :: Text name = "Circle" @@ -40,8 +59,12 @@ circle uniqueSupply = mkBrush uniqueSupply name code \ -- (-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 +{- +rounded + :: forall roundedBrushFields + . ( roundedBrushFields ~ '[ ] ) -- TODO + => UniqueSupply -> IO ( Brush roundedBrushFields ) +rounded uniqueSupply = mkBrush @roundedBrushFields uniqueSupply name code where name, code :: Text name = "Rounded quadrilateral" @@ -65,14 +88,25 @@ rounded uniqueSupply = mkBrush uniqueSupply name code \ -> 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 + :: forall ( givenBrushFields :: [ 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 ) -> - pure ( BrushData { brushName, brushCode, brushFunction } ) \ No newline at end of file + 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 ) + ) diff --git a/src/app/MetaBrush/Brush.hs b/src/app/MetaBrush/Brush.hs index b3dcb18..25df014 100644 --- a/src/app/MetaBrush/Brush.hs +++ b/src/app/MetaBrush/Brush.hs @@ -14,7 +14,8 @@ {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} module MetaBrush.Brush - ( Brush(..), BrushReference(..), newBrushReference + ( Brush(..), SomeBrush(..) + , BrushAdaptedTo(..), adaptBrush , SomeBrushFields(..), SomeFieldSType(..), reflectBrushFieldsNoDups ) where @@ -88,8 +89,6 @@ import MetaBrush.MetaParameter.AST ) import MetaBrush.MetaParameter.Interpolation ( Interpolatable(..), MapDiff, HasDiff', HasTorsor ) -import MetaBrush.Unique - ( Unique ) -------------------------------------------------------------------------------- @@ -97,7 +96,7 @@ whatever :: Int whatever = case Workaround of Workaround -> 0 -data Brush where +data Brush brushFields where BrushData :: forall brushFields . ( STypesI brushFields ) @@ -106,50 +105,53 @@ data Brush where , brushCode :: !Text , brushFunction :: !( BrushFunction brushFields ) } - -> Brush + -> Brush brushFields -instance Show Brush where - show ( BrushData { brushName } ) = Text.unpack brushName -instance NFData Brush where +data SomeBrush where + SomeBrush :: !( Brush brushFields ) -> SomeBrush + +instance Show ( Brush brushFields ) where + show ( BrushData { brushName, brushCode } ) = + "BrushData\n\ + \ { brushName = " <> Text.unpack brushName <> "\n\ + \ , brushCode =\n" <> Text.unpack brushCode <> "\n\ + \ }" +instance NFData ( Brush brushFields ) where rnf ( BrushData { brushName, brushCode } ) = deepseq brushCode $ rnf brushName -instance Eq Brush where +instance Eq ( Brush brushFields ) where BrushData name1 code1 _ == BrushData name2 code2 _ = name1 == name2 && code1 == code2 -instance Ord Brush where +instance Ord ( Brush brushFields ) where compare ( BrushData name1 code1 _ ) ( BrushData name2 code2 _ ) = compare ( name1, code1 ) ( name2, code2 ) -instance Hashable Brush where +instance Hashable ( Brush brushFields ) where hashWithSalt salt ( BrushData { brushName, brushCode } ) = hashWithSalt ( hashWithSalt salt brushName ) brushCode -data BrushReference pointFields where - NoBrush :: BrushReference pointFields - BrushReference +data BrushAdaptedTo pointFields where + AdaptedBrush :: forall brushFields pointFields usedFields brushParams usedParams . ( brushParams ~ Super.Rec brushFields, STypesI brushFields , usedParams ~ Super.Rec usedFields , Interpolatable usedParams , Adapted brushFields pointFields usedFields ) - => Proxy# brushFields - -> Unique - -> BrushReference pointFields -instance Show ( BrushReference pointFields ) where - show NoBrush = "NoBrush" - show ( BrushReference ( _ :: Proxy# brushFields ) uniq ) = - "BrushReference @(" <> show ( sTypesI @brushFields ) <> ") " <> show uniq -instance NFData ( BrushReference pointFields ) where - rnf NoBrush = () - rnf ( BrushReference _ unique ) = rnf unique + => !( Brush brushFields ) + -> BrushAdaptedTo pointFields +instance Show ( BrushAdaptedTo pointFields ) where + show ( AdaptedBrush ( brush :: Brush brushFields ) ) = + "AdaptedBrush @(" <> show ( sTypesI @brushFields ) <> ") " <> show brush +instance NFData ( BrushAdaptedTo pointFields ) where + rnf ( AdaptedBrush brush ) = rnf brush -newBrushReference - :: forall brushFields pointFields +adaptBrush + :: forall pointFields brushFields . ( STypesI brushFields, STypesI pointFields ) - => Unique - -> BrushReference pointFields -newBrushReference uniq = case proveAdapted @brushFields @pointFields of - Dict -> BrushReference ( proxy# :: Proxy# brushFields ) uniq + => Brush brushFields + -> BrushAdaptedTo pointFields +adaptBrush brush = case proveAdapted @brushFields @pointFields of + Dict -> AdaptedBrush brush -------------------------------------------------------------------------------- -- Instance dictionary passing machinery. diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Context.hs index 0bf6c63..b602985 100644 --- a/src/app/MetaBrush/Context.hs +++ b/src/app/MetaBrush/Context.hs @@ -50,8 +50,6 @@ import {-# SOURCE #-} MetaBrush.Action ( ActionName ) import MetaBrush.Asset.Colours ( Colours ) -import MetaBrush.Brush - ( Brush ) import MetaBrush.Document.Draw ( DrawAnchor ) import MetaBrush.Document.History @@ -93,7 +91,6 @@ data Variables , documentRenderTVar :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) ) , activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) ) , openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) ) - , brushesTVar :: !( STM.TVar ( HashMap Brush Unique ) ) , mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) ) , mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) ) , modifiersTVar :: !( STM.TVar ( Set Modifier ) ) diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index 9136848..c5c8144 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -105,7 +105,7 @@ import Math.Module import Math.Vector2D ( Point2D(..), Vector2D(..) ) import MetaBrush.Brush - ( Brush, BrushReference ) + ( BrushAdaptedTo ) import {-# SOURCE #-} MetaBrush.Document.Serialise ( Serialisable(..) ) import MetaBrush.MetaParameter.AST @@ -144,7 +144,6 @@ data Document , zoomFactor :: !Double , documentUnique :: Unique , documentContent :: !DocumentContent - , documentBrushes :: !( Map Unique Brush ) } deriving stock ( Show, Generic ) deriving anyclass NFData @@ -175,15 +174,15 @@ data Stroke where { strokeName :: !Text , strokeVisible :: !Bool , strokeUnique :: Unique - , strokeBrushRef :: !( BrushReference pointFields ) + , strokeBrush :: !( Maybe ( BrushAdaptedTo pointFields ) ) , strokeSpline :: !( StrokeSpline clo pointParams ) } -> Stroke deriving stock instance Show Stroke instance NFData Stroke where - rnf ( Stroke { strokeName, strokeVisible, strokeUnique, strokeBrushRef, strokeSpline } ) + rnf ( Stroke { strokeName, strokeVisible, strokeUnique, strokeBrush, strokeSpline } ) = deepseq strokeSpline - . deepseq strokeBrushRef + . deepseq strokeBrush . deepseq strokeUnique . deepseq strokeVisible $ rnf strokeName @@ -266,7 +265,6 @@ emptyDocument docName unique = , strokes = [] , guides = Map.empty } - , documentBrushes = Map.empty } -------------------------------------------------------------------------------- diff --git a/src/app/MetaBrush/Document/Draw.hs b/src/app/MetaBrush/Document/Draw.hs index b4afd6d..6ad11dc 100644 --- a/src/app/MetaBrush/Document/Draw.hs +++ b/src/app/MetaBrush/Document/Draw.hs @@ -76,7 +76,7 @@ import Math.Vector2D import MetaBrush.Assert ( assert ) import MetaBrush.Brush - ( BrushReference(NoBrush) ) + ( BrushAdaptedTo ) import MetaBrush.Document ( Document(..), DocumentContent(..), Stroke(..), StrokeSpline , FocusState(..), PointData(..) @@ -135,11 +135,11 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = newStroke :: Stroke newStroke = Stroke - { strokeName = "Stroke " <> uniqueText uniq - , strokeVisible = True - , strokeUnique = uniq - , strokeSpline = newSpline - , strokeBrushRef = NoBrush + { strokeName = "Stroke " <> uniqueText uniq + , strokeVisible = True + , strokeUnique = uniq + , strokeSpline = newSpline + , strokeBrush = Nothing } newDoc' :: Document newDoc' @@ -238,7 +238,7 @@ withAnchorBrushData , Interpolatable pointParams , Serialisable pointParams ) - => BrushReference pointFields + => Maybe ( BrushAdaptedTo pointFields ) -> pointParams -> r ) @@ -247,10 +247,10 @@ withAnchorBrushData anchor ( Document { documentContent = Content { strokes } } splineAnchor . listToMaybe $ filter ( \ Stroke { strokeUnique } -> strokeUnique == anchorStrokeUnique anchor ) strokes where splineAnchor :: Maybe Stroke -> r - splineAnchor ( Just ( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo pointData, strokeBrushRef } ) ) + splineAnchor ( Just ( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo pointData, strokeBrush } ) ) | SOpen <- ssplineType @clo = case anchor of - AnchorAtStart {} -> f strokeBrushRef ( brushParams ( splineStart strokeSpline ) ) - AnchorAtEnd {} -> f strokeBrushRef ( brushParams ( splineEnd strokeSpline ) ) + AnchorAtStart {} -> f strokeBrush ( brushParams ( splineStart strokeSpline ) ) + AnchorAtEnd {} -> f strokeBrush ( brushParams ( splineEnd strokeSpline ) ) splineAnchor _ - = f NoBrush SuperRecord.rnil + = f Nothing SuperRecord.rnil diff --git a/src/app/MetaBrush/Document/Serialise.hs b/src/app/MetaBrush/Document/Serialise.hs index 0f05739..09ec9a6 100644 --- a/src/app/MetaBrush/Document/Serialise.hs +++ b/src/app/MetaBrush/Document/Serialise.hs @@ -22,7 +22,7 @@ module MetaBrush.Document.Serialise -- base import Control.Arrow - ( (&&&), first ) + ( (&&&) ) import Control.Monad ( unless ) import Control.Monad.ST @@ -68,7 +68,7 @@ import qualified Data.ByteString.Builder as Lazy.ByteString.Builder import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map - ( elems, empty, fromList, insert, lookup ) + ( elems, fromList ) import Data.Sequence ( Seq ) import qualified Data.Sequence as Seq @@ -117,7 +117,7 @@ import SuperRecord import Data.Text ( Text ) import qualified Data.Text as Text - ( pack, unpack, unwords ) + ( pack, unwords ) -- transformers import Control.Monad.IO.Class @@ -126,14 +126,6 @@ import Control.Monad.Trans.Class ( MonadTrans(lift) ) import Control.Monad.Trans.Reader ( runReaderT ) -import Control.Monad.Trans.State.Strict - ( StateT, runStateT, get, put ) - --- unordered-containers -import Data.HashMap.Strict - ( HashMap ) -import qualified Data.HashMap.Strict as HashMap - ( foldrWithKey', insert, lookup ) -- waargonaut import qualified Waargonaut.Attoparsec as JSON.Decoder @@ -182,10 +174,9 @@ import Math.Bezier.Stroke ( CachedStroke(..) ) import Math.Vector2D ( Point2D(..), Vector2D(..), Segment ) -import MetaBrush.Assert - ( assert ) import MetaBrush.Brush - ( Brush(..), BrushReference(..), newBrushReference + ( Brush(..), SomeBrush(..) + , BrushAdaptedTo(..), adaptBrush , SomeBrushFields(..), SomeFieldSType(..), reflectBrushFieldsNoDups ) import MetaBrush.Document @@ -194,10 +185,10 @@ import MetaBrush.Document , PointData(..), FocusState(..) ) import MetaBrush.MetaParameter.AST - ( SType(..), STypeI(..), STypesI(..) + ( SType(..), STypeI(..) , SomeSType(..), someSTypes - , AdaptableFunction(..), BrushFunction - , eqTy, eqTys + , AdaptableFunction(..) + , eqTy ) import MetaBrush.MetaParameter.Driver ( SomeBrushFunction(..), interpretBrush ) @@ -229,13 +220,12 @@ documentToJSON -- -- Updates the store of brushes by adding any new brushes contained in the document. documentFromJSON - :: UniqueSupply -> HashMap Brush Unique + :: UniqueSupply -> Maybe FilePath -> Strict.ByteString - -> IO ( Either JSON.DecodeError Document, HashMap Brush Unique ) -documentFromJSON uniqueSupply brushUniques mfp - = fmap ( first $ Bifunctor.first fst ) - . ( `runStateT` brushUniques ) + -> IO ( Either JSON.DecodeError Document ) +documentFromJSON uniqueSupply mfp + = fmap ( Bifunctor.first fst ) . JSON.Decoder.decodeAttoparsecByteString ( decodeDocument uniqueSupply mfp ) -------------------------------------------------------------------------------- @@ -254,14 +244,12 @@ saveDocument path doc = do atomicReplaceFile Nothing path' ( documentToJSON doc ) -- | Load a MetaBrush document. --- --- Updates the store of brushes by adding any new brushes contained in the document. -loadDocument :: UniqueSupply -> HashMap Brush Unique -> FilePath -> IO ( Either String Document, HashMap Brush Unique ) -loadDocument uniqueSupply brushUniques fp = do +loadDocument :: UniqueSupply -> FilePath -> IO ( Either String Document ) +loadDocument uniqueSupply fp = do exists <- doesFileExist fp if exists - then first ( Bifunctor.first show ) <$> ( documentFromJSON uniqueSupply brushUniques ( Just fp ) =<< Strict.ByteString.readFile fp ) - else pure ( Left $ "No file at " <> fp, brushUniques ) + then Bifunctor.first show <$> ( documentFromJSON uniqueSupply ( Just fp ) =<< Strict.ByteString.readFile fp ) + else pure ( Left $ "No file at " <> fp ) -------------------------------------------------------------------------------- @@ -635,13 +623,13 @@ decodeFieldTypes = do -encodeBrush :: Applicative f => JSON.Encoder f Brush +encodeBrush :: Applicative f => JSON.Encoder f ( Brush brushFields ) encodeBrush = JSON.Encoder.mapLikeObj \ ( BrushData { brushName, brushCode } ) -> JSON.Encoder.atKey' "name" JSON.Encoder.text brushName . JSON.Encoder.atKey' "code" JSON.Encoder.text brushCode -decodeBrush :: MonadIO m => UniqueSupply -> JSON.Decoder m Brush +decodeBrush :: MonadIO m => UniqueSupply -> JSON.Decoder m SomeBrush decodeBrush uniqSupply = do brushName <- JSON.Decoder.atKey "name" JSON.Decoder.text brushCode <- JSON.Decoder.atKey "code" JSON.Decoder.text @@ -649,17 +637,17 @@ decodeBrush uniqSupply = do case mbBrush of Left err -> throwError ( JSON.ParseFailed ( "Failed to interpret brush code:\n" <> ( Text.pack $ show err ) ) ) Right ( SomeBrushFunction brushFunction ) -> - pure ( BrushData { brushName, brushCode, brushFunction } ) + pure ( SomeBrush $ BrushData { brushName, brushCode, brushFunction } ) -encodeStroke :: Monad f => Map Unique Brush -> JSON.Encoder f Stroke -encodeStroke brushes = JSON.Encoder.mapLikeObj +encodeStroke :: Monad f => JSON.Encoder f Stroke +encodeStroke = JSON.Encoder.mapLikeObj \ ( Stroke { strokeName , strokeVisible , strokeSpline = strokeSpline :: StrokeSpline clo ( Super.Rec pointFields ) - , strokeBrushRef + , strokeBrush } ) -> let @@ -668,22 +656,11 @@ encodeStroke brushes = JSON.Encoder.mapLikeObj SClosed -> True SOpen -> False mbEncodeBrush :: JSON.MapLikeObj JSON.WS Json -> JSON.MapLikeObj JSON.WS Json - mbEncodeBrush = case strokeBrushRef of - BrushReference ( _ :: Proxy# brushFields1 ) unique -> - case Map.lookup unique brushes of - Nothing -> - assert ( "encodeStroke: no brush with unique " <> show unique <> "in environment" ) - id - Just ( brush@BrushData { brushName, brushFunction = ( _ :: BrushFunction brushFields2 ) } ) -> - case eqTys @brushFields1 @brushFields2 of - Nothing -> - assert ( "encodeStroke: brush '" <> Text.unpack brushName <> "' has unexpected field types.\n\ - \Expected: " <> show ( sTypesI @brushFields1 ) <> "\n\ - \ Actual: " <> show ( sTypesI @brushFields2 ) - ) - id - Just Refl -> JSON.Encoder.atKey' "brush" encodeBrush brush - NoBrush -> id + mbEncodeBrush = case strokeBrush of + Nothing -> + id + Just ( AdaptedBrush brush ) -> + JSON.Encoder.atKey' "brush" encodeBrush brush in JSON.Encoder.atKey' "name" JSON.Encoder.text strokeName . JSON.Encoder.atKey' "visible" JSON.Encoder.bool strokeVisible @@ -692,34 +669,28 @@ encodeStroke brushes = JSON.Encoder.mapLikeObj . mbEncodeBrush . JSON.Encoder.atKey' "spline" ( encodeSpline encodePointData ) strokeSpline -decodeStroke :: forall m. MonadIO m => UniqueSupply -> JSON.Decoder ( StateT ( HashMap Brush Unique ) m ) Stroke +decodeStroke :: MonadIO m => UniqueSupply -> JSON.Decoder m Stroke decodeStroke uniqueSupply = do - brushHashMap <- lift get strokeName <- JSON.Decoder.atKey "name" JSON.Decoder.text strokeVisible <- JSON.Decoder.atKey "visible" JSON.Decoder.bool strokeUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply ) strokeClosed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool SomeBrushFields ( _ :: Proxy# pointFields ) <- JSON.Decoder.atKey "pointFields" decodeFieldTypes mbBrush <- JSON.Decoder.atKeyOptional "brush" ( decodeBrush uniqueSupply ) - strokeBrushRef <- - case mbBrush of - Nothing -> pure NoBrush - Just ( brush@BrushData { brushFunction = _ :: BrushFunction brushFields } ) -> do - brushUnique <- - case HashMap.lookup brush brushHashMap of - Nothing -> do - brushUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply ) - lift $ put ( HashMap.insert brush brushUnique brushHashMap ) - pure brushUnique - Just brushUnique -> pure brushUnique - pure ( newBrushReference @brushFields brushUnique ) + let + strokeBrush :: Maybe ( BrushAdaptedTo pointFields ) + strokeBrush = case mbBrush of + Nothing + -> Nothing + Just ( SomeBrush ( brush@( BrushData {} ) ) ) + -> Just $ adaptBrush @pointFields brush if strokeClosed then do strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Super.Rec pointFields ) ) decodePointData ) - pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrushRef } ) + pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush } ) else do strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open @( PointData ( Super.Rec pointFields ) ) decodePointData ) - pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrushRef } ) + pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush } ) @@ -740,15 +711,12 @@ decodeGuide uniqueSupply = do -encodeDocumentContent :: Applicative f => Map Unique Brush -> JSON.Encoder f DocumentContent -encodeDocumentContent brushes = JSON.Encoder.mapLikeObj \ ( Content { guides, strokes } ) -> - JSON.Encoder.atKey' "guides" ( encodeUniqueMap encodeGuide ) guides - . JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list $ encodeStroke brushes ) strokes +encodeDocumentContent :: Applicative f => JSON.Encoder f DocumentContent +encodeDocumentContent = JSON.Encoder.mapLikeObj \ ( Content { guides, strokes } ) -> + JSON.Encoder.atKey' "guides" ( encodeUniqueMap encodeGuide ) guides + . JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeStroke ) strokes -decodeDocumentContent - :: MonadIO m - => UniqueSupply - -> JSON.Decoder ( StateT ( HashMap Brush Unique ) m ) DocumentContent +decodeDocumentContent :: MonadIO m => UniqueSupply -> JSON.Decoder m DocumentContent decodeDocumentContent uniqueSupply = do let unsavedChanges :: Bool @@ -763,22 +731,18 @@ decodeDocumentContent uniqueSupply = do encodeDocument :: Applicative f => JSON.Encoder f Document encodeDocument = JSON.Encoder.mapLikeObj - \ ( Document { displayName, viewportCenter, zoomFactor, documentContent, documentBrushes } ) -> - JSON.Encoder.atKey' "version" ( JSON.Encoder.list JSON.Encoder.int ) ( versionBranch Cabal.version ) - . JSON.Encoder.atKey' "name" JSON.Encoder.text displayName - . JSON.Encoder.atKey' "center" ( encoder @( Point2D Double ) ) viewportCenter - . JSON.Encoder.atKey' "zoom" ( encoder @Double ) zoomFactor - . JSON.Encoder.atKey' "content" ( encodeDocumentContent documentBrushes ) documentContent + \ ( Document { displayName, viewportCenter, zoomFactor, documentContent } ) -> + JSON.Encoder.atKey' "version" ( JSON.Encoder.list JSON.Encoder.int ) ( versionBranch Cabal.version ) + . JSON.Encoder.atKey' "name" JSON.Encoder.text displayName + . JSON.Encoder.atKey' "center" ( encoder @( Point2D Double ) ) viewportCenter + . JSON.Encoder.atKey' "zoom" ( encoder @Double ) zoomFactor + . JSON.Encoder.atKey' "content" encodeDocumentContent documentContent -decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder ( StateT ( HashMap Brush Unique ) m ) Document +decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document decodeDocument uniqueSupply mbFilePath = do displayName <- JSON.Decoder.atKey "name" JSON.Decoder.text viewportCenter <- JSON.Decoder.atKey "center" ( decoder @( Point2D Double ) ) zoomFactor <- JSON.Decoder.atKey "zoom" ( decoder @Double ) documentUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply ) documentContent <- JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply ) - brushUniques <- lift get - let - documentBrushes :: Map Unique Brush - documentBrushes = HashMap.foldrWithKey' ( flip Map.insert ) Map.empty brushUniques - pure ( Document { displayName, mbFilePath, viewportCenter, zoomFactor, documentUnique, documentContent, documentBrushes } ) + pure ( Document { displayName, mbFilePath, viewportCenter, zoomFactor, documentUnique, documentContent } ) diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index cda5ac3..ce9e562 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -37,8 +37,6 @@ import Data.Int ( Int32 ) import Data.Maybe ( mapMaybe ) -import Data.Type.Equality - ( (:~:)(Refl) ) import GHC.Exts ( Proxy#, proxy# ) import GHC.Generics @@ -53,10 +51,6 @@ import Data.Act ) -- containers -import Data.Map.Strict - ( Map ) -import qualified Data.Map.Strict as Map - ( lookup ) import Data.Sequence ( Seq(..) ) import Data.Set @@ -112,7 +106,7 @@ import Math.Vector2D import MetaBrush.Asset.Colours ( Colours, ColourRecord(..) ) import MetaBrush.Brush - ( Brush(..), BrushReference(..) ) + ( Brush(..), BrushAdaptedTo(..) ) import MetaBrush.Context ( Modifier(..) , HoldAction(..), PartialPath(..) @@ -136,13 +130,13 @@ import MetaBrush.Document.Serialise import MetaBrush.Document.Update ( DocChange(..) ) import MetaBrush.MetaParameter.AST - ( AdaptableFunction(..), BrushFunction, eqTys ) + ( AdaptableFunction(..) ) import MetaBrush.MetaParameter.Interpolation ( MapDiff ) import MetaBrush.UI.ToolBar ( Mode(..) ) import MetaBrush.Unique - ( Unique, unsafeUnique ) + ( unsafeUnique ) import MetaBrush.Util ( withRGBA ) @@ -179,7 +173,7 @@ getDocumentRender getDocumentRender cols fitParams mode debug modifiers mbMousePos mbHoldEvent mbPartialPath - doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content, documentBrushes } ) + doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content } ) = do let @@ -212,7 +206,7 @@ getDocumentRender , Just finalPoint <- mbFinalPoint , let previewStroke :: Stroke - previewStroke = withAnchorBrushData anchor doc \ brushRef ( pointData :: Super.Rec pointFields ) -> + previewStroke = withAnchorBrushData anchor doc \ mbBrush ( pointData :: Super.Rec pointFields ) -> let previewSpline :: Spline Open ( CachedStroke RealWorld ) ( PointData ( Super.Rec pointFields ) ) previewSpline = catMaybesSpline ( invalidateCache undefined ) @@ -234,12 +228,12 @@ getDocumentRender , strokeVisible = True , strokeUnique = unsafeUnique 987654321 , strokeName = "Preview stroke (temporary)" - , strokeBrushRef = brushRef + , strokeBrush = mbBrush } -> previewStroke : strokes content _ -> strokes content - strokesRenderData <- sequenceA $ mapMaybe ( strokeRenderData fitParams documentBrushes ) modifiedStrokes + strokesRenderData <- sequenceA $ mapMaybe ( strokeRenderData fitParams ) modifiedStrokes let renderSelectionRect :: Cairo.Render () @@ -299,27 +293,23 @@ instance NFData StrokeRenderData where -- - the computed outline (using fitting algorithm), -- - the brush shape function. -- - Otherwise, this consists of the underlying spline path only. -strokeRenderData :: FitParameters -> Map Unique Brush -> Stroke -> Maybe ( ST RealWorld StrokeRenderData ) -strokeRenderData fitParams brushes +strokeRenderData :: FitParameters -> Stroke -> Maybe ( ST RealWorld StrokeRenderData ) +strokeRenderData fitParams ( Stroke - { strokeSpline = spline :: StrokeSpline clo pointParams - , strokeBrushRef = ( strokeBrushRef :: BrushReference pointFields ) + { strokeSpline = spline :: StrokeSpline clo pointParams + , strokeBrush = ( strokeBrush :: Maybe ( BrushAdaptedTo pointFields ) ) , .. } ) | strokeVisible - = Just $ case strokeBrushRef of - BrushReference ( _ :: Proxy# brushFields ) brushUnique - -- TODO: could emit a warning if the following lookup fails. - | Just ( BrushData { brushFunction = AdaptableFunction brushFn :: BrushFunction brushFields' } ) <- Map.lookup brushUnique brushes - -- TODO: the following check could be skipped if we are feeling confident. - , Just Refl <- eqTys @brushFields @brushFields' -- Refl <- ( unsafeCoerce Refl :: brushFields :~: brushFields' ) - , ( _ :: Proxy# usedFields ) <- ( proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields ) ) + = Just $ case strokeBrush of + Just ( AdaptedBrush ( brush :: Brush brushFields ) ) + | ( _ :: Proxy# usedFields ) <- ( proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields ) ) , let - -- Get the adaptable brush shape (function), - -- specialising it to the type we are using. toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields brushShapeFn :: Super.Rec usedFields -> SplinePts Closed - ( toUsedParams, brushShapeFn ) = brushFn @pointFields @usedFields + AdaptableFunction ( toUsedParams, brushShapeFn ) = brushFunction brush + -- Get the adaptable brush shape (function), + -- specialising it to the type we are using. -> do -- Compute the outline using the brush function. ( outline, fitPts ) <-