hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 23:03:38 +00:00
Code Issues Actions Projects Releases Wiki Activity

Restructure project & update bounds

Browse source
This commit is contained in:
sheaf 2024-02-17 13:58:40 +01:00
parent 1368825103
commit 6b658acedd
34 changed files with 373 additions and 226 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

115
MetaBrush.cabal
View file

@ -29,34 +29,27 @@ flag asserts
default: False default: False
manual: True manual: True
flag use-fma
description: Use fused-muliply add instructions to implement interval arithmetic.
default: False
manual: True
common common common common
build-depends: build-depends:
base brush-strokes
>= 4.17 && < 4.19 ^>= 0.1.0.0
, base
>= 4.17 && < 5
, acts , acts
^>= 0.3.1.0 ^>= 0.3.1.0
, code-page , code-page
^>= 0.2.1 ^>= 0.2.1
, containers , containers
>= 0.6.0.1 && < 0.7 >= 0.6.0.1 && < 0.8
, deepseq , deepseq
>= 1.4.4.0 && < 1.5 >= 1.4.4.0 && < 1.6
, generic-lens , generic-lens
>= 2.2 && < 2.3 >= 2.2 && < 2.3
, groups , groups
^>= 0.5.3 ^>= 0.5.3
, groups-generic
^>= 0.3.1.0
, primitive , primitive
^>= 0.7.1.0 ^>= 0.9.0.0
, rounded-hw
^>= 0.3
, transformers , transformers
>= 0.5.6.2 && < 0.7 >= 0.5.6.2 && < 0.7
@ -94,14 +87,11 @@ common common
UnboxedTuples UnboxedTuples
ViewPatterns ViewPatterns
if impl(ghc >= 9.8)
default-extensions:
TypeAbstractions
ghc-options: ghc-options:
-O2
-fexpose-all-unfoldings
-- -funfolding-use-threshold=1000
-fspecialise-aggressively
-flate-dmd-anal
-fmax-worker-args=200
-optc-O3
-Wall -Wall
-Wcompat -Wcompat
-fwarn-missing-local-signatures -fwarn-missing-local-signatures
@ -114,14 +104,6 @@ common common
cpp-options: cpp-options:
-DASSERTS -DASSERTS
if flag(use-fma)
cpp-options:
-DUSE_FMA
ghc-options:
-mfma
if impl(ghc < 9.7)
buildable: False
autogen-modules: autogen-modules:
Paths_MetaBrush Paths_MetaBrush
@ -131,11 +113,10 @@ common common
common extras common extras
build-depends: build-depends:
directory directory
>= 1.3.4.0 && < 1.4 >= 1.3.4.0 && < 1.4
, filepath , filepath
^>= 1.4.2.1 >= 1.4.2.1 && < 1.6
, hashable , hashable
>= 1.3.0.0 && < 1.5 >= 1.3.0.0 && < 1.5
, lens , lens
@ -147,9 +128,9 @@ common extras
, stm , stm
^>= 2.5.0.0 ^>= 2.5.0.0
, text , text
>= 1.2.3.1 && < 2.1 ^>= 2.1.1
, unordered-containers , unordered-containers
>= 0.2.11 && < 0.2.20 >= 0.2.11 && < 0.3
, waargonaut , waargonaut
^>= 0.8.0.2 ^>= 0.8.0.2
@ -175,64 +156,6 @@ common gtk
, haskell-gi-base , haskell-gi-base
>= 0.26 && < 0.27 >= 0.26 && < 0.27
library splines
import:
common
hs-source-dirs:
src/splines
default-language:
Haskell2010
exposed-modules:
Math.Algebra.Dual
, Math.Bezier.Cubic
, Math.Bezier.Cubic.Fit
, Math.Bezier.Quadratic
, Math.Bezier.Spline
, Math.Bezier.Stroke
, Math.Bezier.Stroke.EnvelopeEquation
, Math.Differentiable
, Math.Epsilon
, Math.Interval
, Math.Linear
, Math.Linear.Solve
, Math.Module
, Math.Monomial
, Math.Orientation
, Math.Ring
, Math.Roots
, Debug.Utils
other-modules:
Math.Algebra.Dual.Internal
, Math.Interval.Internal
, Math.Linear.Internal
, Math.Module.Internal
, TH.Utils
if flag(use-fma)
other-modules:
Math.Interval.FMA
build-depends:
bifunctors
>= 5.5.4 && < 5.6
, eigen
^>= 3.3.7.0
, parallel
^>= 3.2.2.0
, prim-instances
^>= 0.2
, vector
>= 0.12.1.2 && < 0.14
, template-haskell
>= 2.18 && < 2.20
library metabrushes library metabrushes
import: import:
@ -259,8 +182,7 @@ library metabrushes
, MetaBrush.Util , MetaBrush.Util
build-depends: build-depends:
splines atomic-file-ops
, atomic-file-ops
^>= 0.3.0.0 ^>= 0.3.0.0
, bytestring , bytestring
>= 0.10.10.0 && < 0.12 >= 0.10.10.0 && < 0.12
@ -282,9 +204,6 @@ executable cusps
other-modules: other-modules:
Math.Interval.Abstract Math.Interval.Abstract
build-depends:
splines
executable convert-metafont executable convert-metafont
@ -304,7 +223,6 @@ executable convert-metafont
MetaBrush.MetaFont.Convert MetaBrush.MetaFont.Convert
build-depends: build-depends:
splines,
metabrushes, metabrushes,
diagrams-contrib, diagrams-contrib,
diagrams-lib, diagrams-lib,
@ -358,7 +276,6 @@ executable MetaBrush
-threaded -rtsopts -threaded -rtsopts
build-depends: build-depends:
splines metabrushes
, metabrushes
, tardis , tardis
>= 0.4.2.0 && < 0.5 >= 0.4.2.0 && < 0.5

152
brush-strokes/brush-strokes.cabal Normal file
View file

