use R2 instead of Point2D & Vector2D

This commit is contained in:
sheaf 2023-01-09 04:27:08 +01:00
parent 22820b328d
commit 671dae5474
32 changed files with 520 additions and 1162 deletions

View file

@ -170,7 +170,6 @@ library splines
exposed-modules: exposed-modules:
Math.Bezier.Cubic Math.Bezier.Cubic
, Math.Bezier.Cubic.Fit , Math.Bezier.Cubic.Fit
, Math.Bezier.Envelope
, Math.Bezier.Quadratic , Math.Bezier.Quadratic
, Math.Bezier.Spline , Math.Bezier.Spline
, Math.Bezier.Stroke , Math.Bezier.Stroke

View file

@ -90,7 +90,7 @@ import Math.Bezier.Stroke
import Math.Module import Math.Module
( Module((*^)), quadrance ) ( Module((*^)), quadrance )
import Math.Linear import Math.Linear
( Point2D(..), Vector2D(..) ) ( (..), T(..) )
import MetaBrush.Context import MetaBrush.Context
( UIElements(..), Variables(..) ( UIElements(..), Variables(..)
, Modifier(..), modifierKey , Modifier(..), modifierKey
@ -658,24 +658,24 @@ instance HandleAction About where
-- Mouse movement -- -- Mouse movement --
-------------------- --------------------
data MouseMove = MouseMove !( Point2D Double ) data MouseMove = MouseMove !( 2 )
deriving stock Show deriving stock Show
instance HandleAction MouseMove where instance HandleAction MouseMove where
handleAction handleAction
( UIElements { viewport = Viewport {..}, .. } ) ( UIElements { viewport = Viewport {..}, .. } )
vars@( Variables {..} ) vars@( Variables {..} )
( MouseMove ( Point2D x y ) ) ( MouseMove ( 2 x y ) )
= do = do
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
uiUpdateAction <- STM.atomically $ withActiveDocument vars \ doc@( Document {..} ) -> do uiUpdateAction <- STM.atomically $ withActiveDocument vars \ doc@( Document {..} ) -> do
modifiers <- STM.readTVar modifiersTVar modifiers <- STM.readTVar modifiersTVar
let let
toViewport :: Point2D Double -> Point2D Double toViewport :: 2 -> 2
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
pos :: Point2D Double pos :: 2
pos = toViewport ( Point2D x y ) pos = toViewport ( 2 x y )
STM.writeTVar mousePosTVar ( Just pos ) STM.writeTVar mousePosTVar ( Just pos )
---------------------------------------------------------- ----------------------------------------------------------
-- With the pen tool, keeping control pressed while moving the mouse -- With the pen tool, keeping control pressed while moving the mouse
@ -714,7 +714,7 @@ data MouseClick =
{ clickOrigin :: !ActionOrigin { clickOrigin :: !ActionOrigin
, clickType :: !MouseClickType , clickType :: !MouseClickType
, clickButton :: !Word32 , clickButton :: !Word32
, clickCoords :: !( Point2D Double ) , clickCoords :: !( 2 )
} }
deriving stock Show deriving stock Show
@ -731,9 +731,9 @@ instance HandleAction MouseClick where
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
let let
toViewport :: Point2D Double -> Point2D Double toViewport :: 2 -> 2
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
pos :: Point2D Double pos :: 2
pos = toViewport mouseClickCoords pos = toViewport mouseClickCoords
STM.writeTVar mousePosTVar ( Just pos ) STM.writeTVar mousePosTVar ( Just pos )
mode <- STM.readTVar modeTVar mode <- STM.readTVar modeTVar
@ -853,14 +853,14 @@ instance HandleAction MouseClick where
-- Mouse release -- -- Mouse release --
------------------- -------------------
data MouseRelease = MouseRelease !Word32 !( Point2D Double ) data MouseRelease = MouseRelease !Word32 !( 2 )
deriving stock Show deriving stock Show
instance HandleAction MouseRelease where instance HandleAction MouseRelease where
handleAction handleAction
uiElts@( UIElements { viewport = Viewport {..} } ) uiElts@( UIElements { viewport = Viewport {..} } )
vars@( Variables {..} ) vars@( Variables {..} )
( MouseRelease button ( Point2D x y ) ) ( MouseRelease button ( 2 x y ) )
= case button of = case button of
-- Left mouse button. -- Left mouse button.
@ -869,16 +869,16 @@ instance HandleAction MouseRelease where
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
let let
toViewport :: Point2D Double -> Point2D Double toViewport :: 2 -> 2
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
pos :: Point2D Double pos :: 2
pos = toViewport ( Point2D x y ) pos = toViewport ( 2 x y )
STM.writeTVar mousePosTVar ( Just pos ) STM.writeTVar mousePosTVar ( Just pos )
modifiers <- STM.readTVar modifiersTVar modifiers <- STM.readTVar modifiersTVar
mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
case mbHoldPos of case mbHoldPos of
Just ( GuideAction { holdStartPos = holdStartPos@( Point2D hx hy ), guideAction } ) -> do Just ( GuideAction { holdStartPos = holdStartPos@( 2 hx hy ), guideAction } ) -> do
case guideAction of case guideAction of
CreateGuide ruler CreateGuide ruler
| createGuide | createGuide
@ -905,7 +905,7 @@ instance HandleAction MouseRelease where
newDocument = newDocument =
over over
( field' @"documentContent" . field' @"guides" . ix guideUnique . field' @"guidePoint" ) ( field' @"documentContent" . field' @"guides" . ix guideUnique . field' @"guidePoint" )
( ( holdStartPos --> pos :: Vector2D Double ) ) ( ( holdStartPos --> pos :: T ( 2 ) ) )
doc doc
changeText :: Text changeText :: Text
changeText = "Move guide" changeText = "Move guide"
@ -922,7 +922,7 @@ instance HandleAction MouseRelease where
in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
where where
l, t :: Double l, t :: Double
Point2D l t = toViewport ( Point2D 0 0 ) 2 l t = toViewport ( 2 0 0 )
keepGuide :: Bool keepGuide :: Bool
keepGuide keepGuide
= ( x >= 0 || hx < l ) -- mouse hold position (hx,hy) is in document coordinates, = ( x >= 0 || hx < l ) -- mouse hold position (hx,hy) is in document coordinates,
@ -943,7 +943,7 @@ instance HandleAction MouseRelease where
Just hold Just hold
| PathMode <- mode | PathMode <- mode
, DragMoveHold { holdStartPos = pos0, dragAction } <- hold , DragMoveHold { holdStartPos = pos0, dragAction } <- hold
, quadrance @( Vector2D Double ) pos0 pos * zoomFactor ^ ( 2 :: Int ) >= 16 , quadrance @( T ( 2 ) ) pos0 pos * zoomFactor ^ ( 2 :: Int ) >= 16
-> let -> let
alternateMode :: Bool alternateMode :: Bool
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
@ -951,7 +951,7 @@ instance HandleAction MouseRelease where
Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd ) Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd )
Nothing -> pure Don'tModifyDoc Nothing -> pure Don'tModifyDoc
| SelectionHold pos0 <- hold | 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 $ selectRectangle selMode pos0 pos doc )
_ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc ) _ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc )
@ -977,12 +977,12 @@ instance HandleAction MouseRelease where
} }
) -> do ) -> do
let let
pathPoint :: Point2D Double pathPoint :: 2
mbControlPoint :: Maybe ( Point2D Double ) mbControlPoint :: Maybe ( 2 )
partialControlPoint :: Maybe ( Point2D Double ) partialControlPoint :: Maybe ( 2 )
( pathPoint, mbControlPoint, partialControlPoint ) ( pathPoint, mbControlPoint, partialControlPoint )
| Just ( DrawHold holdPos ) <- mbHoldPos | Just ( DrawHold holdPos ) <- mbHoldPos
= ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) holdPos, Just pos ) = ( holdPos, Just $ ( pos --> holdPos :: T ( 2 ) ) holdPos, Just pos )
| otherwise | otherwise
= ( pos, Nothing, Nothing ) = ( pos, Nothing, Nothing )
( _, otherAnchor, otherAnchorPt, _ ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc ( _, otherAnchor, otherAnchorPt, _ ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
@ -1049,14 +1049,14 @@ instance HandleAction MouseRelease where
-- Scrolling -- -- Scrolling --
--------------- ---------------
data Scroll = Scroll !( Maybe ( Point2D Double ) ) !( Vector2D Double ) data Scroll = Scroll !( Maybe ( 2 ) ) !( T ( 2 ) )
deriving stock Show deriving stock Show
instance HandleAction Scroll where instance HandleAction Scroll where
handleAction handleAction
uiElts uiElts
vars@( Variables {..} ) vars@( Variables {..} )
( Scroll mbMousePos ( Vector2D dx dy ) ) = do ( Scroll mbMousePos ( V2 dx dy ) ) = do
--viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea --viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
--viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight 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 modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
modifiers <- STM.readTVar modifiersTVar modifiers <- STM.readTVar modifiersTVar
let let
mousePos :: Point2D Double mousePos :: 2
mousePos = fromMaybe oldCenter mbMousePos mousePos = fromMaybe oldCenter mbMousePos
finalMousePos :: Point2D Double finalMousePos :: 2
newDoc :: Document newDoc :: Document
( newDoc, finalMousePos ) ( newDoc, finalMousePos )
-- Zooming using 'Control'. -- Zooming using 'Control'.
@ -1079,23 +1079,23 @@ instance HandleAction Scroll where
= max 0.0078125 ( oldZoomFactor / sqrt 2 ) = max 0.0078125 ( oldZoomFactor / sqrt 2 )
| otherwise | otherwise
= min 256 ( oldZoomFactor * sqrt 2 ) = min 256 ( oldZoomFactor * sqrt 2 )
newCenter :: Point2D Double newCenter :: 2
newCenter newCenter
= ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double ) = ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: T ( 2 ) )
oldCenter oldCenter
in ( doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }, mousePos ) in ( doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }, mousePos )
-- Vertical scrolling turned into horizontal scrolling using 'Shift'. -- Vertical scrolling turned into horizontal scrolling using 'Shift'.
| dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers | dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers
= let = let
newCenter :: Point2D Double newCenter :: 2
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) oldCenter newCenter = ( ( 25 / oldZoomFactor ) *^ V2 dy 0 ) oldCenter
in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: Vector2D Double ) mousePos ) in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: T ( 2 ) ) mousePos )
-- Vertical scrolling. -- Vertical scrolling.
| otherwise | otherwise
= let = let
newCenter :: Point2D Double newCenter :: 2
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) oldCenter newCenter = ( ( 25 / oldZoomFactor ) *^ V2 dx dy ) oldCenter
in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: Vector2D Double ) mousePos ) in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: T ( 2 ) ) mousePos )
for_ mbMousePos \ _ -> for_ mbMousePos \ _ ->
STM.writeTVar mousePosTVar ( Just finalMousePos ) STM.writeTVar mousePosTVar ( Just finalMousePos )
pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc ) pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )

View file

@ -17,7 +17,7 @@ import Data.Text
-- MetaBrush -- MetaBrush
import Math.Linear import Math.Linear
( Point2D, Vector2D ) ( (..), T(..) )
import {-# SOURCE #-} MetaBrush.Context import {-# SOURCE #-} MetaBrush.Context
( UIElements, Variables ) ( UIElements, Variables )
import {-# SOURCE #-} MetaBrush.UI.FileBar import {-# SOURCE #-} MetaBrush.UI.FileBar
@ -105,7 +105,7 @@ instance HandleAction Confirm
data About = About data About = About
instance HandleAction About instance HandleAction About
data MouseMove = MouseMove !( Point2D Double ) data MouseMove = MouseMove !( 2 )
instance HandleAction MouseMove instance HandleAction MouseMove
data ActionOrigin data ActionOrigin
@ -119,14 +119,14 @@ data MouseClick =
{ clickOrigin :: !ActionOrigin { clickOrigin :: !ActionOrigin
, clickType :: !MouseClickType , clickType :: !MouseClickType
, clickButton :: !Word32 , clickButton :: !Word32
, clickCoords :: !( Point2D Double ) , clickCoords :: !( 2 )
} }
instance HandleAction MouseClick instance HandleAction MouseClick
data MouseRelease = MouseRelease !Word32 !( Point2D Double ) data MouseRelease = MouseRelease !Word32 !( 2 )
instance HandleAction MouseRelease instance HandleAction MouseRelease
data Scroll = Scroll !( Maybe ( Point2D Double ) ) !( Vector2D Double ) data Scroll = Scroll !( Maybe ( 2 ) ) !( T ( 2 ) )
instance HandleAction Scroll instance HandleAction Scroll
data KeyboardPress = KeyboardPress !Word32 data KeyboardPress = KeyboardPress !Word32

View file

@ -80,7 +80,7 @@ import Math.Bezier.Spline
import Math.Bezier.Stroke import Math.Bezier.Stroke
( invalidateCache ) ( invalidateCache )
import Math.Linear import Math.Linear
( Point2D(..), (..) ) ( (..) )
import MetaBrush.Action import MetaBrush.Action
( ActionOrigin(..) ) ( ActionOrigin(..) )
import qualified MetaBrush.Asset.Brushes as Asset.Brushes import qualified MetaBrush.Asset.Brushes as Asset.Brushes
@ -162,11 +162,11 @@ runApplication application = do
, strokeBrush = Just Asset.Brushes.ellipse , strokeBrush = Just Asset.Brushes.ellipse
, strokeSpline = , strokeSpline =
Spline Spline
{ splineStart = mkPoint ( Point2D 10 -20 ) 2 1 0 { splineStart = mkPoint ( 2 10 -20 ) 2 1 0
, splineCurves = OpenCurves $ Seq.fromList , splineCurves = OpenCurves $ Seq.fromList
[ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 10 5 ( pi / 4 ) ), curveData = invalidateCache undefined } [ LineTo { curveEnd = NextPoint ( mkPoint ( 2 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 ( 2 -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 -20 ) 10 7 ( pi / 2 ) ), curveData = invalidateCache undefined }
] ]
} }
} }
@ -174,14 +174,14 @@ runApplication application = do
) )
] ]
where 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 ) mkPoint pt a b phi = PointData pt Normal ( MkR $ 3 a b phi )
recomputeStrokesTVar <- STM.newTVarIO @Bool False recomputeStrokesTVar <- STM.newTVarIO @Bool False
documentRenderTVar <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () ) documentRenderTVar <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () )
activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing
openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments 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 mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing
modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty
toolTVar <- STM.newTVarIO @Tool Selection toolTVar <- STM.newTVarIO @Tool Selection

View file

@ -42,7 +42,7 @@ import Data.HashMap.Strict
import Math.Bezier.Cubic.Fit import Math.Bezier.Cubic.Fit
( FitParameters ) ( FitParameters )
import Math.Linear import Math.Linear
( Point2D ) ( (..) )
import {-# SOURCE #-} MetaBrush.Action import {-# SOURCE #-} MetaBrush.Action
( ActionName ) ( ActionName )
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
@ -88,7 +88,7 @@ data Variables
, documentRenderTVar :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) ) , documentRenderTVar :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) )
, activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) ) , activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) )
, openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) ) , openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) )
, mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) ) , mousePosTVar :: !( STM.TVar ( Maybe ( 2 ) ) )
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) ) , mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
, modifiersTVar :: !( STM.TVar ( Set Modifier ) ) , modifiersTVar :: !( STM.TVar ( Set Modifier ) )
, toolTVar :: !( STM.TVar Tool ) , toolTVar :: !( STM.TVar Tool )
@ -134,21 +134,21 @@ data GuideAction
-- - draw a control point, -- - draw a control point,
-- - create/modify a guide. -- - create/modify a guide.
data HoldAction data HoldAction
= SelectionHold { holdStartPos :: !( Point2D Double ) } = SelectionHold { holdStartPos :: !( 2 ) }
| DragMoveHold { holdStartPos :: !( Point2D Double ) | DragMoveHold { holdStartPos :: !( 2 )
, dragAction :: !DragMoveSelect , dragAction :: !DragMoveSelect
} }
| DrawHold { holdStartPos :: !( Point2D Double ) } | DrawHold { holdStartPos :: !( 2 ) }
| GuideAction { holdStartPos :: !( Point2D Double ) | GuideAction { holdStartPos :: !( 2 )
, guideAction :: !GuideAction , guideAction :: !GuideAction
} }
deriving stock Show deriving stock Show
-- | Keep track of a path that is in the middle of being drawn. -- | Keep track of a path that is in the middle of being drawn.
data PartialPath data PartialPath
= PartialPath = PartialPath
{ partialStartPos :: !( Point2D Double ) { partialStartPos :: !( 2 )
, partialControlPoint :: !( Maybe ( Point2D Double ) ) , partialControlPoint :: !( Maybe ( 2 ) )
, partialPathAnchor :: !DrawAnchor , partialPathAnchor :: !DrawAnchor
, firstPoint :: !Bool , firstPoint :: !Bool
} }

View file

