diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 507f118..7d1f5f5 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -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 diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 910da96..9668caf 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -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 ) diff --git a/src/app/MetaBrush/Action.hs-boot b/src/app/MetaBrush/Action.hs-boot index 80fbf04..23922a7 100644 --- a/src/app/MetaBrush/Action.hs-boot +++ b/src/app/MetaBrush/Action.hs-boot @@ -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 diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index 0611719..2954617 100644 --- a/src/app/MetaBrush/Application.hs +++ b/src/app/MetaBrush/Application.hs @@ -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 diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Context.hs index e4de54b..4bbfae2 100644 --- a/src/app/MetaBrush/Context.hs +++ b/src/app/MetaBrush/Context.hs @@ -42,7 +42,7 @@ import Data.HashMap.Strict import Math.Bezier.Cubic.Fit ( FitParameters ) import Math.Linear - ( Point2D ) + ( ℝ(..) ) import {-# SOURCE #-} MetaBrush.Action ( ActionName ) import MetaBrush.Asset.Colours @@ -88,7 +88,7 @@ data Variables , documentRenderTVar :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) ) , activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) ) , openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) ) - , mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) ) + , mousePosTVar :: !( STM.TVar ( Maybe ( ℝ 2 ) ) ) , mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) ) , modifiersTVar :: !( STM.TVar ( Set Modifier ) ) , toolTVar :: !( STM.TVar Tool ) @@ -134,21 +134,21 @@ data GuideAction -- - draw a control point, -- - create/modify a guide. data HoldAction - = SelectionHold { holdStartPos :: !( Point2D Double ) } - | DragMoveHold { holdStartPos :: !( Point2D Double ) + = SelectionHold { holdStartPos :: !( ℝ 2 ) } + | DragMoveHold { holdStartPos :: !( ℝ 2 ) , dragAction :: !DragMoveSelect } - | DrawHold { holdStartPos :: !( Point2D Double ) } - | GuideAction { holdStartPos :: !( Point2D Double ) - , guideAction :: !GuideAction + | DrawHold { holdStartPos :: !( ℝ 2 ) } + | GuideAction { holdStartPos :: !( ℝ 2 ) + , guideAction :: !GuideAction } deriving stock Show -- | Keep track of a path that is in the middle of being drawn. data PartialPath = PartialPath - { partialStartPos :: !( Point2D Double ) - , partialControlPoint :: !( Maybe ( Point2D Double ) ) + { partialStartPos :: !( ℝ 2 ) + , partialControlPoint :: !( Maybe ( ℝ 2 ) ) , partialPathAnchor :: !DrawAnchor , firstPoint :: !Bool } diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 8ea89ca..1e8bc52 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -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 diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index 604d101..7c8b2d8 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -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. diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 79aacd0..c7762ee 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -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 diff --git a/src/app/MetaBrush/Render/Rulers.hs b/src/app/MetaBrush/Render/Rulers.hs index fc7a497..597de17 100644 --- a/src/app/MetaBrush/Render/Rulers.hs +++ b/src/app/MetaBrush/Render/Rulers.hs @@ -45,7 +45,7 @@ import Control.Lens -- MetaBrush import Math.Linear - ( Point2D(..), Vector2D(..) ) + ( ℝ(..), T(..) ) import MetaBrush.Action ( ActionOrigin(..) ) import MetaBrush.Asset.Colours @@ -70,13 +70,13 @@ import MetaBrush.GTK.Util renderRuler :: Colours -> ( Int32, Int32 ) -> ActionOrigin -> ( Int32, Int32 ) - -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Bool + -> Maybe ( ℝ 2 ) -> Maybe HoldAction -> Bool -> Document -> Cairo.Render () renderRuler cols@( Colours {..} ) ( viewportWidth, viewportHeight ) actionOrigin ( width, height ) mbMousePos mbHoldEvent showGuides - ( Document { viewportCenter = center@( Point2D cx cy ), zoomFactor, documentContent = Content { guides } } ) = do + ( Document { viewportCenter = center@( ℝ2 cx cy ), zoomFactor, documentContent = Content { guides } } ) = do let modifiedGuides :: [ Guide ] @@ -85,12 +85,12 @@ renderRuler , Just mousePos <- mbMousePos = case act of MoveGuide guideUnique - -> + -> let - translate :: Point2D Double -> Point2D Double - translate = ( ( mousePos0 --> mousePos :: Vector2D Double ) • ) - in toList - $ Map.adjust + translate :: ℝ 2 -> ℝ 2 + translate = ( ( mousePos0 --> mousePos :: T ( ℝ 2 ) ) • ) + in toList + $ Map.adjust ( over ( field' @"guidePoint" ) translate . set ( field' @"guideFocus" ) Selected ) guideUnique guides @@ -99,14 +99,14 @@ renderRuler addNewGuides :: [ Guide ] -> [ Guide ] addNewGuides gs = case ruler of RulerCorner - -> Guide { guidePoint = mousePos, guideNormal = Vector2D 0 1, guideFocus = Selected, guideUnique = unsafeUnique 0 } - : Guide { guidePoint = mousePos, guideNormal = Vector2D 1 0, guideFocus = Selected, guideUnique = unsafeUnique 1 } + -> Guide { guidePoint = mousePos, guideNormal = V2 0 1, guideFocus = Selected, guideUnique = unsafeUnique 0 } + : Guide { guidePoint = mousePos, guideNormal = V2 1 0, guideFocus = Selected, guideUnique = unsafeUnique 1 } : gs LeftRuler - -> Guide { guidePoint = mousePos, guideNormal = Vector2D 1 0, guideFocus = Selected, guideUnique = unsafeUnique 2 } + -> Guide { guidePoint = mousePos, guideNormal = V2 1 0, guideFocus = Selected, guideUnique = unsafeUnique 2 } : gs TopRuler - -> Guide { guidePoint = mousePos, guideNormal = Vector2D 0 1, guideFocus = Selected, guideUnique = unsafeUnique 3 } + -> Guide { guidePoint = mousePos, guideNormal = V2 0 1, guideFocus = Selected, guideUnique = unsafeUnique 3 } : gs in addNewGuides ( toList guides ) | otherwise @@ -114,7 +114,7 @@ renderRuler mbHoverContext :: Maybe HoverContext mbHoverContext - | Just mp@( Point2D x y ) <- mbMousePos + | Just mp@( ℝ2 x y ) <- mbMousePos , x <= left || y <= top -- only hover guides from within ruler area = Just ( MouseHover mp ) | otherwise @@ -131,7 +131,7 @@ renderRuler -- Render guides. when showGuides ( for_ modifiedGuides ( renderGuide cols mbHoverContext zoomFactor ) ) -- Render mouse cursor indicator. - for_ mbMousePos \ ( Point2D mx my ) -> + for_ mbMousePos \ ( ℝ2 mx my ) -> case actionOrigin of RulerOrigin TopRuler -> do Cairo.save @@ -149,7 +149,7 @@ renderRuler Cairo.translate left my Cairo.moveTo 0 0 Cairo.scale ( 1 / zoomFactor ) ( 1 / zoomFactor ) - Cairo.lineTo -6 -3 + Cairo.lineTo -6 -3 Cairo.lineTo -6 3 Cairo.closePath withRGBA cursorIndicator Cairo.setSourceRGBA @@ -166,8 +166,8 @@ renderRuler dx = fromIntegral width dy = fromIntegral height left, right, top, bottom :: Double - Point2D left top = toViewport ( Point2D 0 0 ) - Point2D right bottom = toViewport ( Point2D ( fromIntegral viewportWidth ) ( fromIntegral viewportHeight ) ) + ℝ2 left top = toViewport ( ℝ2 0 0 ) + ℝ2 right bottom = toViewport ( ℝ2 ( fromIntegral viewportWidth ) ( fromIntegral viewportHeight ) ) additionalAdjustment :: Cairo.Render () additionalAdjustment = case actionOrigin of ViewportOrigin -> pure () @@ -178,7 +178,7 @@ renderRuler Cairo.translate dx 0 TopRuler -> do Cairo.translate 0 dy - toViewport :: Point2D Double -> Point2D Double + toViewport :: ℝ 2 -> ℝ 2 toViewport = toViewportCoordinates zoomFactor ( fromIntegral viewportWidth, fromIntegral viewportHeight ) center setTickRenderContext :: Cairo.Render () @@ -282,7 +282,7 @@ data Tick renderGuide :: Colours -> Maybe HoverContext -> Double -> Guide -> Cairo.Render () renderGuide ( Colours {..} ) mbHoverContext zoom - gd@( Guide { guidePoint = Point2D x y, guideNormal = Vector2D nx ny, guideFocus } ) + gd@( Guide { guidePoint = ℝ2 x y, guideNormal = V2 nx ny, guideFocus } ) = do Cairo.save diff --git a/src/app/MetaBrush/UI/Coordinates.hs b/src/app/MetaBrush/UI/Coordinates.hs index 9400b45..ff62a28 100644 --- a/src/app/MetaBrush/UI/Coordinates.hs +++ b/src/app/MetaBrush/UI/Coordinates.hs @@ -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 ) diff --git a/src/app/MetaBrush/UI/InfoBar.hs b/src/app/MetaBrush/UI/InfoBar.hs index 8bf14bf..84d54d9 100644 --- a/src/app/MetaBrush/UI/InfoBar.hs +++ b/src/app/MetaBrush/UI/InfoBar.hs @@ -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 ) diff --git a/src/convert/Main.hs b/src/convert/Main.hs index 70ad82d..fb17751 100644 --- a/src/convert/Main.hs +++ b/src/convert/Main.hs @@ -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 = diff --git a/src/convert/MetaBrush/MetaFont/Convert.hs b/src/convert/MetaBrush/MetaFont/Convert.hs index 4092263..e6e3292 100644 --- a/src/convert/MetaBrush/MetaFont/Convert.hs +++ b/src/convert/MetaBrush/MetaFont/Convert.hs @@ -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 -> diff --git a/src/metabrushes/MetaBrush/Asset/Brushes.hs b/src/metabrushes/MetaBrush/Asset/Brushes.hs index 95980ac..a283370 100644 --- a/src/metabrushes/MetaBrush/Asset/Brushes.hs +++ b/src/metabrushes/MetaBrush/Asset/Brushes.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} module MetaBrush.Asset.Brushes where @@ -23,7 +24,7 @@ import qualified Data.HashMap.Strict as HashMap -- MetaBrush import Math.Bezier.Spline import Math.Linear - ( Point2D(..), ℝ(..), T(..) ) + ( ℝ(..), T(..) ) import Math.Linear.Dual ( D, type (~>)(..), Var(var), konst ) import Math.Module @@ -34,8 +35,6 @@ import MetaBrush.Records -------------------------------------------------------------------------------- -type CircleBrushFields = '[ "r" ] - lookupBrush :: Text -> Maybe SomeBrush lookupBrush nm = HashMap.lookup nm brushes @@ -53,45 +52,25 @@ brushes = HashMap.fromList κ :: Double κ = 0.5519150244935105707435627227925 -circleSpline :: (Double -> Double -> ptData) -> Spline 'Closed () ptData -circleSpline p = - Spline { splineStart = p 1 0 - , splineCurves = ClosedCurves crvs lastCrv } - where - crvs = Seq.fromList - [ Bezier3To (p 1 κ) (p κ 1) (NextPoint (p 0 1)) () - , Bezier3To (p -κ 1) (p -1 κ) (NextPoint (p -1 0)) () - , Bezier3To (p -1 -κ) (p -κ -1) (NextPoint (p 0 -1)) () - ] - lastCrv = - Bezier3To (p κ -1) (p 1 -κ) BackToStart () - +type CircleBrushFields = '[ "r" ] circle :: Brush CircleBrushFields -circle = BrushData "circle" (WithParams deflts shape) +circle = BrushData "circle" ( WithParams deflts circleBrush ) where deflts :: Record CircleBrushFields deflts = MkR ( ℝ1 1 ) - shape :: Record CircleBrushFields -> SplinePts 'Closed - shape ( MkR ( ℝ1 r ) ) = - circleSpline ( \ x y -> Point2D (r * x) (r * y) ) type EllipseBrushFields = '[ "a", "b", "phi" ] - ellipse :: Brush EllipseBrushFields -ellipse = BrushData "ellipse" (WithParams deflts shape) +ellipse = BrushData "ellipse" ( WithParams deflts ellipseBrush ) where deflts :: Record EllipseBrushFields deflts = MkR ( ℝ3 1 1 0 ) - shape :: Record EllipseBrushFields -> SplinePts 'Closed - shape ( MkR ( ℝ3 a b phi ) ) = - circleSpline ( \ x y -> Point2D (a * x * cos phi - b * y * sin phi) - (b * y * cos phi + a * x * sin phi) ) -------------------------------------------------------------------------------- -- Differentiable brushes. -circleSpline2 :: ( Double -> Double -> D ( ℝ 3 ) ptData ) -> D ( ℝ 3 ) ( Spline 'Closed () ptData ) -circleSpline2 p = sequenceA $ +circleSpline :: Applicative ( D u ) => ( Double -> Double -> D u v ) -> D u ( Spline 'Closed () v ) +circleSpline p = sequenceA $ Spline { splineStart = p 1 0 , splineCurves = ClosedCurves crvs lastCrv } where @@ -103,24 +82,44 @@ circleSpline2 p = sequenceA $ lastCrv = Bezier3To (p κ -1) (p 1 -κ) BackToStart () -ellipseBrush :: ℝ 3 ~> Spline 'Closed () ( ℝ 2 ) +circleBrush :: Record CircleBrushFields ~> Spline 'Closed () ( ℝ 2 ) +circleBrush = + D \ params -> + let r :: D ( Record CircleBrushFields ) Double + r = runD ( var @1 ) params + mkPt :: Double -> Double -> D ( Record CircleBrushFields ) ( ℝ 2 ) + mkPt ( kon -> x ) ( kon -> y ) + = fmap coerce + $ ( x * r ) *^ e_x + ^+^ ( y * r ) *^ e_y + in circleSpline @( Record CircleBrushFields ) mkPt + where + e_x, e_y :: D ( Record CircleBrushFields ) ( T ( ℝ 2 ) ) + e_x = pure $ T $ ℝ2 1 0 + e_y = pure $ T $ ℝ2 0 1 + + kon = konst @( Record CircleBrushFields ) + +ellipseBrush :: Record EllipseBrushFields ~> Spline 'Closed () ( ℝ 2 ) ellipseBrush = D \ params -> - let a, b, phi :: D ( ℝ 3 ) Double + let a, b, phi :: D ( Record EllipseBrushFields ) Double a = runD ( var @1 ) params b = runD ( var @2 ) params phi = runD ( var @3 ) params - mkPt :: Double -> Double -> D ( ℝ 3 ) ( ℝ 2 ) - mkPt ( konst -> x ) ( konst -> y ) + mkPt :: Double -> Double -> D ( Record EllipseBrushFields ) ( ℝ 2 ) + mkPt ( kon -> x ) ( kon -> y ) = fmap coerce $ ( x * a * cos phi - y * b * sin phi ) *^ e_x ^+^ ( y * b * cos phi + x * a * sin phi ) *^ e_y - in circleSpline2 mkPt + in circleSpline @( Record EllipseBrushFields ) mkPt where - e_x, e_y :: D ( ℝ 3 ) ( T ( ℝ 2 ) ) + e_x, e_y :: D ( Record EllipseBrushFields ) ( T ( ℝ 2 ) ) e_x = pure $ T $ ℝ2 1 0 e_y = pure $ T $ ℝ2 0 1 + kon = konst @( Record EllipseBrushFields ) + --ellipseArc :: ℝ 2 ~> ℝ 2 --ellipseArc = brushStroke ( linear myPath ) ( uncurryD $ fmap bezier3 myBrush ) diff --git a/src/metabrushes/MetaBrush/Brush.hs b/src/metabrushes/MetaBrush/Brush.hs index 7269687..a3fdec0 100644 --- a/src/metabrushes/MetaBrush/Brush.hs +++ b/src/metabrushes/MetaBrush/Brush.hs @@ -37,17 +37,19 @@ import qualified Data.Text as Text ( unpack ) -- MetaBrush +import Math.Linear +import Math.Linear.Dual + ( Diffy ) import Math.Bezier.Spline ( SplineType(Closed), SplinePts) import MetaBrush.Records import MetaBrush.Serialisable -import Math.Linear -------------------------------------------------------------------------------- -- | A brush function: a function from a record of parameters to a closed spline. type BrushFunction :: [ Symbol ] -> Type -type BrushFunction brushFields = WithParams brushFields (SplinePts Closed) +type BrushFunction brushFields = WithParams brushFields ( SplinePts Closed ) type Brush :: [ Symbol ] -> Type data Brush brushFields where @@ -55,6 +57,7 @@ data Brush brushFields where :: forall brushFields . ( KnownSymbols brushFields , Representable ( ℝ ( Length brushFields) ) + , Diffy ( ℝ ( Length brushFields) ) , Typeable brushFields ) => { brushName :: !Text , brushFunction :: BrushFunction brushFields diff --git a/src/metabrushes/MetaBrush/Document.hs b/src/metabrushes/MetaBrush/Document.hs index 1b33a11..bcb76d5 100644 --- a/src/metabrushes/MetaBrush/Document.hs +++ b/src/metabrushes/MetaBrush/Document.hs @@ -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 diff --git a/src/metabrushes/MetaBrush/Document/Draw.hs b/src/metabrushes/MetaBrush/Document/Draw.hs index cc74331..4ab9830 100644 --- a/src/metabrushes/MetaBrush/Document/Draw.hs +++ b/src/metabrushes/MetaBrush/Document/Draw.hs @@ -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 diff --git a/src/metabrushes/MetaBrush/Document/Serialise.hs b/src/metabrushes/MetaBrush/Document/Serialise.hs index b9e8585..750cac0 100644 --- a/src/metabrushes/MetaBrush/Document/Serialise.hs +++ b/src/metabrushes/MetaBrush/Document/Serialise.hs @@ -106,7 +106,7 @@ import qualified Waargonaut.Types.Whitespace as JSON import Math.Bezier.Spline ( SplineType(..), SSplineType(..), SplineTypeI(..) ) import Math.Linear - ( Point2D(..), Vector2D(..)) + ( ℝ(..), T(..) ) import MetaBrush.Asset.Brushes ( lookupBrush ) import MetaBrush.Brush @@ -192,8 +192,8 @@ encodePointData ) => JSON.Encoder f ( PointData brushParams ) encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointCoords, brushParams } ) -> - JSON.Encoder.atKey' "coords" ( encoder @( Point2D Double ) ) pointCoords - . JSON.Encoder.atKey' "brushParams" ( encoder @( Record flds ) ) brushParams + JSON.Encoder.atKey' "coords" ( encoder @( ℝ 2 ) ) pointCoords + . JSON.Encoder.atKey' "brushParams" ( encoder @( Record flds ) ) brushParams decodePointData :: forall m ( flds :: [ Symbol ] ) brushParams @@ -203,7 +203,7 @@ decodePointData ) => JSON.Decoder m ( PointData brushParams ) decodePointData = do - pointCoords <- JSON.Decoder.atKey "coords" ( decoder @( Point2D Double ) ) + pointCoords <- JSON.Decoder.atKey "coords" ( decoder @( ℝ 2 ) ) let pointState :: FocusState pointState = Normal @@ -318,13 +318,13 @@ decodeStrokeHierarchy uniqueSupply = do encodeGuide :: Applicative f => JSON.Encoder f Guide encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) -> - JSON.Encoder.atKey' "point" ( encoder @( Point2D Double ) ) guidePoint - . JSON.Encoder.atKey' "normal" ( encoder @( Vector2D Double ) ) guideNormal + JSON.Encoder.atKey' "point" ( encoder @( ℝ 2 ) ) guidePoint + . JSON.Encoder.atKey' "normal" ( encoder @( T ( ℝ 2 ) ) ) guideNormal decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m Guide decodeGuide uniqueSupply = do - guidePoint <- JSON.Decoder.atKey "point" ( decoder @( Point2D Double ) ) - guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( Vector2D Double ) ) + guidePoint <- JSON.Decoder.atKey "point" ( decoder @( ℝ 2 ) ) + guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( T ( ℝ 2 ) ) ) let guideFocus :: FocusState guideFocus = Normal @@ -356,14 +356,14 @@ encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, documentContent } ) -> JSON.Encoder.atKey' "version" ( JSON.Encoder.list JSON.Encoder.int ) ( versionBranch Cabal.version ) . JSON.Encoder.atKey' "name" JSON.Encoder.text displayName - . JSON.Encoder.atKey' "center" ( encoder @( Point2D Double ) ) viewportCenter + . JSON.Encoder.atKey' "center" ( encoder @( ℝ 2 ) ) viewportCenter . JSON.Encoder.atKey' "zoom" ( encoder @Double ) zoomFactor . JSON.Encoder.atKey' "content" encodeDocumentContent documentContent decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document decodeDocument uniqueSupply mbFilePath = do displayName <- JSON.Decoder.atKey "name" JSON.Decoder.text - viewportCenter <- JSON.Decoder.atKey "center" ( decoder @( Point2D Double ) ) + viewportCenter <- JSON.Decoder.atKey "center" ( decoder @( ℝ 2 ) ) zoomFactor <- JSON.Decoder.atKey "zoom" ( decoder @Double ) documentUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply ) documentContent <- JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply ) diff --git a/src/metabrushes/MetaBrush/Document/SubdivideStroke.hs b/src/metabrushes/MetaBrush/Document/SubdivideStroke.hs index 99f2b2a..e17b851 100644 --- a/src/metabrushes/MetaBrush/Document/SubdivideStroke.hs +++ b/src/metabrushes/MetaBrush/Document/SubdivideStroke.hs @@ -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 diff --git a/src/metabrushes/MetaBrush/Records.hs b/src/metabrushes/MetaBrush/Records.hs index 4f09691..250bba8 100644 --- a/src/metabrushes/MetaBrush/Records.hs +++ b/src/metabrushes/MetaBrush/Records.hs @@ -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 diff --git a/src/metabrushes/MetaBrush/Serialisable.hs b/src/metabrushes/MetaBrush/Serialisable.hs index f4fa221..d240600 100644 --- a/src/metabrushes/MetaBrush/Serialisable.hs +++ b/src/metabrushes/MetaBrush/Serialisable.hs @@ -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 diff --git a/src/splines/Math/Bezier/Cubic.hs b/src/splines/Math/Bezier/Cubic.hs index d3b0e3f..784cf35 100644 --- a/src/splines/Math/Bezier/Cubic.hs +++ b/src/splines/Math/Bezier/Cubic.hs @@ -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 diff --git a/src/splines/Math/Bezier/Cubic/Fit.hs b/src/splines/Math/Bezier/Cubic/Fit.hs index 5f0b91a..2969289 100644 --- a/src/splines/Math/Bezier/Cubic/Fit.hs +++ b/src/splines/Math/Bezier/Cubic/Fit.hs @@ -80,7 +80,7 @@ import Math.Module import Math.Roots ( laguerre ) --, eval, derivative ) import Math.Linear - ( Mat22(..), Point2D(..), Vector2D(..) ) + ( Mat22(..), ℝ(..), T(..) ) -------------------------------------------------------------------------------- @@ -97,10 +97,10 @@ data FitParameters data FitPoint = FitPoint - { fitPoint :: !( Point2D Double ) } + { fitPoint :: !( ℝ 2 ) } | FitTangent - { fitPoint :: !( Point2D Double ) - , fitTangent :: !( Vector2D Double ) + { fitPoint :: !( ℝ 2 ) + , fitTangent :: !( T ( ℝ 2 ) ) } deriving stock ( Show, Generic ) deriving anyclass NFData @@ -120,7 +120,7 @@ data FitPoint -- including the meaning of \( \texttt{t_tol} \) and \( \texttt{maxIters} \). fitSpline :: FitParameters - -> ( Double -> ( Point2D Double, Vector2D Double ) ) -- ^ curve \( t \mapsto ( C(t), C'(t) ) \) to fit + -> ( Double -> ( ℝ 2, T ( ℝ 2 ) ) ) -- ^ curve \( t \mapsto ( C(t), C'(t) ) \) to fit -> ( SplinePts Open, Seq FitPoint ) fitSpline ( FitParameters {..} ) = go 0 where @@ -128,13 +128,13 @@ fitSpline ( FitParameters {..} ) = go 0 dt = recip ( fromIntegral nbSegments ) go :: Int - -> ( Double -> ( Point2D Double, Vector2D Double ) ) + -> ( Double -> ( ℝ 2, T ( ℝ 2 ) ) ) -> ( SplinePts Open, Seq FitPoint ) go subdiv curveFn = let - p, r :: Point2D Double - tp, tr :: Vector2D Double - qs :: [ Point2D Double ] + p, r :: ℝ 2 + tp, tr :: T ( ℝ 2 ) + qs :: [ ℝ 2 ] (p, tp) = curveFn 0 (r, tr) = curveFn 1 qs = [ fst $ curveFn ( dt * fromIntegral j ) | j <- [ 1 .. nbSegments - 1 ] ] @@ -187,15 +187,15 @@ fitSpline ( FitParameters {..} ) = go 0 -- of its corresponding point to fit \( q_i \), -- * the maximum iteration limit \( \texttt{maxIters} \) has been reached. fitPiece - :: Double -- ^ \( \texttt{dist_tol} \), tolerance for the distance - -> Double -- ^ \( \texttt{t_tol} \), the tolerance for the Bézier parameter - -> Int -- ^ \( \texttt{maxIters} \), maximum number of iterations - -> Point2D Double -- ^ \( p \), start point - -> Vector2D Double -- ^ \( \textrm{t}_p \), start tangent vector (length is ignored) - -> [ Point2D Double ] -- ^ \( \left ( q_i \right )_{i=1}^n \), points to fit - -> Point2D Double -- ^ \( r \), end point - -> Vector2D Double -- ^ \( \textrm{t}_r \), end tangent vector (length is ignored) - -> ( Cubic.Bezier ( Point2D Double ), ArgMax Double Double ) + :: Double -- ^ \( \texttt{dist_tol} \), tolerance for the distance + -> Double -- ^ \( \texttt{t_tol} \), the tolerance for the Bézier parameter + -> Int -- ^ \( \texttt{maxIters} \), maximum number of iterations + -> ℝ 2 -- ^ \( p \), start point + -> T ( ℝ 2 ) -- ^ \( \textrm{t}_p \), start tangent vector (length is ignored) + -> [ ℝ 2 ] -- ^ \( \left ( q_i \right )_{i=1}^n \), points to fit + -> ℝ 2 -- ^ \( r \), end point + -> T ( ℝ 2 ) -- ^ \( \textrm{t}_r \), end tangent vector (length is ignored) + -> ( Cubic.Bezier ( ℝ 2 ), ArgMax Double Double ) fitPiece dist_tol t_tol maxIters p tp qs r tr = runST do -- Initialise the parameter values to a uniform subdivision. @@ -207,25 +207,25 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr = uniform :: Int -> Double uniform i = fromIntegral ( i + 1 ) / fromIntegral ( n + 1 ) - f0, f1, f2, f3 :: Double -> Vector2D Double + f0, f1, f2, f3 :: Double -> T ( ℝ 2 ) f0 t = h1 t *^ tp f1 t = h2 t *^ tr - f2 t = h0 t *^ ( MkVector2D p ) - f3 t = h3 t *^ ( MkVector2D r ) + f2 t = h0 t *^ ( T p ) + f3 t = h3 t *^ ( T r ) - loop :: forall s. Unboxed.MVector s Double -> Int -> ST s ( Cubic.Bezier ( Point2D Double ), ArgMax Double Double ) + loop :: forall s. Unboxed.MVector s Double -> Int -> ST s ( Cubic.Bezier ( ℝ 2 ), ArgMax Double Double ) loop ts count = do let - hermiteParameters :: Mat22 Double -> Vector2D Double -> Int -> [ Point2D Double ] -> ST s ( Vector2D Double ) - hermiteParameters ( Mat22 a11 a12 _ a22 ) ( Vector2D b1 b2 ) i ( q : rest ) = do + hermiteParameters :: Mat22 -> T ( ℝ 2 ) -> Int -> [ ℝ 2 ] -> ST s ( T ( ℝ 2 ) ) + hermiteParameters ( Mat22 a11 a12 _ a22 ) ( V2 b1 b2 ) i ( q : rest ) = do ti <- Unboxed.MVector.unsafeRead ts i let - f0i, f1i, f2i, f3i :: Vector2D Double + f0i, f1i, f2i, f3i :: T ( ℝ 2 ) f0i = f0 ti f1i = f1 ti f2i = f2 ti f3i = f3 ti - q' = MkVector2D q ^-^ f2i ^-^ f3i + q' = T q ^-^ f2i ^-^ f3i a11', a12', a21', a22', b1', b2' :: Double a11' = a11 + ( f0i ^.^ f0i ) a12' = a12 + ( f1i ^.^ f0i ) @@ -233,18 +233,18 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr = a22' = a22 + ( f1i ^.^ f1i ) b1' = b1 + ( q' ^.^ f0i ) b2' = b2 + ( q' ^.^ f1i ) - hermiteParameters ( Mat22 a11' a12' a21' a22' ) ( Vector2D b1' b2' ) ( i + 1 ) rest + hermiteParameters ( Mat22 a11' a12' a21' a22' ) ( V2 b1' b2' ) ( i + 1 ) rest hermiteParameters a b _ [] = pure ( linearSolve a b ) - ~(Vector2D s1 s2) <- hermiteParameters ( Mat22 0 0 0 0 ) ( Vector2D 0 0 ) 0 qs + ~(V2 s1 s2) <- hermiteParameters ( Mat22 0 0 0 0 ) ( V2 0 0 ) 0 qs let -- Convert from Hermite form to Bézier form. - cp1, cp2 :: Point2D Double + cp1, cp2 :: ℝ 2 cp1 = ( ( s1 / 3 ) *^ tp ) • p cp2 = ( ( -s2 / 3 ) *^ tr ) • r - bez :: Cubic.Bezier ( Point2D Double ) + bez :: Cubic.Bezier ( ℝ 2 ) bez = Cubic.Bezier p cp1 cp2 r -- Run one iteration of Laguerre's method to improve the parameter values t_i, @@ -256,7 +256,7 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr = laguerreStepResult :: Complex Double laguerreStepResult = runST do coeffs <- unsafeThawPrimArray . primArrayFromListN 6 - $ Cubic.ddist @( Vector2D Double ) bez q + $ Cubic.ddist @( T ( ℝ 2 ) ) bez q laguerre epsilon 1 coeffs ( ti :+ 0 ) ti' <- case laguerreStepResult of x :+ y @@ -272,7 +272,7 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr = $> ( min 1 $ max 0 x ) let sq_dist :: Double - sq_dist = quadrance @( Vector2D Double ) q ( Cubic.bezier @( Vector2D Double ) bez ti' ) + sq_dist = quadrance @( T ( ℝ 2 ) ) q ( Cubic.bezier @( T ( ℝ 2 ) ) bez ti' ) modify' ( second ( <> Max ( Arg sq_dist ti' ) ) ) lift ( Unboxed.MVector.unsafeWrite ts i ti' ) diff --git a/src/splines/Math/Bezier/Envelope.hs b/src/splines/Math/Bezier/Envelope.hs deleted file mode 100644 index 9629c74..0000000 --- a/src/splines/Math/Bezier/Envelope.hs +++ /dev/null @@ -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 diff --git a/src/splines/Math/Bezier/Quadratic.hs b/src/splines/Math/Bezier/Quadratic.hs index 9b6729a..601e2f7 100644 --- a/src/splines/Math/Bezier/Quadratic.hs +++ b/src/splines/Math/Bezier/Quadratic.hs @@ -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 ) diff --git a/src/splines/Math/Bezier/Spline.hs b/src/splines/Math/Bezier/Spline.hs index fb70a1c..90b7706 100644 --- a/src/splines/Math/Bezier/Spline.hs +++ b/src/splines/Math/Bezier/Spline.hs @@ -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 ) diff --git a/src/splines/Math/Bezier/Stroke.hs b/src/splines/Math/Bezier/Stroke.hs index 2016810..d0b70cc 100644 --- a/src/splines/Math/Bezier/Stroke.hs +++ b/src/splines/Math/Bezier/Stroke.hs @@ -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 } -------------------------------------------------------------------------------- diff --git a/src/splines/Math/Linear.hs b/src/splines/Math/Linear.hs index 7266485..cf771d0 100644 --- a/src/splines/Math/Linear.hs +++ b/src/splines/Math/Linear.hs @@ -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 diff --git a/src/splines/Math/Linear/Dual.hs b/src/splines/Math/Linear/Dual.hs index efda6dc..149d846 100644 --- a/src/splines/Math/Linear/Dual.hs +++ b/src/splines/Math/Linear/Dual.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/src/splines/Math/Linear/Solve.hs b/src/splines/Math/Linear/Solve.hs index cfd2e96..d6f8f7e 100644 --- a/src/splines/Math/Linear/Solve.hs +++ b/src/splines/Math/Linear/Solve.hs @@ -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 diff --git a/src/splines/Math/Module.hs b/src/splines/Math/Module.hs index eb2e98d..db952dd 100644 --- a/src/splines/Math/Module.hs +++ b/src/splines/Math/Module.hs @@ -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 diff --git a/src/splines/Math/Orientation.hs b/src/splines/Math/Orientation.hs index 2acf7ff..91d1adf 100644 --- a/src/splines/Math/Orientation.hs +++ b/src/splines/Math/Orientation.hs @@ -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'` τ