diff --git a/.gitignore b/.gitignore index 8905ede..34a5407 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,4 @@ img/examples *.md *.html hie.yaml +*.mb diff --git a/MetaBrush.cabal b/MetaBrush.cabal index e71a20e..aab8a28 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -82,8 +82,6 @@ library ^>= 0.20.0.0 , vector ^>= 0.12.1.2 - , QuickCheck - ^>= 2.14.1 executable MetaBrush @@ -109,6 +107,7 @@ executable MetaBrush , MetaBrush.Document , MetaBrush.Document.Draw , MetaBrush.Document.Selection + , MetaBrush.Document.Serialise , MetaBrush.Event , MetaBrush.Event.KeyCodes , MetaBrush.Render.Document @@ -132,10 +131,10 @@ executable MetaBrush build-depends: MetaBrush + , bytestring + ^>= 0.10.10.1 , directory >= 1.3.4.0 && < 1.4 - --, fingertree - -- >= 0.1.4.2 && < 0.2 , gi-gdk >= 3.0.22 && < 3.1 , gi-gio @@ -152,9 +151,13 @@ executable MetaBrush ^>= 0.24 , lens ^>= 4.19.2 + , scientific + ^>= 0.3.6.2 , stm ^>= 2.5.0.0 , tardis ^>= 0.4.1.0 , text - ^>= 1.2.3.1 && < 1.2.5 \ No newline at end of file + ^>= 1.2.3.1 && < 1.2.5 + , waargonaut + ^>= 0.8.0.1 diff --git a/app/Main.hs b/app/Main.hs index eb3643b..dcd6085 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -102,31 +102,51 @@ testDocuments = IntMap.fromList $ zip [0..] [ Document { displayName = "Closed" - , filePath = Nothing + , mbFilePath = Nothing , unsavedChanges = False - , strokes = [ Stroke ( ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) ) ) "Ellipse" True ( unsafeUnique 0 ) - ] , bounds = AABB ( Point2D 0 0 ) ( Point2D 100 100 ) , viewportCenter = Point2D 50 50 , zoomFactor = 1 + , documentUnique = unsafeUnique 0 + , strokes = [ Stroke + { strokeName = "Ellipse" + , strokeVisible = True + , strokeUnique = unsafeUnique 10 + , strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) ) + } + ] } , Document { displayName = "Line" - , filePath = Nothing + , mbFilePath = Nothing , unsavedChanges = True - , strokes = [ Stroke linePts "Line" True ( unsafeUnique 1 ) ] , bounds = AABB ( Point2D 0 0 ) ( Point2D 50 50 ) , viewportCenter = Point2D 0 0 , zoomFactor = 1 + , documentUnique = unsafeUnique 1 + , strokes = [ Stroke + { strokeName = "Line" + , strokeVisible = True + , strokeUnique = unsafeUnique 11 + , strokePoints = linePts + } + ] } , Document { displayName = "Short line" - , filePath = Nothing + , mbFilePath = Nothing , unsavedChanges = False - , strokes = [ Stroke linePts2 "ShortLine" True ( unsafeUnique 2 ) ] , bounds = AABB ( Point2D 0 0 ) ( Point2D 50 50 ) , viewportCenter = Point2D 0 0 , zoomFactor = 1 + , documentUnique = unsafeUnique 2 + , strokes = [ Stroke + { strokeName = "ShortLine" + , strokeVisible = True + , strokeUnique = unsafeUnique 12 + , strokePoints = linePts2 + } + ] } ] where diff --git a/cabal.project b/cabal.project index 1600002..e50f806 100644 --- a/cabal.project +++ b/cabal.project @@ -3,6 +3,9 @@ packages: . constraints: acts -finitary +allow-newer: + waargonaut:* + -- fixes gi-cairo-render to work with haskell-gi >= 0.24 source-repository-package type: git @@ -16,3 +19,9 @@ source-repository-package location: https://github.com/haskell-numerics/hmatrix tag: 08138810946c7eae2254feeb33269cd962d5e0c8 subdir: packages/base + +-- adds MonadTrans Decoder instance to waargonaut Decoder +source-repository-package + type: git + location: https://github.com/sheaf/waargonaut + tag: dc835fb86d2592fa2e55753fa4eb7c59d6124699 diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index 38578d6..4b66828 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -64,21 +64,22 @@ data AABB data Document = Document { displayName :: !Text - , filePath :: !( Maybe FilePath ) + , mbFilePath :: !( Maybe FilePath ) , unsavedChanges :: !Bool - , strokes :: ![ Stroke ] , bounds :: !AABB , viewportCenter :: !( Point2D Double ) , zoomFactor :: !Double + , documentUnique :: Unique + , strokes :: ![ Stroke ] } deriving stock ( Show, Generic ) data Stroke = Stroke - { strokePoints :: !( Seq ( StrokePoint PointData ) ) - , strokeName :: Text + { strokeName :: Text , strokeVisible :: !Bool , strokeUnique :: Unique + , strokePoints :: !( Seq ( StrokePoint PointData ) ) } deriving stock ( Show, Generic ) diff --git a/src/app/MetaBrush/Document/Draw.hs b/src/app/MetaBrush/Document/Draw.hs index a73dfa7..f270113 100644 --- a/src/app/MetaBrush/Document/Draw.hs +++ b/src/app/MetaBrush/Document/Draw.hs @@ -84,10 +84,11 @@ getDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = newDoc' = over ( field' @"strokes" ) ( Stroke - ( Seq.singleton $ PathPoint c ( PointData Normal Empty ) ) - ( "Stroke " <> uniqueText uniq ) - True - uniq + { strokeName = "Stroke " <> uniqueText uniq + , strokeVisible = True + , strokeUnique = uniq + , strokePoints = Seq.singleton $ PathPoint c ( PointData Normal Empty ) + } : ) newDoc pure ( newDoc', AnchorAtEnd uniq, c ) diff --git a/src/app/MetaBrush/Document/Serialise.hs b/src/app/MetaBrush/Document/Serialise.hs new file mode 100644 index 0000000..c0deedf --- /dev/null +++ b/src/app/MetaBrush/Document/Serialise.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module MetaBrush.Document.Serialise + ( documentToJSON, documentFromJSON ) + where + +-- base +import qualified Data.Bifunctor as Bifunctor + ( first ) +import Data.Foldable + ( toList ) +import Data.Functor.Contravariant + ( contramap ) + +-- bytestring +import qualified Data.ByteString as Strict + ( ByteString ) +import qualified Data.ByteString.Lazy as Lazy + ( ByteString ) + +-- containers +import Data.Sequence + ( Seq ) +import qualified Data.Sequence as Seq + ( fromList ) + +-- scientific +import qualified Data.Scientific as Scientific + ( fromFloatDigits, toRealFloat ) + +-- stm +import qualified Control.Concurrent.STM as STM + ( atomically ) + +-- text +import Data.Text + ( Text ) + +-- transformers +import Control.Monad.IO.Class + ( MonadIO(liftIO) ) +import Control.Monad.Trans.Class + ( MonadTrans(lift) ) + +-- waargonaut +import qualified Waargonaut.Attoparsec as JSON.Decoder + ( decodeAttoparsecByteString ) +import qualified Waargonaut.Decode as JSON + ( Decoder ) +import qualified Waargonaut.Decode.Error as JSON + ( DecodeError ) +import qualified Waargonaut.Decode as JSON.Decoder + ( atKey, bool, list, oneOf, scientific, text ) +import qualified Waargonaut.Encode as JSON + ( Encoder, Encoder' ) +import qualified Waargonaut.Encode as JSON.Encoder + ( simplePureEncodeByteString + , atKey', bool, list, mapLikeObj, scientific, text + ) + +-- MetaBrush +import Math.Bezier.Stroke + ( StrokePoint(..) ) +import Math.Vector2D + ( Point2D(..) ) --, Vector2D(..), Mat22(..) ) +import MetaBrush.Document + ( Document(..) + , AABB(..) + , Stroke(..) + , PointData(..) + , BrushPointData(..) + , FocusState(..) + ) +import MetaBrush.Unique + ( UniqueSupply, freshUnique ) + +-------------------------------------------------------------------------------- + +documentToJSON :: Document -> Lazy.ByteString +documentToJSON = JSON.Encoder.simplePureEncodeByteString encodeDocument + +documentFromJSON :: UniqueSupply -> Maybe FilePath -> Strict.ByteString -> IO ( Either JSON.DecodeError Document ) +documentFromJSON uniqueSupply mfp + = fmap ( Bifunctor.first fst ) + . JSON.Decoder.decodeAttoparsecByteString ( decodeDocument uniqueSupply mfp ) + +-------------------------------------------------------------------------------- + +encodeDouble :: Applicative f => JSON.Encoder f Double +encodeDouble = contramap Scientific.fromFloatDigits JSON.Encoder.scientific + +decodeDouble :: Monad m => JSON.Decoder m Double +decodeDouble = fmap Scientific.toRealFloat JSON.Decoder.scientific + + + +encodePoint2D :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Point2D a ) +encodePoint2D enc = JSON.Encoder.mapLikeObj \ ( Point2D x y ) -> + JSON.Encoder.atKey' "x" enc x . JSON.Encoder.atKey' "y" enc y + +decodePoint2D :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Point2D a ) +decodePoint2D dec = Point2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" dec + + +{- +encodeVector2D :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Vector2D a ) +encodeVector2D enc = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) -> + JSON.Encoder.atKey' "x" enc x + . JSON.Encoder.atKey' "y" enc y + +decodeVector2D :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Vector2D a ) +decodeVector2D dec = Vector2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" dec + + + +encodeMat22 :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Mat22 a ) +encodeMat22 enc = JSON.Encoder.mapLikeObj \ ( Mat22 m00 m01 m10 m11 ) -> + JSON.Encoder.atKey' "m00" enc m00 + . JSON.Encoder.atKey' "m01" enc m01 + . JSON.Encoder.atKey' "m10" enc m10 + . JSON.Encoder.atKey' "m11" enc m11 + +decodeMat22 :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Mat22 a ) +decodeMat22 dec = + Mat22 <$> JSON.Decoder.atKey "m00" dec + <*> JSON.Decoder.atKey "m01" dec + <*> JSON.Decoder.atKey "m10" dec + <*> JSON.Decoder.atKey "m11" dec +-} + + +encodeAABB :: Applicative f => JSON.Encoder f AABB +encodeAABB = JSON.Encoder.mapLikeObj \ ( AABB { topLeft, botRight } ) -> + JSON.Encoder.atKey' "topLeft" enc topLeft + . JSON.Encoder.atKey' "botRight" enc botRight + where + enc :: JSON.Encoder' ( Point2D Double ) + enc = encodePoint2D encodeDouble + +decodeAABB :: forall m. Monad m => JSON.Decoder m AABB +decodeAABB = do + topLeft <- JSON.Decoder.atKey "topLeft" dec + botRight <- JSON.Decoder.atKey "botRight" dec + pure ( AABB { topLeft, botRight } ) + where + dec :: JSON.Decoder m ( Point2D Double ) + dec = decodePoint2D decodeDouble + + + +encodeStrokePoint :: Applicative f => JSON.Encoder' d -> JSON.Encoder f ( StrokePoint d ) +encodeStrokePoint enc = JSON.Encoder.mapLikeObj \case + PathPoint { coords, pointData } -> + JSON.Encoder.atKey' "coords" ( encodePoint2D encodeDouble ) coords + . JSON.Encoder.atKey' "data" enc pointData + . JSON.Encoder.atKey' "type" JSON.Encoder.text "path" + ControlPoint { coords, pointData } -> + JSON.Encoder.atKey' "coords" ( encodePoint2D encodeDouble ) coords + . JSON.Encoder.atKey' "data" enc pointData + . JSON.Encoder.atKey' "type" JSON.Encoder.text "control" + +decodeStrokePointTypeIsPath :: Monad m => JSON.Decoder m Bool +decodeStrokePointTypeIsPath = JSON.Decoder.oneOf JSON.Decoder.text "StrokePoint Type" + [ ( "path", True ), ( "control", False ) ] + +decodeStrokePoint :: Monad m => JSON.Decoder m d -> JSON.Decoder m ( StrokePoint d ) +decodeStrokePoint dec = do + coords <- JSON.Decoder.atKey "coords" ( decodePoint2D decodeDouble ) + pointData <- JSON.Decoder.atKey "data" dec + isPathPoint <- JSON.Decoder.atKey "type" decodeStrokePointTypeIsPath + if isPathPoint + then pure ( PathPoint { coords, pointData } ) + else pure ( ControlPoint { coords, pointData } ) + +encodeFocusState :: Applicative f => JSON.Encoder f FocusState +encodeFocusState = contramap focusText JSON.Encoder.text + where + focusText :: FocusState -> Text + focusText Normal = "normal" + focusText Hover = "hover" + focusText Selected = "selected" + +decodeFocusState :: Monad m => JSON.Decoder m FocusState +decodeFocusState = JSON.Decoder.oneOf JSON.Decoder.text "FocusState" + [ ( "normal" , Normal ) + , ( "hover" , Hover ) + , ( "selected", Selected ) + ] + + + +encodeBrushPointData :: Applicative f => JSON.Encoder f BrushPointData +encodeBrushPointData = JSON.Encoder.mapLikeObj \ ( BrushPointData { brushPointState } ) -> + JSON.Encoder.atKey' "focus" encodeFocusState brushPointState + +decodeBrushPointData :: Monad m => JSON.Decoder m BrushPointData +decodeBrushPointData = do + brushPointState <- JSON.Decoder.atKey "focus" decodeFocusState + pure ( BrushPointData { brushPointState } ) + + + +encodeSequence :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Seq a ) +encodeSequence enc = contramap toList ( JSON.Encoder.list enc ) + +decodeSequence :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Seq a ) +decodeSequence dec = Seq.fromList <$> JSON.Decoder.list dec + + + +encodePointData :: Applicative f => JSON.Encoder f PointData +encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointState, brushShape } ) -> + JSON.Encoder.atKey' "focus" encodeFocusState pointState + . JSON.Encoder.atKey' "brush" ( encodeSequence ( encodeStrokePoint encodeBrushPointData ) ) brushShape + +decodePointData :: Monad m => JSON.Decoder m PointData +decodePointData = do + pointState <- JSON.Decoder.atKey "focus" decodeFocusState + brushShape <- JSON.Decoder.atKey "brush" ( decodeSequence ( decodeStrokePoint decodeBrushPointData ) ) + pure ( PointData { pointState, brushShape } ) + + + +encodeStroke :: Applicative f => JSON.Encoder f Stroke +encodeStroke = JSON.Encoder.mapLikeObj \ ( Stroke { strokeName, strokeVisible, strokePoints } ) -> + JSON.Encoder.atKey' "name" JSON.Encoder.text strokeName + . JSON.Encoder.atKey' "visible" JSON.Encoder.bool strokeVisible + . JSON.Encoder.atKey' "points" ( encodeSequence ( encodeStrokePoint encodePointData ) ) strokePoints + +decodeStroke :: MonadIO m => UniqueSupply -> JSON.Decoder m Stroke +decodeStroke uniqueSupply = do + strokeName <- JSON.Decoder.atKey "name" JSON.Decoder.text + strokeVisible <- JSON.Decoder.atKey "visible" JSON.Decoder.bool + strokeUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply ) + strokePoints <- JSON.Decoder.atKey "points" ( decodeSequence ( decodeStrokePoint decodePointData ) ) + pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokePoints } ) + + + +encodeDocument :: Applicative f => JSON.Encoder f Document +encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, bounds, viewportCenter, zoomFactor, strokes } ) -> + JSON.Encoder.atKey' "name" JSON.Encoder.text displayName + . JSON.Encoder.atKey' "bounds" encodeAABB bounds + . JSON.Encoder.atKey' "center" ( encodePoint2D encodeDouble ) viewportCenter + . JSON.Encoder.atKey' "zoom" encodeDouble zoomFactor + . JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeStroke ) strokes + +decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document +decodeDocument uniqueSupply mbFilePath = do + displayName <- JSON.Decoder.atKey "name" JSON.Decoder.text + let + unsavedChanges :: Bool + unsavedChanges = False + bounds <- JSON.Decoder.atKey "bounds" decodeAABB + viewportCenter <- JSON.Decoder.atKey "center" ( decodePoint2D decodeDouble ) + zoomFactor <- JSON.Decoder.atKey "zoom" decodeDouble + documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply ) + strokes <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list ( decodeStroke uniqueSupply ) ) + pure ( Document { displayName, mbFilePath, unsavedChanges, bounds, viewportCenter, zoomFactor, documentUnique, strokes } ) diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 7a719bf..fce5371 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -160,7 +160,8 @@ renderDocument pure $ ControlPoint cp ( PointData Normal Empty ) , Just ( PathPoint finalPoint ( PointData Normal Empty ) ) ] - = ( Stroke previewPts undefined True undefined ) : strokes doc + = ( Stroke { strokePoints = previewPts, strokeVisible = True, strokeUnique = undefined, strokeName = undefined } ) + : strokes doc | otherwise = strokes doc diff --git a/src/lib/Math/Bezier/Cubic/Fit.hs b/src/lib/Math/Bezier/Cubic/Fit.hs index 5e00d11..9f149fd 100644 --- a/src/lib/Math/Bezier/Cubic/Fit.hs +++ b/src/lib/Math/Bezier/Cubic/Fit.hs @@ -65,8 +65,6 @@ import Math.Roots import Math.Vector2D ( Mat22(..), Point2D(..), Vector2D(..) ) -import Debug.Trace - -------------------------------------------------------------------------------- -- | Fits a cubic Bézier spline to the given curve \( t \mapsto C(t), 0 \leqslant t \leqslant 1 \),