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

find solutions on nearby curves

Browse source
This commit is contained in:
sheaf 2023-01-11 20:05:56 +01:00
parent 094801ca67
commit 33a3cbfaa1
1 changed files with 15 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

32
src/splines/Math/Bezier/Stroke.hs
View file

@ -29,6 +29,8 @@ import Control.Monad.ST
( RealWorld, ST ) ( RealWorld, ST )
import Data.Bifunctor import Data.Bifunctor
( Bifunctor(bimap) ) ( Bifunctor(bimap) )
import Data.Coerce
( coerce )
import Data.Foldable import Data.Foldable
( for_ ) ( for_ )
import Data.Functor.Identity import Data.Functor.Identity
@ -60,7 +62,7 @@ import qualified Data.Sequence as Seq
import Data.Set import Data.Set
( Set ) ( Set )
import qualified Data.Set as Set import qualified Data.Set as Set
( singleton ) ( insert, member, singleton )
-- deepseq -- deepseq
import Control.DeepSeq import Control.DeepSeq
@ -853,33 +855,29 @@ solveEnvelopeEquations path_t path'_t ( fwdOffset, bwdOffset ) strokeData
-- , " bwdOffset: " ++ show bwdOffset ] -- , " bwdOffset: " ++ show bwdOffset ]
-- ) True -- ) True
fwdSol = findSolFrom False fwdOffset fwdSol = findSolFrom fwdOffset
( bwdPt, bwdTgt ) = findSolFrom True bwdOffset ( bwdPt, bwdTgt ) = findSolFrom bwdOffset
n :: Int n :: Int
n = length strokeData n = length strokeData
findSolFrom :: Bool -> Offset -> ( ℝ 2, T ( ℝ 2 ) ) findSolFrom :: Offset -> ( ℝ 2, T ( ℝ 2 ) )
findSolFrom goingBwds ( Offset { offsetIndex = i00, offsetParameter = s00, offset = off } ) findSolFrom ( Offset { offsetIndex = i00, offsetParameter = s00, offset = off } )
= go ( Set.singleton i00 ) i00 ( fromMaybe 0.5 s00 ) = go ( Set.singleton i00 ) i00 ( fromMaybe 0.5 s00 )
where where
plausibleTangent :: T ( ℝ 2 ) -> Bool plausibleTangent :: T ( ℝ 2 ) -> Bool
plausibleTangent tgt plausibleTangent tgt = path'_t ^.^ tgt > 0
| goingBwds
= path'_t ^.^ tgt < 0
| otherwise
= path'_t ^.^ tgt > 0
go :: Set Int -> Int -> Double -> ( ℝ 2, T ( ℝ 2 ) ) go :: Set Int -> Int -> Double -> ( ℝ 2, T ( ℝ 2 ) )
go seen i0 s0 = go seen i0 s0 =
case sol s0 ( strokeData `Seq.index` i0 ) of case sol s0 ( strokeData `Seq.index` i0 ) of
( good, s, pt, tgt ) ( goodSoln, s, pt, tgt )
| True --good && plausibleTangent tgt | goodSoln && plausibleTangent tgt
-> ( pt, tgt ) -> ( pt, tgt )
-- | let ( i', s0' ) = mbNextPoint i0 ( unℝ1 s ) | let ( i', s0' ) = mbNextPoint i0 ( unℝ1 s )
-- , not ( i' `Set.member` seen ) , not ( i' `Set.member` seen )
-- -> go ( Set.insert i' seen ) i' s0' -> go ( Set.insert i' seen ) i' s0'
| otherwise | otherwise
-> ( off • path_t, path'_t ) -> ( off • path_t, path'_t )
@ -928,7 +926,7 @@ solveEnvelopeEquations path_t path'_t ( fwdOffset, bwdOffset ) strokeData
newtype ZipSeq a = ZipSeq { getZipSeq :: Seq a } newtype ZipSeq a = ZipSeq { getZipSeq :: Seq a }
deriving stock Functor deriving stock Functor
instance Applicative ZipSeq where instance Applicative ZipSeq where
pure _ = error "no pure for ZipSeq" pure _ = error "only use Applicative ZipSeq with non-empty Traversable functors"
liftA2 f ( ZipSeq xs ) ( ZipSeq ys ) = ZipSeq ( Seq.zipWith f xs ys ) liftA2 f ( ZipSeq xs ) ( ZipSeq ys ) = ZipSeq ( Seq.zipWith f xs ys )
brushStrokeData :: forall brushParams brushStrokeData :: forall brushParams
@ -947,7 +945,7 @@ brushStrokeData path params brush =
dbrush_params :: D brushParams ( SplinePts Closed ) dbrush_params :: D brushParams ( SplinePts Closed )
!dbrush_params = runD brush params_t !dbrush_params = runD brush params_t
splines :: Seq ( D brushParams ( ℝ 1 ~> ℝ 2 ) ) splines :: Seq ( D brushParams ( ℝ 1 ~> ℝ 2 ) )
!splines = getZipSeq $ traverse @_ @ZipSeq ( ZipSeq . splineCurveFns ) dbrush_params !splines = getZipSeq $ traverse ( ZipSeq . splineCurveFns ) dbrush_params
dbrushes_t :: Seq ( ℝ 1 -> D ( ℝ 2 ) ( ℝ 2 ) ) dbrushes_t :: Seq ( ℝ 1 -> D ( ℝ 2 ) ( ℝ 2 ) )
!dbrushes_t = force $ fmap ( uncurryD' . ( dparams_t `chain` ) ) splines !dbrushes_t = force $ fmap ( uncurryD' . ( dparams_t `chain` ) ) splines