@ -96,7 +96,7 @@ import Math.Bezier.Stroke
import Math.Module import Math.Module
( Module, lerp, squaredNorm, closestPointOnSegment ) ( Module, lerp, squaredNorm, closestPointOnSegment )
import Math.Linear import Math.Linear
( Point2D(..), Vector2D(..), Segment(..), T(..) ) ( Segment(..), (..), T(..) )
import {-# SOURCE #-} MetaBrush.Context import {-# SOURCE #-} MetaBrush.Context
( Modifier(..) ) ( Modifier(..) )
import MetaBrush.Document import MetaBrush.Document
@ -138,7 +138,7 @@ selectionMode = foldMap \case
_ -> New _ -> New
-- | Updates the selected objects on a single click selection event. -- | 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 } ) = selectAt selMode c doc@( Document { zoomFactor } ) =
( `evalState` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc ( `evalState` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc
where where
@ -175,7 +175,7 @@ selectAt selMode c doc@( Document { zoomFactor } ) =
selected :: Bool selected :: Bool
selected selected
| not isVisible = False | 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: -- | 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, -- | 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. -- 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 } ) = dragMoveSelect c doc@( Document { zoomFactor } ) =
let let
res :: WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) Document res :: WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) Document
@ -256,9 +256,9 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
mbCurveDrag = do mbCurveDrag = do
let let
t :: Double t :: Double
p :: Point2D Double p :: 2
( t, p ) ( 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 ) guard ( inSelectionRange isVisible p )
pure $ pure $
ClickedOnCurve ClickedOnCurve
@ -274,12 +274,12 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
mbCurveDrag :: Maybe DragMoveSelect mbCurveDrag :: Maybe DragMoveSelect
mbCurveDrag = do mbCurveDrag = do
let let
bez :: Quadratic.Bezier ( Point2D Double ) bez :: Quadratic.Bezier ( 2 )
bez = Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords $ fromNextPoint start sp2 ) bez = Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords $ fromNextPoint start sp2 )
sq_d :: Double sq_d :: Double
t :: Double t :: Double
Min ( Arg sq_d (t, _) ) 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 ) guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 )
pure $ pure $
ClickedOnCurve ClickedOnCurve
@ -296,12 +296,12 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
mbCurveDrag :: Maybe DragMoveSelect mbCurveDrag :: Maybe DragMoveSelect
mbCurveDrag = do mbCurveDrag = do
let let
bez :: Cubic.Bezier ( Point2D Double ) bez :: Cubic.Bezier ( 2 )
bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords $ fromNextPoint start sp3 ) bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords $ fromNextPoint start sp3 )
sq_d :: Double sq_d :: Double
t :: Double t :: Double
Min ( Arg sq_d (t, _) ) 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 ) guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 )
pure $ pure $
ClickedOnCurve ClickedOnCurve
@ -315,10 +315,10 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
sp3' <- traverse ( updateSplinePoint isVisible ) sp3 sp3' <- traverse ( updateSplinePoint isVisible ) sp3
pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3' } ) pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3' } )
inSelectionRange :: Bool -> Point2D Double -> Bool inSelectionRange :: Bool -> 2 -> Bool
inSelectionRange isVisible p inSelectionRange isVisible p
| not isVisible = False | not isVisible = False
| otherwise = squaredNorm ( c --> p :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16 | otherwise = squaredNorm ( c --> p :: T ( 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
updateSplinePoint updateSplinePoint
:: Bool -> PointData brushParams :: Bool -> PointData brushParams
@ -365,8 +365,8 @@ dragMoveSelect c doc@( Document { zoomFactor } ) =
pure ( set _selection newPointState pt ) pure ( set _selection newPointState pt )
-- | Updates the selected objects on a rectangular selection event. -- | Updates the selected objects on a rectangular selection event.
selectRectangle :: SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document selectRectangle :: SelectionMode -> 2 -> 2 -> Document -> Document
selectRectangle selMode ( Point2D x0 y0 ) ( Point2D x1 y1 ) selectRectangle selMode ( 2 x0 y0 ) ( 2 x1 y1 )
= over ( field' @"documentContent" . field' @"strokes" . mapped ) = over ( field' @"documentContent" . field' @"strokes" . mapped )
updateStrokeHierarchy updateStrokeHierarchy
where where
@ -397,7 +397,7 @@ selectRectangle selMode ( Point2D x0 y0 ) ( Point2D x1 y1 )
_ -> pt _ -> pt
where where
x, y :: Double x, y :: Double
Point2D x y = coords pt 2 x y = coords pt
selected :: Bool selected :: Bool
selected selected
| not isVisible = False | not isVisible = False
@ -416,7 +416,7 @@ data UpdateInfo
-- | Translate all selected points by the given vector. -- | Translate all selected points by the given vector.
-- --
-- Returns the updated document, together with info about how many points were translated. -- 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 = translateSelection t doc =
( `runState` mempty ) . ( `evalStateT` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc ( `runState` mempty ) . ( `evalStateT` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc
where where
@ -683,7 +683,7 @@ deleteSelected doc =
-- | Perform a drag move action on a document. -- | 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 dragUpdate p0 p PointDrag _ doc = do
let let
( newDocument, updateInfo ) = translateSelection ( p0 --> p ) doc ( newDocument, updateInfo ) = translateSelection ( p0 --> p ) doc
@ -799,9 +799,9 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen
-> Curve Open ( CachedStroke RealWorld ) ( PointData pointParams ) -> Curve Open ( CachedStroke RealWorld ) ( PointData pointParams )
quadraticDragCurve dat ( Quadratic.Bezier { Quadratic.p1 = sp1, Quadratic.p2 = sp2 } ) = quadraticDragCurve dat ( Quadratic.Bezier { Quadratic.p1 = sp1, Quadratic.p2 = sp2 } ) =
let let
cp :: Point2D Double cp :: 2
Quadratic.Bezier { Quadratic.p1 = cp } = 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 ) in Bezier2To ( set _coords cp sp1 ) ( NextPoint sp2 ) ( invalidateCache dat )
cubicDragCurve cubicDragCurve
:: CachedStroke RealWorld :: CachedStroke RealWorld
@ -809,9 +809,9 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen
-> Curve Open ( CachedStroke RealWorld ) ( PointData pointParams ) -> Curve Open ( CachedStroke RealWorld ) ( PointData pointParams )
cubicDragCurve dat ( Cubic.Bezier { Cubic.p1 = sp1, Cubic.p2 = sp2, Cubic.p3 = sp3 } ) = cubicDragCurve dat ( Cubic.Bezier { Cubic.p1 = sp1, Cubic.p2 = sp2, Cubic.p3 = sp3 } ) =
let let
cp1, cp2 :: Point2D Double cp1, cp2 :: 2
Cubic.Bezier { Cubic.p1 = cp1, Cubic.p2 = cp2 } = 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 ) ) ( Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 ) )
dragSegmentParameter dragSegmentParameter
p p

View file

@ -27,7 +27,7 @@ import qualified Control.Concurrent.STM.TVar as STM
-- MetaBrush -- MetaBrush
import Math.Linear import Math.Linear
( Point2D(..), Vector2D(..) ) ( (..), T(..) )
import MetaBrush.Action import MetaBrush.Action
( HandleAction(..) ( HandleAction(..)
, ActionOrigin(..) , ActionOrigin(..)
@ -77,13 +77,13 @@ handleEvents elts@( UIElements { viewport = Viewport {..}, .. } ) vars = do
handleMotionEvent :: UIElements -> Variables -> ActionOrigin -> ( Double -> Double -> IO () ) handleMotionEvent :: UIElements -> Variables -> ActionOrigin -> ( Double -> Double -> IO () )
handleMotionEvent elts vars eventOrigin x y = do 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 ) handleAction elts vars ( MouseMove mousePos )
handleScrollEvent :: UIElements -> Variables -> ( Double -> Double -> IO Bool ) handleScrollEvent :: UIElements -> Variables -> ( Double -> Double -> IO Bool )
handleScrollEvent elts vars dx dy = do handleScrollEvent elts vars dx dy = do
mbMousePos <- STM.readTVarIO ( mousePosTVar vars ) mbMousePos <- STM.readTVarIO ( mousePosTVar vars )
handleAction elts vars ( Scroll mbMousePos ( Vector2D dx dy ) ) handleAction elts vars ( Scroll mbMousePos ( V2 dx dy ) )
pure False pure False
handleMouseButtonEvent handleMouseButtonEvent
@ -103,7 +103,7 @@ handleMouseButtonEvent elts@( UIElements{ viewport = Viewport {..} } ) vars even
_ <- GTK.widgetGrabFocus viewportDrawingArea _ <- GTK.widgetGrabFocus viewportDrawingArea
button <- max 1 <$> GTK.gestureSingleGetCurrentButton gestureClick button <- max 1 <$> GTK.gestureSingleGetCurrentButton gestureClick
-- ^^^^^ use button number 1 if no button number is reported (button == 0) -- ^^^^^ 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 ) handleAction elts vars ( MouseClick eventOrigin click button mousePos )
handleMouseButtonRelease handleMouseButtonRelease
@ -112,23 +112,23 @@ handleMouseButtonRelease
handleMouseButtonRelease elts vars eventOrigin gestureClick _ x y = do handleMouseButtonRelease elts vars eventOrigin gestureClick _ x y = do
button <- max 1 <$> GTK.gestureSingleGetCurrentButton gestureClick button <- max 1 <$> GTK.gestureSingleGetCurrentButton gestureClick
-- ^^^^^ same as above -- ^^^^^ 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 ) 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 _ ViewportOrigin pt = pure pt
adjustMousePosition ( Viewport {..} ) ( RulerOrigin ruler ) ( Point2D x y ) = adjustMousePosition ( Viewport {..} ) ( RulerOrigin ruler ) ( 2 x y ) =
case ruler of case ruler of
RulerCorner -> do RulerCorner -> do
dx <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth rulerCornerDrawingArea dx <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth rulerCornerDrawingArea
dy <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight rulerCornerDrawingArea dy <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight rulerCornerDrawingArea
pure ( Point2D ( x - dx ) ( y - dy ) ) pure ( 2 ( x - dx ) ( y - dy ) )
LeftRuler -> do LeftRuler -> do
dx <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth leftRulerDrawingArea dx <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth leftRulerDrawingArea
pure ( Point2D ( x - dx ) y ) pure ( 2 ( x - dx ) y )
TopRuler -> do TopRuler -> do
dy <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight topRulerDrawingArea dy <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight topRulerDrawingArea
pure ( Point2D x ( y - dy ) ) pure ( 2 x ( y - dy ) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Keyboard events. -- Keyboard events.

View file

@ -72,7 +72,9 @@ import Math.Bezier.Stroke
, computeStrokeOutline , computeStrokeOutline
) )
import Math.Linear import Math.Linear
( Point2D(..), Vector2D(..), T(..) ) ( (..), T(..) )
import Math.Linear.Dual
( fun )
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( Colours, ColourRecord(..) ) ( Colours, ColourRecord(..) )
import MetaBrush.Brush import MetaBrush.Brush
@ -142,13 +144,13 @@ blankRender _ = pure ()
getDocumentRender getDocumentRender
:: Colours -> FitParameters -> Mode -> Bool :: Colours -> FitParameters -> Mode -> Bool
-> Set Modifier -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath -> Set Modifier -> Maybe ( 2 ) -> Maybe HoldAction -> Maybe PartialPath
-> Document -> Document
-> ST RealWorld ( ( Int32, Int32 ) -> Cairo.Render () ) -> ST RealWorld ( ( Int32, Int32 ) -> Cairo.Render () )
getDocumentRender getDocumentRender
cols fitParams mode debug cols fitParams mode debug
modifiers mbMousePos mbHoldEvent mbPartialPath modifiers mbMousePos mbHoldEvent mbPartialPath
doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content } ) doc@( Document { viewportCenter = 2 cx cy, zoomFactor, documentContent = content } )
= do = do
let let
@ -169,13 +171,13 @@ getDocumentRender
_ -> foldMap visibleStrokes . strokes $ content _ -> foldMap visibleStrokes . strokes $ content
| Just ( PartialPath p0 cp0 anchor firstPoint ) <- mbPartialPath | Just ( PartialPath p0 cp0 anchor firstPoint ) <- mbPartialPath
, let , let
mbFinalPoint :: Maybe ( Point2D Double ) mbFinalPoint :: Maybe ( 2 )
mbControlPoint :: Maybe ( Point2D Double ) mbControlPoint :: Maybe ( 2 )
( mbFinalPoint, mbControlPoint ) ( mbFinalPoint, mbControlPoint )
| Just ( DrawHold holdPos ) <- mbHoldEvent | Just ( DrawHold holdPos ) <- mbHoldEvent
= if firstPoint = if firstPoint
then ( mbMousePos , Just holdPos ) 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 | otherwise
= ( mbMousePos, Nothing ) = ( mbMousePos, Nothing )
, Just finalPoint <- mbFinalPoint , Just finalPoint <- mbFinalPoint
@ -295,12 +297,12 @@ strokeRenderData fitParams
-- Compute the outline using the brush function. -- Compute the outline using the brush function.
( outline, fitPts ) <- ( outline, fitPts ) <-
computeStrokeOutline @( T ( Record usedFields) ) @clo computeStrokeOutline @( T ( Record usedFields) ) @clo
fitParams ( toUsedParams . brushParams ) ( brushFn . embedUsedParams ) spline fitParams ( toUsedParams . brushParams ) ( fun brushFn . embedUsedParams ) spline
pure $ pure $
StrokeWithOutlineRenderData StrokeWithOutlineRenderData
{ strokeDataSpline = spline { strokeDataSpline = spline
, strokeOutlineData = ( outline, fitPts ) , strokeOutlineData = ( outline, fitPts )
, strokeBrushFunction = brushFn . embedUsedParams . toUsedParams , strokeBrushFunction = fun brushFn . embedUsedParams . toUsedParams
} }
_ -> pure $ _ -> pure $
StrokeRenderData StrokeRenderData
@ -409,11 +411,11 @@ renderBrushShape
renderBrushShape cols mbHoverContext zoom brushFn pt = renderBrushShape cols mbHoverContext zoom brushFn pt =
let let
x, y :: Double x, y :: Double
Point2D x y = coords pt 2 x y = coords pt
brushPts :: SplinePts Closed brushPts :: SplinePts Closed
brushPts = brushFn ( brushParams pt ) brushPts = brushFn ( brushParams pt )
mbHoverContext' :: Maybe HoverContext mbHoverContext' :: Maybe HoverContext
mbHoverContext' = Vector2D -x -y mbHoverContext mbHoverContext' = V2 -x -y mbHoverContext
in in
toAll do toAll do
Cairo.save Cairo.save
@ -427,11 +429,11 @@ drawPoint ( Colours {..} ) mbHover zoom PathPoint pt
= do = do
let let
x, y :: Double x, y :: Double
Point2D x y = coords pt 2 x y = coords pt
hsqrt3 :: Double hsqrt3 :: Double
hsqrt3 = sqrt 0.75 hsqrt3 = sqrt 0.75
selectionState :: FocusState 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.save
Cairo.translate x y Cairo.translate x y
@ -463,9 +465,9 @@ drawPoint ( Colours {..} ) mbHover zoom ControlPoint pt
= do = do
let let
x, y :: Double x, y :: Double
Point2D x y = coords pt 2 x y = coords pt
selectionState :: FocusState 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.save
Cairo.translate x y 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 drawLine ( Colours { path, controlPointLine } ) zoom pointType p1 p2 = do
let let
x1, y1, x2, y2 :: Double x1, y1, x2, y2 :: Double
Point2D x1 y1 = coords p1 2 x1 y1 = coords p1
Point2D x2 y2 = coords p2 2 x2 y2 = coords p2
Cairo.save Cairo.save
Cairo.moveTo x1 y1 Cairo.moveTo x1 y1
@ -512,18 +514,18 @@ drawLine ( Colours { path, controlPointLine } ) zoom pointType p1 p2 = do
Cairo.restore Cairo.restore
drawQuadraticBezier :: Colours -> Double -> Quadratic.Bezier ( Point2D Double ) -> Cairo.Render () drawQuadraticBezier :: Colours -> Double -> Quadratic.Bezier ( 2 ) -> Cairo.Render ()
drawQuadraticBezier cols zoom bez = drawQuadraticBezier cols zoom bez =
drawCubicBezier cols zoom 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 drawCubicBezier ( Colours { path } ) zoom
( Cubic.Bezier ( Cubic.Bezier
{ p0 = Point2D x0 y0 { p0 = 2 x0 y0
, p1 = Point2D x1 y1 , p1 = 2 x1 y1
, p2 = Point2D x2 y2 , p2 = 2 x2 y2
, p3 = Point2D x3 y3 , p3 = 2 x3 y3
} }
) )
= do = do
@ -573,26 +575,26 @@ drawOutline cols@( Colours {..} ) debug zoom strokeData = do
makeOutline :: SplinePts Closed -> Cairo.Render () makeOutline :: SplinePts Closed -> Cairo.Render ()
makeOutline spline = bifoldSpline makeOutline spline = bifoldSpline
( drawCurve ( splineStart spline ) ) ( drawCurve ( splineStart spline ) )
( \ ( Point2D x y ) -> Cairo.moveTo x y ) ( \ ( 2 x y ) -> Cairo.moveTo x y )
spline spline
drawCurve :: forall clo. SplineTypeI clo => Point2D Double -> Point2D Double -> Curve clo () ( Point2D Double ) -> Cairo.Render () drawCurve :: forall clo. SplineTypeI clo => 2 -> 2 -> Curve clo () ( 2 ) -> Cairo.Render ()
drawCurve start ( Point2D x0 y0 ) crv = case crv of drawCurve start ( 2 x0 y0 ) crv = case crv of
LineTo mp1 _ -> LineTo mp1 _ ->
let Point2D x1 y1 = fromNextPoint start mp1 let 2 x1 y1 = fromNextPoint start mp1
in Cairo.lineTo x1 y1 in Cairo.lineTo x1 y1
Bezier2To ( Point2D x1 y1 ) mp2 _ -> Bezier2To ( 2 x1 y1 ) mp2 _ ->
let Point2D x2 y2 = fromNextPoint start mp2 let 2 x2 y2 = fromNextPoint start mp2
in Cairo.curveTo in Cairo.curveTo
( ( 2 * x1 + x0 ) / 3 ) ( ( 2 * y1 + y0 ) / 3 ) ( ( 2 * x1 + x0 ) / 3 ) ( ( 2 * y1 + y0 ) / 3 )
( ( 2 * x1 + x2 ) / 3 ) ( ( 2 * y1 + y2 ) / 3 ) ( ( 2 * x1 + x2 ) / 3 ) ( ( 2 * y1 + y2 ) / 3 )
x2 y2 x2 y2
Bezier3To ( Point2D x1 y1 ) ( Point2D x2 y2 ) mp3 _ -> Bezier3To ( 2 x1 y1 ) ( 2 x2 y2 ) mp3 _ ->
let Point2D x3 y3 = fromNextPoint start mp3 let 2 x3 y3 = fromNextPoint start mp3
in Cairo.curveTo x1 y1 x2 y2 x3 y3 in Cairo.curveTo x1 y1 x2 y2 x3 y3
drawFitPoint :: Colours -> Double -> FitPoint -> StateT Double Cairo.Render () 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 hue <- get
put ( hue + 0.01 ) put ( hue + 0.01 )
@ -607,7 +609,7 @@ drawFitPoint _ zoom ( FitPoint { fitPoint = Point2D x y } ) = do
Cairo.fill Cairo.fill
Cairo.restore 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 hue <- get
put ( hue + 0.01 ) put ( hue + 0.01 )
@ -626,8 +628,8 @@ drawFitPoint _ zoom ( FitTangent { fitPoint = Point2D x y, fitTangent = Vector2D
Cairo.fill Cairo.fill
Cairo.restore Cairo.restore
drawSelectionRectangle :: Colours -> Double -> Point2D Double -> Point2D Double -> Cairo.Render () drawSelectionRectangle :: Colours -> Double -> 2 -> 2 -> Cairo.Render ()
drawSelectionRectangle ( Colours {..} ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1 ) = do drawSelectionRectangle ( Colours {..} ) zoom ( 2 x0 y0 ) ( 2 x1 y1 ) = do
Cairo.save Cairo.save

View file

@ -45,7 +45,7 @@ import Control.Lens
-- MetaBrush -- MetaBrush
import Math.Linear import Math.Linear
( Point2D(..), Vector2D(..) ) ( (..), T(..) )
import MetaBrush.Action import MetaBrush.Action
( ActionOrigin(..) ) ( ActionOrigin(..) )
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
@ -70,13 +70,13 @@ import MetaBrush.GTK.Util
renderRuler renderRuler
:: Colours -> ( Int32, Int32 ) -> ActionOrigin -> ( Int32, Int32 ) :: Colours -> ( Int32, Int32 ) -> ActionOrigin -> ( Int32, Int32 )
-> Maybe ( Point2D Double ) -> Maybe HoldAction -> Bool -> Maybe ( 2 ) -> Maybe HoldAction -> Bool
-> Document -> Document
-> Cairo.Render () -> Cairo.Render ()
renderRuler renderRuler
cols@( Colours {..} ) ( viewportWidth, viewportHeight ) actionOrigin ( width, height ) cols@( Colours {..} ) ( viewportWidth, viewportHeight ) actionOrigin ( width, height )
mbMousePos mbHoldEvent showGuides 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 let
modifiedGuides :: [ Guide ] modifiedGuides :: [ Guide ]
@ -85,12 +85,12 @@ renderRuler
, Just mousePos <- mbMousePos , Just mousePos <- mbMousePos
= case act of = case act of
MoveGuide guideUnique MoveGuide guideUnique
-> ->
let let
translate :: Point2D Double -> Point2D Double translate :: 2 -> 2
translate = ( ( mousePos0 --> mousePos :: Vector2D Double ) ) translate = ( ( mousePos0 --> mousePos :: T ( 2 ) ) )
in toList in toList
$ Map.adjust $ Map.adjust
( over ( field' @"guidePoint" ) translate . set ( field' @"guideFocus" ) Selected ) ( over ( field' @"guidePoint" ) translate . set ( field' @"guideFocus" ) Selected )
guideUnique guideUnique
guides guides
@ -99,14 +99,14 @@ renderRuler
addNewGuides :: [ Guide ] -> [ Guide ] addNewGuides :: [ Guide ] -> [ Guide ]
addNewGuides gs = case ruler of addNewGuides gs = case ruler of
RulerCorner RulerCorner
-> Guide { guidePoint = mousePos, guideNormal = Vector2D 0 1, guideFocus = Selected, guideUnique = unsafeUnique 0 } -> Guide { guidePoint = mousePos, guideNormal = V2 0 1, guideFocus = Selected, guideUnique = unsafeUnique 0 }
: Guide { guidePoint = mousePos, guideNormal = Vector2D 1 0, guideFocus = Selected, guideUnique = unsafeUnique 1 } : Guide { guidePoint = mousePos, guideNormal = V2 1 0, guideFocus = Selected, guideUnique = unsafeUnique 1 }
: gs : gs
LeftRuler 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 : gs
TopRuler 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 : gs
in addNewGuides ( toList guides ) in addNewGuides ( toList guides )
| otherwise | otherwise
@ -114,7 +114,7 @@ renderRuler
mbHoverContext :: Maybe HoverContext mbHoverContext :: Maybe HoverContext
mbHoverContext mbHoverContext
| Just mp@( Point2D x y ) <- mbMousePos | Just mp@( 2 x y ) <- mbMousePos
, x <= left || y <= top -- only hover guides from within ruler area , x <= left || y <= top -- only hover guides from within ruler area
= Just ( MouseHover mp ) = Just ( MouseHover mp )
| otherwise | otherwise
@ -131,7 +131,7 @@ renderRuler
-- Render guides. -- Render guides.
when showGuides ( for_ modifiedGuides ( renderGuide cols mbHoverContext zoomFactor ) ) when showGuides ( for_ modifiedGuides ( renderGuide cols mbHoverContext zoomFactor ) )
-- Render mouse cursor indicator. -- Render mouse cursor indicator.
for_ mbMousePos \ ( Point2D mx my ) -> for_ mbMousePos \ ( 2 mx my ) ->
case actionOrigin of case actionOrigin of
RulerOrigin TopRuler -> do RulerOrigin TopRuler -> do
Cairo.save Cairo.save
@ -149,7 +149,7 @@ renderRuler
Cairo.translate left my Cairo.translate left my
Cairo.moveTo 0 0 Cairo.moveTo 0 0
Cairo.scale ( 1 / zoomFactor ) ( 1 / zoomFactor ) Cairo.scale ( 1 / zoomFactor ) ( 1 / zoomFactor )
Cairo.lineTo -6 -3 Cairo.lineTo -6 -3
Cairo.lineTo -6 3 Cairo.lineTo -6 3
Cairo.closePath Cairo.closePath
withRGBA cursorIndicator Cairo.setSourceRGBA withRGBA cursorIndicator Cairo.setSourceRGBA
@ -166,8 +166,8 @@ renderRuler
dx = fromIntegral width dx = fromIntegral width
dy = fromIntegral height dy = fromIntegral height
left, right, top, bottom :: Double left, right, top, bottom :: Double
Point2D left top = toViewport ( Point2D 0 0 ) 2 left top = toViewport ( 2 0 0 )
Point2D right bottom = toViewport ( Point2D ( fromIntegral viewportWidth ) ( fromIntegral viewportHeight ) ) 2 right bottom = toViewport ( 2 ( fromIntegral viewportWidth ) ( fromIntegral viewportHeight ) )
additionalAdjustment :: Cairo.Render () additionalAdjustment :: Cairo.Render ()
additionalAdjustment = case actionOrigin of additionalAdjustment = case actionOrigin of
ViewportOrigin -> pure () ViewportOrigin -> pure ()
@ -178,7 +178,7 @@ renderRuler
Cairo.translate dx 0 Cairo.translate dx 0
TopRuler -> do TopRuler -> do
Cairo.translate 0 dy Cairo.translate 0 dy
toViewport :: Point2D Double -> Point2D Double toViewport :: 2 -> 2
toViewport = toViewportCoordinates zoomFactor ( fromIntegral viewportWidth, fromIntegral viewportHeight ) center toViewport = toViewportCoordinates zoomFactor ( fromIntegral viewportWidth, fromIntegral viewportHeight ) center
setTickRenderContext :: Cairo.Render () setTickRenderContext :: Cairo.Render ()
@ -282,7 +282,7 @@ data Tick
renderGuide :: Colours -> Maybe HoverContext -> Double -> Guide -> Cairo.Render () renderGuide :: Colours -> Maybe HoverContext -> Double -> Guide -> Cairo.Render ()
renderGuide ( Colours {..} ) mbHoverContext zoom 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 = do
Cairo.save Cairo.save

View file

@ -30,7 +30,7 @@ import Math.Bezier.Spline
import Math.Module import Math.Module
( (*^), squaredNorm, closestPointOnSegment ) ( (*^), squaredNorm, closestPointOnSegment )
import Math.Linear import Math.Linear
( Point2D(..), Vector2D(..), Segment(..) ) ( (..), T(..), Segment(..) )
import MetaBrush.Document import MetaBrush.Document
( Stroke(..), PointData(..) ( Stroke(..), PointData(..)
, coords , coords
@ -39,13 +39,13 @@ import MetaBrush.Document
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Convert a position relative to the drawing area into viewport coordinates. -- | Convert a position relative to the drawing area into viewport coordinates.
toViewportCoordinates :: Double -> ( Double, Double ) -> Point2D Double -> Point2D Double -> Point2D Double toViewportCoordinates :: Double -> ( Double, Double ) -> 2 -> 2 -> 2
toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter ( Point2D x y ) toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter ( 2 x y )
= ( recip zoomFactor *^ ( Point2D ( 0.5 * viewportWidth ) ( 0.5 * viewportHeight ) --> Point2D x y :: Vector2D Double ) ) = ( recip zoomFactor *^ ( 2 ( 0.5 * viewportWidth ) ( 0.5 * viewportHeight ) --> 2 x y :: T ( 2 ) ) )
viewportCenter viewportCenter
-- | Find the closest point in a set of strokes. -- | 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 } ) = closestPoint c ( Stroke { strokeSpline, strokeVisible = True } ) =
coerce $ coerce $
bifoldSpline @_ @Identity bifoldSpline @_ @Identity
@ -53,8 +53,8 @@ closestPoint c ( Stroke { strokeSpline, strokeVisible = True } ) =
( res . coords ) ( res . coords )
strokeSpline strokeSpline
where where
res :: Point2D Double -> Identity ( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) ) res :: 2 -> Identity ( ArgMin BoundedDouble ( Maybe ( 2 ) ) )
res p = coerce $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p ) res p = coerce $ Arg ( squaredNorm ( c --> p :: T ( 2 ) ) ) ( Just p )
closestPointToCurve closestPointToCurve
:: forall clo crvData brushParams :: forall clo crvData brushParams
@ -62,18 +62,18 @@ closestPoint c ( Stroke { strokeSpline, strokeVisible = True } ) =
=> PointData brushParams => PointData brushParams
-> PointData brushParams -> PointData brushParams
-> Curve clo crvData ( PointData brushParams ) -> Curve clo crvData ( PointData brushParams )
-> Identity ( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) ) -> Identity ( ArgMin BoundedDouble ( Maybe ( 2 ) ) )
closestPointToCurve start p0 ( LineTo p1 _ ) = 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 $ closestPointToCurve start p0 ( Bezier2To p1 p2 _ ) = coerce $
fmap ( fmap ( Just . snd ) ) 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 $ closestPointToCurve start p0 ( Bezier3To p1 p2 p3 _ ) = coerce $
fmap ( fmap ( Just . snd ) ) fmap ( fmap ( Just . snd ) )
( Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier ( coords p0 ) ( coords p1 ) ( coords p2 ) ( coords $ fromNextPoint start p3 ) ) c ) ( Cubic.closestPoint @( T ( 2 ) ) ( Cubic.Bezier ( coords p0 ) ( coords p1 ) ( coords p2 ) ( coords $ fromNextPoint start p3 ) ) c )
closestPoint _ _ = coerce $ mempty @( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) ) 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 newtype BoundedDouble = BoundedDouble Double
deriving stock Show deriving stock Show
deriving newtype ( Eq, Ord ) deriving newtype ( Eq, Ord )