@ -0,0 +1,152 @@
cabal-version: 3.0
name: brush-strokes
version: 0.1.0.0
synopsis: Stroking brush paths
category: Calligraphy, Geometry, Graphics
license: BSD-3-Clause
homepage: https://gitlab.com/sheaf/MetaBrush
build-type: Simple
description:
Computing brush strokes using Bézier curves.
flag use-fma
description: Use fused-muliply add instructions to implement interval arithmetic.
default: True
manual: True
common common
build-depends:
base
>= 4.17 && < 4.20
, acts
^>= 0.3.1.0
, code-page
^>= 0.2.1
, containers
>= 0.6.0.1 && < 0.8
, deepseq
>= 1.4.4.0 && < 1.6
, generic-lens
>= 2.2 && < 2.3
, groups
^>= 0.5.3
, groups-generic
^>= 0.3.1.0
, primitive
^>= 0.9.0.0
, rounded-hw
^>= 0.4
, transformers
>= 0.5.6.2 && < 0.7
default-extensions:
BangPatterns
BlockArguments
ConstraintKinds
DataKinds
DeriveAnyClass
DeriveTraversable
DeriveGeneric
DerivingVia
FlexibleContexts
FlexibleInstances
FunctionalDependencies
GADTs
GeneralisedNewtypeDeriving
InstanceSigs
LambdaCase
LexicalNegation
MagicHash
MultiWayIf
NamedFieldPuns
NoStarIsType
PatternSynonyms
RankNTypes
RecordWildCards
RoleAnnotations
StandaloneDeriving
StandaloneKindSignatures
TupleSections
TypeApplications
TypeFamilies
TypeOperators
UnboxedTuples
ViewPatterns
ghc-options:
-O2
-fexpose-all-unfoldings
-- -funfolding-use-threshold=1000
-fspecialise-aggressively
-flate-dmd-anal
-fmax-worker-args=200
-optc-O3
-Wall
-Wcompat
-fwarn-missing-local-signatures
-fwarn-incomplete-patterns
-fwarn-incomplete-uni-patterns
-fwarn-missing-deriving-strategies
-fno-warn-unticked-promoted-constructors
if flag(use-fma)
cpp-options:
-DUSE_FMA
ghc-options:
-mfma
build-depends:
base
>= 4.19
library
import:
common
hs-source-dirs:
src
default-language:
Haskell2010
exposed-modules:
Math.Algebra.Dual
, Math.Bezier.Cubic
, Math.Bezier.Cubic.Fit
, Math.Bezier.Quadratic
, Math.Bezier.Spline
, Math.Bezier.Stroke
, Math.Bezier.Stroke.EnvelopeEquation
, Math.Differentiable
, Math.Epsilon
, Math.Interval
, Math.Linear
, Math.Linear.Solve
, Math.Module
, Math.Monomial
, Math.Orientation
, Math.Ring
, Math.Roots
, Debug.Utils
other-modules:
Math.Algebra.Dual.Internal
, Math.Interval.Internal
, Math.Linear.Internal
, Math.Module.Internal
, TH.Utils
if flag(use-fma)
other-modules:
Math.Interval.FMA
build-depends:
bifunctors
>= 5.5.4 && < 5.7
, eigen
^>= 3.3.7.0
, parallel
^>= 3.2.2.0
, template-haskell
>= 2.18 && < 2.22

28
brush-strokes/cabal.project Normal file
View file

@ -0,0 +1,28 @@
packages: .
constraints:
acts -finitary,
rounded-hw -pure-hs -c99 -avx512 +ghc-prim -x87-long-double
allow-newer:
acts:base, acts:deepseq,
groups-generic:base,
eigen:primitive,
-------------
-- GHC 9.4 --
-------------
-- eigen
source-repository-package
type: git
location: https://github.com/chessai/eigen
tag: 1790fdf9138970dde0dbabf8b270698145a4a88c
-------------
-- GHC 9.6 --
-------------
-------------
-- GHC 9.8 --
-------------

1
src/splines/Debug/Utils.hs → brush-strokes/src/Debug/Utils.hs
View file

@ -1,6 +1,5 @@
module Debug.Utils ( trace ) where module Debug.Utils ( trace ) where
-- base -- base
import System.IO import System.IO
( BufferMode(..), hSetBuffering, hFlush, hPutStrLn, stdout ) ( BufferMode(..), hSetBuffering, hFlush, hPutStrLn, stdout )

3
src/splines/Math/Algebra/Dual.hs → brush-strokes/src/Math/Algebra/Dual.hs
View file

