mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
WIP: add brush widget UI
This commit is contained in:
parent
2a21980ffc
commit
1ec2af6dcc
|
@ -171,6 +171,7 @@ library metabrushes
|
||||||
MetaBrush.Assert
|
MetaBrush.Assert
|
||||||
, MetaBrush.Asset.Brushes
|
, MetaBrush.Asset.Brushes
|
||||||
, MetaBrush.Brush
|
, MetaBrush.Brush
|
||||||
|
, MetaBrush.Brush.Widget
|
||||||
, MetaBrush.Document
|
, MetaBrush.Document
|
||||||
, MetaBrush.Document.Draw
|
, MetaBrush.Document.Draw
|
||||||
, MetaBrush.Document.History
|
, MetaBrush.Document.History
|
||||||
|
|
|
@ -32,6 +32,9 @@
|
||||||
@define-color glass rgba( 156, 231, 255, 0.5);
|
@define-color glass rgba( 156, 231, 255, 0.5);
|
||||||
@define-color selected rgba( 161, 201, 236, 0.5);
|
@define-color selected rgba( 161, 201, 236, 0.5);
|
||||||
@define-color selectedOutline rgb( 74, 150, 218);
|
@define-color selectedOutline rgb( 74, 150, 218);
|
||||||
|
@define-color brushWidget rgba( 0, 0, 0, 0.9);
|
||||||
|
@define-color brushWidgetHover rgb( 231, 172, 83);
|
||||||
|
|
||||||
@define-color shortcutKey rgb( 112, 109, 96 );
|
@define-color shortcutKey rgb( 112, 109, 96 );
|
||||||
|
|
||||||
@define-color windowButtonHover rgb( 34, 131, 186);
|
@define-color windowButtonHover rgb( 34, 131, 186);
|
||||||
|
|
|
@ -113,7 +113,12 @@
|
||||||
.selectedOutline {
|
.selectedOutline {
|
||||||
color: @selectedOutline;
|
color: @selectedOutline;
|
||||||
}
|
}
|
||||||
|
.brushWidget {
|
||||||
|
color: @brushWidget;
|
||||||
|
}
|
||||||
|
.brushWidgetHover {
|
||||||
|
color: @brushWidgetHover;
|
||||||
|
}
|
||||||
|
|
||||||
/* Proper CSS styling */
|
/* Proper CSS styling */
|
||||||
|
|
||||||
|
|
|
@ -127,7 +127,8 @@ import MetaBrush.Document.Selection
|
||||||
, DragMoveSelect(..), dragMoveSelect
|
, DragMoveSelect(..), dragMoveSelect
|
||||||
, UpdateInfo(..)
|
, UpdateInfo(..)
|
||||||
, deleteSelected
|
, deleteSelected
|
||||||
, dragUpdate
|
, dragUpdate, pressingControl
|
||||||
|
, applyBrushWidgetAction
|
||||||
)
|
)
|
||||||
import MetaBrush.Document.Serialise
|
import MetaBrush.Document.Serialise
|
||||||
( saveDocument, loadDocument )
|
( saveDocument, loadDocument )
|
||||||
|
@ -765,13 +766,13 @@ data MouseMove = MouseMove !( ℝ 2 )
|
||||||
|
|
||||||
instance HandleAction MouseMove where
|
instance HandleAction MouseMove where
|
||||||
handleAction
|
handleAction
|
||||||
( UIElements { viewport = Viewport {..}, .. } )
|
uiElts@( UIElements { viewport = Viewport {..}, infoBar } )
|
||||||
vars@( Variables {..} )
|
vars@( Variables {..} )
|
||||||
( MouseMove ( ℝ2 x y ) )
|
( MouseMove ( ℝ2 x y ) )
|
||||||
= do
|
= do
|
||||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||||
uiUpdateAction <- STM.atomically $ withActiveDocument vars \ doc@( Document {..} ) -> do
|
modifyingCurrentDocument uiElts vars \ doc@( Document {..} ) -> do
|
||||||
modifiers <- STM.readTVar modifiersTVar
|
modifiers <- STM.readTVar modifiersTVar
|
||||||
let
|
let
|
||||||
toViewport :: ℝ 2 -> ℝ 2
|
toViewport :: ℝ 2 -> ℝ 2
|
||||||
|
@ -784,18 +785,34 @@ instance HandleAction MouseMove where
|
||||||
-- moves the partial control point (if one exists).
|
-- moves the partial control point (if one exists).
|
||||||
tool <- STM.readTVar toolTVar
|
tool <- STM.readTVar toolTVar
|
||||||
mbPartialPath <- STM.readTVar partialPathTVar
|
mbPartialPath <- STM.readTVar partialPathTVar
|
||||||
|
mode <- STM.readTVar modeTVar
|
||||||
|
STM.writeTVar recomputeStrokesTVar True -- need to keep updating for mouse hover updates
|
||||||
case tool of
|
case tool of
|
||||||
Pen
|
Pen
|
||||||
| Just pp <- mbPartialPath
|
| Just pp <- mbPartialPath
|
||||||
, any ( \ case { Control _ -> True; _ -> False } ) modifiers
|
, any ( \ case { Control _ -> True; _ -> False } ) modifiers
|
||||||
-> STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
|
-> do STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just pos } )
|
||||||
_ -> pure ()
|
pure Don'tModifyDoc
|
||||||
STM.writeTVar recomputeStrokesTVar True -- need to keep updating for mouse hover updates
|
| BrushMode <- mode
|
||||||
pure do
|
-- Pen tool in brush mode: modify brush parameters through brush widget.
|
||||||
updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
|
-> do mbHoldAction <- STM.readTVar mouseHoldTVar
|
||||||
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
|
case mbHoldAction of
|
||||||
GTK.widgetQueueDraw drawingArea
|
Just ( BrushWidgetAction { brushWidgetAction } ) ->
|
||||||
sequenceA_ uiUpdateAction
|
case applyBrushWidgetAction ( pressingControl modifiers ) pos ( Just brushWidgetAction) doc of
|
||||||
|
Nothing ->
|
||||||
|
pure Don'tModifyDoc
|
||||||
|
Just ( widgetAction, newDocument ) -> do
|
||||||
|
STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos widgetAction )
|
||||||
|
let changeText :: Text
|
||||||
|
changeText = "Update brush parameters"
|
||||||
|
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||||
|
_ -> pure Don'tModifyDoc
|
||||||
|
_ -> pure Don'tModifyDoc
|
||||||
|
mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
|
||||||
|
for_ mbDoc \doc ->
|
||||||
|
updateInfoBar viewportDrawingArea infoBar vars ( Just doc )
|
||||||
|
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
|
||||||
|
GTK.widgetQueueDraw drawingArea
|
||||||
|
|
||||||
-----------------
|
-----------------
|
||||||
-- Mouse click --
|
-- Mouse click --
|
||||||
|
@ -874,37 +891,55 @@ instance HandleAction MouseClick where
|
||||||
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
|
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
|
||||||
pure Don'tModifyDoc
|
pure Don'tModifyDoc
|
||||||
|
|
||||||
-- Pen tool: start or continue a drawing operation.
|
Pen ->
|
||||||
Pen | PathMode <- mode -> do
|
case mode of
|
||||||
mbPartialPath <- STM.readTVar partialPathTVar
|
-- Pen tool in path mode: start or continue a drawing operation.
|
||||||
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
|
PathMode -> do
|
||||||
case mbPartialPath of
|
mbPartialPath <- STM.readTVar partialPathTVar
|
||||||
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
|
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
|
||||||
Nothing -> do
|
case mbPartialPath of
|
||||||
( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <-
|
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
|
||||||
getOrCreateDrawAnchor uniqueSupply pos doc
|
Nothing -> do
|
||||||
STM.writeTVar partialPathTVar
|
( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <-
|
||||||
( Just $ PartialPath
|
getOrCreateDrawAnchor uniqueSupply pos doc
|
||||||
{ partialStartPos = anchorPt
|
STM.writeTVar partialPathTVar
|
||||||
, partialControlPoint = Nothing
|
( Just $ PartialPath
|
||||||
, partialPathAnchor = drawAnchor
|
{ partialStartPos = anchorPt
|
||||||
, firstPoint = True
|
, partialControlPoint = Nothing
|
||||||
}
|
, partialPathAnchor = drawAnchor
|
||||||
)
|
, firstPoint = True
|
||||||
case mbExistingAnchorName of
|
}
|
||||||
Nothing ->
|
)
|
||||||
let
|
case mbExistingAnchorName of
|
||||||
changeText :: Text
|
Nothing ->
|
||||||
changeText = "Begin new stroke"
|
let
|
||||||
in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
changeText :: Text
|
||||||
Just _ ->
|
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
|
||||||
-- 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
|
-- Pen tool in brush mode: modify brush parameters through brush widget.
|
||||||
|
BrushMode -> do
|
||||||
|
mbAction <- STM.readTVar mouseHoldTVar
|
||||||
|
let mbPrevWidgetAction = case mbAction of
|
||||||
|
Just ( BrushWidgetAction { brushWidgetAction } )
|
||||||
|
-> Just brushWidgetAction
|
||||||
|
_ -> Nothing
|
||||||
|
case applyBrushWidgetAction ( pressingControl modifiers ) pos mbPrevWidgetAction doc of
|
||||||
|
Nothing ->
|
||||||
|
pure Don'tModifyDoc
|
||||||
|
Just ( widgetAction, newDocument ) -> do
|
||||||
|
STM.writeTVar mouseHoldTVar ( Just $ BrushWidgetAction pos widgetAction )
|
||||||
|
let changeText :: Text
|
||||||
|
changeText = "Update brush parameters"
|
||||||
|
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||||
|
|
||||||
|
MetaMode -> pure Don'tModifyDoc
|
||||||
|
|
||||||
DoubleClick -> do
|
DoubleClick -> do
|
||||||
tool <- STM.readTVar toolTVar
|
tool <- STM.readTVar toolTVar
|
||||||
|
@ -959,7 +994,7 @@ data MouseRelease = MouseRelease !Word32 !( ℝ 2 )
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
instance HandleAction MouseRelease where
|
instance HandleAction MouseRelease where
|
||||||
handleAction
|
handleAction
|
||||||
uiElts@( UIElements { viewport = Viewport {..} } )
|
uiElts@( UIElements { viewport = Viewport {..} } )
|
||||||
vars@( Variables {..} )
|
vars@( Variables {..} )
|
||||||
( MouseRelease button ( ℝ2 x y ) )
|
( MouseRelease button ( ℝ2 x y ) )
|
||||||
|
@ -1057,9 +1092,8 @@ instance HandleAction MouseRelease where
|
||||||
-> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle selMode pos0 pos doc )
|
-> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle selMode pos0 pos doc )
|
||||||
_ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc )
|
_ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc )
|
||||||
|
|
||||||
Pen
|
Pen -> case mode of
|
||||||
| PathMode <- mode
|
PathMode -> do
|
||||||
-> do
|
|
||||||
mbPartialPath <- STM.readTVar partialPathTVar
|
mbPartialPath <- STM.readTVar partialPathTVar
|
||||||
case mbPartialPath of
|
case mbPartialPath of
|
||||||
-- Normal pen mode mouse click should have created an anchor.
|
-- Normal pen mode mouse click should have created an anchor.
|
||||||
|
@ -1141,8 +1175,12 @@ instance HandleAction MouseRelease where
|
||||||
changeText :: Text
|
changeText :: Text
|
||||||
changeText = "Continue stroke"
|
changeText = "Continue stroke"
|
||||||
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||||
|
BrushMode -> do
|
||||||
|
STM.writeTVar mouseHoldTVar Nothing
|
||||||
|
pure Don'tModifyDoc
|
||||||
|
|
||||||
_ -> pure Don'tModifyDoc
|
MetaMode ->
|
||||||
|
pure Don'tModifyDoc
|
||||||
|
|
||||||
-- Other mouse buttons: ignored (for the moment at least).
|
-- Other mouse buttons: ignored (for the moment at least).
|
||||||
_ -> pure ()
|
_ -> pure ()
|
||||||
|
|
|
@ -206,8 +206,8 @@ runApplication application = do
|
||||||
maxHistorySizeTVar <- STM.newTVarIO @Int 1000
|
maxHistorySizeTVar <- STM.newTVarIO @Int 1000
|
||||||
fitParametersTVar <- STM.newTVarIO @FitParameters $
|
fitParametersTVar <- STM.newTVarIO @FitParameters $
|
||||||
FitParameters
|
FitParameters
|
||||||
{ maxSubdiv = 0 --5 --2 --3 -- 6
|
{ maxSubdiv = 2 --5 --2 --3 -- 6
|
||||||
, nbSegments = 1 --5
|
, nbSegments = 3
|
||||||
, dist_tol = 5e-3
|
, dist_tol = 5e-3
|
||||||
, t_tol = 1e-4
|
, t_tol = 1e-4
|
||||||
, maxIters = 20
|
, maxIters = 20
|
||||||
|
@ -217,7 +217,7 @@ runApplication application = do
|
||||||
NewtonRaphson
|
NewtonRaphson
|
||||||
{ maxIters = 20, precision = 8 }
|
{ maxIters = 20, precision = 8 }
|
||||||
cuspFindingOptionsTVar <- STM.newTVarIO @( Maybe ( RootIsolationOptions 2 3 ) ) $
|
cuspFindingOptionsTVar <- STM.newTVarIO @( Maybe ( RootIsolationOptions 2 3 ) ) $
|
||||||
Nothing --Just defaultRootIsolationOptions
|
Just defaultRootIsolationOptions
|
||||||
|
|
||||||
-- Put all these stateful variables in a record for conciseness.
|
-- Put all these stateful variables in a record for conciseness.
|
||||||
let
|
let
|
||||||
|
|
|
@ -35,8 +35,13 @@ data ColourRecord a
|
||||||
, pointHover, pointSelected
|
, pointHover, pointSelected
|
||||||
, viewport, viewportScrollbar, tabScrollbar
|
, viewport, viewportScrollbar, tabScrollbar
|
||||||
, guide, rulerBg, rulerTick, magnifier, glass
|
, guide, rulerBg, rulerTick, magnifier, glass
|
||||||
, selected, selectedOutline :: !a
|
, selected, selectedOutline
|
||||||
|
, brushWidget, brushWidgetHover :: !a
|
||||||
}
|
}
|
||||||
|
-- NB: when adding a new colour to this record, don't forget to update:
|
||||||
|
--
|
||||||
|
-- - colours.css, to define a value for the colour,
|
||||||
|
-- - theme.css, which is where GTK parses the colours in 'getColours'.
|
||||||
deriving stock ( Show, Functor, Foldable, Traversable )
|
deriving stock ( Show, Functor, Foldable, Traversable )
|
||||||
|
|
||||||
newtype ColourName
|
newtype ColourName
|
||||||
|
@ -76,6 +81,8 @@ colourNames = Colours
|
||||||
, glass = ColourName "glass"
|
, glass = ColourName "glass"
|
||||||
, selected = ColourName "selected"
|
, selected = ColourName "selected"
|
||||||
, selectedOutline = ColourName "selectedOutline"
|
, selectedOutline = ColourName "selectedOutline"
|
||||||
|
, brushWidget = ColourName "brushWidget"
|
||||||
|
, brushWidgetHover = ColourName "brushWidgetHover"
|
||||||
}
|
}
|
||||||
|
|
||||||
type Colours = ColourRecord GDK.RGBA
|
type Colours = ColourRecord GDK.RGBA
|
||||||
|
|
|
@ -54,7 +54,7 @@ import MetaBrush.Document.Draw
|
||||||
import MetaBrush.Document.History
|
import MetaBrush.Document.History
|
||||||
( DocumentHistory(..) )
|
( DocumentHistory(..) )
|
||||||
import MetaBrush.Document.Selection
|
import MetaBrush.Document.Selection
|
||||||
( DragMoveSelect )
|
( DragMoveSelect, BrushWidgetActionState )
|
||||||
import {-# SOURCE #-} MetaBrush.UI.FileBar
|
import {-# SOURCE #-} MetaBrush.UI.FileBar
|
||||||
( FileBar, FileBarTab )
|
( FileBar, FileBarTab )
|
||||||
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
||||||
|
@ -135,16 +135,25 @@ data GuideAction
|
||||||
-- - start a rectangular selection,
|
-- - start a rectangular selection,
|
||||||
-- - move objects by dragging,
|
-- - move objects by dragging,
|
||||||
-- - draw a control point,
|
-- - draw a control point,
|
||||||
-- - create/modify a guide.
|
-- - create/modify a guide,
|
||||||
|
-- - modify brush parameters through a brush widget.
|
||||||
data HoldAction
|
data HoldAction
|
||||||
= SelectionHold { holdStartPos :: !( ℝ 2 ) }
|
= SelectionHold
|
||||||
| DragMoveHold { holdStartPos :: !( ℝ 2 )
|
{ holdStartPos :: !( ℝ 2 ) }
|
||||||
, dragAction :: !DragMoveSelect
|
| DragMoveHold
|
||||||
}
|
{ holdStartPos :: !( ℝ 2 )
|
||||||
| DrawHold { holdStartPos :: !( ℝ 2 ) }
|
, dragAction :: !DragMoveSelect
|
||||||
| GuideAction { holdStartPos :: !( ℝ 2 )
|
}
|
||||||
, guideAction :: !GuideAction
|
| DrawHold
|
||||||
}
|
{ holdStartPos :: !( ℝ 2 ) }
|
||||||
|
| GuideAction
|
||||||
|
{ holdStartPos :: !( ℝ 2 )
|
||||||
|
, guideAction :: !GuideAction
|
||||||
|
}
|
||||||
|
| BrushWidgetAction
|
||||||
|
{ holdStartPos :: !( ℝ 2 )
|
||||||
|
, brushWidgetAction :: !BrushWidgetActionState
|
||||||
|
}
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
-- | Keep track of a path that is in the middle of being drawn.
|
-- | Keep track of a path that is in the middle of being drawn.
|
||||||
|
|
|
@ -2,12 +2,14 @@
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
module MetaBrush.Document.Selection
|
module MetaBrush.Document.Selection
|
||||||
( SelectionMode(..), selectionMode
|
( SelectionMode(..), selectionMode, pressingControl
|
||||||
, selectAt, selectRectangle
|
, selectAt, selectRectangle
|
||||||
, DragMoveSelect(.., PointDrag), dragMoveSelect
|
, DragMoveSelect(.., PointDrag), dragMoveSelect
|
||||||
, UpdateInfo(..)
|
, UpdateInfo(..)
|
||||||
, translateSelection, deleteSelected
|
, translateSelection, deleteSelected
|
||||||
, dragUpdate
|
, dragUpdate
|
||||||
|
, BrushWidgetActionState(..)
|
||||||
|
, applyBrushWidgetAction
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -21,7 +23,7 @@ import Data.Functor
|
||||||
import Data.Functor.Identity
|
import Data.Functor.Identity
|
||||||
( runIdentity )
|
( runIdentity )
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
( catMaybes )
|
( catMaybes, listToMaybe )
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
( Sum(..) )
|
( Sum(..) )
|
||||||
import Data.Semigroup
|
import Data.Semigroup
|
||||||
|
@ -97,6 +99,15 @@ import Math.Module
|
||||||
( Module, lerp, squaredNorm, closestPointOnSegment )
|
( Module, lerp, squaredNorm, closestPointOnSegment )
|
||||||
import Math.Linear
|
import Math.Linear
|
||||||
( Segment(..), ℝ(..), T(..) )
|
( Segment(..), ℝ(..), T(..) )
|
||||||
|
|
||||||
|
-- metabrush
|
||||||
|
import MetaBrush.Brush
|
||||||
|
( NamedBrush(..), WithParams(defaultParams) )
|
||||||
|
import qualified MetaBrush.Brush.Widget as Brush
|
||||||
|
( Widget(..), WidgetAction(..), WidgetElements(..)
|
||||||
|
, WhatScale(..)
|
||||||
|
, widgetElements, widgetUpdate
|
||||||
|
)
|
||||||
import {-# SOURCE #-} MetaBrush.Context
|
import {-# SOURCE #-} MetaBrush.Context
|
||||||
( Modifier(..) )
|
( Modifier(..) )
|
||||||
import MetaBrush.Document
|
import MetaBrush.Document
|
||||||
|
@ -108,6 +119,10 @@ import MetaBrush.Document
|
||||||
)
|
)
|
||||||
import {-# SOURCE #-} MetaBrush.Document.Update
|
import {-# SOURCE #-} MetaBrush.Document.Update
|
||||||
( DocChange(..) )
|
( DocChange(..) )
|
||||||
|
import MetaBrush.Records
|
||||||
|
( Record
|
||||||
|
, Intersection(..), intersect
|
||||||
|
)
|
||||||
import MetaBrush.Unique
|
import MetaBrush.Unique
|
||||||
( Unique )
|
( Unique )
|
||||||
import MetaBrush.Util
|
import MetaBrush.Util
|
||||||
|
@ -137,6 +152,11 @@ selectionMode = foldMap \case
|
||||||
Shift _ -> Add
|
Shift _ -> Add
|
||||||
_ -> New
|
_ -> New
|
||||||
|
|
||||||
|
pressingControl :: Foldable f => f Modifier -> Bool
|
||||||
|
pressingControl = any \case
|
||||||
|
Control {} -> True
|
||||||
|
_ -> False
|
||||||
|
|
||||||
-- | Updates the selected objects on a single click selection event.
|
-- | Updates the selected objects on a single click selection event.
|
||||||
selectAt :: SelectionMode -> ℝ 2 -> Document -> Document
|
selectAt :: SelectionMode -> ℝ 2 -> Document -> Document
|
||||||
selectAt selMode c doc@( Document { zoomFactor } ) =
|
selectAt selMode c doc@( Document { zoomFactor } ) =
|
||||||
|
@ -439,7 +459,7 @@ translateSelection t doc =
|
||||||
| not strokeVisible
|
| not strokeVisible
|
||||||
= pure oldSpline
|
= pure oldSpline
|
||||||
| otherwise
|
| otherwise
|
||||||
= bitraverseSpline
|
= bitraverseSpline
|
||||||
( const $ updateSplineCurve ( splineStart oldSpline ) )
|
( const $ updateSplineCurve ( splineStart oldSpline ) )
|
||||||
( updatePoint PathPoint )
|
( updatePoint PathPoint )
|
||||||
oldSpline
|
oldSpline
|
||||||
|
@ -533,7 +553,7 @@ deleteSelected doc =
|
||||||
updateSpline
|
updateSpline
|
||||||
:: forall clo brushParams
|
:: forall clo brushParams
|
||||||
. KnownSplineType clo
|
. KnownSplineType clo
|
||||||
=> StrokeSpline clo brushParams
|
=> StrokeSpline clo brushParams
|
||||||
-> MaybeT ( State UpdateInfo ) ( StrokeSpline clo brushParams )
|
-> MaybeT ( State UpdateInfo ) ( StrokeSpline clo brushParams )
|
||||||
updateSpline oldSpline
|
updateSpline oldSpline
|
||||||
| not strokeVisible
|
| not strokeVisible
|
||||||
|
@ -816,3 +836,178 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen
|
||||||
dragSegmentParameter
|
dragSegmentParameter
|
||||||
p
|
p
|
||||||
in Bezier3To ( set _coords cp1 sp1 ) ( set _coords cp2 sp2 ) ( NextPoint sp3 ) ( invalidateCache dat )
|
in Bezier3To ( set _coords cp1 sp1 ) ( set _coords cp2 sp2 ) ( NextPoint sp3 ) ( invalidateCache dat )
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Brush widget
|
||||||
|
|
||||||
|
data BrushWidgetActionState
|
||||||
|
= BrushWidgetActionState
|
||||||
|
{ brushWidgetAction :: !Brush.WidgetAction
|
||||||
|
, brushWidgetStrokeUnique :: !Unique
|
||||||
|
, brushWidgetPointIndex :: !Int
|
||||||
|
, brushWidgetPointBeingMoved :: !( T ( ℝ 2 ) )
|
||||||
|
}
|
||||||
|
deriving stock ( Eq, Show )
|
||||||
|
instance Semigroup BrushWidgetActionState where
|
||||||
|
a <> b
|
||||||
|
| a == b
|
||||||
|
= a
|
||||||
|
| otherwise
|
||||||
|
= error "internal error: trying to combine incompatible brush widget action states"
|
||||||
|
|
||||||
|
-- | Apply a brush widget action, e.g. rotating or scaling the brush at a particular stroke point.
|
||||||
|
applyBrushWidgetAction :: Bool -> ℝ 2 -> Maybe BrushWidgetActionState -> Document -> Maybe ( BrushWidgetActionState, Document )
|
||||||
|
applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { zoomFactor } ) =
|
||||||
|
let
|
||||||
|
res :: Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState ) Document
|
||||||
|
res = do
|
||||||
|
newDoc <- ( field' @"documentContent" . field' @"strokes" . traverse ) updateStrokeHierarchy doc
|
||||||
|
Tardis.getPast >>= Tardis.sendPast
|
||||||
|
pure newDoc
|
||||||
|
in case runIdentity . ( `Tardis.runTardisT` ( Nothing, Nothing ) ) $ res of
|
||||||
|
( newDoc, ( _, Just brushWidgetAction ) )
|
||||||
|
-> Just ( brushWidgetAction, newDoc )
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
where
|
||||||
|
updateStrokeHierarchy :: StrokeHierarchy -> ( Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState ) ) StrokeHierarchy
|
||||||
|
updateStrokeHierarchy ( StrokeGroup { .. } ) = do
|
||||||
|
newContents <- traverse updateStrokeHierarchy groupContents
|
||||||
|
pure ( StrokeGroup { groupContents = newContents, .. } )
|
||||||
|
updateStrokeHierarchy ( StrokeLeaf { strokeLeaf } ) = StrokeLeaf <$> updateStroke strokeLeaf
|
||||||
|
|
||||||
|
updateStroke :: Stroke -> Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState ) Stroke
|
||||||
|
updateStroke stroke@( Stroke { strokeVisible, strokeUnique, strokeBrush, strokeSpline = ( spline0 :: StrokeSpline _clo ( Record pointFields ) ) } ) =
|
||||||
|
case strokeBrush of
|
||||||
|
-- Don't touch strokes without brushes.
|
||||||
|
Nothing -> pure stroke
|
||||||
|
Just ( brush@( NamedBrush {} ) :: NamedBrush brushFields )
|
||||||
|
| -- Don't touch invisible strokes
|
||||||
|
not strokeVisible
|
||||||
|
-- If we have already started a widget action, only continue an action
|
||||||
|
-- for the stroke with the correct unique.
|
||||||
|
|| case mbPrevAction of { Just act -> brushWidgetStrokeUnique act /= strokeUnique ; Nothing -> False }
|
||||||
|
-> pure stroke
|
||||||
|
| otherwise
|
||||||
|
-> case intersect @pointFields @brushFields of
|
||||||
|
Intersection { inject1 = injectUsedParams, inject2 = updateBrushParams, project1 = ptParamsToUsedParams, project2 = brushParamsToUsedParams } -> do
|
||||||
|
let embedUsedParams = updateBrushParams ( defaultParams $ brushFunction brush )
|
||||||
|
toBrushParams = embedUsedParams . ptParamsToUsedParams
|
||||||
|
updatePointParams brushParams' ptParams = injectUsedParams ptParams ( brushParamsToUsedParams brushParams' )
|
||||||
|
spline' <- updateSpline brush toBrushParams updatePointParams strokeUnique spline0
|
||||||
|
pure $ stroke { strokeSpline = spline' }
|
||||||
|
where
|
||||||
|
updateSpline
|
||||||
|
:: forall clo pointParams brushFields
|
||||||
|
. ( KnownSplineType clo )
|
||||||
|
=> NamedBrush brushFields
|
||||||
|
-> ( pointParams -> Record brushFields )
|
||||||
|
-> ( Record brushFields -> pointParams -> pointParams )
|
||||||
|
-> Unique
|
||||||
|
-> StrokeSpline clo pointParams
|
||||||
|
-> Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState )
|
||||||
|
( StrokeSpline clo pointParams )
|
||||||
|
updateSpline brush toBrushParams updatePointParams uniq oldSpline =
|
||||||
|
ibitraverseSpline
|
||||||
|
( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams updatePointParams uniq )
|
||||||
|
( updateSplinePoint brush toBrushParams updatePointParams uniq 0 )
|
||||||
|
oldSpline
|
||||||
|
|
||||||
|
updateSplineCurve
|
||||||
|
:: forall clo' pointParams brushFields
|
||||||
|
. ( SplineTypeI clo', Traversable ( NextPoint clo' ) )
|
||||||
|
=> PointData pointParams
|
||||||
|
-> NamedBrush brushFields
|
||||||
|
-> ( pointParams -> Record brushFields )
|
||||||
|
-> ( Record brushFields -> pointParams -> pointParams )
|
||||||
|
-> Unique -> Int
|
||||||
|
-> PointData pointParams -> Curve clo' ( CachedStroke RealWorld ) ( PointData pointParams )
|
||||||
|
-> Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState )
|
||||||
|
( Curve clo' ( CachedStroke RealWorld ) ( PointData pointParams ) )
|
||||||
|
updateSplineCurve _start brush toBrushParams updatePointParams uniq i _sp0 curve
|
||||||
|
-- If we have already started a widget action, only continue an action
|
||||||
|
-- at the point with the correct index in the stroke.
|
||||||
|
| case mbPrevAction of { Just act -> brushWidgetPointIndex act /= i ; Nothing -> False }
|
||||||
|
= pure curve
|
||||||
|
| otherwise
|
||||||
|
= case curve of
|
||||||
|
line@( LineTo sp1 _ ) -> do
|
||||||
|
sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ) sp1
|
||||||
|
pure ( line { curveEnd = sp1' } )
|
||||||
|
bez2@( Bezier2To sp1 sp2 _ ) -> do
|
||||||
|
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i sp1
|
||||||
|
sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ) sp2
|
||||||
|
pure ( bez2 { controlPoint = sp1', curveEnd = sp2' } )
|
||||||
|
bez3@( Bezier3To sp1 sp2 sp3 _ ) -> do
|
||||||
|
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq i sp1
|
||||||
|
sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq i sp2
|
||||||
|
sp3' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq i ) sp3
|
||||||
|
pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3' } )
|
||||||
|
|
||||||
|
inSelectionRange :: ℝ 2 -> T ( ℝ 2 ) -> Bool
|
||||||
|
inSelectionRange p cp =
|
||||||
|
squaredNorm ( c --> ( cp • p ) :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
|
||||||
|
|
||||||
|
lineInSelectionRange :: ℝ 2 -> Segment ( T ( ℝ 2 ) ) -> Bool
|
||||||
|
lineInSelectionRange p seg
|
||||||
|
= case closestPointOnSegment @( T ( ℝ 2 ) ) c ( ( \ q -> ( q • p ) ) <$> seg ) of
|
||||||
|
( _, q ) -> squaredNorm ( c --> q :: T ( ℝ 2 ) ) * zoomFactor ^ ( 2 :: Int ) < 16
|
||||||
|
|
||||||
|
updateSplinePoint
|
||||||
|
:: forall pointParams brushFields
|
||||||
|
. NamedBrush brushFields
|
||||||
|
-> ( pointParams -> Record brushFields )
|
||||||
|
-> ( Record brushFields -> pointParams -> pointParams )
|
||||||
|
-> Unique -> Int
|
||||||
|
-> PointData pointParams
|
||||||
|
-> Tardis ( Maybe BrushWidgetActionState ) ( Maybe BrushWidgetActionState )
|
||||||
|
( PointData pointParams )
|
||||||
|
updateSplinePoint brush toBrushParams updatePointParams uniq i pt = do
|
||||||
|
mbPreviousBrushWidgetAction <- Tardis.getPast
|
||||||
|
case mbPreviousBrushWidgetAction of
|
||||||
|
-- Already started a brush widget update: don't do anything else.
|
||||||
|
Just {}
|
||||||
|
-> pure pt
|
||||||
|
-- Otherwise, check whether we are updating the brush parameters at this stroke point.
|
||||||
|
Nothing -> do
|
||||||
|
let
|
||||||
|
currentBrushParams :: Record brushFields
|
||||||
|
currentBrushParams = toBrushParams ( brushParams pt )
|
||||||
|
brushWidgetElts :: Brush.WidgetElements
|
||||||
|
brushWidgetElts = Brush.widgetElements ( brushWidget brush ) currentBrushParams
|
||||||
|
newBrushWidgetAction :: Maybe BrushWidgetActionState
|
||||||
|
( newBrushWidgetAction, newBrushParams ) = case mbPrevAction of
|
||||||
|
-- Continue the current brush widget action.
|
||||||
|
Just prevAction@( BrushWidgetActionState { brushWidgetPointBeingMoved = oldPt, brushWidgetAction = act }) ->
|
||||||
|
let newPt = pointCoords pt --> c
|
||||||
|
newParams =
|
||||||
|
Brush.widgetUpdate ( brushWidget brush ) act
|
||||||
|
( oldPt, newPt )
|
||||||
|
currentBrushParams
|
||||||
|
in ( Just $ prevAction { brushWidgetPointBeingMoved = newPt }, newParams )
|
||||||
|
Nothing ->
|
||||||
|
-- See if we can start a new brush widget action.
|
||||||
|
case listToMaybe $ filter ( inSelectionRange $ pointCoords pt ) ( Brush.widgetPoints brushWidgetElts ) of
|
||||||
|
Just cp ->
|
||||||
|
let newAction =
|
||||||
|
BrushWidgetActionState
|
||||||
|
{ brushWidgetPointBeingMoved = cp
|
||||||
|
, brushWidgetStrokeUnique = uniq
|
||||||
|
, brushWidgetPointIndex = i
|
||||||
|
, brushWidgetAction = case brushWidget brush of
|
||||||
|
Brush.SquareWidget -> Brush.ScaleAction Brush.ScaleXY
|
||||||
|
Brush.RotatableRectangleWidget ->
|
||||||
|
if pressingCtrl
|
||||||
|
then Brush.RotateAction
|
||||||
|
else Brush.ScaleAction Brush.ScaleXY
|
||||||
|
}
|
||||||
|
in ( Just newAction, currentBrushParams )
|
||||||
|
Nothing -> ( Nothing, currentBrushParams )
|
||||||
|
-- TODO: handle clicking on an edge.
|
||||||
|
-- case listToMaybe $ filter ( lineInSelectionRange $ pointCoords pt ) ( Brush.widgetLines brushWidgetElts ) of
|
||||||
|
-- Just ln -> error "todo"
|
||||||
|
-- Nothing -> Nothing
|
||||||
|
|
||||||
|
Tardis.sendFuture newBrushWidgetAction
|
||||||
|
pure ( set ( field' @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt )
|
||||||
|
|
|
@ -77,7 +77,7 @@ import Math.Bezier.Stroke
|
||||||
, RootSolvingAlgorithm
|
, RootSolvingAlgorithm
|
||||||
)
|
)
|
||||||
import Math.Linear
|
import Math.Linear
|
||||||
( ℝ(..), T(..)
|
( ℝ(..), T(..), Segment(..)
|
||||||
, rotate
|
, rotate
|
||||||
)
|
)
|
||||||
import Math.Module
|
import Math.Module
|
||||||
|
@ -88,6 +88,8 @@ import MetaBrush.Asset.Colours
|
||||||
( Colours, ColourRecord(..) )
|
( Colours, ColourRecord(..) )
|
||||||
import MetaBrush.Brush
|
import MetaBrush.Brush
|
||||||
( NamedBrush(..), WithParams(..) )
|
( NamedBrush(..), WithParams(..) )
|
||||||
|
import qualified MetaBrush.Brush.Widget as Brush
|
||||||
|
( Widget(..), WidgetElements(..), widgetElements )
|
||||||
import MetaBrush.Context
|
import MetaBrush.Context
|
||||||
( Modifier(..)
|
( Modifier(..)
|
||||||
, HoldAction(..), PartialPath(..)
|
, HoldAction(..), PartialPath(..)
|
||||||
|
@ -125,7 +127,8 @@ import MetaBrush.GTK.Util
|
||||||
|
|
||||||
data Renders a
|
data Renders a
|
||||||
= Renders
|
= Renders
|
||||||
{ renderStrokes, renderPath, renderDebug, renderBrushes
|
{ renderStrokes, renderPath, renderDebug
|
||||||
|
, renderBrushes, renderBrushWidgets
|
||||||
, renderCLines, renderCPts, renderPPts :: a
|
, renderCLines, renderCPts, renderPPts :: a
|
||||||
}
|
}
|
||||||
deriving stock ( Show, Functor, Foldable, Traversable, Generic, Generic1 )
|
deriving stock ( Show, Functor, Foldable, Traversable, Generic, Generic1 )
|
||||||
|
@ -261,7 +264,7 @@ data StrokeRenderData where
|
||||||
=> { strokeDataSpline :: !( StrokeSpline clo pointParams ) }
|
=> { strokeDataSpline :: !( StrokeSpline clo pointParams ) }
|
||||||
-> StrokeRenderData
|
-> StrokeRenderData
|
||||||
StrokeWithOutlineRenderData
|
StrokeWithOutlineRenderData
|
||||||
:: forall pointParams clo
|
:: forall pointParams clo brushFields
|
||||||
. ( KnownSplineType clo, Show pointParams, NFData pointParams )
|
. ( KnownSplineType clo, Show pointParams, NFData pointParams )
|
||||||
=> { strokeDataSpline :: !( StrokeSpline clo pointParams )
|
=> { strokeDataSpline :: !( StrokeSpline clo pointParams )
|
||||||
, strokeOutlineData :: !( Either
|
, strokeOutlineData :: !( Either
|
||||||
|
@ -271,6 +274,7 @@ data StrokeRenderData where
|
||||||
, [ Cusp ]
|
, [ Cusp ]
|
||||||
)
|
)
|
||||||
, strokeBrushFunction :: pointParams -> SplinePts Closed
|
, strokeBrushFunction :: pointParams -> SplinePts Closed
|
||||||
|
, strokeWidgetData :: ( Brush.Widget brushFields, pointParams -> Record brushFields )
|
||||||
}
|
}
|
||||||
-> StrokeRenderData
|
-> StrokeRenderData
|
||||||
|
|
||||||
|
@ -285,7 +289,8 @@ instance NFData StrokeRenderData where
|
||||||
-- - If the stroke has an associated brush, this consists of:
|
-- - If the stroke has an associated brush, this consists of:
|
||||||
-- - the path that the brush follows,
|
-- - the path that the brush follows,
|
||||||
-- - the computed outline (using fitting algorithm),
|
-- - the computed outline (using fitting algorithm),
|
||||||
-- - the brush shape function.
|
-- - the brush shape function,
|
||||||
|
-- - the brush widget (UI for modifying brush parameters).
|
||||||
-- - Otherwise, this consists of the underlying spline path only.
|
-- - Otherwise, this consists of the underlying spline path only.
|
||||||
strokeRenderData
|
strokeRenderData
|
||||||
:: RootSolvingAlgorithm
|
:: RootSolvingAlgorithm
|
||||||
|
@ -301,7 +306,7 @@ strokeRenderData rootAlgo mbCuspOptions fitParams
|
||||||
}
|
}
|
||||||
) | strokeVisible
|
) | strokeVisible
|
||||||
= Just $ case strokeBrush of
|
= Just $ case strokeBrush of
|
||||||
Just ( NamedBrush { brushFunction = fn } )
|
Just ( NamedBrush { brushFunction = fn, brushWidget = widget } )
|
||||||
| WithParams
|
| WithParams
|
||||||
{ defaultParams = brush_defaults
|
{ defaultParams = brush_defaults
|
||||||
, withParams = brush@( Brush { brushBaseShape, mbRotation = mbRot } )
|
, withParams = brush@( Brush { brushBaseShape, mbRotation = mbRot } )
|
||||||
|
@ -311,10 +316,10 @@ strokeRenderData rootAlgo mbCuspOptions fitParams
|
||||||
-- the collection of parameters expected by the brush.
|
-- the collection of parameters expected by the brush.
|
||||||
case intersect @pointFields @brushFields of
|
case intersect @pointFields @brushFields of
|
||||||
Intersection
|
Intersection
|
||||||
{ inject
|
{ inject2
|
||||||
, project = toUsedParams :: Record pointFields -> Record usedFields }
|
, project1 = toUsedParams :: Record pointFields -> Record usedFields }
|
||||||
-> do
|
-> do
|
||||||
let embedUsedParams = inject brush_defaults
|
let embedUsedParams = inject2 brush_defaults
|
||||||
|
|
||||||
-- Compute the outline using the brush function.
|
-- Compute the outline using the brush function.
|
||||||
( outline, fitPts, cusps ) <-
|
( outline, fitPts, cusps ) <-
|
||||||
|
@ -339,6 +344,8 @@ strokeRenderData rootAlgo mbCuspOptions fitParams
|
||||||
cosθ = cos θ
|
cosθ = cos θ
|
||||||
sinθ = sin θ
|
sinθ = sin θ
|
||||||
in fmap ( unT . rotate cosθ sinθ . T ) shape
|
in fmap ( unT . rotate cosθ sinθ . T ) shape
|
||||||
|
, strokeWidgetData =
|
||||||
|
( widget, \ params -> embedUsedParams $ toUsedParams params )
|
||||||
}
|
}
|
||||||
_ -> pure $
|
_ -> pure $
|
||||||
StrokeRenderData
|
StrokeRenderData
|
||||||
|
@ -353,10 +360,19 @@ renderStroke
|
||||||
renderStroke cols@( Colours { brush } ) mbHoverContext mode rdrMode debug zoom = \case
|
renderStroke cols@( Colours { brush } ) mbHoverContext mode rdrMode debug zoom = \case
|
||||||
StrokeRenderData { strokeDataSpline } ->
|
StrokeRenderData { strokeDataSpline } ->
|
||||||
renderStrokeSpline cols mode rdrMode mbHoverContext zoom ( const ( pure () ) ) strokeDataSpline
|
renderStrokeSpline cols mode rdrMode mbHoverContext zoom ( const ( pure () ) ) strokeDataSpline
|
||||||
StrokeWithOutlineRenderData strokeDataSpline ( strokeOutlineData, fitPts, cusps ) strokeBrushFunction ->
|
StrokeWithOutlineRenderData
|
||||||
|
{ strokeDataSpline
|
||||||
|
, strokeOutlineData = ( strokeOutlineData, fitPts, cusps )
|
||||||
|
, strokeBrushFunction
|
||||||
|
, strokeWidgetData = ( widget, widgetParams )
|
||||||
|
} ->
|
||||||
renderStrokeSpline cols mode rdrMode mbHoverContext zoom
|
renderStrokeSpline cols mode rdrMode mbHoverContext zoom
|
||||||
( when ( mode == BrushMode )
|
( when ( mode == BrushMode )
|
||||||
. renderBrushShape ( cols { path = brush } ) mbHoverContext ( 2 * zoom ) strokeBrushFunction
|
. ( \ pt ->
|
||||||
|
renderBrushShape ( cols { path = brush } ) mbHoverContext ( 2 * zoom )
|
||||||
|
strokeBrushFunction ( Brush.widgetElements widget ( widgetParams $ brushParams pt ) )
|
||||||
|
pt
|
||||||
|
)
|
||||||
)
|
)
|
||||||
strokeDataSpline
|
strokeDataSpline
|
||||||
*> Compose blank
|
*> Compose blank
|
||||||
|
@ -445,10 +461,11 @@ renderStrokeSpline cols mode rdrMode mbHover zoom renderSubcontent spline =
|
||||||
|
|
||||||
renderBrushShape
|
renderBrushShape
|
||||||
:: Colours -> Maybe HoverContext -> Double
|
:: Colours -> Maybe HoverContext -> Double
|
||||||
-> ( brushParams -> SplinePts Closed )
|
-> ( pointParams -> SplinePts Closed )
|
||||||
-> PointData brushParams
|
-> Brush.WidgetElements
|
||||||
|
-> PointData pointParams
|
||||||
-> Compose Renders Cairo.Render ()
|
-> Compose Renders Cairo.Render ()
|
||||||
renderBrushShape cols mbHoverContext zoom brushFn pt =
|
renderBrushShape cols mbHoverContext zoom brushFn brushWidgetElts pt =
|
||||||
let
|
let
|
||||||
x, y :: Double
|
x, y :: Double
|
||||||
ℝ2 x y = coords pt
|
ℝ2 x y = coords pt
|
||||||
|
@ -462,6 +479,7 @@ renderBrushShape cols mbHoverContext zoom brushFn pt =
|
||||||
Cairo.translate x y
|
Cairo.translate x y
|
||||||
*> renderStrokeSpline cols BrushMode RenderingBrush mbHoverContext' zoom ( const $ pure () )
|
*> renderStrokeSpline cols BrushMode RenderingBrush mbHoverContext' zoom ( const $ pure () )
|
||||||
( fmap ( \ p -> PointData p Normal () ) brushPts )
|
( fmap ( \ p -> PointData p Normal () ) brushPts )
|
||||||
|
*> renderBrushWidgetElements cols zoom mbHoverContext' brushWidgetElts
|
||||||
*> toAll Cairo.restore
|
*> toAll Cairo.restore
|
||||||
|
|
||||||
drawPoint :: Colours -> Maybe HoverContext -> Double -> PointType -> PointData brushData -> Cairo.Render ()
|
drawPoint :: Colours -> Maybe HoverContext -> Double -> PointType -> PointData brushData -> Cairo.Render ()
|
||||||
|
@ -742,6 +760,49 @@ drawCross ( Colours {..} ) zoom = do
|
||||||
Cairo.restore
|
Cairo.restore
|
||||||
-}
|
-}
|
||||||
|
|
||||||
|
renderBrushWidgetElements :: Colours -> Double -> Maybe HoverContext -> Brush.WidgetElements -> Compose Renders Cairo.Render ()
|
||||||
|
renderBrushWidgetElements ( Colours { .. } ) zoom mbHover ( Brush.WidgetElements { Brush.widgetPoints = pts, Brush.widgetLines = lns } ) =
|
||||||
|
Compose blank
|
||||||
|
{ renderBrushWidgets = do
|
||||||
|
for_ lns $ \ seg@( Segment ( T p0@( ℝ2 x1 y1 ) ) ( T p1@( ℝ2 x2 y2 ) ) ) -> do
|
||||||
|
let lineFocus
|
||||||
|
-- Don't do rectangle hover highlighting; doesn't make sense here.
|
||||||
|
| Just ( MouseHover {} ) <- mbHover
|
||||||
|
-- Only focus the line if we aren't focusing a point,
|
||||||
|
-- as line focus corresponds to horizontal/vertical scaling
|
||||||
|
-- as opposed to 2D scaling.
|
||||||
|
, Normal <- hovered mbHover zoom p0
|
||||||
|
, Normal <- hovered mbHover zoom p1
|
||||||
|
= hovered mbHover zoom ( fmap unT seg )
|
||||||
|
| otherwise
|
||||||
|
= Normal
|
||||||
|
Cairo.save
|
||||||
|
Cairo.moveTo x1 y1
|
||||||
|
Cairo.lineTo x2 y2
|
||||||
|
Cairo.setLineWidth ( 2 / zoom )
|
||||||
|
case lineFocus of
|
||||||
|
Hover -> withRGBA brushWidgetHover Cairo.setSourceRGBA
|
||||||
|
_ -> withRGBA brushWidget Cairo.setSourceRGBA
|
||||||
|
Cairo.stroke
|
||||||
|
Cairo.restore
|
||||||
|
for_ pts $ \ ( T p@( ℝ2 x y ) ) -> do
|
||||||
|
let ptFocus
|
||||||
|
-- Don't do rectangle hover highlighting; doesn't make sense here.
|
||||||
|
| Just ( MouseHover {} ) <- mbHover
|
||||||
|
= hovered mbHover zoom p
|
||||||
|
| otherwise
|
||||||
|
= Normal
|
||||||
|
Cairo.save
|
||||||
|
Cairo.translate x y
|
||||||
|
Cairo.arc 0 0 ( 4 / zoom ) 0 ( 2 * pi )
|
||||||
|
Cairo.setLineWidth ( 2 / zoom )
|
||||||
|
case ptFocus of
|
||||||
|
Hover -> withRGBA brushWidgetHover Cairo.setSourceRGBA
|
||||||
|
_ -> withRGBA brushWidget Cairo.setSourceRGBA
|
||||||
|
Cairo.fill
|
||||||
|
Cairo.restore
|
||||||
|
}
|
||||||
|
|
||||||
hsl2rgb :: Double -> Double -> Double -> ( Double, Double, Double )
|
hsl2rgb :: Double -> Double -> Double -> ( Double, Double, Double )
|
||||||
hsl2rgb h s l = case hc2rgb h c of
|
hsl2rgb h s l = case hc2rgb h c of
|
||||||
( r, g, b ) -> ( r + m, g + m, b + m )
|
( r, g, b ) -> ( r + m, g + m, b + m )
|
||||||
|
|
|
@ -39,6 +39,8 @@ import Math.Ring
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import MetaBrush.Brush
|
import MetaBrush.Brush
|
||||||
( NamedBrush(..), SomeBrush(..), WithParams(..) )
|
( NamedBrush(..), SomeBrush(..), WithParams(..) )
|
||||||
|
import qualified MetaBrush.Brush.Widget as Brush
|
||||||
|
( Widget(..) )
|
||||||
import MetaBrush.Records
|
import MetaBrush.Records
|
||||||
( Record(MkR) )
|
( Record(MkR) )
|
||||||
|
|
||||||
|
@ -60,7 +62,12 @@ brushes = HashMap.fromList
|
||||||
type CircleBrushFields = '[ "r" ]
|
type CircleBrushFields = '[ "r" ]
|
||||||
-- | A circular brush with the given radius.
|
-- | A circular brush with the given radius.
|
||||||
circle :: NamedBrush CircleBrushFields
|
circle :: NamedBrush CircleBrushFields
|
||||||
circle = NamedBrush "circle" ( WithParams deflts $ coerce circleBrush )
|
circle =
|
||||||
|
NamedBrush
|
||||||
|
{ brushName = "circle"
|
||||||
|
, brushFunction = WithParams deflts $ coerce circleBrush
|
||||||
|
, brushWidget = Brush.SquareWidget
|
||||||
|
}
|
||||||
where
|
where
|
||||||
deflts :: Record CircleBrushFields
|
deflts :: Record CircleBrushFields
|
||||||
deflts = MkR ( ℝ1 1 )
|
deflts = MkR ( ℝ1 1 )
|
||||||
|
@ -70,7 +77,12 @@ type EllipseBrushFields = '[ "a", "b", "phi" ]
|
||||||
-- | An elliptical brush with the given semi-major and semi-minor axes and
|
-- | An elliptical brush with the given semi-major and semi-minor axes and
|
||||||
-- angle of rotation.
|
-- angle of rotation.
|
||||||
ellipse :: NamedBrush EllipseBrushFields
|
ellipse :: NamedBrush EllipseBrushFields
|
||||||
ellipse = NamedBrush "ellipse" ( WithParams deflts $ coerce ellipseBrush )
|
ellipse =
|
||||||
|
NamedBrush
|
||||||
|
{ brushName = "ellipse"
|
||||||
|
, brushFunction = WithParams deflts $ coerce ellipseBrush
|
||||||
|
, brushWidget = Brush.RotatableRectangleWidget
|
||||||
|
}
|
||||||
where
|
where
|
||||||
deflts :: Record EllipseBrushFields
|
deflts :: Record EllipseBrushFields
|
||||||
deflts = MkR ( ℝ3 1 1 0 )
|
deflts = MkR ( ℝ3 1 1 0 )
|
||||||
|
@ -79,7 +91,12 @@ ellipse = NamedBrush "ellipse" ( WithParams deflts $ coerce ellipseBrush )
|
||||||
type TearDropBrushFields = '[ "w", "h", "phi" ]
|
type TearDropBrushFields = '[ "w", "h", "phi" ]
|
||||||
-- | A tear-drop shape with the given width, height and angle of rotation.
|
-- | A tear-drop shape with the given width, height and angle of rotation.
|
||||||
tearDrop :: NamedBrush TearDropBrushFields
|
tearDrop :: NamedBrush TearDropBrushFields
|
||||||
tearDrop = NamedBrush "tear-drop" ( WithParams deflts $ coerce tearDropBrush )
|
tearDrop =
|
||||||
|
NamedBrush
|
||||||
|
{ brushName = "tear-drop"
|
||||||
|
, brushFunction = WithParams deflts $ coerce tearDropBrush
|
||||||
|
, brushWidget = Brush.RotatableRectangleWidget
|
||||||
|
}
|
||||||
where
|
where
|
||||||
deflts :: Record TearDropBrushFields
|
deflts :: Record TearDropBrushFields
|
||||||
deflts = MkR ( ℝ3 1 2.25 0 )
|
deflts = MkR ( ℝ3 1 2.25 0 )
|
||||||
|
|
|
@ -42,8 +42,6 @@ import qualified Data.Text as Text
|
||||||
-- brush-strokes
|
-- brush-strokes
|
||||||
import Calligraphy.Brushes
|
import Calligraphy.Brushes
|
||||||
( Brush(..) )
|
( Brush(..) )
|
||||||
import Math.Bezier.Spline
|
|
||||||
( SplineType(Closed), Spline )
|
|
||||||
import Math.Differentiable
|
import Math.Differentiable
|
||||||
( DiffInterp )
|
( DiffInterp )
|
||||||
import Math.Interval
|
import Math.Interval
|
||||||
|
@ -51,6 +49,8 @@ import Math.Interval
|
||||||
import Math.Linear
|
import Math.Linear
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
|
import qualified MetaBrush.Brush.Widget as Brush
|
||||||
|
( Widget )
|
||||||
import MetaBrush.Records
|
import MetaBrush.Records
|
||||||
( KnownSymbols, Length, Record )
|
( KnownSymbols, Length, Record )
|
||||||
import MetaBrush.Serialisable
|
import MetaBrush.Serialisable
|
||||||
|
@ -77,19 +77,22 @@ type NamedBrush :: [ Symbol ] -> Type
|
||||||
data NamedBrush brushFields where
|
data NamedBrush brushFields where
|
||||||
NamedBrush
|
NamedBrush
|
||||||
:: forall brushFields
|
:: forall brushFields
|
||||||
. ( KnownSymbols brushFields, Typeable brushFields
|
. ( KnownSymbols brushFields
|
||||||
, Representable Double ( ℝ ( Length brushFields ) )
|
, Representable Double ( ℝ ( Length brushFields ) )
|
||||||
, DiffInterp 2 () ( ℝ ( Length brushFields ) )
|
, DiffInterp 2 () ( ℝ ( Length brushFields ) )
|
||||||
, DiffInterp 3 𝕀 ( ℝ ( Length brushFields ) )
|
, DiffInterp 3 𝕀 ( ℝ ( Length brushFields ) )
|
||||||
)
|
)
|
||||||
=> { brushName :: !Text
|
=> { brushName :: !Text
|
||||||
, brushFunction :: BrushFunction brushFields
|
, brushFunction :: !( BrushFunction brushFields )
|
||||||
|
, brushWidget :: !( Brush.Widget brushFields )
|
||||||
}
|
}
|
||||||
-> NamedBrush brushFields
|
-> NamedBrush brushFields
|
||||||
|
|
||||||
data SomeBrush where
|
data SomeBrush where
|
||||||
SomeBrush
|
SomeBrush
|
||||||
:: { someBrush :: !( NamedBrush brushFields ) }
|
:: forall brushFields
|
||||||
|
. KnownSymbols brushFields
|
||||||
|
=> { someBrush :: !( NamedBrush brushFields ) }
|
||||||
-> SomeBrush
|
-> SomeBrush
|
||||||
|
|
||||||
instance Show ( NamedBrush brushFields ) where
|
instance Show ( NamedBrush brushFields ) where
|
||||||
|
@ -102,9 +105,11 @@ instance NFData ( NamedBrush brushFields ) where
|
||||||
rnf ( NamedBrush { brushName } )
|
rnf ( NamedBrush { brushName } )
|
||||||
= rnf brushName
|
= rnf brushName
|
||||||
instance Eq ( NamedBrush brushFields ) where
|
instance Eq ( NamedBrush brushFields ) where
|
||||||
NamedBrush name1 _ == NamedBrush name2 _ = name1 == name2
|
NamedBrush { brushName = name1 } == NamedBrush { brushName = name2 }
|
||||||
|
= name1 == name2
|
||||||
instance Ord ( NamedBrush brushFields ) where
|
instance Ord ( NamedBrush brushFields ) where
|
||||||
compare ( NamedBrush name1 _ ) ( NamedBrush name2 _ ) = compare name1 name2
|
compare ( NamedBrush { brushName = name1 } ) ( NamedBrush { brushName = name2 } )
|
||||||
|
= compare name1 name2
|
||||||
instance Hashable ( NamedBrush brushFields ) where
|
instance Hashable ( NamedBrush brushFields ) where
|
||||||
hashWithSalt salt ( NamedBrush { brushName } ) =
|
hashWithSalt salt ( NamedBrush { brushName } ) =
|
||||||
hashWithSalt salt brushName
|
hashWithSalt salt brushName
|
||||||
|
|
129
src/metabrushes/MetaBrush/Brush/Widget.hs
Normal file
129
src/metabrushes/MetaBrush/Brush/Widget.hs
Normal file
|
@ -0,0 +1,129 @@
|
||||||
|
module MetaBrush.Brush.Widget
|
||||||
|
( Widget(..)
|
||||||
|
, WidgetElements(..)
|
||||||
|
, widgetElements
|
||||||
|
, widgetUpdate
|
||||||
|
, WhatScale(..)
|
||||||
|
, WidgetAction(..)
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
-- base
|
||||||
|
import Data.Fixed
|
||||||
|
( mod' )
|
||||||
|
import Data.Kind
|
||||||
|
( Type )
|
||||||
|
import GHC.TypeLits
|
||||||
|
( Symbol )
|
||||||
|
|
||||||
|
-- brush-strokes
|
||||||
|
import Math.Linear
|
||||||
|
( ℝ(..), T(..), Segment(..)
|
||||||
|
, rotate
|
||||||
|
)
|
||||||
|
import Math.Module
|
||||||
|
( (^.^), (×)
|
||||||
|
, norm
|
||||||
|
)
|
||||||
|
|
||||||
|
-- metabrushes
|
||||||
|
import MetaBrush.Records
|
||||||
|
( Record(..) )
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
-- | A description of a widget to control brush parameters interactively.
|
||||||
|
--
|
||||||
|
-- For example, a rotatable rectangle widget to control the size of an
|
||||||
|
-- elliptical brush.
|
||||||
|
type Widget :: [ Symbol ] -> Type
|
||||||
|
data Widget flds where
|
||||||
|
SquareWidget
|
||||||
|
:: Widget '[ r ]
|
||||||
|
RotatableRectangleWidget
|
||||||
|
:: Widget '[ w, h, phi ]
|
||||||
|
deriving stock instance Eq ( Widget flds )
|
||||||
|
deriving stock instance Ord ( Widget flds )
|
||||||
|
deriving stock instance Show ( Widget flds )
|
||||||
|
|
||||||
|
-- | Components of a widget that can be displayed visually.
|
||||||
|
data WidgetElements
|
||||||
|
= WidgetElements
|
||||||
|
{ widgetPoints :: ![ T ( ℝ 2 ) ]
|
||||||
|
, widgetLines :: ![ Segment ( T ( ℝ 2 ) ) ]
|
||||||
|
}
|
||||||
|
|
||||||
|
-- | All UI elements associated to a 'Widget'.
|
||||||
|
widgetElements :: Widget flds -> Record flds -> WidgetElements
|
||||||
|
widgetElements widget ( MkR flds ) =
|
||||||
|
case widget of
|
||||||
|
SquareWidget
|
||||||
|
| ℝ1 r <- flds
|
||||||
|
-> rectElements r r 0
|
||||||
|
RotatableRectangleWidget
|
||||||
|
| ℝ3 w h θ <- flds
|
||||||
|
-> rectElements w h θ
|
||||||
|
where
|
||||||
|
rectElements w h θ =
|
||||||
|
WidgetElements
|
||||||
|
{ widgetPoints = [ p1, p2, p3, p4 ]
|
||||||
|
, widgetLines = [ Segment p1 p2
|
||||||
|
, Segment p2 p3
|
||||||
|
, Segment p3 p4
|
||||||
|
, Segment p4 p1
|
||||||
|
]
|
||||||
|
}
|
||||||
|
where
|
||||||
|
p1 = rot $ T $ ℝ2 -w -h
|
||||||
|
p2 = rot $ T $ ℝ2 w -h
|
||||||
|
p3 = rot $ T $ ℝ2 w h
|
||||||
|
p4 = rot $ T $ ℝ2 -w h
|
||||||
|
rot = rotate ( cos θ ) ( sin θ )
|
||||||
|
|
||||||
|
data WhatScale
|
||||||
|
= ScaleXY
|
||||||
|
| ScaleX
|
||||||
|
| ScaleY
|
||||||
|
deriving stock ( Eq, Ord, Show )
|
||||||
|
|
||||||
|
-- | Keep track of state in a brush widget action, e.g.
|
||||||
|
-- scaling or rotating a brush.
|
||||||
|
data WidgetAction
|
||||||
|
= ScaleAction WhatScale
|
||||||
|
| RotateAction
|
||||||
|
--{ windingNumber :: Int }
|
||||||
|
deriving stock ( Eq, Ord, Show )
|
||||||
|
|
||||||
|
-- | Given an UI action (moving a widget control element),
|
||||||
|
-- how should we update the brush parameters?
|
||||||
|
widgetUpdate :: Widget flds
|
||||||
|
-> WidgetAction
|
||||||
|
-> ( T ( ℝ 2 ), T ( ℝ 2 ) )
|
||||||
|
-- ^ ( oldPt, newPt )
|
||||||
|
-> Record flds
|
||||||
|
-> Record flds
|
||||||
|
widgetUpdate widget mode ( oldPt, newPt ) ( MkR oldFlds ) =
|
||||||
|
case widget of
|
||||||
|
SquareWidget
|
||||||
|
| T ( ℝ2 x y ) <- newPt
|
||||||
|
-> MkR $ ℝ1 ( max ( abs x ) ( abs y ) )
|
||||||
|
RotatableRectangleWidget
|
||||||
|
| ℝ3 w h θ <- oldFlds
|
||||||
|
-> case mode of
|
||||||
|
ScaleAction whatScale ->
|
||||||
|
let T ( ℝ2 w' h' ) = rotate ( cos -θ ) ( sin -θ ) newPt
|
||||||
|
in case whatScale of
|
||||||
|
ScaleXY -> MkR $ ℝ3 ( abs w' ) ( abs h' ) θ
|
||||||
|
ScaleX -> MkR $ ℝ3 ( abs w' ) h θ
|
||||||
|
ScaleY -> MkR $ ℝ3 w ( abs h' ) θ
|
||||||
|
RotateAction {}
|
||||||
|
| norm newPt < 1e-5
|
||||||
|
-> MkR oldFlds
|
||||||
|
| otherwise
|
||||||
|
->
|
||||||
|
let θ1 = atan2 ( oldPt ^.^ newPt ) ( oldPt × newPt )
|
||||||
|
θ' = nearestAngle θ θ1
|
||||||
|
in MkR $ ℝ3 w h θ'
|
||||||
|
|
||||||
|
nearestAngle :: Double -> Double -> Double
|
||||||
|
nearestAngle θ0 θ = θ0 + ( ( θ - θ0 + pi ) `mod'` ( 2 * pi ) - pi )
|
|
@ -85,9 +85,10 @@ import Math.Module
|
||||||
( origin, (^+^), (^-^), (*^) )
|
( origin, (^+^), (^-^), (*^) )
|
||||||
, Inner((^.^))
|
, Inner((^.^))
|
||||||
, squaredNorm, quadrance
|
, squaredNorm, quadrance
|
||||||
|
, closestPointOnSegment
|
||||||
)
|
)
|
||||||
import Math.Linear
|
import Math.Linear
|
||||||
( ℝ(..), T(..) )
|
( ℝ(..), T(..), Segment(..) )
|
||||||
import MetaBrush.Brush
|
import MetaBrush.Brush
|
||||||
( NamedBrush, PointFields )
|
( NamedBrush, PointFields )
|
||||||
import MetaBrush.Records
|
import MetaBrush.Records
|
||||||
|
@ -298,6 +299,17 @@ instance Hoverable ( ℝ 2 ) where
|
||||||
| otherwise
|
| otherwise
|
||||||
= Normal
|
= Normal
|
||||||
|
|
||||||
|
instance Hoverable ( Segment ( ℝ 2 ) ) where
|
||||||
|
hovered Nothing _ _ = Normal
|
||||||
|
hovered ( Just ( MouseHover p ) ) zoom seg
|
||||||
|
= hovered ( Just ( MouseHover p ) ) zoom p'
|
||||||
|
where
|
||||||
|
( _, p' ) = closestPointOnSegment @( T ( ℝ 2 ) ) p seg
|
||||||
|
hovered hov@( Just ( RectangleHover {} ) ) zoom ( Segment p0 p1 )
|
||||||
|
-- Only consider a segment to be "hovered" if it lies entirely within the
|
||||||
|
-- hover rectangle, not just if the hover rectangle intersects it.
|
||||||
|
= hovered hov zoom p0 <> hovered hov zoom p1
|
||||||
|
|
||||||
class HasSelection pt where
|
class HasSelection pt where
|
||||||
_selection :: Lens' pt FocusState
|
_selection :: Lens' pt FocusState
|
||||||
instance HasSelection ( PointData brushParams ) where
|
instance HasSelection ( PointData brushParams ) where
|
||||||
|
|
|
@ -162,7 +162,7 @@ type family Length xs where
|
||||||
Length ( _ : xs ) = 1 + Length xs
|
Length ( _ : xs ) = 1 + Length xs
|
||||||
|
|
||||||
type KnownSymbols :: [ Symbol ] -> Constraint
|
type KnownSymbols :: [ Symbol ] -> Constraint
|
||||||
class KnownSymbols ks where
|
class Typeable ks => KnownSymbols ks where
|
||||||
knownSymbols :: [ Text ]
|
knownSymbols :: [ Text ]
|
||||||
instance KnownSymbols '[] where
|
instance KnownSymbols '[] where
|
||||||
knownSymbols = []
|
knownSymbols = []
|
||||||
|
@ -176,8 +176,7 @@ instance ( KnownSymbol k, KnownSymbols ks ) => KnownSymbols ( k ': ks ) where
|
||||||
|
|
||||||
{-# INLINE intersect #-}
|
{-# INLINE intersect #-}
|
||||||
intersect :: forall r1 r2 l1 l2
|
intersect :: forall r1 r2 l1 l2
|
||||||
. ( Typeable r1, Typeable r2
|
. ( KnownSymbols r1, KnownSymbols r2
|
||||||
, KnownSymbols r1, KnownSymbols r2
|
|
||||||
, l1 ~ Length r1, l2 ~ Length r2
|
, l1 ~ Length r1, l2 ~ Length r2
|
||||||
, Representable Double ( ℝ l1 )
|
, Representable Double ( ℝ l1 )
|
||||||
, Representable Double ( ℝ l2 )
|
, Representable Double ( ℝ l2 )
|
||||||
|
@ -189,16 +188,22 @@ intersect
|
||||||
-- Shortcut when the two rows are equal.
|
-- Shortcut when the two rows are equal.
|
||||||
| Just Refl <- eqT @r1 @r2
|
| Just Refl <- eqT @r1 @r2
|
||||||
, Refl <- ( unsafeCoerce Refl :: r1 :~: Intersect r1 r2 )
|
, Refl <- ( unsafeCoerce Refl :: r1 :~: Intersect r1 r2 )
|
||||||
= Intersection { project = id, inject = \ _ -> id }
|
= Intersection { project1 = id, project2 = id, inject1 = \ _ -> id, inject2 = \ _ -> id }
|
||||||
| otherwise
|
| otherwise
|
||||||
= doIntersection @r1 @r2 \ ( _ :: Proxy# r1r2 ) r1_idxs r2_idxs ->
|
= doIntersection @r1 @r2 \ ( _ :: Proxy# r1r2 ) r1_idxs r2_idxs ->
|
||||||
let
|
let
|
||||||
project :: Record r1 -> Record r1r2
|
project1 :: Record r1 -> Record r1r2
|
||||||
project = \ ( MkR r1 ) -> MkR $ projection ( (!) r1_idxs ) r1
|
project1 = \ ( MkR r1 ) -> MkR $ projection ( (!) r1_idxs ) r1
|
||||||
|
|
||||||
inject :: Record r2 -> Record r1r2 -> Record r2
|
project2 :: Record r2 -> Record r1r2
|
||||||
inject = \ ( MkR r2 ) -> \ ( MkR r1r2 ) -> MkR $ injection ( \ i -> find ( == i ) r2_idxs ) r1r2 r2
|
project2 = \ ( MkR r2 ) -> MkR $ projection ( (!) r2_idxs ) r2
|
||||||
in Intersection { project, inject }
|
|
||||||
|
inject1 :: Record r1 -> Record r1r2 -> Record r1
|
||||||
|
inject1 = \ ( MkR r1 ) -> \ ( MkR r1r2 ) -> MkR $ injection ( \ i -> find ( == i ) r1_idxs ) r1r2 r1
|
||||||
|
|
||||||
|
inject2 :: Record r2 -> Record r1r2 -> Record r2
|
||||||
|
inject2 = \ ( MkR r2 ) -> \ ( MkR r1r2 ) -> MkR $ injection ( \ i -> find ( == i ) r2_idxs ) r1r2 r2
|
||||||
|
in Intersection { project1, project2, inject1, inject2 }
|
||||||
|
|
||||||
data Intersection r1 r2 where
|
data Intersection r1 r2 where
|
||||||
Intersection
|
Intersection
|
||||||
|
@ -209,10 +214,16 @@ data Intersection r1 r2 where
|
||||||
, Differentiable 2 () ( ℝ l12 )
|
, Differentiable 2 () ( ℝ l12 )
|
||||||
, Differentiable 3 𝕀 ( ℝ l12 )
|
, Differentiable 3 𝕀 ( ℝ l12 )
|
||||||
)
|
)
|
||||||
=> { project :: Record r1 -> Record r1r2
|
=> { project1 :: Record r1 -> Record r1r2
|
||||||
-- ^ project out fields present in both rows
|
-- ^ project out fields present in both rows
|
||||||
-- (linear non-decreasing mapping)
|
-- (linear non-decreasing mapping)
|
||||||
, inject :: Record r2 -> Record r1r2 -> Record r2
|
, project2 :: Record r2 -> Record r1r2
|
||||||
|
-- ^ project out fields present in both rows
|
||||||
|
-- (linear non-decreasing mapping)
|
||||||
|
, inject1 :: Record r1 -> Record r1r2 -> Record r1
|
||||||
|
-- ^ overrides the components of the first record with the second
|
||||||
|
-- (linear non-decreasing mapping in its second argument)
|
||||||
|
, inject2 :: Record r2 -> Record r1r2 -> Record r2
|
||||||
-- ^ overrides the components of the first record with the second
|
-- ^ overrides the components of the first record with the second
|
||||||
-- (linear non-decreasing mapping in its second argument)
|
-- (linear non-decreasing mapping in its second argument)
|
||||||
} -> Intersection r1 r2
|
} -> Intersection r1 r2
|
||||||
|
|
Loading…
Reference in a new issue