View file

@ -36,7 +36,7 @@ import qualified Data.Text as Text
-- MetaBrush -- MetaBrush
import Math.Linear import Math.Linear
( Point2D(..) ) ( (..) )
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( Colours ) ( Colours )
import MetaBrush.Asset.Cursor import MetaBrush.Asset.Cursor
@ -164,14 +164,14 @@ updateInfoBar viewportDrawingArea ( InfoBar {..} ) ( Variables { mousePosTVar }
GTK.labelSetText botRightPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na ) GTK.labelSetText botRightPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na )
Just ( Document { zoomFactor, viewportCenter } ) -> do Just ( Document { zoomFactor, viewportCenter } ) -> do
let let
toViewport :: Point2D Double -> Point2D Double toViewport :: 2 -> 2
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
Point2D l t = toViewport ( Point2D 0 0 ) 2 l t = toViewport ( 2 0 0 )
Point2D r b = toViewport ( Point2D viewportWidth viewportHeight ) 2 r b = toViewport ( 2 viewportWidth viewportHeight )
mbMousePos <- STM.readTVarIO mousePosTVar mbMousePos <- STM.readTVarIO mousePosTVar
GTK.labelSetText zoomText $ Text.pack ( fixed 5 2 ( 100 * zoomFactor ) <> "%" ) GTK.labelSetText zoomText $ Text.pack ( fixed 5 2 ( 100 * zoomFactor ) <> "%" )
case mbMousePos of 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 ) GTK.labelSetText cursorPosText $ Text.pack ( "x: " <> fixed 6 2 mx <> "\ny: " <> fixed 6 2 my )
Nothing -> Nothing ->
GTK.labelSetText cursorPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na ) GTK.labelSetText cursorPosText $ Text.pack ( "x: " <> na <> "\ny: " <> na )

View file

