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