@ -6,9 +6,6 @@
{-# OPTIONS_GHC -Wno-orphans -O2 #-} {-# OPTIONS_GHC -Wno-orphans -O2 #-}
{-# OPTIONS_GHC -ddump-splices -ddump-simpl -ddump-cmm -ddump-to-file -dno-typeable-binds
-dsuppress-unfoldings -dsuppress-coercions #-}
module Math.Algebra.Dual module Math.Algebra.Dual
( C(..), D ( C(..), D
, HasChainRule(..), chainRule , HasChainRule(..), chainRule

0
src/splines/Math/Algebra/Dual/Internal.hs → brush-strokes/src/Math/Algebra/Dual/Internal.hs
View file

0
src/splines/Math/Bezier/Cubic.hs → brush-strokes/src/Math/Bezier/Cubic.hs
View file

25
src/splines/Math/Bezier/Cubic/Fit.hs → brush-strokes/src/Math/Bezier/Cubic/Fit.hs
View file

@ -46,7 +46,12 @@ import qualified Control.Parallel.Strategies as Parallel.Strategy
-- primitive -- primitive
import Data.Primitive.PrimArray import Data.Primitive.PrimArray
( primArrayFromListN, unsafeThawPrimArray ) ( MutablePrimArray
, generatePrimArray
, primArrayFromListN
, unsafeThawPrimArray
, readPrimArray, writePrimArray
)
-- transformers -- transformers
import Control.Monad.Trans.State.Strict import Control.Monad.Trans.State.Strict
@ -54,14 +59,6 @@ import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
( lift ) ( lift )
-- vector
import qualified Data.Vector.Unboxed.Mutable as Unboxed
( MVector )
import qualified Data.Vector.Unboxed.Mutable as Unboxed.MVector
( unsafeRead, unsafeWrite )
import qualified Data.Vector.Unboxed as Unboxed.Vector
( unsafeThaw, generate )
-- MetaBrush -- MetaBrush
import qualified Math.Bezier.Cubic as Cubic import qualified Math.Bezier.Cubic as Cubic
( Bezier(..), bezier, ddist ) ( Bezier(..), bezier, ddist )
@ -202,7 +199,7 @@ fitPiece
fitPiece dist_tol t_tol maxIters p tp qs r tr = fitPiece dist_tol t_tol maxIters p tp qs r tr =
runST do runST do
-- Initialise the parameter values to a uniform subdivision. -- Initialise the parameter values to a uniform subdivision.
ts <- Unboxed.Vector.unsafeThaw ( Unboxed.Vector.generate n uniform ) ts <- unsafeThawPrimArray $ generatePrimArray n uniform
loop ts 0 loop ts 0
where where
n :: Int n :: Int
@ -216,12 +213,12 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr =
f2 t = h0 t *^ ( T p ) f2 t = h0 t *^ ( T p )
f3 t = h3 t *^ ( T r ) f3 t = h3 t *^ ( T r )
loop :: forall s. Unboxed.MVector s Double -> Int -> ST s ( Cubic.Bezier ( ℝ 2 ), ArgMax Double Double ) loop :: forall s. MutablePrimArray s Double -> Int -> ST s ( Cubic.Bezier ( ℝ 2 ), ArgMax Double Double )
loop ts count = do loop ts count = do
let let
hermiteParameters :: Mat22 -> T ( ℝ 2 ) -> Int -> [ ℝ 2 ] -> ST s ( T ( ℝ 2 ) ) hermiteParameters :: Mat22 -> T ( ℝ 2 ) -> Int -> [ ℝ 2 ] -> ST s ( T ( ℝ 2 ) )
hermiteParameters ( Mat22 a11 a12 _ a22 ) ( V2 b1 b2 ) i ( q : rest ) = do hermiteParameters ( Mat22 a11 a12 _ a22 ) ( V2 b1 b2 ) i ( q : rest ) = do
ti <- Unboxed.MVector.unsafeRead ts i ti <- readPrimArray ts i
let let
f0i, f1i, f2i, f3i :: T ( ℝ 2 ) f0i, f1i, f2i, f3i :: T ( ℝ 2 )
f0i = f0 ti f0i = f0 ti
@ -254,7 +251,7 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr =
-- so that t_i' is a better approximation of the parameter -- so that t_i' is a better approximation of the parameter
-- at which the curve is closest to q_i. -- at which the curve is closest to q_i.
( dts_changed, argmax_sq_dist ) <- ( `execStateT` ( False, Max ( Arg 0 0 ) ) ) $ for_ ( zip qs [ 0 .. ] ) \( q, i ) -> do ( dts_changed, argmax_sq_dist ) <- ( `execStateT` ( False, Max ( Arg 0 0 ) ) ) $ for_ ( zip qs [ 0 .. ] ) \( q, i ) -> do
ti <- lift ( Unboxed.MVector.unsafeRead ts i ) ti <- lift ( readPrimArray ts i )
let let
laguerreStepResult :: Complex Double laguerreStepResult :: Complex Double
laguerreStepResult = runST do laguerreStepResult = runST do
@ -277,7 +274,7 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr =
sq_dist :: Double sq_dist :: Double
sq_dist = quadrance @( T ( ℝ 2 ) ) q ( Cubic.bezier @( T ( ℝ 2 ) ) bez ti' ) sq_dist = quadrance @( T ( ℝ 2 ) ) q ( Cubic.bezier @( T ( ℝ 2 ) ) bez ti' )
modify' ( second ( <> Max ( Arg sq_dist ti' ) ) ) modify' ( second ( <> Max ( Arg sq_dist ti' ) ) )
lift ( Unboxed.MVector.unsafeWrite ts i ti' ) lift ( writePrimArray ts i ti' )
case argmax_sq_dist of case argmax_sq_dist of
Max ( Arg max_sq_dist _ ) Max ( Arg max_sq_dist _ )

0
src/splines/Math/Bezier/Quadratic.hs → brush-strokes/src/Math/Bezier/Quadratic.hs
View file

0
src/splines/Math/Bezier/Spline.hs → brush-strokes/src/Math/Bezier/Spline.hs
View file

46
src/splines/Math/Bezier/Stroke.hs → brush-strokes/src/Math/Bezier/Stroke.hs
View file

