mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
anchor position is not static
This commit is contained in:
parent
66490b87aa
commit
a41c6235ae
|
@ -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
|
||||
|
|
|
@ -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 <-
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -117,7 +117,7 @@ data ContentDiff
|
|||
{ closedStroke :: !Unique }
|
||||
| ContinueStroke
|
||||
{ continuedStroke :: !Unique
|
||||
, newSegment :: !( Spline Open () () )
|
||||
, newSegment :: !( Spline Open () ( PointData () ) )
|
||||
}
|
||||
| UpdateBrushParameters
|
||||
{ updateBrushStroke :: !Unique
|
||||
|
|
|
@ -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 )
|
||||
|
|
Loading…
Reference in a new issue