@ -40,7 +40,7 @@ import Math.Bezier.Spline
import Math.Bezier.Stroke import Math.Bezier.Stroke
( CachedStroke(..) ) ( CachedStroke(..) )
import Math.Linear import Math.Linear
( Point2D(..) ) ( (..) )
-- metabrushes -- metabrushes
import MetaBrush.Asset.Brushes import MetaBrush.Asset.Brushes
@ -140,7 +140,7 @@ main = case test of
Document Document
{ displayName = "beta" { displayName = "beta"
, mbFilePath = Just "betamf.mb" , mbFilePath = Just "betamf.mb"
, viewportCenter = Point2D 0 0 , viewportCenter = 2 0 0
, zoomFactor = 16 , zoomFactor = 16
, documentUnique = docUnique , documentUnique = docUnique
, documentContent = , documentContent =

View file

@ -66,7 +66,7 @@ import Math.Bezier.Stroke
import Math.Module import Math.Module
( lerp ) ( lerp )
import Math.Linear import Math.Linear
( Point2D(..), Vector2D(..) ) ( (..), T(..) )
-- metabrushes -- metabrushes
import MetaBrush.DSL.Interpolation import MetaBrush.DSL.Interpolation
@ -142,7 +142,7 @@ trailToSpline (Diagrams.Loc { Diagrams.loc = Linear.P ( Linear.V2 sx sy ), Diagr
where where
start :: PointData ptParams start :: PointData ptParams
start = PointData start = PointData
{ pointCoords = Point2D sx sy { pointCoords = 2 sx sy
, pointState = Normal , pointState = Normal
, brushParams = ptDatum , brushParams = ptDatum
} }
@ -157,9 +157,9 @@ trailToSpline (Diagrams.Loc { Diagrams.loc = Linear.P ( Linear.V2 sx sy ), Diagr
nextStart = nextStart =
case seg of case seg of
Diagrams.Linear ( Diagrams.OffsetClosed ( Linear.V2 ex ey ) ) -> 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 ) ) -> 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 :: Curve Open (CachedStroke RealWorld) (PointData ptParams)
curve = segmentToCurve p0 par1 seg curve = segmentToCurve p0 par1 seg
in in
@ -180,8 +180,8 @@ segmentToCurve p0@( PointData { brushParams = startParams } ) endParams = \case
} }
Diagrams.Cubic ( Linear.V2 x1 y1 ) ( Linear.V2 x2 y2 ) end -> Diagrams.Cubic ( Linear.V2 x1 y1 ) ( Linear.V2 x2 y2 ) end ->
Bezier3To Bezier3To
{ controlPoint1 = Vector2D x1 y1 ( p0 { brushParams = lerpParams (1/3) startParams endParams } ) { controlPoint1 = V2 x1 y1 ( p0 { brushParams = lerpParams (1/3) startParams endParams } )
, controlPoint2 = Vector2D x2 y2 ( p0 { brushParams = lerpParams (2/3) startParams endParams } ) , controlPoint2 = V2 x2 y2 ( p0 { brushParams = lerpParams (2/3) startParams endParams } )
, curveEnd = offsetToNextPoint ( p0 { brushParams = endParams } ) end , curveEnd = offsetToNextPoint ( p0 { brushParams = endParams } ) end
, curveData = noCache , curveData = noCache
} }
@ -196,7 +196,7 @@ offsetToNextPoint :: PointData ptParams
offsetToNextPoint _ Diagrams.OffsetOpen offsetToNextPoint _ Diagrams.OffsetOpen
= BackToStart = BackToStart
offsetToNextPoint p0 ( Diagrams.OffsetClosed ( Linear.V2 ex ey ) ) offsetToNextPoint p0 ( Diagrams.OffsetClosed ( Linear.V2 ex ey ) )
= NextPoint $ Vector2D ex ey p0 = NextPoint $ V2 ex ey p0
noCache :: CachedStroke RealWorld noCache :: CachedStroke RealWorld
noCache = runRW# \ s -> noCache = runRW# \ s ->

View file

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
module MetaBrush.Asset.Brushes where module MetaBrush.Asset.Brushes where
@ -23,7 +24,7 @@ import qualified Data.HashMap.Strict as HashMap
-- MetaBrush -- MetaBrush
import Math.Bezier.Spline import Math.Bezier.Spline
import Math.Linear import Math.Linear
( Point2D(..), (..), T(..) ) ( (..), T(..) )
import Math.Linear.Dual import Math.Linear.Dual
( D, type (~>)(..), Var(var), konst ) ( D, type (~>)(..), Var(var), konst )
import Math.Module import Math.Module
@ -34,8 +35,6 @@ import MetaBrush.Records
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
type CircleBrushFields = '[ "r" ]
lookupBrush :: Text -> Maybe SomeBrush lookupBrush :: Text -> Maybe SomeBrush
lookupBrush nm = HashMap.lookup nm brushes lookupBrush nm = HashMap.lookup nm brushes
@ -53,45 +52,25 @@ brushes = HashMap.fromList
κ :: Double κ :: Double
κ = 0.5519150244935105707435627227925 κ = 0.5519150244935105707435627227925
circleSpline :: (Double -> Double -> ptData) -> Spline 'Closed () ptData type CircleBrushFields = '[ "r" ]
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 ()
circle :: Brush CircleBrushFields circle :: Brush CircleBrushFields
circle = BrushData "circle" (WithParams deflts shape) circle = BrushData "circle" ( WithParams deflts circleBrush )
where where
deflts :: Record CircleBrushFields deflts :: Record CircleBrushFields
deflts = MkR ( 1 1 ) 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" ] type EllipseBrushFields = '[ "a", "b", "phi" ]
ellipse :: Brush EllipseBrushFields ellipse :: Brush EllipseBrushFields
ellipse = BrushData "ellipse" (WithParams deflts shape) ellipse = BrushData "ellipse" ( WithParams deflts ellipseBrush )
where where
deflts :: Record EllipseBrushFields deflts :: Record EllipseBrushFields
deflts = MkR ( 3 1 1 0 ) 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. -- Differentiable brushes.
circleSpline2 :: ( Double -> Double -> D ( 3 ) ptData ) -> D ( 3 ) ( Spline 'Closed () ptData ) circleSpline :: Applicative ( D u ) => ( Double -> Double -> D u v ) -> D u ( Spline 'Closed () v )
circleSpline2 p = sequenceA $ circleSpline p = sequenceA $
Spline { splineStart = p 1 0 Spline { splineStart = p 1 0
, splineCurves = ClosedCurves crvs lastCrv } , splineCurves = ClosedCurves crvs lastCrv }
where where
@ -103,24 +82,44 @@ circleSpline2 p = sequenceA $
lastCrv = lastCrv =
Bezier3To (p κ -1) (p 1 -κ) BackToStart () 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 = ellipseBrush =
D \ params -> D \ params ->
let a, b, phi :: D ( 3 ) Double let a, b, phi :: D ( Record EllipseBrushFields ) Double
a = runD ( var @1 ) params a = runD ( var @1 ) params
b = runD ( var @2 ) params b = runD ( var @2 ) params
phi = runD ( var @3 ) params phi = runD ( var @3 ) params
mkPt :: Double -> Double -> D ( 3 ) ( 2 ) mkPt :: Double -> Double -> D ( Record EllipseBrushFields ) ( 2 )
mkPt ( konst -> x ) ( konst -> y ) mkPt ( kon -> x ) ( kon -> y )
= fmap coerce = fmap coerce
$ ( x * a * cos phi - y * b * sin phi ) *^ e_x $ ( x * a * cos phi - y * b * sin phi ) *^ e_x
^+^ ( y * b * cos phi + x * a * sin phi ) *^ e_y ^+^ ( y * b * cos phi + x * a * sin phi ) *^ e_y
in circleSpline2 mkPt in circleSpline @( Record EllipseBrushFields ) mkPt
where 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_x = pure $ T $ 2 1 0
e_y = pure $ T $ 2 0 1 e_y = pure $ T $ 2 0 1
kon = konst @( Record EllipseBrushFields )
--ellipseArc :: 2 ~> 2 --ellipseArc :: 2 ~> 2
--ellipseArc = brushStroke ( linear myPath ) ( uncurryD $ fmap bezier3 myBrush ) --ellipseArc = brushStroke ( linear myPath ) ( uncurryD $ fmap bezier3 myBrush )

View file

@ -37,17 +37,19 @@ import qualified Data.Text as Text
( unpack ) ( unpack )
-- MetaBrush -- MetaBrush
import Math.Linear
import Math.Linear.Dual
( Diffy )
import Math.Bezier.Spline import Math.Bezier.Spline
( SplineType(Closed), SplinePts) ( SplineType(Closed), SplinePts)
import MetaBrush.Records import MetaBrush.Records
import MetaBrush.Serialisable import MetaBrush.Serialisable
import Math.Linear
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | A brush function: a function from a record of parameters to a closed spline. -- | A brush function: a function from a record of parameters to a closed spline.
type BrushFunction :: [ Symbol ] -> Type type BrushFunction :: [ Symbol ] -> Type
type BrushFunction brushFields = WithParams brushFields (SplinePts Closed) type BrushFunction brushFields = WithParams brushFields ( SplinePts Closed )
type Brush :: [ Symbol ] -> Type type Brush :: [ Symbol ] -> Type
data Brush brushFields where data Brush brushFields where
@ -55,6 +57,7 @@ data Brush brushFields where
:: forall brushFields :: forall brushFields
. ( KnownSymbols brushFields . ( KnownSymbols brushFields
, Representable ( ( Length brushFields) ) , Representable ( ( Length brushFields) )
, Diffy ( ( Length brushFields) )
, Typeable brushFields ) , Typeable brushFields )
=> { brushName :: !Text => { brushName :: !Text
, brushFunction :: BrushFunction brushFields , brushFunction :: BrushFunction brushFields

View file

@ -87,7 +87,7 @@ import Math.Module
, squaredNorm, quadrance , squaredNorm, quadrance
) )
import Math.Linear import Math.Linear
( Point2D(..), Vector2D(..) ) ( (..), T(..) )
import MetaBrush.Brush import MetaBrush.Brush
( Brush, PointFields ) ( Brush, PointFields )
import MetaBrush.Records import MetaBrush.Records
@ -98,12 +98,12 @@ import MetaBrush.Unique
data AABB data AABB
= AABB = AABB
{ topLeft, botRight :: !( Point2D Double ) } { topLeft, botRight :: !( 2 ) }
deriving stock ( Show, Generic ) deriving stock ( Show, Generic )
deriving anyclass NFData deriving anyclass NFData
mkAABB :: Point2D Double -> Point2D Double -> AABB mkAABB :: 2 -> 2 -> AABB
mkAABB ( Point2D x1 y1 ) ( Point2D x2 y2 ) = AABB ( Point2D xmin ymin ) ( Point2D xmax ymax ) mkAABB ( 2 x1 y1 ) ( 2 x2 y2 ) = AABB ( 2 xmin ymin ) ( 2 xmax ymax )
where where
( xmin, xmax ) ( xmin, xmax )
| x1 > x2 = ( x2, x1 ) | x1 > x2 = ( x2, x1 )
@ -117,7 +117,7 @@ data Document
= Document = Document
{ displayName :: !Text { displayName :: !Text
, mbFilePath :: !( Maybe FilePath ) , mbFilePath :: !( Maybe FilePath )
, viewportCenter :: !( Point2D Double ) , viewportCenter :: !( 2 )
, zoomFactor :: !Double , zoomFactor :: !Double
, documentUnique :: Unique , documentUnique :: Unique
, documentContent :: !DocumentContent , documentContent :: !DocumentContent
@ -217,14 +217,14 @@ overStrokeSpline f = coerce ( _strokeSpline @Identity ( coerce . f ) )
data PointData params data PointData params
= PointData = PointData
{ pointCoords :: !( Point2D Double ) { pointCoords :: !( 2 )
, pointState :: FocusState , pointState :: FocusState
, brushParams :: !params , brushParams :: !params
} }
deriving stock ( Show, Generic ) deriving stock ( Show, Generic )
deriving anyclass NFData deriving anyclass NFData
instance Act (Vector2D Double) (PointData params) where instance Act (T ( 2 )) (PointData params) where
v ( dat@( PointData { pointCoords = p } ) ) = v ( dat@( PointData { pointCoords = p } ) ) =
dat { pointCoords = v p } dat { pointCoords = v p }
@ -255,7 +255,7 @@ emptyDocument docName unique =
Document Document
{ displayName = docName { displayName = docName
, mbFilePath = Nothing , mbFilePath = Nothing
, viewportCenter = Point2D 0 0 , viewportCenter = 2 0 0
, zoomFactor = 1 , zoomFactor = 1
, documentUnique = unique , documentUnique = unique
, documentContent = , documentContent =
@ -270,29 +270,29 @@ emptyDocument docName unique =
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data HoverContext data HoverContext
= MouseHover !( Point2D Double ) = MouseHover !( 2 )
| RectangleHover !AABB | RectangleHover !AABB
deriving stock ( Show, Generic ) deriving stock ( Show, Generic )
deriving anyclass NFData deriving anyclass NFData
instance Act ( Vector2D Double ) HoverContext where instance Act ( T ( 2 ) ) HoverContext where
v MouseHover p = MouseHover ( v p ) v MouseHover p = MouseHover ( v p )
v RectangleHover ( AABB p1 p2 ) = RectangleHover ( AABB ( v p1 ) ( v p2 ) ) 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 ) () v = fmap ( v )
class Hoverable a where class Hoverable a where
hovered :: Maybe HoverContext -> Double -> a -> FocusState hovered :: Maybe HoverContext -> Double -> a -> FocusState
instance Hoverable ( Point2D Double ) where instance Hoverable ( 2 ) where
hovered Nothing _ _ = Normal hovered Nothing _ _ = Normal
hovered ( Just ( MouseHover p ) ) zoom q 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 = Hover
| otherwise | otherwise
= Normal = 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 | x >= x1 && x <= x2 && y >= y1 && y <= y2
= Hover = Hover
| otherwise | otherwise
@ -305,10 +305,10 @@ instance HasSelection ( PointData brushParams ) where
instance HasSelection BrushPointData where instance HasSelection BrushPointData where
_selection = field' @"brushPointState" _selection = field' @"brushPointState"
_coords :: Lens' ( PointData brushParams ) ( Point2D Double ) _coords :: Lens' ( PointData brushParams ) ( 2 )
_coords = field' @"pointCoords" _coords = field' @"pointCoords"
coords :: PointData brushParams -> Point2D Double coords :: PointData brushParams -> 2
coords = view _coords coords = view _coords
data FocusDifference data FocusDifference
@ -329,7 +329,7 @@ instance Group FocusDifference where
data DiffPointData diffBrushParams data DiffPointData diffBrushParams
= DiffPointData = DiffPointData
{ diffVector :: !( Vector2D Double ) { diffVector :: !( T ( 2 ) )
, diffParams :: !diffBrushParams , diffParams :: !diffBrushParams
, diffState :: !FocusDifference , diffState :: !FocusDifference
} }
@ -371,8 +371,8 @@ instance Module Double brushParams => Module Double ( DiffPointData brushParams
data Guide data Guide
= Guide = Guide
{ guidePoint :: !( Point2D Double ) -- ^ point on the guide line { guidePoint :: !( 2 ) -- ^ point on the guide line
, guideNormal :: !( Vector2D Double ) -- ^ /normalised/ normal vector of the guide , guideNormal :: !( T ( 2 ) ) -- ^ /normalised/ normal vector of the guide
, guideFocus :: !FocusState , guideFocus :: !FocusState
, guideUnique :: Unique , guideUnique :: Unique
} }
@ -386,11 +386,11 @@ data Ruler
deriving stock Show deriving stock Show
-- | Try to select a guide at the given document coordinates. -- | 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 } } ) = selectedGuide c ( Document { zoomFactor, documentContent = Content { guides } } ) =
\case { Min ( Arg _ g ) -> g } <$> foldMap ( selectGuide_maybe c zoomFactor ) 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 } ) selectGuide_maybe c zoom guide@( Guide { guidePoint = p, guideNormal = n } )
| sqDist * zoom ^ ( 2 :: Int ) < 4 | sqDist * zoom ^ ( 2 :: Int ) < 4
= Just ( Min ( Arg sqDist guide ) ) = 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 sqDist = t ^ ( 2 :: Int ) / squaredNorm n
-- | Add new guide after a mouse drag from a ruler area. -- | 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 addGuide uniqueSupply ruler p doc = ( `runReaderT` uniqueSupply ) $ ( field' @"documentContent" . field' @"guides" ) insertNewGuides doc
where where
insertNewGuides :: Map Unique Guide -> ReaderT UniqueSupply STM ( Map Unique Guide ) 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 uniq2 <- freshUnique
let let
guide1, guide2 :: Guide guide1, guide2 :: 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 }
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 . Map.insert uniq1 guide1 $ gs ) pure ( Map.insert uniq2 guide2 . Map.insert uniq1 guide1 $ gs )
TopRuler TopRuler
-> do -> do
uniq1 <- freshUnique uniq1 <- freshUnique
let let
guide1 :: Guide 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 ) pure ( Map.insert uniq1 guide1 gs )
LeftRuler LeftRuler
-> do -> do
uniq2 <- freshUnique uniq2 <- freshUnique
let let
guide2 :: Guide 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 ) pure ( Map.insert uniq2 guide2 gs )
instance Hoverable Guide where instance Hoverable Guide where

View file

@ -59,7 +59,7 @@ import Math.Bezier.Spline
import Math.Module import Math.Module
( squaredNorm ) ( squaredNorm )
import Math.Linear import Math.Linear
( Point2D(..), Vector2D(..), (..) ) ( (..), T(..) )
import MetaBrush.Assert import MetaBrush.Assert
( assert ) ( assert )
import MetaBrush.Brush import MetaBrush.Brush
@ -94,9 +94,9 @@ anchorsAreComplementary _ _ = False
getOrCreateDrawAnchor getOrCreateDrawAnchor
:: UniqueSupply :: UniqueSupply
-> Point2D Double -> 2
-> Document -> Document
-> STM ( Document, DrawAnchor, Point2D Double, Maybe Text ) -> STM ( Document, DrawAnchor, 2, Maybe Text )
getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
case case
( `runState` Nothing ) ( `runState` Nothing )
@ -135,13 +135,13 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
-- Deselect all points, and try to find a valid anchor for drawing -- Deselect all points, and try to find a valid anchor for drawing
-- (a path start/end point at mouse click point). -- (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 updateStrokeHierarchy ( StrokeGroup { .. } ) = do
newContents <- traverse updateStrokeHierarchy groupContents newContents <- traverse updateStrokeHierarchy groupContents
pure ( StrokeGroup { groupContents = newContents, .. } ) pure ( StrokeGroup { groupContents = newContents, .. } )
updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf 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 updateStroke stroke@( Stroke { strokeName, strokeVisible, strokeUnique } ) = _strokeSpline updateStrokeSpline stroke
where where
@ -149,7 +149,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
:: forall clo brushParams :: forall clo brushParams
. SplineTypeI clo . SplineTypeI clo
=> StrokeSpline clo brushParams => StrokeSpline clo brushParams
-> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) ( StrokeSpline clo brushParams ) -> State ( Maybe ( ( DrawAnchor, 2 ), Text ) ) ( StrokeSpline clo brushParams )
updateStrokeSpline spline = do updateStrokeSpline spline = do
mbAnchor <- get mbAnchor <- get
@ -167,24 +167,24 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
where where
-- See if we can anchor a drawing operation on a given (visible) stroke. -- 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 endpointAnchor uniq ( Spline { splineStart, splineCurves } ) = case ssplineType @clo of
SOpen SOpen
| let | let
p0 :: Point2D Double p0 :: 2
p0 = coords splineStart p0 = coords splineStart
, inPointClickRange p0 , inPointClickRange p0
-> Just ( AnchorAtStart uniq, p0 ) -> Just ( AnchorAtStart uniq, p0 )
| OpenCurves ( _ :|> lastCurve ) <- splineCurves | OpenCurves ( _ :|> lastCurve ) <- splineCurves
, let , let
pn :: Point2D Double pn :: 2
pn = coords ( openCurveEnd lastCurve ) pn = coords ( openCurveEnd lastCurve )
, inPointClickRange pn , inPointClickRange pn
-> Just ( AnchorAtEnd uniq, pn ) -> Just ( AnchorAtEnd uniq, pn )
_ -> Nothing _ -> Nothing
inPointClickRange :: Point2D Double -> Bool inPointClickRange :: 2 -> Bool
inPointClickRange p = 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 :: DrawAnchor -> StrokeSpline Open () -> Document -> Document
addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strokes" . mapped ) updateStrokeHierarchy addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strokes" . mapped ) updateStrokeHierarchy

View file