@ -10,6 +10,8 @@ module Math.Bezier.Stroke
, computeStrokeOutline, joinWithBrush , computeStrokeOutline, joinWithBrush
, withTangent , withTangent
, RootSolvingAlgorithm(..) -- TODO: move this?
-- * Brush stroking -- * Brush stroking
, brushStroke, envelopeEquation , brushStroke, envelopeEquation
@ -127,8 +129,6 @@ import Math.Orientation
, between , between
) )
import Math.Roots import Math.Roots
( solveQuadratic, newtonRaphson )
import Debug.Utils import Debug.Utils
@ -237,7 +237,8 @@ computeStrokeOutline ::
, Show ptData, Show brushParams , Show ptData, Show brushParams
) )
=> FitParameters => RootSolvingAlgorithm
-> FitParameters
-> ( ptData -> usedParams ) -> ( ptData -> usedParams )
-> ( usedParams -> brushParams ) -- ^ assumed to be linear and non-decreasing -> ( usedParams -> brushParams ) -- ^ assumed to be linear and non-decreasing
-> ( forall {t} k (i :: t) -> ( forall {t} k (i :: t)
@ -253,7 +254,7 @@ computeStrokeOutline ::
, Seq FitPoint , Seq FitPoint
, [ Cusp ] , [ Cusp ]
) )
computeStrokeOutline fitParams ptParams toBrushParams brushFn spline@( Spline { splineStart = spt0 } ) = case ssplineType @clo of computeStrokeOutline rootAlgo fitParams ptParams toBrushParams brushFn spline@( Spline { splineStart = spt0 } ) = case ssplineType @clo of
-- Open brush path with at least one segment. -- Open brush path with at least one segment.
-- Need to add caps at both ends of the path. -- Need to add caps at both ends of the path.
SOpen SOpen
@ -355,7 +356,7 @@ computeStrokeOutline fitParams ptParams toBrushParams brushFn spline@( Spline {
where where
outlineInfo :: ptData -> Curve Open crvData ptData -> OutlineInfo outlineInfo :: ptData -> Curve Open crvData ptData -> OutlineInfo
outlineInfo = inline ( outlineFunction ptParams toBrushParams brushFn ) outlineInfo = inline ( outlineFunction rootAlgo ptParams toBrushParams brushFn )
outlineFns :: Seq OutlineInfo outlineFns :: Seq OutlineInfo
outlineFns = go spt0 ( openCurves $ splineCurves ( adjustSplineType @Open spline ) ) outlineFns = go spt0 ( openCurves $ splineCurves ( adjustSplineType @Open spline ) )
@ -517,7 +518,8 @@ outlineFunction
-- Debugging. -- Debugging.
, Show ptData, Show brushParams , Show ptData, Show brushParams
) )
=> ( ptData -> usedParams ) => RootSolvingAlgorithm
-> ( ptData -> usedParams )
-> ( usedParams -> brushParams ) -- ^ assumed to be linear and non-decreasing -> ( usedParams -> brushParams ) -- ^ assumed to be linear and non-decreasing
-> ( forall {t} k (i :: t) -> ( forall {t} k (i :: t)
. DiffInterp k i brushParams . DiffInterp k i brushParams
@ -529,7 +531,7 @@ outlineFunction
-> ptData -> ptData
-> Curve Open crvData ptData -> Curve Open crvData ptData
-> OutlineInfo -> OutlineInfo
outlineFunction ptParams toBrushParams brushFromParams = \ sp0 crv -> outlineFunction rootAlgo ptParams toBrushParams brushFromParams = \ sp0 crv ->
let let
usedParams :: C 2 ( ℝ 1 ) usedParams usedParams :: C 2 ( ℝ 1 ) usedParams
@ -566,7 +568,7 @@ outlineFunction ptParams toBrushParams brushFromParams = \ sp0 crv ->
fwdBwd :: OutlineFn fwdBwd :: OutlineFn
fwdBwd t fwdBwd t
= solveEnvelopeEquations t path_t path'_t ( fwdOffset, bwdOffset ) = solveEnvelopeEquations rootAlgo t path_t path'_t ( fwdOffset, bwdOffset )
( curves t ) ( curves t )
where where
@ -953,15 +955,23 @@ splineCurveFns co spls
Bezier3To { controlPoint1 = p1, controlPoint2 = p2, curveEnd = NextPoint p3 } Bezier3To { controlPoint1 = p1, controlPoint2 = p2, curveEnd = NextPoint p3 }
-> bezier3 @k @i @( ℝ 2 ) co $ Cubic.Bezier p0 p1 p2 p3 -> bezier3 @k @i @( ℝ 2 ) co $ Cubic.Bezier p0 p1 p2 p3
-- | Which method to use to solve the envelope equation?
data RootSolvingAlgorithm
-- | Use the Newton–Raphson method.
= NewtonRaphson { maxIters :: Word, precision :: Int }
-- | Use the modified Halley M2 method.
| HalleyM2 { maxIters :: Word, precision :: Int }
-- | Solve the envelope equations at a given point \( t = t_0 \), to find -- | Solve the envelope equations at a given point \( t = t_0 \), to find
-- \( s_0 \) such that \( c(t_0, s_0) \) is on the envelope of the brush stroke. -- \( s_0 \) such that \( c(t_0, s_0) \) is on the envelope of the brush stroke.
solveEnvelopeEquations :: ℝ 1 -- ^ @t@ (for debugging only) solveEnvelopeEquations :: RootSolvingAlgorithm
-> ℝ 1 -- ^ @t@ (for debugging only)
-> ℝ 2 -> ℝ 2
-> T ( ℝ 2 ) -> T ( ℝ 2 )
-> ( Offset, Offset ) -> ( Offset, Offset )
-> Seq ( ℝ 1 -> StrokeDatum 2 () ) -> Seq ( ℝ 1 -> StrokeDatum 2 () )
-> ( ( ℝ 2, T ( ℝ 2 ) ), ( ℝ 2, T ( ℝ 2 ) ) ) -> ( ( ℝ 2, T ( ℝ 2 ) ), ( ℝ 2, T ( ℝ 2 ) ) )
solveEnvelopeEquations _t path_t path'_t ( fwdOffset, bwdOffset ) strokeData solveEnvelopeEquations rootAlgo _t path_t path'_t ( fwdOffset, bwdOffset ) strokeData
= ( fwdSol, ( bwdPt, -1 *^ bwdTgt ) ) = ( fwdSol, ( bwdPt, -1 *^ bwdTgt ) )
where where
@ -999,12 +1009,18 @@ solveEnvelopeEquations _t path_t path'_t ( fwdOffset, bwdOffset ) strokeData
sol :: Seq ( ℝ 1 -> StrokeDatum 2 () ) -> Double -> ( Bool, ℝ 2, T ( ℝ 2 ) ) sol :: Seq ( ℝ 1 -> StrokeDatum 2 () ) -> Double -> ( Bool, ℝ 2, T ( ℝ 2 ) )
sol f is0 = sol f is0 =
let ( good, is ) = let ( good, is ) =
case newtonRaphson maxIters precision domain ( eqn f ) is0 of case runSolveMethod ( eqn f ) is0 of
Nothing -> ( False, is0 ) Nothing -> ( False, is0 )
Just is1 -> ( True , is1 ) Just is1 -> ( True , is1 )
( ds, dcdt ) = finish f is ( ds, dcdt ) = finish f is
in ( good, ds, dcdt ) in ( good, ds, dcdt )
runSolveMethod = case rootAlgo of
HalleyM2 { maxIters, precision } ->
halleyM2 maxIters precision
NewtonRaphson { maxIters, precision } ->
newtonRaphson maxIters precision domain
finish :: Seq ( ℝ 1 -> StrokeDatum 2 () ) -> Double -> ( ℝ 2, T ( ℝ 2 ) ) finish :: Seq ( ℝ 1 -> StrokeDatum 2 () ) -> Double -> ( ℝ 2, T ( ℝ 2 ) )
finish f is = finish f is =
let (i, s) = fromDomain is in let (i, s) = fromDomain is in
@ -1037,17 +1053,13 @@ solveEnvelopeEquations _t path_t path'_t ( fwdOffset, bwdOffset ) strokeData
-- ] ) -- ] )
( value @Double @2 @( ℝ 2 ) dstroke, dcdt ) ( value @Double @2 @( ℝ 2 ) dstroke, dcdt )
eqn :: Seq ( ℝ 1 -> StrokeDatum 2 () ) -> ( Double -> ( Double, Double ) ) eqn :: Seq ( ℝ 1 -> StrokeDatum 2 () ) -> ( Double -> (# Double, Double #) )
eqn fs is = eqn fs is =
let (i, s) = fromDomain is let (i, s) = fromDomain is
in case ( fs `Seq.index` i ) ( ℝ1 s ) of in case ( fs `Seq.index` i ) ( ℝ1 s ) of
StrokeDatum { ee = D12 ee _ ee_s } -> StrokeDatum { ee = D12 ee _ ee_s } ->
coerce ( ee, ee_s ) coerce (# ee, ee_s #)
maxIters :: Word
maxIters = 20
precision :: Int
precision = 8
n :: Int n :: Int
n = Seq.length strokeData n = Seq.length strokeData
domain :: ( Double, Double ) domain :: ( Double, Double )

0
src/splines/Math/Bezier/Stroke/EnvelopeEquation.hs → brush-strokes/src/Math/Bezier/Stroke/EnvelopeEquation.hs
View file

0
src/splines/Math/Differentiable.hs → brush-strokes/src/Math/Differentiable.hs
View file

0
src/splines/Math/Epsilon.hs → brush-strokes/src/Math/Epsilon.hs
View file

5
src/splines/Math/Interval.hs → brush-strokes/src/Math/Interval.hs
View file

@ -4,9 +4,6 @@
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -ddump-splices -ddump-simpl -ddump-cmm -ddump-to-file -dno-typeable-binds
-dsuppress-unfoldings -dsuppress-coercions #-}
module Math.Interval module Math.Interval
( 𝕀(𝕀), inf, sup ( 𝕀(𝕀), inf, sup
, scaleInterval , scaleInterval
@ -32,7 +29,7 @@ import Data.Group
import Data.Group.Generics import Data.Group.Generics
( ) ( )
-- splines -- brush-strokes
import Math.Algebra.Dual import Math.Algebra.Dual
import Math.Interval.Internal import Math.Interval.Internal
( 𝕀(𝕀), inf, sup, scaleInterval ) ( 𝕀(𝕀), inf, sup, scaleInterval )

0
src/splines/Math/Interval/FMA.hs → brush-strokes/src/Math/Interval/FMA.hs
View file

1
src/splines/Math/Interval/Internal.hs → brush-strokes/src/Math/Interval/Internal.hs
View file

@ -136,6 +136,7 @@ instance Transcendental ( 𝕀 Double ) where
atan = withHW Prelude.atan atan = withHW Prelude.atan
{-# INLINE withHW #-} {-# INLINE withHW #-}
-- | Internal function: use @rounded-hw@ to define a function on intervals.
withHW :: (Interval.Interval a -> Interval.Interval b) -> 𝕀 a -> 𝕀 b withHW :: (Interval.Interval a -> Interval.Interval b) -> 𝕀 a -> 𝕀 b
withHW f = \ ( 𝕀 lo hi ) -> withHW f = \ ( 𝕀 lo hi ) ->
case f ( Interval.I ( Rounded lo ) ( Rounded hi ) ) of case f ( Interval.I ( Rounded lo ) ( Rounded hi ) ) of

0
src/splines/Math/Linear.hs → brush-strokes/src/Math/Linear.hs
View file

0
src/splines/Math/Linear/Internal.hs → brush-strokes/src/Math/Linear/Internal.hs
View file

0
src/splines/Math/Linear/Solve.hs → brush-strokes/src/Math/Linear/Solve.hs
View file

0
src/splines/Math/Module.hs → brush-strokes/src/Math/Module.hs
View file

0
src/splines/Math/Module/Internal.hs → brush-strokes/src/Math/Module/Internal.hs
View file

0
src/splines/Math/Monomial.hs → brush-strokes/src/Math/Monomial.hs
View file

0
src/splines/Math/Orientation.hs → brush-strokes/src/Math/Orientation.hs
View file

0
src/splines/Math/Ring.hs → brush-strokes/src/Math/Ring.hs
View file

78
src/splines/Math/Roots.hs → brush-strokes/src/Math/Roots.hs
View file

@ -13,6 +13,9 @@ module Math.Roots
-- * Newton–Raphson -- * Newton–Raphson
, newtonRaphson , newtonRaphson
-- * Modified Halley's method M2
, halleyStep, halleyM2
) )
where where
@ -43,10 +46,6 @@ import Data.Primitive.PrimArray
import Data.Primitive.Types import Data.Primitive.Types
( Prim ) ( Prim )
-- prim-instances
import Data.Primitive.Instances
() -- instance Prim a => Prim ( Complex a )
-- MetaBrush -- MetaBrush
import Math.Epsilon import Math.Epsilon
( epsilon, nearZero ) ( epsilon, nearZero )
@ -299,15 +298,15 @@ derivative p = do
-- https://github.com/boostorg/math/blob/0dc6a70caa6bbec2b6ae25eede36c430f0ccae13/include/boost/math/tools/roots.hpp#L217 -- https://github.com/boostorg/math/blob/0dc6a70caa6bbec2b6ae25eede36c430f0ccae13/include/boost/math/tools/roots.hpp#L217
{-# SPECIALISE {-# SPECIALISE
newtonRaphson newtonRaphson
:: Word -> Int -> ( Double, Double ) -> ( Double -> ( Double, Double ) ) -> Double -> Maybe Double :: Word -> Int -> ( Double, Double ) -> ( Double -> (# Double, Double #) ) -> Double -> Maybe Double
#-} #-}
{-# INLINEABLE newtonRaphson #-} {-# INLINEABLE newtonRaphson #-}
newtonRaphson :: ( RealFloat r, Show r ) newtonRaphson :: ( RealFloat r, Show r )
=> Word -- ^ maximum number of iterations => Word -- ^ maximum number of iterations
-> Int -- ^ desired digits of precision -> Int -- ^ desired digits of precision
-> ( r, r ) -- ^ @(min_x, max_x)@. -> ( r, r ) -- ^ @(min_x, max_x)@.
-> ( r -> ( r, r ) ) -- ^ function and its derivative -> ( r -> (# r, r #) ) -- ^ function and its derivative
-> r -- ^ initial guess -> r -- ^ initial guess
-> Maybe r -> Maybe r
newtonRaphson maxIters digits ( min_x, max_x ) f x0 = newtonRaphson maxIters digits ( min_x, max_x ) f x0 =
doNewtonRaphson f maxIters factor min_x max_x 0 0 0 x0 maxRealFloat maxRealFloat doNewtonRaphson f maxIters factor min_x max_x 0 0 0 x0 maxRealFloat maxRealFloat
@ -315,7 +314,7 @@ newtonRaphson maxIters digits ( min_x, max_x ) f x0 =
!factor = encodeFloat 1 ( 1 - digits ) !factor = encodeFloat 1 ( 1 - digits )
doNewtonRaphson :: ( Fractional r, Ord r, Show r ) doNewtonRaphson :: ( Fractional r, Ord r, Show r )
=> ( r -> (r, r) ) => ( r -> (# r, r #) )
-> Word -> Word
-> r -> r
-> r -> r -> r -> r
@ -329,7 +328,7 @@ doNewtonRaphson f maxIters factor min_x max_x min_f_x max_f_x f_x_prev x δ1 δ2
where where
go min_x max_x min_f_x max_f_x f_x_prev !iters !x !δ1 !δ2 = go min_x max_x min_f_x max_f_x f_x_prev !iters !x !δ1 !δ2 =
case f x of case f x of
( f_x, f'_x ) (# f_x, f'_x #)
| f_x == 0 | f_x == 0
-> Just x -> Just x
| ( new_x, δ, δ1 ) <- newtonRaphsonStep f min_x max_x f_x_prev x f_x f'_x δ1 δ2 | ( new_x, δ, δ1 ) <- newtonRaphsonStep f min_x max_x f_x_prev x f_x f'_x δ1 δ2
@ -349,7 +348,7 @@ doNewtonRaphson f maxIters factor min_x max_x min_f_x max_f_x f_x_prev x δ1 δ2
go min_x max_x min_f_x max_f_x f_x ( iters + 1 ) new_x δ δ1 go min_x max_x min_f_x max_f_x f_x ( iters + 1 ) new_x δ δ1
newtonRaphsonStep :: ( Fractional r, Ord r, Show r ) newtonRaphsonStep :: ( Fractional r, Ord r, Show r )
=> ( r -> ( r, r ) ) => ( r -> (# r, r #) )
-> r -> r
-> r -> r -> r -> r -> r -> r
-> r -> r -> r -> r
@ -380,7 +379,7 @@ newtonRaphsonStep f min_x max_x f_x_prev x f_x f'_x δ1 δ2
-- Handle \( f'(x_0) = 0 \). -- Handle \( f'(x_0) = 0 \).
zeroDerivativeStep :: ( Fractional r, Ord r, Show r ) zeroDerivativeStep :: ( Fractional r, Ord r, Show r )
=> ( r -> ( r, r ) ) => ( r -> (# r, r #) )
-> r -> r
-> r -> r -> r -> r
-> r -> r
@ -390,7 +389,7 @@ zeroDerivativeStep f min_x max_x f_x_prev x f_x δ
-- Handle zero derivative on first iteration. -- Handle zero derivative on first iteration.
| f_x_prev == 0 | f_x_prev == 0
, x_prev <- if x <= 0.5 * ( min_x + max_x ) then max_x else min_x , x_prev <- if x <= 0.5 * ( min_x + max_x ) then max_x else min_x
, ( f_x_prev, _ ) <- f x_prev , (# f_x_prev, _ #) <- f x_prev
, δ <- x_prev - x , δ <- x_prev - x
= finish f_x_prev δ = finish f_x_prev δ
| otherwise | otherwise
@ -430,3 +429,52 @@ maxDouble :: Double
maxDouble = D# 1.7976931348623157e308## maxDouble = D# 1.7976931348623157e308##
-} -}
--------------------------------------------------------------------------------
-- Halley's method (WIP).
-- | Take a single step with Halley's method.
halleyStep :: Fractional a => (# a, a, a, a #) -> a
halleyStep (# x, f, f', f'' #) =
x - 2 * f * f' / ( 2 * f' ^ ( 2 :: Int ) - f * f'' )
-- | Take a single step in the M2 modified Halley method.
--
-- Taken from @Some variants of Halley’s method with memory and their applications for solving several chemical problems@
-- by A. Cordero, H. Ramos & J.R. Torregrosa, J Math Chem 58, 751–774 (2020).
--
-- @https://doi.org/10.1007/s10910-020-01108-3@
halleyM2Step :: Fractional a => (# a, (# a, a #) #) -> (# a, (# a, a #) #) -> a
halleyM2Step (# x_nm1, (# f_nm1, f'_nm1 #) #) (# x_n, (# f_n, f'_n #) #) =
num / denom
where
u = f_n * f_nm1 * (f_n - f_nm1)
dx = x_n - x_nm1
g1 = f_nm1 ^ ( 2 :: Int ) * f'_n
g2 = f_n ^ ( 2 :: Int ) * f'_nm1
num = (x_n + x_nm1) * u - dx * ( g1 * x_n + g2 * x_nm1)
denom = 2 * u - dx * ( g1 + g2 )
{-# SPECIALISE
halleyM2
:: Word -> Int -> ( Double -> (# Double, Double #) ) -> Double -> Maybe Double
#-}
{-# INLINEABLE halleyM2 #-}
halleyM2 :: ( RealFloat r, Show r )
=> Word -- ^ maximum number of iterations
-> Int -- ^ desired digits of precision
-> ( r -> (# r, r #) ) -- ^ function and its derivative
-> r -- ^ initial guess
-> Maybe r
halleyM2 maxIters digits f x0 =
let y0 = (# x0, f x0 #)
in go 0 y0 y0
where
!factor = encodeFloat 1 ( 1 - digits )
go i y_nm1 y_n@(# x_n, _ #) =
let x_np1 = halleyM2Step y_nm1 y_n
in if | i >= maxIters
|| abs ( x_np1 - x_n ) < abs ( x_n * factor )
-> Just x_np1
| otherwise
-> go (i+1) y_n (# x_n, f x_np1 #)

0
src/splines/TH/Utils.hs → brush-strokes/src/TH/Utils.hs
View file

44
cabal.project
View file

@ -1,9 +1,12 @@
packages: . packages: brush-strokes
, .
constraints: constraints:
acts -finitary, acts -finitary,
rounded-hw -pure-hs -c99 -avx512 +ghc-prim -x87-long-double brush-strokes +use-fma,
rounded-hw -pure-hs -c99 -avx512 +ghc-prim -x87-long-double,
text -simdutf
-- text +simdutf causes the "digit" package to fail to build with undefined symbol linker errors
-- Fix a severe bug in Waargonaut (no corresponding Hackage release???) -- Fix a severe bug in Waargonaut (no corresponding Hackage release???)
source-repository-package source-repository-package
@ -12,27 +15,23 @@ source-repository-package
tag: 5f838582a8c5aae1a198ecd4958729e53a6b03cf tag: 5f838582a8c5aae1a198ecd4958729e53a6b03cf
allow-newer: allow-newer:
*:base, *:ghc, *:ghc-prim, *:template-haskell, *:base, *:template-haskell, *:ghc-prim,
*:text acts:deepseq,
-------------
-- GHC 9.2 --
-------------
allow-newer:
digit:lens, digit:lens,
eigen:primitive,
eigen:transformers,
gi-cairo-connector:mtl,
hedgehog:resourcet, hedgehog:resourcet,
JuicyPixels:zlib,
natural:lens, natural:lens,
records-sop:deepseq,
waargonaut:bifunctors,
waargonaut:lens, waargonaut:lens,
waargonaut:records-sop, waargonaut:records-sop,
waargonaut:semigroups, waargonaut:text, waargonaut:semigroups,
waargonaut:vector, waargonaut:witherable, waargonaut:text,
waargonaut:vector,
-- records-sop waargonaut:witherable,
source-repository-package
type: git
location: https://github.com/kosmikus/records-sop
tag: abab99b4b870fce55e81dd03d4e41fb50502ca4e
------------- -------------
-- GHC 9.4 -- -- GHC 9.4 --
@ -44,13 +43,6 @@ source-repository-package
location: https://github.com/chessai/eigen location: https://github.com/chessai/eigen
tag: 1790fdf9138970dde0dbabf8b270698145a4a88c tag: 1790fdf9138970dde0dbabf8b270698145a4a88c
-- rounded-hw
source-repository-package
type: git
location: https://github.com/minoki/haskell-floating-point
subdir: rounded-hw
tag: c141bc8435c556e94d51254479a8213698679261
------------- -------------
-- GHC 9.6 -- -- GHC 9.6 --
------------- -------------

64
src/app/MetaBrush/Application.hs
View file

@ -78,7 +78,7 @@ import Math.Bezier.Cubic.Fit
import Math.Bezier.Spline import Math.Bezier.Spline
( Spline(..), Curves(..), Curve(..), NextPoint(..) ) ( Spline(..), Curves(..), Curve(..), NextPoint(..) )
import Math.Bezier.Stroke import Math.Bezier.Stroke
( invalidateCache ) ( RootSolvingAlgorithm(..), invalidateCache )
import Math.Linear import Math.Linear
( ℝ(..) ) ( ℝ(..) )
import MetaBrush.Action import MetaBrush.Action
@ -200,15 +200,16 @@ runApplication application = do
fileBarTabsTVar <- STM.newTVarIO @( Map Unique FileBarTab ) Map.empty fileBarTabsTVar <- STM.newTVarIO @( Map Unique FileBarTab ) Map.empty
showGuidesTVar <- STM.newTVarIO @Bool True showGuidesTVar <- STM.newTVarIO @Bool True
maxHistorySizeTVar <- STM.newTVarIO @Int 1000 maxHistorySizeTVar <- STM.newTVarIO @Int 1000
fitParametersTVar <- STM.newTVarIO @FitParameters fitParametersTVar <- STM.newTVarIO @FitParameters $
( FitParameters FitParameters
{ maxSubdiv = 5 --2 --3 -- 6 { maxSubdiv = 5 --2 --3 -- 6
, nbSegments = 3 --3 --6 -- 12 , nbSegments = 3 --3 --6 -- 12
, dist_tol = 0.1 -- 5e-3 , dist_tol = 0.1 -- 5e-3
, t_tol = 0.1 -- 1e-4 , t_tol = 0.1 -- 1e-4
, maxIters = 5 -- 100 , maxIters = 5 -- 100
} }
) rootsAlgoTVar <- STM.newTVarIO @RootSolvingAlgorithm $
HalleyM2 { maxIters = 20, precision = 8 }
-- Put all these stateful variables in a record for conciseness. -- Put all these stateful variables in a record for conciseness.
let let
@ -321,33 +322,34 @@ runApplication application = do
case needsRecomputation of case needsRecomputation of
False -> STM.retry False -> STM.retry
True -> do True -> do
mbDocNow <- fmap present <$> activeDocument variables mbDocNow <- fmap present <$> activeDocument variables
case mbDocNow of case mbDocNow of
Nothing -> pure ( pure . const $ blankRender colours ) Nothing -> pure ( pure . const $ blankRender colours )
Just doc -> do Just doc -> do
modifiers <- STM.readTVar modifiersTVar modifiers <- STM.readTVar modifiersTVar
mbMousePos <- STM.readTVar mousePosTVar mbMousePos <- STM.readTVar mousePosTVar
mbHoldAction <- STM.readTVar mouseHoldTVar mbHoldAction <- STM.readTVar mouseHoldTVar
mbPartialPath <- STM.readTVar partialPathTVar mbPartialPath <- STM.readTVar partialPathTVar
mode <- STM.readTVar modeTVar mode <- STM.readTVar modeTVar
showGuides <- STM.readTVar showGuidesTVar showGuides <- STM.readTVar showGuidesTVar
debug <- STM.readTVar debugTVar debug <- STM.readTVar debugTVar
fitParameters <- STM.readTVar fitParametersTVar fitParameters <- STM.readTVar fitParametersTVar
STM.writeTVar recomputeStrokesTVar False rootsAlgo <- STM.readTVar rootsAlgoTVar
let STM.writeTVar recomputeStrokesTVar False
addRulers :: ( ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () ) let
addRulers newRender viewportSize = do addRulers :: ( ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () )
newRender viewportSize addRulers newRender viewportSize = do
renderRuler newRender viewportSize
colours viewportSize ViewportOrigin viewportSize renderRuler
mbMousePos mbHoldAction showGuides colours viewportSize ViewportOrigin viewportSize
doc mbMousePos mbHoldAction showGuides
pure doc
( addRulers <$> getDocumentRender pure
colours fitParameters mode debug ( addRulers <$> getDocumentRender
modifiers mbMousePos mbHoldAction mbPartialPath colours rootsAlgo fitParameters mode debug
doc modifiers mbMousePos mbHoldAction mbPartialPath
) doc
)
renderDoc <- stToIO getRenderDoc renderDoc <- stToIO getRenderDoc
STM.atomically do STM.atomically do
STM.writeTVar documentRenderTVar renderDoc STM.writeTVar documentRenderTVar renderDoc

3
src/app/MetaBrush/Context.hs
View file

@ -41,6 +41,8 @@ import Data.HashMap.Strict
-- MetaBrush -- MetaBrush
import Math.Bezier.Cubic.Fit import Math.Bezier.Cubic.Fit
( FitParameters ) ( FitParameters )
import Math.Bezier.Stroke
( RootSolvingAlgorithm )
import Math.Linear import Math.Linear
( ℝ(..) ) ( ℝ(..) )
import {-# SOURCE #-} MetaBrush.Action import {-# SOURCE #-} MetaBrush.Action
@ -99,6 +101,7 @@ data Variables
, showGuidesTVar :: !( STM.TVar Bool ) , showGuidesTVar :: !( STM.TVar Bool )
, maxHistorySizeTVar :: !( STM.TVar Int ) , maxHistorySizeTVar :: !( STM.TVar Int )
, fitParametersTVar :: !( STM.TVar FitParameters ) , fitParametersTVar :: !( STM.TVar FitParameters )
, rootsAlgoTVar :: !( STM.TVar RootSolvingAlgorithm )
} }
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

13
src/app/MetaBrush/Render/Document.hs
View file

@ -74,6 +74,7 @@ import Math.Bezier.Spline
import Math.Bezier.Stroke import Math.Bezier.Stroke
( Cusp(..), CachedStroke(..), invalidateCache ( Cusp(..), CachedStroke(..), invalidateCache
, computeStrokeOutline , computeStrokeOutline
, RootSolvingAlgorithm
) )
import Math.Linear import Math.Linear
( ℝ(..), T(..) ) ( ℝ(..), T(..) )
@ -147,12 +148,12 @@ blankRender :: Colours -> Cairo.Render ()
blankRender _ = pure () blankRender _ = pure ()
getDocumentRender getDocumentRender
:: Colours -> FitParameters -> Mode -> Bool :: Colours -> RootSolvingAlgorithm -> FitParameters -> Mode -> Bool
-> Set Modifier -> Maybe ( ℝ 2 ) -> Maybe HoldAction -> Maybe PartialPath -> Set Modifier -> Maybe ( ℝ 2 ) -> Maybe HoldAction -> Maybe PartialPath
-> Document -> Document
-> ST RealWorld ( ( Int32, Int32 ) -> Cairo.Render () ) -> ST RealWorld ( ( Int32, Int32 ) -> Cairo.Render () )
getDocumentRender getDocumentRender
cols fitParams mode debug cols rootAlgo fitParams mode debug
modifiers mbMousePos mbHoldEvent mbPartialPath modifiers mbMousePos mbHoldEvent mbPartialPath
doc@( Document { viewportCenter = ℝ2 cx cy, zoomFactor, documentContent = content } ) doc@( Document { viewportCenter = ℝ2 cx cy, zoomFactor, documentContent = content } )
= do = do
@ -214,7 +215,7 @@ getDocumentRender
-> previewStroke :<| foldMap visibleStrokes ( strokes content ) -> previewStroke :<| foldMap visibleStrokes ( strokes content )
_ -> foldMap visibleStrokes ( strokes content ) _ -> foldMap visibleStrokes ( strokes content )
strokesRenderData <- traverseMaybe ( sequenceA . strokeRenderData fitParams ) modifiedStrokes strokesRenderData <- traverseMaybe ( sequenceA . strokeRenderData rootAlgo fitParams ) modifiedStrokes
let let
renderSelectionRect :: Cairo.Render () renderSelectionRect :: Cairo.Render ()
@ -275,8 +276,8 @@ instance NFData StrokeRenderData where
-- - the computed outline (using fitting algorithm), -- - the computed outline (using fitting algorithm),
-- - the brush shape function. -- - the brush shape function.
-- - Otherwise, this consists of the underlying spline path only. -- - Otherwise, this consists of the underlying spline path only.
strokeRenderData :: FitParameters -> Stroke -> Maybe ( ST RealWorld StrokeRenderData ) strokeRenderData :: RootSolvingAlgorithm -> FitParameters -> Stroke -> Maybe ( ST RealWorld StrokeRenderData )
strokeRenderData fitParams strokeRenderData rootAlgo fitParams
( Stroke ( Stroke
{ strokeSpline = spline :: StrokeSpline clo ( Record pointFields ) { strokeSpline = spline :: StrokeSpline clo ( Record pointFields )
, strokeBrush = ( strokeBrush :: Maybe ( Brush brushFields ) ) , strokeBrush = ( strokeBrush :: Maybe ( Brush brushFields ) )
@ -301,7 +302,7 @@ strokeRenderData fitParams
-- Compute the outline using the brush function. -- Compute the outline using the brush function.
( outline, fitPts, cusps ) <- ( outline, fitPts, cusps ) <-
computeStrokeOutline @clo fitParams computeStrokeOutline @clo rootAlgo fitParams
( toUsedParams . brushParams ) embedUsedParams brushFn ( toUsedParams . brushParams ) embedUsedParams brushFn
spline spline
pure $ pure $

17
src/app/MetaBrush/UI/InfoBar.hs
View file

@ -179,14 +179,15 @@ updateInfoBar viewportDrawingArea ( InfoBar {..} ) ( Variables { mousePosTVar }
GTK.labelSetText botRightPosText $ Text.pack ( "x: " <> fixed 6 2 r <> "\ny: " <> fixed 6 2 b ) GTK.labelSetText botRightPosText $ Text.pack ( "x: " <> fixed 6 2 r <> "\ny: " <> fixed 6 2 b )
fixed :: Int -> Int -> Double -> String fixed :: Int -> Int -> Double -> String
fixed digitsBefore digitsAfter x = case second tail . break ( == '.' ) $ showFFloat ( Just digitsAfter ) x "" of fixed digitsBefore digitsAfter x =
( as, bs ) -> case second (drop 1) . break ( == '.' ) $ showFFloat ( Just digitsAfter ) x "" of
let ( as, bs ) ->
l, r :: Int let
l = length as l, r :: Int
r = length bs l = length as
in r = length bs
replicate ( digitsBefore - l ) ' ' <> as <> "." <> bs <> replicate ( digitsAfter - r ) '0' in
replicate ( digitsBefore - l ) ' ' <> as <> "." <> bs <> replicate ( digitsAfter - r ) '0'
na :: IsString a => a na :: IsString a => a
na = " n/a" na = " n/a"

2
src/convert/Main.hs
View file

@ -34,7 +34,7 @@ import qualified Linear.V2 as Linear
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
( runReaderT ) ( runReaderT )
-- splines -- brush-strokes
import Math.Bezier.Spline import Math.Bezier.Spline
( Spline, SplineType(..) ) ( Spline, SplineType(..) )
import Math.Bezier.Stroke import Math.Bezier.Stroke

2
src/convert/MetaBrush/MetaFont/Convert.hs
View file

@ -56,7 +56,7 @@ import qualified Text.Parsec.Error as Parsec
import Data.Text import Data.Text
( Text ) ( Text )
-- splines -- brush-strokes
import Math.Bezier.Spline import Math.Bezier.Spline
( Spline(..), SplineType(..), KnownSplineType ( Spline(..), SplineType(..), KnownSplineType
, Curves(..), Curve(..), NextPoint(..) , Curves(..), Curve(..), NextPoint(..)