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