@ -106,7 +106,7 @@ import qualified Waargonaut.Types.Whitespace as JSON
import Math.Bezier.Spline import Math.Bezier.Spline
( SplineType(..), SSplineType(..), SplineTypeI(..) ) ( SplineType(..), SSplineType(..), SplineTypeI(..) )
import Math.Linear import Math.Linear
( Point2D(..), Vector2D(..)) ( (..), T(..) )
import MetaBrush.Asset.Brushes import MetaBrush.Asset.Brushes
( lookupBrush ) ( lookupBrush )
import MetaBrush.Brush import MetaBrush.Brush
@ -192,8 +192,8 @@ encodePointData
) )
=> JSON.Encoder f ( PointData brushParams ) => JSON.Encoder f ( PointData brushParams )
encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointCoords, brushParams } ) -> encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointCoords, brushParams } ) ->
JSON.Encoder.atKey' "coords" ( encoder @( Point2D Double ) ) pointCoords JSON.Encoder.atKey' "coords" ( encoder @( 2 ) ) pointCoords
. JSON.Encoder.atKey' "brushParams" ( encoder @( Record flds ) ) brushParams . JSON.Encoder.atKey' "brushParams" ( encoder @( Record flds ) ) brushParams
decodePointData decodePointData
:: forall m ( flds :: [ Symbol ] ) brushParams :: forall m ( flds :: [ Symbol ] ) brushParams
@ -203,7 +203,7 @@ decodePointData
) )
=> JSON.Decoder m ( PointData brushParams ) => JSON.Decoder m ( PointData brushParams )
decodePointData = do decodePointData = do
pointCoords <- JSON.Decoder.atKey "coords" ( decoder @( Point2D Double ) ) pointCoords <- JSON.Decoder.atKey "coords" ( decoder @( 2 ) )
let let
pointState :: FocusState pointState :: FocusState
pointState = Normal pointState = Normal
@ -318,13 +318,13 @@ decodeStrokeHierarchy uniqueSupply = do
encodeGuide :: Applicative f => JSON.Encoder f Guide encodeGuide :: Applicative f => JSON.Encoder f Guide
encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) -> encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) ->
JSON.Encoder.atKey' "point" ( encoder @( Point2D Double ) ) guidePoint JSON.Encoder.atKey' "point" ( encoder @( 2 ) ) guidePoint
. JSON.Encoder.atKey' "normal" ( encoder @( Vector2D Double ) ) guideNormal . JSON.Encoder.atKey' "normal" ( encoder @( T ( 2 ) ) ) guideNormal
decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m Guide decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m Guide
decodeGuide uniqueSupply = do decodeGuide uniqueSupply = do
guidePoint <- JSON.Decoder.atKey "point" ( decoder @( Point2D Double ) ) guidePoint <- JSON.Decoder.atKey "point" ( decoder @( 2 ) )
guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( Vector2D Double ) ) guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( T ( 2 ) ) )
let let
guideFocus :: FocusState guideFocus :: FocusState
guideFocus = Normal guideFocus = Normal
@ -356,14 +356,14 @@ encodeDocument = JSON.Encoder.mapLikeObj
\ ( Document { displayName, viewportCenter, zoomFactor, documentContent } ) -> \ ( Document { displayName, viewportCenter, zoomFactor, documentContent } ) ->
JSON.Encoder.atKey' "version" ( JSON.Encoder.list JSON.Encoder.int ) ( versionBranch Cabal.version ) JSON.Encoder.atKey' "version" ( JSON.Encoder.list JSON.Encoder.int ) ( versionBranch Cabal.version )
. JSON.Encoder.atKey' "name" JSON.Encoder.text displayName . 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' "zoom" ( encoder @Double ) zoomFactor
. JSON.Encoder.atKey' "content" encodeDocumentContent documentContent . JSON.Encoder.atKey' "content" encodeDocumentContent documentContent
decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document
decodeDocument uniqueSupply mbFilePath = do decodeDocument uniqueSupply mbFilePath = do
displayName <- JSON.Decoder.atKey "name" JSON.Decoder.text 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 ) zoomFactor <- JSON.Decoder.atKey "zoom" ( decoder @Double )
documentUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply ) documentUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
documentContent <- JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply ) documentContent <- JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply )

View file

@ -51,7 +51,7 @@ import Math.Bezier.Stroke
import Math.Module import Math.Module
( lerp, quadrance, closestPointOnSegment ) ( lerp, quadrance, closestPointOnSegment )
import Math.Linear import Math.Linear
( Point2D(..), Vector2D(..), Segment(..), T(..) ) ( Segment(..), (..), T(..) )
import MetaBrush.Document import MetaBrush.Document
( Document(..), Stroke(..), StrokeHierarchy(..), StrokeSpline ( Document(..), Stroke(..), StrokeHierarchy(..), StrokeSpline
, PointData(..), DiffPointData(..) , PointData(..), DiffPointData(..)
@ -63,7 +63,7 @@ import MetaBrush.Records
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Subdivide a path at the given center, provided a path indeed lies there. -- | 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 } ) = subdivide c doc@( Document { zoomFactor } ) =
let let
updatedDoc :: Document updatedDoc :: Document
@ -95,14 +95,14 @@ subdivide c doc@( Document { zoomFactor } ) =
| otherwise | otherwise
= fmap ( \ curves -> adjustSplineType @clo $ Spline { splineStart, splineCurves = OpenCurves curves } ) = fmap ( \ curves -> adjustSplineType @clo $ Spline { splineStart, splineCurves = OpenCurves curves } )
$ bifoldSpline $ bifoldSpline
( updateCurve ( "stroke " <> strokeName ) ( Vector2D 0 0 ) ) ( updateCurve ( "stroke " <> strokeName ) ( V2 0 0 ) )
( const $ pure Empty ) ( const $ pure Empty )
( adjustSplineType @Open spline ) ( adjustSplineType @Open spline )
where where
updateCurve updateCurve
:: Text :: Text
-> Vector2D Double -> T ( 2 )
-> PointData brushParams -> PointData brushParams
-> Curve Open ( CachedStroke RealWorld ) ( PointData brushParams ) -> Curve Open ( CachedStroke RealWorld ) ( PointData brushParams )
-> State ( Maybe Text ) -> State ( Maybe Text )
@ -110,13 +110,13 @@ subdivide c doc@( Document { zoomFactor } ) =
updateCurve txt offset sp0 curve = case curve of updateCurve txt offset sp0 curve = case curve of
line@( LineTo ( NextPoint sp1 ) dat ) -> line@( LineTo ( NextPoint sp1 ) dat ) ->
let let
p0, p1, s :: Point2D Double p0, p1, s :: 2
t :: Double t :: Double
p0 = coords sp0 p0 = coords sp0
p1 = coords sp1 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 :: 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 in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
then then
let let
@ -128,13 +128,13 @@ subdivide c doc@( Document { zoomFactor } ) =
else pure $ Seq.singleton line else pure $ Seq.singleton line
bez2@( Bezier2To sp1 ( NextPoint sp2 ) dat ) -> bez2@( Bezier2To sp1 ( NextPoint sp2 ) dat ) ->
let let
p0, p1, p2 :: Point2D Double p0, p1, p2 :: 2
p0 = coords sp0 p0 = coords sp0
p1 = coords sp1 p1 = coords sp1
p2 = coords sp2 p2 = coords sp2
sqDist :: Double sqDist :: Double
Min ( Arg sqDist ( t, _ ) ) 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 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 then case Quadratic.subdivide @( DiffPointData ( T brushParams ) ) ( Quadratic.Bezier sp0 sp1 sp2 ) t of
( Quadratic.Bezier _ q1 subdiv, Quadratic.Bezier _ r1 _ ) -> do ( Quadratic.Bezier _ q1 subdiv, Quadratic.Bezier _ r1 _ ) -> do
@ -147,13 +147,13 @@ subdivide c doc@( Document { zoomFactor } ) =
else pure $ Seq.singleton bez2 else pure $ Seq.singleton bez2
bez3@( Bezier3To sp1 sp2 ( NextPoint sp3 ) dat ) -> bez3@( Bezier3To sp1 sp2 ( NextPoint sp3 ) dat ) ->
let let
p0, p1, p2, p3 :: Point2D Double p0, p1, p2, p3 :: 2
p0 = coords sp0 p0 = coords sp0
p1 = coords sp1 p1 = coords sp1
p2 = coords sp2 p2 = coords sp2
p3 = coords sp3 p3 = coords sp3
Min ( Arg sqDist ( t, _ ) ) 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 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 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 ( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) -> do

View file

