mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
improvements to brush params when changing brush
This commit is contained in:
parent
c1d6dd4151
commit
1a8f4b5f5d
|
@ -56,7 +56,7 @@ main = withCP65001 do
|
||||||
when (isNothing mbGdkScale) $
|
when (isNothing mbGdkScale) $
|
||||||
setEnv "GDK_SCALE" "2"
|
setEnv "GDK_SCALE" "2"
|
||||||
|
|
||||||
setEnv "GSK_RENDERER" "cairo"
|
setEnv "GSK_RENDERER" "vulkan"
|
||||||
|
|
||||||
---------------------------------------------------------
|
---------------------------------------------------------
|
||||||
-- Run GTK application
|
-- Run GTK application
|
||||||
|
|
|
@ -213,8 +213,8 @@ tearDropBrushFn :: forall {t} (i :: t) k nbParams
|
||||||
tearDropBrushFn _ mkI1 mkI2 =
|
tearDropBrushFn _ mkI1 mkI2 =
|
||||||
D \ params ->
|
D \ params ->
|
||||||
let w, h :: D k nbParams ( I i Double )
|
let w, h :: D k nbParams ( I i Double )
|
||||||
w = runD ( var @_ @k ( Fin 1 ) ) params
|
w = 2 * runD ( var @_ @k ( Fin 1 ) ) params
|
||||||
h = runD ( var @_ @k ( Fin 2 ) ) params
|
h = 2 * runD ( var @_ @k ( Fin 2 ) ) params
|
||||||
mkPt :: Double -> Double -> D k nbParams ( I i 2 )
|
mkPt :: Double -> Double -> D k nbParams ( I i 2 )
|
||||||
mkPt x y
|
mkPt x y
|
||||||
-- 1. translate the teardrop so that the centre of mass is at the origin
|
-- 1. translate the teardrop so that the centre of mass is at the origin
|
||||||
|
|
|
@ -25,6 +25,8 @@ module Math.Bezier.Stroke
|
||||||
where
|
where
|
||||||
|
|
||||||
-- base
|
-- base
|
||||||
|
import Prelude
|
||||||
|
hiding ( unzip )
|
||||||
import Control.Arrow
|
import Control.Arrow
|
||||||
( first, (***) )
|
( first, (***) )
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
@ -40,7 +42,7 @@ import Data.Fixed
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
( for_ )
|
( for_ )
|
||||||
import Data.Functor
|
import Data.Functor
|
||||||
( (<&>) )
|
( (<&>), unzip )
|
||||||
import Data.Functor.Identity
|
import Data.Functor.Identity
|
||||||
( Identity(..) )
|
( Identity(..) )
|
||||||
import Data.List
|
import Data.List
|
||||||
|
@ -48,7 +50,7 @@ import Data.List
|
||||||
import Data.List.NonEmpty
|
import Data.List.NonEmpty
|
||||||
( NonEmpty )
|
( NonEmpty )
|
||||||
import qualified Data.List.NonEmpty as NE
|
import qualified Data.List.NonEmpty as NE
|
||||||
( cons, singleton, unzip )
|
( cons, singleton )
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
( fromMaybe, isJust, listToMaybe, mapMaybe )
|
( fromMaybe, isJust, listToMaybe, mapMaybe )
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
|
@ -721,7 +723,7 @@ joinBetweenOffsets
|
||||||
= let
|
= let
|
||||||
pcs, lastAndRest :: Maybe ( SplinePts Open )
|
pcs, lastAndRest :: Maybe ( SplinePts Open )
|
||||||
( pcs, lastAndRest )
|
( pcs, lastAndRest )
|
||||||
= NE.unzip
|
= unzip
|
||||||
$ ( discardCurveData *** discardCurveData )
|
$ ( discardCurveData *** discardCurveData )
|
||||||
. splitSplineAt ( i2 - i1 )
|
. splitSplineAt ( i2 - i1 )
|
||||||
<$> dropCurves i1 openSpline
|
<$> dropCurves i1 openSpline
|
||||||
|
|
|
@ -9,7 +9,7 @@ module Math.Root.Isolation.Utils
|
||||||
import Prelude hiding ( unzip )
|
import Prelude hiding ( unzip )
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
( toList )
|
( toList )
|
||||||
import Data.List.NonEmpty
|
import Data.Functor
|
||||||
( unzip )
|
( unzip )
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
|
|
|
@ -214,6 +214,7 @@ runApplication application = do
|
||||||
modifiersTVar <- STM.newTVarIO Set.empty
|
modifiersTVar <- STM.newTVarIO Set.empty
|
||||||
toolTVar <- STM.newTVarIO Selection
|
toolTVar <- STM.newTVarIO Selection
|
||||||
modeTVar <- STM.newTVarIO PathMode
|
modeTVar <- STM.newTVarIO PathMode
|
||||||
|
selectedBrushTVar <- STM.newTVarIO Nothing
|
||||||
debugTVar <- STM.newTVarIO False
|
debugTVar <- STM.newTVarIO False
|
||||||
partialPathTVar <- STM.newTVarIO Nothing
|
partialPathTVar <- STM.newTVarIO Nothing
|
||||||
fileBarTabsTVar <- STM.newTVarIO Map.empty
|
fileBarTabsTVar <- STM.newTVarIO Map.empty
|
||||||
|
@ -479,7 +480,7 @@ runApplication application = do
|
||||||
---------------------------------------------------------
|
---------------------------------------------------------
|
||||||
-- Brushes view
|
-- Brushes view
|
||||||
|
|
||||||
brushesListView <- newBrushView window DragBrush
|
brushesListView <- newBrushView window variables DragBrush
|
||||||
GTK.scrolledWindowSetChild
|
GTK.scrolledWindowSetChild
|
||||||
( brushesScrolledWindow panelsBar )
|
( brushesScrolledWindow panelsBar )
|
||||||
( Just brushesListView )
|
( Just brushesListView )
|
||||||
|
|
|
@ -939,13 +939,14 @@ instance HandleAction MouseClick where
|
||||||
Pen -> do
|
Pen -> do
|
||||||
-- Pen tool in path mode: start or continue a drawing operation.
|
-- Pen tool in path mode: start or continue a drawing operation.
|
||||||
mbPartialPath <- STM.readTVar partialPathTVar
|
mbPartialPath <- STM.readTVar partialPathTVar
|
||||||
|
mbSelBrush <- STM.readTVar selectedBrushTVar
|
||||||
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
|
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
|
||||||
case mbPartialPath of
|
case mbPartialPath of
|
||||||
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
|
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
( newDocument, drawAnchor ) <-
|
( newDocument, drawAnchor ) <-
|
||||||
getOrCreateDrawAnchor uniqueSupply pos doc
|
getOrCreateDrawAnchor uniqueSupply mbSelBrush pos doc
|
||||||
let firstPos = anchorPos drawAnchor doc
|
let firstPos = anchorPos drawAnchor newDocument
|
||||||
STM.writeTVar partialPathTVar
|
STM.writeTVar partialPathTVar
|
||||||
( Just $ PartialPath
|
( Just $ PartialPath
|
||||||
{ partialPathAnchor = drawAnchor
|
{ partialPathAnchor = drawAnchor
|
||||||
|
@ -1159,6 +1160,7 @@ instance HandleAction MouseRelease where
|
||||||
Pen -> case mode of
|
Pen -> case mode of
|
||||||
PathMode -> do
|
PathMode -> do
|
||||||
mbPartialPath <- STM.readTVar partialPathTVar
|
mbPartialPath <- STM.readTVar partialPathTVar
|
||||||
|
mbSelBrush <- STM.readTVar selectedBrushTVar
|
||||||
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.
|
||||||
-- If no anchor exists, then just ignore the mouse release event.
|
-- If no anchor exists, then just ignore the mouse release event.
|
||||||
|
@ -1186,7 +1188,7 @@ instance HandleAction MouseRelease where
|
||||||
= ( holdPos, Just $ ( pos --> holdPos :: T ( ℝ 2 ) ) • holdPos, Just pos )
|
= ( holdPos, Just $ ( pos --> holdPos :: T ( ℝ 2 ) ) • holdPos, Just pos )
|
||||||
| otherwise
|
| otherwise
|
||||||
= ( pos, Nothing, Nothing )
|
= ( pos, Nothing, Nothing )
|
||||||
( _, otherAnchor ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
|
( _, otherAnchor ) <- getOrCreateDrawAnchor uniqueSupply mbSelBrush pathPoint doc
|
||||||
if isNothing firstPoint && anchorsAreComplementary anchor otherAnchor
|
if isNothing firstPoint && anchorsAreComplementary anchor otherAnchor
|
||||||
-- Close path.
|
-- Close path.
|
||||||
then do
|
then do
|
||||||
|
|
|
@ -58,6 +58,8 @@ import MetaBrush.Action
|
||||||
( BrushWidgetActionState )
|
( BrushWidgetActionState )
|
||||||
import MetaBrush.Asset.Colours
|
import MetaBrush.Asset.Colours
|
||||||
( Colours )
|
( Colours )
|
||||||
|
import MetaBrush.Brush
|
||||||
|
( SomeBrush )
|
||||||
import MetaBrush.Document.Diff
|
import MetaBrush.Document.Diff
|
||||||
( DragMoveSelect )
|
( DragMoveSelect )
|
||||||
import MetaBrush.Draw
|
import MetaBrush.Draw
|
||||||
|
@ -74,6 +76,7 @@ import MetaBrush.Unique
|
||||||
( UniqueSupply, Unique )
|
( UniqueSupply, Unique )
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
data UIElements
|
data UIElements
|
||||||
|
@ -113,6 +116,8 @@ data Variables
|
||||||
-- is kept in-sync between the application and the UI's 'GTK.TreeListModel'.
|
-- is kept in-sync between the application and the UI's 'GTK.TreeListModel'.
|
||||||
, listModelUpToDateTMVar :: !( STM.TMVar () )
|
, listModelUpToDateTMVar :: !( STM.TMVar () )
|
||||||
|
|
||||||
|
, selectedBrushTVar :: !( STM.TVar ( Maybe SomeBrush ) )
|
||||||
|
|
||||||
, mousePosTVar :: !( STM.TVar ( Maybe ( ℝ 2 ) ) )
|
, mousePosTVar :: !( STM.TVar ( Maybe ( ℝ 2 ) ) )
|
||||||
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
|
, mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) )
|
||||||
, modifiersTVar :: !( STM.TVar ( Set Modifier ) )
|
, modifiersTVar :: !( STM.TVar ( Set Modifier ) )
|
||||||
|
|
|
@ -175,6 +175,7 @@ getDocumentRender
|
||||||
| Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent
|
| Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent
|
||||||
, Just p1 <- mbMousePos
|
, Just p1 <- mbMousePos
|
||||||
, p0 /= p1
|
, p0 /= p1
|
||||||
|
-- Non-trivial drag in progress.
|
||||||
, let
|
, let
|
||||||
alternateMode :: Bool
|
alternateMode :: Bool
|
||||||
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
|
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
|
||||||
|
@ -197,6 +198,7 @@ getDocumentRender
|
||||||
| otherwise
|
| otherwise
|
||||||
= ( mbMousePos, Nothing )
|
= ( mbMousePos, Nothing )
|
||||||
, Just finalPoint <- mbFinalPoint
|
, Just finalPoint <- mbFinalPoint
|
||||||
|
-- Path drawing operation in progress.
|
||||||
, let
|
, let
|
||||||
previewSpline :: Spline Open () ( PointData () )
|
previewSpline :: Spline Open () ( PointData () )
|
||||||
previewSpline = catMaybesSpline ( inPointClickRange zoom `on` coords ) ()
|
previewSpline = catMaybesSpline ( inPointClickRange zoom `on` coords ) ()
|
||||||
|
|
|
@ -33,27 +33,46 @@ import qualified GI.Gtk as GTK
|
||||||
import qualified Data.GI.Base as GI
|
import qualified Data.GI.Base as GI
|
||||||
import qualified Data.GI.Base.GValue as GI
|
import qualified Data.GI.Base.GValue as GI
|
||||||
|
|
||||||
|
-- stm
|
||||||
|
import qualified Control.Concurrent.STM as STM
|
||||||
|
|
||||||
-- text
|
-- text
|
||||||
import Data.Text
|
import Data.Text
|
||||||
( Text )
|
( Text )
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
( toLower )
|
( null, toLower )
|
||||||
|
|
||||||
-- unordered-containers
|
-- unordered-containers
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
|
import MetaBrush.Application.Context
|
||||||
|
( Variables(selectedBrushTVar) )
|
||||||
|
import MetaBrush.Brush
|
||||||
|
( SomeBrush )
|
||||||
import qualified MetaBrush.Asset.Brushes as Brushes
|
import qualified MetaBrush.Asset.Brushes as Brushes
|
||||||
( brushes )
|
( brushes )
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Brush lookup --
|
||||||
|
------------------
|
||||||
|
|
||||||
|
brushFromName :: Text -> Maybe SomeBrush
|
||||||
|
brushFromName str
|
||||||
|
| Text.null str || Text.toLower str == "no brush"
|
||||||
|
= Nothing
|
||||||
|
| otherwise
|
||||||
|
= HashMap.lookup str Brushes.brushes
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- GTK StringList --
|
-- GTK StringList --
|
||||||
--------------------
|
--------------------
|
||||||
|
|
||||||
-- | Create a new 'GTK.StringList' with 'GTK.SingleSelection' to hold
|
-- | Create a new 'GTK.StringList' with 'GTK.SingleSelection' to hold
|
||||||
-- the given brush names.
|
-- the given brush names.
|
||||||
newBrushListModel :: [ Text ] -> IO GTK.SingleSelection
|
newBrushListModel :: Variables -> [ Text ] -> IO GTK.SingleSelection
|
||||||
newBrushListModel brushNames = do
|
newBrushListModel vars brushNames = do
|
||||||
|
|
||||||
stringList <- GTK.stringListNew ( Just brushNames )
|
stringList <- GTK.stringListNew ( Just brushNames )
|
||||||
|
|
||||||
|
@ -61,6 +80,17 @@ newBrushListModel brushNames = do
|
||||||
GI.withNewObject slPtr $ \ slCopy ->
|
GI.withNewObject slPtr $ \ slCopy ->
|
||||||
GTK.singleSelectionNew ( Just slCopy )
|
GTK.singleSelectionNew ( Just slCopy )
|
||||||
|
|
||||||
|
void $ GI.after selectionModel ( GI.PropertyNotify #selected ) $ \ _ -> do
|
||||||
|
selObj <- GTK.singleSelectionGetSelectedItem selectionModel
|
||||||
|
selBrush <-
|
||||||
|
case selObj of
|
||||||
|
Nothing -> return Nothing
|
||||||
|
Just obj -> do
|
||||||
|
strObj <- GTK.unsafeCastTo GTK.StringObject obj
|
||||||
|
str <- GTK.stringObjectGetString strObj
|
||||||
|
return $ brushFromName str
|
||||||
|
STM.atomically $ STM.writeTVar ( selectedBrushTVar vars ) selBrush
|
||||||
|
|
||||||
return selectionModel
|
return selectionModel
|
||||||
|
|
||||||
------------------
|
------------------
|
||||||
|
@ -70,12 +100,13 @@ newBrushListModel brushNames = do
|
||||||
-- | Create a new 'GTK.ListView' that displays brush names.
|
-- | Create a new 'GTK.ListView' that displays brush names.
|
||||||
newBrushView :: Typeable dnd_data
|
newBrushView :: Typeable dnd_data
|
||||||
=> GTK.ApplicationWindow
|
=> GTK.ApplicationWindow
|
||||||
|
-> Variables
|
||||||
-> ( Maybe Text -> dnd_data )
|
-> ( Maybe Text -> dnd_data )
|
||||||
-- ^ drag and drop data for the brush
|
-- ^ drag and drop data for the brush
|
||||||
-> IO GTK.ListView
|
-> IO GTK.ListView
|
||||||
newBrushView rootWindow mkDND_data = mdo
|
newBrushView rootWindow vars mkDND_data = mdo
|
||||||
|
|
||||||
brushListModel <- newBrushListModel ( "No brush" : HashMap.keys Brushes.brushes )
|
brushListModel <- newBrushListModel vars ( "No brush" : HashMap.keys Brushes.brushes )
|
||||||
|
|
||||||
brushesListFactory <- GTK.signalListItemFactoryNew
|
brushesListFactory <- GTK.signalListItemFactoryNew
|
||||||
|
|
||||||
|
|
|
@ -52,7 +52,7 @@ import qualified Data.Set as Set
|
||||||
|
|
||||||
-- generic-lens
|
-- generic-lens
|
||||||
import Data.Generics.Product.Fields
|
import Data.Generics.Product.Fields
|
||||||
( field' )
|
( field, field' )
|
||||||
|
|
||||||
-- groups
|
-- groups
|
||||||
import Data.Group
|
import Data.Group
|
||||||
|
@ -924,7 +924,9 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
|
||||||
zoom = documentZoom $ documentMetadata
|
zoom = documentZoom $ documentMetadata
|
||||||
|
|
||||||
updateStroke :: Unique -> Stroke -> StrokeMetadata -> State ( Maybe BrushWidgetActionState, Bool ) UpdateStroke
|
updateStroke :: Unique -> Stroke -> StrokeMetadata -> State ( Maybe BrushWidgetActionState, Bool ) UpdateStroke
|
||||||
updateStroke u stroke@( Stroke { strokeBrush, strokeSpline = oldSpline :: StrokeSpline _clo ( Record pointFields ) } ) ( StrokeMetadata { strokeVisible, strokeLocked } )
|
updateStroke u
|
||||||
|
( Stroke { strokeBrush, strokeSpline = oldSpline :: StrokeSpline clo ( Record pointFields ) } )
|
||||||
|
( StrokeMetadata { strokeVisible, strokeLocked } )
|
||||||
| strokeVisible
|
| strokeVisible
|
||||||
, not strokeLocked
|
, not strokeLocked
|
||||||
-- If we have already started a widget action, only continue an action
|
-- If we have already started a widget action, only continue an action
|
||||||
|
@ -932,35 +934,42 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
|
||||||
, case mbPrevAction of { Just act -> brushWidgetStrokeUnique act == u; Nothing -> True }
|
, case mbPrevAction of { Just act -> brushWidgetStrokeUnique act == u; Nothing -> True }
|
||||||
-- Don't touch strokes without brushes.
|
-- Don't touch strokes without brushes.
|
||||||
, Just ( brush@( NamedBrush {} ) :: NamedBrush brushFields ) <- strokeBrush
|
, Just ( brush@( NamedBrush {} ) :: NamedBrush brushFields ) <- strokeBrush
|
||||||
= case intersect @pointFields @brushFields of
|
, Intersection { inject2 = updateBrushParams, project1 = ptParamsToUsedParams }
|
||||||
Intersection { inject1 = injectUsedParams, inject2 = updateBrushParams, project1 = ptParamsToUsedParams, project2 = brushParamsToUsedParams } -> do
|
<- intersect @pointFields @brushFields
|
||||||
let embedUsedParams = updateBrushParams ( MkR $ defaultParams $ brushFunction brush )
|
, Union @pointFields' unionWith
|
||||||
|
<- union @pointFields @brushFields
|
||||||
|
= do let defaultBrushParams = MkR $ defaultParams $ brushFunction brush
|
||||||
|
embedUsedParams = updateBrushParams defaultBrushParams
|
||||||
toBrushParams = embedUsedParams . ptParamsToUsedParams
|
toBrushParams = embedUsedParams . ptParamsToUsedParams
|
||||||
updatePointParams brushParams' ptParams = injectUsedParams ptParams ( brushParamsToUsedParams brushParams' )
|
noUpdatePointParams :: Record pointFields -> Record pointFields'
|
||||||
|
noUpdatePointParams p = unionWith ( \ pt _ -> pt ) p defaultBrushParams
|
||||||
|
updatePointParams :: Record brushFields -> Record pointFields -> Record pointFields'
|
||||||
|
updatePointParams b p = unionWith ( \ _ brushParam' -> brushParam' ) p b
|
||||||
spline' <-
|
spline' <-
|
||||||
bitraverseSpline
|
bitraverseSpline
|
||||||
( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams updatePointParams u )
|
( updateSplineCurve ( splineStart oldSpline ) brush toBrushParams noUpdatePointParams updatePointParams u )
|
||||||
( updateSplinePoint brush toBrushParams updatePointParams u FirstPoint )
|
( updateSplinePoint brush toBrushParams updatePointParams u FirstPoint )
|
||||||
oldSpline
|
oldSpline
|
||||||
( mbAct, _ ) <- State.get
|
( mbAct, _ ) <- State.get
|
||||||
case mbAct of
|
case mbAct of
|
||||||
Nothing -> return PreserveStroke
|
Nothing -> return PreserveStroke
|
||||||
Just {} -> return $ UpdateStrokeTo $ stroke { strokeSpline = spline' }
|
Just {} -> return $ UpdateStrokeTo $ Stroke { strokeBrush, strokeSpline = spline' }
|
||||||
| otherwise
|
| otherwise
|
||||||
= return PreserveStroke
|
= return PreserveStroke
|
||||||
|
|
||||||
updateSplineCurve
|
updateSplineCurve
|
||||||
:: forall clo' pointParams brushFields
|
:: forall clo' pointParams brushFields pointParams'
|
||||||
. ( SplineTypeI clo', Traversable ( NextPoint clo' ) )
|
. ( SplineTypeI clo', Traversable ( NextPoint clo' ) )
|
||||||
=> PointData pointParams
|
=> PointData pointParams
|
||||||
-> NamedBrush brushFields
|
-> NamedBrush brushFields
|
||||||
-> ( pointParams -> Record brushFields )
|
-> ( pointParams -> Record brushFields )
|
||||||
-> ( Record brushFields -> pointParams -> pointParams )
|
-> ( pointParams -> pointParams' )
|
||||||
|
-> ( Record brushFields -> pointParams -> pointParams' )
|
||||||
-> Unique
|
-> Unique
|
||||||
-> PointData pointParams -> Curve clo' ( CurveData RealWorld ) ( PointData pointParams )
|
-> PointData pointParams -> Curve clo' ( CurveData RealWorld ) ( PointData pointParams )
|
||||||
-> State ( Maybe BrushWidgetActionState, Bool )
|
-> State ( Maybe BrushWidgetActionState, Bool )
|
||||||
( Curve clo' ( CurveData RealWorld ) ( PointData pointParams ) )
|
( Curve clo' ( CurveData RealWorld ) ( PointData pointParams' ) )
|
||||||
updateSplineCurve _start brush toBrushParams updatePointParams uniq _sp0 curve = do
|
updateSplineCurve _start brush toBrushParams noUpdatePointParams updatePointParams uniq _sp0 curve = do
|
||||||
( mbAct, prevCurveAct ) <- State.get
|
( mbAct, prevCurveAct ) <- State.get
|
||||||
-- We can only perform a brush widget update if:
|
-- We can only perform a brush widget update if:
|
||||||
-- - we aren't already updating another point,
|
-- - we aren't already updating another point,
|
||||||
|
@ -979,24 +988,24 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
|
||||||
if canAct
|
if canAct
|
||||||
then do
|
then do
|
||||||
case curve of
|
case curve of
|
||||||
line@( LineTo sp1 dat ) -> do
|
LineTo sp1 dat -> do
|
||||||
sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp1
|
sp1' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp1
|
||||||
pure ( line { curveEnd = sp1', curveData = invalidateCache dat } )
|
pure ( LineTo { curveEnd = sp1', curveData = invalidateCache dat } )
|
||||||
bez2@( Bezier2To sp1 sp2 dat ) -> do
|
Bezier2To sp1 sp2 dat -> do
|
||||||
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez2Cp ) ) sp1
|
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez2Cp ) ) sp1
|
||||||
sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp2
|
sp2' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp2
|
||||||
pure ( bez2 { controlPoint = sp1', curveEnd = sp2', curveData = invalidateCache dat } )
|
pure ( Bezier2To { controlPoint = sp1', curveEnd = sp2', curveData = invalidateCache dat } )
|
||||||
bez3@( Bezier3To sp1 sp2 sp3 dat ) -> do
|
Bezier3To sp1 sp2 sp3 dat -> do
|
||||||
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp1 ) ) sp1
|
sp1' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp1 ) ) sp1
|
||||||
sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp2 ) ) sp2
|
sp2' <- updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx ( ControlPoint Bez3Cp2 ) ) sp2
|
||||||
sp3' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp3
|
sp3' <- traverse ( updateSplinePoint brush toBrushParams updatePointParams uniq ( PointIndex crvIx PathPoint ) ) sp3
|
||||||
pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3', curveData = invalidateCache dat } )
|
pure ( Bezier3To { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3', curveData = invalidateCache dat } )
|
||||||
else do
|
else do
|
||||||
State.put ( mbAct, False )
|
State.put ( mbAct, False )
|
||||||
let curve' = if prevCurveAct
|
let curve' = if prevCurveAct
|
||||||
then curve { curveData = invalidateCache $ curveData curve }
|
then curve { curveData = invalidateCache $ curveData curve }
|
||||||
else curve
|
else curve
|
||||||
return curve'
|
return $ bimapCurve id ( \ _ -> fmap noUpdatePointParams ) curve'
|
||||||
where
|
where
|
||||||
crvIx = curveIndex ( curveData curve )
|
crvIx = curveIndex ( curveData curve )
|
||||||
|
|
||||||
|
@ -1011,14 +1020,14 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
|
||||||
inPointClickRange zoom c q
|
inPointClickRange zoom c q
|
||||||
|
|
||||||
updateSplinePoint
|
updateSplinePoint
|
||||||
:: forall pointParams brushFields
|
:: forall pointParams brushFields pointParams'
|
||||||
. NamedBrush brushFields
|
. NamedBrush brushFields
|
||||||
-> ( pointParams -> Record brushFields )
|
-> ( pointParams -> Record brushFields )
|
||||||
-> ( Record brushFields -> pointParams -> pointParams )
|
-> ( Record brushFields -> pointParams -> pointParams' )
|
||||||
-> Unique -> PointIndex
|
-> Unique -> PointIndex
|
||||||
-> PointData pointParams
|
-> PointData pointParams
|
||||||
-> State ( Maybe BrushWidgetActionState, Bool )
|
-> State ( Maybe BrushWidgetActionState, Bool )
|
||||||
( PointData pointParams )
|
( PointData pointParams' )
|
||||||
updateSplinePoint brush toBrushParams updatePointParams uniq j pt = do
|
updateSplinePoint brush toBrushParams updatePointParams uniq j pt = do
|
||||||
let
|
let
|
||||||
currentBrushParams :: Record brushFields
|
currentBrushParams :: Record brushFields
|
||||||
|
@ -1069,4 +1078,4 @@ applyBrushWidgetAction pressingCtrl c mbPrevAction doc@( Document { documentCont
|
||||||
case newBrushWidgetAction of
|
case newBrushWidgetAction of
|
||||||
Just a -> State.put ( Just a, True )
|
Just a -> State.put ( Just a, True )
|
||||||
_ -> State.modify' ( \ ( a, _ ) -> ( a, False ) )
|
_ -> State.modify' ( \ ( a, _ ) -> ( a, False ) )
|
||||||
pure ( set ( field' @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt )
|
pure ( set ( field @"brushParams" ) ( updatePointParams newBrushParams ( brushParams pt ) ) pt )
|
||||||
|
|
|
@ -23,6 +23,8 @@ import GHC.Exts
|
||||||
-- text
|
-- text
|
||||||
import Data.Text
|
import Data.Text
|
||||||
( Text )
|
( Text )
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
( toLower )
|
||||||
|
|
||||||
-- unordered-containers
|
-- unordered-containers
|
||||||
import Data.HashMap.Strict
|
import Data.HashMap.Strict
|
||||||
|
@ -45,7 +47,7 @@ import qualified MetaBrush.Brush.Widget as Brush
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
lookupBrush :: Text -> Maybe SomeBrush
|
lookupBrush :: Text -> Maybe SomeBrush
|
||||||
lookupBrush nm = HashMap.lookup nm brushes
|
lookupBrush nm = HashMap.lookup ( Text.toLower nm ) brushes
|
||||||
|
|
||||||
-- | All brushes supported by this application.
|
-- | All brushes supported by this application.
|
||||||
brushes :: HashMap Text SomeBrush
|
brushes :: HashMap Text SomeBrush
|
||||||
|
@ -57,7 +59,7 @@ brushes = HashMap.fromList
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
type CircleBrushFields = '[ "r" ]
|
type CircleBrushFields = '[ "a" ]
|
||||||
-- | A circular brush with the given radius.
|
-- | A circular brush with the given radius.
|
||||||
circle :: NamedBrush CircleBrushFields
|
circle :: NamedBrush CircleBrushFields
|
||||||
circle =
|
circle =
|
||||||
|
@ -67,7 +69,7 @@ circle =
|
||||||
, brushWidget = Brush.SquareWidget
|
, brushWidget = Brush.SquareWidget
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
deflts = ℝ1 1
|
deflts = ℝ1 10
|
||||||
{-# INLINE circle #-}
|
{-# INLINE circle #-}
|
||||||
|
|
||||||
type EllipseBrushFields = '[ "a", "b", "phi" ]
|
type EllipseBrushFields = '[ "a", "b", "phi" ]
|
||||||
|
@ -81,11 +83,11 @@ ellipse =
|
||||||
, brushWidget = Brush.RotatableRectangleWidget
|
, brushWidget = Brush.RotatableRectangleWidget
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
deflts = ℝ3 1 1 0
|
deflts = ℝ3 10 7 0
|
||||||
{-# INLINE ellipse #-}
|
{-# INLINE ellipse #-}
|
||||||
|
|
||||||
type TearDropBrushFields = '[ "w", "h", "phi" ]
|
type TearDropBrushFields = '[ "a", "b", "phi" ]
|
||||||
-- | A tear-drop shape with the given width, height and angle of rotation.
|
-- | A tear-drop shape with the given half-width, half-height and angle of rotation.
|
||||||
tearDrop :: NamedBrush TearDropBrushFields
|
tearDrop :: NamedBrush TearDropBrushFields
|
||||||
tearDrop =
|
tearDrop =
|
||||||
NamedBrush
|
NamedBrush
|
||||||
|
@ -94,5 +96,5 @@ tearDrop =
|
||||||
, brushWidget = Brush.RotatableRectangleWidget
|
, brushWidget = Brush.RotatableRectangleWidget
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
deflts = ℝ3 1 2.25 0
|
deflts = ℝ3 10 7 0
|
||||||
{-# INLINE tearDrop #-}
|
{-# INLINE tearDrop #-}
|
||||||
|
|
|
@ -84,6 +84,7 @@ data NamedBrush brushFields where
|
||||||
, DiffInterp 2 ℝ ( Length brushFields )
|
, DiffInterp 2 ℝ ( Length brushFields )
|
||||||
, DiffInterp 3 𝕀 ( Length brushFields )
|
, DiffInterp 3 𝕀 ( Length brushFields )
|
||||||
, Show ( ℝ ( Length brushFields ) )
|
, Show ( ℝ ( Length brushFields ) )
|
||||||
|
, NFData ( ℝ ( Length brushFields ) )
|
||||||
)
|
)
|
||||||
=> { brushName :: !Text
|
=> { brushName :: !Text
|
||||||
, brushFunction :: !( BrushFunction brushFields )
|
, brushFunction :: !( BrushFunction brushFields )
|
||||||
|
|
|
@ -17,6 +17,8 @@ import Data.Foldable
|
||||||
( for_ )
|
( for_ )
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
( Generic )
|
( Generic )
|
||||||
|
import GHC.Stack
|
||||||
|
( HasCallStack )
|
||||||
import GHC.TypeLits
|
import GHC.TypeLits
|
||||||
( Symbol )
|
( Symbol )
|
||||||
|
|
||||||
|
@ -58,7 +60,7 @@ import Math.Linear
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import MetaBrush.Brush
|
import MetaBrush.Brush
|
||||||
( NamedBrush(..) )
|
( SomeBrush(..), NamedBrush (..), WithParams (defaultParams) )
|
||||||
import MetaBrush.Document
|
import MetaBrush.Document
|
||||||
import MetaBrush.Hover
|
import MetaBrush.Hover
|
||||||
( inPointClickRange )
|
( inPointClickRange )
|
||||||
|
@ -91,10 +93,11 @@ anchorsAreComplementary
|
||||||
-- drawing a stroke or to start a new one.
|
-- drawing a stroke or to start a new one.
|
||||||
getOrCreateDrawAnchor
|
getOrCreateDrawAnchor
|
||||||
:: UniqueSupply
|
:: UniqueSupply
|
||||||
|
-> Maybe SomeBrush
|
||||||
-> ℝ 2
|
-> ℝ 2
|
||||||
-> Document
|
-> Document
|
||||||
-> STM ( Document, DrawAnchor )
|
-> STM ( Document, DrawAnchor )
|
||||||
getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldContent, documentMetadata } ) =
|
getOrCreateDrawAnchor uniqueSupply mbBrush c doc@( Document { documentContent = oldContent, documentMetadata } ) =
|
||||||
|
|
||||||
-- Deselect all points, and try to find a valid anchor for drawing
|
-- Deselect all points, and try to find a valid anchor for drawing
|
||||||
-- (a path start/end point at mouse click point).
|
-- (a path start/end point at mouse click point).
|
||||||
|
@ -116,16 +119,34 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldConte
|
||||||
Right {} -> do
|
Right {} -> do
|
||||||
newStrokeUnique <- runReaderT freshUnique uniqueSupply
|
newStrokeUnique <- runReaderT freshUnique uniqueSupply
|
||||||
let
|
let
|
||||||
newSpline :: StrokeSpline Open ( Record ( '[] :: [ Symbol ] ) )
|
|
||||||
newSpline =
|
|
||||||
Spline { splineStart = PointData c ( MkR ℝ0 )
|
|
||||||
, splineCurves = OpenCurves Empty
|
|
||||||
}
|
|
||||||
newStroke :: Stroke
|
newStroke :: Stroke
|
||||||
newStroke =
|
newStroke =
|
||||||
|
case mbBrush of
|
||||||
|
Nothing ->
|
||||||
|
let
|
||||||
|
newSpline :: StrokeSpline Open ( Record @Symbol '[] )
|
||||||
|
newSpline =
|
||||||
|
Spline
|
||||||
|
{ splineStart = PointData c ( MkR ℝ0 )
|
||||||
|
, splineCurves = OpenCurves Empty
|
||||||
|
}
|
||||||
|
in
|
||||||
Stroke
|
Stroke
|
||||||
{ strokeSpline = newSpline
|
{ strokeSpline = newSpline
|
||||||
, strokeBrush = Nothing :: Maybe ( NamedBrush ( '[] :: [ Symbol ] ) )
|
, strokeBrush = Nothing
|
||||||
|
}
|
||||||
|
Just ( SomeBrush ( b@( NamedBrush { brushFunction = fn } ) :: NamedBrush brushFields ) ) ->
|
||||||
|
let
|
||||||
|
newSpline :: StrokeSpline Open ( Record brushFields )
|
||||||
|
newSpline =
|
||||||
|
Spline
|
||||||
|
{ splineStart = PointData c ( MkR $ defaultParams fn )
|
||||||
|
, splineCurves = OpenCurves Empty
|
||||||
|
}
|
||||||
|
in
|
||||||
|
Stroke
|
||||||
|
{ strokeSpline = newSpline
|
||||||
|
, strokeBrush = Just b
|
||||||
}
|
}
|
||||||
newSel = StrokePoints $ Map.singleton newStrokeUnique ( Set.singleton FirstPoint )
|
newSel = StrokePoints $ Map.singleton newStrokeUnique ( Set.singleton FirstPoint )
|
||||||
newMeta :: DocumentMetadata
|
newMeta :: DocumentMetadata
|
||||||
|
@ -199,7 +220,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldConte
|
||||||
-> Just anchor
|
-> Just anchor
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
anchorPos :: DrawAnchor -> Document -> ℝ 2
|
anchorPos :: HasCallStack => DrawAnchor -> Document -> ℝ 2
|
||||||
anchorPos ( DrawAnchor { anchorStroke, anchorIsAtEnd } )
|
anchorPos ( DrawAnchor { anchorStroke, anchorIsAtEnd } )
|
||||||
( Document { documentContent = Content { strokeHierarchy = Hierarchy { content = strokes } } } ) =
|
( Document { documentContent = Content { strokeHierarchy = Hierarchy { content = strokes } } } ) =
|
||||||
case Map.lookup anchorStroke strokes of
|
case Map.lookup anchorStroke strokes of
|
||||||
|
|
|
@ -1,4 +1,5 @@
|
||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
|
{-# LANGUAGE ParallelListComp #-}
|
||||||
{-# LANGUAGE PolyKinds #-}
|
{-# LANGUAGE PolyKinds #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
@ -11,7 +12,9 @@ import Data.Functor
|
||||||
import Data.Kind
|
import Data.Kind
|
||||||
( Type, Constraint )
|
( Type, Constraint )
|
||||||
import Data.List
|
import Data.List
|
||||||
( findIndex, intersperse )
|
( findIndex, intersperse, sortBy )
|
||||||
|
import Data.Ord
|
||||||
|
( comparing )
|
||||||
import Data.Typeable
|
import Data.Typeable
|
||||||
( Typeable, eqT )
|
( Typeable, eqT )
|
||||||
import Data.Type.Equality
|
import Data.Type.Equality
|
||||||
|
@ -33,6 +36,9 @@ import Unsafe.Coerce
|
||||||
import Data.Act
|
import Data.Act
|
||||||
( Act(..), Torsor(..) )
|
( Act(..), Torsor(..) )
|
||||||
|
|
||||||
|
-- containers
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
|
||||||
-- deepseq
|
-- deepseq
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
( NFData(..) )
|
( NFData(..) )
|
||||||
|
@ -291,3 +297,144 @@ type family Elem k ks where
|
||||||
Elem _ '[] = False
|
Elem _ '[] = False
|
||||||
Elem k ( k ': _ ) = True
|
Elem k ( k ': _ ) = True
|
||||||
Elem k ( _ ': ks ) = Elem k ks
|
Elem k ( _ ': ks ) = Elem k ks
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Union of two records.
|
||||||
|
|
||||||
|
data Union r1 r2 where
|
||||||
|
Union
|
||||||
|
:: forall r1r2_rocky r1 r2 l12_rocky
|
||||||
|
. ( l12_rocky ~ Length r1r2_rocky
|
||||||
|
, KnownSymbols r1r2_rocky
|
||||||
|
, Representable Double ( ℝ l12_rocky )
|
||||||
|
, Show ( ℝ l12_rocky )
|
||||||
|
, NFData ( ℝ l12_rocky )
|
||||||
|
, DiffInterp 2 ℝ l12_rocky
|
||||||
|
, DiffInterp 3 𝕀 l12_rocky
|
||||||
|
)
|
||||||
|
=> { unionWith :: ( Double -> Double -> Double )
|
||||||
|
-> Record r1 -> Record r2 -> Record r1r2_rocky
|
||||||
|
-- ^ union of two records
|
||||||
|
} -> Union r1 r2
|
||||||
|
|
||||||
|
{-# INLINE union #-}
|
||||||
|
union :: forall r1 r2 l1 l2
|
||||||
|
. ( KnownSymbols r1, KnownSymbols r2
|
||||||
|
, l1 ~ Length r1, l2 ~ Length r2
|
||||||
|
, Representable Double ( ℝ l1 )
|
||||||
|
, Representable Double ( ℝ l2 )
|
||||||
|
, Show ( ℝ l1 )
|
||||||
|
, Show ( ℝ l2 )
|
||||||
|
, NFData ( ℝ l2 )
|
||||||
|
, DiffInterp 2 ℝ l2
|
||||||
|
, DiffInterp 3 𝕀 l2
|
||||||
|
)
|
||||||
|
=> Union r1 r2
|
||||||
|
union
|
||||||
|
-- Shortcut when the two rows are equal.
|
||||||
|
| Just Refl <- eqT @r1 @r2
|
||||||
|
= Union { unionWith = \ f ( MkR l ) ( MkR r ) -> MkR @Symbol @r1 ( tabulate $ \ i -> f ( index l i ) ( index r i ) ) }
|
||||||
|
| otherwise
|
||||||
|
= doUnion @r1 @r2 \ ( _ :: Proxy# r1r2 ) idxs ->
|
||||||
|
let
|
||||||
|
unionWith :: ( Double -> Double -> Double )
|
||||||
|
-> Record r1 -> Record r2 -> Record r1r2
|
||||||
|
unionWith f = \ ( MkR r1 ) ( MkR r2 ) -> MkR $ tabulate $ \ i ->
|
||||||
|
case idxs ! i of
|
||||||
|
InBoth i1 i2 -> f ( index r1 i1 ) ( index r2 i2 )
|
||||||
|
InL i1 -> index r1 i1
|
||||||
|
InR i2 -> index r2 i2
|
||||||
|
in Union { unionWith }
|
||||||
|
|
||||||
|
|
||||||
|
data LR l r
|
||||||
|
= InL !l
|
||||||
|
| InR !r
|
||||||
|
| InBoth !l !r
|
||||||
|
deriving stock ( Eq, Show )
|
||||||
|
|
||||||
|
bimapLR :: ( l1 -> l2 ) -> ( r1 -> r2 ) -> LR l1 r1 -> LR l2 r2
|
||||||
|
bimapLR f g = \case
|
||||||
|
InL l -> InL ( f l )
|
||||||
|
InR r -> InR ( g r )
|
||||||
|
InBoth l r -> InBoth ( f l ) ( g r )
|
||||||
|
|
||||||
|
instance ( Ord l, Ord r ) => Ord ( LR l r ) where
|
||||||
|
compare a b = compare ( getL a, getR a ) ( getL b, getR b )
|
||||||
|
where
|
||||||
|
getL :: LR l r -> Maybe l
|
||||||
|
getL ( InL l ) = Just l
|
||||||
|
getL ( InBoth l _ ) = Just l
|
||||||
|
getL ( InR {} ) = Nothing
|
||||||
|
getR :: LR l r -> Maybe r
|
||||||
|
getR ( InL {} ) = Nothing
|
||||||
|
getR ( InBoth _ r ) = Just r
|
||||||
|
getR ( InR r ) = Just r
|
||||||
|
|
||||||
|
{-# INLINE doUnion #-}
|
||||||
|
doUnion
|
||||||
|
:: forall r1 r2 l1 l2 kont
|
||||||
|
. ( KnownSymbols r1, KnownSymbols r2
|
||||||
|
, l1 ~ Length r1, l2 ~ Length r2
|
||||||
|
)
|
||||||
|
=> ( forall r1r2 l12.
|
||||||
|
( KnownSymbols r1r2, l12 ~ Length r1r2
|
||||||
|
, DiffInterp 2 ℝ l12
|
||||||
|
, DiffInterp 3 𝕀 l12
|
||||||
|
, Representable Double ( ℝ l12 )
|
||||||
|
, Show ( ℝ l12 )
|
||||||
|
, NFData ( ℝ l12 )
|
||||||
|
)
|
||||||
|
=> Proxy# r1r2 -> Vec l12 ( LR ( Fin l1 ) ( Fin l2 ) ) -> kont )
|
||||||
|
-> kont
|
||||||
|
doUnion k =
|
||||||
|
case knownSymbols @r1 `unionLists` knownSymbols @r2 of
|
||||||
|
|
||||||
|
[ ]
|
||||||
|
| ( _ :: Proxy# r1r2 ) <- proxy# @'[ ]
|
||||||
|
, Refl <- ( unsafeCoerce Refl :: r1r2 :~: Intersect r1 r2 )
|
||||||
|
-> k @r1r2 proxy#
|
||||||
|
( Vec [] )
|
||||||
|
|
||||||
|
[ ( f1, i1 ) ]
|
||||||
|
| SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 )
|
||||||
|
, ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1 ]
|
||||||
|
-> k @r1r2 proxy#
|
||||||
|
( Vec $ map ( bimapLR Fin Fin ) [ i1 ] )
|
||||||
|
|
||||||
|
[ ( f1, i1 ), ( f2, i2 ) ]
|
||||||
|
| SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 )
|
||||||
|
, SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 )
|
||||||
|
, ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1, f2 ]
|
||||||
|
-> k @r1r2 proxy#
|
||||||
|
( Vec $ map ( bimapLR Fin Fin ) [ i1, i2 ] )
|
||||||
|
|
||||||
|
[ ( f1, i1 ), ( f2, i2 ), ( f3, i3 ) ]
|
||||||
|
| SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 )
|
||||||
|
, SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 )
|
||||||
|
, SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 )
|
||||||
|
, ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1, f2, f3 ]
|
||||||
|
-> k @r1r2 proxy#
|
||||||
|
( Vec $ map ( bimapLR Fin Fin ) [ i1, i2, i3 ] )
|
||||||
|
|
||||||
|
[ ( f1, i1 ), ( f2, i2 ), ( f3, i3 ), ( f4, i4 ) ]
|
||||||
|
| SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 )
|
||||||
|
, SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 )
|
||||||
|
, SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 )
|
||||||
|
, SomeSymbol @f4 _ <- someSymbolVal ( Text.unpack f4 )
|
||||||
|
, ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1, f2, f3, f4 ]
|
||||||
|
-> k @r1r2 proxy#
|
||||||
|
( Vec $ map ( bimapLR Fin Fin ) [ i1, i2, i3, i4 ] )
|
||||||
|
|
||||||
|
other -> error $ "Union not defined in dimension " ++ show ( length other )
|
||||||
|
|
||||||
|
unionLists :: forall k. Ord k => [ k ] -> [ k ] -> [ ( k, LR Word Word ) ]
|
||||||
|
unionLists l r = sortBy ( comparing snd )
|
||||||
|
$ Map.toList
|
||||||
|
$ Map.unionWith f
|
||||||
|
( Map.fromList [ ( k, InL i ) | k <- l | i <- [ 0 .. ] ] )
|
||||||
|
( Map.fromList [ ( k, InR i ) | k <- r | i <- [ 0 .. ] ] )
|
||||||
|
where
|
||||||
|
f :: LR Word Word -> LR Word Word -> LR Word Word
|
||||||
|
f ( InL i ) ( InR j ) = InBoth i j
|
||||||
|
f _ _ = error "unionList: internal error"
|
||||||
|
|
|
@ -14,8 +14,6 @@ import Data.Foldable
|
||||||
( foldr' )
|
( foldr' )
|
||||||
import Data.Functor.Identity
|
import Data.Functor.Identity
|
||||||
( Identity(..) )
|
( Identity(..) )
|
||||||
import Data.Typeable
|
|
||||||
( Typeable )
|
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
( Generic, Generic1 )
|
( Generic, Generic1 )
|
||||||
import GHC.Stack
|
import GHC.Stack
|
||||||
|
@ -97,7 +95,7 @@ data PointData params
|
||||||
{ pointCoords :: !( ℝ 2 )
|
{ pointCoords :: !( ℝ 2 )
|
||||||
, brushParams :: !params
|
, brushParams :: !params
|
||||||
}
|
}
|
||||||
deriving stock ( Show, Generic )
|
deriving stock ( Show, Generic, Functor, Foldable, Traversable )
|
||||||
deriving anyclass NFData
|
deriving anyclass NFData
|
||||||
|
|
||||||
-- | Data attached to each curve in a spline.
|
-- | Data attached to each curve in a spline.
|
||||||
|
@ -141,14 +139,11 @@ type StrokeSpline clo brushParams =
|
||||||
|
|
||||||
data Stroke where
|
data Stroke where
|
||||||
Stroke
|
Stroke
|
||||||
:: forall clo pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
|
:: forall clo ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
|
||||||
. ( KnownSplineType clo
|
. ( KnownSplineType clo , PointFields pointFields )
|
||||||
, pointParams ~ Record pointFields
|
|
||||||
, PointFields pointFields, Typeable pointFields
|
|
||||||
)
|
|
||||||
=>
|
=>
|
||||||
{ strokeBrush :: !( Maybe ( NamedBrush brushFields ) )
|
{ strokeBrush :: !( Maybe ( NamedBrush brushFields ) )
|
||||||
, strokeSpline :: !( StrokeSpline clo pointParams )
|
, strokeSpline :: !( StrokeSpline clo ( Record pointFields ) )
|
||||||
}
|
}
|
||||||
-> Stroke
|
-> Stroke
|
||||||
deriving stock instance Show Stroke
|
deriving stock instance Show Stroke
|
||||||
|
|
Loading…
Reference in a new issue