hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-23 15:34:06 +00:00
Code Issues Actions Projects Releases Wiki Activity

anchor position is not static

Browse source
This commit is contained in:
sheaf 2024-09-28 03:12:23 +02:00
parent 66490b87aa
commit a41c6235ae
6 changed files with 52 additions and 94 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
src/app/MetaBrush/Application/Action.hs
View file

@ -1167,7 +1167,7 @@ instance HandleAction MouseRelease where
) -> do
let
p1 :: ℝ 2
p1 = anchorPos anchor
p1 = anchorPos anchor doc
pathPoint :: ℝ 2
mbControlPoint :: Maybe ( ℝ 2 )
partialControlPoint :: Maybe ( ℝ 2 )
@ -1192,10 +1192,10 @@ instance HandleAction MouseRelease where
)
( do
cp <- mbControlPoint
guard ( cp /= anchorPos otherAnchor )
guard ( cp /= anchorPos otherAnchor doc )
pure ( PointData cp () )
)
( PointData ( anchorPos otherAnchor ) () )
( PointData ( anchorPos otherAnchor doc ) () )
newDocument :: Document
newDocument = addToAnchor anchor newSegment doc
diff = HistoryDiff $ ContentDiff
@ -1209,7 +1209,7 @@ instance HandleAction MouseRelease where
pure Don'tModifyDoc
-- Finish current partial path.
else do
STM.writeTVar partialPathTVar ( Just $ PartialPath ( anchor { anchorPos = pathPoint } ) partialControlPoint False )
STM.writeTVar partialPathTVar ( Just $ PartialPath anchor partialControlPoint False )
let
newSegment :: Spline Open () ( PointData () )
newSegment = catMaybesSpline ()
@ -1230,7 +1230,7 @@ instance HandleAction MouseRelease where
diff = HistoryDiff $ ContentDiff
$ ContinueStroke
{ continuedStroke = anchorStroke anchor
, newSegment = bimapSpline ( \ _ crv -> bimapCurve ( \ _ -> () ) ( \ _ _ -> () ) crv ) ( \ _ -> () ) newSegment
, newSegment
}
pure ( UpdateDoc $ UpdateDocumentTo newDocument diff )
BrushMode -> do

50
src/app/MetaBrush/Render/Document.hs
View file

