mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
Farey sum for curve subdivision
This commit is contained in:
sheaf
parent
f7a4b02e90
commit
b5b29f124a
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue