From 66490b87aae649e064958c38cdf0d54303764fb1 Mon Sep 17 00:00:00 2001 From: sheaf Date: Sat, 28 Sep 2024 01:32:03 +0200 Subject: [PATCH] fix draw anchor curve indexing --- assets/theme.css | 10 +----- src/app/MetaBrush/Application/Action.hs | 34 +++++++------------ .../MetaBrush/Application/UpdateDocument.hs | 10 ++++-- src/app/MetaBrush/UI/StrokeTreeView.hs-boot | 18 ++++++++++ src/metabrushes/MetaBrush/Brush.hs | 6 +--- .../MetaBrush/Document/Serialise.hs | 3 +- src/metabrushes/MetaBrush/Draw.hs | 22 +++++++++--- 7 files changed, 60 insertions(+), 43 deletions(-) diff --git a/assets/theme.css b/assets/theme.css index 1757f9b..69a6bcc 100644 --- a/assets/theme.css +++ b/assets/theme.css @@ -526,14 +526,7 @@ indent { color: @plain; background-color: @active; border: 0px solid @bg; - transition: - border-color 0.3s ease-out, - border-color 0.2s ease-in, - background-color 0.6s ease-out, - background-color 0.4s ease-in, - box-shadow 0.6s ease-out, - box-shadow 0.4s ease-in; - + transition: all 0.35s ease-in-out; padding-top: 4px; padding-bottom: 4px; border-top: 1px solid @active; @@ -562,7 +555,6 @@ indent { border-top: 2px solid @highlight; margin-top: -2px; box-shadow: - 0 -1px 6px 1px @highlight, inset 0 8px 6px -6px @highlight; } diff --git a/src/app/MetaBrush/Application/Action.hs b/src/app/MetaBrush/Application/Action.hs index 206e041..4e7e220 100644 --- a/src/app/MetaBrush/Application/Action.hs +++ b/src/app/MetaBrush/Application/Action.hs @@ -87,8 +87,6 @@ import qualified Data.Text as Text -- brush-strokes import Math.Bezier.Spline -import Math.Bezier.Stroke - ( invalidateCache ) import Math.Module ( Module((*^)) ) import Math.Linear @@ -222,8 +220,12 @@ openFileWarningDialog openFileWarningDialog window filePath errMess = do dialogWindow <- GTK.windowNew - GTK.setWindowDecorated dialogWindow False - GTK.windowSetTransientFor dialogWindow (Just window) + + -- Show a header, but not a "X" close button. + GTK.setWindowDecorated dialogWindow True + GTK.windowSetDeletable dialogWindow False + GTK.windowSetTitle dialogWindow ( Just "Warning" ) + GTK.windowSetTransientFor dialogWindow ( Just window ) contentBox <- GTK.boxNew GTK.OrientationVertical 30 GTK.widgetSetMarginStart contentBox 20 @@ -238,7 +240,7 @@ openFileWarningDialog window filePath errMess = do GTK.buttonSetLabel closeButton "OK" GTK.boxAppend contentBox closeButton - GTK.windowSetChild dialogWindow (Just contentBox) + GTK.windowSetChild dialogWindow ( Just contentBox ) widgetAddClasses dialogWindow ["metabrush", "bg", "plain", "text", "dialog"] widgetAddClass closeButton "dialogButton" @@ -248,9 +250,6 @@ openFileWarningDialog window filePath errMess = do GTK.widgetSetVisible dialogWindow True - -- TODO: make the dialog draggable. - -- See https://discourse.gnome.org/t/enabling-window-dragging-on-specific-elements-in-gtk-4/5731/4 - ----------------- -- Open folder -- ----------------- @@ -1177,23 +1176,14 @@ instance HandleAction MouseRelease where = ( holdPos, Just $ ( pos --> holdPos :: T ( ℝ 2 ) ) • holdPos, Just pos ) | otherwise = ( pos, Nothing, Nothing ) - i0 - | anchorIsAtEnd anchor - = case anchorIndex anchor of - FirstPoint -> 0 - PointIndex { pointCurve = i } -> i + 1 - | otherwise - = case anchorIndex anchor of - FirstPoint -> -1 - PointIndex { pointCurve = i } -> i - 1 ( _, otherAnchor ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc if not firstPoint && anchorsAreComplementary anchor otherAnchor -- Close path. then do STM.writeTVar partialPathTVar Nothing let - newSegment :: Spline Open CurveData ( PointData () ) - newSegment = catMaybesSpline ( CurveData i0 ( invalidateCache undefined ) ) + newSegment :: Spline Open () ( PointData () ) + newSegment = catMaybesSpline () ( PointData p1 () ) ( do cp <- mbCp2 @@ -1205,7 +1195,7 @@ instance HandleAction MouseRelease where guard ( cp /= anchorPos otherAnchor ) pure ( PointData cp () ) ) - ( PointData ( anchorPos otherAnchor) () ) + ( PointData ( anchorPos otherAnchor ) () ) newDocument :: Document newDocument = addToAnchor anchor newSegment doc diff = HistoryDiff $ ContentDiff @@ -1221,8 +1211,8 @@ instance HandleAction MouseRelease where else do STM.writeTVar partialPathTVar ( Just $ PartialPath ( anchor { anchorPos = pathPoint } ) partialControlPoint False ) let - newSegment :: Spline Open CurveData ( PointData () ) - newSegment = catMaybesSpline ( CurveData i0 ( invalidateCache undefined ) ) + newSegment :: Spline Open () ( PointData () ) + newSegment = catMaybesSpline () ( PointData p1 () ) ( do cp <- mbCp2 diff --git a/src/app/MetaBrush/Application/UpdateDocument.hs b/src/app/MetaBrush/Application/UpdateDocument.hs index 1df9794..aad7bba 100644 --- a/src/app/MetaBrush/Application/UpdateDocument.hs +++ b/src/app/MetaBrush/Application/UpdateDocument.hs @@ -64,7 +64,8 @@ import MetaBrush.Document ) import MetaBrush.Document.Diff import MetaBrush.Document.History - ( DocumentHistory(..), atStart, atEnd + ( DocumentHistory(..), Do(..) + , atStart, atEnd , newFutureStep, affirmPresentSaved ) import MetaBrush.GTK.Util @@ -74,7 +75,7 @@ import {-# SOURCE #-} MetaBrush.UI.FileBar import MetaBrush.UI.InfoBar ( updateInfoBar ) import {-# SOURCE #-} MetaBrush.UI.StrokeTreeView - ( switchStrokeView ) + ( applyDiffToListModel, switchStrokeView ) import MetaBrush.UI.Viewport ( Viewport(..) ) import MetaBrush.Unique @@ -181,6 +182,11 @@ modifyingCurrentDocument uiElts@( UIElements { menuActions } ) vars@( Variables ) uiUpdateAction <- updateUIAction NoActiveDocChange uiElts vars pure $ Ap do + case histDiff of + DocumentDiff {} -> return () + HierarchyDiff hDiff -> + applyDiffToListModel parStoresTVar unique ( Do, hDiff ) + ContentDiff {} -> return () uiUpdateAction for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` True ) for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False ) diff --git a/src/app/MetaBrush/UI/StrokeTreeView.hs-boot b/src/app/MetaBrush/UI/StrokeTreeView.hs-boot index 16c2f22..6aec8c4 100644 --- a/src/app/MetaBrush/UI/StrokeTreeView.hs-boot +++ b/src/app/MetaBrush/UI/StrokeTreeView.hs-boot @@ -1,10 +1,23 @@ module MetaBrush.UI.StrokeTreeView where +-- containers +import Data.Map.Strict + ( Map ) + +-- gi-gio +import qualified GI.Gio as GIO + -- gi-gtk import qualified GI.Gtk as GTK +-- stm +import qualified Control.Concurrent.STM as STM + -- MetaBrush import MetaBrush.Application.Context +import MetaBrush.Document.Diff +import MetaBrush.Document.History +import MetaBrush.Layer import MetaBrush.Unique -------------------------------------------------------------------------------- @@ -14,3 +27,8 @@ newLayersListModel :: Variables -> Unique -> IO GTK.SingleSelection switchStrokeView :: GTK.ListView -> Variables -> Maybe Unique -> IO () newLayerView :: UIElements -> Variables -> IO GTK.ListView + +applyDiffToListModel :: STM.TVar ( Map Unique ( Map ( Parent Unique ) GIO.ListStore ) ) + -> Unique + -> ( Do, HierarchyDiff ) + -> IO () diff --git a/src/metabrushes/MetaBrush/Brush.hs b/src/metabrushes/MetaBrush/Brush.hs index fdea194..88d1bb2 100644 --- a/src/metabrushes/MetaBrush/Brush.hs +++ b/src/metabrushes/MetaBrush/Brush.hs @@ -99,11 +99,7 @@ data SomeBrush where -> SomeBrush instance Show ( NamedBrush brushFields ) where - show ( NamedBrush { brushName } ) = - "NamedBrush\n\ - \ { brushName = " <> Text.unpack brushName <> "\n\ - \ }" - + show ( NamedBrush { brushName } ) = Text.unpack brushName instance NFData ( NamedBrush brushFields ) where rnf ( NamedBrush { brushName } ) = rnf brushName diff --git a/src/metabrushes/MetaBrush/Document/Serialise.hs b/src/metabrushes/MetaBrush/Document/Serialise.hs index 509d26f..67b1049 100644 --- a/src/metabrushes/MetaBrush/Document/Serialise.hs +++ b/src/metabrushes/MetaBrush/Document/Serialise.hs @@ -120,7 +120,8 @@ import MetaBrush.Asset.Brushes import MetaBrush.Brush ( NamedBrush(..), SomeBrush(..), provePointFields, duplicates ) import MetaBrush.Document -import MetaBrush.Layer ( LayerMetadata(..) ) +import MetaBrush.Layer + ( LayerMetadata(..) ) import MetaBrush.Serialisable ( Serialisable(..) , encodeSpline, decodeSpline diff --git a/src/metabrushes/MetaBrush/Draw.hs b/src/metabrushes/MetaBrush/Draw.hs index 7fcd144..665f6c5 100644 --- a/src/metabrushes/MetaBrush/Draw.hs +++ b/src/metabrushes/MetaBrush/Draw.hs @@ -49,10 +49,14 @@ import qualified Control.Monad.Trans.Except as Except import Control.Monad.Trans.Reader ( runReaderT ) --- MetaBrush +-- brush-strokes import Math.Bezier.Spline +import Math.Bezier.Stroke + ( invalidateCache ) import Math.Linear ( ℝ(..) ) + +-- MetaBrush import MetaBrush.Assert ( assert ) import MetaBrush.Brush @@ -208,7 +212,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { documentContent = oldConte -> Just anchor _ -> Nothing -addToAnchor :: DrawAnchor -> StrokeSpline Open () -> Document -> Document +addToAnchor :: DrawAnchor -> Spline Open () ( PointData () ) -> Document -> Document addToAnchor anchor newSpline doc@( Document { documentMetadata, documentContent = oldContent } ) = let strokes' = @@ -233,14 +237,24 @@ addToAnchor anchor newSpline doc@( Document { documentMetadata, documentContent = if anchorIsAtEnd anchor then let + i0 = case splineCurves prevSpline of + OpenCurves ( _ :|> lastCurve ) -> + curveIndex ( curveData lastCurve ) + 1 + _ -> 0 setBrushData :: PointData () -> PointData brushData setBrushData = set ( field @"brushParams" ) ( brushParams ( splineEnd prevSpline ) ) - in prevSpline <> fmap setBrushData newSpline + setData = bimapSpline ( \ _ -> bimapCurve ( \ s -> CurveData i0 ( invalidateCache $ undefined s ) ) ( \ _ -> setBrushData ) ) setBrushData + in prevSpline <> setData newSpline else let + i0 = case splineCurves prevSpline of + OpenCurves ( firstCurve :<| _ ) -> + curveIndex ( curveData firstCurve ) - 1 + _ -> 0 setBrushData :: PointData () -> PointData brushData setBrushData = set ( field @"brushParams" ) ( brushParams ( splineStart prevSpline ) ) - in fmap setBrushData ( reverseSpline newSpline ) <> prevSpline + setData = bimapSpline ( \ _ -> bimapCurve ( \ s -> CurveData i0 ( invalidateCache $ undefined s ) ) ( \ _ -> setBrushData ) ) setBrushData + in setData ( reverseSpline newSpline ) <> prevSpline | otherwise = assert False ( "addToAnchor: trying to add to closed spline " <> show strokeUnique ) prevSpline -- should never add to a closed spline