From 4e15380c7ea8aafe6ceb754250551db84e06c9ad Mon Sep 17 00:00:00 2001 From: sheaf Date: Sun, 13 Feb 2022 17:30:54 +0100 Subject: [PATCH] use diagrams to parse MetaFont paths --- MetaBrush.cabal | 87 +++++-- src/convert/Main.hs | 156 +++++++++++++ src/convert/MetaBrush/MetaFont/Convert.hs | 218 ++++++++++++++++++ .../MetaBrush/Asset/Brushes.hs | 0 .../MetaBrush/Document.hs | 4 + .../MetaBrush/Document/Draw.hs | 0 .../MetaBrush/Document/History.hs | 2 +- .../MetaBrush/Document/Serialise.hs | 0 .../MetaBrush/Document/SubdivideStroke.hs | 0 src/metabrushes/MetaBrush/Records.hs | 9 +- src/metabrushes/MetaBrush/Serialisable.hs | 6 - src/splines/Math/Bezier/Spline.hs | 2 +- src/splines/Math/MPoly.hs | 1 - 13 files changed, 450 insertions(+), 35 deletions(-) create mode 100644 src/convert/Main.hs create mode 100644 src/convert/MetaBrush/MetaFont/Convert.hs rename src/{app => metabrushes}/MetaBrush/Asset/Brushes.hs (100%) rename src/{app => metabrushes}/MetaBrush/Document.hs (98%) rename src/{app => metabrushes}/MetaBrush/Document/Draw.hs (100%) rename src/{app => metabrushes}/MetaBrush/Document/History.hs (99%) rename src/{app => metabrushes}/MetaBrush/Document/Serialise.hs (100%) rename src/{app => metabrushes}/MetaBrush/Document/SubdivideStroke.hs (100%) delete mode 100644 src/splines/Math/MPoly.hs diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 2b60e0b..b61f01d 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -50,9 +50,6 @@ common common , transformers ^>= 0.5.6.2 - default-language: - Haskell2010 - ghc-options: -O1 -fexpose-all-unfoldings @@ -72,7 +69,11 @@ common common common extras build-depends: - hashable + directory + >= 1.3.4.0 && < 1.4 + , filepath + ^>= 1.4.2.1 + , hashable >= 1.3.0.0 && < 1.5 , lens >= 4.19.2 && < 5.2 @@ -122,6 +123,9 @@ library splines hs-source-dirs: src/splines + default-language: + Haskell2010 + exposed-modules: Math.Bezier.Cubic , Math.Bezier.Cubic.Fit @@ -156,9 +160,18 @@ library metabrushes hs-source-dirs: src/metabrushes + default-language: + Haskell2010 + exposed-modules: MetaBrush.Assert + , MetaBrush.Asset.Brushes , MetaBrush.Brush + , MetaBrush.Document + , MetaBrush.Document.Draw + , MetaBrush.Document.History + , MetaBrush.Document.Serialise + , MetaBrush.Document.SubdivideStroke , MetaBrush.DSL.AST , MetaBrush.DSL.Driver , MetaBrush.DSL.Eval @@ -172,19 +185,54 @@ library metabrushes , MetaBrush.Serialisable , MetaBrush.Unique , MetaBrush.Util + , Paths_MetaBrush + + autogen-modules: + Paths_MetaBrush if flag(asserts) cpp-options: -DASSERTS build-depends: - splines - , dlist - ^>= 1.0 - , Earley - ^>= 0.13.0.1 - , tree-view - ^>= 0.5 + splines + , atomic-file-ops + ^>= 0.3.0.0 + , bytestring + >= 0.10.10.0 && < 0.12 + , dlist + ^>= 1.0 + , Earley + ^>= 0.13.0.1 + , tree-view + ^>= 0.5 + + +executable convert-metafont + + import: + common, extras + + hs-source-dirs: + src/convert + + default-language: + Haskell2010 + + main-is: + + Main.hs + + other-modules: + MetaBrush.MetaFont.Convert + + build-depends: + splines, + metabrushes, + diagrams-contrib, + diagrams-lib, + linear, + parsec executable MetaBrush @@ -199,10 +247,12 @@ executable MetaBrush main-is: Main.hs + default-language: + Haskell2010 + other-modules: MetaBrush.Action , MetaBrush.Application - , MetaBrush.Asset.Brushes , MetaBrush.Asset.CloseTabButton , MetaBrush.Asset.Colours , MetaBrush.Asset.Cursor @@ -212,12 +262,7 @@ executable MetaBrush , MetaBrush.Asset.Tools , MetaBrush.Asset.WindowIcons , MetaBrush.Context - , MetaBrush.Document - , MetaBrush.Document.Draw - , MetaBrush.Document.History , MetaBrush.Document.Selection - , MetaBrush.Document.Serialise - , MetaBrush.Document.SubdivideStroke , MetaBrush.Document.Update , MetaBrush.Event , MetaBrush.GTK.Util @@ -246,13 +291,5 @@ executable MetaBrush build-depends: splines , metabrushes - , atomic-file-ops - ^>= 0.3.0.0 - , bytestring - >= 0.10.10.0 && < 0.12 - , directory - >= 1.3.4.0 && < 1.4 - , filepath - ^>= 1.4.2.1 , tardis >= 0.4.2.0 && < 0.5 diff --git a/src/convert/Main.hs b/src/convert/Main.hs new file mode 100644 index 0000000..c76e417 --- /dev/null +++ b/src/convert/Main.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +-- base +import System.Exit + ( exitSuccess, exitFailure ) +import GHC.Exts + ( RealWorld ) + +-- containers +import qualified Data.Sequence as Seq + ( singleton ) + +-- diagrams-contrib +import qualified Diagrams.TwoD.Path.Metafont as MetaFont + ( metafont ) +import Diagrams.TwoD.Path.Metafont.Combinators + ( (.--.), (.-), (-.) + , endpt, arriving, leaving + ) + +-- diagrams-lib +import Diagrams.Prelude + ( p2 ) +import qualified Diagrams.Trail as Diagrams + ( Line ) + +-- linear +import qualified Linear.V2 as Linear + ( V2(..) ) + +-- transformers +import Control.Monad.Trans.Reader + ( runReaderT ) + +-- splines +import Math.Bezier.Spline + ( Spline, SplineType(..) ) +import Math.Bezier.Stroke + ( CachedStroke(..) ) +import Math.Vector2D + ( Point2D(..) ) + +-- metabrushes +import MetaBrush.Asset.Brushes + ( EllipseBrushFields, ellipse ) +import MetaBrush.Document + ( Document(..), DocumentContent(..) + , StrokeHierarchy(..), Stroke(..) + , PointData + ) +import MetaBrush.Document.Serialise + ( saveDocument ) +import MetaBrush.Records + ( Rec, I(..) ) +import qualified MetaBrush.Records as Rec + ( empty, insert ) +import MetaBrush.Unique + ( newUniqueSupply, freshUnique ) + +-- convert-metafont +import MetaBrush.MetaFont.Convert + ( MetaFontError, trailToSpline ) + +-------------------------------------------------------------------------------- + +test :: Either MetaFontError (Spline Open (CachedStroke RealWorld) (PointData (Rec EllipseBrushFields))) +test = trailToSpline @Diagrams.Line + ( MetaFont.metafont path ) params + where + z1 = p2 ( 2 , 5 ) + z2 = p2 ( 3 , -8 ) + z3 = p2 ( 3 , -14 ) + z4 = p2 ( 6.5, -16 ) + z5 = p2 ( 10 , -12 ) + z6 = p2 ( 7.5, -7.5 ) + z7 = p2 ( 4 , -7.5 ) + z8 = p2 ( 7.5, -7.5 ) + z9 = p2 ( 11.5, -2 ) + z0 = p2 ( 5 , -1 ) + path = + z1 .--. + z2 .--. + z3 .--. + z4 .--. + z5 .--. + z6 .- up -. + z7 .--. + z8 .--. + z9 .- up -. + endpt z0 + + params :: [ Rec EllipseBrushFields ] + params = + map ( uncurry mk_ellipse ) + [ ( 2 , -0.349066 ) + , ( 0.5, 0 ) + , ( 1 , 0.785398 ) + , ( 0.8, 1.5708 ) + , ( 1.5, 3.14159 ) + , ( 0.4, 3.66519 ) + , ( 0.4, 6.283185 ) + , ( 0.4, 8.90 ) + , ( 1.5, 9.4247 ) + , ( 0.3, 12.217 ) + ] + + + mk_ellipse :: Double -> Double -> Rec EllipseBrushFields + mk_ellipse a phi = + Rec.insert @"a" (I $ 0.5 * a) $ Rec.insert @"b" (I 0.05) $ Rec.insert @"phi" (I phi) $ Rec.empty + + up = arriving $ Linear.V2 0 (-1) + +main :: IO () +main = case test of + Left err -> do + print err + exitFailure + Right spline -> do + + uniqueSupply <- newUniqueSupply + docUnique <- runReaderT freshUnique uniqueSupply + strokeUnique <- runReaderT freshUnique uniqueSupply + ellipseBrush <- ellipse uniqueSupply + + let + stroke :: Stroke + stroke = + Stroke + { strokeName = "beta" + , strokeVisible = True + , strokeUnique = strokeUnique + , strokeBrush = Just ellipseBrush + , strokeSpline = spline + } + doc :: Document + doc = + Document + { displayName = "beta" + , mbFilePath = Just "betamf.mb" + , viewportCenter = Point2D 0 0 + , zoomFactor = 16 + , documentUnique = docUnique + , documentContent = + Content + { unsavedChanges = False + , latestChange = "Parsed from MetaFont" + , guides = mempty + , strokes = Seq.singleton ( StrokeLeaf stroke ) } + } + saveDocument "betamf.mb" doc + exitSuccess diff --git a/src/convert/MetaBrush/MetaFont/Convert.hs b/src/convert/MetaBrush/MetaFont/Convert.hs new file mode 100644 index 0000000..06c0662 --- /dev/null +++ b/src/convert/MetaBrush/MetaFont/Convert.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UnboxedTuples #-} + +module MetaBrush.MetaFont.Convert + ( MetaFontError(..) + , SomeSpline(..) + , parseMetaFontPath + , trailToSpline + ) + where + +-- base +import Data.Kind + ( Type ) +import Data.Foldable + ( toList ) +import qualified Data.Bifunctor as Bi + ( first ) +import GHC.Exts + ( RealWorld, newMutVar#, runRW# ) +import GHC.STRef + ( STRef(..) ) + +-- acts +import Data.Act + ( Act((•)) ) + +-- containers +import qualified Data.Sequence as Seq + ( fromList ) + +-- diagrams-contrib +import qualified Diagrams.TwoD.Path.Metafont as MetaFont + ( fromString ) + +-- diagrams-lib +import qualified Diagrams.Located as Diagrams + ( Located(..) ) +import qualified Diagrams.Segment as Diagrams + ( Segment(..), Offset(..) + , Open, Closed + ) +import qualified Diagrams.Trail as Diagrams + ( Trail(..), Trail'(..), SegTree(..) + , Line, Loop + ) + +-- linear +import qualified Linear.V2 as Linear + ( V2(..) ) +import qualified Linear.Affine as Linear + ( Point(..) ) + +-- parsec +import qualified Text.Parsec.Error as Parsec + ( ParseError ) + +-- text +import Data.Text + ( Text ) + +-- splines +import Math.Bezier.Spline + ( Spline(..), SplineType(..), KnownSplineType + , Curves(..), Curve(..), NextPoint(..) + ) +import Math.Bezier.Stroke + ( CachedStroke(..) ) +import Math.Module + ( lerp ) +import Math.Vector2D + ( Point2D(..), Vector2D(..) ) + +-- metabrushes +import MetaBrush.DSL.Interpolation + ( Interpolatable(Diff) ) +import MetaBrush.Document + ( PointData(..), FocusState(Normal) ) + +-------------------------------------------------------------------------------- + +data MetaFontError + = PathParseError Parsec.ParseError + | TooFewBrushParams + | TooManyBrushParams + deriving stock Show + +type Openness :: Type -> SplineType +type family Openness l = clo | clo -> l where + Openness Diagrams.Line = Open + Openness Diagrams.Loop = Closed + +type Openness' :: Type -> SplineType +type family Openness' c = clo | clo -> c where + Openness' Diagrams.Closed = Open + Openness' Diagrams.Open = Closed + +type LocatedTrail = Diagrams.Located (Diagrams.Trail Linear.V2 Double) +type LocatedTrail' l = Diagrams.Located (Diagrams.Trail' l Linear.V2 Double) + +data SomeSpline ptData where + SomeSpline :: KnownSplineType clo => Spline clo (CachedStroke RealWorld) ptData -> SomeSpline ptData + +parseMetaFontPath :: Interpolatable ptParams => Text -> [ptParams] -> Either MetaFontError (SomeSpline (PointData ptParams)) +parseMetaFontPath pathText ptParams = do + locTrail <- Bi.first PathParseError $ MetaFont.fromString @LocatedTrail pathText + let + loc = Diagrams.loc locTrail + case Diagrams.unLoc locTrail of + Diagrams.Trail trail'@(Diagrams.Line {}) -> + SomeSpline <$> trailToSpline @Diagrams.Line ( Diagrams.Loc { Diagrams.loc = loc, Diagrams.unLoc = trail' } ) ptParams + Diagrams.Trail trail'@(Diagrams.Loop {}) -> + SomeSpline <$> trailToSpline @Diagrams.Loop ( Diagrams.Loc { Diagrams.loc = loc, Diagrams.unLoc = trail' } ) ptParams + +trailToSpline :: forall l ptParams + . Interpolatable ptParams + => LocatedTrail' l + -> [ptParams] + -> Either MetaFontError (Spline (Openness l) (CachedStroke RealWorld) (PointData ptParams)) +trailToSpline _ [] = Left TooFewBrushParams +trailToSpline (Diagrams.Loc { Diagrams.loc = Linear.P ( Linear.V2 sx sy ), Diagrams.unLoc = trail }) (ptDatum:ptData) = + case trail of + Diagrams.Line ( Diagrams.SegTree segs ) -> do + ( curves, _, _ ) <- go start (toList segs) ptData + pure $ + Spline + { splineStart = start + , splineCurves = OpenCurves { openCurves = Seq.fromList curves } + } + Diagrams.Loop ( Diagrams.SegTree prevSegs ) lastSeg -> do + ( prevCurves, lastStart, endParams ) <- go start (toList prevSegs) ptData + case endParams of + [] -> Left TooFewBrushParams + ( _ : _ : _ ) -> Left TooManyBrushParams + [ lastParams ] -> + pure $ + Spline + { splineStart = start + , splineCurves = + ClosedCurves + { prevOpenCurves = Seq.fromList prevCurves + , lastClosedCurve = segmentToCurve lastStart lastParams lastSeg + } + } + where + start :: PointData ptParams + start = PointData + { pointCoords = Point2D sx sy + , pointState = Normal + , brushParams = ptDatum + } + go :: PointData ptParams + -> [Diagrams.Segment Diagrams.Closed Linear.V2 Double] + -> [ptParams] + -> Either MetaFontError ( [Curve Open (CachedStroke RealWorld) (PointData ptParams)], PointData ptParams, [ptParams] ) + go p0 [] pars = Right ( [], p0, pars ) + go p0 (seg:segs) (par1:pars) = + let + nextStart :: PointData ptParams + nextStart = + case seg of + Diagrams.Linear ( Diagrams.OffsetClosed ( Linear.V2 ex ey ) ) -> + Vector2D ex ey • ( p0 { brushParams = par1 } ) + Diagrams.Cubic _ _ ( Diagrams.OffsetClosed ( Linear.V2 ex ey ) ) -> + Vector2D ex ey • ( p0 { brushParams = par1 } ) + curve :: Curve Open (CachedStroke RealWorld) (PointData ptParams) + curve = segmentToCurve p0 par1 seg + in + fmap ( \ (crvs, end, endParams) -> (curve:crvs, end, endParams) ) $ go nextStart segs pars + go _ (_:_) [] = Left TooFewBrushParams + +segmentToCurve :: forall c ptParams + . Interpolatable ptParams + => PointData ptParams -- ^ start point + -> ptParams -- ^ parameters at end of curve + -> Diagrams.Segment c Linear.V2 Double + -> Curve (Openness' c) (CachedStroke RealWorld) (PointData ptParams) +segmentToCurve p0@( PointData { brushParams = startParams } ) endParams = \case + Diagrams.Linear end -> + LineTo + { curveEnd = offsetToNextPoint ( p0 { brushParams = endParams } ) end + , curveData = noCache + } + Diagrams.Cubic ( Linear.V2 x1 y1 ) ( Linear.V2 x2 y2 ) end -> + Bezier3To + { controlPoint1 = Vector2D x1 y1 • ( p0 { brushParams = lerpParams (1/3) startParams endParams } ) + , controlPoint2 = Vector2D x2 y2 • ( p0 { brushParams = lerpParams (2/3) startParams endParams } ) + , curveEnd = offsetToNextPoint ( p0 { brushParams = endParams } ) end + , curveData = noCache + } + + where + lerpParams :: Double -> ptParams -> ptParams -> ptParams + lerpParams = lerp @( Diff ptParams ) + +offsetToNextPoint :: PointData ptParams + -> Diagrams.Offset c Linear.V2 Double + -> NextPoint (Openness' c) (PointData ptParams) +offsetToNextPoint _ Diagrams.OffsetOpen + = BackToStart +offsetToNextPoint p0 ( Diagrams.OffsetClosed ( Linear.V2 ex ey ) ) + = NextPoint $ Vector2D ex ey • p0 + +noCache :: CachedStroke RealWorld +noCache = runRW# \ s -> + case newMutVar# Nothing s of + (# _, mutVar #) -> + CachedStroke { cachedStrokeRef = STRef mutVar } diff --git a/src/app/MetaBrush/Asset/Brushes.hs b/src/metabrushes/MetaBrush/Asset/Brushes.hs similarity index 100% rename from src/app/MetaBrush/Asset/Brushes.hs rename to src/metabrushes/MetaBrush/Asset/Brushes.hs diff --git a/src/app/MetaBrush/Document.hs b/src/metabrushes/MetaBrush/Document.hs similarity index 98% rename from src/app/MetaBrush/Document.hs rename to src/metabrushes/MetaBrush/Document.hs index 417cae4..2aee1b3 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/metabrushes/MetaBrush/Document.hs @@ -254,6 +254,10 @@ data PointData params deriving stock ( Show, Generic ) deriving anyclass NFData +instance Act (Vector2D Double) (PointData params) where + v • ( dat@( PointData { pointCoords = p } ) ) = + dat { pointCoords = v • p } + data BrushPointData = BrushPointData { brushPointState :: FocusState } diff --git a/src/app/MetaBrush/Document/Draw.hs b/src/metabrushes/MetaBrush/Document/Draw.hs similarity index 100% rename from src/app/MetaBrush/Document/Draw.hs rename to src/metabrushes/MetaBrush/Document/Draw.hs diff --git a/src/app/MetaBrush/Document/History.hs b/src/metabrushes/MetaBrush/Document/History.hs similarity index 99% rename from src/app/MetaBrush/Document/History.hs rename to src/metabrushes/MetaBrush/Document/History.hs index 4061c69..7042c48 100644 --- a/src/app/MetaBrush/Document/History.hs +++ b/src/metabrushes/MetaBrush/Document/History.hs @@ -54,7 +54,7 @@ data DocumentHistory instance NFData DocumentHistory where rnf ( History { past = ps, present, future } ) = ps `deepseq` present `deepseq` future `deepseq` () - + back :: DocumentHistory -> DocumentHistory back hist@( History { past = ps, present = c, future = fs } ) = case ps of Empty -> hist diff --git a/src/app/MetaBrush/Document/Serialise.hs b/src/metabrushes/MetaBrush/Document/Serialise.hs similarity index 100% rename from src/app/MetaBrush/Document/Serialise.hs rename to src/metabrushes/MetaBrush/Document/Serialise.hs diff --git a/src/app/MetaBrush/Document/SubdivideStroke.hs b/src/metabrushes/MetaBrush/Document/SubdivideStroke.hs similarity index 100% rename from src/app/MetaBrush/Document/SubdivideStroke.hs rename to src/metabrushes/MetaBrush/Document/SubdivideStroke.hs diff --git a/src/metabrushes/MetaBrush/Records.hs b/src/metabrushes/MetaBrush/Records.hs index 9af215b..d83dabb 100644 --- a/src/metabrushes/MetaBrush/Records.hs +++ b/src/metabrushes/MetaBrush/Records.hs @@ -179,7 +179,14 @@ instance ( AllFields Semigroup kvs instance AllFields NFData kvs => NFData ( Record I kvs ) where - rnf (MkR !_) = () -- todo + rnf (MkR r) = HashMap.foldlWithKey' go () r + where + dicts :: HashMap Text (Dict NFData Any) + MkR dicts = recordDicts @NFData @kvs + go :: () -> Text -> I Any -> () + go !_ k (I a) = + case dicts HashMap.! k of + Dict -> rnf a data MyIntersection r1 g r2 c where MyIntersection diff --git a/src/metabrushes/MetaBrush/Serialisable.hs b/src/metabrushes/MetaBrush/Serialisable.hs index 0056aaa..0e3a20e 100644 --- a/src/metabrushes/MetaBrush/Serialisable.hs +++ b/src/metabrushes/MetaBrush/Serialisable.hs @@ -37,10 +37,6 @@ import Data.Functor.Identity ( Identity(..) ) import Data.STRef ( newSTRef ) -import GHC.Exts - ( Proxy# ) -import GHC.TypeLits - ( symbolVal', KnownSymbol ) -- containers import Data.Map.Strict @@ -67,8 +63,6 @@ import qualified Data.Scientific as Scientific -- text import Data.Text ( Text ) -import qualified Data.Text as Text - ( pack ) -- transformers import Control.Monad.IO.Class diff --git a/src/splines/Math/Bezier/Spline.hs b/src/splines/Math/Bezier/Spline.hs index 2b4be12..33b65aa 100644 --- a/src/splines/Math/Bezier/Spline.hs +++ b/src/splines/Math/Bezier/Spline.hs @@ -99,7 +99,7 @@ class ( Traversable ( NextPoint clo ) ) => SplineTypeI ( clo :: SplineType ) where -- | Singleton for the spline type - ssplineType :: SSplineType clo + ssplineType :: SSplineType clo instance SplineTypeI Open where ssplineType = SOpen instance SplineTypeI Closed where diff --git a/src/splines/Math/MPoly.hs b/src/splines/Math/MPoly.hs deleted file mode 100644 index 0efe206..0000000 --- a/src/splines/Math/MPoly.hs +++ /dev/null @@ -1 +0,0 @@ -module Math.MPoly where \ No newline at end of file