brush-stroking-0.1.0.0: src/BrushStroking/Render/Stroke.hs
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
module BrushStroking.Render.Stroke
( Renders(..), compositeRenders, blankRender
, RenderColours(..), RGBA(..)
, StrokeRenderData(..)
, strokeRenderData
, WantedElements(..)
, renderStroke
, drawRectangle, drawSelectionRectangle
, withRGBA
, Renderable(..), NoExtraRenderData(..)
)
where
-- base
import Control.Monad
( when )
import Control.Monad.ST
( RealWorld, ST )
import Data.Coerce
( coerce )
import Data.Fixed
( mod' )
import Data.Foldable
( for_, sequenceA_, traverse_ )
import Data.Functor.Compose
( Compose(..) )
import Data.Kind
( Type, Constraint )
import Data.Maybe
( fromMaybe )
import GHC.Generics
( Generic, Generic1, Generically1(..) )
import GHC.Exts
( Proxy# )
-- acts
import Data.Act
( Act(..) )
-- containers
import qualified Data.Map.Strict as Map
import Data.Sequence
( Seq(..) )
import Data.Set
( Set )
import qualified Data.Set as Set
-- deepseq
import Control.DeepSeq
( NFData(..), deepseq )
-- gi-cairo-render
import qualified GI.Cairo.Render as Cairo
-- text
import Data.Text
( Text )
-- transformers
import Control.Monad.Trans.Class
( lift )
import Control.Monad.Trans.State.Strict
( StateT, evalStateT, get, put )
-- brush-strokes
import Calligraphy.Brushes
( Brush(..), getUnrotated )
import Math.Algebra.Dual
( D2𝔸1(..), fun )
import qualified Math.Bezier.Cubic as Cubic
( Bezier(..), fromQuadratic )
import Math.Bezier.Cubic.Fit
( FitPoint(..), FitParameters, FwdBwd(..) )
import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..) )
import Math.Bezier.Spline
import Math.Bezier.Stroke
( Cusp(..), invalidateCache
, computeStrokeOutline_specialise
, RootSolvingAlgorithm
)
import Math.Epsilon
( epsilon )
import Math.Linear
( ℝ(..), T(..)
, rotate
)
import Math.Module
( Module((*^)), normalise )
import Math.Root.Isolation
( RootIsolationOptions )
-- MetaBrush
import BrushStroking.Asset.Brushes
( SomeBrush(..), lookupBrush )
import BrushStroking.Brush
( NamedBrush(..), WithParams(..) )
import BrushStroking.Document
import BrushStroking.Document.Serialise
( ) -- 'Serialisable' instances
import BrushStroking.Hover
( HoverContext(..), Hoverable(..)
)
import BrushStroking.Records
import BrushStroking.Stroke
import BrushStroking.Unique
( Unique )
--------------------------------------------------------------------------------
data Renders a
= Renders
{ renderStrokes, renderPath, renderDebug
, renderBrushes, renderBrushWidgets
, renderCLines, renderCPts, renderPPts :: a
}
deriving stock ( Show, Functor, Foldable, Traversable, Generic, Generic1 )
deriving Applicative
via Generically1 Renders
blankRender :: Renders ( Cairo.Render () )
blankRender = pure ( pure () )
compositeRenders :: Renders ( Cairo.Render () ) -> Cairo.Render ()
compositeRenders = sequenceA_
toAll :: Cairo.Render () -> Compose Renders Cairo.Render ()
toAll action = Compose ( pure action )
data WantedElements
= WantedElements
{ wantPoints :: !Bool
, wantPaths :: !Bool
, wantBrushes :: !Bool
} deriving stock ( Show, Eq )
data RGBA = RGBA { r, g, b, a :: !Double }
deriving stock ( Eq, Show )
data RenderColours a
= RenderColours
{ path, brush, brushStroke
, pathPoint, pathPointOutline
, selected, selectedOutline
, pointSelected, pointHover
, controlPoint, controlPointLine, controlPointOutline
, brushWidget, brushWidgetHover
, base, empty, emptyOutline
:: !a
}
deriving stock ( Show, Eq, Generic, Generic1, Functor, Foldable, Traversable )
deriving Applicative
via Generically1 RenderColours
-- | Utility type to gather information needed to render a stroke.
--
-- - No outline: just the underlying spline.
-- - Outline: keep track of the function which returns brush shape.
data StrokeRenderData extraData where
StrokeRenderData
:: forall pointParams clo extraData
. ( KnownSplineType clo, Show pointParams, NFData pointParams )
=> { strokeDataSpline :: !( StrokeSpline clo pointParams ) }
-> StrokeRenderData extraData
StrokeWithOutlineRenderData
:: forall pointParams clo extraData
. ( KnownSplineType clo, Show pointParams, NFData pointParams )
=> { strokeDataSpline :: !( StrokeSpline clo pointParams )
, strokeOutlineData :: !( Either
( SplinePts Closed )
( SplinePts Closed, SplinePts Closed )
, Seq FitPoint
, [ Cusp ]
)
, strokeBrushFunction :: pointParams -> SplinePts Closed
, strokeExtraData :: !( extraData pointParams )
}
-> StrokeRenderData extraData
instance ( forall flds. NFData ( extraData flds ) ) => NFData ( StrokeRenderData extraData ) where
rnf ( StrokeRenderData spline ) =
rnf spline
rnf ( StrokeWithOutlineRenderData
{ strokeDataSpline
, strokeOutlineData
, strokeExtraData } ) =
strokeDataSpline
`deepseq`
strokeOutlineData
`deepseq`
strokeExtraData
`deepseq`
()
--------------------------------------------------------------------------------
type Renderable :: ( Type -> Type ) -> Constraint
class Renderable f where
renderAt
:: RenderColours RGBA
-> Zoom
-> Maybe HoverContext
-> PointData pointParams
-> f pointParams
-> Compose Renders Cairo.Render ()
type NoExtraRenderData :: Type -> Type
data NoExtraRenderData pointParams = NoExtraRenderData
deriving stock ( Eq, Ord, Show, Generic )
deriving anyclass NFData
instance Renderable NoExtraRenderData where
renderAt _ _ _ _ _ = pure ()
-- | Compute the data necessary to render a stroke.
--
-- - If the stroke has an associated brush, this consists of:
-- - the path that the brush follows,
-- - the computed outline (using fitting algorithm),
-- - the brush shape function,
-- - the brush widget (UI for modifying brush parameters).
-- - Otherwise, this consists of the underlying spline path only.
strokeRenderData
:: ( forall pointParams brushFields
. KnownSymbols brushFields
=> Text
-> ( pointParams -> Record brushFields )
-> extraData pointParams
)
-> RootSolvingAlgorithm
-> Maybe ( RootIsolationOptions 1 1, RootIsolationOptions 1 2, RootIsolationOptions 2 3 )
-> FitParameters
-> Stroke
-> ST s ( StrokeRenderData extraData )
strokeRenderData mkExtraData rootAlgo mbCuspOptions fitParams
( Stroke
{ strokeSpline = spline :: StrokeSpline clo ( Record pointFields )
, strokeBrushName = mbStrokeBrush
}
) = case mbStrokeBrush of
Just brushName
| Just
( SomeBrush
( NamedBrush { brushFunction = fn } :: NamedBrush brushFields )
) <- lookupBrush brushName
, WithParams
{ defaultParams = brush_defaults
, withParams = brush@( Brush { brushBaseShape, mbRotation = mbRot } )
} <- fn
-> -- This is the key place where we need to perform impedance matching
-- between the collection of parameters supplied along a stroke and
-- the collection of parameters expected by the brush.
intersect @pointFields @brushFields
\ ( Intersection
{ lg2 = ( _ :: Proxy# nbBrushFields )
, lg12 = ( _ :: Proxy# nbUsedFields )
, inject2
, project1 = toUsedParams :: Record pointFields -> Record usedFields }
) -> do
let embedUsedParams = inject2 $ MkR brush_defaults
-- Compute the outline using the brush function.
( outline, fitPts, cusps ) <-
computeStrokeOutline_specialise @clo @nbUsedFields @nbBrushFields
rootAlgo mbCuspOptions fitParams
( coerce toUsedParams . brushParams ) ( coerce embedUsedParams )
brush ( coCache spline )
pure $
StrokeWithOutlineRenderData
{ strokeDataSpline = spline
, strokeOutlineData = ( outline, fitPts, cusps )
, strokeBrushFunction =
\ params ->
let MkR brushParams = embedUsedParams $ toUsedParams params
unrotatedShape = fun ( getUnrotated brushBaseShape ) brushParams
-- TODO: remove this logic which is duplicated
-- from elsewhere. The type should make it
-- impossible to forget to apply the rotation.
in case mbRot of
Nothing -> unrotatedShape
Just getθ ->
let θ = getθ brushParams
cosθ = cos θ
sinθ = sin θ
in fmap ( unT . rotate cosθ sinθ . T ) unrotatedShape
, strokeExtraData =
mkExtraData brushName ( embedUsedParams . toUsedParams )
}
_ -> pure $
StrokeRenderData
{ strokeDataSpline = spline }
renderStroke
:: Renderable extraData
=> RenderColours RGBA
-> WantedElements
-> StrokePoints
-> Maybe HoverContext
-> Bool -- ^ want debug visualisations?
-> Zoom
-> ( Maybe Unique, StrokeRenderData extraData )
-> Compose Renders Cairo.Render ()
renderStroke cols@( RenderColours { brush } ) wanted selPts mbHoverContext debug zoom ( mbUnique, strokeData ) =
case strokeData of
StrokeRenderData { strokeDataSpline } ->
renderStrokeSpline cols wanted strokeSelPts mbHoverContext zoom ( const ( pure () ) ) strokeDataSpline
StrokeWithOutlineRenderData
{ strokeDataSpline
, strokeOutlineData = ( strokeOutlineData, fitPts, cusps )
, strokeBrushFunction
, strokeExtraData = extraData
} ->
renderStrokeSpline cols wanted strokeSelPts mbHoverContext zoom
( when ( wantBrushes wanted )
. ( \ pt ->
renderBrushShape ( cols { path = brush } ) mbHoverContext ( Zoom $ 2 * zoomFactor zoom )
strokeBrushFunction
( extraData )
pt
)
)
strokeDataSpline
*> Compose blankRender
{ renderStrokes = drawOutline cols debug zoom strokeOutlineData
, renderDebug =
when debug $ drawDebugInfo cols zoom ( fitPts, cusps )
}
where
strokeSelPts =
case mbUnique of
Nothing -> Set.empty
Just u -> fromMaybe Set.empty $ Map.lookup u ( strokePoints selPts )
-- | Render a sequence of stroke points.
--
-- Accepts a sub-function for additional rendering of each stroke point
-- (e.g. overlay a brush shape over each stroke point).
renderStrokeSpline
:: forall clo pointData
. ( Show pointData, KnownSplineType clo )
=> RenderColours RGBA -> WantedElements
-> Set PointIndex -> Maybe HoverContext -> Zoom
-> ( PointData pointData -> Compose Renders Cairo.Render () )
-> Spline clo ( CurveData RealWorld ) ( PointData pointData )
-> Compose Renders Cairo.Render ()
renderStrokeSpline cols wanted selPts mbHover zoom renderSubcontent spline =
bifoldSpline ( renderSplineCurve ( splineStart spline ) ) ( renderSplinePoint FirstPoint ) spline
where
renderSplinePoint :: PointIndex -> PointData pointData -> Compose Renders Cairo.Render ()
renderSplinePoint i sp0
= Compose blankRender
{ renderPPts =
when ( wantPoints wanted ) do
drawPoint cols selPts mbHover zoom i sp0
}
*> renderSubcontent sp0
renderSplineCurve
:: forall clo'
. SplineTypeI clo'
=> PointData pointData -> PointData pointData -> Curve clo' ( CurveData RealWorld ) ( PointData pointData ) -> Compose Renders Cairo.Render ()
renderSplineCurve start p0 ( LineTo np1 ( CurveData { curveIndex } ) )
= Compose blankRender
{ renderPPts = when ( wantPoints wanted ) do
for_ np1 \ p1 ->
drawPoint cols selPts mbHover zoom ( PointIndex curveIndex PathPoint ) p1
, renderPath = when ( wantPaths wanted ) do
drawLine cols zoom PathPoint p0 ( fromNextPoint start np1 )
}
*> for_ np1 \ p1 -> renderSubcontent p1
renderSplineCurve start p0 ( Bezier2To p1 np2 ( CurveData { curveIndex } ) )
= Compose blankRender
{ renderCLines
= when ( wantPoints wanted ) do
drawLine cols zoom ( ControlPoint Bez2Cp ) p0 p1
drawLine cols zoom ( ControlPoint Bez2Cp ) p1 ( fromNextPoint start np2 )
, renderCPts
= when ( wantPoints wanted ) do
drawPoint cols selPts mbHover zoom ( PointIndex curveIndex $ ControlPoint Bez2Cp ) p1
, renderPPts
= when ( wantPoints wanted ) do
for_ np2 \ p2 ->
drawPoint cols selPts mbHover zoom ( PointIndex curveIndex PathPoint ) p2
, renderPath
= when ( wantPaths wanted ) 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 ( CurveData { curveIndex } ) )
= Compose blankRender
{ renderCLines
= when ( wantPoints wanted ) do
drawLine cols zoom ( ControlPoint Bez3Cp1 ) p0 p1
drawLine cols zoom ( ControlPoint Bez3Cp2 ) p2 ( fromNextPoint start np3 )
, renderCPts
= when ( wantPoints wanted ) do
drawPoint cols selPts mbHover zoom ( PointIndex curveIndex $ ControlPoint Bez3Cp1 ) p1
drawPoint cols selPts mbHover zoom ( PointIndex curveIndex $ ControlPoint Bez3Cp2 ) p2
, renderPPts
= when ( wantPoints wanted ) do
for_ np3 \ p3 ->
drawPoint cols selPts mbHover zoom ( PointIndex curveIndex $ PathPoint ) p3
, renderPath
= when ( wantPaths wanted ) do
drawCubicBezier cols zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 = fromNextPoint start np3 } )
}
*> renderSubcontent p1
*> renderSubcontent p2
*> for_ np3 \ p3 -> renderSubcontent p3
drawPoint :: RenderColours RGBA -> Set PointIndex -> Maybe HoverContext -> Zoom -> PointIndex -> PointData brushData -> Cairo.Render ()
drawPoint ( RenderColours {..} ) selPts mbHover zoom@( Zoom { zoomFactor } ) i pt
| i == FirstPoint || pointType i == PathPoint
= do
let
x, y :: Double
ℝ2 x y = coords pt
hsqrt3 :: Double
hsqrt3 = sqrt 0.75
isSelected = i `Set.member` selPts
hover
| Just hov <- mbHover
= hovered hov zoom ( ℝ2 x y )
| otherwise
= False
Cairo.save
Cairo.translate x y
Cairo.scale ( 3 / zoomFactor ) ( 3 / zoomFactor )
Cairo.moveTo 1 0
Cairo.lineTo 0.5 hsqrt3
Cairo.lineTo -0.5 hsqrt3
Cairo.lineTo -1 0
Cairo.lineTo -0.5 -hsqrt3
Cairo.lineTo 0.5 -hsqrt3
Cairo.closePath
Cairo.setLineWidth 1.0
if isSelected
then withRGBA pathPoint Cairo.setSourceRGBA
else withRGBA pathPointOutline Cairo.setSourceRGBA
Cairo.strokePreserve
if | isSelected
-> withRGBA pointSelected Cairo.setSourceRGBA
| hover
-> withRGBA pointHover Cairo.setSourceRGBA
| otherwise
-> withRGBA pathPoint Cairo.setSourceRGBA
Cairo.fill
Cairo.restore
| otherwise
= do
let
x, y :: Double
ℝ2 x y = coords pt
isSelected = i `Set.member` selPts
hover
| Just hov <- mbHover
= hovered hov zoom ( ℝ2 x y )
| otherwise
= False
Cairo.save
Cairo.translate x y
Cairo.scale ( 3 / zoomFactor ) ( 3 / zoomFactor )
Cairo.arc 0 0 1 0 ( 2 * pi )
Cairo.setLineWidth 1.0
if isSelected
then withRGBA controlPoint Cairo.setSourceRGBA
else withRGBA controlPointOutline Cairo.setSourceRGBA
Cairo.strokePreserve
if | isSelected
-> withRGBA pointSelected Cairo.setSourceRGBA
| hover
-> withRGBA pointHover Cairo.setSourceRGBA
| otherwise
-> withRGBA controlPoint Cairo.setSourceRGBA
Cairo.fill
withRGBA controlPoint Cairo.setSourceRGBA
Cairo.fill
Cairo.restore
drawLine :: RenderColours RGBA -> Zoom -> PointType -> PointData b -> PointData b -> Cairo.Render ()
drawLine ( RenderColours { path, controlPointLine } ) ( Zoom zoom ) pointType p1 p2 = do
let
x1, y1, x2, y2 :: Double
ℝ2 x1 y1 = coords p1
ℝ2 x2 y2 = coords p2
Cairo.save
Cairo.moveTo x1 y1
Cairo.lineTo x2 y2
case pointType of
PathPoint -> do
Cairo.setLineWidth ( 5 / zoom )
withRGBA path Cairo.setSourceRGBA
ControlPoint {} -> do
Cairo.setLineWidth ( 3 / zoom )
withRGBA controlPointLine Cairo.setSourceRGBA
Cairo.stroke
Cairo.restore
drawQuadraticBezier :: RenderColours RGBA -> Zoom -> Quadratic.Bezier ( ℝ 2 ) -> Cairo.Render ()
drawQuadraticBezier cols zoom bez =
drawCubicBezier cols zoom
( Cubic.fromQuadratic @( T ( ℝ 2 ) ) bez )
drawCubicBezier :: RenderColours RGBA -> Zoom -> Cubic.Bezier ( ℝ 2 ) -> Cairo.Render ()
drawCubicBezier ( RenderColours { path } ) ( Zoom { zoomFactor } )
( Cubic.Bezier
{ p0 = ℝ2 x0 y0
, p1 = ℝ2 x1 y1
, p2 = ℝ2 x2 y2
, p3 = ℝ2 x3 y3
}
)
= do
Cairo.save
Cairo.moveTo x0 y0
Cairo.curveTo x1 y1 x2 y2 x3 y3
Cairo.setLineWidth ( 6 / zoomFactor )
withRGBA path Cairo.setSourceRGBA
Cairo.stroke
Cairo.restore
drawOutline
:: RenderColours RGBA -> Bool -> Zoom
-> Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
-> Cairo.Render ()
drawOutline ( RenderColours {..} ) debug ( Zoom { zoomFactor } ) strokeData = do
Cairo.save
withRGBA brushStroke Cairo.setSourceRGBA
case strokeData of
Left outline -> do
makeOutline outline
case debug of
False -> Cairo.fill
True -> do
Cairo.fillPreserve
Cairo.setSourceRGBA 0 0 0 0.75
Cairo.setLineWidth ( 2 / zoomFactor )
Cairo.stroke
Right ( fwd, bwd ) -> do
makeOutline fwd
makeOutline bwd
case debug of
False -> Cairo.fill
True -> do
Cairo.fillPreserve
Cairo.setSourceRGBA 0 0 0 0.75
Cairo.setLineWidth ( 2 / zoomFactor )
Cairo.stroke
Cairo.restore
where
makeOutline :: SplinePts Closed -> Cairo.Render ()
makeOutline spline = bifoldSpline
( drawCurve ( splineStart spline ) )
( \ ( ℝ2 x y ) -> Cairo.moveTo x y )
spline
drawCurve :: forall clo. SplineTypeI clo => ℝ 2 -> ℝ 2 -> Curve clo () ( ℝ 2 ) -> Cairo.Render ()
drawCurve start ( ℝ2 x0 y0 ) crv = case crv of
LineTo mp1 _ ->
let ℝ2 x1 y1 = fromNextPoint start mp1
in Cairo.lineTo x1 y1
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 ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) mp3 _ ->
let ℝ2 x3 y3 = fromNextPoint start mp3
in Cairo.curveTo x1 y1 x2 y2 x3 y3
drawDebugInfo :: RenderColours RGBA -> Zoom
-> ( Seq FitPoint, [ Cusp ] )
-> Cairo.Render ()
drawDebugInfo cols zoom@( Zoom { zoomFactor } ) ( fitPts, cusps ) = do
Cairo.setLineWidth ( 2 / zoomFactor )
( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts
for_ cusps ( drawCusp cols zoom )
drawFitPoint :: RenderColours RGBA -> Zoom -> FitPoint -> StateT Double Cairo.Render ()
drawFitPoint _ zoom ( FitPoint { fitDotProduct = dot, fitDir = fwdOrBwd, fitPoint = ℝ2 x y } ) = do
hue <- get
put ( hue + 0.01 )
let
r, g, b :: Double
( r, g, b ) = hsl2rgb hue 0.9 0.4
lift do
Cairo.save
Cairo.translate x y
drawFitPointHelper zoom ( fwdOrBwd, dot ) r g b
Cairo.restore
drawFitPoint _ ( Zoom { zoomFactor } ) ( JoinPoint { joinDir = mbDir, joinPoint = ℝ2 x y } ) = lift do
-- Draw a little red or blue circle.
Cairo.save
Cairo.translate x y
Cairo.arc 0 0 ( 4 / zoomFactor ) 0 ( 2 * pi )
case mbDir of
Fwd -> do
-- Forward: red.
Cairo.setSourceRGBA 0.87 0.23 0.18 0.9
Cairo.setLineWidth ( 3 / zoomFactor )
Bwd -> do
-- Backwards: blue.
Cairo.setSourceRGBA 0.24 0.45 0.9 0.9
Cairo.setLineWidth ( 3 / zoomFactor )
Cairo.stroke
Cairo.restore
drawFitPoint _ zoom@( Zoom { zoomFactor } ) ( FitTangent { fitDotProduct = dot, fitDir = fwdOrBwd, fitPoint = ℝ2 x y, fitTangent = tgt } ) = do
hue <- get
put ( hue + 0.01 )
let
r, g, b :: Double
( r, g, b ) = hsl2rgb hue 0.9 0.4
V2 tx ty = 10 *^ normalise tgt
lift do
Cairo.save
Cairo.translate x y
Cairo.moveTo 0 0
Cairo.lineTo tx ty
Cairo.setLineWidth ( 2 / zoomFactor )
Cairo.setSourceRGBA r g b 0.8
Cairo.stroke
drawFitPointHelper zoom ( fwdOrBwd, dot ) r g b
Cairo.restore
drawFitPointHelper :: Zoom -> ( FwdBwd, Double ) -> Double -> Double -> Double -> Cairo.Render ()
drawFitPointHelper ( Zoom { zoomFactor } ) ( fwdOrBwd, dot ) r g b = do
Cairo.moveTo 0 0
Cairo.arc 0 0 ( 4 / zoomFactor ) 0 ( 2 * pi )
Cairo.setSourceRGBA r g b 0.8
Cairo.fill
Cairo.moveTo 0 0
case fwdOrBwd of
Fwd -> do
-- Forwards: little dot above
Cairo.arc 0 ( -1 / zoomFactor ) ( 1 / zoomFactor ) 0 ( 2 * pi )
Bwd -> do
-- Backwards: little dot below
Cairo.arc 0 ( 1 / zoomFactor ) ( 1 / zoomFactor ) 0 ( 2 * pi )
if | dot > epsilon
-> Cairo.setSourceRGBA 0.87 0.23 0.18 0.8
| dot < -epsilon
-> Cairo.setSourceRGBA 0.24 0.45 0.9 0.8
| otherwise
-> Cairo.setSourceRGBA 0.5 0.5 0.5 0.8
Cairo.fill
drawCusp :: RenderColours RGBA -> Zoom -> Cusp -> Cairo.Render ()
drawCusp _ ( Zoom { zoomFactor } )
( Cusp { cuspPathCoords = D21 { _D21_v = ℝ2 px py
, _D21_dx = tgt }
, cuspStrokeCoords = ℝ2 cx cy
, cornerCusp = isCorner
} ) = do
-- Draw a line perpendicular to the underlying path at the cusp.
let
!( V2 tx ty ) = ( 6 / zoomFactor ) *^ normalise tgt
setCol =
if isCorner
then Cairo.setSourceRGBA 1 1 1 0.75
else Cairo.setSourceRGBA 0 0 0 0.75
Cairo.save
Cairo.translate px py
Cairo.moveTo -ty tx
Cairo.lineTo ty -tx
setCol
Cairo.setLineWidth ( 2 / zoomFactor )
Cairo.stroke
Cairo.restore
-- Draw a circle around the outline cusp point.
Cairo.save
Cairo.translate cx cy
Cairo.arc 0 0 ( 4 / zoomFactor ) 0 ( 2 * pi )
setCol
Cairo.stroke
Cairo.restore
drawSelectionRectangle :: RenderColours RGBA -> Double -> ℝ 2 -> ℝ 2 -> Cairo.Render ()
drawSelectionRectangle ( RenderColours { selected, selectedOutline } ) =
drawRectangle ( Just selected, Just selectedOutline )
drawRectangle :: ( Maybe RGBA, Maybe RGBA ) -> Double -> ℝ 2 -> ℝ 2 -> Cairo.Render ()
drawRectangle ( mbFillCol, mbStrokeCol ) zoom ( ℝ2 a_x a_y ) ( ℝ2 b_x b_y ) = do
-- Offset by half the line width,
-- so that the rectangle exactly encloses the contents.
let
width = 1 / zoom
x0 = min a_x b_x - 0.5 * width
x1 = max a_x b_x + 0.5 * width
y0 = min a_y b_y - 0.5 * width
y1 = max a_y b_y + 0.5 * width
Cairo.save
Cairo.moveTo x0 y0
Cairo.lineTo x1 y0
Cairo.lineTo x1 y1
Cairo.lineTo x0 y1
Cairo.closePath
for_ mbFillCol $ \ fillCol -> do
withRGBA fillCol Cairo.setSourceRGBA
case mbStrokeCol of
Nothing -> Cairo.fill
Just {} -> Cairo.fillPreserve
for_ mbStrokeCol $ \ strokeCol -> do
Cairo.setLineWidth width
withRGBA strokeCol Cairo.setSourceRGBA
Cairo.stroke
Cairo.restore
{-
drawCross :: RenderColours RGBA -> Double -> Cairo.Render ()
drawCross ( RenderColours {..} ) zoom = do
Cairo.save
Cairo.setLineWidth 1.5
withRGBA brushCenter Cairo.setSourceRGBA
Cairo.scale ( 1.5 / zoom ) ( 1.5 / zoom )
Cairo.moveTo -3 -3
Cairo.lineTo 3 3
Cairo.stroke
Cairo.moveTo -3 3
Cairo.lineTo 3 -3
Cairo.stroke
Cairo.restore
-}
renderBrushShape
:: Renderable extraData
=> RenderColours RGBA -> Maybe HoverContext -> Zoom
-> ( pointParams -> SplinePts Closed )
-> extraData pointParams
-> PointData pointParams
-> Compose Renders Cairo.Render ()
renderBrushShape cols mbHoverContext zoom brushFn extraData pt =
let
x, y :: Double
ℝ2 x y = coords pt
brushPts :: SplinePts Closed
brushPts = brushFn ( brushParams pt )
mbHoverContext' :: Maybe HoverContext
mbHoverContext' = V2 -x -y • mbHoverContext
brushWanted =
WantedElements
{ wantPoints = False
, wantPaths = True
, wantBrushes = True
}
in
toAll do
Cairo.save
Cairo.translate x y
*> renderStrokeSpline cols brushWanted Set.empty mbHoverContext zoom ( const $ pure () )
( noCurveData brushPts )
*> renderAt cols zoom mbHoverContext' pt extraData
*> toAll Cairo.restore
where
noCurveData :: Spline Closed () ( ℝ 2 ) -> Spline Closed ( CurveData RealWorld ) ( PointData () )
noCurveData =
bimapSpline
( \ _ -> bimapCurve ( \ _ -> CurveData 987654321 ( invalidateCache undefined ) ) ( \ _ p -> PointData p () ) )
( \ p -> PointData p () )
--------------------------------------------------------------------------------
-- Utilities
withRGBA :: RGBA -> ( Double -> Double -> Double -> Double -> r ) -> r
withRGBA ( RGBA r g b a ) f = f r g b a
hsl2rgb :: Double -> Double -> Double -> ( Double, Double, Double )
hsl2rgb h s l = case hc2rgb h c of
( r, g, b ) -> ( r + m, g + m, b + m )
where
c = ( 1 - abs ( 2 * l - 1 ) ) * s
m = l - c / 2
hc2rgb :: Double -> Double -> ( Double, Double, Double )
hc2rgb h c
| h' <= 1 = ( c, x, 0 )
| h' <= 2 = ( x, c, 0 )
| h' <= 3 = ( 0, c, x )
| h' <= 4 = ( 0, x, c )
| h' <= 5 = ( x, 0, c )
| otherwise = ( c, 0, x )
where
h' = ( h * 6 ) `mod'` 6
hTrunc = truncate h' :: Int
hMod2 = fromIntegral ( hTrunc `mod` 2 ) + ( h' - fromIntegral hTrunc )
x = c * ( 1 - abs ( hMod2 - 1 ) )