mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
use R2 instead of Point2D & Vector2D
This commit is contained in:
parent
22820b328d
commit
671dae5474
|
@ -170,7 +170,6 @@ library splines
|
|||
exposed-modules:
|
||||
Math.Bezier.Cubic
|
||||
, Math.Bezier.Cubic.Fit
|
||||
, Math.Bezier.Envelope
|
||||
, Math.Bezier.Quadratic
|
||||
, Math.Bezier.Spline
|
||||
, Math.Bezier.Stroke
|
||||
|
|
|
@ -90,7 +90,7 @@ import Math.Bezier.Stroke
|
|||
import Math.Module
|
||||
( Module((*^)), quadrance )
|
||||
import Math.Linear
|
||||
( Point2D(..), Vector2D(..) )
|
||||
( ℝ(..), T(..) )
|
||||
import MetaBrush.Context
|
||||
( UIElements(..), Variables(..)
|
||||
, Modifier(..), modifierKey
|
||||
|
@ -658,24 +658,24 @@ instance HandleAction About where
|
|||
-- Mouse movement --
|
||||
--------------------
|
||||
|
||||
data MouseMove = MouseMove !( Point2D Double )
|
||||
data MouseMove = MouseMove !( ℝ 2 )
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction MouseMove where
|
||||
handleAction
|
||||
( UIElements { viewport = Viewport {..}, .. } )
|
||||
vars@( Variables {..} )
|
||||
( MouseMove ( Point2D x y ) )
|
||||
( MouseMove ( ℝ2 x y ) )
|
||||
= do
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
uiUpdateAction <- STM.atomically $ withActiveDocument vars \ doc@( Document {..} ) -> do
|
||||
modifiers <- STM.readTVar modifiersTVar
|
||||
let
|
||||
toViewport :: Point2D Double -> Point2D Double
|
||||
toViewport :: ℝ 2 -> ℝ 2
|
||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||
pos :: Point2D Double
|
||||
pos = toViewport ( Point2D x y )
|
||||
pos :: ℝ 2
|
||||
pos = toViewport ( ℝ2 x y )
|
||||
STM.writeTVar mousePosTVar ( Just pos )
|
||||
----------------------------------------------------------
|
||||
-- With the pen tool, keeping control pressed while moving the mouse
|
||||
|
@ -714,7 +714,7 @@ data MouseClick =
|
|||
{ clickOrigin :: !ActionOrigin
|
||||
, clickType :: !MouseClickType
|
||||
, clickButton :: !Word32
|
||||
, clickCoords :: !( Point2D Double )
|
||||
, clickCoords :: !( ℝ 2 )
|
||||
}
|
||||
deriving stock Show
|
||||
|
||||
|
@ -731,9 +731,9 @@ instance HandleAction MouseClick where
|
|||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
|
||||
let
|
||||
toViewport :: Point2D Double -> Point2D Double
|
||||
toViewport :: ℝ 2 -> ℝ 2
|
||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||
pos :: Point2D Double
|
||||
pos :: ℝ 2
|
||||
pos = toViewport mouseClickCoords
|
||||
STM.writeTVar mousePosTVar ( Just pos )
|
||||
mode <- STM.readTVar modeTVar
|
||||
|
@ -853,14 +853,14 @@ instance HandleAction MouseClick where
|
|||
-- Mouse release --
|
||||
-------------------
|
||||
|
||||
data MouseRelease = MouseRelease !Word32 !( Point2D Double )
|
||||
data MouseRelease = MouseRelease !Word32 !( ℝ 2 )
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction MouseRelease where
|
||||
handleAction
|
||||
uiElts@( UIElements { viewport = Viewport {..} } )
|
||||
vars@( Variables {..} )
|
||||
( MouseRelease button ( Point2D x y ) )
|
||||
( MouseRelease button ( ℝ2 x y ) )
|
||||
= case button of
|
||||
|
||||
-- Left mouse button.
|
||||
|
@ -869,16 +869,16 @@ instance HandleAction MouseRelease where
|
|||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
|
||||
let
|
||||
toViewport :: Point2D Double -> Point2D Double
|
||||
toViewport :: ℝ 2 -> ℝ 2
|
||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||
pos :: Point2D Double
|
||||
pos = toViewport ( Point2D x y )
|
||||
pos :: ℝ 2
|
||||
pos = toViewport ( ℝ2 x y )
|
||||
STM.writeTVar mousePosTVar ( Just pos )
|
||||
modifiers <- STM.readTVar modifiersTVar
|
||||
mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
|
||||
|
||||
case mbHoldPos of
|
||||
Just ( GuideAction { holdStartPos = holdStartPos@( Point2D hx hy ), guideAction } ) -> do
|
||||
Just ( GuideAction { holdStartPos = holdStartPos@( ℝ2 hx hy ), guideAction } ) -> do
|
||||
case guideAction of
|
||||
CreateGuide ruler
|
||||
| createGuide
|
||||
|
@ -905,7 +905,7 @@ instance HandleAction MouseRelease where
|
|||
newDocument =
|
||||
over
|
||||
( field' @"documentContent" . field' @"guides" . ix guideUnique . field' @"guidePoint" )
|
||||
( ( holdStartPos --> pos :: Vector2D Double ) • )
|
||||
( ( holdStartPos --> pos :: T ( ℝ 2 ) ) • )
|
||||
doc
|
||||
changeText :: Text
|
||||
changeText = "Move guide"
|
||||
|
@ -922,7 +922,7 @@ instance HandleAction MouseRelease where
|
|||
in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||
where
|
||||
l, t :: Double
|
||||
Point2D l t = toViewport ( Point2D 0 0 )
|
||||
ℝ2 l t = toViewport ( ℝ2 0 0 )
|
||||
keepGuide :: Bool
|
||||
keepGuide
|
||||
= ( x >= 0 || hx < l ) -- mouse hold position (hx,hy) is in document coordinates,
|
||||
|
@ -943,7 +943,7 @@ instance HandleAction MouseRelease where
|
|||
Just hold
|
||||
| PathMode <- mode
|
||||
, DragMoveHold { holdStartPos = pos0, dragAction } <- hold
|
||||
, quadrance @( Vector2D Double ) pos0 pos * zoomFactor ^ ( 2 :: Int ) >= 16
|
||||
, quadrance @( T ( ℝ 2 ) ) pos0 pos * zoomFactor ^ ( 2 :: Int ) >= 16
|
||||
-> let
|
||||
alternateMode :: Bool
|
||||
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
|
||||
|
@ -951,7 +951,7 @@ instance HandleAction MouseRelease where
|
|||
Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd )
|
||||
Nothing -> pure Don'tModifyDoc
|
||||
| SelectionHold pos0 <- hold
|
||||
, quadrance @( Vector2D Double ) pos0 pos * zoomFactor ^ ( 2 :: Int ) >= 16
|
||||
, quadrance @( T ( ℝ 2 ) ) pos0 pos * zoomFactor ^ ( 2 :: Int ) >= 16
|
||||
-> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle selMode pos0 pos doc )
|
||||
_ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc )
|
||||
|
||||
|
@ -977,12 +977,12 @@ instance HandleAction MouseRelease where
|
|||
}
|
||||
) -> do
|
||||
let
|
||||
pathPoint :: Point2D Double
|
||||
mbControlPoint :: Maybe ( Point2D Double )
|
||||
partialControlPoint :: Maybe ( Point2D Double )
|
||||
pathPoint :: ℝ 2
|
||||
mbControlPoint :: Maybe ( ℝ 2 )
|
||||
partialControlPoint :: Maybe ( ℝ 2 )
|
||||
( pathPoint, mbControlPoint, partialControlPoint )
|
||||
| Just ( DrawHold holdPos ) <- mbHoldPos
|
||||
= ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos )
|
||||
= ( holdPos, Just $ ( pos --> holdPos :: T ( ℝ 2 ) ) • holdPos, Just pos )
|
||||
| otherwise
|
||||
= ( pos, Nothing, Nothing )
|
||||
( _, otherAnchor, otherAnchorPt, _ ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
|
||||
|
@ -1049,14 +1049,14 @@ instance HandleAction MouseRelease where
|
|||
-- Scrolling --
|
||||
---------------
|
||||
|
||||
data Scroll = Scroll !( Maybe ( Point2D Double ) ) !( Vector2D Double )
|
||||
data Scroll = Scroll !( Maybe ( ℝ 2 ) ) !( T ( ℝ 2 ) )
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction Scroll where
|
||||
handleAction
|
||||
uiElts
|
||||
vars@( Variables {..} )
|
||||
( Scroll mbMousePos ( Vector2D dx dy ) ) = do
|
||||
( Scroll mbMousePos ( V2 dx dy ) ) = do
|
||||
|
||||
--viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
--viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
|
@ -1065,9 +1065,9 @@ instance HandleAction Scroll where
|
|||
modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
|
||||
modifiers <- STM.readTVar modifiersTVar
|
||||
let
|
||||
mousePos :: Point2D Double
|
||||
mousePos :: ℝ 2
|
||||
mousePos = fromMaybe oldCenter mbMousePos
|
||||
finalMousePos :: Point2D Double
|
||||
finalMousePos :: ℝ 2
|
||||
newDoc :: Document
|
||||
( newDoc, finalMousePos )
|
||||
-- Zooming using 'Control'.
|
||||
|
@ -1079,23 +1079,23 @@ instance HandleAction Scroll where
|
|||
= max 0.0078125 ( oldZoomFactor / sqrt 2 )
|
||||
| otherwise
|
||||
= min 256 ( oldZoomFactor * sqrt 2 )
|
||||
newCenter :: Point2D Double
|
||||
newCenter :: ℝ 2
|
||||
newCenter
|
||||
= ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double )
|
||||
= ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: T ( ℝ 2 ) )
|
||||
• oldCenter
|
||||
in ( doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }, mousePos )
|
||||
-- Vertical scrolling turned into horizontal scrolling using 'Shift'.
|
||||
| dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers
|
||||
= let
|
||||
newCenter :: Point2D Double
|
||||
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter
|
||||
in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: Vector2D Double ) • mousePos )
|
||||
newCenter :: ℝ 2
|
||||
newCenter = ( ( 25 / oldZoomFactor ) *^ V2 dy 0 ) • oldCenter
|
||||
in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: T ( ℝ 2 ) ) • mousePos )
|
||||
-- Vertical scrolling.
|
||||
| otherwise
|
||||
= let
|
||||
newCenter :: Point2D Double
|
||||
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter
|
||||
in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: Vector2D Double ) • mousePos )
|
||||
newCenter :: ℝ 2
|
||||
newCenter = ( ( 25 / oldZoomFactor ) *^ V2 dx dy ) • oldCenter
|
||||
in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: T ( ℝ 2 ) ) • mousePos )
|
||||
for_ mbMousePos \ _ ->
|
||||
STM.writeTVar mousePosTVar ( Just finalMousePos )
|
||||
pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
|
||||
|
|
|
@ -17,7 +17,7 @@ import Data.Text
|
|||
|
||||
-- MetaBrush
|
||||
import Math.Linear
|
||||
( Point2D, Vector2D )
|
||||
( ℝ(..), T(..) )
|
||||
import {-# SOURCE #-} MetaBrush.Context
|
||||
( UIElements, Variables )
|
||||
import {-# SOURCE #-} MetaBrush.UI.FileBar
|
||||
|
@ -105,7 +105,7 @@ instance HandleAction Confirm
|
|||
data About = About
|
||||
instance HandleAction About
|
||||
|
||||
data MouseMove = MouseMove !( Point2D Double )
|
||||
data MouseMove = MouseMove !( ℝ 2 )
|
||||
instance HandleAction MouseMove
|
||||
|
||||
data ActionOrigin
|
||||
|
@ -119,14 +119,14 @@ data MouseClick =
|
|||
{ clickOrigin :: !ActionOrigin
|
||||
, clickType :: !MouseClickType
|
||||
, clickButton :: !Word32
|
||||
, clickCoords :: !( Point2D Double )
|
||||
, clickCoords :: !( ℝ 2 )
|
||||
}
|
||||
instance HandleAction MouseClick
|
||||
|
||||
data MouseRelease = MouseRelease !Word32 !( Point2D Double )
|
||||
data MouseRelease = MouseRelease !Word32 !( ℝ 2 )
|
||||
instance HandleAction MouseRelease
|
||||
|
||||
data Scroll = Scroll !( Maybe ( Point2D Double ) ) !( Vector2D Double )
|
||||
data Scroll = Scroll !( Maybe ( ℝ 2 ) ) !( T ( ℝ 2 ) )
|
||||
instance HandleAction Scroll
|
||||
|
||||
data KeyboardPress = KeyboardPress !Word32
|
||||
|
|
|
@ -80,7 +80,7 @@ import Math.Bezier.Spline
|
|||
import Math.Bezier.Stroke
|
||||
( invalidateCache )
|
||||
import Math.Linear
|
||||
( Point2D(..), ℝ(..) )
|
||||
( ℝ(..) )
|
||||
import MetaBrush.Action
|
||||
( ActionOrigin(..) )
|
||||
import qualified MetaBrush.Asset.Brushes as Asset.Brushes
|
||||
|
@ -162,11 +162,11 @@ runApplication application = do
|
|||
, strokeBrush = Just Asset.Brushes.ellipse
|
||||
, strokeSpline =
|
||||
Spline
|
||||
{ splineStart = mkPoint ( Point2D 10 -20 ) 2 1 0
|
||||
{ splineStart = mkPoint ( ℝ2 10 -20 ) 2 1 0
|
||||
, splineCurves = OpenCurves $ Seq.fromList
|
||||
[ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 10 5 ( pi / 4 ) ), curveData = invalidateCache undefined }
|
||||
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 8 5 ( pi / 4 ) ), curveData = invalidateCache undefined }
|
||||
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 10 7 ( pi / 2 ) ), curveData = invalidateCache undefined }
|
||||
[ LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 10 10 ) 10 5 ( pi / 4 ) ), curveData = invalidateCache undefined }
|
||||
, LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 -10 10 ) 8 5 ( pi / 4 ) ), curveData = invalidateCache undefined }
|
||||
, LineTo { curveEnd = NextPoint ( mkPoint ( ℝ2 -10 -20 ) 10 7 ( pi / 2 ) ), curveData = invalidateCache undefined }
|
||||
]
|
||||
}
|
||||
}
|
||||
|
@ -174,14 +174,14 @@ runApplication application = do
|
|||
)
|
||||
]
|
||||
where
|
||||
mkPoint :: Point2D Double -> Double -> Double -> Double -> PointData ( Record Asset.Brushes.EllipseBrushFields )
|
||||
mkPoint :: ℝ 2 -> Double -> Double -> Double -> PointData ( Record Asset.Brushes.EllipseBrushFields )
|
||||
mkPoint pt a b phi = PointData pt Normal ( MkR $ ℝ3 a b phi )
|
||||
|
||||
recomputeStrokesTVar <- STM.newTVarIO @Bool False
|
||||
documentRenderTVar <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () )
|
||||
activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing
|
||||
openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments
|
||||
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
|
||||
mousePosTVar <- STM.newTVarIO @( Maybe ( ℝ 2 ) ) Nothing
|
||||
mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing
|
||||
modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty
|
||||
toolTVar <- STM.newTVarIO @Tool Selection
|
||||
|
|
|
@ -42,7 +42,7 @@ import Data.HashMap.Strict
|
|||
import Math.Bezier.Cubic.Fit
|
||||
( FitParameters )
|
||||
import Math.Linear
|
||||
( Point2D )
|
||||
( ℝ(..) )
|
||||
import {-# SOURCE #-} MetaBrush.Action
|
||||
( ActionName )
|
||||
import MetaBrush.Asset.Colours
|
||||
|
@ -88,7 +88,7 @@ data Variables
|
|||
, documentRenderTVar :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) )
|
||||
, activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) )
|
||||
, openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) )
|
||||
, mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) )
|
||||
, mousePosTVar :: !( STM.TVar ( Maybe ( ℝ 2 ) ) )
|
||||
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
|
||||
, modifiersTVar :: !( STM.TVar ( Set Modifier ) )
|
||||
, toolTVar :: !( STM.TVar Tool )
|
||||
|
@ -134,21 +134,21 @@ data GuideAction
|
|||
-- - draw a control point,
|
||||
-- - create/modify a guide.
|
||||
data HoldAction
|
||||
= SelectionHold { holdStartPos :: !( Point2D Double ) }
|
||||
| DragMoveHold { holdStartPos :: !( Point2D Double )
|
||||
= SelectionHold { holdStartPos :: !( ℝ 2 ) }
|
||||
| DragMoveHold { holdStartPos :: !( ℝ 2 )
|
||||
, dragAction :: !DragMoveSelect
|
||||
}
|
||||
| DrawHold { holdStartPos :: !( Point2D Double ) }
|
||||
| GuideAction { holdStartPos :: !( Point2D Double )
|
||||
, guideAction :: !GuideAction
|
||||
| DrawHold { holdStartPos :: !( ℝ 2 ) }
|
||||
| GuideAction { holdStartPos :: !( ℝ 2 )
|
||||
, guideAction :: !GuideAction
|
||||
}
|
||||
deriving stock Show
|
||||
|
||||
-- | Keep track of a path that is in the middle of being drawn.
|
||||
data PartialPath
|
||||
= PartialPath
|
||||
{ partialStartPos :: !( Point2D Double )
|
||||
, partialControlPoint :: !( Maybe ( Point2D Double ) )
|
||||
{ partialStartPos :: !( ℝ 2 )
|
||||
, partialControlPoint :: !( Maybe ( ℝ 2 ) )
|
||||
, partialPathAnchor :: !DrawAnchor
|
||||
, firstPoint :: !Bool
|
||||
}
|
||||
|
|
|
@ -96,7 +96,7 @@ import Math.Bezier.Stroke
|
|||
import Math.Module
|
||||
( Module, lerp, squaredNorm, closestPointOnSegment )
|
||||
import Math.Linear
|
||||
( Point2D(..), Vector2D(..), Segment(..), T(..) )
|
||||
( Segment(..), ℝ(..), T(..) )
|
||||
import {-# SOURCE #-} MetaBrush.Context
|
||||
( Modifier(..) )
|
||||
import MetaBrush.Document
|
||||
|
@ -138,7 +138,7 @@ selectionMode = foldMap \case
|
|||
_ -> New
|
||||
|
||||
-- | Updates the selected objects on a single click selection event.
|
||||
selectAt :: SelectionMode -> Point2D Double -> Document -> Document
|
||||
selectAt :: SelectionMode -> ℝ 2 -> Document -> Document
|
||||
selectAt selMode c doc@( Document { zoomFactor } ) =
|
||||
( `evalState` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc
|
||||
where
|
||||
|
@ -175,7 +175,7 @@ selectAt selMode c doc@( Document { zoomFactor } ) =
|
|||
selected :: Bool
|
||||
selected
|
||||
| not isVisible = False
|
||||
| otherwise = squaredNorm ( c --> coords pt :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16
|
||||
| otherwise = squaredNorm ( c --> coords pt :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
|
||||
|
||||
-- | Type of a drag move selection:
|
||||
--
|
||||
|
@ -205,7 +205,7 @@ instance Semigroup DragMoveSelect where
|
|||
|
||||
-- | Checks whether a mouse click can initiate a drag move event,
|
||||
-- and if so returns an updated document with the selection modified from the start of the drag move.
|
||||
dragMoveSelect :: Point2D Double -> Document -> Maybe ( DragMoveSelect, Document )
|
||||
dragMoveSelect :: ℝ 2 -> Document -> Maybe ( DragMoveSelect, Document )
|
||||
dragMoveSelect c doc@( Document { zoomFactor } ) =
|
||||
let
|
||||
res :: WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) Document
|
||||
|
@ -256,9 +256,9 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
|
|||
mbCurveDrag = do
|
||||
let
|
||||
t :: Double
|
||||
p :: Point2D Double
|
||||
p :: ℝ 2
|
||||
( t, p )
|
||||
= closestPointOnSegment @( Vector2D Double ) c ( Segment ( coords sp0 ) ( coords $ fromNextPoint start sp1 ) )
|
||||
= closestPointOnSegment @( T ( ℝ 2 ) ) c ( Segment ( coords sp0 ) ( coords $ fromNextPoint start sp1 ) )
|
||||
guard ( inSelectionRange isVisible p )
|
||||
pure $
|
||||
ClickedOnCurve
|
||||
|
@ -274,12 +274,12 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
|
|||
mbCurveDrag :: Maybe DragMoveSelect
|
||||
mbCurveDrag = do
|
||||
let
|
||||
bez :: Quadratic.Bezier ( Point2D Double )
|
||||
bez :: Quadratic.Bezier ( ℝ 2 )
|
||||
bez = Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords $ fromNextPoint start sp2 )
|
||||
sq_d :: Double
|
||||
t :: Double
|
||||
Min ( Arg sq_d (t, _) )
|
||||
= Quadratic.closestPoint @( Vector2D Double ) bez c
|
||||
= Quadratic.closestPoint @( T ( ℝ 2 ) ) bez c
|
||||
guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 )
|
||||
pure $
|
||||
ClickedOnCurve
|
||||
|
@ -296,12 +296,12 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
|
|||
mbCurveDrag :: Maybe DragMoveSelect
|
||||
mbCurveDrag = do
|
||||
let
|
||||
bez :: Cubic.Bezier ( Point2D Double )
|
||||
bez :: Cubic.Bezier ( ℝ 2 )
|
||||
bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords $ fromNextPoint start sp3 )
|
||||
sq_d :: Double
|
||||
t :: Double
|
||||
Min ( Arg sq_d (t, _) )
|
||||
= Cubic.closestPoint @( Vector2D Double ) bez c
|
||||
= Cubic.closestPoint @( T ( ℝ 2 ) ) bez c
|
||||
guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 )
|
||||
pure $
|
||||
ClickedOnCurve
|
||||
|
@ -315,10 +315,10 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
|
|||
sp3' <- traverse ( updateSplinePoint isVisible ) sp3
|
||||
pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3' } )
|
||||
|
||||
inSelectionRange :: Bool -> Point2D Double -> Bool
|
||||
inSelectionRange :: Bool -> ℝ 2 -> Bool
|
||||
inSelectionRange isVisible p
|
||||
| not isVisible = False
|
||||
| otherwise = squaredNorm ( c --> p :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16
|
||||
| otherwise = squaredNorm ( c --> p :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
|
||||
|
||||
updateSplinePoint
|
||||
:: Bool -> PointData brushParams
|
||||
|
@ -365,8 +365,8 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
|
|||
pure ( set _selection newPointState pt )
|
||||
|
||||
-- | Updates the selected objects on a rectangular selection event.
|
||||
selectRectangle :: SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document
|
||||
selectRectangle selMode ( Point2D x0 y0 ) ( Point2D x1 y1 )
|
||||
selectRectangle :: SelectionMode -> ℝ 2 -> ℝ 2 -> Document -> Document
|
||||
selectRectangle selMode ( ℝ2 x0 y0 ) ( ℝ2 x1 y1 )
|
||||
= over ( field' @"documentContent" . field' @"strokes" . mapped )
|
||||
updateStrokeHierarchy
|
||||
where
|
||||
|
@ -397,7 +397,7 @@ selectRectangle selMode ( Point2D x0 y0 ) ( Point2D x1 y1 )
|
|||
_ -> pt
|
||||
where
|
||||
x, y :: Double
|
||||
Point2D x y = coords pt
|
||||
ℝ2 x y = coords pt
|
||||
selected :: Bool
|
||||
selected
|
||||
| not isVisible = False
|
||||
|
@ -416,7 +416,7 @@ data UpdateInfo
|
|||
-- | Translate all selected points by the given vector.
|
||||
--
|
||||
-- Returns the updated document, together with info about how many points were translated.
|
||||
translateSelection :: Vector2D Double -> Document -> ( Document, UpdateInfo )
|
||||
translateSelection :: T ( ℝ 2 ) -> Document -> ( Document, UpdateInfo )
|
||||
translateSelection t doc =
|
||||
( `runState` mempty ) . ( `evalStateT` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc
|
||||
where
|
||||
|
@ -683,7 +683,7 @@ deleteSelected doc =
|
|||
|
||||
|
||||
-- | Perform a drag move action on a document.
|
||||
dragUpdate :: Point2D Double -> Point2D Double -> DragMoveSelect -> Bool -> Document -> Maybe DocChange
|
||||
dragUpdate :: ℝ 2 -> ℝ 2 -> DragMoveSelect -> Bool -> Document -> Maybe DocChange
|
||||
dragUpdate p0 p PointDrag _ doc = do
|
||||
let
|
||||
( newDocument, updateInfo ) = translateSelection ( p0 --> p ) doc
|
||||
|
@ -799,9 +799,9 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen
|
|||
-> Curve Open ( CachedStroke RealWorld ) ( PointData pointParams )
|
||||
quadraticDragCurve dat ( Quadratic.Bezier { Quadratic.p1 = sp1, Quadratic.p2 = sp2 } ) =
|
||||
let
|
||||
cp :: Point2D Double
|
||||
cp :: ℝ 2
|
||||
Quadratic.Bezier { Quadratic.p1 = cp } =
|
||||
Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp2 ) dragSegmentParameter p
|
||||
Quadratic.interpolate @( T ( ℝ 2 ) ) ( coords sp0 ) ( coords sp2 ) dragSegmentParameter p
|
||||
in Bezier2To ( set _coords cp sp1 ) ( NextPoint sp2 ) ( invalidateCache dat )
|
||||
cubicDragCurve
|
||||
:: CachedStroke RealWorld
|
||||
|
@ -809,9 +809,9 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen
|
|||
-> Curve Open ( CachedStroke RealWorld ) ( PointData pointParams )
|
||||
cubicDragCurve dat ( Cubic.Bezier { Cubic.p1 = sp1, Cubic.p2 = sp2, Cubic.p3 = sp3 } ) =
|
||||
let
|
||||
cp1, cp2 :: Point2D Double
|
||||
cp1, cp2 :: ℝ 2
|
||||
Cubic.Bezier { Cubic.p1 = cp1, Cubic.p2 = cp2 } =
|
||||
Cubic.drag @( Vector2D Double )
|
||||
Cubic.drag @( T ( ℝ 2 ) )
|
||||
( Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 ) )
|
||||
dragSegmentParameter
|
||||
p
|
||||
|
|
|
@ -27,7 +27,7 @@ import qualified Control.Concurrent.STM.TVar as STM
|
|||
|
||||
-- MetaBrush
|
||||
import Math.Linear
|
||||
( Point2D(..), Vector2D(..) )
|
||||
( ℝ(..), T(..) )
|
||||
import MetaBrush.Action
|
||||
( HandleAction(..)
|
||||
, ActionOrigin(..)
|
||||
|
@ -77,13 +77,13 @@ handleEvents elts@( UIElements { viewport = Viewport {..}, .. } ) vars = do
|
|||
|
||||
handleMotionEvent :: UIElements -> Variables -> ActionOrigin -> ( Double -> Double -> IO () )
|
||||
handleMotionEvent elts vars eventOrigin x y = do
|
||||
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
|
||||
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( ℝ2 x y )
|
||||
handleAction elts vars ( MouseMove mousePos )
|
||||
|
||||
handleScrollEvent :: UIElements -> Variables -> ( Double -> Double -> IO Bool )
|
||||
handleScrollEvent elts vars dx dy = do
|
||||
mbMousePos <- STM.readTVarIO ( mousePosTVar vars )
|
||||
handleAction elts vars ( Scroll mbMousePos ( Vector2D dx dy ) )
|
||||
handleAction elts vars ( Scroll mbMousePos ( V2 dx dy ) )
|
||||
pure False
|
||||
|
||||
handleMouseButtonEvent
|
||||
|
@ -103,7 +103,7 @@ handleMouseButtonEvent elts@( UIElements{ viewport = Viewport {..} } ) vars even
|
|||
_ <- GTK.widgetGrabFocus viewportDrawingArea
|
||||
button <- max 1 <$> GTK.gestureSingleGetCurrentButton gestureClick
|
||||
-- ^^^^^ use button number 1 if no button number is reported (button == 0)
|
||||
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
|
||||
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( ℝ2 x y )
|
||||
handleAction elts vars ( MouseClick eventOrigin click button mousePos )
|
||||
|
||||
handleMouseButtonRelease
|
||||
|
@ -112,23 +112,23 @@ handleMouseButtonRelease
|
|||
handleMouseButtonRelease elts vars eventOrigin gestureClick _ x y = do
|
||||
button <- max 1 <$> GTK.gestureSingleGetCurrentButton gestureClick
|
||||
-- ^^^^^ same as above
|
||||
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
|
||||
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( ℝ2 x y )
|
||||
handleAction elts vars ( MouseRelease button mousePos )
|
||||
|
||||
adjustMousePosition :: Viewport -> ActionOrigin -> Point2D Double -> IO ( Point2D Double )
|
||||
adjustMousePosition :: Viewport -> ActionOrigin -> ℝ 2 -> IO ( ℝ 2 )
|
||||
adjustMousePosition _ ViewportOrigin pt = pure pt
|
||||
adjustMousePosition ( Viewport {..} ) ( RulerOrigin ruler ) ( Point2D x y ) =
|
||||
adjustMousePosition ( Viewport {..} ) ( RulerOrigin ruler ) ( ℝ2 x y ) =
|
||||
case ruler of
|
||||
RulerCorner -> do
|
||||
dx <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth rulerCornerDrawingArea
|
||||
dy <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight rulerCornerDrawingArea
|
||||
pure ( Point2D ( x - dx ) ( y - dy ) )
|
||||
pure ( ℝ2 ( x - dx ) ( y - dy ) )
|
||||
LeftRuler -> do
|
||||
dx <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth leftRulerDrawingArea
|
||||
pure ( Point2D ( x - dx ) y )
|
||||
pure ( ℝ2 ( x - dx ) y )
|
||||
TopRuler -> do
|
||||
dy <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight topRulerDrawingArea
|
||||
pure ( Point2D x ( y - dy ) )
|
||||
pure ( ℝ2 x ( y - dy ) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Keyboard events.
|
||||
|
|
|
@ -72,7 +72,9 @@ import Math.Bezier.Stroke
|
|||
, computeStrokeOutline
|
||||
)
|
||||
import Math.Linear
|
||||
( Point2D(..), Vector2D(..), T(..) )
|
||||
( ℝ(..), T(..) )
|
||||
import Math.Linear.Dual
|
||||
( fun )
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours, ColourRecord(..) )
|
||||
import MetaBrush.Brush
|
||||
|
@ -142,13 +144,13 @@ blankRender _ = pure ()
|
|||
|
||||
getDocumentRender
|
||||
:: Colours -> FitParameters -> Mode -> Bool
|
||||
-> Set Modifier -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath
|
||||
-> Set Modifier -> Maybe ( ℝ 2 ) -> Maybe HoldAction -> Maybe PartialPath
|
||||
-> Document
|
||||
-> ST RealWorld ( ( Int32, Int32 ) -> Cairo.Render () )
|
||||
getDocumentRender
|
||||
cols fitParams mode debug
|
||||
modifiers mbMousePos mbHoldEvent mbPartialPath
|
||||
doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content } )
|
||||
doc@( Document { viewportCenter = ℝ2 cx cy, zoomFactor, documentContent = content } )
|
||||
= do
|
||||
|
||||
let
|
||||
|
@ -169,13 +171,13 @@ getDocumentRender
|
|||
_ -> foldMap visibleStrokes . strokes $ content
|
||||
| Just ( PartialPath p0 cp0 anchor firstPoint ) <- mbPartialPath
|
||||
, let
|
||||
mbFinalPoint :: Maybe ( Point2D Double )
|
||||
mbControlPoint :: Maybe ( Point2D Double )
|
||||
mbFinalPoint :: Maybe ( ℝ 2 )
|
||||
mbControlPoint :: Maybe ( ℝ 2 )
|
||||
( mbFinalPoint, mbControlPoint )
|
||||
| Just ( DrawHold holdPos ) <- mbHoldEvent
|
||||
= if firstPoint
|
||||
then ( mbMousePos , Just holdPos )
|
||||
else ( Just holdPos, ( \ cp -> ( cp --> holdPos :: Vector2D Double ) • holdPos ) <$> mbMousePos )
|
||||
else ( Just holdPos, ( \ cp -> ( cp --> holdPos :: T ( ℝ 2 ) ) • holdPos ) <$> mbMousePos )
|
||||
| otherwise
|
||||
= ( mbMousePos, Nothing )
|
||||
, Just finalPoint <- mbFinalPoint
|
||||
|
@ -295,12 +297,12 @@ strokeRenderData fitParams
|
|||
-- Compute the outline using the brush function.
|
||||
( outline, fitPts ) <-
|
||||
computeStrokeOutline @( T ( Record usedFields) ) @clo
|
||||
fitParams ( toUsedParams . brushParams ) ( brushFn . embedUsedParams ) spline
|
||||
fitParams ( toUsedParams . brushParams ) ( fun brushFn . embedUsedParams ) spline
|
||||
pure $
|
||||
StrokeWithOutlineRenderData
|
||||
{ strokeDataSpline = spline
|
||||
, strokeOutlineData = ( outline, fitPts )
|
||||
, strokeBrushFunction = brushFn . embedUsedParams . toUsedParams
|
||||
, strokeBrushFunction = fun brushFn . embedUsedParams . toUsedParams
|
||||
}
|
||||
_ -> pure $
|
||||
StrokeRenderData
|
||||
|
@ -409,11 +411,11 @@ renderBrushShape
|
|||
renderBrushShape cols mbHoverContext zoom brushFn pt =
|
||||
let
|
||||
x, y :: Double
|
||||
Point2D x y = coords pt
|
||||
ℝ2 x y = coords pt
|
||||
brushPts :: SplinePts Closed
|
||||
brushPts = brushFn ( brushParams pt )
|
||||
mbHoverContext' :: Maybe HoverContext
|
||||
mbHoverContext' = Vector2D -x -y • mbHoverContext
|
||||
mbHoverContext' = V2 -x -y • mbHoverContext
|
||||
in
|
||||
toAll do
|
||||
Cairo.save
|
||||
|
@ -427,11 +429,11 @@ drawPoint ( Colours {..} ) mbHover zoom PathPoint pt
|
|||
= do
|
||||
let
|
||||
x, y :: Double
|
||||
Point2D x y = coords pt
|
||||
ℝ2 x y = coords pt
|
||||
hsqrt3 :: Double
|
||||
hsqrt3 = sqrt 0.75
|
||||
selectionState :: FocusState
|
||||
selectionState = view _selection pt <> hovered mbHover zoom ( Point2D x y )
|
||||
selectionState = view _selection pt <> hovered mbHover zoom ( ℝ2 x y )
|
||||
|
||||
Cairo.save
|
||||
Cairo.translate x y
|
||||
|
@ -463,9 +465,9 @@ drawPoint ( Colours {..} ) mbHover zoom ControlPoint pt
|
|||
= do
|
||||
let
|
||||
x, y :: Double
|
||||
Point2D x y = coords pt
|
||||
ℝ2 x y = coords pt
|
||||
selectionState :: FocusState
|
||||
selectionState = view _selection pt <> hovered mbHover zoom ( Point2D x y )
|
||||
selectionState = view _selection pt <> hovered mbHover zoom ( ℝ2 x y )
|
||||
|
||||
Cairo.save
|
||||
Cairo.translate x y
|
||||
|
@ -494,8 +496,8 @@ drawLine :: Colours -> Double -> PointType -> PointData b -> PointData b -> Cair
|
|||
drawLine ( Colours { path, controlPointLine } ) zoom pointType p1 p2 = do
|
||||
let
|
||||
x1, y1, x2, y2 :: Double
|
||||
Point2D x1 y1 = coords p1
|
||||
Point2D x2 y2 = coords p2
|
||||
ℝ2 x1 y1 = coords p1
|
||||
ℝ2 x2 y2 = coords p2
|
||||
|
||||
Cairo.save
|
||||
Cairo.moveTo x1 y1
|
||||
|
@ -512,18 +514,18 @@ drawLine ( Colours { path, controlPointLine } ) zoom pointType p1 p2 = do
|
|||
|
||||
Cairo.restore
|
||||
|
||||
drawQuadraticBezier :: Colours -> Double -> Quadratic.Bezier ( Point2D Double ) -> Cairo.Render ()
|
||||
drawQuadraticBezier :: Colours -> Double -> Quadratic.Bezier ( ℝ 2 ) -> Cairo.Render ()
|
||||
drawQuadraticBezier cols zoom bez =
|
||||
drawCubicBezier cols zoom
|
||||
( Cubic.fromQuadratic @( Vector2D Double ) bez )
|
||||
( Cubic.fromQuadratic @( T ( ℝ 2 ) ) bez )
|
||||
|
||||
drawCubicBezier :: Colours -> Double -> Cubic.Bezier ( Point2D Double ) -> Cairo.Render ()
|
||||
drawCubicBezier :: Colours -> Double -> Cubic.Bezier ( ℝ 2 ) -> Cairo.Render ()
|
||||
drawCubicBezier ( Colours { path } ) zoom
|
||||
( Cubic.Bezier
|
||||
{ p0 = Point2D x0 y0
|
||||
, p1 = Point2D x1 y1
|
||||
, p2 = Point2D x2 y2
|
||||
, p3 = Point2D x3 y3
|
||||
{ p0 = ℝ2 x0 y0
|
||||
, p1 = ℝ2 x1 y1
|
||||
, p2 = ℝ2 x2 y2
|
||||
, p3 = ℝ2 x3 y3
|
||||
}
|
||||
)
|
||||
= do
|
||||
|
@ -573,26 +575,26 @@ drawOutline cols@( Colours {..} ) debug zoom strokeData = do
|
|||
makeOutline :: SplinePts Closed -> Cairo.Render ()
|
||||
makeOutline spline = bifoldSpline
|
||||
( drawCurve ( splineStart spline ) )
|
||||
( \ ( Point2D x y ) -> Cairo.moveTo x y )
|
||||
( \ ( ℝ2 x y ) -> Cairo.moveTo x y )
|
||||
spline
|
||||
|
||||
drawCurve :: forall clo. SplineTypeI clo => Point2D Double -> Point2D Double -> Curve clo () ( Point2D Double ) -> Cairo.Render ()
|
||||
drawCurve start ( Point2D x0 y0 ) crv = case crv of
|
||||
drawCurve :: forall clo. SplineTypeI clo => ℝ 2 -> ℝ 2 -> Curve clo () ( ℝ 2 ) -> Cairo.Render ()
|
||||
drawCurve start ( ℝ2 x0 y0 ) crv = case crv of
|
||||
LineTo mp1 _ ->
|
||||
let Point2D x1 y1 = fromNextPoint start mp1
|
||||
let ℝ2 x1 y1 = fromNextPoint start mp1
|
||||
in Cairo.lineTo x1 y1
|
||||
Bezier2To ( Point2D x1 y1 ) mp2 _ ->
|
||||
let Point2D x2 y2 = fromNextPoint start mp2
|
||||
Bezier2To ( ℝ2 x1 y1 ) mp2 _ ->
|
||||
let ℝ2 x2 y2 = fromNextPoint start mp2
|
||||
in Cairo.curveTo
|
||||
( ( 2 * x1 + x0 ) / 3 ) ( ( 2 * y1 + y0 ) / 3 )
|
||||
( ( 2 * x1 + x2 ) / 3 ) ( ( 2 * y1 + y2 ) / 3 )
|
||||
x2 y2
|
||||
Bezier3To ( Point2D x1 y1 ) ( Point2D x2 y2 ) mp3 _ ->
|
||||
let Point2D x3 y3 = fromNextPoint start mp3
|
||||
Bezier3To ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) mp3 _ ->
|
||||
let ℝ2 x3 y3 = fromNextPoint start mp3
|
||||
in Cairo.curveTo x1 y1 x2 y2 x3 y3
|
||||
|
||||
drawFitPoint :: Colours -> Double -> FitPoint -> StateT Double Cairo.Render ()
|
||||
drawFitPoint _ zoom ( FitPoint { fitPoint = Point2D x y } ) = do
|
||||
drawFitPoint _ zoom ( FitPoint { fitPoint = ℝ2 x y } ) = do
|
||||
|
||||
hue <- get
|
||||
put ( hue + 0.01 )
|
||||
|
@ -607,7 +609,7 @@ drawFitPoint _ zoom ( FitPoint { fitPoint = Point2D x y } ) = do
|
|||
Cairo.fill
|
||||
Cairo.restore
|
||||
|
||||
drawFitPoint _ zoom ( FitTangent { fitPoint = Point2D x y, fitTangent = Vector2D tx ty } ) = do
|
||||
drawFitPoint _ zoom ( FitTangent { fitPoint = ℝ2 x y, fitTangent = V2 tx ty } ) = do
|
||||
|
||||
hue <- get
|
||||
put ( hue + 0.01 )
|
||||
|
@ -626,8 +628,8 @@ drawFitPoint _ zoom ( FitTangent { fitPoint = Point2D x y, fitTangent = Vector2D
|
|||
Cairo.fill
|
||||
Cairo.restore
|
||||
|
||||
drawSelectionRectangle :: Colours -> Double -> Point2D Double -> Point2D Double -> Cairo.Render ()
|
||||
drawSelectionRectangle ( Colours {..} ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1 ) = do
|
||||
drawSelectionRectangle :: Colours -> Double -> ℝ 2 -> ℝ 2 -> Cairo.Render ()
|
||||
drawSelectionRectangle ( Colours {..} ) zoom ( ℝ2 x0 y0 ) ( ℝ2 x1 y1 ) = do
|
||||
|
||||
Cairo.save
|
||||
|
||||
|
|
|
@ -45,7 +45,7 @@ import Control.Lens
|
|||
|
||||
-- MetaBrush
|
||||
import Math.Linear
|
||||
( Point2D(..), Vector2D(..) )
|
||||
( ℝ(..), T(..) )
|
||||
import MetaBrush.Action
|
||||
( ActionOrigin(..) )
|
||||
import MetaBrush.Asset.Colours
|
||||
|
@ -70,13 +70,13 @@ import MetaBrush.GTK.Util
|
|||
|
||||
renderRuler
|
||||
:: Colours -> ( Int32, Int32 ) -> ActionOrigin -> ( Int32, Int32 )
|
||||
-> Maybe ( Point2D Double ) -> Maybe HoldAction -> Bool
|
||||
-> Maybe ( ℝ 2 ) -> Maybe HoldAction -> Bool
|
||||
-> Document
|
||||
-> Cairo.Render ()
|
||||
renderRuler
|
||||
cols@( Colours {..} ) ( viewportWidth, viewportHeight ) actionOrigin ( width, height )
|
||||
mbMousePos mbHoldEvent showGuides
|
||||
( Document { viewportCenter = center@( Point2D cx cy ), zoomFactor, documentContent = Content { guides } } ) = do
|
||||
( Document { viewportCenter = center@( ℝ2 cx cy ), zoomFactor, documentContent = Content { guides } } ) = do
|
||||
|
||||
let
|
||||
modifiedGuides :: [ Guide ]
|
||||
|
@ -85,12 +85,12 @@ renderRuler
|
|||
, Just mousePos <- mbMousePos
|
||||
= case act of
|
||||
MoveGuide guideUnique
|
||||
->
|
||||
->
|
||||
let
|
||||
translate :: Point2D Double -> Point2D Double
|
||||
translate = ( ( mousePos0 --> mousePos :: Vector2D Double ) • )
|
||||
in toList
|
||||
$ Map.adjust
|
||||
translate :: ℝ 2 -> ℝ 2
|
||||
translate = ( ( mousePos0 --> mousePos :: T ( ℝ 2 ) ) • )
|
||||
in toList
|
||||
$ Map.adjust
|
||||
( over ( field' @"guidePoint" ) translate . set ( field' @"guideFocus" ) Selected )
|
||||
guideUnique
|
||||
guides
|
||||
|
@ -99,14 +99,14 @@ renderRuler
|
|||
addNewGuides :: [ Guide ] -> [ Guide ]
|
||||
addNewGuides gs = case ruler of
|
||||
RulerCorner
|
||||
-> Guide { guidePoint = mousePos, guideNormal = Vector2D 0 1, guideFocus = Selected, guideUnique = unsafeUnique 0 }
|
||||
: Guide { guidePoint = mousePos, guideNormal = Vector2D 1 0, guideFocus = Selected, guideUnique = unsafeUnique 1 }
|
||||
-> Guide { guidePoint = mousePos, guideNormal = V2 0 1, guideFocus = Selected, guideUnique = unsafeUnique 0 }
|
||||
: Guide { guidePoint = mousePos, guideNormal = V2 1 0, guideFocus = Selected, guideUnique = unsafeUnique 1 }
|
||||
: gs
|
||||
LeftRuler
|
||||
-> Guide { guidePoint = mousePos, guideNormal = Vector2D 1 0, guideFocus = Selected, guideUnique = unsafeUnique 2 }
|
||||
-> Guide { guidePoint = mousePos, guideNormal = V2 1 0, guideFocus = Selected, guideUnique = unsafeUnique 2 }
|
||||
: gs
|
||||
TopRuler
|
||||
-> Guide { guidePoint = mousePos, guideNormal = Vector2D 0 1, guideFocus = Selected, guideUnique = unsafeUnique 3 }
|
||||
-> Guide { guidePoint = mousePos, guideNormal = V2 0 1, guideFocus = Selected, guideUnique = unsafeUnique 3 }
|
||||
: gs
|
||||
in addNewGuides ( toList guides )
|
||||
| otherwise
|
||||
|
@ -114,7 +114,7 @@ renderRuler
|
|||
|
||||
mbHoverContext :: Maybe HoverContext
|
||||
mbHoverContext
|
||||
| Just mp@( Point2D x y ) <- mbMousePos
|
||||
| Just mp@( ℝ2 x y ) <- mbMousePos
|
||||
, x <= left || y <= top -- only hover guides from within ruler area
|
||||
= Just ( MouseHover mp )
|
||||
| otherwise
|
||||
|
@ -131,7 +131,7 @@ renderRuler
|
|||
-- Render guides.
|
||||
when showGuides ( for_ modifiedGuides ( renderGuide cols mbHoverContext zoomFactor ) )
|
||||
-- Render mouse cursor indicator.
|
||||
for_ mbMousePos \ ( Point2D mx my ) ->
|
||||
for_ mbMousePos \ ( ℝ2 mx my ) ->
|
||||
case actionOrigin of
|
||||
RulerOrigin TopRuler -> do
|
||||
Cairo.save
|
||||
|
@ -149,7 +149,7 @@ renderRuler
|
|||
Cairo.translate left my
|
||||
Cairo.moveTo 0 0
|
||||
Cairo.scale ( 1 / zoomFactor ) ( 1 / zoomFactor )
|
||||
Cairo.lineTo -6 -3
|
||||
Cairo.lineTo -6 -3
|
||||
Cairo.lineTo -6 3
|
||||
Cairo.closePath
|
||||
withRGBA cursorIndicator Cairo.setSourceRGBA
|
||||
|
@ -166,8 +166,8 @@ renderRuler
|
|||
dx = fromIntegral width
|
||||
dy = fromIntegral height
|
||||
left, right, top, bottom :: Double
|
||||
Point2D left top = toViewport ( Point2D 0 0 )
|
||||
Point2D right bottom = toViewport ( Point2D ( fromIntegral viewportWidth ) ( fromIntegral viewportHeight ) )
|
||||
ℝ2 left top = toViewport ( ℝ2 0 0 )
|
||||
ℝ2 right bottom = toViewport ( ℝ2 ( fromIntegral viewportWidth ) ( fromIntegral viewportHeight ) )
|
||||
additionalAdjustment :: Cairo.Render ()
|
||||
additionalAdjustment = case actionOrigin of
|
||||
ViewportOrigin -> pure ()
|
||||
|
@ -178,7 +178,7 @@ renderRuler
|
|||
Cairo.translate dx 0
|
||||
TopRuler -> do
|
||||
Cairo.translate 0 dy
|
||||
toViewport :: Point2D Double -> Point2D Double
|
||||
toViewport :: ℝ 2 -> ℝ 2
|
||||
toViewport = toViewportCoordinates zoomFactor ( fromIntegral viewportWidth, fromIntegral viewportHeight ) center
|
||||
|
||||
setTickRenderContext :: Cairo.Render ()
|
||||
|
@ -282,7 +282,7 @@ data Tick
|
|||
|
||||
renderGuide :: Colours -> Maybe HoverContext -> Double -> Guide -> Cairo.Render ()
|
||||
renderGuide ( Colours {..} ) mbHoverContext zoom
|
||||
gd@( Guide { guidePoint = Point2D x y, guideNormal = Vector2D nx ny, guideFocus } )
|
||||
gd@( Guide { guidePoint = ℝ2 x y, guideNormal = V2 nx ny, guideFocus } )
|
||||
= do
|
||||
|
||||
Cairo.save
|
||||
|
|
|
@ -30,7 +30,7 @@ import Math.Bezier.Spline
|
|||
import Math.Module
|
||||
( (*^), squaredNorm, closestPointOnSegment )
|
||||
import Math.Linear
|
||||
( Point2D(..), Vector2D(..), Segment(..) )
|
||||
( ℝ(..), T(..), Segment(..) )
|
||||
import MetaBrush.Document
|
||||
( Stroke(..), PointData(..)
|
||||
, coords
|
||||
|
@ -39,13 +39,13 @@ import MetaBrush.Document
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Convert a position relative to the drawing area into viewport coordinates.
|
||||
toViewportCoordinates :: Double -> ( Double, Double ) -> Point2D Double -> Point2D Double -> Point2D Double
|
||||
toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter ( Point2D x y )
|
||||
= ( recip zoomFactor *^ ( Point2D ( 0.5 * viewportWidth ) ( 0.5 * viewportHeight ) --> Point2D x y :: Vector2D Double ) )
|
||||
toViewportCoordinates :: Double -> ( Double, Double ) -> ℝ 2 -> ℝ 2 -> ℝ 2
|
||||
toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter ( ℝ2 x y )
|
||||
= ( recip zoomFactor *^ ( ℝ2 ( 0.5 * viewportWidth ) ( 0.5 * viewportHeight ) --> ℝ2 x y :: T ( ℝ 2 ) ) )
|
||||
• viewportCenter
|
||||
|
||||
-- | Find the closest point in a set of strokes.
|
||||
closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Maybe ( Point2D Double ) )
|
||||
closestPoint :: ℝ 2 -> Stroke -> ArgMin Double ( Maybe ( ℝ 2 ) )
|
||||
closestPoint c ( Stroke { strokeSpline, strokeVisible = True } ) =
|
||||
coerce $
|
||||
bifoldSpline @_ @Identity
|
||||
|
@ -53,8 +53,8 @@ closestPoint c ( Stroke { strokeSpline, strokeVisible = True } ) =
|
|||
( res . coords )
|
||||
strokeSpline
|
||||
where
|
||||
res :: Point2D Double -> Identity ( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) )
|
||||
res p = coerce $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p )
|
||||
res :: ℝ 2 -> Identity ( ArgMin BoundedDouble ( Maybe ( ℝ 2 ) ) )
|
||||
res p = coerce $ Arg ( squaredNorm ( c --> p :: T ( ℝ 2 ) ) ) ( Just p )
|
||||
|
||||
closestPointToCurve
|
||||
:: forall clo crvData brushParams
|
||||
|
@ -62,18 +62,18 @@ closestPoint c ( Stroke { strokeSpline, strokeVisible = True } ) =
|
|||
=> PointData brushParams
|
||||
-> PointData brushParams
|
||||
-> Curve clo crvData ( PointData brushParams )
|
||||
-> Identity ( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) )
|
||||
-> Identity ( ArgMin BoundedDouble ( Maybe ( ℝ 2 ) ) )
|
||||
closestPointToCurve start p0 ( LineTo p1 _ ) =
|
||||
res ( snd $ closestPointOnSegment @( Vector2D Double ) c ( Segment (coords p0 ) ( coords $ fromNextPoint start p1 ) ) )
|
||||
res ( snd $ closestPointOnSegment @( T ( ℝ 2 ) ) c ( Segment (coords p0 ) ( coords $ fromNextPoint start p1 ) ) )
|
||||
closestPointToCurve start p0 ( Bezier2To p1 p2 _ ) = coerce $
|
||||
fmap ( fmap ( Just . snd ) )
|
||||
( Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier ( coords p0 ) ( coords p1 ) ( coords $ fromNextPoint start p2 ) ) c )
|
||||
( Quadratic.closestPoint @( T ( ℝ 2 ) ) ( Quadratic.Bezier ( coords p0 ) ( coords p1 ) ( coords $ fromNextPoint start p2 ) ) c )
|
||||
closestPointToCurve start p0 ( Bezier3To p1 p2 p3 _ ) = coerce $
|
||||
fmap ( fmap ( Just . snd ) )
|
||||
( Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier ( coords p0 ) ( coords p1 ) ( coords p2 ) ( coords $ fromNextPoint start p3 ) ) c )
|
||||
closestPoint _ _ = coerce $ mempty @( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) )
|
||||
( Cubic.closestPoint @( T ( ℝ 2 ) ) ( Cubic.Bezier ( coords p0 ) ( coords p1 ) ( coords p2 ) ( coords $ fromNextPoint start p3 ) ) c )
|
||||
closestPoint _ _ = coerce $ mempty @( ArgMin BoundedDouble ( Maybe ( ℝ 2 ) ) )
|
||||
|
||||
-- Messing around to emulate a `Monoid` instance for `ArgMin Double ( Maybe ( Point2D Double ) )`
|
||||
-- Messing around to emulate a `Monoid` instance for `ArgMin Double ( Maybe ( ℝ 2 ) )`
|
||||
newtype BoundedDouble = BoundedDouble Double
|
||||
deriving stock Show
|
||||
deriving newtype ( Eq, Ord )
|
||||
|
|
|
@ -36,7 +36,7 @@ import qualified Data.Text as Text
|
|||
|
||||
-- MetaBrush
|
||||
import Math.Linear
|
||||
( Point2D(..) )
|
||||
( ℝ(..) )
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours )
|
||||
import MetaBrush.Asset.Cursor
|
||||
|
@ -164,14 +164,14 @@ updateInfoBar viewportDrawingArea ( InfoBar {..} ) ( Variables { mousePosTVar }
|
|||
GTK.labelSetText botRightPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na )
|
||||
Just ( Document { zoomFactor, viewportCenter } ) -> do
|
||||
let
|
||||
toViewport :: Point2D Double -> Point2D Double
|
||||
toViewport :: ℝ 2 -> ℝ 2
|
||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||
Point2D l t = toViewport ( Point2D 0 0 )
|
||||
Point2D r b = toViewport ( Point2D viewportWidth viewportHeight )
|
||||
ℝ2 l t = toViewport ( ℝ2 0 0 )
|
||||
ℝ2 r b = toViewport ( ℝ2 viewportWidth viewportHeight )
|
||||
mbMousePos <- STM.readTVarIO mousePosTVar
|
||||
GTK.labelSetText zoomText $ Text.pack ( fixed 5 2 ( 100 * zoomFactor ) <> "%" )
|
||||
case mbMousePos of
|
||||
Just ( Point2D mx my ) ->
|
||||
Just ( ℝ2 mx my ) ->
|
||||
GTK.labelSetText cursorPosText $ Text.pack ( "x: " <> fixed 6 2 mx <> "\ny: " <> fixed 6 2 my )
|
||||
Nothing ->
|
||||
GTK.labelSetText cursorPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na )
|
||||
|
|
|
@ -40,7 +40,7 @@ import Math.Bezier.Spline
|
|||
import Math.Bezier.Stroke
|
||||
( CachedStroke(..) )
|
||||
import Math.Linear
|
||||
( Point2D(..) )
|
||||
( ℝ(..) )
|
||||
|
||||
-- metabrushes
|
||||
import MetaBrush.Asset.Brushes
|
||||
|
@ -140,7 +140,7 @@ main = case test of
|
|||
Document
|
||||
{ displayName = "beta"
|
||||
, mbFilePath = Just "betamf.mb"
|
||||
, viewportCenter = Point2D 0 0
|
||||
, viewportCenter = ℝ2 0 0
|
||||
, zoomFactor = 16
|
||||
, documentUnique = docUnique
|
||||
, documentContent =
|
||||
|
|
|
@ -66,7 +66,7 @@ import Math.Bezier.Stroke
|
|||
import Math.Module
|
||||
( lerp )
|
||||
import Math.Linear
|
||||
( Point2D(..), Vector2D(..) )
|
||||
( ℝ(..), T(..) )
|
||||
|
||||
-- metabrushes
|
||||
import MetaBrush.DSL.Interpolation
|
||||
|
@ -142,7 +142,7 @@ trailToSpline (Diagrams.Loc { Diagrams.loc = Linear.P ( Linear.V2 sx sy ), Diagr
|
|||
where
|
||||
start :: PointData ptParams
|
||||
start = PointData
|
||||
{ pointCoords = Point2D sx sy
|
||||
{ pointCoords = ℝ2 sx sy
|
||||
, pointState = Normal
|
||||
, brushParams = ptDatum
|
||||
}
|
||||
|
@ -157,9 +157,9 @@ trailToSpline (Diagrams.Loc { Diagrams.loc = Linear.P ( Linear.V2 sx sy ), Diagr
|
|||
nextStart =
|
||||
case seg of
|
||||
Diagrams.Linear ( Diagrams.OffsetClosed ( Linear.V2 ex ey ) ) ->
|
||||
Vector2D ex ey • ( p0 { brushParams = par1 } )
|
||||
V2 ex ey • ( p0 { brushParams = par1 } )
|
||||
Diagrams.Cubic _ _ ( Diagrams.OffsetClosed ( Linear.V2 ex ey ) ) ->
|
||||
Vector2D ex ey • ( p0 { brushParams = par1 } )
|
||||
V2 ex ey • ( p0 { brushParams = par1 } )
|
||||
curve :: Curve Open (CachedStroke RealWorld) (PointData ptParams)
|
||||
curve = segmentToCurve p0 par1 seg
|
||||
in
|
||||
|
@ -180,8 +180,8 @@ segmentToCurve p0@( PointData { brushParams = startParams } ) endParams = \case
|
|||
}
|
||||
Diagrams.Cubic ( Linear.V2 x1 y1 ) ( Linear.V2 x2 y2 ) end ->
|
||||
Bezier3To
|
||||
{ controlPoint1 = Vector2D x1 y1 • ( p0 { brushParams = lerpParams (1/3) startParams endParams } )
|
||||
, controlPoint2 = Vector2D x2 y2 • ( p0 { brushParams = lerpParams (2/3) startParams endParams } )
|
||||
{ controlPoint1 = V2 x1 y1 • ( p0 { brushParams = lerpParams (1/3) startParams endParams } )
|
||||
, controlPoint2 = V2 x2 y2 • ( p0 { brushParams = lerpParams (2/3) startParams endParams } )
|
||||
, curveEnd = offsetToNextPoint ( p0 { brushParams = endParams } ) end
|
||||
, curveData = noCache
|
||||
}
|
||||
|
@ -196,7 +196,7 @@ offsetToNextPoint :: PointData ptParams
|
|||
offsetToNextPoint _ Diagrams.OffsetOpen
|
||||
= BackToStart
|
||||
offsetToNextPoint p0 ( Diagrams.OffsetClosed ( Linear.V2 ex ey ) )
|
||||
= NextPoint $ Vector2D ex ey • p0
|
||||
= NextPoint $ V2 ex ey • p0
|
||||
|
||||
noCache :: CachedStroke RealWorld
|
||||
noCache = runRW# \ s ->
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module MetaBrush.Asset.Brushes where
|
||||
|
||||
|
@ -23,7 +24,7 @@ import qualified Data.HashMap.Strict as HashMap
|
|||
-- MetaBrush
|
||||
import Math.Bezier.Spline
|
||||
import Math.Linear
|
||||
( Point2D(..), ℝ(..), T(..) )
|
||||
( ℝ(..), T(..) )
|
||||
import Math.Linear.Dual
|
||||
( D, type (~>)(..), Var(var), konst )
|
||||
import Math.Module
|
||||
|
@ -34,8 +35,6 @@ import MetaBrush.Records
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
type CircleBrushFields = '[ "r" ]
|
||||
|
||||
lookupBrush :: Text -> Maybe SomeBrush
|
||||
lookupBrush nm = HashMap.lookup nm brushes
|
||||
|
||||
|
@ -53,45 +52,25 @@ brushes = HashMap.fromList
|
|||
κ :: Double
|
||||
κ = 0.5519150244935105707435627227925
|
||||
|
||||
circleSpline :: (Double -> Double -> ptData) -> Spline 'Closed () ptData
|
||||
circleSpline p =
|
||||
Spline { splineStart = p 1 0
|
||||
, splineCurves = ClosedCurves crvs lastCrv }
|
||||
where
|
||||
crvs = Seq.fromList
|
||||
[ Bezier3To (p 1 κ) (p κ 1) (NextPoint (p 0 1)) ()
|
||||
, Bezier3To (p -κ 1) (p -1 κ) (NextPoint (p -1 0)) ()
|
||||
, Bezier3To (p -1 -κ) (p -κ -1) (NextPoint (p 0 -1)) ()
|
||||
]
|
||||
lastCrv =
|
||||
Bezier3To (p κ -1) (p 1 -κ) BackToStart ()
|
||||
|
||||
type CircleBrushFields = '[ "r" ]
|
||||
circle :: Brush CircleBrushFields
|
||||
circle = BrushData "circle" (WithParams deflts shape)
|
||||
circle = BrushData "circle" ( WithParams deflts circleBrush )
|
||||
where
|
||||
deflts :: Record CircleBrushFields
|
||||
deflts = MkR ( ℝ1 1 )
|
||||
shape :: Record CircleBrushFields -> SplinePts 'Closed
|
||||
shape ( MkR ( ℝ1 r ) ) =
|
||||
circleSpline ( \ x y -> Point2D (r * x) (r * y) )
|
||||
|
||||
type EllipseBrushFields = '[ "a", "b", "phi" ]
|
||||
|
||||
ellipse :: Brush EllipseBrushFields
|
||||
ellipse = BrushData "ellipse" (WithParams deflts shape)
|
||||
ellipse = BrushData "ellipse" ( WithParams deflts ellipseBrush )
|
||||
where
|
||||
deflts :: Record EllipseBrushFields
|
||||
deflts = MkR ( ℝ3 1 1 0 )
|
||||
shape :: Record EllipseBrushFields -> SplinePts 'Closed
|
||||
shape ( MkR ( ℝ3 a b phi ) ) =
|
||||
circleSpline ( \ x y -> Point2D (a * x * cos phi - b * y * sin phi)
|
||||
(b * y * cos phi + a * x * sin phi) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Differentiable brushes.
|
||||
|
||||
circleSpline2 :: ( Double -> Double -> D ( ℝ 3 ) ptData ) -> D ( ℝ 3 ) ( Spline 'Closed () ptData )
|
||||
circleSpline2 p = sequenceA $
|
||||
circleSpline :: Applicative ( D u ) => ( Double -> Double -> D u v ) -> D u ( Spline 'Closed () v )
|
||||
circleSpline p = sequenceA $
|
||||
Spline { splineStart = p 1 0
|
||||
, splineCurves = ClosedCurves crvs lastCrv }
|
||||
where
|
||||
|
@ -103,24 +82,44 @@ circleSpline2 p = sequenceA $
|
|||
lastCrv =
|
||||
Bezier3To (p κ -1) (p 1 -κ) BackToStart ()
|
||||
|
||||
ellipseBrush :: ℝ 3 ~> Spline 'Closed () ( ℝ 2 )
|
||||
circleBrush :: Record CircleBrushFields ~> Spline 'Closed () ( ℝ 2 )
|
||||
circleBrush =
|
||||
D \ params ->
|
||||
let r :: D ( Record CircleBrushFields ) Double
|
||||
r = runD ( var @1 ) params
|
||||
mkPt :: Double -> Double -> D ( Record CircleBrushFields ) ( ℝ 2 )
|
||||
mkPt ( kon -> x ) ( kon -> y )
|
||||
= fmap coerce
|
||||
$ ( x * r ) *^ e_x
|
||||
^+^ ( y * r ) *^ e_y
|
||||
in circleSpline @( Record CircleBrushFields ) mkPt
|
||||
where
|
||||
e_x, e_y :: D ( Record CircleBrushFields ) ( T ( ℝ 2 ) )
|
||||
e_x = pure $ T $ ℝ2 1 0
|
||||
e_y = pure $ T $ ℝ2 0 1
|
||||
|
||||
kon = konst @( Record CircleBrushFields )
|
||||
|
||||
ellipseBrush :: Record EllipseBrushFields ~> Spline 'Closed () ( ℝ 2 )
|
||||
ellipseBrush =
|
||||
D \ params ->
|
||||
let a, b, phi :: D ( ℝ 3 ) Double
|
||||
let a, b, phi :: D ( Record EllipseBrushFields ) Double
|
||||
a = runD ( var @1 ) params
|
||||
b = runD ( var @2 ) params
|
||||
phi = runD ( var @3 ) params
|
||||
mkPt :: Double -> Double -> D ( ℝ 3 ) ( ℝ 2 )
|
||||
mkPt ( konst -> x ) ( konst -> y )
|
||||
mkPt :: Double -> Double -> D ( Record EllipseBrushFields ) ( ℝ 2 )
|
||||
mkPt ( kon -> x ) ( kon -> y )
|
||||
= fmap coerce
|
||||
$ ( x * a * cos phi - y * b * sin phi ) *^ e_x
|
||||
^+^ ( y * b * cos phi + x * a * sin phi ) *^ e_y
|
||||
in circleSpline2 mkPt
|
||||
in circleSpline @( Record EllipseBrushFields ) mkPt
|
||||
where
|
||||
e_x, e_y :: D ( ℝ 3 ) ( T ( ℝ 2 ) )
|
||||
e_x, e_y :: D ( Record EllipseBrushFields ) ( T ( ℝ 2 ) )
|
||||
e_x = pure $ T $ ℝ2 1 0
|
||||
e_y = pure $ T $ ℝ2 0 1
|
||||
|
||||
kon = konst @( Record EllipseBrushFields )
|
||||
|
||||
--ellipseArc :: ℝ 2 ~> ℝ 2
|
||||
--ellipseArc = brushStroke ( linear myPath ) ( uncurryD $ fmap bezier3 myBrush )
|
||||
|
||||
|
|
|
@ -37,17 +37,19 @@ import qualified Data.Text as Text
|
|||
( unpack )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Linear
|
||||
import Math.Linear.Dual
|
||||
( Diffy )
|
||||
import Math.Bezier.Spline
|
||||
( SplineType(Closed), SplinePts)
|
||||
import MetaBrush.Records
|
||||
import MetaBrush.Serialisable
|
||||
import Math.Linear
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | A brush function: a function from a record of parameters to a closed spline.
|
||||
type BrushFunction :: [ Symbol ] -> Type
|
||||
type BrushFunction brushFields = WithParams brushFields (SplinePts Closed)
|
||||
type BrushFunction brushFields = WithParams brushFields ( SplinePts Closed )
|
||||
|
||||
type Brush :: [ Symbol ] -> Type
|
||||
data Brush brushFields where
|
||||
|
@ -55,6 +57,7 @@ data Brush brushFields where
|
|||
:: forall brushFields
|
||||
. ( KnownSymbols brushFields
|
||||
, Representable ( ℝ ( Length brushFields) )
|
||||
, Diffy ( ℝ ( Length brushFields) )
|
||||
, Typeable brushFields )
|
||||
=> { brushName :: !Text
|
||||
, brushFunction :: BrushFunction brushFields
|
||||
|
|
|
@ -87,7 +87,7 @@ import Math.Module
|
|||
, squaredNorm, quadrance
|
||||
)
|
||||
import Math.Linear
|
||||
( Point2D(..), Vector2D(..) )
|
||||
( ℝ(..), T(..) )
|
||||
import MetaBrush.Brush
|
||||
( Brush, PointFields )
|
||||
import MetaBrush.Records
|
||||
|
@ -98,12 +98,12 @@ import MetaBrush.Unique
|
|||
|
||||
data AABB
|
||||
= AABB
|
||||
{ topLeft, botRight :: !( Point2D Double ) }
|
||||
{ topLeft, botRight :: !( ℝ 2 ) }
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
mkAABB :: Point2D Double -> Point2D Double -> AABB
|
||||
mkAABB ( Point2D x1 y1 ) ( Point2D x2 y2 ) = AABB ( Point2D xmin ymin ) ( Point2D xmax ymax )
|
||||
mkAABB :: ℝ 2 -> ℝ 2 -> AABB
|
||||
mkAABB ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) = AABB ( ℝ2 xmin ymin ) ( ℝ2 xmax ymax )
|
||||
where
|
||||
( xmin, xmax )
|
||||
| x1 > x2 = ( x2, x1 )
|
||||
|
@ -117,7 +117,7 @@ data Document
|
|||
= Document
|
||||
{ displayName :: !Text
|
||||
, mbFilePath :: !( Maybe FilePath )
|
||||
, viewportCenter :: !( Point2D Double )
|
||||
, viewportCenter :: !( ℝ 2 )
|
||||
, zoomFactor :: !Double
|
||||
, documentUnique :: Unique
|
||||
, documentContent :: !DocumentContent
|
||||
|
@ -217,14 +217,14 @@ overStrokeSpline f = coerce ( _strokeSpline @Identity ( coerce . f ) )
|
|||
|
||||
data PointData params
|
||||
= PointData
|
||||
{ pointCoords :: !( Point2D Double )
|
||||
{ pointCoords :: !( ℝ 2 )
|
||||
, pointState :: FocusState
|
||||
, brushParams :: !params
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
instance Act (Vector2D Double) (PointData params) where
|
||||
instance Act (T ( ℝ 2 )) (PointData params) where
|
||||
v • ( dat@( PointData { pointCoords = p } ) ) =
|
||||
dat { pointCoords = v • p }
|
||||
|
||||
|
@ -255,7 +255,7 @@ emptyDocument docName unique =
|
|||
Document
|
||||
{ displayName = docName
|
||||
, mbFilePath = Nothing
|
||||
, viewportCenter = Point2D 0 0
|
||||
, viewportCenter = ℝ2 0 0
|
||||
, zoomFactor = 1
|
||||
, documentUnique = unique
|
||||
, documentContent =
|
||||
|
@ -270,29 +270,29 @@ emptyDocument docName unique =
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
data HoverContext
|
||||
= MouseHover !( Point2D Double )
|
||||
= MouseHover !( ℝ 2 )
|
||||
| RectangleHover !AABB
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
||||
instance Act ( Vector2D Double ) HoverContext where
|
||||
instance Act ( T ( ℝ 2 ) ) HoverContext where
|
||||
v • MouseHover p = MouseHover ( v • p )
|
||||
v • RectangleHover ( AABB p1 p2 ) = RectangleHover ( AABB ( v • p1 ) ( v • p2 ) )
|
||||
|
||||
instance Act ( Vector2D Double ) ( Maybe HoverContext ) where
|
||||
instance Act ( T ( ℝ 2 ) ) ( Maybe HoverContext ) where
|
||||
(•) v = fmap ( v • )
|
||||
|
||||
class Hoverable a where
|
||||
hovered :: Maybe HoverContext -> Double -> a -> FocusState
|
||||
|
||||
instance Hoverable ( Point2D Double ) where
|
||||
instance Hoverable ( ℝ 2 ) where
|
||||
hovered Nothing _ _ = Normal
|
||||
hovered ( Just ( MouseHover p ) ) zoom q
|
||||
| quadrance @( Vector2D Double ) p q * zoom ^ ( 2 :: Int ) < 16
|
||||
| quadrance @( T ( ℝ 2 ) ) p q * zoom ^ ( 2 :: Int ) < 16
|
||||
= Hover
|
||||
| otherwise
|
||||
= Normal
|
||||
hovered ( Just ( RectangleHover ( AABB ( Point2D x1 y1 ) ( Point2D x2 y2 ) ) ) ) _ ( Point2D x y )
|
||||
hovered ( Just ( RectangleHover ( AABB ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) ) ) ) _ ( ℝ2 x y )
|
||||
| x >= x1 && x <= x2 && y >= y1 && y <= y2
|
||||
= Hover
|
||||
| otherwise
|
||||
|
@ -305,10 +305,10 @@ instance HasSelection ( PointData brushParams ) where
|
|||
instance HasSelection BrushPointData where
|
||||
_selection = field' @"brushPointState"
|
||||
|
||||
_coords :: Lens' ( PointData brushParams ) ( Point2D Double )
|
||||
_coords :: Lens' ( PointData brushParams ) ( ℝ 2 )
|
||||
_coords = field' @"pointCoords"
|
||||
|
||||
coords :: PointData brushParams -> Point2D Double
|
||||
coords :: PointData brushParams -> ℝ 2
|
||||
coords = view _coords
|
||||
|
||||
data FocusDifference
|
||||
|
@ -329,7 +329,7 @@ instance Group FocusDifference where
|
|||
|
||||
data DiffPointData diffBrushParams
|
||||
= DiffPointData
|
||||
{ diffVector :: !( Vector2D Double )
|
||||
{ diffVector :: !( T ( ℝ 2 ) )
|
||||
, diffParams :: !diffBrushParams
|
||||
, diffState :: !FocusDifference
|
||||
}
|
||||
|
@ -371,8 +371,8 @@ instance Module Double brushParams => Module Double ( DiffPointData brushParams
|
|||
|
||||
data Guide
|
||||
= Guide
|
||||
{ guidePoint :: !( Point2D Double ) -- ^ point on the guide line
|
||||
, guideNormal :: !( Vector2D Double ) -- ^ /normalised/ normal vector of the guide
|
||||
{ guidePoint :: !( ℝ 2 ) -- ^ point on the guide line
|
||||
, guideNormal :: !( T ( ℝ 2 ) ) -- ^ /normalised/ normal vector of the guide
|
||||
, guideFocus :: !FocusState
|
||||
, guideUnique :: Unique
|
||||
}
|
||||
|
@ -386,11 +386,11 @@ data Ruler
|
|||
deriving stock Show
|
||||
|
||||
-- | Try to select a guide at the given document coordinates.
|
||||
selectedGuide :: Point2D Double -> Document -> Maybe Guide
|
||||
selectedGuide :: ℝ 2 -> Document -> Maybe Guide
|
||||
selectedGuide c ( Document { zoomFactor, documentContent = Content { guides } } ) =
|
||||
\case { Min ( Arg _ g ) -> g } <$> foldMap ( selectGuide_maybe c zoomFactor ) guides
|
||||
|
||||
selectGuide_maybe :: Point2D Double -> Double -> Guide -> Maybe ( ArgMin Double Guide )
|
||||
selectGuide_maybe :: ℝ 2 -> Double -> Guide -> Maybe ( ArgMin Double Guide )
|
||||
selectGuide_maybe c zoom guide@( Guide { guidePoint = p, guideNormal = n } )
|
||||
| sqDist * zoom ^ ( 2 :: Int ) < 4
|
||||
= Just ( Min ( Arg sqDist guide ) )
|
||||
|
@ -403,7 +403,7 @@ selectGuide_maybe c zoom guide@( Guide { guidePoint = p, guideNormal = n } )
|
|||
sqDist = t ^ ( 2 :: Int ) / squaredNorm n
|
||||
|
||||
-- | Add new guide after a mouse drag from a ruler area.
|
||||
addGuide :: UniqueSupply -> Ruler -> Point2D Double -> Document -> STM Document
|
||||
addGuide :: UniqueSupply -> Ruler -> ℝ 2 -> Document -> STM Document
|
||||
addGuide uniqueSupply ruler p doc = ( `runReaderT` uniqueSupply ) $ ( field' @"documentContent" . field' @"guides" ) insertNewGuides doc
|
||||
where
|
||||
insertNewGuides :: Map Unique Guide -> ReaderT UniqueSupply STM ( Map Unique Guide )
|
||||
|
@ -414,22 +414,22 @@ addGuide uniqueSupply ruler p doc = ( `runReaderT` uniqueSupply ) $ ( field' @"d
|
|||
uniq2 <- freshUnique
|
||||
let
|
||||
guide1, guide2 :: Guide
|
||||
guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideFocus = Normal, guideUnique = uniq1 }
|
||||
guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideFocus = Normal, guideUnique = uniq2 }
|
||||
guide1 = Guide { guidePoint = p, guideNormal = V2 0 1, guideFocus = Normal, guideUnique = uniq1 }
|
||||
guide2 = Guide { guidePoint = p, guideNormal = V2 1 0, guideFocus = Normal, guideUnique = uniq2 }
|
||||
pure ( Map.insert uniq2 guide2 . Map.insert uniq1 guide1 $ gs )
|
||||
TopRuler
|
||||
-> do
|
||||
uniq1 <- freshUnique
|
||||
let
|
||||
guide1 :: Guide
|
||||
guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideFocus = Normal, guideUnique = uniq1 }
|
||||
guide1 = Guide { guidePoint = p, guideNormal = V2 0 1, guideFocus = Normal, guideUnique = uniq1 }
|
||||
pure ( Map.insert uniq1 guide1 gs )
|
||||
LeftRuler
|
||||
-> do
|
||||
uniq2 <- freshUnique
|
||||
let
|
||||
guide2 :: Guide
|
||||
guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideFocus = Normal, guideUnique = uniq2 }
|
||||
guide2 = Guide { guidePoint = p, guideNormal = V2 1 0, guideFocus = Normal, guideUnique = uniq2 }
|
||||
pure ( Map.insert uniq2 guide2 gs )
|
||||
|
||||
instance Hoverable Guide where
|
||||
|
|
|
@ -59,7 +59,7 @@ import Math.Bezier.Spline
|
|||
import Math.Module
|
||||
( squaredNorm )
|
||||
import Math.Linear
|
||||
( Point2D(..), Vector2D(..), ℝ(..) )
|
||||
( ℝ(..), T(..) )
|
||||
import MetaBrush.Assert
|
||||
( assert )
|
||||
import MetaBrush.Brush
|
||||
|
@ -94,9 +94,9 @@ anchorsAreComplementary _ _ = False
|
|||
|
||||
getOrCreateDrawAnchor
|
||||
:: UniqueSupply
|
||||
-> Point2D Double
|
||||
-> ℝ 2
|
||||
-> Document
|
||||
-> STM ( Document, DrawAnchor, Point2D Double, Maybe Text )
|
||||
-> STM ( Document, DrawAnchor, ℝ 2, Maybe Text )
|
||||
getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
|
||||
case
|
||||
( `runState` Nothing )
|
||||
|
@ -135,13 +135,13 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
|
|||
-- Deselect all points, and try to find a valid anchor for drawing
|
||||
-- (a path start/end point at mouse click point).
|
||||
|
||||
updateStrokeHierarchy :: StrokeHierarchy -> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) StrokeHierarchy
|
||||
updateStrokeHierarchy :: StrokeHierarchy -> State ( Maybe ( ( DrawAnchor, ℝ 2 ), Text ) ) StrokeHierarchy
|
||||
updateStrokeHierarchy ( StrokeGroup { .. } ) = do
|
||||
newContents <- traverse updateStrokeHierarchy groupContents
|
||||
pure ( StrokeGroup { groupContents = newContents, .. } )
|
||||
updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf
|
||||
|
||||
updateStroke :: Stroke -> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) Stroke
|
||||
updateStroke :: Stroke -> State ( Maybe ( ( DrawAnchor, ℝ 2 ), Text ) ) Stroke
|
||||
updateStroke stroke@( Stroke { strokeName, strokeVisible, strokeUnique } ) = _strokeSpline updateStrokeSpline stroke
|
||||
|
||||
where
|
||||
|
@ -149,7 +149,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
|
|||
:: forall clo brushParams
|
||||
. SplineTypeI clo
|
||||
=> StrokeSpline clo brushParams
|
||||
-> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) ( StrokeSpline clo brushParams )
|
||||
-> State ( Maybe ( ( DrawAnchor, ℝ 2 ), Text ) ) ( StrokeSpline clo brushParams )
|
||||
updateStrokeSpline spline = do
|
||||
|
||||
mbAnchor <- get
|
||||
|
@ -167,24 +167,24 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
|
|||
|
||||
where
|
||||
-- See if we can anchor a drawing operation on a given (visible) stroke.
|
||||
endpointAnchor :: Unique -> StrokeSpline clo brushParams -> Maybe ( DrawAnchor, Point2D Double )
|
||||
endpointAnchor :: Unique -> StrokeSpline clo brushParams -> Maybe ( DrawAnchor, ℝ 2 )
|
||||
endpointAnchor uniq ( Spline { splineStart, splineCurves } ) = case ssplineType @clo of
|
||||
SOpen
|
||||
| let
|
||||
p0 :: Point2D Double
|
||||
p0 :: ℝ 2
|
||||
p0 = coords splineStart
|
||||
, inPointClickRange p0
|
||||
-> Just ( AnchorAtStart uniq, p0 )
|
||||
| OpenCurves ( _ :|> lastCurve ) <- splineCurves
|
||||
, let
|
||||
pn :: Point2D Double
|
||||
pn :: ℝ 2
|
||||
pn = coords ( openCurveEnd lastCurve )
|
||||
, inPointClickRange pn
|
||||
-> Just ( AnchorAtEnd uniq, pn )
|
||||
_ -> Nothing
|
||||
inPointClickRange :: Point2D Double -> Bool
|
||||
inPointClickRange :: ℝ 2 -> Bool
|
||||
inPointClickRange p =
|
||||
squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
|
||||
squaredNorm ( c --> p :: T ( ℝ 2 ) ) < 16 / ( zoomFactor * zoomFactor )
|
||||
|
||||
addToAnchor :: DrawAnchor -> StrokeSpline Open () -> Document -> Document
|
||||
addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strokes" . mapped ) updateStrokeHierarchy
|
||||
|
|
|
@ -106,7 +106,7 @@ import qualified Waargonaut.Types.Whitespace as JSON
|
|||
import Math.Bezier.Spline
|
||||
( SplineType(..), SSplineType(..), SplineTypeI(..) )
|
||||
import Math.Linear
|
||||
( Point2D(..), Vector2D(..))
|
||||
( ℝ(..), T(..) )
|
||||
import MetaBrush.Asset.Brushes
|
||||
( lookupBrush )
|
||||
import MetaBrush.Brush
|
||||
|
@ -192,8 +192,8 @@ encodePointData
|
|||
)
|
||||
=> JSON.Encoder f ( PointData brushParams )
|
||||
encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointCoords, brushParams } ) ->
|
||||
JSON.Encoder.atKey' "coords" ( encoder @( Point2D Double ) ) pointCoords
|
||||
. JSON.Encoder.atKey' "brushParams" ( encoder @( Record flds ) ) brushParams
|
||||
JSON.Encoder.atKey' "coords" ( encoder @( ℝ 2 ) ) pointCoords
|
||||
. JSON.Encoder.atKey' "brushParams" ( encoder @( Record flds ) ) brushParams
|
||||
|
||||
decodePointData
|
||||
:: forall m ( flds :: [ Symbol ] ) brushParams
|
||||
|
@ -203,7 +203,7 @@ decodePointData
|
|||
)
|
||||
=> JSON.Decoder m ( PointData brushParams )
|
||||
decodePointData = do
|
||||
pointCoords <- JSON.Decoder.atKey "coords" ( decoder @( Point2D Double ) )
|
||||
pointCoords <- JSON.Decoder.atKey "coords" ( decoder @( ℝ 2 ) )
|
||||
let
|
||||
pointState :: FocusState
|
||||
pointState = Normal
|
||||
|
@ -318,13 +318,13 @@ decodeStrokeHierarchy uniqueSupply = do
|
|||
|
||||
encodeGuide :: Applicative f => JSON.Encoder f Guide
|
||||
encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) ->
|
||||
JSON.Encoder.atKey' "point" ( encoder @( Point2D Double ) ) guidePoint
|
||||
. JSON.Encoder.atKey' "normal" ( encoder @( Vector2D Double ) ) guideNormal
|
||||
JSON.Encoder.atKey' "point" ( encoder @( ℝ 2 ) ) guidePoint
|
||||
. JSON.Encoder.atKey' "normal" ( encoder @( T ( ℝ 2 ) ) ) guideNormal
|
||||
|
||||
decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m Guide
|
||||
decodeGuide uniqueSupply = do
|
||||
guidePoint <- JSON.Decoder.atKey "point" ( decoder @( Point2D Double ) )
|
||||
guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( Vector2D Double ) )
|
||||
guidePoint <- JSON.Decoder.atKey "point" ( decoder @( ℝ 2 ) )
|
||||
guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( T ( ℝ 2 ) ) )
|
||||
let
|
||||
guideFocus :: FocusState
|
||||
guideFocus = Normal
|
||||
|
@ -356,14 +356,14 @@ encodeDocument = JSON.Encoder.mapLikeObj
|
|||
\ ( Document { displayName, viewportCenter, zoomFactor, documentContent } ) ->
|
||||
JSON.Encoder.atKey' "version" ( JSON.Encoder.list JSON.Encoder.int ) ( versionBranch Cabal.version )
|
||||
. JSON.Encoder.atKey' "name" JSON.Encoder.text displayName
|
||||
. JSON.Encoder.atKey' "center" ( encoder @( Point2D Double ) ) viewportCenter
|
||||
. JSON.Encoder.atKey' "center" ( encoder @( ℝ 2 ) ) viewportCenter
|
||||
. JSON.Encoder.atKey' "zoom" ( encoder @Double ) zoomFactor
|
||||
. JSON.Encoder.atKey' "content" encodeDocumentContent documentContent
|
||||
|
||||
decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document
|
||||
decodeDocument uniqueSupply mbFilePath = do
|
||||
displayName <- JSON.Decoder.atKey "name" JSON.Decoder.text
|
||||
viewportCenter <- JSON.Decoder.atKey "center" ( decoder @( Point2D Double ) )
|
||||
viewportCenter <- JSON.Decoder.atKey "center" ( decoder @( ℝ 2 ) )
|
||||
zoomFactor <- JSON.Decoder.atKey "zoom" ( decoder @Double )
|
||||
documentUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
|
||||
documentContent <- JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply )
|
||||
|
|
|
@ -51,7 +51,7 @@ import Math.Bezier.Stroke
|
|||
import Math.Module
|
||||
( lerp, quadrance, closestPointOnSegment )
|
||||
import Math.Linear
|
||||
( Point2D(..), Vector2D(..), Segment(..), T(..) )
|
||||
( Segment(..), ℝ(..), T(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..), Stroke(..), StrokeHierarchy(..), StrokeSpline
|
||||
, PointData(..), DiffPointData(..)
|
||||
|
@ -63,7 +63,7 @@ import MetaBrush.Records
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Subdivide a path at the given center, provided a path indeed lies there.
|
||||
subdivide :: Point2D Double -> Document -> Maybe ( Document, Text )
|
||||
subdivide :: ℝ 2 -> Document -> Maybe ( Document, Text )
|
||||
subdivide c doc@( Document { zoomFactor } ) =
|
||||
let
|
||||
updatedDoc :: Document
|
||||
|
@ -95,14 +95,14 @@ subdivide c doc@( Document { zoomFactor } ) =
|
|||
| otherwise
|
||||
= fmap ( \ curves -> adjustSplineType @clo $ Spline { splineStart, splineCurves = OpenCurves curves } )
|
||||
$ bifoldSpline
|
||||
( updateCurve ( "stroke " <> strokeName ) ( Vector2D 0 0 ) )
|
||||
( updateCurve ( "stroke " <> strokeName ) ( V2 0 0 ) )
|
||||
( const $ pure Empty )
|
||||
( adjustSplineType @Open spline )
|
||||
|
||||
where
|
||||
updateCurve
|
||||
:: Text
|
||||
-> Vector2D Double
|
||||
-> T ( ℝ 2 )
|
||||
-> PointData brushParams
|
||||
-> Curve Open ( CachedStroke RealWorld ) ( PointData brushParams )
|
||||
-> State ( Maybe Text )
|
||||
|
@ -110,13 +110,13 @@ subdivide c doc@( Document { zoomFactor } ) =
|
|||
updateCurve txt offset sp0 curve = case curve of
|
||||
line@( LineTo ( NextPoint sp1 ) dat ) ->
|
||||
let
|
||||
p0, p1, s :: Point2D Double
|
||||
p0, p1, s :: ℝ 2
|
||||
t :: Double
|
||||
p0 = coords sp0
|
||||
p1 = coords sp1
|
||||
( t, s ) = closestPointOnSegment @( Vector2D Double ) ( invert offset • c ) ( Segment p0 p1 )
|
||||
( t, s ) = closestPointOnSegment @( T ( ℝ 2 ) ) ( invert offset • c ) ( Segment p0 p1 )
|
||||
sqDist :: Double
|
||||
sqDist = quadrance @( Vector2D Double ) c ( offset • s )
|
||||
sqDist = quadrance @( T ( ℝ 2 ) ) c ( offset • s )
|
||||
in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
|
||||
then
|
||||
let
|
||||
|
@ -128,13 +128,13 @@ subdivide c doc@( Document { zoomFactor } ) =
|
|||
else pure $ Seq.singleton line
|
||||
bez2@( Bezier2To sp1 ( NextPoint sp2 ) dat ) ->
|
||||
let
|
||||
p0, p1, p2 :: Point2D Double
|
||||
p0, p1, p2 :: ℝ 2
|
||||
p0 = coords sp0
|
||||
p1 = coords sp1
|
||||
p2 = coords sp2
|
||||
sqDist :: Double
|
||||
Min ( Arg sqDist ( t, _ ) )
|
||||
= Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier {..} ) ( invert offset • c )
|
||||
= Quadratic.closestPoint @( T ( ℝ 2 ) ) ( Quadratic.Bezier {..} ) ( invert offset • c )
|
||||
in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
|
||||
then case Quadratic.subdivide @( DiffPointData ( T brushParams ) ) ( Quadratic.Bezier sp0 sp1 sp2 ) t of
|
||||
( Quadratic.Bezier _ q1 subdiv, Quadratic.Bezier _ r1 _ ) -> do
|
||||
|
@ -147,13 +147,13 @@ subdivide c doc@( Document { zoomFactor } ) =
|
|||
else pure $ Seq.singleton bez2
|
||||
bez3@( Bezier3To sp1 sp2 ( NextPoint sp3 ) dat ) ->
|
||||
let
|
||||
p0, p1, p2, p3 :: Point2D Double
|
||||
p0, p1, p2, p3 :: ℝ 2
|
||||
p0 = coords sp0
|
||||
p1 = coords sp1
|
||||
p2 = coords sp2
|
||||
p3 = coords sp3
|
||||
Min ( Arg sqDist ( t, _ ) )
|
||||
= Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier {..} ) ( invert offset • c )
|
||||
= Cubic.closestPoint @( T ( ℝ 2 ) ) ( Cubic.Bezier {..} ) ( invert offset • c )
|
||||
in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
|
||||
then case Cubic.subdivide @( DiffPointData ( T brushParams ) ) ( Cubic.Bezier sp0 sp1 sp2 sp3 ) t of
|
||||
( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) -> do
|
||||
|
|
|
@ -49,6 +49,7 @@ import qualified Data.Text as Text
|
|||
|
||||
-- MetaBrush
|
||||
import Math.Linear
|
||||
import Math.Linear.Dual
|
||||
import Math.Module
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
@ -66,7 +67,7 @@ type WithParams :: [ Symbol ] -> Type -> Type
|
|||
data WithParams params a =
|
||||
WithParams
|
||||
{ defaultParams :: Record params
|
||||
, withParams :: Record params -> a
|
||||
, withParams :: Record params ~> a
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
@ -122,6 +123,11 @@ instance ( Torsor ( T ( ℝ ( Length ks ) ) ) ( ℝ ( Length ks ) )
|
|||
=> Torsor ( T ( Record ks ) ) ( Record ks ) where
|
||||
MkR g --> MkR a = T $ MkR $ unT $ g --> a
|
||||
|
||||
type instance D ( Record ks ) = D ( ℝ ( Length ks ) )
|
||||
|
||||
deriving newtype instance Var n ( ℝ ( Length ks ) ) => Var n ( Record ks )
|
||||
deriving newtype instance Diffy ( ℝ ( Length ks ) ) => Diffy ( Record ks )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
type Length :: [ k ] -> Nat
|
||||
|
|
|
@ -82,7 +82,7 @@ import Math.Bezier.Spline
|
|||
import Math.Bezier.Stroke
|
||||
( CachedStroke(..) )
|
||||
import Math.Linear
|
||||
( Point2D(..), Vector2D(..), ℝ(..)
|
||||
( ℝ(..), T(..)
|
||||
, Fin(..), Representable(tabulate, index)
|
||||
)
|
||||
import MetaBrush.Records
|
||||
|
@ -99,17 +99,17 @@ instance Serialisable Double where
|
|||
encoder = contramap Scientific.fromFloatDigits JSON.Encoder.scientific
|
||||
decoder = fmap Scientific.toRealFloat JSON.Decoder.scientific
|
||||
|
||||
instance Serialisable a => Serialisable ( Point2D a ) where
|
||||
encoder = JSON.Encoder.mapLikeObj \ ( Point2D x y ) ->
|
||||
instance Serialisable ( ℝ 2 ) where
|
||||
encoder = JSON.Encoder.mapLikeObj \ ( ℝ2 x y ) ->
|
||||
JSON.Encoder.atKey' "x" encoder x
|
||||
. JSON.Encoder.atKey' "y" encoder y
|
||||
decoder = Point2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
|
||||
decoder = ℝ2 <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
|
||||
|
||||
instance Serialisable a => Serialisable ( Vector2D a ) where
|
||||
encoder = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) ->
|
||||
instance Serialisable ( T ( ℝ 2 ) ) where
|
||||
encoder = JSON.Encoder.mapLikeObj \ ( V2 x y ) ->
|
||||
JSON.Encoder.atKey' "x" encoder x
|
||||
. JSON.Encoder.atKey' "y" encoder y
|
||||
decoder = Vector2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
|
||||
decoder = V2 <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
|
||||
instance ( KnownSymbols ks, Representable ( ℝ ( Length ks ) ) ) => Serialisable ( Record ks ) where
|
||||
encoder = contramap encodeFields ( JSON.Encoder.keyValueTupleFoldable ( encoder @Double ) )
|
||||
where
|
||||
|
|
|
@ -62,7 +62,7 @@ import Math.Module
|
|||
import Math.Roots
|
||||
( realRoots, solveQuadratic )
|
||||
import Math.Linear
|
||||
( Point2D(..), Vector2D(..), T(..) )
|
||||
( ℝ(..), T(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
@ -138,12 +138,12 @@ squaredCurvature bez t
|
|||
sq_nm_g' = squaredNorm @v g'
|
||||
|
||||
-- | Signed curvature of a planar cubic Bézier curve.
|
||||
signedCurvature :: forall r. Floating r => Bezier ( Point2D r ) -> r -> r
|
||||
signedCurvature :: Bezier ( ℝ 2 ) -> Double -> Double
|
||||
signedCurvature bez t = ( g' `cross` g'' ) / norm g' ^ ( 3 :: Int )
|
||||
where
|
||||
g', g'' :: Vector2D r
|
||||
g' = bezier' @( Vector2D r ) bez t
|
||||
g'' = bezier'' @( Vector2D r ) bez t
|
||||
g', g'' :: T ( ℝ 2 )
|
||||
g' = bezier' @( T ( ℝ 2 ) ) bez t
|
||||
g'' = bezier'' @( T ( ℝ 2 ) ) bez t
|
||||
|
||||
-- | Subdivide a cubic Bézier curve into two parts.
|
||||
subdivide :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> ( Bezier p, Bezier p )
|
||||
|
@ -231,13 +231,13 @@ drag ( Bezier {..} ) t q = Bezier { p0, p1 = p1', p2 = p2', p3 }
|
|||
-- Formula taken from:
|
||||
-- "A Basis for the Implicit Representation of Planar Rational Cubic Bézier Curves"
|
||||
-- – Oliver J. D. Barrowclough, 2016
|
||||
selfIntersectionParameters :: forall r. RealFloat r => Bezier ( Point2D r ) -> [ r ]
|
||||
selfIntersectionParameters :: Bezier ( ℝ 2 ) -> [ Double ]
|
||||
selfIntersectionParameters ( Bezier {..} ) = solveQuadratic c0 c1 c2
|
||||
where
|
||||
areaConstant :: Point2D r -> Point2D r -> Point2D r -> r
|
||||
areaConstant ( Point2D x1 y1 ) ( Point2D x2 y2 ) ( Point2D x3 y3 ) =
|
||||
areaConstant :: ℝ 2 -> ℝ 2 -> ℝ 2 -> Double
|
||||
areaConstant ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) ( ℝ2 x3 y3 ) =
|
||||
x1 * ( y2 - y3 ) + x2 * ( y3 - y1 ) + x3 * ( y1 - y2 )
|
||||
l0, l1, l2, l3, f1, f2, f3, c0, c1, c2 :: r
|
||||
l0, l1, l2, l3, f1, f2, f3, c0, c1, c2 :: Double
|
||||
l0 = areaConstant p3 p2 p1
|
||||
l1 = areaConstant p2 p3 p0
|
||||
l2 = areaConstant p1 p0 p3
|
||||
|
|
|
@ -80,7 +80,7 @@ import Math.Module
|
|||
import Math.Roots
|
||||
( laguerre ) --, eval, derivative )
|
||||
import Math.Linear
|
||||
( Mat22(..), Point2D(..), Vector2D(..) )
|
||||
( Mat22(..), ℝ(..), T(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
@ -97,10 +97,10 @@ data FitParameters
|
|||
|
||||
data FitPoint
|
||||
= FitPoint
|
||||
{ fitPoint :: !( Point2D Double ) }
|
||||
{ fitPoint :: !( ℝ 2 ) }
|
||||
| FitTangent
|
||||
{ fitPoint :: !( Point2D Double )
|
||||
, fitTangent :: !( Vector2D Double )
|
||||
{ fitPoint :: !( ℝ 2 )
|
||||
, fitTangent :: !( T ( ℝ 2 ) )
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
@ -120,7 +120,7 @@ data FitPoint
|
|||
-- including the meaning of \( \texttt{t_tol} \) and \( \texttt{maxIters} \).
|
||||
fitSpline
|
||||
:: FitParameters
|
||||
-> ( Double -> ( Point2D Double, Vector2D Double ) ) -- ^ curve \( t \mapsto ( C(t), C'(t) ) \) to fit
|
||||
-> ( Double -> ( ℝ 2, T ( ℝ 2 ) ) ) -- ^ curve \( t \mapsto ( C(t), C'(t) ) \) to fit
|
||||
-> ( SplinePts Open, Seq FitPoint )
|
||||
fitSpline ( FitParameters {..} ) = go 0
|
||||
where
|
||||
|
@ -128,13 +128,13 @@ fitSpline ( FitParameters {..} ) = go 0
|
|||
dt = recip ( fromIntegral nbSegments )
|
||||
go
|
||||
:: Int
|
||||
-> ( Double -> ( Point2D Double, Vector2D Double ) )
|
||||
-> ( Double -> ( ℝ 2, T ( ℝ 2 ) ) )
|
||||
-> ( SplinePts Open, Seq FitPoint )
|
||||
go subdiv curveFn =
|
||||
let
|
||||
p, r :: Point2D Double
|
||||
tp, tr :: Vector2D Double
|
||||
qs :: [ Point2D Double ]
|
||||
p, r :: ℝ 2
|
||||
tp, tr :: T ( ℝ 2 )
|
||||
qs :: [ ℝ 2 ]
|
||||
(p, tp) = curveFn 0
|
||||
(r, tr) = curveFn 1
|
||||
qs = [ fst $ curveFn ( dt * fromIntegral j ) | j <- [ 1 .. nbSegments - 1 ] ]
|
||||
|
@ -187,15 +187,15 @@ fitSpline ( FitParameters {..} ) = go 0
|
|||
-- of its corresponding point to fit \( q_i \),
|
||||
-- * the maximum iteration limit \( \texttt{maxIters} \) has been reached.
|
||||
fitPiece
|
||||
:: Double -- ^ \( \texttt{dist_tol} \), tolerance for the distance
|
||||
-> Double -- ^ \( \texttt{t_tol} \), the tolerance for the Bézier parameter
|
||||
-> Int -- ^ \( \texttt{maxIters} \), maximum number of iterations
|
||||
-> Point2D Double -- ^ \( p \), start point
|
||||
-> Vector2D Double -- ^ \( \textrm{t}_p \), start tangent vector (length is ignored)
|
||||
-> [ Point2D Double ] -- ^ \( \left ( q_i \right )_{i=1}^n \), points to fit
|
||||
-> Point2D Double -- ^ \( r \), end point
|
||||
-> Vector2D Double -- ^ \( \textrm{t}_r \), end tangent vector (length is ignored)
|
||||
-> ( Cubic.Bezier ( Point2D Double ), ArgMax Double Double )
|
||||
:: Double -- ^ \( \texttt{dist_tol} \), tolerance for the distance
|
||||
-> Double -- ^ \( \texttt{t_tol} \), the tolerance for the Bézier parameter
|
||||
-> Int -- ^ \( \texttt{maxIters} \), maximum number of iterations
|
||||
-> ℝ 2 -- ^ \( p \), start point
|
||||
-> T ( ℝ 2 ) -- ^ \( \textrm{t}_p \), start tangent vector (length is ignored)
|
||||
-> [ ℝ 2 ] -- ^ \( \left ( q_i \right )_{i=1}^n \), points to fit
|
||||
-> ℝ 2 -- ^ \( r \), end point
|
||||
-> T ( ℝ 2 ) -- ^ \( \textrm{t}_r \), end tangent vector (length is ignored)
|
||||
-> ( Cubic.Bezier ( ℝ 2 ), ArgMax Double Double )
|
||||
fitPiece dist_tol t_tol maxIters p tp qs r tr =
|
||||
runST do
|
||||
-- Initialise the parameter values to a uniform subdivision.
|
||||
|
@ -207,25 +207,25 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr =
|
|||
uniform :: Int -> Double
|
||||
uniform i = fromIntegral ( i + 1 ) / fromIntegral ( n + 1 )
|
||||
|
||||
f0, f1, f2, f3 :: Double -> Vector2D Double
|
||||
f0, f1, f2, f3 :: Double -> T ( ℝ 2 )
|
||||
f0 t = h1 t *^ tp
|
||||
f1 t = h2 t *^ tr
|
||||
f2 t = h0 t *^ ( MkVector2D p )
|
||||
f3 t = h3 t *^ ( MkVector2D r )
|
||||
f2 t = h0 t *^ ( T p )
|
||||
f3 t = h3 t *^ ( T r )
|
||||
|
||||
loop :: forall s. Unboxed.MVector s Double -> Int -> ST s ( Cubic.Bezier ( Point2D Double ), ArgMax Double Double )
|
||||
loop :: forall s. Unboxed.MVector s Double -> Int -> ST s ( Cubic.Bezier ( ℝ 2 ), ArgMax Double Double )
|
||||
loop ts count = do
|
||||
let
|
||||
hermiteParameters :: Mat22 Double -> Vector2D Double -> Int -> [ Point2D Double ] -> ST s ( Vector2D Double )
|
||||
hermiteParameters ( Mat22 a11 a12 _ a22 ) ( Vector2D b1 b2 ) i ( q : rest ) = do
|
||||
hermiteParameters :: Mat22 -> T ( ℝ 2 ) -> Int -> [ ℝ 2 ] -> ST s ( T ( ℝ 2 ) )
|
||||
hermiteParameters ( Mat22 a11 a12 _ a22 ) ( V2 b1 b2 ) i ( q : rest ) = do
|
||||
ti <- Unboxed.MVector.unsafeRead ts i
|
||||
let
|
||||
f0i, f1i, f2i, f3i :: Vector2D Double
|
||||
f0i, f1i, f2i, f3i :: T ( ℝ 2 )
|
||||
f0i = f0 ti
|
||||
f1i = f1 ti
|
||||
f2i = f2 ti
|
||||
f3i = f3 ti
|
||||
q' = MkVector2D q ^-^ f2i ^-^ f3i
|
||||
q' = T q ^-^ f2i ^-^ f3i
|
||||
a11', a12', a21', a22', b1', b2' :: Double
|
||||
a11' = a11 + ( f0i ^.^ f0i )
|
||||
a12' = a12 + ( f1i ^.^ f0i )
|
||||
|
@ -233,18 +233,18 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr =
|
|||
a22' = a22 + ( f1i ^.^ f1i )
|
||||
b1' = b1 + ( q' ^.^ f0i )
|
||||
b2' = b2 + ( q' ^.^ f1i )
|
||||
hermiteParameters ( Mat22 a11' a12' a21' a22' ) ( Vector2D b1' b2' ) ( i + 1 ) rest
|
||||
hermiteParameters ( Mat22 a11' a12' a21' a22' ) ( V2 b1' b2' ) ( i + 1 ) rest
|
||||
hermiteParameters a b _ [] = pure ( linearSolve a b )
|
||||
|
||||
~(Vector2D s1 s2) <- hermiteParameters ( Mat22 0 0 0 0 ) ( Vector2D 0 0 ) 0 qs
|
||||
~(V2 s1 s2) <- hermiteParameters ( Mat22 0 0 0 0 ) ( V2 0 0 ) 0 qs
|
||||
|
||||
let
|
||||
-- Convert from Hermite form to Bézier form.
|
||||
cp1, cp2 :: Point2D Double
|
||||
cp1, cp2 :: ℝ 2
|
||||
cp1 = ( ( s1 / 3 ) *^ tp ) • p
|
||||
cp2 = ( ( -s2 / 3 ) *^ tr ) • r
|
||||
|
||||
bez :: Cubic.Bezier ( Point2D Double )
|
||||
bez :: Cubic.Bezier ( ℝ 2 )
|
||||
bez = Cubic.Bezier p cp1 cp2 r
|
||||
|
||||
-- Run one iteration of Laguerre's method to improve the parameter values t_i,
|
||||
|
@ -256,7 +256,7 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr =
|
|||
laguerreStepResult :: Complex Double
|
||||
laguerreStepResult = runST do
|
||||
coeffs <- unsafeThawPrimArray . primArrayFromListN 6
|
||||
$ Cubic.ddist @( Vector2D Double ) bez q
|
||||
$ Cubic.ddist @( T ( ℝ 2 ) ) bez q
|
||||
laguerre epsilon 1 coeffs ( ti :+ 0 )
|
||||
ti' <- case laguerreStepResult of
|
||||
x :+ y
|
||||
|
@ -272,7 +272,7 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr =
|
|||
$> ( min 1 $ max 0 x )
|
||||
let
|
||||
sq_dist :: Double
|
||||
sq_dist = quadrance @( Vector2D Double ) q ( Cubic.bezier @( Vector2D Double ) bez ti' )
|
||||
sq_dist = quadrance @( T ( ℝ 2 ) ) q ( Cubic.bezier @( T ( ℝ 2 ) ) bez ti' )
|
||||
modify' ( second ( <> Max ( Arg sq_dist ti' ) ) )
|
||||
lift ( Unboxed.MVector.unsafeWrite ts i ti' )
|
||||
|
||||
|
|
|
@ -1,612 +0,0 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
-- TODO: unused module.
|
||||
module Math.Bezier.Envelope where
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Torsor((-->)) )
|
||||
|
||||
-- deepseq
|
||||
import Control.DeepSeq
|
||||
( NFData )
|
||||
|
||||
-- primitive
|
||||
import Data.Primitive.Types
|
||||
( Prim )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Roots
|
||||
( realRoots )
|
||||
import qualified Math.Bezier.Cubic as Cubic
|
||||
( Bezier(..), bezier, bezier' )
|
||||
import qualified Math.Bezier.Quadratic as Quadratic
|
||||
( Bezier(..), bezier, bezier' )
|
||||
import Math.Module
|
||||
( Module((^+^),(*^)), lerp, cross )
|
||||
import Math.Linear
|
||||
( Point2D(..), Vector2D(..), Segment(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{-
|
||||
data StrokePolynomialData
|
||||
= StrokePolynomialData
|
||||
{ envelope :: !Poly
|
||||
, envelope' :: !Poly
|
||||
, tangent :: !( Poly, Poly )
|
||||
, type1Cusps :: [ ( Double, Double ) ]
|
||||
, type2Cusps :: [ ( Double, Double ) ]
|
||||
}
|
||||
deriving stock Show
|
||||
|
||||
validRoot :: Sized 2 ( Complex Double ) -> Maybe ( Double, Double )
|
||||
validRoot r
|
||||
| any isNaN [a,b,c,d]
|
||||
|| any isInfinite [a,b,c,d]
|
||||
|| any ( not . nearZero ) [b,d]
|
||||
|| any ( < 0 ) [ a, c ]
|
||||
|| any ( > 1 ) [ a, c ]
|
||||
= Nothing
|
||||
| otherwise
|
||||
= Just ( a, c )
|
||||
where
|
||||
a, b, c, d :: Double
|
||||
a :+ b = r %!! 0
|
||||
c :+ d = r %!! 1
|
||||
|
||||
{-
|
||||
:seti -XNegativeLiterals -XFlexibleInstances -XRebindableSyntax
|
||||
:m Math.Linear Math.Bezier.Envelope
|
||||
import qualified Math.Bezier.Cubic as Cubic
|
||||
import Prelude hiding ( fromInteger )
|
||||
import AlgebraicPrelude ( fromInteger )
|
||||
|
||||
:{
|
||||
let
|
||||
path :: Cubic.Bezier ( Point2D AlgebraicPrelude.Rational )
|
||||
path = Cubic.Bezier
|
||||
(Point2D p0_x p0_y) (Point2D p1_x p1_y) (Point2D p2_x p2_y) (Point2D p3_x p3_y)
|
||||
brush :: Cubic.Bezier ( Cubic.Bezier ( Point2D AlgebraicPrelude.Rational ) )
|
||||
brush = Cubic.Bezier
|
||||
( Cubic.Bezier (Point2D b00_x b00_y) (Point2D b01_x b01_y) (Point2D b02_x b02_y) (Point2D b03_x b03_y) )
|
||||
( Cubic.Bezier (Point2D b10_x b10_y) (Point2D b11_x b11_y) (Point2D b12_x b12_y) (Point2D b13_x b13_y) )
|
||||
( Cubic.Bezier (Point2D b20_x b20_y) (Point2D b21_x b21_y) (Point2D b22_x b22_y) (Point2D b23_x b23_y) )
|
||||
( Cubic.Bezier (Point2D b30_x b30_y) (Point2D b31_x b31_y) (Point2D b32_x b32_y) (Point2D b33_x b33_y) )
|
||||
:}
|
||||
|
||||
:{
|
||||
let
|
||||
path :: Cubic.Bezier ( Point2D AlgebraicPrelude.Rational )
|
||||
path = Cubic.Bezier
|
||||
(Point2D 0.5 0.5) (Point2D 0.5 4) (Point2D 1 4) (Point2D 6 2)
|
||||
brush :: Cubic.Bezier ( Cubic.Bezier ( Point2D AlgebraicPrelude.Rational ) )
|
||||
brush = Cubic.Bezier
|
||||
( Cubic.Bezier (Point2D 0 -0.5) (Point2D 1 1 ) (Point2D -1 1 ) (Point2D 0 -0.5) )
|
||||
( Cubic.Bezier (Point2D 0.5 -0.5) (Point2D 5 1 ) (Point2D -5 1 ) (Point2D 0 -0.5) )
|
||||
( Cubic.Bezier (Point2D 0 -0.5) (Point2D 1 1 ) (Point2D -1 1 ) (Point2D 0 -0.5) )
|
||||
( Cubic.Bezier (Point2D 1 -0.2) (Point2D -3 -0.8) (Point2D -1 -0.2) (Point2D 1 -0.2) )
|
||||
:}
|
||||
|
||||
strokePolynomialData33 path brush
|
||||
|
||||
-}
|
||||
|
||||
-- c(t,u) = p(t) + b(t,u) = ( x(t,u), y(t,u) )
|
||||
strokePolynomialData33
|
||||
:: Cubic.Bezier ( Point2D CA.Rational )
|
||||
-> Cubic.Bezier ( Cubic.Bezier ( Point2D CA.Rational ) )
|
||||
-> StrokePolynomialData
|
||||
strokePolynomialData33 ( Cubic.Bezier (Point2D p0_x p0_y) (Point2D p1_x p1_y) (Point2D p2_x p2_y) (Point2D p3_x p3_y) )
|
||||
( Cubic.Bezier
|
||||
( Cubic.Bezier (Point2D b00_x b00_y) (Point2D b01_x b01_y) (Point2D b02_x b02_y) (Point2D b03_x b03_y) )
|
||||
( Cubic.Bezier (Point2D b10_x b10_y) (Point2D b11_x b11_y) (Point2D b12_x b12_y) (Point2D b13_x b13_y) )
|
||||
( Cubic.Bezier (Point2D b20_x b20_y) (Point2D b21_x b21_y) (Point2D b22_x b22_y) (Point2D b23_x b23_y) )
|
||||
( Cubic.Bezier (Point2D b30_x b30_y) (Point2D b31_x b31_y) (Point2D b32_x b32_y) (Point2D b33_x b33_y) )
|
||||
) = StrokePolynomialData
|
||||
{ envelope
|
||||
, envelope' = pepu
|
||||
, tangent = ( dxdt, dydt )
|
||||
, type1Cusps = trace ( show "grobner = " <> show grobner ) [] --mapMaybe validRoot $ unsafePerformIO . evalRandIO $ CA.solveM ( CA.toIdeal [ envelope, pepu ] )
|
||||
, type2Cusps = [] --mapMaybe validRoot $ unsafePerformIO . evalRandIO $ CA.solveM ( CA.toIdeal [ dxdt, dydt ] )
|
||||
}
|
||||
where
|
||||
|
||||
grobner = CA.f4 ( CA.toIdeal [ envelope, dxdt, dydt ] )
|
||||
|
||||
-- Computation of ∂c/∂t: partial derivatives ∂x/∂t and ∂y/∂t.
|
||||
|
||||
t, u :: Poly
|
||||
t = CA.fromMonomial $ ( CA.varMonom ( Data.Type.Natural.sNat @2 ) 0 )
|
||||
u = CA.fromMonomial $ ( CA.varMonom ( Data.Type.Natural.sNat @2 ) 1 )
|
||||
|
||||
bez3Pol :: Poly -> Poly -> Poly -> Poly -> Poly -> Poly
|
||||
bez3Pol v a0 a1 a2 a3
|
||||
= a0 * ( 1 - v ) ^ ( 3 :: Int )
|
||||
+ 3 * a1 * v * ( 1 - v ) ^ ( 2 :: Int )
|
||||
+ 3 * a2 * ( 1 - v ) * v ^ ( 2 :: Int )
|
||||
+ a3 * v ^ ( 3 :: Int )
|
||||
|
||||
bez3'Pol :: Poly -> Poly -> Poly -> Poly -> Poly -> Poly
|
||||
bez3'Pol v a0 a1 a2 a3
|
||||
= 3 *
|
||||
( a1 - a0
|
||||
+ 2 * ( a0 + a2 - 2 * a1 ) * v
|
||||
+ ( a3 - 3 * a2 + 3 * a1 - a0 ) * v ^ ( 2 :: Int )
|
||||
)
|
||||
|
||||
f0_x, f1_x, f2_x, f3_x, f0_y, f1_y, f2_y, f3_y :: Poly
|
||||
f0_x = bez3'Pol t ( CA.injectCoeff b00_x ) ( CA.injectCoeff b10_x ) ( CA.injectCoeff b20_x ) ( CA.injectCoeff b30_x )
|
||||
f1_x = bez3'Pol t ( CA.injectCoeff b01_x ) ( CA.injectCoeff b11_x ) ( CA.injectCoeff b21_x ) ( CA.injectCoeff b31_x )
|
||||
f2_x = bez3'Pol t ( CA.injectCoeff b02_x ) ( CA.injectCoeff b12_x ) ( CA.injectCoeff b22_x ) ( CA.injectCoeff b32_x )
|
||||
f3_x = bez3'Pol t ( CA.injectCoeff b03_x ) ( CA.injectCoeff b13_x ) ( CA.injectCoeff b23_x ) ( CA.injectCoeff b33_x )
|
||||
f0_y = bez3'Pol t ( CA.injectCoeff b00_y ) ( CA.injectCoeff b10_y ) ( CA.injectCoeff b20_y ) ( CA.injectCoeff b30_y )
|
||||
f1_y = bez3'Pol t ( CA.injectCoeff b01_y ) ( CA.injectCoeff b11_y ) ( CA.injectCoeff b21_y ) ( CA.injectCoeff b31_y )
|
||||
f2_y = bez3'Pol t ( CA.injectCoeff b02_y ) ( CA.injectCoeff b12_y ) ( CA.injectCoeff b22_y ) ( CA.injectCoeff b32_y )
|
||||
f3_y = bez3'Pol t ( CA.injectCoeff b03_y ) ( CA.injectCoeff b13_y ) ( CA.injectCoeff b23_y ) ( CA.injectCoeff b33_y )
|
||||
|
||||
pxpt, pypt :: Poly
|
||||
pxpt = trace "pxpt = " . traceShowId $ bez3'Pol t ( CA.injectCoeff p0_x ) ( CA.injectCoeff p1_x ) ( CA.injectCoeff p2_x ) ( CA.injectCoeff p3_x ) + bez3Pol u f0_x f1_x f2_x f3_x
|
||||
pypt = trace "pypt = " . traceShowId $ bez3'Pol t ( CA.injectCoeff p0_y ) ( CA.injectCoeff p1_y ) ( CA.injectCoeff p2_y ) ( CA.injectCoeff p3_y ) + bez3Pol u f0_y f1_y f2_y f3_y
|
||||
|
||||
-- Computation of ∂c/∂u: partial derivatives ∂x/∂u and ∂y/∂u.
|
||||
|
||||
g0_x, g1_x, g2_x, g3_x, g0_y, g1_y, g2_y, g3_y :: Poly
|
||||
g0_x = bez3Pol t ( CA.injectCoeff b00_x ) ( CA.injectCoeff b10_x ) ( CA.injectCoeff b20_x ) ( CA.injectCoeff b30_x )
|
||||
g1_x = bez3Pol t ( CA.injectCoeff b01_x ) ( CA.injectCoeff b11_x ) ( CA.injectCoeff b21_x ) ( CA.injectCoeff b31_x )
|
||||
g2_x = bez3Pol t ( CA.injectCoeff b02_x ) ( CA.injectCoeff b12_x ) ( CA.injectCoeff b22_x ) ( CA.injectCoeff b32_x )
|
||||
g3_x = bez3Pol t ( CA.injectCoeff b03_x ) ( CA.injectCoeff b13_x ) ( CA.injectCoeff b23_x ) ( CA.injectCoeff b33_x )
|
||||
g0_y = bez3Pol t ( CA.injectCoeff b00_y ) ( CA.injectCoeff b10_y ) ( CA.injectCoeff b20_y ) ( CA.injectCoeff b30_y )
|
||||
g1_y = bez3Pol t ( CA.injectCoeff b01_y ) ( CA.injectCoeff b11_y ) ( CA.injectCoeff b21_y ) ( CA.injectCoeff b31_y )
|
||||
g2_y = bez3Pol t ( CA.injectCoeff b02_y ) ( CA.injectCoeff b12_y ) ( CA.injectCoeff b22_y ) ( CA.injectCoeff b32_y )
|
||||
g3_y = bez3Pol t ( CA.injectCoeff b03_y ) ( CA.injectCoeff b13_y ) ( CA.injectCoeff b23_y ) ( CA.injectCoeff b33_y )
|
||||
|
||||
pxpu, pypu :: Poly
|
||||
pxpu = bez3'Pol u g0_x g1_x g2_x g3_x
|
||||
pypu = bez3'Pol u g0_y g1_y g2_y g3_y
|
||||
|
||||
-- Envelope equation.
|
||||
envelope :: Poly
|
||||
envelope = pxpt * pypu - pypt * pxpu
|
||||
|
||||
-- Computation of total derivative dc/dt = ( dx/dt, dy/dt ).
|
||||
-- Rather, we are clearing denominators:
|
||||
-- dc/dt = ∂c/∂t + ∂c/∂u ∂u/dt
|
||||
-- ∂u/∂t = - ( ∂ envelope / ∂ t ) / ( ∂ envelope / ∂ u )
|
||||
--
|
||||
-- So we compute instead:
|
||||
-- ( ∂ envelope / ∂ u ) dc/dt = ( ∂ envelope / ∂ u ) ∂c/∂t - ( ∂ envelope / ∂ t ) ∂c/∂u.
|
||||
|
||||
pepu, pept :: Poly
|
||||
pept = CA.diff 0 envelope
|
||||
pepu = CA.diff 1 envelope
|
||||
|
||||
dxdt, dydt :: Poly
|
||||
dxdt = pxpt * pepu - pxpu * pept
|
||||
dydt = pypt * pepu - pypu * pept
|
||||
|
||||
-}
|
||||
-- | Find the roots of the envelope equation for a family of cubic Bézier curves
|
||||
-- varying along a cubic Bézier path.
|
||||
--
|
||||
-- \[ c(t,u) = p(t) + b(t,u), \]
|
||||
--
|
||||
-- where \( t \mapsto p(t) \) describes the underlying path,
|
||||
-- and \( u \mapsto b(t_0,u) \) describes the brush shape at point \( t = t_0 \).
|
||||
--
|
||||
-- The envelope equation is then:
|
||||
--
|
||||
-- \[ \frac{\partial c}{\partial t} \cross \frac{\partial c}{\partial u} = 0. \]
|
||||
--
|
||||
-- Given \( t_0 \), this function returns a (possibly empty) list of values \( u_i \)
|
||||
-- satisfying the envelope equation at \( (t_0, u_i) \).
|
||||
--
|
||||
-- The points \( c(t_0,u_i) \) are thus potential outline points on the contour stroked
|
||||
-- by the brush as it moves along the path.
|
||||
envelope33
|
||||
:: forall r
|
||||
. ( RealFloat r, Prim r, NFData r )
|
||||
=> Cubic.Bezier ( Point2D r ) -> Cubic.Bezier ( Cubic.Bezier ( Point2D r ) ) -> r -> [ r ]
|
||||
envelope33 path
|
||||
( Cubic.Bezier
|
||||
( Cubic.Bezier b00 b01 b02 b03 )
|
||||
( Cubic.Bezier b10 b11 b12 b13 )
|
||||
( Cubic.Bezier b20 b21 b22 b23 )
|
||||
( Cubic.Bezier b30 b31 b32 b33 )
|
||||
) t0 = realRoots 50 [ a5, a4, a3, a2, a1, a0 ]
|
||||
|
||||
where
|
||||
|
||||
-- Compute ∂p/∂t(t0).
|
||||
dpdt :: Vector2D r
|
||||
dpdt = Cubic.bezier' @( Vector2D r ) path t0
|
||||
|
||||
-- Compute ∂b/∂t(t0,u) using the Bernstein basis:
|
||||
--
|
||||
-- ∂b/∂t(t0,u) = Cubic.bezier ( Cubic.Bezier ct0 ct1 ct2 ct3 ) u.
|
||||
ct0, ct1, ct2, ct3, dt0, dt1, dt2, dt3 :: Vector2D r
|
||||
ct0 = Cubic.bezier' @( Vector2D r ) ( Cubic.Bezier b00 b10 b20 b30 ) t0
|
||||
ct1 = Cubic.bezier' @( Vector2D r ) ( Cubic.Bezier b01 b11 b21 b31 ) t0
|
||||
ct2 = Cubic.bezier' @( Vector2D r ) ( Cubic.Bezier b02 b12 b22 b32 ) t0
|
||||
ct3 = Cubic.bezier' @( Vector2D r ) ( Cubic.Bezier b03 b13 b23 b33 ) t0
|
||||
|
||||
-- Add ∂p/∂t and convert the Bernstein representation to the monomial basis to obtain
|
||||
--
|
||||
-- ∂c/∂t(t0,u) = dt0 + u dt1 + u² dt2 + u³ dt3.
|
||||
dt0 = ct0 ^+^ dpdt
|
||||
dt1 = 3 *^ ( ct0 --> ct1 )
|
||||
dt2 = 3 *^ ( ct1 --> ct0 ^+^ ct1 --> ct2 )
|
||||
dt3 = ct0 --> ct3 ^+^ 3 *^ ( ct2 --> ct1 )
|
||||
|
||||
-- Compute ∂c/∂u(t0,u) using the Bernstein basis:
|
||||
--
|
||||
-- ∂c/∂u(t0,u) = Cubic.bezier' ( Cubic.Bezier cu0 cu1 cu2 cu3 ) u.
|
||||
cu0, cu1, cu2, cu3 :: Point2D r
|
||||
cu0 = Cubic.bezier @( Vector2D r ) ( Cubic.Bezier b00 b10 b20 b30 ) t0
|
||||
cu1 = Cubic.bezier @( Vector2D r ) ( Cubic.Bezier b01 b11 b21 b31 ) t0
|
||||
cu2 = Cubic.bezier @( Vector2D r ) ( Cubic.Bezier b02 b12 b22 b32 ) t0
|
||||
cu3 = Cubic.bezier @( Vector2D r ) ( Cubic.Bezier b03 b13 b23 b33 ) t0
|
||||
|
||||
-- Convert the Bernstein representation to the monomial basis to obtain
|
||||
--
|
||||
-- ∂c/∂u(t0,u) = du0 + u du1 + u² du2.
|
||||
du0, du1, du2 :: Vector2D r
|
||||
du0 = cu0 --> cu1
|
||||
du1 = 2 *^ ( cu1 --> cu0 ^+^ cu1 --> cu2 )
|
||||
du2 = cu0 --> cu3 ^+^ 3 *^ ( cu2 --> cu1 )
|
||||
|
||||
-- Expand out the cross-product ∂c/∂t × ∂c/∂u to obtain the envelope equation:
|
||||
--
|
||||
-- a0 + a1 u + a2 u² + a3 u³ + a4 u⁴ + a5 u⁵.
|
||||
a0, a1, a2, a3, a4, a5 :: r
|
||||
a0 = dt0 `cross` du0
|
||||
a1 = dt1 `cross` du0 + dt0 `cross` du1
|
||||
a2 = dt2 `cross` du0 + dt1 `cross` du1 + dt0 `cross` du2
|
||||
a3 = dt3 `cross` du0 + dt2 `cross` du1 + dt1 `cross` du2
|
||||
a4 = dt3 `cross` du1 + dt2 `cross` du2
|
||||
a5 = dt3 `cross` du2
|
||||
|
||||
-- | Find the roots of the envelope equation for a family of cubic Bézier curves
|
||||
-- varying along a quadratic Bézier path.
|
||||
--
|
||||
-- See 'envelope33' for more information.
|
||||
envelope23
|
||||
:: forall r
|
||||
. ( RealFloat r, Prim r, NFData r )
|
||||
=> Quadratic.Bezier ( Point2D r ) -> Quadratic.Bezier ( Cubic.Bezier ( Point2D r ) ) -> r -> [ r ]
|
||||
envelope23 path
|
||||
( Quadratic.Bezier
|
||||
( Cubic.Bezier b00 b01 b02 b03 )
|
||||
( Cubic.Bezier b10 b11 b12 b13 )
|
||||
( Cubic.Bezier b20 b21 b22 b23 )
|
||||
) t0 = realRoots 50 [ a5, a4, a3, a2, a1, a0 ]
|
||||
|
||||
where
|
||||
|
||||
dpdt :: Vector2D r
|
||||
dpdt = Quadratic.bezier' @( Vector2D r ) path t0
|
||||
|
||||
ct0, ct1, ct2, ct3, dt0, dt1, dt2, dt3 :: Vector2D r
|
||||
ct0 = Quadratic.bezier' @( Vector2D r ) ( Quadratic.Bezier b00 b10 b20 ) t0
|
||||
ct1 = Quadratic.bezier' @( Vector2D r ) ( Quadratic.Bezier b01 b11 b21 ) t0
|
||||
ct2 = Quadratic.bezier' @( Vector2D r ) ( Quadratic.Bezier b02 b12 b22 ) t0
|
||||
ct3 = Quadratic.bezier' @( Vector2D r ) ( Quadratic.Bezier b03 b13 b23 ) t0
|
||||
|
||||
dt0 = ct0 ^+^ dpdt
|
||||
dt1 = 3 *^ ( ct0 --> ct1 )
|
||||
dt2 = 3 *^ ( ct1 --> ct0 ^+^ ct1 --> ct2 )
|
||||
dt3 = ct0 --> ct3 ^+^ 3 *^ ( ct2 --> ct1 )
|
||||
|
||||
cu0, cu1, cu2, cu3 :: Point2D r
|
||||
cu0 = Quadratic.bezier @( Vector2D r ) ( Quadratic.Bezier b00 b10 b20 ) t0
|
||||
cu1 = Quadratic.bezier @( Vector2D r ) ( Quadratic.Bezier b01 b11 b21 ) t0
|
||||
cu2 = Quadratic.bezier @( Vector2D r ) ( Quadratic.Bezier b02 b12 b22 ) t0
|
||||
cu3 = Quadratic.bezier @( Vector2D r ) ( Quadratic.Bezier b03 b13 b23 ) t0
|
||||
|
||||
du0, du1, du2 :: Vector2D r
|
||||
du0 = cu0 --> cu1
|
||||
du1 = 2 *^ ( cu1 --> cu0 ^+^ cu1 --> cu2 )
|
||||
du2 = cu0 --> cu3 ^+^ 3 *^ ( cu2 --> cu1 )
|
||||
|
||||
a0, a1, a2, a3, a4, a5 :: r
|
||||
a0 = dt0 `cross` du0
|
||||
a1 = dt1 `cross` du0 + dt0 `cross` du1
|
||||
a2 = dt2 `cross` du0 + dt1 `cross` du1 + dt0 `cross` du2
|
||||
a3 = dt3 `cross` du0 + dt2 `cross` du1 + dt1 `cross` du2
|
||||
a4 = dt3 `cross` du1 + dt2 `cross` du2
|
||||
a5 = dt3 `cross` du2
|
||||
|
||||
-- | Find the roots of the envelope equation for a family of cubic Bézier curves
|
||||
-- varying along a straight line path.
|
||||
--
|
||||
-- See 'envelope33' for more information.
|
||||
envelope13
|
||||
:: forall r
|
||||
. ( RealFloat r, Prim r, NFData r )
|
||||
=> Segment ( Point2D r ) -> Segment ( Cubic.Bezier ( Point2D r ) ) -> r -> [ r ]
|
||||
envelope13 ( Segment p0 p1 )
|
||||
( Segment
|
||||
( Cubic.Bezier b00 b01 b02 b03 )
|
||||
( Cubic.Bezier b10 b11 b12 b13 )
|
||||
) t0 = realRoots 50 [ a5, a4, a3, a2, a1, a0 ]
|
||||
|
||||
where
|
||||
|
||||
dpdt :: Vector2D r
|
||||
dpdt = p0 --> p1
|
||||
|
||||
ct0, ct1, ct2, ct3, dt0, dt1, dt2, dt3 :: Vector2D r
|
||||
ct0 = b00 --> b10
|
||||
ct1 = b01 --> b11
|
||||
ct2 = b02 --> b12
|
||||
ct3 = b03 --> b13
|
||||
|
||||
dt0 = ct0 ^+^ dpdt
|
||||
dt1 = 3 *^ ( ct0 --> ct1 )
|
||||
dt2 = 3 *^ ( ct1 --> ct0 ^+^ ct1 --> ct2 )
|
||||
dt3 = ct0 --> ct3 ^+^ 3 *^ ( ct2 --> ct1 )
|
||||
|
||||
cu0, cu1, cu2, cu3 :: Point2D r
|
||||
cu0 = lerp @( Vector2D r ) t0 b00 b10
|
||||
cu1 = lerp @( Vector2D r ) t0 b01 b11
|
||||
cu2 = lerp @( Vector2D r ) t0 b02 b12
|
||||
cu3 = lerp @( Vector2D r ) t0 b03 b13
|
||||
|
||||
du0, du1, du2 :: Vector2D r
|
||||
du0 = cu0 --> cu1
|
||||
du1 = 2 *^ ( cu1 --> cu0 ^+^ cu1 --> cu2 )
|
||||
du2 = cu0 --> cu3 ^+^ 3 *^ ( cu2 --> cu1 )
|
||||
|
||||
a0, a1, a2, a3, a4, a5 :: r
|
||||
a0 = dt0 `cross` du0
|
||||
a1 = dt1 `cross` du0 + dt0 `cross` du1
|
||||
a2 = dt2 `cross` du0 + dt1 `cross` du1 + dt0 `cross` du2
|
||||
a3 = dt3 `cross` du0 + dt2 `cross` du1 + dt1 `cross` du2
|
||||
a4 = dt3 `cross` du1 + dt2 `cross` du2
|
||||
a5 = dt3 `cross` du2
|
||||
|
||||
-- | Find the roots of the envelope equation for a family of quadratic Bézier curves
|
||||
-- varying along a cubic Bézier path.
|
||||
--
|
||||
-- See 'envelope33' for more information.
|
||||
envelope32
|
||||
:: forall r
|
||||
. ( RealFloat r, Prim r, NFData r )
|
||||
=> Cubic.Bezier ( Point2D r ) -> Cubic.Bezier ( Quadratic.Bezier ( Point2D r ) ) -> r -> [ r ]
|
||||
envelope32 path
|
||||
( Cubic.Bezier
|
||||
( Quadratic.Bezier b00 b01 b02 )
|
||||
( Quadratic.Bezier b10 b11 b12 )
|
||||
( Quadratic.Bezier b20 b21 b22 )
|
||||
( Quadratic.Bezier b30 b31 b32 )
|
||||
) t0 = realRoots 50 [ a3, a2, a1, a0 ]
|
||||
|
||||
where
|
||||
|
||||
dpdt :: Vector2D r
|
||||
dpdt = Cubic.bezier' @( Vector2D r ) path t0
|
||||
|
||||
ct0, ct1, ct2, dt0, dt1, dt2 :: Vector2D r
|
||||
ct0 = Cubic.bezier' @( Vector2D r ) ( Cubic.Bezier b00 b10 b20 b30 ) t0
|
||||
ct1 = Cubic.bezier' @( Vector2D r ) ( Cubic.Bezier b01 b11 b21 b31 ) t0
|
||||
ct2 = Cubic.bezier' @( Vector2D r ) ( Cubic.Bezier b02 b12 b22 b32 ) t0
|
||||
|
||||
dt0 = ct0 ^+^ dpdt
|
||||
dt1 = 2 *^ ( ct0 --> ct1 )
|
||||
dt2 = ct1 --> ct0 ^+^ ct1 --> ct2
|
||||
|
||||
cu0, cu1, cu2 :: Point2D r
|
||||
cu0 = Cubic.bezier @( Vector2D r ) ( Cubic.Bezier b00 b10 b20 b30 ) t0
|
||||
cu1 = Cubic.bezier @( Vector2D r ) ( Cubic.Bezier b01 b11 b21 b31 ) t0
|
||||
cu2 = Cubic.bezier @( Vector2D r ) ( Cubic.Bezier b02 b12 b22 b32 ) t0
|
||||
|
||||
du0, du1 :: Vector2D r
|
||||
du0 = cu0 --> cu1
|
||||
du1 = cu1 --> cu0 ^+^ cu1 --> cu2
|
||||
|
||||
a0, a1, a2, a3 :: r
|
||||
a0 = dt0 `cross` du0
|
||||
a1 = dt1 `cross` du0 + dt0 `cross` du1
|
||||
a2 = dt2 `cross` du0 + dt1 `cross` du1
|
||||
a3 = dt2 `cross` du1
|
||||
|
||||
-- | Find the roots of the envelope equation for a family of quadratic Bézier curves
|
||||
-- varying along a quadratic Bézier path.
|
||||
--
|
||||
-- See 'envelope33' for more information.
|
||||
envelope22
|
||||
:: forall r
|
||||
. ( RealFloat r, Prim r, NFData r )
|
||||
=> Quadratic.Bezier ( Point2D r ) -> Quadratic.Bezier ( Quadratic.Bezier ( Point2D r ) ) -> r -> [ r ]
|
||||
envelope22 path
|
||||
( Quadratic.Bezier
|
||||
( Quadratic.Bezier b00 b01 b02 )
|
||||
( Quadratic.Bezier b10 b11 b12 )
|
||||
( Quadratic.Bezier b20 b21 b22 )
|
||||
) t0 = realRoots 50 [ a3, a2, a1, a0 ]
|
||||
|
||||
where
|
||||
|
||||
dpdt :: Vector2D r
|
||||
dpdt = Quadratic.bezier' @( Vector2D r ) path t0
|
||||
|
||||
ct0, ct1, ct2, dt0, dt1, dt2 :: Vector2D r
|
||||
ct0 = Quadratic.bezier' @( Vector2D r ) ( Quadratic.Bezier b00 b10 b20 ) t0
|
||||
ct1 = Quadratic.bezier' @( Vector2D r ) ( Quadratic.Bezier b01 b11 b21 ) t0
|
||||
ct2 = Quadratic.bezier' @( Vector2D r ) ( Quadratic.Bezier b02 b12 b22 ) t0
|
||||
|
||||
dt0 = ct0 ^+^ dpdt
|
||||
dt1 = 2 *^ ( ct0 --> ct1 )
|
||||
dt2 = ct1 --> ct0 ^+^ ct1 --> ct2
|
||||
|
||||
cu0, cu1, cu2 :: Point2D r
|
||||
cu0 = Quadratic.bezier @( Vector2D r ) ( Quadratic.Bezier b00 b10 b20 ) t0
|
||||
cu1 = Quadratic.bezier @( Vector2D r ) ( Quadratic.Bezier b01 b11 b21 ) t0
|
||||
cu2 = Quadratic.bezier @( Vector2D r ) ( Quadratic.Bezier b02 b12 b22 ) t0
|
||||
|
||||
du0, du1 :: Vector2D r
|
||||
du0 = cu0 --> cu1
|
||||
du1 = cu1 --> cu0 ^+^ cu1 --> cu2
|
||||
|
||||
a0, a1, a2, a3 :: r
|
||||
a0 = dt0 `cross` du0
|
||||
a1 = dt1 `cross` du0 + dt0 `cross` du1
|
||||
a2 = dt2 `cross` du0 + dt1 `cross` du1
|
||||
a3 = dt2 `cross` du1
|
||||
|
||||
-- | Find the roots of the envelope equation for a family of quadratic Bézier curves
|
||||
-- varying along a straight line.
|
||||
--
|
||||
-- See 'envelope33' for more information.
|
||||
envelope12
|
||||
:: forall r
|
||||
. ( RealFloat r, Prim r, NFData r )
|
||||
=> Segment ( Point2D r ) -> Segment ( Quadratic.Bezier ( Point2D r ) ) -> r -> [ r ]
|
||||
envelope12 ( Segment p0 p1 )
|
||||
( Segment
|
||||
( Quadratic.Bezier b00 b01 b02 )
|
||||
( Quadratic.Bezier b10 b11 b12 )
|
||||
) t0 = realRoots 50 [ a3, a2, a1, a0 ]
|
||||
|
||||
where
|
||||
|
||||
dpdt :: Vector2D r
|
||||
dpdt = p0 --> p1
|
||||
|
||||
ct0, ct1, ct2, dt0, dt1, dt2 :: Vector2D r
|
||||
ct0 = b00 --> b10
|
||||
ct1 = b01 --> b11
|
||||
ct2 = b02 --> b12
|
||||
|
||||
dt0 = ct0 ^+^ dpdt
|
||||
dt1 = 2 *^ ( ct0 --> ct1 )
|
||||
dt2 = ct1 --> ct0 ^+^ ct1 --> ct2
|
||||
|
||||
cu0, cu1, cu2 :: Point2D r
|
||||
cu0 = lerp @( Vector2D r ) t0 b00 b10
|
||||
cu1 = lerp @( Vector2D r ) t0 b01 b11
|
||||
cu2 = lerp @( Vector2D r ) t0 b02 b12
|
||||
|
||||
du0, du1 :: Vector2D r
|
||||
du0 = cu0 --> cu1
|
||||
du1 = cu1 --> cu0 ^+^ cu1 --> cu2
|
||||
|
||||
a0, a1, a2, a3 :: r
|
||||
a0 = dt0 `cross` du0
|
||||
a1 = dt1 `cross` du0 + dt0 `cross` du1
|
||||
a2 = dt2 `cross` du0 + dt1 `cross` du1
|
||||
a3 = dt2 `cross` du1
|
||||
|
||||
-- | Find the roots of the envelope equation for a family of line segments
|
||||
-- varying along a cubic Bézier curve.
|
||||
--
|
||||
-- See 'envelope33' for more information.
|
||||
envelope31
|
||||
:: forall r
|
||||
. ( RealFloat r, Prim r, NFData r )
|
||||
=> Cubic.Bezier ( Point2D r ) -> Cubic.Bezier ( Segment ( Point2D r ) ) -> r -> [ r ]
|
||||
envelope31 path
|
||||
( Cubic.Bezier
|
||||
( Segment b00 b01 )
|
||||
( Segment b10 b11 )
|
||||
( Segment b20 b21 )
|
||||
( Segment b30 b31 )
|
||||
) t0 = [ -a1 / a0 ]
|
||||
|
||||
where
|
||||
|
||||
dpdt :: Vector2D r
|
||||
dpdt = Cubic.bezier' @( Vector2D r ) path t0
|
||||
|
||||
ct0, ct1, dt0, dt1 :: Vector2D r
|
||||
ct0 = Cubic.bezier' @( Vector2D r ) ( Cubic.Bezier b00 b10 b20 b30 ) t0
|
||||
ct1 = Cubic.bezier' @( Vector2D r ) ( Cubic.Bezier b01 b11 b21 b31 ) t0
|
||||
|
||||
dt0 = ct0 ^+^ dpdt
|
||||
dt1 = ct0 --> ct1
|
||||
|
||||
cu0, cu1 :: Point2D r
|
||||
cu0 = Cubic.bezier @( Vector2D r ) ( Cubic.Bezier b00 b10 b20 b30 ) t0
|
||||
cu1 = Cubic.bezier @( Vector2D r ) ( Cubic.Bezier b01 b11 b21 b31 ) t0
|
||||
|
||||
du0 :: Vector2D r
|
||||
du0 = cu0 --> cu1
|
||||
|
||||
a0, a1 :: r
|
||||
a0 = dt0 `cross` du0
|
||||
a1 = dt1 `cross` du0
|
||||
|
||||
-- | Find the roots of the envelope equation for a family of line segments
|
||||
-- varying along a quadratic Bézier curve.
|
||||
--
|
||||
-- See 'envelope33' for more information.
|
||||
envelope21
|
||||
:: forall r
|
||||
. ( RealFloat r, Prim r, NFData r )
|
||||
=> Quadratic.Bezier ( Point2D r ) -> Quadratic.Bezier ( Segment ( Point2D r ) ) -> r -> [ r ]
|
||||
envelope21 path
|
||||
( Quadratic.Bezier
|
||||
( Segment b00 b01 )
|
||||
( Segment b10 b11 )
|
||||
( Segment b20 b21 )
|
||||
) t0 = [ -a1 / a0 ]
|
||||
|
||||
where
|
||||
|
||||
dpdt :: Vector2D r
|
||||
dpdt = Quadratic.bezier' @( Vector2D r ) path t0
|
||||
|
||||
ct0, ct1, dt0, dt1 :: Vector2D r
|
||||
ct0 = Quadratic.bezier' @( Vector2D r ) ( Quadratic.Bezier b00 b10 b20 ) t0
|
||||
ct1 = Quadratic.bezier' @( Vector2D r ) ( Quadratic.Bezier b01 b11 b21 ) t0
|
||||
|
||||
dt0 = ct0 ^+^ dpdt
|
||||
dt1 = ct0 --> ct1
|
||||
|
||||
cu0, cu1 :: Point2D r
|
||||
cu0 = Quadratic.bezier @( Vector2D r ) ( Quadratic.Bezier b00 b10 b20 ) t0
|
||||
cu1 = Quadratic.bezier @( Vector2D r ) ( Quadratic.Bezier b01 b11 b21 ) t0
|
||||
|
||||
du0 :: Vector2D r
|
||||
du0 = cu0 --> cu1
|
||||
|
||||
a0, a1 :: r
|
||||
a0 = dt0 `cross` du0
|
||||
a1 = dt1 `cross` du0
|
||||
|
||||
-- | Find the roots of the envelope equation for a family of line segments
|
||||
-- varying along a straight line path.
|
||||
--
|
||||
-- See 'envelope33' for more information.
|
||||
envelope11
|
||||
:: forall r
|
||||
. ( RealFloat r, Prim r, NFData r )
|
||||
=> Segment ( Point2D r ) -> Segment ( Segment ( Point2D r ) ) -> r -> [ r ]
|
||||
envelope11 ( Segment p0 p1 )
|
||||
( Segment
|
||||
( Segment b00 b01 )
|
||||
( Segment b10 b11 )
|
||||
) t0 = [ -a1 / a0 ]
|
||||
|
||||
where
|
||||
|
||||
dpdt :: Vector2D r
|
||||
dpdt = p0 --> p1
|
||||
|
||||
ct0, ct1, dt0, dt1 :: Vector2D r
|
||||
ct0 = b00 --> b10
|
||||
ct1 = b01 --> b11
|
||||
|
||||
dt0 = ct0 ^+^ dpdt
|
||||
dt1 = ct0 --> ct1
|
||||
|
||||
cu0, cu1 :: Point2D r
|
||||
cu0 = lerp @( Vector2D r ) t0 b00 b10
|
||||
cu1 = lerp @( Vector2D r ) t0 b01 b11
|
||||
|
||||
du0 :: Vector2D r
|
||||
du0 = cu0 --> cu1
|
||||
|
||||
a0, a1 :: r
|
||||
a0 = dt0 `cross` du0
|
||||
a1 = dt1 `cross` du0
|
|
@ -59,7 +59,7 @@ import Math.Module
|
|||
import Math.Roots
|
||||
( realRoots )
|
||||
import Math.Linear
|
||||
( Point2D(..), Vector2D(..), T(..) )
|
||||
( ℝ(..), T(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
@ -117,12 +117,12 @@ squaredCurvature bez t
|
|||
sq_nm_g' = squaredNorm @v g'
|
||||
|
||||
-- | Signed curvature of a planar quadratic Bézier curve.
|
||||
signedCurvature :: forall r. Floating r => Bezier ( Point2D r ) -> r -> r
|
||||
signedCurvature :: Bezier ( ℝ 2 ) -> Double -> Double
|
||||
signedCurvature bez t = ( g' `cross` g'' ) / norm g' ^ ( 3 :: Int )
|
||||
where
|
||||
g', g'' :: Vector2D r
|
||||
g' = bezier' @( Vector2D r ) bez t
|
||||
g'' = bezier'' @( Vector2D r ) bez
|
||||
g', g'' :: T ( ℝ 2 )
|
||||
g' = bezier' @( T ( ℝ 2 ) ) bez t
|
||||
g'' = bezier'' @( T ( ℝ 2 ) ) bez
|
||||
|
||||
-- | Subdivide a quadratic Bézier curve into two parts.
|
||||
subdivide :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> ( Bezier p, Bezier p )
|
||||
|
|
|
@ -56,7 +56,7 @@ import Control.Monad.Trans.State.Strict
|
|||
import qualified Math.Bezier.Cubic as Cubic
|
||||
( Bezier(..) )
|
||||
import Math.Linear
|
||||
( Point2D )
|
||||
( ℝ(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
@ -215,8 +215,7 @@ instance KnownSplineType clo => Bifoldable ( Spline clo ) where
|
|||
instance KnownSplineType clo => Bitraversable ( Spline clo ) where
|
||||
bitraverse fc fp = bitraverseSpline ( const $ bitraverse fc fp ) fp
|
||||
|
||||
type SplinePts clo = Spline clo () ( Point2D Double )
|
||||
|
||||
type SplinePts clo = Spline clo () ( ℝ 2 )
|
||||
|
||||
bimapCurve
|
||||
:: Functor ( NextPoint clo )
|
||||
|
|
|
@ -120,7 +120,7 @@ data Offset
|
|||
= Offset
|
||||
{ offsetIndex :: !Int
|
||||
, offsetParameter :: !( Maybe Double )
|
||||
, offset :: !( Vector2D Double )
|
||||
, offset :: !( T ( ℝ 2 ) )
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
deriving anyclass NFData
|
||||
|
@ -143,7 +143,7 @@ instance Monoid OutlineData where
|
|||
mempty = TwoSided empt empt
|
||||
where
|
||||
empt :: ( SplinePts Open, Seq FitPoint )
|
||||
empt = ( Spline { splineStart = Point2D 0 0, splineCurves = OpenCurves Empty }, Empty )
|
||||
empt = ( Spline { splineStart = ℝ2 0 0, splineCurves = OpenCurves Empty }, Empty )
|
||||
|
||||
newtype CachedStroke s = CachedStroke { cachedStrokeRef :: STRef s ( Maybe OutlineData ) }
|
||||
instance Show ( CachedStroke s ) where
|
||||
|
@ -163,7 +163,7 @@ invalidateCache = runRW# \ s ->
|
|||
set ( typed @( CachedStroke RealWorld ) )
|
||||
( CachedStroke $ STRef mutVar )
|
||||
|
||||
coords :: forall ptData. HasType ( Point2D Double ) ptData => ptData -> Point2D Double
|
||||
coords :: forall ptData. HasType ( ℝ 2 ) ptData => ptData -> ℝ 2
|
||||
coords = view typed
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
@ -174,7 +174,7 @@ computeStrokeOutline ::
|
|||
, Group diffParams
|
||||
, Module Double diffParams
|
||||
, Torsor diffParams brushParams
|
||||
, HasType ( Point2D Double ) ptData
|
||||
, HasType ( ℝ 2 ) ptData
|
||||
, HasType ( CachedStroke s ) crvData
|
||||
, NFData ptData, NFData crvData
|
||||
-- Debugging.
|
||||
|
@ -199,7 +199,7 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
|||
, let
|
||||
endPt :: ptData
|
||||
endPt = openCurveEnd lastCurve
|
||||
startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: Vector2D Double
|
||||
startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: T ( ℝ 2 )
|
||||
startTgtFwd = snd ( firstOutlineFwd 0 )
|
||||
startTgtBwd = -1 *^ snd ( firstOutlineBwd 1 )
|
||||
endTgtFwd = snd ( lastOutlineFwd 1 )
|
||||
|
@ -209,36 +209,36 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
|||
endBrush = brushShape endPt
|
||||
|
||||
-- Computation of which brush segment to use for the end caps.
|
||||
startTgt, endTgt :: Vector2D Double
|
||||
startTgt, endTgt :: T ( ℝ 2 )
|
||||
startTgt = coords spt0 --> coords ( openCurveStart firstCurve )
|
||||
endTgt = case prevCurves of
|
||||
Empty -> endTangent spt0 spt0 lastCurve
|
||||
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
|
||||
startTestTgt, endTestTgt :: Vector2D Double
|
||||
startTestTgt = Vector2D sty -stx
|
||||
startTestTgt, endTestTgt :: T ( ℝ 2 )
|
||||
startTestTgt = V2 sty -stx
|
||||
where
|
||||
stx, sty :: Double
|
||||
Vector2D stx sty = startTgt
|
||||
endTestTgt = Vector2D ety -etx
|
||||
V2 stx sty = startTgt
|
||||
endTestTgt = V2 ety -etx
|
||||
where
|
||||
etx, ety :: Double
|
||||
Vector2D etx ety = endTgt
|
||||
V2 etx ety = endTgt
|
||||
|
||||
startCap, endCap :: SplinePts Open
|
||||
startCap
|
||||
| isJust $ between CCW startTgtBwd startTgtFwd startTestTgt
|
||||
= fmap ( MkVector2D ( coords spt0 ) • )
|
||||
= fmap ( T ( coords spt0 ) • )
|
||||
$ joinWithBrush startBrush startTgtBwd startTgtFwd
|
||||
| otherwise
|
||||
= fmap ( MkVector2D ( coords spt0 ) • )
|
||||
= fmap ( T ( coords spt0 ) • )
|
||||
. reverseSpline
|
||||
$ joinWithBrush startBrush startTgtFwd startTgtBwd
|
||||
endCap
|
||||
| isJust $ between CCW endTgtBwd endTgtFwd endTestTgt
|
||||
= fmap ( MkVector2D ( coords endPt ) • )
|
||||
= fmap ( T ( coords endPt ) • )
|
||||
$ joinWithBrush endBrush endTgtFwd endTgtBwd
|
||||
| otherwise
|
||||
= fmap ( MkVector2D ( coords endPt ) • )
|
||||
= fmap ( T ( coords endPt ) • )
|
||||
. reverseSpline
|
||||
$ joinWithBrush endBrush endTgtBwd endTgtFwd
|
||||
|
||||
|
@ -255,7 +255,7 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
|||
, ( firstOutlineFwd, firstOutlineBwd ) :<| _ <- outlineFns
|
||||
, _ :|> ( lastOutlineFwd, lastOutlineBwd ) <- outlineFns
|
||||
, let
|
||||
startTgt, endTgt, startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: Vector2D Double
|
||||
startTgt, endTgt, startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: T ( ℝ 2 )
|
||||
startTgt = case prevCurves of
|
||||
Empty -> startTangent spt0 spt0 lastCurve
|
||||
firstCrv :<| _ -> startTangent spt0 spt0 firstCrv
|
||||
|
@ -279,15 +279,15 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
|||
-- Single point.
|
||||
_ ->
|
||||
pure
|
||||
( Left $ fmap ( MkVector2D ( coords spt0 ) • ) ( brushShape spt0 )
|
||||
( Left $ fmap ( T ( coords spt0 ) • ) ( brushShape spt0 )
|
||||
, Empty
|
||||
)
|
||||
where
|
||||
|
||||
outlineFns
|
||||
:: Seq
|
||||
( Double -> ( Point2D Double, Vector2D Double )
|
||||
, Double -> ( Point2D Double, Vector2D Double )
|
||||
( Double -> ( ℝ 2, T ( ℝ 2 ) )
|
||||
, Double -> ( ℝ 2, T ( ℝ 2 ) )
|
||||
)
|
||||
outlineFns = go spt0 ( openCurves $ splineCurves ( adjustSplineType @Open spline ) )
|
||||
where
|
||||
|
@ -295,8 +295,8 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
|||
:: ptData
|
||||
-> Seq ( Curve Open crvData ptData )
|
||||
-> Seq
|
||||
( Double -> ( Point2D Double, Vector2D Double )
|
||||
, Double -> ( Point2D Double, Vector2D Double )
|
||||
( Double -> ( ℝ 2, T ( ℝ 2 ) )
|
||||
, Double -> ( ℝ 2, T ( ℝ 2 ) )
|
||||
)
|
||||
go _ Empty = Empty
|
||||
go p0 ( crv :<| crvs ) =
|
||||
|
@ -305,7 +305,7 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
|||
brushShape :: ptData -> SplinePts Closed
|
||||
brushShape pt = brushFn ( ptParams pt )
|
||||
|
||||
updateSpline :: ( Vector2D Double, Vector2D Double, Vector2D Double ) -> ST s OutlineData
|
||||
updateSpline :: ( T ( ℝ 2 ), T ( ℝ 2 ), T ( ℝ 2 ) ) -> ST s OutlineData
|
||||
updateSpline ( lastTgt, lastTgtFwd, lastTgtBwd )
|
||||
= execWriterT
|
||||
. ( `evalStateT` ( lastTgt, lastTgtFwd, lastTgtBwd ) )
|
||||
|
@ -313,9 +313,9 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
|||
( \ ptData curve -> do
|
||||
( prevTgt, prev_tgtFwd, prev_tgtBwd ) <- get
|
||||
let
|
||||
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
|
||||
fwd, bwd :: Double -> ( ℝ 2, T ( ℝ 2 ) )
|
||||
( fwd, bwd ) = outlineFunctions @diffParams ptParams brushFn ptData curve
|
||||
tgt, next_tgt, tgtFwd, next_tgtFwd, tgtBwd, next_tgtBwd :: Vector2D Double
|
||||
tgt, next_tgt, tgtFwd, next_tgtFwd, tgtBwd, next_tgtBwd :: T ( ℝ 2 )
|
||||
tgt = startTangent spt0 ptData curve
|
||||
next_tgt = endTangent spt0 ptData curve
|
||||
tgtFwd = snd ( fwd 0 )
|
||||
|
@ -331,8 +331,8 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
|||
|
||||
updateCurveData
|
||||
:: crvData
|
||||
-> ( Double -> ( Point2D Double, Vector2D Double ) )
|
||||
-> ( Double -> ( Point2D Double, Vector2D Double ) )
|
||||
-> ( Double -> ( ℝ 2, T ( ℝ 2 ) ) )
|
||||
-> ( Double -> ( ℝ 2, T ( ℝ 2 ) ) )
|
||||
-> WriterT OutlineData ( ST s ) ()
|
||||
updateCurveData ( view ( typed @( CachedStroke s ) ) -> CachedStroke { cachedStrokeRef } ) fwd bwd = do
|
||||
mbOutline <- lift ( readSTRef cachedStrokeRef )
|
||||
|
@ -358,21 +358,21 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
|||
-- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction).
|
||||
tellBrushJoin
|
||||
:: Monad m
|
||||
=> ( Vector2D Double, Vector2D Double, Vector2D Double )
|
||||
=> ( T ( ℝ 2 ), T ( ℝ 2 ), T ( ℝ 2 ) )
|
||||
-> ptData
|
||||
-> ( Vector2D Double, Vector2D Double, Vector2D Double )
|
||||
-> ( T ( ℝ 2 ), T ( ℝ 2 ), T ( ℝ 2 ) )
|
||||
-> WriterT OutlineData m ()
|
||||
tellBrushJoin ( prevTgt, prevTgtFwd, prevTgtBwd ) sp0 ( tgt, tgtFwd, tgtBwd ) =
|
||||
tell $ TwoSided ( fwdJoin, Empty ) ( bwdJoin, Empty )
|
||||
where
|
||||
ptOffset :: Vector2D Double
|
||||
ptOffset = Point2D 0 0 --> coords sp0
|
||||
ptOffset :: T ( ℝ 2 )
|
||||
ptOffset = ℝ2 0 0 --> coords sp0
|
||||
brush0 :: SplinePts Closed
|
||||
brush0 = brushShape sp0
|
||||
|
||||
-- Figure out which part of the brush to use for the join.
|
||||
ori :: Orientation
|
||||
ori = splineOrientation @Double brush0
|
||||
ori = splineOrientation brush0
|
||||
fwdCond, bwdCond :: Bool
|
||||
( fwdCond, bwdCond )
|
||||
| prevTgt `cross` tgt < 0 && prevTgt ^.^ tgt < 0
|
||||
|
@ -383,11 +383,11 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
|
|||
= ( not . isJust $ between ori prevTgtFwd tgtFwd testTgt2
|
||||
, not . isJust $ between ori prevTgtBwd tgtBwd ( -1 *^ testTgt2 )
|
||||
)
|
||||
testTgt1, testTgt2 :: Vector2D Double
|
||||
testTgt1 = Vector2D -ty tx
|
||||
testTgt1, testTgt2 :: T ( ℝ 2 )
|
||||
testTgt1 = V2 -ty tx
|
||||
where
|
||||
tx, ty :: Double
|
||||
Vector2D tx ty = tgt ^-^ prevTgt
|
||||
V2 tx ty = tgt ^-^ prevTgt
|
||||
testTgt2
|
||||
| prevTgt ^.^ tgt < 0
|
||||
= testTgt1
|
||||
|
@ -420,7 +420,7 @@ outlineFunctions
|
|||
:: forall diffParams brushParams crvData ptData
|
||||
. ( Group diffParams, Module Double diffParams
|
||||
, Torsor diffParams brushParams
|
||||
, HasType ( Point2D Double ) ptData
|
||||
, HasType ( ℝ 2 ) ptData
|
||||
-- Debugging.
|
||||
, Show ptData
|
||||
)
|
||||
|
@ -428,68 +428,68 @@ outlineFunctions
|
|||
-> ( brushParams -> SplinePts Closed )
|
||||
-> ptData
|
||||
-> Curve Open crvData ptData
|
||||
-> ( Double -> ( Point2D Double, Vector2D Double )
|
||||
, Double -> ( Point2D Double, Vector2D Double )
|
||||
-> ( Double -> ( ℝ 2, T ( ℝ 2 ) )
|
||||
, Double -> ( ℝ 2, T ( ℝ 2 ) )
|
||||
)
|
||||
outlineFunctions ptParams brushFn sp0 crv =
|
||||
let
|
||||
p0 :: Point2D Double
|
||||
p0 :: ℝ 2
|
||||
p0 = coords sp0
|
||||
brush :: Double -> SplinePts Closed
|
||||
f :: Double -> Point2D Double
|
||||
f' :: Double -> Vector2D Double
|
||||
f :: Double -> ℝ 2
|
||||
f' :: Double -> T ( ℝ 2 )
|
||||
( brush, f, f' ) = case crv of
|
||||
LineTo { curveEnd = NextPoint sp1 }
|
||||
| let
|
||||
p1 :: Point2D Double
|
||||
p1 :: ℝ 2
|
||||
p1 = coords sp1
|
||||
tgt :: Vector2D Double
|
||||
tgt :: T ( ℝ 2 )
|
||||
tgt = p0 --> p1
|
||||
brush1 :: Double -> SplinePts Closed
|
||||
brush1 t = brushFn ( lerp @diffParams t ( ptParams sp0 ) ( ptParams sp1 ) )
|
||||
-> ( brush1, \ t -> lerp @( Vector2D Double ) t p0 p1, const tgt )
|
||||
-> ( brush1, \ t -> lerp @( T ( ℝ 2 ) ) t p0 p1, const tgt )
|
||||
Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2 }
|
||||
| let
|
||||
p1, p2 :: Point2D Double
|
||||
p1, p2 :: ℝ 2
|
||||
p1 = coords sp1
|
||||
p2 = coords sp2
|
||||
bez :: Quadratic.Bezier ( Point2D Double )
|
||||
bez :: Quadratic.Bezier ( ℝ 2 )
|
||||
bez = Quadratic.Bezier {..}
|
||||
brush2 :: Double -> SplinePts Closed
|
||||
brush2 t =
|
||||
brushFn $
|
||||
Quadratic.bezier @diffParams
|
||||
( Quadratic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ) t
|
||||
-> ( brush2, Quadratic.bezier @( Vector2D Double ) bez, Quadratic.bezier' bez )
|
||||
-> ( brush2, Quadratic.bezier @( T ( ℝ 2 ) ) bez, Quadratic.bezier' bez )
|
||||
Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3 }
|
||||
| let
|
||||
p1, p2, p3 :: Point2D Double
|
||||
p1, p2, p3 :: ℝ 2
|
||||
p1 = coords sp1
|
||||
p2 = coords sp2
|
||||
p3 = coords sp3
|
||||
bez :: Cubic.Bezier ( Point2D Double )
|
||||
bez :: Cubic.Bezier ( ℝ 2 )
|
||||
bez = Cubic.Bezier {..}
|
||||
brush3 :: Double -> SplinePts Closed
|
||||
brush3 t =
|
||||
brushFn $
|
||||
Cubic.bezier @diffParams
|
||||
( Cubic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ( ptParams sp3 ) ) t
|
||||
-> ( brush3, Cubic.bezier @( Vector2D Double ) bez, Cubic.bezier' bez )
|
||||
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
|
||||
-> ( brush3, Cubic.bezier @( T ( ℝ 2 ) ) bez, Cubic.bezier' bez )
|
||||
fwd, bwd :: Double -> ( ℝ 2, T ( ℝ 2 ) )
|
||||
fwd t
|
||||
= ( off t --offset ( withTangent ( fwd' t ) ( brush t ) ) • f t
|
||||
, fwd' t
|
||||
)
|
||||
where
|
||||
off :: Double -> Point2D Double
|
||||
off :: Double -> ℝ 2
|
||||
off u = offset ( withTangent ( f' u ) ( brush u ) ) • f u
|
||||
offTgt :: Double -> Vector2D Double
|
||||
offTgt :: Double -> T ( ℝ 2 )
|
||||
offTgt u
|
||||
| u < 0.5
|
||||
= 1e9 *^ ( off u --> off (u + 1e-9) )
|
||||
| otherwise
|
||||
= 1e9 *^ ( off (u - 1e-9) --> off u )
|
||||
fwd' :: Double -> Vector2D Double
|
||||
fwd' :: Double -> T ( ℝ 2 )
|
||||
fwd' u
|
||||
| squaredNorm ( offTgt u ) < epsilon
|
||||
= f' u
|
||||
|
@ -502,15 +502,15 @@ outlineFunctions ptParams brushFn sp0 crv =
|
|||
where
|
||||
s :: Double
|
||||
s = 1 - t
|
||||
off :: Double -> Point2D Double
|
||||
off :: Double -> ℝ 2
|
||||
off u = offset ( withTangent ( -1 *^ f' u ) ( brush u ) ) • f u
|
||||
offTgt :: Double -> Vector2D Double
|
||||
offTgt :: Double -> T ( ℝ 2 )
|
||||
offTgt u
|
||||
| u < 0.5
|
||||
= 1e9 *^ ( off u --> off (u + 1e-9) )
|
||||
| otherwise
|
||||
= 1e9 *^ ( off (u - 1e-9) --> off u )
|
||||
bwd' :: Double -> Vector2D Double
|
||||
bwd' :: Double -> T ( ℝ 2 )
|
||||
bwd' u
|
||||
| squaredNorm ( offTgt u ) < epsilon
|
||||
= -1 *^ f' u
|
||||
|
@ -523,7 +523,7 @@ outlineFunctions ptParams brushFn sp0 crv =
|
|||
-- used in the "stroke" function.
|
||||
-----
|
||||
|
||||
startTangent, endTangent :: ( SplineTypeI clo, HasType ( Point2D Double ) ptData ) => ptData -> ptData -> Curve clo crvData ptData -> Vector2D Double
|
||||
startTangent, endTangent :: ( SplineTypeI clo, HasType ( ℝ 2 ) ptData ) => ptData -> ptData -> Curve clo crvData ptData -> T ( ℝ 2 )
|
||||
startTangent sp p0 ( LineTo mp1 _ ) = coords p0 --> coords ( fromNextPoint sp mp1 )
|
||||
startTangent _ p0 ( Bezier2To p1 _ _ ) = coords p0 --> coords p1
|
||||
startTangent _ p0 ( Bezier3To p1 _ _ _ ) = coords p0 --> coords p1
|
||||
|
@ -531,7 +531,7 @@ endTangent sp p0 ( LineTo mp1 _ ) = coords p0 --> coords ( fromNextPoi
|
|||
endTangent sp _ ( Bezier2To p0 mp1 _ ) = coords p0 --> coords ( fromNextPoint sp mp1 )
|
||||
endTangent sp _ ( Bezier3To _ p0 mp1 _ ) = coords p0 --> coords ( fromNextPoint sp mp1 )
|
||||
|
||||
lastTangent :: HasType ( Point2D Double ) ptData => Spline Closed crvData ptData -> Maybe ( Vector2D Double )
|
||||
lastTangent :: HasType ( ℝ 2 ) ptData => Spline Closed crvData ptData -> Maybe ( T ( ℝ 2 ) )
|
||||
lastTangent ( Spline { splineCurves = NoCurves } ) = Nothing
|
||||
lastTangent ( Spline { splineStart, splineCurves = ClosedCurves Empty lst } ) = Just $ endTangent splineStart splineStart lst
|
||||
lastTangent ( Spline { splineStart, splineCurves = ClosedCurves ( _ :|> prev ) lst } ) = Just $ endTangent splineStart ( openCurveEnd prev ) lst
|
||||
|
@ -540,13 +540,13 @@ lastTangent ( Spline { splineStart, splineCurves = ClosedCurves ( _ :|> prev ) l
|
|||
|
||||
-- | Compute the join at a point of discontinuity of the tangent vector direction (G1 discontinuity).
|
||||
joinWithBrush
|
||||
:: ( HasType ( Point2D Double ) ptData
|
||||
:: ( HasType ( ℝ 2 ) ptData
|
||||
-- debugging
|
||||
, Show ptData, Show crvData
|
||||
)
|
||||
=> Spline Closed crvData ptData
|
||||
-> Vector2D Double
|
||||
-> Vector2D Double
|
||||
-> T ( ℝ 2 )
|
||||
-> T ( ℝ 2 )
|
||||
-> SplinePts Open
|
||||
joinWithBrush brush startTgt endTgt = joinBetweenOffsets brush startOffset endOffset
|
||||
where
|
||||
|
@ -555,7 +555,7 @@ joinWithBrush brush startTgt endTgt = joinBetweenOffsets brush startOffset endOf
|
|||
endOffset = withTangent endTgt brush
|
||||
|
||||
-- | Select the section of a spline in between two offsets.
|
||||
joinBetweenOffsets :: forall crvData ptData. HasType ( Point2D Double ) ptData => Spline Closed crvData ptData -> Offset -> Offset -> SplinePts Open
|
||||
joinBetweenOffsets :: forall crvData ptData. HasType ( ℝ 2 ) ptData => Spline Closed crvData ptData -> Offset -> Offset -> SplinePts Open
|
||||
joinBetweenOffsets
|
||||
spline
|
||||
( Offset { offsetIndex = i1, offsetParameter = mb_t1 } )
|
||||
|
@ -599,7 +599,7 @@ joinBetweenOffsets
|
|||
]
|
||||
where
|
||||
empty :: SplinePts Open
|
||||
empty = Spline { splineStart = Point2D 0 0, splineCurves = OpenCurves Empty }
|
||||
empty = Spline { splineStart = ℝ2 0 0, splineCurves = OpenCurves Empty }
|
||||
openSpline :: Spline Open crvData ptData
|
||||
openSpline = adjustSplineType spline
|
||||
t1, t2 :: Double
|
||||
|
@ -608,12 +608,12 @@ joinBetweenOffsets
|
|||
|
||||
|
||||
discardCurveData
|
||||
:: ( Bifunctor f, HasType ( Point2D Double ) ptData )
|
||||
=> f crvData ptData -> f () ( Point2D Double )
|
||||
:: ( Bifunctor f, HasType ( ℝ 2 ) ptData )
|
||||
=> f crvData ptData -> f () ( ℝ 2 )
|
||||
discardCurveData = bimap ( const () ) coords
|
||||
|
||||
-- | Drop the first curve in a Bézier spline.
|
||||
dropFirstPiece :: HasType ( Point2D Double ) ptData => Spline Open crvData ptData -> Maybe ( SplinePts Open )
|
||||
dropFirstPiece :: HasType ( ℝ 2 ) ptData => Spline Open crvData ptData -> Maybe ( SplinePts Open )
|
||||
dropFirstPiece ( Spline { splineCurves = OpenCurves curves } ) = case curves of
|
||||
Empty -> Nothing
|
||||
fstPiece :<| laterPieces ->
|
||||
|
@ -623,15 +623,15 @@ dropFirstPiece ( Spline { splineCurves = OpenCurves curves } ) = case curves of
|
|||
}
|
||||
|
||||
-- | Subdivide the first piece at the given parameter, discarding the subsequent pieces.
|
||||
splitFirstPiece :: HasType ( Point2D Double ) ptData => Double -> Spline Open crvData ptData -> Maybe ( SplinePts Open, SplinePts Open )
|
||||
splitFirstPiece :: HasType ( ℝ 2 ) ptData => Double -> Spline Open crvData ptData -> Maybe ( SplinePts Open, SplinePts Open )
|
||||
splitFirstPiece t ( Spline { splineStart = sp0, splineCurves = OpenCurves curves } ) = case curves of
|
||||
Empty -> Nothing
|
||||
fstPiece :<| _ -> case fstPiece of
|
||||
LineTo { curveEnd = NextPoint sp1 } ->
|
||||
let
|
||||
p1, p :: Point2D Double
|
||||
p1, p :: ℝ 2
|
||||
p1 = coords sp1
|
||||
p = lerp @( Vector2D Double ) t p0 p1
|
||||
p = lerp @( T ( ℝ 2 ) ) t p0 p1
|
||||
in
|
||||
Just
|
||||
( Spline
|
||||
|
@ -647,11 +647,11 @@ splitFirstPiece t ( Spline { splineStart = sp0, splineCurves = OpenCurves curves
|
|||
)
|
||||
Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2 } ->
|
||||
let
|
||||
p1, p2, q1, p, r1 :: Point2D Double
|
||||
p1, p2, q1, p, r1 :: ℝ 2
|
||||
p1 = coords sp1
|
||||
p2 = coords sp2
|
||||
( Quadratic.Bezier _ q1 p, Quadratic.Bezier _ r1 _ )
|
||||
= Quadratic.subdivide @( Vector2D Double ) ( Quadratic.Bezier {..} ) t
|
||||
= Quadratic.subdivide @( T ( ℝ 2 ) ) ( Quadratic.Bezier {..} ) t
|
||||
in
|
||||
Just
|
||||
( Spline
|
||||
|
@ -667,12 +667,12 @@ splitFirstPiece t ( Spline { splineStart = sp0, splineCurves = OpenCurves curves
|
|||
)
|
||||
Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3 } ->
|
||||
let
|
||||
p1, p2, p3, q1, q2, p, r1, r2 :: Point2D Double
|
||||
p1, p2, p3, q1, q2, p, r1, r2 :: ℝ 2
|
||||
p1 = coords sp1
|
||||
p2 = coords sp2
|
||||
p3 = coords sp3
|
||||
( Cubic.Bezier _ q1 q2 p, Cubic.Bezier _ r1 r2 _ )
|
||||
= Cubic.subdivide @( Vector2D Double ) ( Cubic.Bezier {..} ) t
|
||||
= Cubic.subdivide @( T ( ℝ 2 ) ) ( Cubic.Bezier {..} ) t
|
||||
in
|
||||
Just
|
||||
( Spline
|
||||
|
@ -687,7 +687,7 @@ splitFirstPiece t ( Spline { splineStart = sp0, splineCurves = OpenCurves curves
|
|||
}
|
||||
)
|
||||
where
|
||||
p0 :: Point2D Double
|
||||
p0 :: ℝ 2
|
||||
p0 = coords sp0
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
@ -697,8 +697,8 @@ splitFirstPiece t ( Spline { splineStart = sp0, splineCurves = OpenCurves curves
|
|||
-- Does /not/ check that the provided nib shape is convex.
|
||||
withTangent
|
||||
:: forall crvData ptData
|
||||
. ( HasType ( Point2D Double ) ptData, Show crvData, Show ptData )
|
||||
=> Vector2D Double -> Spline Closed crvData ptData -> Offset
|
||||
. ( HasType ( ℝ 2 ) ptData, Show crvData, Show ptData )
|
||||
=> T ( ℝ 2 ) -> Spline Closed crvData ptData -> Offset
|
||||
withTangent tgt_wanted spline@( Spline { splineStart } )
|
||||
-- only allow non-empty splines
|
||||
| Just tgt_last <- lastTangent spline
|
||||
|
@ -712,24 +712,24 @@ withTangent tgt_wanted spline@( Spline { splineStart } )
|
|||
\tangent vector: " <> show tgt_wanted <> "\n\
|
||||
\spline:\n" <> showSplinePoints spline <> "\n"
|
||||
| otherwise
|
||||
= Offset { offsetIndex = 0, offsetParameter = Just 0, offset = MkVector2D ( coords splineStart ) }
|
||||
= Offset { offsetIndex = 0, offsetParameter = Just 0, offset = T ( coords splineStart ) }
|
||||
|
||||
where
|
||||
badTangent :: Vector2D Double -> Bool
|
||||
badTangent ( Vector2D tx ty ) =
|
||||
badTangent :: T ( ℝ 2 ) -> Bool
|
||||
badTangent ( V2 tx ty ) =
|
||||
isNaN tx || isNaN ty || isInfinite tx || isInfinite ty
|
||||
|| ( abs tx < epsilon && abs ty < epsilon )
|
||||
ori :: Orientation
|
||||
ori = splineOrientation @Double spline
|
||||
go :: Int -> ptData -> Curve Open crvData ptData -> StateT ( Vector2D Double ) ( Except Offset ) ()
|
||||
ori = splineOrientation spline
|
||||
go :: Int -> ptData -> Curve Open crvData ptData -> StateT ( T ( ℝ 2 ) ) ( Except Offset ) ()
|
||||
go i cp cseg = do
|
||||
tgt_prev <- get
|
||||
let
|
||||
p :: Point2D Double
|
||||
p :: ℝ 2
|
||||
p = coords cp
|
||||
seg :: Curve Open crvData ( Point2D Double )
|
||||
seg :: Curve Open crvData ( ℝ 2 )
|
||||
seg = fmap coords cseg
|
||||
tgt_start, tgt_end :: Vector2D Double
|
||||
tgt_start, tgt_end :: T ( ℝ 2 )
|
||||
tgt_start = startTangent splineStart cp cseg
|
||||
tgt_end = endTangent splineStart cp cseg
|
||||
-- Handle corner.
|
||||
|
@ -739,38 +739,38 @@ withTangent tgt_wanted spline@( Spline { splineStart } )
|
|||
Offset
|
||||
{ offsetIndex = i
|
||||
, offsetParameter = Just 0
|
||||
, offset = MkVector2D p
|
||||
, offset = T p
|
||||
}
|
||||
-- Handle segment.
|
||||
lift $ handleSegment i p seg tgt_start
|
||||
put tgt_end
|
||||
|
||||
handleSegment :: Int -> Point2D Double -> Curve Open crvData ( Point2D Double ) -> Vector2D Double -> Except Offset ()
|
||||
handleSegment :: Int -> ℝ 2 -> Curve Open crvData ( ℝ 2 ) -> T ( ℝ 2 ) -> Except Offset ()
|
||||
handleSegment i p0 ( LineTo ( NextPoint p1 ) _ ) tgt0
|
||||
| tgt_wanted `strictlyParallel` tgt0
|
||||
, let
|
||||
offset :: Vector2D Double
|
||||
offset = MkVector2D $ lerp @( Vector2D Double ) 0.5 p0 p1
|
||||
offset :: T ( ℝ 2 )
|
||||
offset = T $ lerp @( T ( ℝ 2 ) ) 0.5 p0 p1
|
||||
= throwE ( Offset { offsetIndex = i, offsetParameter = Nothing, offset } )
|
||||
| otherwise
|
||||
= pure ()
|
||||
handleSegment i p0 ( Bezier2To p1 ( NextPoint p2 ) _ ) tgt0 =
|
||||
let
|
||||
tgt1 :: Vector2D Double
|
||||
tgt1 :: T ( ℝ 2 )
|
||||
tgt1 = p1 --> p2
|
||||
in for_ ( convexCombination tgt0 tgt1 tgt_wanted ) \ t ->
|
||||
throwE $
|
||||
Offset
|
||||
{ offsetIndex = i
|
||||
, offsetParameter = Just t
|
||||
, offset = MkVector2D $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t
|
||||
, offset = T $ Quadratic.bezier @( T ( ℝ 2 ) ) ( Quadratic.Bezier {..} ) t
|
||||
}
|
||||
handleSegment i p0 ( Bezier3To p1 p2 ( NextPoint p3 ) _ ) tgt0 =
|
||||
let
|
||||
tgt1, tgt2 :: Vector2D Double
|
||||
tgt1, tgt2 :: T ( ℝ 2 )
|
||||
tgt1 = p1 --> p2
|
||||
tgt2 = p2 --> p3
|
||||
bez :: Cubic.Bezier ( Point2D Double )
|
||||
bez :: Cubic.Bezier ( ℝ 2 )
|
||||
bez = Cubic.Bezier {..}
|
||||
c01, c12, c23 :: Double
|
||||
c01 = tgt_wanted `cross` tgt0
|
||||
|
@ -794,7 +794,7 @@ withTangent tgt_wanted spline@( Spline { splineStart } )
|
|||
Offset
|
||||
{ offsetIndex = i
|
||||
, offsetParameter = Just t
|
||||
, offset = MkVector2D $ Cubic.bezier @( Vector2D Double ) bez t
|
||||
, offset = T $ Cubic.bezier @( T ( ℝ 2 ) ) bez t
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
@ -5,7 +5,7 @@
|
|||
|
||||
module Math.Linear
|
||||
( -- * Points and vectors
|
||||
Point2D(..), Vector2D(.., Vector2D), Segment(..), Mat22(..)
|
||||
Segment(..), Mat22(..)
|
||||
|
||||
-- * Points and vectors (second version)
|
||||
, ℝ(..), T(.., V2, V3)
|
||||
|
@ -46,39 +46,7 @@ import Data.Group.Generics
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Point2D a = Point2D !a !a
|
||||
deriving stock ( Eq, Generic, Generic1, Functor, Foldable, Traversable )
|
||||
deriving ( Act ( Vector2D a ), Torsor ( Vector2D a ) )
|
||||
via Vector2D a
|
||||
deriving Applicative
|
||||
via Generically1 Point2D
|
||||
deriving anyclass ( NFData, NFData1 )
|
||||
|
||||
instance Show a => Show (Point2D a) where
|
||||
showsPrec i (Point2D a b) = showsPrec i (a,b)
|
||||
|
||||
newtype Vector2D a = MkVector2D { tip :: Point2D a }
|
||||
deriving stock ( Generic, Generic1, Foldable, Traversable )
|
||||
deriving newtype ( Eq, Functor, Applicative, NFData, NFData1 )
|
||||
deriving ( Semigroup, Monoid, Group )
|
||||
via Generically ( Point2D ( Sum a ) )
|
||||
|
||||
-- | One-off datatype used for the 'Show' instance of Vector2D.
|
||||
data V a = V a a
|
||||
deriving stock Show
|
||||
instance Show a => Show (Vector2D a) where
|
||||
showsPrec i (Vector2D x y) = showsPrec i (V x y)
|
||||
|
||||
{-# COMPLETE Vector2D #-}
|
||||
pattern Vector2D :: a -> a -> Vector2D a
|
||||
pattern Vector2D x y = MkVector2D ( Point2D x y )
|
||||
|
||||
data Mat22 a
|
||||
= Mat22 !a !a !a !a
|
||||
deriving stock ( Show, Eq, Generic, Generic1, Functor, Foldable, Traversable )
|
||||
deriving Applicative
|
||||
via Generically1 Mat22
|
||||
deriving anyclass ( NFData, NFData1 )
|
||||
data Mat22 = Mat22 !Double !Double !Double !Double
|
||||
|
||||
data Segment p =
|
||||
Segment
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Math.Linear.Dual where
|
||||
|
@ -28,30 +29,35 @@ deriving stock instance Functor ( D a ) => Functor ( (~>) a )
|
|||
|
||||
-- | @D ( ℝ n ) v@ is \( \mathbb{R}[x_1, \ldots, x_n]/(x_1, \ldots, x_n)^3 \otimes_\mathbb{R} v \)
|
||||
type D :: Type -> Type -> Type
|
||||
data family D u v
|
||||
newtype instance D ( ℝ 0 ) v = D0 { v :: v }
|
||||
type family D u
|
||||
type instance D ( ℝ 0 ) = Dℝ0
|
||||
type instance D ( ℝ 1 ) = Dℝ1
|
||||
type instance D ( ℝ 2 ) = Dℝ2
|
||||
type instance D ( ℝ 3 ) = Dℝ3
|
||||
|
||||
newtype Dℝ0 v = D0 { v :: v }
|
||||
deriving stock ( Show, Eq, Functor, Generic, Generic1 )
|
||||
deriving newtype ( Num, Fractional, Floating )
|
||||
deriving Applicative
|
||||
via Generically1 ( D ( ℝ 0 ) )
|
||||
data instance D ( ℝ 1 ) v = D1 { v :: !v, dx :: !( T v ), ddx :: !( T v ) }
|
||||
via Generically1 Dℝ0
|
||||
data Dℝ1 v = D1 { v :: !v, dx :: !( T v ), ddx :: !( T v ) }
|
||||
deriving stock ( Show, Eq, Functor, Generic, Generic1 )
|
||||
deriving Applicative
|
||||
via Generically1 ( D ( ℝ 1 ) )
|
||||
data instance D ( ℝ 2 ) v = D2 { v :: !v, dx, dy :: !( T v ), ddx, dxdy, ddy :: !( T v ) }
|
||||
via Generically1 Dℝ1
|
||||
data Dℝ2 v = D2 { v :: !v, dx, dy :: !( T v ), ddx, dxdy, ddy :: !( T v ) }
|
||||
deriving stock ( Show, Eq, Functor, Generic, Generic1 )
|
||||
deriving Applicative
|
||||
via Generically1 ( D ( ℝ 2 ) )
|
||||
data instance D ( ℝ 3 ) v = D3 { v :: !v, dx, dy, dz :: !( T v ), ddx, dxdy, ddy, dxdz, dydz, ddz :: !( T v ) }
|
||||
via Generically1 Dℝ2
|
||||
data Dℝ3 v = D3 { v :: !v, dx, dy, dz :: !( T v ), ddx, dxdy, ddy, dxdz, dydz, ddz :: !( T v ) }
|
||||
deriving stock ( Show, Eq, Functor, Generic, Generic1 )
|
||||
deriving Applicative
|
||||
via Generically1 ( D ( ℝ 3 ) )
|
||||
via Generically1 Dℝ3
|
||||
|
||||
instance Num ( D ( ℝ 1 ) Double ) where
|
||||
instance Num ( Dℝ1 Double ) where
|
||||
(+) = liftA2 (+)
|
||||
(-) = liftA2 (-)
|
||||
negate = fmap negate
|
||||
fromInteger = konst . fromInteger
|
||||
fromInteger = konst @( ℝ 1 ) . fromInteger
|
||||
|
||||
abs = error "no"
|
||||
signum = error "no"
|
||||
|
@ -62,11 +68,11 @@ instance Num ( D ( ℝ 1 ) Double ) where
|
|||
( T $ dx1 * v2 + v1 * dx2 )
|
||||
( T $ dx1 * dx2 + v1 * ddx2 + ddx1 * v2 )
|
||||
|
||||
instance Num ( D ( ℝ 2 ) Double ) where
|
||||
instance Num ( Dℝ2 Double ) where
|
||||
(+) = liftA2 (+)
|
||||
(-) = liftA2 (-)
|
||||
negate = fmap negate
|
||||
fromInteger = konst . fromInteger
|
||||
fromInteger = konst @( ℝ 2 ) . fromInteger
|
||||
|
||||
abs = error "no"
|
||||
signum = error "no"
|
||||
|
@ -81,11 +87,11 @@ instance Num ( D ( ℝ 2 ) Double ) where
|
|||
( T $ dy1 * dy2 + v1 * ddy2 + ddy1 * v2 )
|
||||
|
||||
|
||||
instance Num ( D ( ℝ 3 ) Double ) where
|
||||
instance Num ( Dℝ3 Double ) where
|
||||
(+) = liftA2 (+)
|
||||
(-) = liftA2 (-)
|
||||
negate = fmap negate
|
||||
fromInteger = konst . fromInteger
|
||||
fromInteger = konst @( ℝ 3 ) . fromInteger
|
||||
|
||||
abs = error "no"
|
||||
signum = error "no"
|
||||
|
@ -104,35 +110,35 @@ instance Num ( D ( ℝ 3 ) Double ) where
|
|||
( T $ dz1 * dz2 + v1 * ddz2 + ddz1 * v2)
|
||||
|
||||
|
||||
instance Module Double v => Module ( D ( ℝ 0 ) Double ) ( D ( ℝ 0 ) v ) where
|
||||
instance Module Double v => Module ( Dℝ0 Double ) ( Dℝ0 v ) where
|
||||
(^+^) = liftA2 (^+^)
|
||||
(^-^) = liftA2 (^-^)
|
||||
origin = pure origin
|
||||
(*^) = liftA2 (*^)
|
||||
|
||||
instance Module Double v => Module ( D ( ℝ 1 ) Double ) ( D ( ℝ 1 ) v ) where
|
||||
instance Module Double v => Module ( Dℝ1 Double ) ( Dℝ1 v ) where
|
||||
(^+^) = liftA2 (^+^)
|
||||
(^-^) = liftA2 (^-^)
|
||||
origin = pure origin
|
||||
(*^) = liftA2 (*^)
|
||||
|
||||
instance Module Double v => Module ( D ( ℝ 2 ) Double ) ( D ( ℝ 2 ) v ) where
|
||||
instance Module Double v => Module ( Dℝ2 Double ) ( Dℝ2 v ) where
|
||||
(^+^) = liftA2 (^+^)
|
||||
(^-^) = liftA2 (^-^)
|
||||
origin = pure origin
|
||||
(*^) = liftA2 (*^)
|
||||
|
||||
instance Module Double v => Module ( D ( ℝ 3 ) Double ) ( D ( ℝ 3 ) v ) where
|
||||
instance Module Double v => Module ( Dℝ3 Double ) ( Dℝ3 v ) where
|
||||
(^+^) = liftA2 (^+^)
|
||||
(^-^) = liftA2 (^-^)
|
||||
origin = pure origin
|
||||
(*^) = liftA2 (*^)
|
||||
|
||||
instance Fractional ( D ( ℝ 1 ) Double ) where
|
||||
(/) = error "I haven't yet defined (/) for D ( ℝ 1 )"
|
||||
fromRational = konst . fromRational
|
||||
instance Floating ( D ( ℝ 1 ) Double ) where
|
||||
pi = konst pi
|
||||
instance Fractional ( Dℝ1 Double ) where
|
||||
(/) = error "I haven't yet defined (/) for Dℝ1"
|
||||
fromRational = konst @( ℝ 1 ) . fromRational
|
||||
instance Floating ( Dℝ1 Double ) where
|
||||
pi = konst @( ℝ 1 ) pi
|
||||
sin ( D1 v ( T dx ) ( T ddx ) )
|
||||
= let !s = sin v
|
||||
!c = cos v
|
||||
|
@ -143,11 +149,11 @@ instance Floating ( D ( ℝ 1 ) Double ) where
|
|||
!c = cos v
|
||||
in D1 c ( T $ -s * dx ) ( T $ -2 * s * ddx - c * dx * dx )
|
||||
|
||||
instance Fractional ( D ( ℝ 2 ) Double ) where
|
||||
(/) = error "I haven't yet defined (/) for D ( ℝ 2 )"
|
||||
fromRational = konst . fromRational
|
||||
instance Floating ( D ( ℝ 2 ) Double ) where
|
||||
pi = konst pi
|
||||
instance Fractional ( Dℝ2 Double ) where
|
||||
(/) = error "I haven't yet defined (/) for Dℝ2"
|
||||
fromRational = konst @( ℝ 2 ) . fromRational
|
||||
instance Floating ( Dℝ2 Double ) where
|
||||
pi = konst @( ℝ 2 ) pi
|
||||
sin ( D2 v ( T dx ) ( T dy ) ( T ddx ) ( T dxdy ) ( T ddy ) )
|
||||
= let !s = sin v
|
||||
!c = cos v
|
||||
|
@ -166,11 +172,11 @@ instance Floating ( D ( ℝ 2 ) Double ) where
|
|||
( T $ -2 * s * dxdy - 2 * c * dx * dy )
|
||||
( T $ -2 * s * ddy - c * dy * dy )
|
||||
|
||||
instance Fractional ( D ( ℝ 3 ) Double ) where
|
||||
(/) = error "I haven't yet defined (/) for D ( ℝ 3 )"
|
||||
fromRational = konst . fromRational
|
||||
instance Floating ( D ( ℝ 3 ) Double ) where
|
||||
pi = konst pi
|
||||
instance Fractional ( Dℝ3 Double ) where
|
||||
(/) = error "I haven't yet defined (/) for Dℝ3"
|
||||
fromRational = konst @( ℝ 3 ) . fromRational
|
||||
instance Floating ( Dℝ3 Double ) where
|
||||
pi = konst @( ℝ 3 ) pi
|
||||
sin ( D3 v ( T dx ) ( T dy ) ( T dz ) ( T ddx ) ( T dxdy ) ( T ddy ) ( T dxdz ) ( T dydz ) ( T ddz ) )
|
||||
= let !s = sin v
|
||||
!c = cos v
|
||||
|
@ -207,7 +213,7 @@ uncurryD ( D b ) = D \ ( ℝ2 t0 s0 ) ->
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
chainRule :: ( Chain v, Module Double ( T w ) )
|
||||
chainRule :: ( Diffy v, Module Double ( T w ) )
|
||||
=> ( ( ℝ 1 ) ~> v )
|
||||
-> ( v ~> w )
|
||||
-> ( ( ℝ 1 ) ~> w )
|
||||
|
@ -217,24 +223,31 @@ chainRule ( D f ) ( D g ) =
|
|||
df@( D1 { v = f_x } ) ->
|
||||
chain df ( g f_x )
|
||||
|
||||
type Chain :: Type -> Constraint
|
||||
class Chain v where
|
||||
-- | Recover the underlying function, discarding all infinitesimal information.
|
||||
fun :: forall v w. Diffy v => ( v ~> w ) -> ( v -> w )
|
||||
fun ( D f ) = value @v . f
|
||||
|
||||
type Diffy :: Type -> Constraint
|
||||
class Diffy v where
|
||||
chain :: ( Module Double ( T w ) )
|
||||
=> D ( ℝ 1 ) v -> D v w -> D ( ℝ 1 ) w
|
||||
=> Dℝ1 v -> D v w -> D ( ℝ 1 ) w
|
||||
konst :: Module Double ( T w ) => w -> D v w
|
||||
value :: D v w -> w
|
||||
|
||||
instance Chain ( ℝ 0 ) where
|
||||
chain _ ( D0 v ) = D1 v origin origin
|
||||
instance Diffy ( ℝ 0 ) where
|
||||
chain _ ( D0 w ) = D1 w origin origin
|
||||
konst k = D0 k
|
||||
value ( D0 w ) = w
|
||||
|
||||
instance Chain ( ℝ 1 ) where
|
||||
instance Diffy ( ℝ 1 ) where
|
||||
chain ( D1 _ ( T ( ℝ1 x' ) ) ( T ( ℝ1 x'' ) ) ) ( D1 v g_x g_xx )
|
||||
= D1 v
|
||||
( x' *^ g_x )
|
||||
( x'' *^ g_x ^+^ ( x' * x' ) *^ g_xx )
|
||||
konst k = D1 k origin origin
|
||||
value ( D1 { v } ) = v
|
||||
|
||||
instance Chain ( ℝ 2 ) where
|
||||
instance Diffy ( ℝ 2 ) where
|
||||
chain ( D1 _ ( T ( ℝ2 x' y' ) ) ( T ( ℝ2 x'' y'' ) ) ) ( D2 v g_x g_y g_xx g_xy g_yy )
|
||||
= D1 v
|
||||
( x' *^ g_x ^+^ y' *^ g_y )
|
||||
|
@ -242,8 +255,9 @@ instance Chain ( ℝ 2 ) where
|
|||
^+^ ( x' * x' ) *^ g_xx ^+^ ( y' * y' ) *^ g_yy
|
||||
^+^ 2 *^ ( ( x' * y' ) *^ g_xy ) )
|
||||
konst k = D2 k origin origin origin origin origin
|
||||
value ( D2 { v } ) = v
|
||||
|
||||
instance Chain ( ℝ 3 ) where
|
||||
instance Diffy ( ℝ 3 ) where
|
||||
chain ( D1 _ ( T ( ℝ3 x' y' z' ) ) ( T ( ℝ3 x'' y'' z'' ) ) )
|
||||
( D3 v g_x g_y g_z g_xx g_xy g_yy g_xz g_yz g_zz )
|
||||
= D1 v
|
||||
|
@ -252,6 +266,7 @@ instance Chain ( ℝ 3 ) where
|
|||
^+^ ( x' * x' ) *^ g_xx ^+^ ( y' * y' ) *^ g_yy ^+^ ( z' * z' ) *^ g_zz
|
||||
^+^ 2 *^ ( ( x' * y' ) *^ g_xy ) ^+^ ( x' * z' ) *^ g_xz ^+^ ( y' * z' ) *^ g_yz )
|
||||
konst k = D3 k origin origin origin origin origin origin origin origin origin
|
||||
value ( D3 { v } ) = v
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
@ -16,12 +16,12 @@ import qualified Eigen.Solver.LA as Eigen
|
|||
|
||||
-- MetaBrush
|
||||
import Math.Linear
|
||||
( Vector2D(..), Mat22(..) )
|
||||
( Mat22(..), ℝ(..), T(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
linearSolve :: Mat22 Double -> Vector2D Double -> Vector2D Double
|
||||
linearSolve ( Mat22 a b c d ) ( Vector2D p q ) = Vector2D u v
|
||||
linearSolve :: Mat22 -> T ( ℝ 2 ) -> T ( ℝ 2 )
|
||||
linearSolve ( Mat22 a b c d ) ( V2 p q ) = V2 u v
|
||||
where
|
||||
[[u],[v]] = Eigen.toList
|
||||
$ Eigen.solve Eigen.JacobiSVD
|
||||
|
|
|
@ -28,10 +28,6 @@ import Data.Act
|
|||
( (-->) )
|
||||
)
|
||||
|
||||
-- groups
|
||||
import Data.Group
|
||||
( invert )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Epsilon
|
||||
( epsilon )
|
||||
|
@ -126,21 +122,6 @@ instance Num a => Module a ( Sum a ) where
|
|||
instance Num a => Inner a ( Sum a ) where
|
||||
Sum a ^.^ Sum b = a * b
|
||||
|
||||
|
||||
instance Num a => Module a ( Vector2D a ) where
|
||||
|
||||
origin = pure 0
|
||||
|
||||
(^+^) = (<>)
|
||||
p ^-^ q = p <> invert q
|
||||
|
||||
c *^ p = fmap ( c * ) p
|
||||
p ^* c = fmap ( * c ) p
|
||||
|
||||
instance Num a => Inner a ( Vector2D a ) where
|
||||
( Vector2D x1 y1 ) ^.^ ( Vector2D x2 y2 )
|
||||
= x1 * x2 + y1 * y2
|
||||
|
||||
instance Module Double ( T ( ℝ 0 ) ) where
|
||||
origin = T ℝ0
|
||||
_ ^+^ _ = T ℝ0
|
||||
|
@ -164,16 +145,18 @@ instance Module Double ( T ( ℝ 3 ) ) where
|
|||
T ( ℝ3 ( x1 - x2 ) ( y1 - y2 ) ( z1 - z2 ) )
|
||||
k *^ ( T ( ℝ3 a b c ) ) = T ( ℝ3 ( k * a ) ( k * b ) ( k * c ) )
|
||||
|
||||
instance Inner Double ( T ( ℝ 2 ) ) where
|
||||
V2 x1 y1 ^.^ V2 x2 y2 = x1 * x2 + y1 * y2
|
||||
|
||||
-- | Cross-product of two 2D vectors.
|
||||
cross :: Num a => Vector2D a -> Vector2D a -> a
|
||||
cross ( Vector2D x1 y1 ) ( Vector2D x2 y2 )
|
||||
= x1 * y2 - x2 * y1
|
||||
cross :: T ( ℝ 2 ) -> T ( ℝ 2 ) -> Double
|
||||
cross ( V2 x1 y1 ) ( V2 x2 y2 ) = x1 * y2 - x2 * y1
|
||||
|
||||
-- | Compute whether two vectors point in the same direction,
|
||||
-- that is, whether each vector is a (strictly) positive multiple of the other.
|
||||
--
|
||||
-- Returns @False@ if either of the vectors is zero.
|
||||
strictlyParallel :: RealFloat r => Vector2D r -> Vector2D r -> Bool
|
||||
strictlyParallel :: T ( ℝ 2 ) -> T ( ℝ 2 ) -> Bool
|
||||
strictlyParallel u v
|
||||
= abs ( u `cross` v ) < epsilon -- vectors are collinear
|
||||
&& u ^.^ v > epsilon -- vectors point in the same direction (parallel and not anti-parallel)
|
||||
|
@ -182,12 +165,10 @@ strictlyParallel u v
|
|||
--
|
||||
-- If so, returns @ t @ in @ [ 0, 1 ] @ such that @ ( 1 - t ) v0 + t v1 @ is a positive multiple of @ u @.
|
||||
convexCombination
|
||||
:: forall r
|
||||
. RealFloat r
|
||||
=> Vector2D r -- ^ first vector
|
||||
-> Vector2D r -- ^ second vector
|
||||
-> Vector2D r -- ^ query vector
|
||||
-> Maybe r
|
||||
:: T ( ℝ 2 ) -- ^ first vector
|
||||
-> T ( ℝ 2 ) -- ^ second vector
|
||||
-> T ( ℝ 2 ) -- ^ query vector
|
||||
-> Maybe Double
|
||||
convexCombination v0 v1 u
|
||||
| abs c10 < epsilon
|
||||
= if strictlyParallel u v0
|
||||
|
@ -198,13 +179,13 @@ convexCombination v0 v1 u
|
|||
| otherwise
|
||||
= do
|
||||
let
|
||||
t :: r
|
||||
t :: Double
|
||||
t = c0 / c10
|
||||
guard ( t > -epsilon && t < 1 + epsilon )
|
||||
guard ( epsilon < u ^.^ ( lerp @( Vector2D r ) t v0 v1 ) )
|
||||
guard ( epsilon < u ^.^ ( lerp @( T ( ℝ 2 ) ) t v0 v1 ) )
|
||||
Just $ min 1 ( max 0 t )
|
||||
|
||||
where
|
||||
c0, c10 :: r
|
||||
c0, c10 :: Double
|
||||
c0 = v0 `cross` u
|
||||
c10 = ( v0 ^-^ v1 ) `cross` u
|
||||
|
|
|
@ -39,7 +39,7 @@ import Math.Bezier.Spline
|
|||
, ssplineType
|
||||
)
|
||||
import Math.Linear
|
||||
( Point2D, Vector2D(..) )
|
||||
( ℝ(..), T(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
@ -53,7 +53,7 @@ reverseOrientation CCW = CW
|
|||
reverseOrientation CW = CCW
|
||||
|
||||
-- | Compute an orientation from a sequence of tangent vectors (assumed to have monotone angle).
|
||||
convexOrientation :: forall r. RealFloat r => [ Vector2D r ] -> Orientation
|
||||
convexOrientation :: [ T ( ℝ 2 ) ] -> Orientation
|
||||
convexOrientation ( v1 : v2 : vs )
|
||||
| nearZero crossProduct
|
||||
= convexOrientation ( v2 : vs )
|
||||
|
@ -62,27 +62,27 @@ convexOrientation ( v1 : v2 : vs )
|
|||
| otherwise
|
||||
= CW
|
||||
where
|
||||
crossProduct :: r
|
||||
crossProduct :: Double
|
||||
crossProduct = v1 `cross` v2
|
||||
convexOrientation _ = CCW -- default
|
||||
|
||||
-- | Compute the orientation of a spline, assuming tangent vectors have a monotone angle.
|
||||
splineOrientation
|
||||
:: forall r clo crvData ptData
|
||||
. ( KnownSplineType clo, RealFloat r, HasType ( Point2D r ) ptData )
|
||||
:: forall clo crvData ptData
|
||||
. ( KnownSplineType clo, HasType ( ℝ 2 ) ptData )
|
||||
=> Spline clo crvData ptData
|
||||
-> Orientation
|
||||
splineOrientation = convexOrientation . splineTangents @r
|
||||
splineOrientation = convexOrientation . splineTangents
|
||||
|
||||
-- | Compute the sequence of tangent vectors given by the control points of a Bézier spline.
|
||||
splineTangents
|
||||
:: forall r clo crvData ptData
|
||||
. ( Num r, KnownSplineType clo, HasType ( Point2D r ) ptData )
|
||||
:: forall clo crvData ptData
|
||||
. ( KnownSplineType clo, HasType ( ℝ 2 ) ptData )
|
||||
=> Spline clo crvData ptData
|
||||
-> [ Vector2D r ]
|
||||
-> [ T ( ℝ 2 ) ]
|
||||
splineTangents spline@( Spline { splineStart = sp0, splineCurves = curves } )
|
||||
| let
|
||||
p0 :: Point2D r
|
||||
p0 :: ℝ 2
|
||||
p0 = view typed sp0
|
||||
= case ssplineType @clo of
|
||||
SOpen
|
||||
|
@ -93,24 +93,24 @@ splineTangents spline@( Spline { splineStart = sp0, splineCurves = curves } )
|
|||
-> go p0 ( cs :|> c )
|
||||
_ -> []
|
||||
where
|
||||
go :: Point2D r -> Seq ( Curve Open crvData ptData ) -> [ Vector2D r ]
|
||||
go :: ℝ 2 -> Seq ( Curve Open crvData ptData ) -> [ T ( ℝ 2 ) ]
|
||||
go _ Empty = []
|
||||
go p ( crv :<| crvs ) =
|
||||
case crv of
|
||||
LineTo { curveEnd = NextPoint sq }
|
||||
| let
|
||||
q :: Point2D r
|
||||
q :: ℝ 2
|
||||
q = view typed sq
|
||||
-> ( p --> q ) : go q crvs
|
||||
Bezier2To { controlPoint = scp, curveEnd = NextPoint sq }
|
||||
| let
|
||||
cp, q :: Point2D r
|
||||
cp, q :: ℝ 2
|
||||
cp = view typed scp
|
||||
q = view typed sq
|
||||
-> ( p --> cp ) : ( cp --> q ) : go q crvs
|
||||
Bezier3To { controlPoint1 = scp1, controlPoint2 = scp2, curveEnd = NextPoint sq }
|
||||
| let
|
||||
cp1, cp2, q :: Point2D r
|
||||
cp1, cp2, q :: ℝ 2
|
||||
cp1 = view typed scp1
|
||||
cp2 = view typed scp2
|
||||
q = view typed sq
|
||||
|
@ -122,19 +122,17 @@ splineTangents spline@( Spline { splineStart = sp0, splineCurves = curves } )
|
|||
-- Returns the proportion of the angle the vector is in between, or @Nothing@ if the query vector
|
||||
-- is not in between.
|
||||
--
|
||||
-- >>> between CCW ( Vector2D 1 0 ) ( Vector2D -1 1 ) ( Vector2D 1 1 )
|
||||
-- >>> between CCW ( V2 1 0 ) ( V2 -1 1 ) ( V2 1 1 )
|
||||
-- Just 0.3333333333333333
|
||||
between
|
||||
:: forall r
|
||||
. RealFloat r
|
||||
=> Orientation
|
||||
-> Vector2D r -- ^ start vector
|
||||
-> Vector2D r -- ^ end vector
|
||||
-> Vector2D r -- ^ query vector: is it in between the start and end vectors w.r.t. the provided orientation?
|
||||
-> Maybe r
|
||||
between CCW ( Vector2D x1 y1 ) ( Vector2D x2 y2 ) ( Vector2D a b ) =
|
||||
:: Orientation
|
||||
-> T ( ℝ 2 ) -- ^ start vector
|
||||
-> T ( ℝ 2 ) -- ^ end vector
|
||||
-> T ( ℝ 2 ) -- ^ query vector: is it in between the start and end vectors w.r.t. the provided orientation?
|
||||
-> Maybe Double
|
||||
between CCW ( V2 x1 y1 ) ( V2 x2 y2 ) ( V2 a b ) =
|
||||
let
|
||||
τ, η, φ, θ :: r
|
||||
τ, η, φ, θ :: Double
|
||||
τ = 2 * pi
|
||||
η = atan2 y1 x1
|
||||
φ = ( atan2 y2 x2 - η ) `mod'` τ
|
||||
|
|
Loading…
Reference in a new issue