mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
embed brushes inline into strokes
This commit is contained in:
sheaf
parent
70cab39947
commit
e1c5d266eb
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } )
|
||||
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 )
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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 ) )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } )
|
||||
|
|
|
|||
|
|
@ -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 ) <-
|
||||
|
|
|
|||
Loading…
Reference in a new issue