mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 23:03:38 +00:00
find solutions on nearby curves
This commit is contained in:
parent
094801ca67
commit
33a3cbfaa1
|
@ -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
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue