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

Farey sum for curve subdivision

Browse source
This commit is contained in:
sheaf 2024-09-28 15:45:07 +02:00
parent f7a4b02e90
commit b5b29f124a
1 changed files with 36 additions and 20 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

46
src/metabrushes/MetaBrush/Action.hs
View file

@ -31,6 +31,7 @@ import Data.Functor
import qualified Data.List.NonEmpty as NE
import Data.Maybe
( fromMaybe, isNothing, listToMaybe )
import Data.Ratio
import Data.Semigroup
( Arg(..), Min(..) )
import Data.Traversable
@ -66,11 +67,13 @@ import Control.Monad.Trans.Except
( Except )
import qualified Control.Monad.Trans.Except as Except
import Control.Monad.Trans.State.Strict
( State )
( State, StateT )
import qualified Control.Monad.Trans.State.Strict as State
import Control.Monad.Trans.Writer.CPS
( Writer )
import qualified Control.Monad.Trans.Writer.CPS as Writer
import Control.Monad.Trans.Class
( lift )
-- brush-strokes
import qualified Math.Bezier.Cubic as Cubic
@ -132,6 +135,7 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
mbPrevSubdivision <- State.get
let ( curves', subdivs ) =
Writer.runWriter $
( `State.evalStateT` Nothing ) $
bifoldSpline @Open
( subdivideCurve ( V2 0 0 ) )
( const $ pure Seq.Empty )
@ -156,11 +160,17 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
:: T ( ℝ 2 )
-> PointData brushParams
-> Curve Open ( CurveData RealWorld ) ( PointData brushParams )
-> Writer [ ( Curve Open () (), Double ) ]
-> StateT ( Maybe Rational )
( Writer [ ( Curve Open () (), Double ) ] )
( Seq ( Curve Open ( CurveData RealWorld ) ( PointData brushParams ) ) )
subdivideCurve offset sp0 crv =
subdivideCurve offset sp0 crv = do
mbPrevCrvIx <- State.get
let i = curveIndex ( curveData crv )
i' = case mbPrevCrvIx of { Nothing -> i - 1
; Just i0 -> fareySum i0 i }
State.put ( Just i )
case crv of
LineTo ( NextPoint sp1 ) dat -> do
LineTo ( NextPoint sp1 ) ( CurveData _ dat ) -> do
let
p0, p1, s :: ℝ 2
t :: Double
@ -171,16 +181,16 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
sqDist = quadrance @( T ( ℝ 2 ) ) c ( offset • s )
if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
then do
Writer.tell [ ( stripData crv, t ) ]
lift $ Writer.tell [ ( stripData crv, t ) ]
let
subdiv :: PointData brushParams
subdiv = lerp @( DiffPointData ( T brushParams ) ) t sp0 sp1
return $
LineTo ( NextPoint subdiv ) ( invalidateCache dat )
Seq.:<| LineTo ( NextPoint sp1 ) ( invalidateCache dat )
LineTo ( NextPoint subdiv ) ( CurveData i' $ invalidateCache dat )
Seq.:<| LineTo ( NextPoint sp1 ) ( CurveData i $ invalidateCache dat )
Seq.:<| Seq.Empty
else return $ Seq.singleton crv
Bezier2To sp1 ( NextPoint sp2 ) dat -> do
Bezier2To sp1 ( NextPoint sp2 ) ( CurveData _ dat ) -> do
let
p0, p1, p2 :: ℝ 2
p0 = coords sp0
@ -193,14 +203,14 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
then
case Quadratic.subdivide @( DiffPointData ( T brushParams ) ) ( Quadratic.Bezier sp0 sp1 sp2 ) t of
( Quadratic.Bezier _ q1 subdiv, Quadratic.Bezier _ r1 _ ) -> do
Writer.tell [ ( stripData crv, t ) ]
lift $ Writer.tell [ ( stripData crv, t ) ]
let
bez_start, bez_end :: Curve Open ( CurveData RealWorld ) ( PointData brushParams )
bez_start = Bezier2To q1 ( NextPoint subdiv ) ( invalidateCache dat )
bez_end = Bezier2To r1 ( NextPoint sp2 ) ( invalidateCache dat )
bez_start = Bezier2To q1 ( NextPoint subdiv ) ( CurveData i' $ invalidateCache dat )
bez_end = Bezier2To r1 ( NextPoint sp2 ) ( CurveData i $ invalidateCache dat )
return ( bez_start Seq.:<| bez_end Seq.:<| Seq.Empty )
else return $ Seq.singleton crv
Bezier3To sp1 sp2 ( NextPoint sp3 ) dat -> do
Bezier3To sp1 sp2 ( NextPoint sp3 ) ( CurveData _ dat ) -> do
let
p0, p1, p2, p3 :: ℝ 2
p0 = coords sp0
@ -213,15 +223,21 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
then do
case Cubic.subdivide @( DiffPointData ( T brushParams ) ) ( Cubic.Bezier sp0 sp1 sp2 sp3 ) t of
( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) -> do
Writer.tell [ ( stripData crv, t ) ]
lift $ Writer.tell [ ( stripData crv, t ) ]
let
bez_start, bez_end :: Curve Open ( CurveData RealWorld ) ( PointData brushParams )
bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) ( invalidateCache dat )
bez_end = Bezier3To r1 r2 ( NextPoint sp3 ) ( invalidateCache dat )
bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) ( CurveData i' $ invalidateCache dat )
bez_end = Bezier3To r1 r2 ( NextPoint sp3 ) ( CurveData i $ invalidateCache dat )
return ( bez_start Seq.:<| bez_end Seq.:<| Seq.Empty )
else
return $ Seq.singleton crv
-- | Stroke subdivision is the key reason why we index curves with 'Rational'
-- rather than 'Integer'.
fareySum :: Rational -> Rational -> Rational
fareySum a b = ( numerator a + numerator b )
% ( denominator a + denominator b )
--------------------------------------------------------------------------------
-- Selection.