use diagrams to parse MetaFont paths

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
+        splines
-        , dlist
+      , atomic-file-ops
-            ^>= 1.0
+          ^>= 0.3.0.0
-        , Earley
+      , bytestring
-            ^>= 0.13.0.1
+           >= 0.10.10.0  && < 0.12
-        , tree-view
+      , dlist
-            ^>= 0.5
+          ^>= 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

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

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 }

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 }

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

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

src/splines/Math/MPoly.hs

@@ -1 +0,0 @@
-module Math.MPoly where