@ -49,6 +49,7 @@ import qualified Data.Text as Text
-- MetaBrush -- MetaBrush
import Math.Linear import Math.Linear
import Math.Linear.Dual
import Math.Module import Math.Module
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -66,7 +67,7 @@ type WithParams :: [ Symbol ] -> Type -> Type
data WithParams params a = data WithParams params a =
WithParams WithParams
{ defaultParams :: Record params { 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 => Torsor ( T ( Record ks ) ) ( Record ks ) where
MkR g --> MkR a = T $ MkR $ unT $ g --> a 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 type Length :: [ k ] -> Nat

View file

@ -82,7 +82,7 @@ import Math.Bezier.Spline
import Math.Bezier.Stroke import Math.Bezier.Stroke
( CachedStroke(..) ) ( CachedStroke(..) )
import Math.Linear import Math.Linear
( Point2D(..), Vector2D(..), (..) ( (..), T(..)
, Fin(..), Representable(tabulate, index) , Fin(..), Representable(tabulate, index)
) )
import MetaBrush.Records import MetaBrush.Records
@ -99,17 +99,17 @@ instance Serialisable Double where
encoder = contramap Scientific.fromFloatDigits JSON.Encoder.scientific encoder = contramap Scientific.fromFloatDigits JSON.Encoder.scientific
decoder = fmap Scientific.toRealFloat JSON.Decoder.scientific decoder = fmap Scientific.toRealFloat JSON.Decoder.scientific
instance Serialisable a => Serialisable ( Point2D a ) where instance Serialisable ( 2 ) where
encoder = JSON.Encoder.mapLikeObj \ ( Point2D x y ) -> encoder = JSON.Encoder.mapLikeObj \ ( 2 x y ) ->
JSON.Encoder.atKey' "x" encoder x JSON.Encoder.atKey' "x" encoder x
. JSON.Encoder.atKey' "y" encoder y . 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 instance Serialisable ( T ( 2 ) ) where
encoder = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) -> encoder = JSON.Encoder.mapLikeObj \ ( V2 x y ) ->
JSON.Encoder.atKey' "x" encoder x JSON.Encoder.atKey' "x" encoder x
. JSON.Encoder.atKey' "y" encoder y . 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 instance ( KnownSymbols ks, Representable ( ( Length ks ) ) ) => Serialisable ( Record ks ) where
encoder = contramap encodeFields ( JSON.Encoder.keyValueTupleFoldable ( encoder @Double ) ) encoder = contramap encodeFields ( JSON.Encoder.keyValueTupleFoldable ( encoder @Double ) )
where where

View file

@ -62,7 +62,7 @@ import Math.Module
import Math.Roots import Math.Roots
( realRoots, solveQuadratic ) ( realRoots, solveQuadratic )
import Math.Linear import Math.Linear
( Point2D(..), Vector2D(..), T(..) ) ( (..), T(..) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -138,12 +138,12 @@ squaredCurvature bez t
sq_nm_g' = squaredNorm @v g' sq_nm_g' = squaredNorm @v g'
-- | Signed curvature of a planar cubic Bézier curve. -- | 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 ) signedCurvature bez t = ( g' `cross` g'' ) / norm g' ^ ( 3 :: Int )
where where
g', g'' :: Vector2D r g', g'' :: T ( 2 )
g' = bezier' @( Vector2D r ) bez t g' = bezier' @( T ( 2 ) ) bez t
g'' = bezier'' @( Vector2D r ) bez t g'' = bezier'' @( T ( 2 ) ) bez t
-- | Subdivide a cubic Bézier curve into two parts. -- | 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 ) 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: -- Formula taken from:
-- "A Basis for the Implicit Representation of Planar Rational Cubic Bézier Curves" -- "A Basis for the Implicit Representation of Planar Rational Cubic Bézier Curves"
-- Oliver J. D. Barrowclough, 2016 -- Oliver J. D. Barrowclough, 2016
selfIntersectionParameters :: forall r. RealFloat r => Bezier ( Point2D r ) -> [ r ] selfIntersectionParameters :: Bezier ( 2 ) -> [ Double ]
selfIntersectionParameters ( Bezier {..} ) = solveQuadratic c0 c1 c2 selfIntersectionParameters ( Bezier {..} ) = solveQuadratic c0 c1 c2
where where
areaConstant :: Point2D r -> Point2D r -> Point2D r -> r areaConstant :: 2 -> 2 -> 2 -> Double
areaConstant ( Point2D x1 y1 ) ( Point2D x2 y2 ) ( Point2D x3 y3 ) = areaConstant ( 2 x1 y1 ) ( 2 x2 y2 ) ( 2 x3 y3 ) =
x1 * ( y2 - y3 ) + x2 * ( y3 - y1 ) + x3 * ( y1 - y2 ) 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 l0 = areaConstant p3 p2 p1
l1 = areaConstant p2 p3 p0 l1 = areaConstant p2 p3 p0
l2 = areaConstant p1 p0 p3 l2 = areaConstant p1 p0 p3

View file

@ -80,7 +80,7 @@ import Math.Module
import Math.Roots import Math.Roots
( laguerre ) --, eval, derivative ) ( laguerre ) --, eval, derivative )
import Math.Linear import Math.Linear
( Mat22(..), Point2D(..), Vector2D(..) ) ( Mat22(..), (..), T(..) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -97,10 +97,10 @@ data FitParameters
data FitPoint data FitPoint
= FitPoint = FitPoint
{ fitPoint :: !( Point2D Double ) } { fitPoint :: !( 2 ) }
| FitTangent | FitTangent
{ fitPoint :: !( Point2D Double ) { fitPoint :: !( 2 )
, fitTangent :: !( Vector2D Double ) , fitTangent :: !( T ( 2 ) )
} }
deriving stock ( Show, Generic ) deriving stock ( Show, Generic )
deriving anyclass NFData deriving anyclass NFData
@ -120,7 +120,7 @@ data FitPoint
-- including the meaning of \( \texttt{t_tol} \) and \( \texttt{maxIters} \). -- including the meaning of \( \texttt{t_tol} \) and \( \texttt{maxIters} \).
fitSpline fitSpline
:: FitParameters :: 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 ) -> ( SplinePts Open, Seq FitPoint )
fitSpline ( FitParameters {..} ) = go 0 fitSpline ( FitParameters {..} ) = go 0
where where
@ -128,13 +128,13 @@ fitSpline ( FitParameters {..} ) = go 0
dt = recip ( fromIntegral nbSegments ) dt = recip ( fromIntegral nbSegments )
go go
:: Int :: Int
-> ( Double -> ( Point2D Double, Vector2D Double ) ) -> ( Double -> ( 2, T ( 2 ) ) )
-> ( SplinePts Open, Seq FitPoint ) -> ( SplinePts Open, Seq FitPoint )
go subdiv curveFn = go subdiv curveFn =
let let
p, r :: Point2D Double p, r :: 2
tp, tr :: Vector2D Double tp, tr :: T ( 2 )
qs :: [ Point2D Double ] qs :: [ 2 ]
(p, tp) = curveFn 0 (p, tp) = curveFn 0
(r, tr) = curveFn 1 (r, tr) = curveFn 1
qs = [ fst $ curveFn ( dt * fromIntegral j ) | j <- [ 1 .. nbSegments - 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 \), -- of its corresponding point to fit \( q_i \),
-- * the maximum iteration limit \( \texttt{maxIters} \) has been reached. -- * the maximum iteration limit \( \texttt{maxIters} \) has been reached.
fitPiece fitPiece
:: Double -- ^ \( \texttt{dist_tol} \), tolerance for the distance :: Double -- ^ \( \texttt{dist_tol} \), tolerance for the distance
-> Double -- ^ \( \texttt{t_tol} \), the tolerance for the Bézier parameter -> Double -- ^ \( \texttt{t_tol} \), the tolerance for the Bézier parameter
-> Int -- ^ \( \texttt{maxIters} \), maximum number of iterations -> Int -- ^ \( \texttt{maxIters} \), maximum number of iterations
-> Point2D Double -- ^ \( p \), start point -> 2 -- ^ \( p \), start point
-> Vector2D Double -- ^ \( \textrm{t}_p \), start tangent vector (length is ignored) -> T ( 2 ) -- ^ \( \textrm{t}_p \), start tangent vector (length is ignored)
-> [ Point2D Double ] -- ^ \( \left ( q_i \right )_{i=1}^n \), points to fit -> [ 2 ] -- ^ \( \left ( q_i \right )_{i=1}^n \), points to fit
-> Point2D Double -- ^ \( r \), end point -> 2 -- ^ \( r \), end point
-> Vector2D Double -- ^ \( \textrm{t}_r \), end tangent vector (length is ignored) -> T ( 2 ) -- ^ \( \textrm{t}_r \), end tangent vector (length is ignored)
-> ( Cubic.Bezier ( Point2D Double ), ArgMax Double Double ) -> ( Cubic.Bezier ( 2 ), ArgMax Double Double )
fitPiece dist_tol t_tol maxIters p tp qs r tr = fitPiece dist_tol t_tol maxIters p tp qs r tr =
runST do runST do
-- Initialise the parameter values to a uniform subdivision. -- 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 :: Int -> Double
uniform i = fromIntegral ( i + 1 ) / fromIntegral ( n + 1 ) 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 f0 t = h1 t *^ tp
f1 t = h2 t *^ tr f1 t = h2 t *^ tr
f2 t = h0 t *^ ( MkVector2D p ) f2 t = h0 t *^ ( T p )
f3 t = h3 t *^ ( MkVector2D r ) 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 loop ts count = do
let let
hermiteParameters :: Mat22 Double -> Vector2D Double -> Int -> [ Point2D Double ] -> ST s ( Vector2D Double ) hermiteParameters :: Mat22 -> T ( 2 ) -> Int -> [ 2 ] -> ST s ( T ( 2 ) )
hermiteParameters ( Mat22 a11 a12 _ a22 ) ( Vector2D b1 b2 ) i ( q : rest ) = do hermiteParameters ( Mat22 a11 a12 _ a22 ) ( V2 b1 b2 ) i ( q : rest ) = do
ti <- Unboxed.MVector.unsafeRead ts i ti <- Unboxed.MVector.unsafeRead ts i
let let
f0i, f1i, f2i, f3i :: Vector2D Double f0i, f1i, f2i, f3i :: T ( 2 )
f0i = f0 ti f0i = f0 ti
f1i = f1 ti f1i = f1 ti
f2i = f2 ti f2i = f2 ti
f3i = f3 ti f3i = f3 ti
q' = MkVector2D q ^-^ f2i ^-^ f3i q' = T q ^-^ f2i ^-^ f3i
a11', a12', a21', a22', b1', b2' :: Double a11', a12', a21', a22', b1', b2' :: Double
a11' = a11 + ( f0i ^.^ f0i ) a11' = a11 + ( f0i ^.^ f0i )
a12' = a12 + ( f1i ^.^ f0i ) a12' = a12 + ( f1i ^.^ f0i )
@ -233,18 +233,18 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr =
a22' = a22 + ( f1i ^.^ f1i ) a22' = a22 + ( f1i ^.^ f1i )
b1' = b1 + ( q' ^.^ f0i ) b1' = b1 + ( q' ^.^ f0i )
b2' = b2 + ( q' ^.^ f1i ) 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 ) 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 let
-- Convert from Hermite form to Bézier form. -- Convert from Hermite form to Bézier form.
cp1, cp2 :: Point2D Double cp1, cp2 :: 2
cp1 = ( ( s1 / 3 ) *^ tp ) p cp1 = ( ( s1 / 3 ) *^ tp ) p
cp2 = ( ( -s2 / 3 ) *^ tr ) r cp2 = ( ( -s2 / 3 ) *^ tr ) r
bez :: Cubic.Bezier ( Point2D Double ) bez :: Cubic.Bezier ( 2 )
bez = Cubic.Bezier p cp1 cp2 r bez = Cubic.Bezier p cp1 cp2 r
-- Run one iteration of Laguerre's method to improve the parameter values t_i, -- 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 :: Complex Double
laguerreStepResult = runST do laguerreStepResult = runST do
coeffs <- unsafeThawPrimArray . primArrayFromListN 6 coeffs <- unsafeThawPrimArray . primArrayFromListN 6
$ Cubic.ddist @( Vector2D Double ) bez q $ Cubic.ddist @( T ( 2 ) ) bez q
laguerre epsilon 1 coeffs ( ti :+ 0 ) laguerre epsilon 1 coeffs ( ti :+ 0 )
ti' <- case laguerreStepResult of ti' <- case laguerreStepResult of
x :+ y x :+ y
@ -272,7 +272,7 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr =
$> ( min 1 $ max 0 x ) $> ( min 1 $ max 0 x )
let let
sq_dist :: Double 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' ) ) ) modify' ( second ( <> Max ( Arg sq_dist ti' ) ) )
lift ( Unboxed.MVector.unsafeWrite ts i ti' ) lift ( Unboxed.MVector.unsafeWrite ts i ti' )

View file

@ -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

View file

@ -59,7 +59,7 @@ import Math.Module
import Math.Roots import Math.Roots
( realRoots ) ( realRoots )
import Math.Linear import Math.Linear
( Point2D(..), Vector2D(..), T(..) ) ( (..), T(..) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -117,12 +117,12 @@ squaredCurvature bez t
sq_nm_g' = squaredNorm @v g' sq_nm_g' = squaredNorm @v g'
-- | Signed curvature of a planar quadratic Bézier curve. -- | 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 ) signedCurvature bez t = ( g' `cross` g'' ) / norm g' ^ ( 3 :: Int )
where where
g', g'' :: Vector2D r g', g'' :: T ( 2 )
g' = bezier' @( Vector2D r ) bez t g' = bezier' @( T ( 2 ) ) bez t
g'' = bezier'' @( Vector2D r ) bez g'' = bezier'' @( T ( 2 ) ) bez
-- | Subdivide a quadratic Bézier curve into two parts. -- | 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 ) subdivide :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> ( Bezier p, Bezier p )

View file

@ -56,7 +56,7 @@ import Control.Monad.Trans.State.Strict
import qualified Math.Bezier.Cubic as Cubic import qualified Math.Bezier.Cubic as Cubic
( Bezier(..) ) ( Bezier(..) )
import Math.Linear import Math.Linear
( Point2D ) ( (..) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -215,8 +215,7 @@ instance KnownSplineType clo => Bifoldable ( Spline clo ) where
instance KnownSplineType clo => Bitraversable ( Spline clo ) where instance KnownSplineType clo => Bitraversable ( Spline clo ) where
bitraverse fc fp = bitraverseSpline ( const $ bitraverse fc fp ) fp bitraverse fc fp = bitraverseSpline ( const $ bitraverse fc fp ) fp
type SplinePts clo = Spline clo () ( Point2D Double ) type SplinePts clo = Spline clo () ( 2 )
bimapCurve bimapCurve
:: Functor ( NextPoint clo ) :: Functor ( NextPoint clo )

View file

@ -120,7 +120,7 @@ data Offset
= Offset = Offset
{ offsetIndex :: !Int { offsetIndex :: !Int
, offsetParameter :: !( Maybe Double ) , offsetParameter :: !( Maybe Double )
, offset :: !( Vector2D Double ) , offset :: !( T ( 2 ) )
} }
deriving stock ( Show, Generic ) deriving stock ( Show, Generic )
deriving anyclass NFData deriving anyclass NFData
@ -143,7 +143,7 @@ instance Monoid OutlineData where
mempty = TwoSided empt empt mempty = TwoSided empt empt
where where
empt :: ( SplinePts Open, Seq FitPoint ) 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 ) } newtype CachedStroke s = CachedStroke { cachedStrokeRef :: STRef s ( Maybe OutlineData ) }
instance Show ( CachedStroke s ) where instance Show ( CachedStroke s ) where
@ -163,7 +163,7 @@ invalidateCache = runRW# \ s ->
set ( typed @( CachedStroke RealWorld ) ) set ( typed @( CachedStroke RealWorld ) )
( CachedStroke $ STRef mutVar ) ( CachedStroke $ STRef mutVar )
coords :: forall ptData. HasType ( Point2D Double ) ptData => ptData -> Point2D Double coords :: forall ptData. HasType ( 2 ) ptData => ptData -> 2
coords = view typed coords = view typed
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -174,7 +174,7 @@ computeStrokeOutline ::
, Group diffParams , Group diffParams
, Module Double diffParams , Module Double diffParams
, Torsor diffParams brushParams , Torsor diffParams brushParams
, HasType ( Point2D Double ) ptData , HasType ( 2 ) ptData
, HasType ( CachedStroke s ) crvData , HasType ( CachedStroke s ) crvData
, NFData ptData, NFData crvData , NFData ptData, NFData crvData
-- Debugging. -- Debugging.
@ -199,7 +199,7 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
, let , let
endPt :: ptData endPt :: ptData
endPt = openCurveEnd lastCurve endPt = openCurveEnd lastCurve
startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: Vector2D Double startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: T ( 2 )
startTgtFwd = snd ( firstOutlineFwd 0 ) startTgtFwd = snd ( firstOutlineFwd 0 )
startTgtBwd = -1 *^ snd ( firstOutlineBwd 1 ) startTgtBwd = -1 *^ snd ( firstOutlineBwd 1 )
endTgtFwd = snd ( lastOutlineFwd 1 ) endTgtFwd = snd ( lastOutlineFwd 1 )
@ -209,36 +209,36 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
endBrush = brushShape endPt endBrush = brushShape endPt
-- Computation of which brush segment to use for the end caps. -- 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 ) startTgt = coords spt0 --> coords ( openCurveStart firstCurve )
endTgt = case prevCurves of endTgt = case prevCurves of
Empty -> endTangent spt0 spt0 lastCurve Empty -> endTangent spt0 spt0 lastCurve
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve _ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
startTestTgt, endTestTgt :: Vector2D Double startTestTgt, endTestTgt :: T ( 2 )
startTestTgt = Vector2D sty -stx startTestTgt = V2 sty -stx
where where
stx, sty :: Double stx, sty :: Double
Vector2D stx sty = startTgt V2 stx sty = startTgt
endTestTgt = Vector2D ety -etx endTestTgt = V2 ety -etx
where where
etx, ety :: Double etx, ety :: Double
Vector2D etx ety = endTgt V2 etx ety = endTgt
startCap, endCap :: SplinePts Open startCap, endCap :: SplinePts Open
startCap startCap
| isJust $ between CCW startTgtBwd startTgtFwd startTestTgt | isJust $ between CCW startTgtBwd startTgtFwd startTestTgt
= fmap ( MkVector2D ( coords spt0 ) ) = fmap ( T ( coords spt0 ) )
$ joinWithBrush startBrush startTgtBwd startTgtFwd $ joinWithBrush startBrush startTgtBwd startTgtFwd
| otherwise | otherwise
= fmap ( MkVector2D ( coords spt0 ) ) = fmap ( T ( coords spt0 ) )
. reverseSpline . reverseSpline
$ joinWithBrush startBrush startTgtFwd startTgtBwd $ joinWithBrush startBrush startTgtFwd startTgtBwd
endCap endCap
| isJust $ between CCW endTgtBwd endTgtFwd endTestTgt | isJust $ between CCW endTgtBwd endTgtFwd endTestTgt
= fmap ( MkVector2D ( coords endPt ) ) = fmap ( T ( coords endPt ) )
$ joinWithBrush endBrush endTgtFwd endTgtBwd $ joinWithBrush endBrush endTgtFwd endTgtBwd
| otherwise | otherwise
= fmap ( MkVector2D ( coords endPt ) ) = fmap ( T ( coords endPt ) )
. reverseSpline . reverseSpline
$ joinWithBrush endBrush endTgtBwd endTgtFwd $ joinWithBrush endBrush endTgtBwd endTgtFwd
@ -255,7 +255,7 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
, ( firstOutlineFwd, firstOutlineBwd ) :<| _ <- outlineFns , ( firstOutlineFwd, firstOutlineBwd ) :<| _ <- outlineFns
, _ :|> ( lastOutlineFwd, lastOutlineBwd ) <- outlineFns , _ :|> ( lastOutlineFwd, lastOutlineBwd ) <- outlineFns
, let , let
startTgt, endTgt, startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: Vector2D Double startTgt, endTgt, startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: T ( 2 )
startTgt = case prevCurves of startTgt = case prevCurves of
Empty -> startTangent spt0 spt0 lastCurve Empty -> startTangent spt0 spt0 lastCurve
firstCrv :<| _ -> startTangent spt0 spt0 firstCrv firstCrv :<| _ -> startTangent spt0 spt0 firstCrv
@ -279,15 +279,15 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
-- Single point. -- Single point.
_ -> _ ->
pure pure
( Left $ fmap ( MkVector2D ( coords spt0 ) ) ( brushShape spt0 ) ( Left $ fmap ( T ( coords spt0 ) ) ( brushShape spt0 )
, Empty , Empty
) )
where where
outlineFns outlineFns
:: Seq :: Seq
( Double -> ( Point2D Double, Vector2D Double ) ( Double -> ( 2, T ( 2 ) )
, Double -> ( Point2D Double, Vector2D Double ) , Double -> ( 2, T ( 2 ) )
) )
outlineFns = go spt0 ( openCurves $ splineCurves ( adjustSplineType @Open spline ) ) outlineFns = go spt0 ( openCurves $ splineCurves ( adjustSplineType @Open spline ) )
where where
@ -295,8 +295,8 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
:: ptData :: ptData
-> Seq ( Curve Open crvData ptData ) -> Seq ( Curve Open crvData ptData )
-> Seq -> Seq
( Double -> ( Point2D Double, Vector2D Double ) ( Double -> ( 2, T ( 2 ) )
, Double -> ( Point2D Double, Vector2D Double ) , Double -> ( 2, T ( 2 ) )
) )
go _ Empty = Empty go _ Empty = Empty
go p0 ( crv :<| crvs ) = go p0 ( crv :<| crvs ) =
@ -305,7 +305,7 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
brushShape :: ptData -> SplinePts Closed brushShape :: ptData -> SplinePts Closed
brushShape pt = brushFn ( ptParams pt ) 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 ) updateSpline ( lastTgt, lastTgtFwd, lastTgtBwd )
= execWriterT = execWriterT
. ( `evalStateT` ( lastTgt, lastTgtFwd, lastTgtBwd ) ) . ( `evalStateT` ( lastTgt, lastTgtFwd, lastTgtBwd ) )
@ -313,9 +313,9 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
( \ ptData curve -> do ( \ ptData curve -> do
( prevTgt, prev_tgtFwd, prev_tgtBwd ) <- get ( prevTgt, prev_tgtFwd, prev_tgtBwd ) <- get
let let
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double ) fwd, bwd :: Double -> ( 2, T ( 2 ) )
( fwd, bwd ) = outlineFunctions @diffParams ptParams brushFn ptData curve ( 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 tgt = startTangent spt0 ptData curve
next_tgt = endTangent spt0 ptData curve next_tgt = endTangent spt0 ptData curve
tgtFwd = snd ( fwd 0 ) tgtFwd = snd ( fwd 0 )
@ -331,8 +331,8 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
updateCurveData updateCurveData
:: crvData :: crvData
-> ( Double -> ( Point2D Double, Vector2D Double ) ) -> ( Double -> ( 2, T ( 2 ) ) )
-> ( Double -> ( Point2D Double, Vector2D Double ) ) -> ( Double -> ( 2, T ( 2 ) ) )
-> WriterT OutlineData ( ST s ) () -> WriterT OutlineData ( ST s ) ()
updateCurveData ( view ( typed @( CachedStroke s ) ) -> CachedStroke { cachedStrokeRef } ) fwd bwd = do updateCurveData ( view ( typed @( CachedStroke s ) ) -> CachedStroke { cachedStrokeRef } ) fwd bwd = do
mbOutline <- lift ( readSTRef cachedStrokeRef ) 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). -- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction).
tellBrushJoin tellBrushJoin
:: Monad m :: Monad m
=> ( Vector2D Double, Vector2D Double, Vector2D Double ) => ( T ( 2 ), T ( 2 ), T ( 2 ) )
-> ptData -> ptData
-> ( Vector2D Double, Vector2D Double, Vector2D Double ) -> ( T ( 2 ), T ( 2 ), T ( 2 ) )
-> WriterT OutlineData m () -> WriterT OutlineData m ()
tellBrushJoin ( prevTgt, prevTgtFwd, prevTgtBwd ) sp0 ( tgt, tgtFwd, tgtBwd ) = tellBrushJoin ( prevTgt, prevTgtFwd, prevTgtBwd ) sp0 ( tgt, tgtFwd, tgtBwd ) =
tell $ TwoSided ( fwdJoin, Empty ) ( bwdJoin, Empty ) tell $ TwoSided ( fwdJoin, Empty ) ( bwdJoin, Empty )
where where
ptOffset :: Vector2D Double ptOffset :: T ( 2 )
ptOffset = Point2D 0 0 --> coords sp0 ptOffset = 2 0 0 --> coords sp0
brush0 :: SplinePts Closed brush0 :: SplinePts Closed
brush0 = brushShape sp0 brush0 = brushShape sp0
-- Figure out which part of the brush to use for the join. -- Figure out which part of the brush to use for the join.
ori :: Orientation ori :: Orientation
ori = splineOrientation @Double brush0 ori = splineOrientation brush0
fwdCond, bwdCond :: Bool fwdCond, bwdCond :: Bool
( fwdCond, bwdCond ) ( fwdCond, bwdCond )
| prevTgt `cross` tgt < 0 && prevTgt ^.^ tgt < 0 | 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 prevTgtFwd tgtFwd testTgt2
, not . isJust $ between ori prevTgtBwd tgtBwd ( -1 *^ testTgt2 ) , not . isJust $ between ori prevTgtBwd tgtBwd ( -1 *^ testTgt2 )
) )
testTgt1, testTgt2 :: Vector2D Double testTgt1, testTgt2 :: T ( 2 )
testTgt1 = Vector2D -ty tx testTgt1 = V2 -ty tx
where where
tx, ty :: Double tx, ty :: Double
Vector2D tx ty = tgt ^-^ prevTgt V2 tx ty = tgt ^-^ prevTgt
testTgt2 testTgt2
| prevTgt ^.^ tgt < 0 | prevTgt ^.^ tgt < 0
= testTgt1 = testTgt1
@ -420,7 +420,7 @@ outlineFunctions
:: forall diffParams brushParams crvData ptData :: forall diffParams brushParams crvData ptData
. ( Group diffParams, Module Double diffParams . ( Group diffParams, Module Double diffParams
, Torsor diffParams brushParams , Torsor diffParams brushParams
, HasType ( Point2D Double ) ptData , HasType ( 2 ) ptData
-- Debugging. -- Debugging.
, Show ptData , Show ptData
) )
@ -428,68 +428,68 @@ outlineFunctions
-> ( brushParams -> SplinePts Closed ) -> ( brushParams -> SplinePts Closed )
-> ptData -> ptData
-> Curve Open crvData ptData -> Curve Open crvData ptData
-> ( Double -> ( Point2D Double, Vector2D Double ) -> ( Double -> ( 2, T ( 2 ) )
, Double -> ( Point2D Double, Vector2D Double ) , Double -> ( 2, T ( 2 ) )
) )
outlineFunctions ptParams brushFn sp0 crv = outlineFunctions ptParams brushFn sp0 crv =
let let
p0 :: Point2D Double p0 :: 2
p0 = coords sp0 p0 = coords sp0
brush :: Double -> SplinePts Closed brush :: Double -> SplinePts Closed
f :: Double -> Point2D Double f :: Double -> 2
f' :: Double -> Vector2D Double f' :: Double -> T ( 2 )
( brush, f, f' ) = case crv of ( brush, f, f' ) = case crv of
LineTo { curveEnd = NextPoint sp1 } LineTo { curveEnd = NextPoint sp1 }
| let | let
p1 :: Point2D Double p1 :: 2
p1 = coords sp1 p1 = coords sp1
tgt :: Vector2D Double tgt :: T ( 2 )
tgt = p0 --> p1 tgt = p0 --> p1
brush1 :: Double -> SplinePts Closed brush1 :: Double -> SplinePts Closed
brush1 t = brushFn ( lerp @diffParams t ( ptParams sp0 ) ( ptParams sp1 ) ) 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 } Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2 }
| let | let
p1, p2 :: Point2D Double p1, p2 :: 2
p1 = coords sp1 p1 = coords sp1
p2 = coords sp2 p2 = coords sp2
bez :: Quadratic.Bezier ( Point2D Double ) bez :: Quadratic.Bezier ( 2 )
bez = Quadratic.Bezier {..} bez = Quadratic.Bezier {..}
brush2 :: Double -> SplinePts Closed brush2 :: Double -> SplinePts Closed
brush2 t = brush2 t =
brushFn $ brushFn $
Quadratic.bezier @diffParams Quadratic.bezier @diffParams
( Quadratic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ) t ( 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 } Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3 }
| let | let
p1, p2, p3 :: Point2D Double p1, p2, p3 :: 2
p1 = coords sp1 p1 = coords sp1
p2 = coords sp2 p2 = coords sp2
p3 = coords sp3 p3 = coords sp3
bez :: Cubic.Bezier ( Point2D Double ) bez :: Cubic.Bezier ( 2 )
bez = Cubic.Bezier {..} bez = Cubic.Bezier {..}
brush3 :: Double -> SplinePts Closed brush3 :: Double -> SplinePts Closed
brush3 t = brush3 t =
brushFn $ brushFn $
Cubic.bezier @diffParams Cubic.bezier @diffParams
( Cubic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ( ptParams sp3 ) ) t ( Cubic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ( ptParams sp3 ) ) t
-> ( brush3, Cubic.bezier @( Vector2D Double ) bez, Cubic.bezier' bez ) -> ( brush3, Cubic.bezier @( T ( 2 ) ) bez, Cubic.bezier' bez )
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double ) fwd, bwd :: Double -> ( 2, T ( 2 ) )
fwd t fwd t
= ( off t --offset ( withTangent ( fwd' t ) ( brush t ) ) • f t = ( off t --offset ( withTangent ( fwd' t ) ( brush t ) ) • f t
, fwd' t , fwd' t
) )
where where
off :: Double -> Point2D Double off :: Double -> 2
off u = offset ( withTangent ( f' u ) ( brush u ) ) f u off u = offset ( withTangent ( f' u ) ( brush u ) ) f u
offTgt :: Double -> Vector2D Double offTgt :: Double -> T ( 2 )
offTgt u offTgt u
| u < 0.5 | u < 0.5
= 1e9 *^ ( off u --> off (u + 1e-9) ) = 1e9 *^ ( off u --> off (u + 1e-9) )
| otherwise | otherwise
= 1e9 *^ ( off (u - 1e-9) --> off u ) = 1e9 *^ ( off (u - 1e-9) --> off u )
fwd' :: Double -> Vector2D Double fwd' :: Double -> T ( 2 )
fwd' u fwd' u
| squaredNorm ( offTgt u ) < epsilon | squaredNorm ( offTgt u ) < epsilon
= f' u = f' u
@ -502,15 +502,15 @@ outlineFunctions ptParams brushFn sp0 crv =
where where
s :: Double s :: Double
s = 1 - t s = 1 - t
off :: Double -> Point2D Double off :: Double -> 2
off u = offset ( withTangent ( -1 *^ f' u ) ( brush u ) ) f u off u = offset ( withTangent ( -1 *^ f' u ) ( brush u ) ) f u
offTgt :: Double -> Vector2D Double offTgt :: Double -> T ( 2 )
offTgt u offTgt u
| u < 0.5 | u < 0.5
= 1e9 *^ ( off u --> off (u + 1e-9) ) = 1e9 *^ ( off u --> off (u + 1e-9) )
| otherwise | otherwise
= 1e9 *^ ( off (u - 1e-9) --> off u ) = 1e9 *^ ( off (u - 1e-9) --> off u )
bwd' :: Double -> Vector2D Double bwd' :: Double -> T ( 2 )
bwd' u bwd' u
| squaredNorm ( offTgt u ) < epsilon | squaredNorm ( offTgt u ) < epsilon
= -1 *^ f' u = -1 *^ f' u
@ -523,7 +523,7 @@ outlineFunctions ptParams brushFn sp0 crv =
-- used in the "stroke" function. -- 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 sp p0 ( LineTo mp1 _ ) = coords p0 --> coords ( fromNextPoint sp mp1 )
startTangent _ p0 ( Bezier2To p1 _ _ ) = coords p0 --> coords p1 startTangent _ p0 ( Bezier2To p1 _ _ ) = coords p0 --> coords p1
startTangent _ p0 ( Bezier3To 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 _ ( Bezier2To p0 mp1 _ ) = coords p0 --> coords ( fromNextPoint sp mp1 )
endTangent sp _ ( Bezier3To _ 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 { splineCurves = NoCurves } ) = Nothing
lastTangent ( Spline { splineStart, splineCurves = ClosedCurves Empty lst } ) = Just $ endTangent splineStart splineStart lst 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 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). -- | Compute the join at a point of discontinuity of the tangent vector direction (G1 discontinuity).
joinWithBrush joinWithBrush
:: ( HasType ( Point2D Double ) ptData :: ( HasType ( 2 ) ptData
-- debugging -- debugging
, Show ptData, Show crvData , Show ptData, Show crvData
) )
=> Spline Closed crvData ptData => Spline Closed crvData ptData
-> Vector2D Double -> T ( 2 )
-> Vector2D Double -> T ( 2 )
-> SplinePts Open -> SplinePts Open
joinWithBrush brush startTgt endTgt = joinBetweenOffsets brush startOffset endOffset joinWithBrush brush startTgt endTgt = joinBetweenOffsets brush startOffset endOffset
where where
@ -555,7 +555,7 @@ joinWithBrush brush startTgt endTgt = joinBetweenOffsets brush startOffset endOf
endOffset = withTangent endTgt brush endOffset = withTangent endTgt brush
-- | Select the section of a spline in between two offsets. -- | 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 joinBetweenOffsets
spline spline
( Offset { offsetIndex = i1, offsetParameter = mb_t1 } ) ( Offset { offsetIndex = i1, offsetParameter = mb_t1 } )
@ -599,7 +599,7 @@ joinBetweenOffsets
] ]
where where
empty :: SplinePts Open 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 :: Spline Open crvData ptData
openSpline = adjustSplineType spline openSpline = adjustSplineType spline
t1, t2 :: Double t1, t2 :: Double
@ -608,12 +608,12 @@ joinBetweenOffsets
discardCurveData discardCurveData
:: ( Bifunctor f, HasType ( Point2D Double ) ptData ) :: ( Bifunctor f, HasType ( 2 ) ptData )
=> f crvData ptData -> f () ( Point2D Double ) => f crvData ptData -> f () ( 2 )
discardCurveData = bimap ( const () ) coords discardCurveData = bimap ( const () ) coords
-- | Drop the first curve in a Bézier spline. -- | 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 dropFirstPiece ( Spline { splineCurves = OpenCurves curves } ) = case curves of
Empty -> Nothing Empty -> Nothing
fstPiece :<| laterPieces -> 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. -- | 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 splitFirstPiece t ( Spline { splineStart = sp0, splineCurves = OpenCurves curves } ) = case curves of
Empty -> Nothing Empty -> Nothing
fstPiece :<| _ -> case fstPiece of fstPiece :<| _ -> case fstPiece of
LineTo { curveEnd = NextPoint sp1 } -> LineTo { curveEnd = NextPoint sp1 } ->
let let
p1, p :: Point2D Double p1, p :: 2
p1 = coords sp1 p1 = coords sp1
p = lerp @( Vector2D Double ) t p0 p1 p = lerp @( T ( 2 ) ) t p0 p1
in in
Just Just
( Spline ( Spline
@ -647,11 +647,11 @@ splitFirstPiece t ( Spline { splineStart = sp0, splineCurves = OpenCurves curves
) )
Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2 } -> Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2 } ->
let let
p1, p2, q1, p, r1 :: Point2D Double p1, p2, q1, p, r1 :: 2
p1 = coords sp1 p1 = coords sp1
p2 = coords sp2 p2 = coords sp2
( Quadratic.Bezier _ q1 p, Quadratic.Bezier _ r1 _ ) ( Quadratic.Bezier _ q1 p, Quadratic.Bezier _ r1 _ )
= Quadratic.subdivide @( Vector2D Double ) ( Quadratic.Bezier {..} ) t = Quadratic.subdivide @( T ( 2 ) ) ( Quadratic.Bezier {..} ) t
in in
Just Just
( Spline ( Spline
@ -667,12 +667,12 @@ splitFirstPiece t ( Spline { splineStart = sp0, splineCurves = OpenCurves curves
) )
Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3 } -> Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3 } ->
let let
p1, p2, p3, q1, q2, p, r1, r2 :: Point2D Double p1, p2, p3, q1, q2, p, r1, r2 :: 2
p1 = coords sp1 p1 = coords sp1
p2 = coords sp2 p2 = coords sp2
p3 = coords sp3 p3 = coords sp3
( Cubic.Bezier _ q1 q2 p, Cubic.Bezier _ r1 r2 _ ) ( Cubic.Bezier _ q1 q2 p, Cubic.Bezier _ r1 r2 _ )
= Cubic.subdivide @( Vector2D Double ) ( Cubic.Bezier {..} ) t = Cubic.subdivide @( T ( 2 ) ) ( Cubic.Bezier {..} ) t
in in
Just Just
( Spline ( Spline
@ -687,7 +687,7 @@ splitFirstPiece t ( Spline { splineStart = sp0, splineCurves = OpenCurves curves
} }
) )
where where
p0 :: Point2D Double p0 :: 2
p0 = coords sp0 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. -- Does /not/ check that the provided nib shape is convex.
withTangent withTangent
:: forall crvData ptData :: forall crvData ptData
. ( HasType ( Point2D Double ) ptData, Show crvData, Show ptData ) . ( HasType ( 2 ) ptData, Show crvData, Show ptData )
=> Vector2D Double -> Spline Closed crvData ptData -> Offset => T ( 2 ) -> Spline Closed crvData ptData -> Offset
withTangent tgt_wanted spline@( Spline { splineStart } ) withTangent tgt_wanted spline@( Spline { splineStart } )
-- only allow non-empty splines -- only allow non-empty splines
| Just tgt_last <- lastTangent spline | Just tgt_last <- lastTangent spline
@ -712,24 +712,24 @@ withTangent tgt_wanted spline@( Spline { splineStart } )
\tangent vector: " <> show tgt_wanted <> "\n\ \tangent vector: " <> show tgt_wanted <> "\n\
\spline:\n" <> showSplinePoints spline <> "\n" \spline:\n" <> showSplinePoints spline <> "\n"
| otherwise | otherwise
= Offset { offsetIndex = 0, offsetParameter = Just 0, offset = MkVector2D ( coords splineStart ) } = Offset { offsetIndex = 0, offsetParameter = Just 0, offset = T ( coords splineStart ) }
where where
badTangent :: Vector2D Double -> Bool badTangent :: T ( 2 ) -> Bool
badTangent ( Vector2D tx ty ) = badTangent ( V2 tx ty ) =
isNaN tx || isNaN ty || isInfinite tx || isInfinite ty isNaN tx || isNaN ty || isInfinite tx || isInfinite ty
|| ( abs tx < epsilon && abs ty < epsilon ) || ( abs tx < epsilon && abs ty < epsilon )
ori :: Orientation ori :: Orientation
ori = splineOrientation @Double spline ori = splineOrientation spline
go :: Int -> ptData -> Curve Open crvData ptData -> StateT ( Vector2D Double ) ( Except Offset ) () go :: Int -> ptData -> Curve Open crvData ptData -> StateT ( T ( 2 ) ) ( Except Offset ) ()
go i cp cseg = do go i cp cseg = do
tgt_prev <- get tgt_prev <- get
let let
p :: Point2D Double p :: 2
p = coords cp p = coords cp
seg :: Curve Open crvData ( Point2D Double ) seg :: Curve Open crvData ( 2 )
seg = fmap coords cseg seg = fmap coords cseg
tgt_start, tgt_end :: Vector2D Double tgt_start, tgt_end :: T ( 2 )
tgt_start = startTangent splineStart cp cseg tgt_start = startTangent splineStart cp cseg
tgt_end = endTangent splineStart cp cseg tgt_end = endTangent splineStart cp cseg
-- Handle corner. -- Handle corner.
@ -739,38 +739,38 @@ withTangent tgt_wanted spline@( Spline { splineStart } )
Offset Offset
{ offsetIndex = i { offsetIndex = i
, offsetParameter = Just 0 , offsetParameter = Just 0
, offset = MkVector2D p , offset = T p
} }
-- Handle segment. -- Handle segment.
lift $ handleSegment i p seg tgt_start lift $ handleSegment i p seg tgt_start
put tgt_end 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 handleSegment i p0 ( LineTo ( NextPoint p1 ) _ ) tgt0
| tgt_wanted `strictlyParallel` tgt0 | tgt_wanted `strictlyParallel` tgt0
, let , let
offset :: Vector2D Double offset :: T ( 2 )
offset = MkVector2D $ lerp @( Vector2D Double ) 0.5 p0 p1 offset = T $ lerp @( T ( 2 ) ) 0.5 p0 p1
= throwE ( Offset { offsetIndex = i, offsetParameter = Nothing, offset } ) = throwE ( Offset { offsetIndex = i, offsetParameter = Nothing, offset } )
| otherwise | otherwise
= pure () = pure ()
handleSegment i p0 ( Bezier2To p1 ( NextPoint p2 ) _ ) tgt0 = handleSegment i p0 ( Bezier2To p1 ( NextPoint p2 ) _ ) tgt0 =
let let
tgt1 :: Vector2D Double tgt1 :: T ( 2 )
tgt1 = p1 --> p2 tgt1 = p1 --> p2
in for_ ( convexCombination tgt0 tgt1 tgt_wanted ) \ t -> in for_ ( convexCombination tgt0 tgt1 tgt_wanted ) \ t ->
throwE $ throwE $
Offset Offset
{ offsetIndex = i { offsetIndex = i
, offsetParameter = Just t , 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 = handleSegment i p0 ( Bezier3To p1 p2 ( NextPoint p3 ) _ ) tgt0 =
let let
tgt1, tgt2 :: Vector2D Double tgt1, tgt2 :: T ( 2 )
tgt1 = p1 --> p2 tgt1 = p1 --> p2
tgt2 = p2 --> p3 tgt2 = p2 --> p3
bez :: Cubic.Bezier ( Point2D Double ) bez :: Cubic.Bezier ( 2 )
bez = Cubic.Bezier {..} bez = Cubic.Bezier {..}
c01, c12, c23 :: Double c01, c12, c23 :: Double
c01 = tgt_wanted `cross` tgt0 c01 = tgt_wanted `cross` tgt0
@ -794,7 +794,7 @@ withTangent tgt_wanted spline@( Spline { splineStart } )
Offset Offset
{ offsetIndex = i { offsetIndex = i
, offsetParameter = Just t , offsetParameter = Just t
, offset = MkVector2D $ Cubic.bezier @( Vector2D Double ) bez t , offset = T $ Cubic.bezier @( T ( 2 ) ) bez t
} }
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -5,7 +5,7 @@
module Math.Linear module Math.Linear
( -- * Points and vectors ( -- * Points and vectors
Point2D(..), Vector2D(.., Vector2D), Segment(..), Mat22(..) Segment(..), Mat22(..)
-- * Points and vectors (second version) -- * Points and vectors (second version)
, (..), T(.., V2, V3) , (..), T(.., V2, V3)
@ -46,39 +46,7 @@ import Data.Group.Generics
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data Point2D a = Point2D !a !a data Mat22 = Mat22 !Double !Double !Double !Double
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 Segment p = data Segment p =
Segment Segment

View file

@ -1,5 +1,6 @@
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Math.Linear.Dual where 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 \) -- | @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 type D :: Type -> Type -> Type
data family D u v type family D u
newtype instance D ( 0 ) v = D0 { v :: v } type instance D ( 0 ) = D0
type instance D ( 1 ) = D1
type instance D ( 2 ) = D2
type instance D ( 3 ) = D3
newtype D0 v = D0 { v :: v }
deriving stock ( Show, Eq, Functor, Generic, Generic1 ) deriving stock ( Show, Eq, Functor, Generic, Generic1 )
deriving newtype ( Num, Fractional, Floating ) deriving newtype ( Num, Fractional, Floating )
deriving Applicative deriving Applicative
via Generically1 ( D ( 0 ) ) via Generically1 D0
data instance D ( 1 ) v = D1 { v :: !v, dx :: !( T v ), ddx :: !( T v ) } data D1 v = D1 { v :: !v, dx :: !( T v ), ddx :: !( T v ) }
deriving stock ( Show, Eq, Functor, Generic, Generic1 ) deriving stock ( Show, Eq, Functor, Generic, Generic1 )
deriving Applicative deriving Applicative
via Generically1 ( D ( 1 ) ) via Generically1 D1
data instance D ( 2 ) v = D2 { v :: !v, dx, dy :: !( T v ), ddx, dxdy, ddy :: !( T v ) } data D2 v = D2 { v :: !v, dx, dy :: !( T v ), ddx, dxdy, ddy :: !( T v ) }
deriving stock ( Show, Eq, Functor, Generic, Generic1 ) deriving stock ( Show, Eq, Functor, Generic, Generic1 )
deriving Applicative deriving Applicative
via Generically1 ( D ( 2 ) ) via Generically1 D2
data instance D ( 3 ) v = D3 { v :: !v, dx, dy, dz :: !( T v ), ddx, dxdy, ddy, dxdz, dydz, ddz :: !( T v ) } data D3 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 stock ( Show, Eq, Functor, Generic, Generic1 )
deriving Applicative deriving Applicative
via Generically1 ( D ( 3 ) ) via Generically1 D3
instance Num ( D ( 1 ) Double ) where instance Num ( D1 Double ) where
(+) = liftA2 (+) (+) = liftA2 (+)
(-) = liftA2 (-) (-) = liftA2 (-)
negate = fmap negate negate = fmap negate
fromInteger = konst . fromInteger fromInteger = konst @( 1 ) . fromInteger
abs = error "no" abs = error "no"
signum = error "no" signum = error "no"
@ -62,11 +68,11 @@ instance Num ( D ( 1 ) Double ) where
( T $ dx1 * v2 + v1 * dx2 ) ( T $ dx1 * v2 + v1 * dx2 )
( T $ dx1 * dx2 + v1 * ddx2 + ddx1 * v2 ) ( T $ dx1 * dx2 + v1 * ddx2 + ddx1 * v2 )
instance Num ( D ( 2 ) Double ) where instance Num ( D2 Double ) where
(+) = liftA2 (+) (+) = liftA2 (+)
(-) = liftA2 (-) (-) = liftA2 (-)
negate = fmap negate negate = fmap negate
fromInteger = konst . fromInteger fromInteger = konst @( 2 ) . fromInteger
abs = error "no" abs = error "no"
signum = error "no" signum = error "no"
@ -81,11 +87,11 @@ instance Num ( D ( 2 ) Double ) where
( T $ dy1 * dy2 + v1 * ddy2 + ddy1 * v2 ) ( T $ dy1 * dy2 + v1 * ddy2 + ddy1 * v2 )
instance Num ( D ( 3 ) Double ) where instance Num ( D3 Double ) where
(+) = liftA2 (+) (+) = liftA2 (+)
(-) = liftA2 (-) (-) = liftA2 (-)
negate = fmap negate negate = fmap negate
fromInteger = konst . fromInteger fromInteger = konst @( 3 ) . fromInteger
abs = error "no" abs = error "no"
signum = error "no" signum = error "no"
@ -104,35 +110,35 @@ instance Num ( D ( 3 ) Double ) where
( T $ dz1 * dz2 + v1 * ddz2 + ddz1 * v2) ( T $ dz1 * dz2 + v1 * ddz2 + ddz1 * v2)
instance Module Double v => Module ( D ( 0 ) Double ) ( D ( 0 ) v ) where instance Module Double v => Module ( D0 Double ) ( D0 v ) where
(^+^) = liftA2 (^+^) (^+^) = liftA2 (^+^)
(^-^) = liftA2 (^-^) (^-^) = liftA2 (^-^)
origin = pure origin origin = pure origin
(*^) = liftA2 (*^) (*^) = liftA2 (*^)
instance Module Double v => Module ( D ( 1 ) Double ) ( D ( 1 ) v ) where instance Module Double v => Module ( D1 Double ) ( D1 v ) where
(^+^) = liftA2 (^+^) (^+^) = liftA2 (^+^)
(^-^) = liftA2 (^-^) (^-^) = liftA2 (^-^)
origin = pure origin origin = pure origin
(*^) = liftA2 (*^) (*^) = liftA2 (*^)
instance Module Double v => Module ( D ( 2 ) Double ) ( D ( 2 ) v ) where instance Module Double v => Module ( D2 Double ) ( D2 v ) where
(^+^) = liftA2 (^+^) (^+^) = liftA2 (^+^)
(^-^) = liftA2 (^-^) (^-^) = liftA2 (^-^)
origin = pure origin origin = pure origin
(*^) = liftA2 (*^) (*^) = liftA2 (*^)
instance Module Double v => Module ( D ( 3 ) Double ) ( D ( 3 ) v ) where instance Module Double v => Module ( D3 Double ) ( D3 v ) where
(^+^) = liftA2 (^+^) (^+^) = liftA2 (^+^)
(^-^) = liftA2 (^-^) (^-^) = liftA2 (^-^)
origin = pure origin origin = pure origin
(*^) = liftA2 (*^) (*^) = liftA2 (*^)
instance Fractional ( D ( 1 ) Double ) where instance Fractional ( D1 Double ) where
(/) = error "I haven't yet defined (/) for D ( 1 )" (/) = error "I haven't yet defined (/) for D1"
fromRational = konst . fromRational fromRational = konst @( 1 ) . fromRational
instance Floating ( D ( 1 ) Double ) where instance Floating ( D1 Double ) where
pi = konst pi pi = konst @( 1 ) pi
sin ( D1 v ( T dx ) ( T ddx ) ) sin ( D1 v ( T dx ) ( T ddx ) )
= let !s = sin v = let !s = sin v
!c = cos v !c = cos v
@ -143,11 +149,11 @@ instance Floating ( D ( 1 ) Double ) where
!c = cos v !c = cos v
in D1 c ( T $ -s * dx ) ( T $ -2 * s * ddx - c * dx * dx ) in D1 c ( T $ -s * dx ) ( T $ -2 * s * ddx - c * dx * dx )
instance Fractional ( D ( 2 ) Double ) where instance Fractional ( D2 Double ) where
(/) = error "I haven't yet defined (/) for D ( 2 )" (/) = error "I haven't yet defined (/) for D2"
fromRational = konst . fromRational fromRational = konst @( 2 ) . fromRational
instance Floating ( D ( 2 ) Double ) where instance Floating ( D2 Double ) where
pi = konst pi pi = konst @( 2 ) pi
sin ( D2 v ( T dx ) ( T dy ) ( T ddx ) ( T dxdy ) ( T ddy ) ) sin ( D2 v ( T dx ) ( T dy ) ( T ddx ) ( T dxdy ) ( T ddy ) )
= let !s = sin v = let !s = sin v
!c = cos 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 * dxdy - 2 * c * dx * dy )
( T $ -2 * s * ddy - c * dy * dy ) ( T $ -2 * s * ddy - c * dy * dy )
instance Fractional ( D ( 3 ) Double ) where instance Fractional ( D3 Double ) where
(/) = error "I haven't yet defined (/) for D ( 3 )" (/) = error "I haven't yet defined (/) for D3"
fromRational = konst . fromRational fromRational = konst @( 3 ) . fromRational
instance Floating ( D ( 3 ) Double ) where instance Floating ( D3 Double ) where
pi = konst pi 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 ) ) 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 = let !s = sin v
!c = cos 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 ) => ( ( 1 ) ~> v )
-> ( v ~> w ) -> ( v ~> w )
-> ( ( 1 ) ~> w ) -> ( ( 1 ) ~> w )
@ -217,24 +223,31 @@ chainRule ( D f ) ( D g ) =
df@( D1 { v = f_x } ) -> df@( D1 { v = f_x } ) ->
chain df ( g f_x ) chain df ( g f_x )
type Chain :: Type -> Constraint -- | Recover the underlying function, discarding all infinitesimal information.
class Chain v where 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 ) ) chain :: ( Module Double ( T w ) )
=> D ( 1 ) v -> D v w -> D ( 1 ) w => D1 v -> D v w -> D ( 1 ) w
konst :: Module Double ( T w ) => w -> D v w konst :: Module Double ( T w ) => w -> D v w
value :: D v w -> w
instance Chain ( 0 ) where instance Diffy ( 0 ) where
chain _ ( D0 v ) = D1 v origin origin chain _ ( D0 w ) = D1 w origin origin
konst k = D0 k 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 ) chain ( D1 _ ( T ( 1 x' ) ) ( T ( 1 x'' ) ) ) ( D1 v g_x g_xx )
= D1 v = D1 v
( x' *^ g_x ) ( x' *^ g_x )
( x'' *^ g_x ^+^ ( x' * x' ) *^ g_xx ) ( x'' *^ g_x ^+^ ( x' * x' ) *^ g_xx )
konst k = D1 k origin origin 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 ) chain ( D1 _ ( T ( 2 x' y' ) ) ( T ( 2 x'' y'' ) ) ) ( D2 v g_x g_y g_xx g_xy g_yy )
= D1 v = D1 v
( x' *^ g_x ^+^ y' *^ g_y ) ( x' *^ g_x ^+^ y' *^ g_y )
@ -242,8 +255,9 @@ instance Chain ( 2 ) where
^+^ ( x' * x' ) *^ g_xx ^+^ ( y' * y' ) *^ g_yy ^+^ ( x' * x' ) *^ g_xx ^+^ ( y' * y' ) *^ g_yy
^+^ 2 *^ ( ( x' * y' ) *^ g_xy ) ) ^+^ 2 *^ ( ( x' * y' ) *^ g_xy ) )
konst k = D2 k origin origin origin origin origin 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'' ) ) ) 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 ) ( D3 v g_x g_y g_z g_xx g_xy g_yy g_xz g_yz g_zz )
= D1 v = D1 v
@ -252,6 +266,7 @@ instance Chain ( 3 ) where
^+^ ( x' * x' ) *^ g_xx ^+^ ( y' * y' ) *^ g_yy ^+^ ( z' * z' ) *^ g_zz ^+^ ( 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 ) ^+^ 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 konst k = D3 k origin origin origin origin origin origin origin origin origin
value ( D3 { v } ) = v
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -16,12 +16,12 @@ import qualified Eigen.Solver.LA as Eigen
-- MetaBrush -- MetaBrush
import Math.Linear import Math.Linear
( Vector2D(..), Mat22(..) ) ( Mat22(..), (..), T(..) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
linearSolve :: Mat22 Double -> Vector2D Double -> Vector2D Double linearSolve :: Mat22 -> T ( 2 ) -> T ( 2 )
linearSolve ( Mat22 a b c d ) ( Vector2D p q ) = Vector2D u v linearSolve ( Mat22 a b c d ) ( V2 p q ) = V2 u v
where where
[[u],[v]] = Eigen.toList [[u],[v]] = Eigen.toList
$ Eigen.solve Eigen.JacobiSVD $ Eigen.solve Eigen.JacobiSVD

View file

@ -28,10 +28,6 @@ import Data.Act
( (-->) ) ( (-->) )
) )
-- groups
import Data.Group
( invert )
-- MetaBrush -- MetaBrush
import Math.Epsilon import Math.Epsilon
( epsilon ) ( epsilon )
@ -126,21 +122,6 @@ instance Num a => Module a ( Sum a ) where
instance Num a => Inner a ( Sum a ) where instance Num a => Inner a ( Sum a ) where
Sum a ^.^ Sum b = a * b 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 instance Module Double ( T ( 0 ) ) where
origin = T 0 origin = T 0
_ ^+^ _ = T 0 _ ^+^ _ = T 0
@ -164,16 +145,18 @@ instance Module Double ( T ( 3 ) ) where
T ( 3 ( x1 - x2 ) ( y1 - y2 ) ( z1 - z2 ) ) T ( 3 ( x1 - x2 ) ( y1 - y2 ) ( z1 - z2 ) )
k *^ ( T ( 3 a b c ) ) = T ( 3 ( k * a ) ( k * b ) ( k * c ) ) 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-product of two 2D vectors.
cross :: Num a => Vector2D a -> Vector2D a -> a cross :: T ( 2 ) -> T ( 2 ) -> Double
cross ( Vector2D x1 y1 ) ( Vector2D x2 y2 ) cross ( V2 x1 y1 ) ( V2 x2 y2 ) = x1 * y2 - x2 * y1
= x1 * y2 - x2 * y1
-- | Compute whether two vectors point in the same direction, -- | Compute whether two vectors point in the same direction,
-- that is, whether each vector is a (strictly) positive multiple of the other. -- that is, whether each vector is a (strictly) positive multiple of the other.
-- --
-- Returns @False@ if either of the vectors is zero. -- 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 strictlyParallel u v
= abs ( u `cross` v ) < epsilon -- vectors are collinear = abs ( u `cross` v ) < epsilon -- vectors are collinear
&& u ^.^ v > epsilon -- vectors point in the same direction (parallel and not anti-parallel) && 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 @. -- If so, returns @ t @ in @ [ 0, 1 ] @ such that @ ( 1 - t ) v0 + t v1 @ is a positive multiple of @ u @.
convexCombination convexCombination
:: forall r :: T ( 2 ) -- ^ first vector
. RealFloat r -> T ( 2 ) -- ^ second vector
=> Vector2D r -- ^ first vector -> T ( 2 ) -- ^ query vector
-> Vector2D r -- ^ second vector -> Maybe Double
-> Vector2D r -- ^ query vector
-> Maybe r
convexCombination v0 v1 u convexCombination v0 v1 u
| abs c10 < epsilon | abs c10 < epsilon
= if strictlyParallel u v0 = if strictlyParallel u v0
@ -198,13 +179,13 @@ convexCombination v0 v1 u
| otherwise | otherwise
= do = do
let let
t :: r t :: Double
t = c0 / c10 t = c0 / c10
guard ( t > -epsilon && t < 1 + epsilon ) 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 ) Just $ min 1 ( max 0 t )
where where
c0, c10 :: r c0, c10 :: Double
c0 = v0 `cross` u c0 = v0 `cross` u
c10 = ( v0 ^-^ v1 ) `cross` u c10 = ( v0 ^-^ v1 ) `cross` u

