hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-27 09:24:08 +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

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

@ -31,6 +31,7 @@ import Data.Functor
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import Data.Maybe import Data.Maybe
( fromMaybe, isNothing, listToMaybe ) ( fromMaybe, isNothing, listToMaybe )
import Data.Ratio
import Data.Semigroup import Data.Semigroup
( Arg(..), Min(..) ) ( Arg(..), Min(..) )
import Data.Traversable import Data.Traversable
@ -66,11 +67,13 @@ import Control.Monad.Trans.Except
( Except ) ( Except )
import qualified Control.Monad.Trans.Except as Except import qualified Control.Monad.Trans.Except as Except
import Control.Monad.Trans.State.Strict import Control.Monad.Trans.State.Strict
( State ) ( State, StateT )
import qualified Control.Monad.Trans.State.Strict as State import qualified Control.Monad.Trans.State.Strict as State
import Control.Monad.Trans.Writer.CPS import Control.Monad.Trans.Writer.CPS
( Writer ) ( Writer )
import qualified Control.Monad.Trans.Writer.CPS as Writer import qualified Control.Monad.Trans.Writer.CPS as Writer
import Control.Monad.Trans.Class
( lift )
-- brush-strokes -- brush-strokes
import qualified Math.Bezier.Cubic as Cubic import qualified Math.Bezier.Cubic as Cubic
@ -131,11 +134,12 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
subdivideStroke u stroke0@( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do subdivideStroke u stroke0@( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo brushParams } ) ( StrokeMetadata { strokeVisible, strokeLocked } ) = do
mbPrevSubdivision <- State.get mbPrevSubdivision <- State.get
let ( curves', subdivs ) = let ( curves', subdivs ) =
Writer.runWriter $ Writer.runWriter $
bifoldSpline @Open ( `State.evalStateT` Nothing ) $
( subdivideCurve ( V2 0 0 ) ) bifoldSpline @Open
( const $ pure Seq.Empty ) ( subdivideCurve ( V2 0 0 ) )
( adjustSplineType @Open strokeSpline ) ( const $ pure Seq.Empty )
( adjustSplineType @Open strokeSpline )
if | strokeVisible if | strokeVisible
, not strokeLocked , not strokeLocked
, Nothing <- mbPrevSubdivision , Nothing <- mbPrevSubdivision
@ -156,11 +160,17 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
:: T ( ℝ 2 ) :: T ( ℝ 2 )
-> PointData brushParams -> PointData brushParams
-> Curve Open ( CurveData RealWorld ) ( 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 ) ) ) ( 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 case crv of
LineTo ( NextPoint sp1 ) dat -> do LineTo ( NextPoint sp1 ) ( CurveData _ dat ) -> do
let let
p0, p1, s :: ℝ 2 p0, p1, s :: ℝ 2
t :: Double t :: Double
@ -171,16 +181,16 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
sqDist = quadrance @( T ( ℝ 2 ) ) c ( offset • s ) sqDist = quadrance @( T ( ℝ 2 ) ) c ( offset • s )
if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
then do then do
Writer.tell [ ( stripData crv, t ) ] lift $ Writer.tell [ ( stripData crv, t ) ]
let let
subdiv :: PointData brushParams subdiv :: PointData brushParams
subdiv = lerp @( DiffPointData ( T brushParams ) ) t sp0 sp1 subdiv = lerp @( DiffPointData ( T brushParams ) ) t sp0 sp1
return $ return $
LineTo ( NextPoint subdiv ) ( invalidateCache dat ) LineTo ( NextPoint subdiv ) ( CurveData i' $ invalidateCache dat )
Seq.:<| LineTo ( NextPoint sp1 ) ( invalidateCache dat ) Seq.:<| LineTo ( NextPoint sp1 ) ( CurveData i $ invalidateCache dat )
Seq.:<| Seq.Empty Seq.:<| Seq.Empty
else return $ Seq.singleton crv else return $ Seq.singleton crv
Bezier2To sp1 ( NextPoint sp2 ) dat -> do Bezier2To sp1 ( NextPoint sp2 ) ( CurveData _ dat ) -> do
let let
p0, p1, p2 :: ℝ 2 p0, p1, p2 :: ℝ 2
p0 = coords sp0 p0 = coords sp0
@ -193,14 +203,14 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
then then
case Quadratic.subdivide @( DiffPointData ( T brushParams ) ) ( Quadratic.Bezier sp0 sp1 sp2 ) t of case Quadratic.subdivide @( DiffPointData ( T brushParams ) ) ( Quadratic.Bezier sp0 sp1 sp2 ) t of
( Quadratic.Bezier _ q1 subdiv, Quadratic.Bezier _ r1 _ ) -> do ( Quadratic.Bezier _ q1 subdiv, Quadratic.Bezier _ r1 _ ) -> do
Writer.tell [ ( stripData crv, t ) ] lift $ Writer.tell [ ( stripData crv, t ) ]
let let
bez_start, bez_end :: Curve Open ( CurveData RealWorld ) ( PointData brushParams ) bez_start, bez_end :: Curve Open ( CurveData RealWorld ) ( PointData brushParams )
bez_start = Bezier2To q1 ( NextPoint subdiv ) ( invalidateCache dat ) bez_start = Bezier2To q1 ( NextPoint subdiv ) ( CurveData i' $ invalidateCache dat )
bez_end = Bezier2To r1 ( NextPoint sp2 ) ( invalidateCache dat ) bez_end = Bezier2To r1 ( NextPoint sp2 ) ( CurveData i $ invalidateCache dat )
return ( bez_start Seq.:<| bez_end Seq.:<| Seq.Empty ) return ( bez_start Seq.:<| bez_end Seq.:<| Seq.Empty )
else return $ Seq.singleton crv else return $ Seq.singleton crv
Bezier3To sp1 sp2 ( NextPoint sp3 ) dat -> do Bezier3To sp1 sp2 ( NextPoint sp3 ) ( CurveData _ dat ) -> do
let let
p0, p1, p2, p3 :: ℝ 2 p0, p1, p2, p3 :: ℝ 2
p0 = coords sp0 p0 = coords sp0
@ -213,15 +223,21 @@ subdivide c doc@( Document { documentMetadata, documentContent }) =
then do then do
case Cubic.subdivide @( DiffPointData ( T brushParams ) ) ( Cubic.Bezier sp0 sp1 sp2 sp3 ) t of case Cubic.subdivide @( DiffPointData ( T brushParams ) ) ( Cubic.Bezier sp0 sp1 sp2 sp3 ) t of
( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) -> do ( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) -> do
Writer.tell [ ( stripData crv, t ) ] lift $ Writer.tell [ ( stripData crv, t ) ]
let let
bez_start, bez_end :: Curve Open ( CurveData RealWorld ) ( PointData brushParams ) bez_start, bez_end :: Curve Open ( CurveData RealWorld ) ( PointData brushParams )
bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) ( invalidateCache dat ) bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) ( CurveData i' $ invalidateCache dat )
bez_end = Bezier3To r1 r2 ( NextPoint sp3 ) ( invalidateCache dat ) bez_end = Bezier3To r1 r2 ( NextPoint sp3 ) ( CurveData i $ invalidateCache dat )
return ( bez_start Seq.:<| bez_end Seq.:<| Seq.Empty ) return ( bez_start Seq.:<| bez_end Seq.:<| Seq.Empty )
else else
return $ Seq.singleton crv 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. -- Selection.