update render & select for new brush manipulation

This commit is contained in:
sheaf 2021-05-24 17:30:25 +02:00
parent 15d50f8d76
commit 5ff935b4b2
10 changed files with 418 additions and 220 deletions

View file

@ -32,7 +32,7 @@ common common
build-depends:
base
>= 4.13 && < 4.17
>= 4.13 && < 4.17
, acts
^>= 0.3.1.0
, containers

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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