View file

@ -39,7 +39,7 @@ import Math.Bezier.Spline
, ssplineType , ssplineType
) )
import Math.Linear import Math.Linear
( Point2D, Vector2D(..) ) ( (..), T(..) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -53,7 +53,7 @@ reverseOrientation CCW = CW
reverseOrientation CW = CCW reverseOrientation CW = CCW
-- | Compute an orientation from a sequence of tangent vectors (assumed to have monotone angle). -- | 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 ) convexOrientation ( v1 : v2 : vs )
| nearZero crossProduct | nearZero crossProduct
= convexOrientation ( v2 : vs ) = convexOrientation ( v2 : vs )
@ -62,27 +62,27 @@ convexOrientation ( v1 : v2 : vs )
| otherwise | otherwise
= CW = CW
where where
crossProduct :: r crossProduct :: Double
crossProduct = v1 `cross` v2 crossProduct = v1 `cross` v2
convexOrientation _ = CCW -- default convexOrientation _ = CCW -- default
-- | Compute the orientation of a spline, assuming tangent vectors have a monotone angle. -- | Compute the orientation of a spline, assuming tangent vectors have a monotone angle.
splineOrientation splineOrientation
:: forall r clo crvData ptData :: forall clo crvData ptData
. ( KnownSplineType clo, RealFloat r, HasType ( Point2D r ) ptData ) . ( KnownSplineType clo, HasType ( 2 ) ptData )
=> Spline clo crvData ptData => Spline clo crvData ptData
-> Orientation -> Orientation
splineOrientation = convexOrientation . splineTangents @r splineOrientation = convexOrientation . splineTangents
-- | Compute the sequence of tangent vectors given by the control points of a Bézier spline. -- | Compute the sequence of tangent vectors given by the control points of a Bézier spline.
splineTangents splineTangents
:: forall r clo crvData ptData :: forall clo crvData ptData
. ( Num r, KnownSplineType clo, HasType ( Point2D r ) ptData ) . ( KnownSplineType clo, HasType ( 2 ) ptData )
=> Spline clo crvData ptData => Spline clo crvData ptData
-> [ Vector2D r ] -> [ T ( 2 ) ]
splineTangents spline@( Spline { splineStart = sp0, splineCurves = curves } ) splineTangents spline@( Spline { splineStart = sp0, splineCurves = curves } )
| let | let
p0 :: Point2D r p0 :: 2
p0 = view typed sp0 p0 = view typed sp0
= case ssplineType @clo of = case ssplineType @clo of
SOpen SOpen
@ -93,24 +93,24 @@ splineTangents spline@( Spline { splineStart = sp0, splineCurves = curves } )
-> go p0 ( cs :|> c ) -> go p0 ( cs :|> c )
_ -> [] _ -> []
where where
go :: Point2D r -> Seq ( Curve Open crvData ptData ) -> [ Vector2D r ] go :: 2 -> Seq ( Curve Open crvData ptData ) -> [ T ( 2 ) ]
go _ Empty = [] go _ Empty = []
go p ( crv :<| crvs ) = go p ( crv :<| crvs ) =
case crv of case crv of
LineTo { curveEnd = NextPoint sq } LineTo { curveEnd = NextPoint sq }
| let | let
q :: Point2D r q :: 2
q = view typed sq q = view typed sq
-> ( p --> q ) : go q crvs -> ( p --> q ) : go q crvs
Bezier2To { controlPoint = scp, curveEnd = NextPoint sq } Bezier2To { controlPoint = scp, curveEnd = NextPoint sq }
| let | let
cp, q :: Point2D r cp, q :: 2
cp = view typed scp cp = view typed scp
q = view typed sq q = view typed sq
-> ( p --> cp ) : ( cp --> q ) : go q crvs -> ( p --> cp ) : ( cp --> q ) : go q crvs
Bezier3To { controlPoint1 = scp1, controlPoint2 = scp2, curveEnd = NextPoint sq } Bezier3To { controlPoint1 = scp1, controlPoint2 = scp2, curveEnd = NextPoint sq }
| let | let
cp1, cp2, q :: Point2D r cp1, cp2, q :: 2
cp1 = view typed scp1 cp1 = view typed scp1
cp2 = view typed scp2 cp2 = view typed scp2
q = view typed sq 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 -- Returns the proportion of the angle the vector is in between, or @Nothing@ if the query vector
-- is not in between. -- 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 -- Just 0.3333333333333333
between between
:: forall r :: Orientation
. RealFloat r -> T ( 2 ) -- ^ start vector
=> Orientation -> T ( 2 ) -- ^ end vector
-> Vector2D r -- ^ start vector -> T ( 2 ) -- ^ query vector: is it in between the start and end vectors w.r.t. the provided orientation?
-> Vector2D r -- ^ end vector -> Maybe Double
-> Vector2D r -- ^ query vector: is it in between the start and end vectors w.r.t. the provided orientation? between CCW ( V2 x1 y1 ) ( V2 x2 y2 ) ( V2 a b ) =
-> Maybe r
between CCW ( Vector2D x1 y1 ) ( Vector2D x2 y2 ) ( Vector2D a b ) =
let let
τ, η, φ, θ :: r τ, η, φ, θ :: Double
τ = 2 * pi τ = 2 * pi
η = atan2 y1 x1 η = atan2 y1 x1
φ = ( atan2 y2 x2 - η ) `mod'` τ φ = ( atan2 y2 x2 - η ) `mod'` τ