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

use R2 instead of Point2D & Vector2D

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

1
MetaBrush.cabal
View file

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

70
src/app/MetaBrush/Action.hs
View file

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

10
src/app/MetaBrush/Action.hs-boot
View file

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

14
src/app/MetaBrush/Application.hs
View file

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

16
src/app/MetaBrush/Context.hs
View file

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

42
src/app/MetaBrush/Document/Selection.hs
View file

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

20
src/app/MetaBrush/Event.hs
View file

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

72
src/app/MetaBrush/Render/Document.hs
View file

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

30
src/app/MetaBrush/Render/Rulers.hs
View file

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

26
src/app/MetaBrush/UI/Coordinates.hs
View file

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

10
src/app/MetaBrush/UI/InfoBar.hs
View file

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

4
src/convert/Main.hs
View file

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

14
src/convert/MetaBrush/MetaFont/Convert.hs
View file

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

67
src/metabrushes/MetaBrush/Asset/Brushes.hs
View file

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

5
src/metabrushes/MetaBrush/Brush.hs
View file

@ -37,11 +37,13 @@ import qualified Data.Text as Text
( unpack )
-- MetaBrush
import Math.Linear
import Math.Linear.Dual
( Diffy )
import Math.Bezier.Spline
( SplineType(Closed), SplinePts)
import MetaBrush.Records
import MetaBrush.Serialisable
import Math.Linear
--------------------------------------------------------------------------------
@ -55,6 +57,7 @@ data Brush brushFields where
:: forall brushFields
. ( KnownSymbols brushFields
, Representable ( ℝ ( Length brushFields) )
, Diffy ( ℝ ( Length brushFields) )
, Typeable brushFields )
=> { brushName :: !Text
, brushFunction :: BrushFunction brushFields

52
src/metabrushes/MetaBrush/Document.hs
View file

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

22
src/metabrushes/MetaBrush/Document/Draw.hs
View file

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

18
src/metabrushes/MetaBrush/Document/Serialise.hs
View file

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

22
src/metabrushes/MetaBrush/Document/SubdivideStroke.hs
View file

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

8
src/metabrushes/MetaBrush/Records.hs
View file

@ -49,6 +49,7 @@ import qualified Data.Text as Text
-- MetaBrush
import Math.Linear
import Math.Linear.Dual
import Math.Module
--------------------------------------------------------------------------------
@ -66,7 +67,7 @@ type WithParams :: [ Symbol ] -> Type -> Type
data WithParams params a =
WithParams
{ defaultParams :: Record params
, withParams :: Record params -> a
, withParams :: Record params ~> a
}
--------------------------------------------------------------------------------
@ -122,6 +123,11 @@ instance ( Torsor ( T ( ℝ ( Length ks ) ) ) ( ℝ ( Length ks ) )
=> Torsor ( T ( Record ks ) ) ( Record ks ) where
MkR g --> MkR a = T $ MkR $ unT $ g --> a
type instance D ( Record ks ) = D ( ℝ ( Length ks ) )
deriving newtype instance Var n ( ℝ ( Length ks ) ) => Var n ( Record ks )
deriving newtype instance Diffy ( ℝ ( Length ks ) ) => Diffy ( Record ks )
--------------------------------------------------------------------------------
type Length :: [ k ] -> Nat

14
src/metabrushes/MetaBrush/Serialisable.hs
View file

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

18
src/splines/Math/Bezier/Cubic.hs
View file

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

58
src/splines/Math/Bezier/Cubic/Fit.hs
View file

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

612
src/splines/Math/Bezier/Envelope.hs
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

10
src/splines/Math/Bezier/Quadratic.hs
View file

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

5
src/splines/Math/Bezier/Spline.hs
View file

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

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

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

36
src/splines/Math/Linear.hs
View file

@ -5,7 +5,7 @@
module Math.Linear
( -- * Points and vectors
Point2D(..), Vector2D(.., Vector2D), Segment(..), Mat22(..)
Segment(..), Mat22(..)
-- * Points and vectors (second version)
, ℝ(..), T(.., V2, V3)
@ -46,39 +46,7 @@ import Data.Group.Generics
--------------------------------------------------------------------------------
data Point2D a = Point2D !a !a
deriving stock ( Eq, Generic, Generic1, Functor, Foldable, Traversable )
deriving ( Act ( Vector2D a ), Torsor ( Vector2D a ) )
via Vector2D a
deriving Applicative
via Generically1 Point2D
deriving anyclass ( NFData, NFData1 )
instance Show a => Show (Point2D a) where
showsPrec i (Point2D a b) = showsPrec i (a,b)
newtype Vector2D a = MkVector2D { tip :: Point2D a }
deriving stock ( Generic, Generic1, Foldable, Traversable )
deriving newtype ( Eq, Functor, Applicative, NFData, NFData1 )
deriving ( Semigroup, Monoid, Group )
via Generically ( Point2D ( Sum a ) )
-- | One-off datatype used for the 'Show' instance of Vector2D.
data V a = V a a
deriving stock Show
instance Show a => Show (Vector2D a) where
showsPrec i (Vector2D x y) = showsPrec i (V x y)
{-# COMPLETE Vector2D #-}
pattern Vector2D :: a -> a -> Vector2D a
pattern Vector2D x y = MkVector2D ( Point2D x y )
data Mat22 a
= Mat22 !a !a !a !a
deriving stock ( Show, Eq, Generic, Generic1, Functor, Foldable, Traversable )
deriving Applicative
via Generically1 Mat22
deriving anyclass ( NFData, NFData1 )
data Mat22 = Mat22 !Double !Double !Double !Double
data Segment p =
Segment

101
src/splines/Math/Linear/Dual.hs
View file

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

6
src/splines/Math/Linear/Solve.hs
View file

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

45
src/splines/Math/Module.hs
View file

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

46
src/splines/Math/Orientation.hs
View file

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