From 5ff935b4b21ece4a46119bbf79d70bc0cbd59b16 Mon Sep 17 00:00:00 2001 From: sheaf Date: Mon, 24 May 2021 17:30:25 +0200 Subject: [PATCH] update render & select for new brush manipulation --- MetaBrush.cabal | 2 +- assets/theme.css | 2 +- cabal.project | 2 +- installation_notes.md | 18 +- src/app/MetaBrush/Action.hs | 371 ++++++++++++------------ src/app/MetaBrush/Action.hs-boot | 8 +- src/app/MetaBrush/Document/Selection.hs | 3 +- src/app/MetaBrush/Render/Document.hs | 63 ++-- src/lib/Math/Bezier/Envelope.hs | 165 ++++++++++- src/lib/Math/Bezier/Stroke.hs | 4 +- 10 files changed, 418 insertions(+), 220 deletions(-) diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 626c74c..2852902 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -32,7 +32,7 @@ common common build-depends: base - >= 4.13 && < 4.17 + >= 4.13 && < 4.17 , acts ^>= 0.3.1.0 , containers diff --git a/assets/theme.css b/assets/theme.css index a6b4997..6b08a55 100644 --- a/assets/theme.css +++ b/assets/theme.css @@ -53,7 +53,7 @@ color: rgb(184,80,80); } .brush { - color: rgb(235,118,219); + color: rgb(106,63,222); } .brushStroke { color: rgba(235,118,219,0.66); diff --git a/cabal.project b/cabal.project index 9f78283..3d4541e 100644 --- a/cabal.project +++ b/cabal.project @@ -5,7 +5,7 @@ constraints: allow-newer: waargonaut:*, - *:haskell-gi-base, *:haskell-gi, + *:haskell-gi-base, *:haskell-gi -- various fixes for 'hmatrix' source-repository-package diff --git a/installation_notes.md b/installation_notes.md index dd65689..dbcc526 100644 --- a/installation_notes.md +++ b/installation_notes.md @@ -3,8 +3,7 @@ On Windows, we need to install an up-to-date MinGW/MSYS2 toolchain, together with the packages required by the `haskell-gi` libraries (for `GTK`), -as well as the `hmatrix` library. - +the `hmatrix` library, as well as `flint` and `msolve`. With an `MSYS2` installation, the following environment variables will need to be set (with `MSYS2` installed at `C:\msys64`): @@ -16,9 +15,22 @@ With an `MSYS2` installation, the following environment variables will need to b Then we install some necessary packages using the following command: ```bash -pacman -S -q --noconfirm mingw64/mingw-w64-x86_64-pkg-config mingw64/mingw-w64-x86_64-gobject-introspection mingw64/mingw-w64-x86_64-gtksourceview3 mingw64/mingw-w64-x86_64-openblas +pacman -S -q --noconfirm mingw64/mingw-w64-x86_64-pkg-config mingw64/mingw-w64-x86_64-gobject-introspection mingw64/mingw-w64-x86_64-openblas ``` +Next, `flint`, which `msolve` depends on. + +Build `flint` by downloading it and running the configure script. On Windows (MINGW64): + +```bash +./configure ABI=64 --build=${MINGW_CHOST} --prefix=${MINGW_PREFIX} --enable-static --disable-shared --with-gmp=${MINGW_PREFIX} --with-mpfr=${MINGW_PREFIX} +make && make install +``` + +`flint` needs `gmp`, `mpfr`, but these should already be present. + +For `msolve`, the default installation directions (`./autogen.sh`, `./configure`, `make && make install`) seem to work (without having to set any additional options), as of `msolve` version `0.1.3`. + ## Possible errors ### pkg-config could not be found diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 4fbcc79..afd775c 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -103,7 +103,7 @@ import Math.Bezier.Spline import Math.Bezier.Stroke ( CachedStroke(..), invalidateCache ) import Math.Module - ( Module((*^)) ) + ( Module((*^)), quadrance ) import Math.Vector2D ( Point2D(..), Vector2D(..) ) import MetaBrush.Context @@ -722,7 +722,13 @@ data MouseClickType | DoubleClick deriving stock Show -data MouseClick = MouseClick !ActionOrigin !MouseClickType !Word32 !( Point2D Double ) +data MouseClick = + MouseClick + { clickOrigin :: !ActionOrigin + , clickType :: !MouseClickType + , clickButton :: !Word32 + , clickCoords :: !( Point2D Double ) + } deriving stock Show instance HandleAction MouseClick where @@ -744,108 +750,108 @@ instance HandleAction MouseClick where pos = toViewport mouseClickCoords STM.writeTVar mousePosTVar ( Just pos ) mode <- STM.readTVar modeTVar - case mode of - BrushMode -> pure Don'tModifyDoc -- TODO: brush parameter modification UI - _ -> - case actionOrigin of + case actionOrigin of - ViewportOrigin -> case ty of + ViewportOrigin -> case ty of - SingleClick -> do - modifiers <- STM.readTVar modifiersTVar - tool <- STM.readTVar toolTVar + SingleClick -> do + modifiers <- STM.readTVar modifiersTVar + tool <- STM.readTVar toolTVar - case tool of - -- Selection mode mouse hold: - -- - -- - If holding shift or alt, mouse hold initiates a rectangular selection. - -- - If not holding shift or alt: - -- - if mouse click selected an object, initiate a drag move, - -- - otherwise, initiate a rectangular selection. - Selection -> - case selectionMode modifiers of - -- Drag move: not holding shift or alt, click has selected something. - New - | Just ( dragMove, newDoc ) <- dragMoveSelect pos doc - -> do - STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove ) - case dragMove of - ClickedOnSelected -> - pure Don'tModifyDoc - ClickedOnUnselected -> - pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc ) - ClickedOnCurve {} -> - pure Don'tModifyDoc - -- Rectangular selection. - _ -> do - STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos ) - pure Don'tModifyDoc - - -- Pen tool: start or continue a drawing operation. - Pen -> do - mbPartialPath <- STM.readTVar partialPathTVar - STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos ) - case mbPartialPath of - -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke). - Nothing -> do - ( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <- - getOrCreateDrawAnchor uniqueSupply pos doc - STM.writeTVar partialPathTVar - ( Just $ PartialPath - { partialStartPos = anchorPt - , partialControlPoint = Nothing - , partialPathAnchor = drawAnchor - , firstPoint = True - } - ) - case mbExistingAnchorName of - Nothing -> - let - changeText :: Text - changeText = "Begin new stroke" - in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) - Just _ -> - pure Don'tModifyDoc - -- Path already started: indicate that we are continuing a path. - Just pp -> do - STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } ) - pure Don'tModifyDoc - - DoubleClick -> do - tool <- STM.readTVar toolTVar - modifs <- STM.readTVar modifiersTVar - case tool of - Selection + case tool of + -- Selection mode mouse hold: + -- + -- - If holding shift or alt, mouse hold initiates a rectangular selection. + -- - If not holding shift or alt: + -- - if mouse click selected an object, initiate a drag move, + -- - otherwise, initiate a rectangular selection. + Selection -> + case selectionMode modifiers of + -- Drag move: not holding shift or alt, click has selected something. + New | PathMode <- mode - , null modifs + , Just ( dragMove, newDoc ) <- dragMoveSelect pos doc -> do - STM.writeTVar mouseHoldTVar Nothing - case subdivide pos doc of - Nothing -> + STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove ) + case dragMove of + ClickedOnSelected -> pure Don'tModifyDoc - Just ( newDocument, loc ) -> do - let - changeText :: Text - changeText = "Subdivide " <> loc - pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) - - -- Ignore double click event otherwise. - _ -> pure Don'tModifyDoc + ClickedOnUnselected -> + pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc ) + ClickedOnCurve {} -> + pure Don'tModifyDoc + -- Rectangular selection. + _ -> do + STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos ) + pure Don'tModifyDoc - RulerOrigin ruler -> do - showGuides <- STM.readTVar showGuidesTVar - when showGuides do - let - mbGuide :: Maybe Guide - mbGuide = selectedGuide pos doc - guideAction :: GuideAction - guideAction - | Just guide <- mbGuide - = MoveGuide ( guideUnique guide ) - | otherwise - = CreateGuide ruler - STM.writeTVar mouseHoldTVar ( Just $ GuideAction { holdStartPos = pos, guideAction } ) - pure Don'tModifyDoc + -- Pen tool: start or continue a drawing operation. + Pen | PathMode <- mode -> do + mbPartialPath <- STM.readTVar partialPathTVar + STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos ) + case mbPartialPath of + -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke). + Nothing -> do + ( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <- + getOrCreateDrawAnchor uniqueSupply pos doc + STM.writeTVar partialPathTVar + ( Just $ PartialPath + { partialStartPos = anchorPt + , partialControlPoint = Nothing + , partialPathAnchor = drawAnchor + , firstPoint = True + } + ) + case mbExistingAnchorName of + Nothing -> + let + changeText :: Text + changeText = "Begin new stroke" + in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) + Just _ -> + pure Don'tModifyDoc + -- Path already started: indicate that we are continuing a path. + Just pp -> do + STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } ) + pure Don'tModifyDoc + + _ -> pure Don'tModifyDoc + + DoubleClick -> do + tool <- STM.readTVar toolTVar + modifs <- STM.readTVar modifiersTVar + case tool of + Selection + | PathMode <- mode + , null modifs + -> do + STM.writeTVar mouseHoldTVar Nothing + case subdivide pos doc of + Nothing -> + pure Don'tModifyDoc + Just ( newDocument, loc ) -> do + let + changeText :: Text + changeText = "Subdivide " <> loc + pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) + + -- Ignore double click event otherwise. + _ -> pure Don'tModifyDoc + + RulerOrigin ruler -> do + showGuides <- STM.readTVar showGuidesTVar + when showGuides do + let + mbGuide :: Maybe Guide + mbGuide = selectedGuide pos doc + guideAction :: GuideAction + guideAction + | Just guide <- mbGuide + = MoveGuide ( guideUnique guide ) + | otherwise + = CreateGuide ruler + STM.writeTVar mouseHoldTVar ( Just $ GuideAction { holdStartPos = pos, guideAction } ) + pure Don'tModifyDoc -- Right mouse button: end partial path. 3 -> STM.atomically do @@ -940,62 +946,92 @@ instance HandleAction MouseRelease where _ -> do tool <- STM.readTVar toolTVar mode <- STM.readTVar modeTVar - case mode of - BrushMode -> pure Don'tModifyDoc -- TODO: brush parameter modification UI - _ -> - case tool of + case tool of - Selection -> do - let - selMode :: SelectionMode - selMode = selectionMode modifiers - case mbHoldPos of - Just hold - | DragMoveHold { holdStartPos = pos0, dragAction } <- hold - , pos0 /= pos - -> let - alternateMode :: Bool - alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers - in case dragUpdate pos0 pos dragAction alternateMode doc of - Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd ) - Nothing -> pure Don'tModifyDoc - | SelectionHold pos0 <- hold - -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle selMode pos0 pos doc ) - _ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc ) + Selection -> do + let + selMode :: SelectionMode + selMode = selectionMode modifiers + case mbHoldPos of + Just hold + | PathMode <- mode + , DragMoveHold { holdStartPos = pos0, dragAction } <- hold + , quadrance @( Vector2D Double ) pos0 pos * zoomFactor ^ ( 2 :: Int ) >= 16 + -> let + alternateMode :: Bool + alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers + in case dragUpdate pos0 pos dragAction alternateMode doc of + Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd ) + Nothing -> pure Don'tModifyDoc + | SelectionHold pos0 <- hold + , quadrance @( Vector2D Double ) pos0 pos * zoomFactor ^ ( 2 :: Int ) >= 16 + -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle selMode pos0 pos doc ) + _ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc ) - Pen -> do - mbPartialPath <- STM.readTVar partialPathTVar - case mbPartialPath of - -- Normal pen mode mouse click should have created an anchor. - -- If no anchor exists, then just ignore the mouse release event. - Nothing -> pure Don'tModifyDoc - -- Mouse click release possibilities: - -- - -- - click was on complementary draw stroke draw anchor to close the path, - -- - release at same point as click: finish current segment, - -- - release at different point as click: finish current segment, adding a control point. - Just - ( PartialPath - { partialStartPos = p1 - , partialControlPoint = mbCp2 - , partialPathAnchor = anchor - , firstPoint - } - ) -> do + Pen + | PathMode <- mode + -> do + mbPartialPath <- STM.readTVar partialPathTVar + case mbPartialPath of + -- Normal pen mode mouse click should have created an anchor. + -- If no anchor exists, then just ignore the mouse release event. + Nothing -> pure Don'tModifyDoc + -- Mouse click release possibilities: + -- + -- - click was on complementary draw stroke draw anchor to close the path, + -- - release at same point as click: finish current segment, + -- - release at different point as click: finish current segment, adding a control point. + Just + ( PartialPath + { partialStartPos = p1 + , partialControlPoint = mbCp2 + , partialPathAnchor = anchor + , firstPoint + } + ) -> do + let + pathPoint :: Point2D Double + mbControlPoint :: Maybe ( Point2D Double ) + partialControlPoint :: Maybe ( Point2D Double ) + ( pathPoint, mbControlPoint, partialControlPoint ) + | Just ( DrawHold holdPos ) <- mbHoldPos + = ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos ) + | otherwise + = ( pos, Nothing, Nothing ) + ( _, otherAnchor, otherAnchorPt, _ ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc + if not firstPoint && anchorsAreComplementary anchor otherAnchor + -- Close path. + then do + STM.writeTVar partialPathTVar Nothing let - pathPoint :: Point2D Double - mbControlPoint :: Maybe ( Point2D Double ) - partialControlPoint :: Maybe ( Point2D Double ) - ( pathPoint, mbControlPoint, partialControlPoint ) - | Just ( DrawHold holdPos ) <- mbHoldPos - = ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos ) - | otherwise - = ( pos, Nothing, Nothing ) - ( _, otherAnchor, otherAnchorPt, _ ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc - if not firstPoint && anchorsAreComplementary anchor otherAnchor - -- Close path. + newSegment :: Spline Open ( CachedStroke RealWorld ) ( PointData () ) + newSegment = catMaybesSpline ( invalidateCache undefined ) + ( PointData p1 Normal () ) + ( do + cp <- mbCp2 + guard ( cp /= p1 ) + pure ( PointData cp Normal () ) + ) + ( do + cp <- mbControlPoint + guard ( cp /= otherAnchorPt ) + pure ( PointData cp Normal () ) + ) + ( PointData otherAnchorPt Normal () ) + newDocument :: Document + newDocument = addToAnchor anchor newSegment doc + changeText :: Text + changeText = "Close stroke" + pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) + else + if firstPoint + -- Continue current partial path. then do - STM.writeTVar partialPathTVar Nothing + STM.writeTVar partialPathTVar ( Just $ PartialPath p1 partialControlPoint anchor False ) + pure Don'tModifyDoc + -- Finish current partial path. + else do + STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False ) let newSegment :: Spline Open ( CachedStroke RealWorld ) ( PointData () ) newSegment = catMaybesSpline ( invalidateCache undefined ) @@ -1007,44 +1043,17 @@ instance HandleAction MouseRelease where ) ( do cp <- mbControlPoint - guard ( cp /= otherAnchorPt ) + guard ( cp /= pathPoint ) pure ( PointData cp Normal () ) ) - ( PointData otherAnchorPt Normal () ) + ( PointData pathPoint Normal () ) newDocument :: Document newDocument = addToAnchor anchor newSegment doc changeText :: Text - changeText = "Close stroke" + changeText = "Continue stroke" pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) - else - if firstPoint - -- Continue current partial path. - then do - STM.writeTVar partialPathTVar ( Just $ PartialPath p1 partialControlPoint anchor False ) - pure Don'tModifyDoc - -- Finish current partial path. - else do - STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False ) - let - newSegment :: Spline Open ( CachedStroke RealWorld ) ( PointData () ) - newSegment = catMaybesSpline ( invalidateCache undefined ) - ( PointData p1 Normal () ) - ( do - cp <- mbCp2 - guard ( cp /= p1 ) - pure ( PointData cp Normal () ) - ) - ( do - cp <- mbControlPoint - guard ( cp /= pathPoint ) - pure ( PointData cp Normal () ) - ) - ( PointData pathPoint Normal () ) - newDocument :: Document - newDocument = addToAnchor anchor newSegment doc - changeText :: Text - changeText = "Continue stroke" - pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) + + _ -> pure Don'tModifyDoc -- Other mouse buttons: ignored (for the moment at least). _ -> pure () diff --git a/src/app/MetaBrush/Action.hs-boot b/src/app/MetaBrush/Action.hs-boot index ec8d260..a2a823b 100644 --- a/src/app/MetaBrush/Action.hs-boot +++ b/src/app/MetaBrush/Action.hs-boot @@ -116,7 +116,13 @@ data ActionOrigin data MouseClickType = SingleClick | DoubleClick -data MouseClick = MouseClick !ActionOrigin !MouseClickType !Word32 !( Point2D Double ) +data MouseClick = + MouseClick + { clickOrigin :: !ActionOrigin + , clickType :: !MouseClickType + , clickButton :: !Word32 + , clickCoords :: !( Point2D Double ) + } instance HandleAction MouseClick data MouseRelease = MouseRelease !Word32 !( Point2D Double ) diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 2fa8970..1f4a848 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -177,8 +177,7 @@ selectAt selMode c doc@( Document { zoomFactor } ) = . ( KnownSplineType clo ) => StrokeSpline clo brushParams -> State Bool ( StrokeSpline clo brushParams ) updateSpline oldSpline = - bitraverseSpline - ( const pure ) + traverse ( updateSplinePoint strokeVisible ) oldSpline diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index ee8adc3..221c8d7 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -159,6 +159,11 @@ compositeRenders = sequenceA_ toAll :: Cairo.Render () -> Compose Renders Cairo.Render () toAll action = Compose ( pure action ) +data RenderMode + = RenderingPath + | RenderingBrush + deriving stock ( Show, Eq ) + -------------------------------------------------------------------------------- blankRender :: Colours -> Cairo.Render () @@ -251,7 +256,7 @@ getDocumentRender Cairo.scale zoomFactor zoomFactor Cairo.translate ( -cx ) ( -cy ) for_ strokesRenderData - ( compositeRenders . getCompose . renderStroke cols mbHoverContext mode debug zoomFactor ) + ( compositeRenders . getCompose . renderStroke cols mbHoverContext mode RenderingPath debug zoomFactor ) renderSelectionRect Cairo.restore @@ -327,16 +332,16 @@ strokeRenderData fitParams = Nothing renderStroke - :: Colours -> Maybe HoverContext -> Mode -> Bool -> Double + :: Colours -> Maybe HoverContext -> Mode -> RenderMode -> Bool -> Double -> StrokeRenderData -> Compose Renders Cairo.Render () -renderStroke cols@( Colours { brush } ) mbHoverContext mode debug zoom = \case +renderStroke cols@( Colours { brush } ) mbHoverContext mode rdrMode debug zoom = \case StrokeRenderData { strokeDataSpline } -> - renderStrokeSpline cols mode mbHoverContext zoom ( const ( pure () ) ) strokeDataSpline + renderStrokeSpline cols mode rdrMode mbHoverContext zoom ( const ( pure () ) ) strokeDataSpline StrokeWithOutlineRenderData strokeDataSpline strokeOutlineData strokeBrushFunction -> - renderStrokeSpline cols mode mbHoverContext zoom + renderStrokeSpline cols mode rdrMode mbHoverContext zoom ( when ( mode == BrushMode ) - . renderBrushShape ( cols { path = brush } ) mbHoverContext ( 1.5 * zoom ) strokeBrushFunction + . renderBrushShape ( cols { path = brush } ) mbHoverContext ( 2 * zoom ) strokeBrushFunction ) strokeDataSpline *> Compose blank { renderStrokes = drawOutline cols debug zoom strokeOutlineData } @@ -348,17 +353,21 @@ renderStroke cols@( Colours { brush } ) mbHoverContext mode debug zoom = \case renderStrokeSpline :: forall clo crvData pointData . ( Show pointData, KnownSplineType clo ) - => Colours -> Mode -> Maybe HoverContext -> Double + => Colours -> Mode -> RenderMode -> Maybe HoverContext -> Double -> ( PointData pointData -> Compose Renders Cairo.Render () ) -> Spline clo crvData ( PointData pointData ) -> Compose Renders Cairo.Render () -renderStrokeSpline cols mode mbHover zoom renderSubcontent spline = +renderStrokeSpline cols mode rdrMode mbHover zoom renderSubcontent spline = bifoldSpline ( renderSplineCurve ( splineStart spline ) ) renderSplinePoint spline where renderSplinePoint :: PointData pointData -> Compose Renders Cairo.Render () renderSplinePoint sp0 - = Compose blank { renderPPts = when ( mode == PathMode ) $ drawPoint cols mbHover zoom PathPoint sp0 } + = Compose blank + { renderPPts = + when ( rdrMode == RenderingPath ) do + drawPoint cols mbHover zoom PathPoint sp0 + } *> renderSubcontent sp0 renderSplineCurve :: forall clo' @@ -366,48 +375,50 @@ renderStrokeSpline cols mode mbHover zoom renderSubcontent spline = => PointData pointData -> PointData pointData -> Curve clo' crvData ( PointData pointData ) -> Compose Renders Cairo.Render () renderSplineCurve start p0 ( LineTo np1 _ ) = Compose blank - { renderPPts = - when ( mode == PathMode ) $ - for_ np1 \ p1 -> - drawPoint cols mbHover zoom PathPoint p1 + { renderPPts = when ( rdrMode == RenderingPath ) do + for_ np1 \ p1 -> + drawPoint cols mbHover zoom PathPoint p1 , renderPath = unless ( mode == MetaMode ) $ - drawLine cols zoom PathPoint p0 ( fromNextPoint start np1 ) + drawLine cols zoom PathPoint p0 ( fromNextPoint start np1 ) } *> for_ np1 \ p1 -> renderSubcontent p1 renderSplineCurve start p0 ( Bezier2To p1 np2 _ ) = Compose blank { renderCLines - = when ( mode == PathMode ) do + = when ( rdrMode == RenderingPath ) do drawLine cols zoom ControlPoint p0 p1 drawLine cols zoom ControlPoint p1 ( fromNextPoint start np2 ) , renderCPts - = when ( mode == PathMode ) $ drawPoint cols mbHover zoom ControlPoint p1 + = when ( rdrMode == RenderingPath ) do + drawPoint cols mbHover zoom ControlPoint p1 , renderPPts - = when ( mode == PathMode ) $ + = when ( rdrMode == RenderingPath ) do for_ np2 \ p2 -> - drawPoint cols mbHover zoom PathPoint p2 + drawPoint cols mbHover zoom PathPoint p2 , renderPath - = unless ( mode == MetaMode ) $ drawQuadraticBezier cols zoom ( coords <$> Quadratic.Bezier { p0, p1, p2 = fromNextPoint start np2 } ) + = unless ( mode == MetaMode ) do + drawQuadraticBezier cols zoom ( coords <$> Quadratic.Bezier { p0, p1, p2 = fromNextPoint start np2 } ) } *> renderSubcontent p1 *> for_ np2 \ p2 -> renderSubcontent p2 renderSplineCurve start p0 ( Bezier3To p1 p2 np3 _ ) = Compose blank { renderCLines - = when ( mode == PathMode ) do + = when ( rdrMode == RenderingPath ) do drawLine cols zoom ControlPoint p0 p1 drawLine cols zoom ControlPoint p2 ( fromNextPoint start np3 ) , renderCPts - = when ( mode == PathMode ) do + = when ( rdrMode == RenderingPath ) do drawPoint cols mbHover zoom ControlPoint p1 drawPoint cols mbHover zoom ControlPoint p2 , renderPPts - = when ( mode == PathMode ) $ + = when ( rdrMode == RenderingPath ) do for_ np3 \ p3 -> drawPoint cols mbHover zoom PathPoint p3 , renderPath - = unless ( mode == MetaMode ) $ drawCubicBezier cols zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 = fromNextPoint start np3 } ) + = unless ( mode == MetaMode ) do + drawCubicBezier cols zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 = fromNextPoint start np3 } ) } *> renderSubcontent p1 *> renderSubcontent p2 @@ -430,9 +441,8 @@ renderBrushShape cols mbHoverContext zoom brushFn pt = toAll do Cairo.save Cairo.translate x y - *> renderStrokeSpline cols PathMode mbHoverContext' zoom ( const $ pure () ) + *> renderStrokeSpline cols BrushMode RenderingBrush mbHoverContext' zoom ( const $ pure () ) ( fmap ( \ p -> PointData p Normal () ) brushPts ) - *> Compose blank { renderPPts = drawCross cols zoom } *> toAll Cairo.restore drawPoint :: Colours -> Maybe HoverContext -> Double -> PointType -> PointData brushData -> Cairo.Render () @@ -659,6 +669,7 @@ drawSelectionRectangle ( Colours {..} ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1 ) Cairo.restore +{- drawCross :: Colours -> Double -> Cairo.Render () drawCross ( Colours {..} ) zoom = do Cairo.save @@ -677,7 +688,7 @@ drawCross ( Colours {..} ) zoom = do Cairo.stroke Cairo.restore - +-} hsl2rgb :: Double -> Double -> Double -> ( Double, Double, Double ) hsl2rgb h s l = case hc2rgb h c of diff --git a/src/lib/Math/Bezier/Envelope.hs b/src/lib/Math/Bezier/Envelope.hs index 823f247..3801d7d 100644 --- a/src/lib/Math/Bezier/Envelope.hs +++ b/src/lib/Math/Bezier/Envelope.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Math.Bezier.Envelope where @@ -29,6 +33,163 @@ import Math.Vector2D -------------------------------------------------------------------------------- +{- +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.Vector2D 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. -- diff --git a/src/lib/Math/Bezier/Stroke.hs b/src/lib/Math/Bezier/Stroke.hs index b5448b3..0ea95e9 100644 --- a/src/lib/Math/Bezier/Stroke.hs +++ b/src/lib/Math/Bezier/Stroke.hs @@ -483,7 +483,7 @@ outlineFunctions ptParams brushFn sp0 crv = -> ( brush3, Cubic.bezier @( Vector2D Double ) bez, Cubic.bezier' bez ) fwd, bwd :: Double -> ( Point2D Double, Vector2D Double ) fwd t - = ( offset ( withTangent ( fwd' t ) ( brush t ) ) • f t + = ( off t --offset ( withTangent ( fwd' t ) ( brush t ) ) • f t , fwd' t ) where @@ -502,7 +502,7 @@ outlineFunctions ptParams brushFn sp0 crv = | otherwise = offTgt u bwd t - = ( offset ( withTangent ( (-1) *^ bwd' s ) ( brush s ) ) • f s + = ( off s --offset ( withTangent ( (-1) *^ bwd' s ) ( brush s ) ) • f s , bwd' s ) where