use diagrams to parse MetaFont paths

This commit is contained in:
sheaf 2022-02-13 17:30:54 +01:00
parent 64e45f126b
commit 4e15380c7e
13 changed files with 450 additions and 35 deletions

View file

@ -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

156
src/convert/Main.hs Normal file
View file

@ -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

View file

@ -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 }

View file

@ -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 }

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

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