@ -110,6 +110,8 @@ import MetaBrush.Unique
import MetaBrush.GTK.Util
( withRGBA )
import Debug.Trace
--------------------------------------------------------------------------------
data Renders a
@ -174,14 +176,11 @@ getDocumentRender
, let
alternateMode :: Bool
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
afterDrag :: Maybe ( Document, StrokePoints )
afterDrag = dragUpdate p0 p1 dragAction alternateMode doc
-> case afterDrag of
Just ( docUpdate, _ ) -> getVisibleStrokes docUpdate
Nothing -> getVisibleStrokes doc
, Just ( doc', _ ) <- dragUpdate p0 p1 dragAction alternateMode doc
-> getVisibleStrokes doc'
| Just ( PartialPath anchor cp0 firstPoint ) <- mbPartialPath
, let
p0 = anchorPos anchor
p0 = anchorPos anchor doc
mbFinalPoint :: Maybe ( ℝ 2 )
mbControlPoint :: Maybe ( ℝ 2 )
( mbFinalPoint, mbControlPoint )
@ -193,29 +192,22 @@ getDocumentRender
= ( mbMousePos, Nothing )
, Just finalPoint <- mbFinalPoint
, let
previewStroke :: Stroke
previewStroke = withAnchorBrushData anchor doc \ mbBrush ( pointData :: Record pointFields ) ->
let
previewSpline :: Spline Open CurveData ( PointData ( Record pointFields ) )
previewSpline = catMaybesSpline ( CurveData 987654321 ( invalidateCache undefined ) )
( PointData p0 pointData )
( do
cp <- cp0
guard ( cp /= p0 )
pure ( PointData cp pointData )
)
( do
cp <- mbControlPoint
guard ( cp /= finalPoint )
pure ( PointData cp pointData )
)
( PointData finalPoint pointData )
in
Stroke
{ strokeSpline = previewSpline
, strokeBrush = mbBrush
}
-> ( Nothing, previewStroke ) : getVisibleStrokes doc
previewSpline :: Spline Open () ( PointData () )
previewSpline = catMaybesSpline ()
( PointData p0 () )
( do
cp <- cp0
guard ( cp /= p0 )
pure ( PointData cp () )
)
( do
cp <- mbControlPoint
guard ( cp /= finalPoint )
pure ( PointData cp () )
)
( PointData finalPoint () )
doc' = addToAnchor anchor previewSpline doc
-> getVisibleStrokes doc'
_ -> getVisibleStrokes doc
strokesRenderData <-

5
src/app/MetaBrush/UI/StrokeTreeView.hs
View file

@ -1145,8 +1145,9 @@ applyDiffToListModel parStoreTVar docUnique ( doOrUndo, diff ) = do
item <- GI.new LayerItem []
GI.gobjectSetPrivateData item ( Just $ if delIsGroup then GroupLayer delUnique else StrokeLayer delUnique )
GIO.listStoreInsert srcStore srcIx item
DeletePoints {} ->
error "TODO"
DeletePoints { deletedStrokes } ->
unless ( null deletedStrokes ) $
putStrLn "TODO: delete strokes"
-- | Update the 'StrokeHierarchy' after a drag-and-drop operation,
-- moving one layer or group around.

6
src/metabrushes/MetaBrush/Action.hs
View file

@ -886,12 +886,6 @@ data BrushWidgetActionState
, 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 ( Document, BrushWidgetActionState )

2
src/metabrushes/MetaBrush/Document/Diff.hs
View file

@ -117,7 +117,7 @@ data ContentDiff
{ closedStroke :: !Unique }
| ContinueStroke
{ continuedStroke :: !Unique
, newSegment :: !( Spline Open () () )
, newSegment :: !( Spline Open () ( PointData () ) )
}
| UpdateBrushParameters
{ updateBrushStroke :: !Unique

73
src/metabrushes/MetaBrush/Draw.hs
View file

@ -4,7 +4,7 @@
module MetaBrush.Draw
( DrawAnchor(..), anchorsAreComplementary
, getOrCreateDrawAnchor, addToAnchor
, withAnchorBrushData
, anchorPos
)
where
@ -60,7 +60,7 @@ import Math.Linear
import MetaBrush.Assert
( assert )
import MetaBrush.Brush
( NamedBrush(..), PointFields )
( NamedBrush(..) )
import MetaBrush.Document
import MetaBrush.Hover
( inPointClickRange )
@ -70,6 +70,8 @@ import MetaBrush.Stroke
import MetaBrush.Unique
( Unique, UniqueSupply, freshUnique )
import Debug.Trace
--------------------------------------------------------------------------------
-- | A draw anchor, to continue drawing from one end of an existing stroke.
@ -78,8 +80,6 @@ data DrawAnchor
{ anchorIsNew :: !Bool
, anchorStroke :: !Unique
, anchorIsAtEnd :: !Bool
, anchorPos :: !( ℝ 2 )
, anchorIndex :: !PointIndex
}
deriving stock ( Show, Eq, Generic )
deriving anyclass NFData
@ -87,8 +87,8 @@ data DrawAnchor
-- | Computes whether two anchors are the two ends of the same stroke.
anchorsAreComplementary :: DrawAnchor -> DrawAnchor -> Bool
anchorsAreComplementary
( DrawAnchor { anchorStroke = uniq1, anchorIndex = end1 } )
( DrawAnchor { anchorStroke = uniq2, anchorIndex = end2 } )
( DrawAnchor { anchorStroke = uniq1, anchorIsAtEnd = end1 } )
( DrawAnchor { anchorStroke = uniq2, anchorIsAtEnd = end2 } )
= uniq1 == uniq2 && end1 /= end2
-- | Compute a draw anchor at the given position, e.g. to continue
@ -111,10 +111,9 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldConte
findAnchor
of
-- Anchor found: use it.
Left anchor@( DrawAnchor { anchorStroke, anchorIndex }) ->
let newSel = StrokePoints $ Map.singleton anchorStroke ( Set.singleton anchorIndex )
newMeta :: DocumentMetadata
newMeta = documentMetadata { selectedPoints = newSel }
Left anchor ->
let newMeta :: DocumentMetadata
newMeta = documentMetadata { selectedPoints = mempty }
in pure ( doc { documentMetadata = newMeta }
, anchor )
-- No anchor found: start a new stroke (on a new stroke layer).
@ -156,8 +155,6 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldConte
{ anchorIsNew = True
, anchorStroke = newStrokeUnique
, anchorIsAtEnd = True
, anchorPos = c
, anchorIndex = FirstPoint
}
pure ( newDoc', anchor )
where
@ -190,8 +187,6 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldConte
{ anchorIsNew = False
, anchorStroke = uniq
, anchorIsAtEnd = False
, anchorPos = p0
, anchorIndex = FirstPoint
}
-> Just anchor
| OpenCurves ( _ :|> lastCurve ) <- splineCurves
@ -204,14 +199,23 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldConte
{ anchorIsNew = False
, anchorStroke = uniq
, anchorIsAtEnd = True
, anchorPos = pn
, anchorIndex = PointIndex
( curveIndex $ curveData lastCurve )
PathPoint
}
-> Just anchor
_ -> Nothing
anchorPos :: DrawAnchor -> Document -> ℝ 2
anchorPos ( DrawAnchor { anchorStroke, anchorIsAtEnd } )
( Document { documentContent = Content { strokeHierarchy = Hierarchy { content = strokes } } } ) =
case Map.lookup anchorStroke strokes of
Nothing -> error "draw anchor: stroke not present in hierarchy"
Just ( Stroke { strokeSpline } ) ->
let res =
coords $
if anchorIsAtEnd
then splineEnd ( adjustSplineType @Open strokeSpline )
else splineStart ( adjustSplineType @Open strokeSpline )
in trace ("anchorPos: " ++ show res) res
addToAnchor :: DrawAnchor -> Spline Open () ( PointData () ) -> Document -> Document
addToAnchor anchor newSpline doc@( Document { documentMetadata, documentContent = oldContent } ) =
let
@ -261,36 +265,3 @@ addToAnchor anchor newSpline doc@( Document { documentMetadata, documentContent
= UpdateStrokeTo $ overStrokeSpline updateSpline stroke
| otherwise
= PreserveStroke
withAnchorBrushData
:: forall r
. DrawAnchor
-> Document
-> ( forall pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
. ( pointParams ~ Record pointFields
, PointFields pointFields
)
=> Maybe ( NamedBrush brushFields )
-> pointParams
-> r
)
-> r
withAnchorBrushData anchor ( Document { documentMetadata = Metadata { layerMetadata }, documentContent = Content { strokeHierarchy } } ) f =
splineAnchor $ Except.runExcept $ forStrokeHierarchy layerMetadata strokeHierarchy relevantStroke
where
relevantStroke :: Unique -> Stroke -> StrokeMetadata -> Except Stroke UpdateStroke
relevantStroke strokeUnique stroke _
| strokeUnique == anchorStroke anchor
= Except.throwE stroke
| otherwise
= return PreserveStroke
splineAnchor :: Either Stroke other -> r
splineAnchor ( Left ( Stroke { strokeSpline = strokeSpline :: StrokeSpline clo pointData, strokeBrush } ) )
| SOpen <- ssplineType @clo
= if anchorIsAtEnd anchor
then f strokeBrush ( brushParams ( splineEnd strokeSpline ) )
else f strokeBrush ( brushParams ( splineStart strokeSpline ) )
splineAnchor _
= f @_ @'[] @'[] Nothing ( MkR ℝ0 )