mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-27 09:24:08 +00:00
add change descriptions for document history
* fix issue with accelerator key press handler overriding the application's key press handler * fix not being able to close tabs when no document is active
This commit is contained in:
sheaf
parent
7e8c2e10d1
commit
dc11c1af15
|
|
@ -24,6 +24,8 @@ import Data.Int
|
|||
( Int32 )
|
||||
import Data.Maybe
|
||||
( catMaybes, listToMaybe )
|
||||
import Data.Traversable
|
||||
( for )
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
|
||||
|
|
@ -43,7 +45,7 @@ import Data.Sequence
|
|||
import qualified Data.Sequence as Seq
|
||||
( fromList )
|
||||
import qualified Data.Set as Set
|
||||
( insert, delete )
|
||||
( delete, insert )
|
||||
|
||||
-- directory
|
||||
import System.Directory
|
||||
|
|
@ -79,7 +81,7 @@ import qualified Control.Concurrent.STM.TVar as STM
|
|||
import Data.Text
|
||||
( Text )
|
||||
import qualified Data.Text as Text
|
||||
( pack )
|
||||
( intercalate, pack )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Bezier.Stroke
|
||||
|
|
@ -107,8 +109,8 @@ import MetaBrush.Document.Selection
|
|||
( SelectionMode(..), selectionMode
|
||||
, selectAt, selectRectangle
|
||||
, dragMoveSelect
|
||||
, translateSelection
|
||||
, deleteSelected
|
||||
, UpdateInfo(..)
|
||||
, translateSelection, deleteSelected
|
||||
)
|
||||
import MetaBrush.Document.Serialise
|
||||
( saveDocument, loadDocument )
|
||||
|
|
@ -337,7 +339,8 @@ instance HandleAction Close where
|
|||
CloseThis unique -> do
|
||||
mbCurrentDoc <- fmap present <$> STM.atomically ( activeDocument vars )
|
||||
mbDoc <- fmap present . Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
|
||||
pure ( ( \ doc currDoc -> ( doc, documentUnique currDoc == unique ) ) <$> mbDoc <*> mbCurrentDoc )
|
||||
for mbDoc \ doc ->
|
||||
pure ( doc, maybe False ( ( == unique ) . documentUnique ) mbCurrentDoc )
|
||||
case mbDoc of
|
||||
Nothing -> pure () -- could show a warning message
|
||||
Just ( Document { displayName, documentUnique, documentContent }, isActiveDoc )
|
||||
|
|
@ -514,12 +517,29 @@ instance HandleAction Delete where
|
|||
Selection
|
||||
-> modifyingCurrentDocument uiElts vars \ doc -> do
|
||||
let
|
||||
newDoc :: Document
|
||||
docChanged :: Bool
|
||||
( newDoc, docChanged ) = deleteSelected mode doc
|
||||
if docChanged
|
||||
then pure $ UpdateDoc ( UpdateDocumentTo $ HistoryChange newDoc )
|
||||
else pure Don'tModifyDoc
|
||||
newDocument :: Document
|
||||
updateInfo :: UpdateInfo
|
||||
( newDocument, updateInfo ) = deleteSelected mode doc
|
||||
case updateInfo of
|
||||
UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
|
||||
| null strokesAffected
|
||||
-> pure Don'tModifyDoc
|
||||
| let
|
||||
ppDel, cpDel, changeText :: Text
|
||||
ppDel
|
||||
| pathPointsAffected == 0
|
||||
= ""
|
||||
| otherwise
|
||||
= Text.pack ( show pathPointsAffected ) <> " path points"
|
||||
cpDel
|
||||
| controlPointsAffected == 0
|
||||
= ""
|
||||
| otherwise
|
||||
= Text.pack ( show controlPointsAffected ) <> " control points"
|
||||
changeText =
|
||||
"Delete " <> Text.intercalate " and" [ ppDel, cpDel ]
|
||||
<> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes"
|
||||
-> pure $ UpdateDoc ( UpdateDocumentTo $ HistoryChange {..} )
|
||||
_ -> pure ()
|
||||
|
||||
-------------------
|
||||
|
|
@ -691,7 +711,8 @@ instance HandleAction MouseClick where
|
|||
case mbPartialPath of
|
||||
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
|
||||
Nothing -> do
|
||||
( newDoc, drawAnchor, anchorPt ) <- getOrCreateDrawAnchor uniqueSupply pos doc
|
||||
( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <-
|
||||
getOrCreateDrawAnchor uniqueSupply pos doc
|
||||
STM.writeTVar partialPathTVar
|
||||
( Just $ PartialPath
|
||||
{ partialStartPos = anchorPt
|
||||
|
|
@ -700,7 +721,14 @@ instance HandleAction MouseClick where
|
|||
, firstPoint = True
|
||||
}
|
||||
)
|
||||
pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc )
|
||||
case mbExistingAnchorName of
|
||||
Nothing ->
|
||||
let
|
||||
changeText :: Text
|
||||
changeText = "Begin new stroke"
|
||||
in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||
Just _ ->
|
||||
pure Don'tModifyDoc
|
||||
-- Path already started: indicate that we are continuing a path.
|
||||
Just pp -> do
|
||||
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
|
||||
|
|
@ -715,12 +743,14 @@ instance HandleAction MouseClick where
|
|||
| null modifs
|
||||
-> do
|
||||
STM.writeTVar mouseHoldTVar Nothing
|
||||
let
|
||||
mbSubdivide :: Maybe Document
|
||||
mbSubdivide = subdivide mode pos doc
|
||||
case mbSubdivide of
|
||||
Nothing -> pure Don'tModifyDoc
|
||||
Just newDoc -> pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc )
|
||||
case subdivide mode pos doc of
|
||||
Nothing ->
|
||||
pure Don'tModifyDoc
|
||||
Just ( newDocument, loc ) -> do
|
||||
let
|
||||
changeText :: Text
|
||||
changeText = "Subdivide " <> loc
|
||||
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange { .. } )
|
||||
|
||||
-- Ignore double click event otherwise.
|
||||
_ -> pure Don'tModifyDoc
|
||||
|
|
@ -779,12 +809,17 @@ instance HandleAction MouseRelease where
|
|||
|
||||
case mbHoldPos of
|
||||
Just ( GuideAction { holdStartPos = holdStartPos@( Point2D hx hy ), guideAction } ) -> do
|
||||
newDoc <- case guideAction of
|
||||
case guideAction of
|
||||
CreateGuide ruler
|
||||
| createGuide
|
||||
-> addGuide uniqueSupply ruler pos doc
|
||||
-> do
|
||||
newDocument <- addGuide uniqueSupply ruler pos doc
|
||||
let
|
||||
changeText :: Text
|
||||
changeText = "Create guide"
|
||||
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||
| otherwise
|
||||
-> pure doc
|
||||
-> pure Don'tModifyDoc
|
||||
where
|
||||
createGuide :: Bool
|
||||
createGuide
|
||||
|
|
@ -794,13 +829,26 @@ instance HandleAction MouseRelease where
|
|||
&& y <= viewportHeight
|
||||
MoveGuide guideUnique
|
||||
| keepGuide
|
||||
-> pure $
|
||||
over
|
||||
( field' @"documentContent" . field' @"guides" . ix guideUnique . field' @"guidePoint" )
|
||||
( ( holdStartPos --> pos :: Vector2D Double ) • )
|
||||
doc
|
||||
-> let
|
||||
newDocument :: Document
|
||||
newDocument =
|
||||
over
|
||||
( field' @"documentContent" . field' @"guides" . ix guideUnique . field' @"guidePoint" )
|
||||
( ( holdStartPos --> pos :: Vector2D Double ) • )
|
||||
doc
|
||||
changeText :: Text
|
||||
changeText = "Move guide"
|
||||
in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||
| otherwise
|
||||
-> pure $ set ( field' @"documentContent" . field' @"guides" . at guideUnique ) Nothing doc
|
||||
-> let
|
||||
newDocument :: Document
|
||||
newDocument =
|
||||
set ( field' @"documentContent" . field' @"guides" . at guideUnique )
|
||||
Nothing
|
||||
doc
|
||||
changeText :: Text
|
||||
changeText = "Delete guide"
|
||||
in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||
where
|
||||
l, t :: Double
|
||||
Point2D l t = toViewport ( Point2D 0 0 )
|
||||
|
|
@ -810,7 +858,6 @@ instance HandleAction MouseRelease where
|
|||
&& ( y >= 0 || hy < t ) -- so we must compare it to the point (l,t) instead of (0,0)
|
||||
&& x <= viewportWidth
|
||||
&& y <= viewportHeight
|
||||
pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc )
|
||||
|
||||
_ -> do
|
||||
tool <- STM.readTVar toolTVar
|
||||
|
|
@ -825,13 +872,33 @@ instance HandleAction MouseRelease where
|
|||
Just hold
|
||||
| DragMoveHold pos0 <- hold
|
||||
, pos0 /= pos
|
||||
, let
|
||||
newDoc :: Document
|
||||
docChanged :: Bool
|
||||
( newDoc, docChanged ) = translateSelection mode ( pos0 --> pos ) doc
|
||||
-> if docChanged
|
||||
then pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ newDoc )
|
||||
else pure Don'tModifyDoc
|
||||
-> do
|
||||
let
|
||||
vec :: Vector2D Double
|
||||
vec = pos0 --> pos
|
||||
newDocument :: Document
|
||||
updateInfo :: UpdateInfo
|
||||
( newDocument, updateInfo ) = translateSelection mode vec doc
|
||||
case updateInfo of
|
||||
UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
|
||||
| null strokesAffected
|
||||
-> pure Don'tModifyDoc
|
||||
| let
|
||||
ppMv, cpMv, changeText :: Text
|
||||
ppMv
|
||||
| pathPointsAffected == 0
|
||||
= ""
|
||||
| otherwise
|
||||
= Text.pack ( show pathPointsAffected ) <> " path points"
|
||||
cpMv
|
||||
| controlPointsAffected == 0
|
||||
= ""
|
||||
| otherwise
|
||||
= Text.pack ( show controlPointsAffected ) <> " control points"
|
||||
changeText =
|
||||
"Translate " <> Text.intercalate " and" [ ppMv, cpMv ]
|
||||
<> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes"
|
||||
-> pure $ UpdateDoc ( UpdateDocumentTo $ HistoryChange {..} )
|
||||
| SelectionHold pos0 <- hold
|
||||
, pos0 /= pos
|
||||
-> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle mode selMode pos0 pos doc )
|
||||
|
|
@ -865,7 +932,7 @@ instance HandleAction MouseRelease where
|
|||
= ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos )
|
||||
| otherwise
|
||||
= ( pos, Nothing, Nothing )
|
||||
( _, otherAnchor, otherAnchorPt ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
|
||||
( _, otherAnchor, otherAnchorPt, _ ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
|
||||
if not firstPoint && anchorsAreComplementary anchor otherAnchor
|
||||
-- Close path.
|
||||
then do
|
||||
|
|
@ -886,7 +953,11 @@ instance HandleAction MouseRelease where
|
|||
pure $ ControlPoint cp ( PointData Normal Empty )
|
||||
, Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) )
|
||||
]
|
||||
pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ addToAnchor anchor newSegment doc )
|
||||
newDocument :: Document
|
||||
newDocument = addToAnchor anchor newSegment doc
|
||||
changeText :: Text
|
||||
changeText = "Close stroke"
|
||||
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||
else
|
||||
if firstPoint
|
||||
-- Continue current partial path.
|
||||
|
|
@ -912,7 +983,11 @@ instance HandleAction MouseRelease where
|
|||
pure $ ControlPoint cp ( PointData Normal Empty )
|
||||
, Just ( PathPoint pathPoint ( PointData Normal Empty ) )
|
||||
]
|
||||
pure ( UpdateDoc . UpdateDocumentTo . HistoryChange $ addToAnchor anchor newSegment doc )
|
||||
newDocument :: Document
|
||||
newDocument = addToAnchor anchor newSegment doc
|
||||
changeText :: Text
|
||||
changeText = "Continue stroke"
|
||||
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
|
||||
|
||||
-- Other mouse buttons: ignored (for the moment at least).
|
||||
_ -> pure ()
|
||||
|
|
@ -1001,7 +1076,10 @@ instance HandleAction KeyboardPress where
|
|||
|
||||
GDK.KEY_Escape -> handleAction uiElts vars Quit
|
||||
|
||||
GDK.KEY_Return -> handleAction uiElts vars Confirm
|
||||
confirm
|
||||
| confirm == GDK.KEY_Return
|
||||
|| confirm == GDK.KEY_space
|
||||
-> handleAction uiElts vars Confirm
|
||||
|
||||
ctrl
|
||||
| ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R
|
||||
|
|
|
|||
|
|
@ -80,37 +80,28 @@ getOrCreateDrawAnchor
|
|||
:: UniqueSupply
|
||||
-> Point2D Double
|
||||
-> Document
|
||||
-> STM ( Document, DrawAnchor, Point2D Double )
|
||||
-> STM ( Document, DrawAnchor, Point2D Double, Maybe Text )
|
||||
getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
|
||||
case ( `runState` Nothing ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc of
|
||||
-- Anchor found: use it.
|
||||
( newDoc, Just ( ( anchor, anchorPt ), anchorName ) ) -> do
|
||||
let
|
||||
newDoc' :: Document
|
||||
newDoc' =
|
||||
set ( field' @"documentContent" . field' @"latestChange" )
|
||||
( "Continue stroke " <> anchorName )
|
||||
newDoc
|
||||
pure ( newDoc', anchor, anchorPt )
|
||||
pure ( newDoc, anchor, anchorPt, Just anchorName )
|
||||
-- No anchor found: start a new stroke (on a new stroke layer).
|
||||
( newDoc, Nothing ) -> do
|
||||
uniq <- freshUnique uniqueSupply
|
||||
let
|
||||
newDoc' :: Document
|
||||
newDoc'
|
||||
= over ( field' @"documentContent" )
|
||||
( over ( field' @"strokes" )
|
||||
( Stroke
|
||||
{ strokeName = "Stroke " <> uniqueText uniq
|
||||
, strokeVisible = True
|
||||
, strokeUnique = uniq
|
||||
, strokePoints = Seq.singleton $ PathPoint c ( PointData Normal Empty )
|
||||
}
|
||||
: )
|
||||
. set ( field' @"latestChange" ) "Begin new stroke"
|
||||
)
|
||||
$ newDoc
|
||||
pure ( newDoc', AnchorAtEnd uniq, c )
|
||||
= over ( field' @"documentContent" . field' @"strokes" )
|
||||
( Stroke
|
||||
{ strokeName = "Stroke " <> uniqueText uniq
|
||||
, strokeVisible = True
|
||||
, strokeUnique = uniq
|
||||
, strokePoints = Seq.singleton $ PathPoint c ( PointData Normal Empty )
|
||||
}
|
||||
: )
|
||||
newDoc
|
||||
pure ( newDoc', AnchorAtEnd uniq, c, Nothing )
|
||||
where
|
||||
-- Deselect all points, and try to find a valid anchor for drawing
|
||||
-- (a path start/end point at mouse click point).
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
|
@ -12,20 +13,22 @@ module MetaBrush.Document.Selection
|
|||
( SelectionMode(..), selectionMode
|
||||
, selectAt, selectRectangle
|
||||
, DragMoveSelect(..), dragMoveSelect
|
||||
, translateSelection
|
||||
, deleteSelected
|
||||
, UpdateInfo(..)
|
||||
, translateSelection, deleteSelected
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Arrow
|
||||
( first )
|
||||
import Control.Category
|
||||
( (>>>) )
|
||||
import Data.Functor
|
||||
( ($>) )
|
||||
import Data.Functor.Identity
|
||||
( runIdentity )
|
||||
import Data.Monoid
|
||||
( Sum(..) )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
|
|
@ -34,6 +37,14 @@ import Data.Act
|
|||
-- containers
|
||||
import Data.Sequence
|
||||
( Seq(..) )
|
||||
import Data.Set
|
||||
( Set )
|
||||
import qualified Data.Set as Set
|
||||
( insert )
|
||||
|
||||
-- generic-data
|
||||
import Generic.Data
|
||||
( Generically(..) )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
|
|
@ -58,7 +69,7 @@ import Control.Monad.Trans.Class
|
|||
( lift )
|
||||
import Control.Monad.Trans.State.Strict
|
||||
( StateT(..)
|
||||
, State, runState, evalState, get, put
|
||||
, State, runState, evalState, get, put, modify'
|
||||
)
|
||||
|
||||
-- MetaBrush
|
||||
|
|
@ -76,6 +87,8 @@ import MetaBrush.Document
|
|||
)
|
||||
import MetaBrush.UI.ToolBar
|
||||
( Mode(..) )
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -273,75 +286,104 @@ selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 )
|
|||
| not isVisible = False
|
||||
| otherwise = x >= xMin && x <= xMax && y >= yMin && y <= yMax
|
||||
|
||||
data UpdateInfo
|
||||
= UpdateInfo
|
||||
{ pathPointsAffected :: !( Sum Int )
|
||||
, controlPointsAffected :: !( Sum Int )
|
||||
, strokesAffected :: !( Set Unique )
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
deriving ( Semigroup, Monoid )
|
||||
via Generically UpdateInfo
|
||||
|
||||
recordPointUpdate :: Unique -> StrokePoint d -> State UpdateInfo ()
|
||||
recordPointUpdate uniq ( PathPoint {} ) = modify'
|
||||
( over ( field' @"pathPointsAffected" ) (<>1)
|
||||
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
|
||||
)
|
||||
recordPointUpdate uniq ( ControlPoint {} ) = modify'
|
||||
( over ( field' @"controlPointsAffected" ) (<>1)
|
||||
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
|
||||
)
|
||||
|
||||
-- | Translate all selected points by the given vector.
|
||||
translateSelection :: Mode -> Vector2D Double -> Document -> ( Document, Bool )
|
||||
--
|
||||
-- Returns the updated doucment, together with info about how many points were translated.
|
||||
translateSelection :: Mode -> Vector2D Double -> Document -> ( Document, UpdateInfo )
|
||||
translateSelection mode t doc =
|
||||
( `runState` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
|
||||
( `runState` mempty ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
|
||||
|
||||
where
|
||||
updateStroke :: Stroke -> State Bool Stroke
|
||||
updateStroke stroke@( Stroke { strokeVisible } )
|
||||
updateStroke :: Stroke -> State UpdateInfo Stroke
|
||||
updateStroke stroke@( Stroke { strokeVisible, strokeUnique } )
|
||||
| not strokeVisible
|
||||
= pure stroke
|
||||
| Brush <- mode
|
||||
= ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" . traverse )
|
||||
updateStrokePoint
|
||||
( updateStrokePoint strokeUnique )
|
||||
stroke
|
||||
| otherwise
|
||||
= ( field' @"strokePoints" . traverse )
|
||||
updateStrokePoint
|
||||
( updateStrokePoint strokeUnique )
|
||||
stroke
|
||||
|
||||
updateStrokePoint :: HasType FocusState pt => StrokePoint pt -> State Bool ( StrokePoint pt )
|
||||
updateStrokePoint pt
|
||||
updateStrokePoint :: HasType FocusState pt => Unique -> StrokePoint pt -> State UpdateInfo ( StrokePoint pt )
|
||||
updateStrokePoint uniq pt
|
||||
| Selected <- view _selection pt
|
||||
= put True
|
||||
= recordPointUpdate uniq pt
|
||||
$> pt { coords = t • coords pt }
|
||||
| otherwise
|
||||
= pure pt
|
||||
|
||||
-- | Delete the selected points.
|
||||
deleteSelected :: Mode -> Document -> ( Document, Bool )
|
||||
deleteSelected mode doc
|
||||
= first fst . runIdentity . ( `runStateT` False ) . ( `Tardis.runTardisT` ( False, False ) )
|
||||
$ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
|
||||
--
|
||||
-- Returns the updated document, together with info about how many points were deleted.
|
||||
deleteSelected :: Mode -> Document -> ( Document, UpdateInfo )
|
||||
deleteSelected mode doc = ( newDoc, updateInfo )
|
||||
where
|
||||
updateStroke :: Stroke -> TardisT Bool Bool ( State Bool ) Stroke
|
||||
updateStroke stroke@( Stroke { strokeVisible } )
|
||||
|
||||
newDoc :: Document
|
||||
updateInfo :: UpdateInfo
|
||||
( ( newDoc, _ ), updateInfo )
|
||||
= runIdentity . ( `runStateT` mempty ) . ( `Tardis.runTardisT` ( False, False ) )
|
||||
$ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
|
||||
|
||||
updateStroke :: Stroke -> TardisT Bool Bool ( State UpdateInfo ) Stroke
|
||||
updateStroke stroke@( Stroke { strokeVisible, strokeUnique } )
|
||||
| not strokeVisible
|
||||
= pure stroke
|
||||
| Brush <- mode
|
||||
= ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" )
|
||||
updateStrokePoints
|
||||
( updateStrokePoints strokeUnique )
|
||||
stroke
|
||||
| otherwise
|
||||
= ( field' @"strokePoints" )
|
||||
updateStrokePoints
|
||||
( updateStrokePoints strokeUnique )
|
||||
stroke
|
||||
|
||||
updateStrokePoints
|
||||
:: forall pt
|
||||
. HasType FocusState pt
|
||||
=> Seq ( StrokePoint pt )
|
||||
-> TardisT Bool Bool ( State Bool ) ( Seq ( StrokePoint pt ) )
|
||||
updateStrokePoints Empty = pure Empty
|
||||
updateStrokePoints ( p :<| ps ) = case p of
|
||||
=> Unique -> Seq ( StrokePoint pt )
|
||||
-> TardisT Bool Bool ( State UpdateInfo ) ( Seq ( StrokePoint pt ) )
|
||||
updateStrokePoints _ Empty = pure Empty
|
||||
updateStrokePoints uniq ( p :<| ps ) = case p of
|
||||
PathPoint {}
|
||||
| Selected <- selectionState
|
||||
-> do
|
||||
Tardis.sendPast True
|
||||
Tardis.sendFuture True
|
||||
lift $ put True
|
||||
updateStrokePoints ps
|
||||
lift ( recordPointUpdate uniq p )
|
||||
updateStrokePoints uniq ps
|
||||
| otherwise
|
||||
-> do
|
||||
Tardis.sendPast False
|
||||
Tardis.sendFuture False
|
||||
( p :<| ) <$> updateStrokePoints ps
|
||||
( p :<| ) <$> updateStrokePoints uniq ps
|
||||
_ -> do
|
||||
prevPathPointDeleted <- Tardis.getPast
|
||||
nextPathPointDeleted <- Tardis.getFuture
|
||||
rest <- updateStrokePoints ps
|
||||
rest <- updateStrokePoints uniq ps
|
||||
let
|
||||
-- Control point must be deleted:
|
||||
-- - if it is selected,
|
||||
|
|
@ -350,9 +392,15 @@ deleteSelected mode doc
|
|||
--
|
||||
-- Need to be lazy in "nextPathPointDeleted" to avoid looping.
|
||||
res :: Seq ( StrokePoint pt )
|
||||
res = if selectionState == Selected || prevPathPointDeleted || nextPathPointDeleted
|
||||
then rest
|
||||
else p :<| rest
|
||||
stateAction :: State UpdateInfo ()
|
||||
( res, stateAction )
|
||||
| selectionState == Selected
|
||||
|| prevPathPointDeleted
|
||||
|| nextPathPointDeleted
|
||||
= ( rest, recordPointUpdate uniq p )
|
||||
| otherwise
|
||||
= ( p :<| rest, pure () )
|
||||
lift stateAction
|
||||
pure res
|
||||
where
|
||||
selectionState :: FocusState
|
||||
|
|
|
|||
|
|
@ -1,7 +1,9 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module MetaBrush.Document.SubdivideStroke
|
||||
|
|
@ -28,6 +30,10 @@ import Data.Generics.Product.Fields
|
|||
import Data.Group
|
||||
( invert )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.Trans.State.Strict
|
||||
( State, runState, put )
|
||||
|
|
@ -51,110 +57,106 @@ import MetaBrush.UI.ToolBar
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Subdivide a path at the given center, provided a path indeed lies there.
|
||||
subdivide :: Mode -> Point2D Double -> Document -> Maybe Document
|
||||
subdivide mode c doc@( Document { zoomFactor } )
|
||||
| subdivOccurred
|
||||
= Just updatedDoc
|
||||
| otherwise
|
||||
= Nothing
|
||||
where
|
||||
subdivide :: Mode -> Point2D Double -> Document -> Maybe ( Document, Text )
|
||||
subdivide mode c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc
|
||||
where
|
||||
updatedDoc :: Document
|
||||
mbSubdivLoc :: Maybe Text
|
||||
( updatedDoc, mbSubdivLoc )
|
||||
= ( `runState` Nothing )
|
||||
$ ( field' @"documentContent" . field' @"strokes" . traverse )
|
||||
updateStroke
|
||||
doc
|
||||
|
||||
updatedDoc :: Document
|
||||
subdivOccurred :: Bool
|
||||
( updatedDoc, subdivOccurred )
|
||||
= ( `runState` False )
|
||||
$ ( field' @"documentContent" . field' @"strokes" . traverse )
|
||||
updateStroke
|
||||
doc
|
||||
updateStroke :: Stroke -> State ( Maybe Text ) Stroke
|
||||
updateStroke stroke@( Stroke { strokeVisible, strokeName } )
|
||||
| Brush <- mode
|
||||
= ( field' @"strokePoints" . traverse )
|
||||
( \ spt ->
|
||||
( field' @"pointData" . field' @"brushShape" )
|
||||
( subdivideStroke strokeVisible ( "brush shape of stroke " <> strokeName ) ( MkVector2D $ coords spt ) )
|
||||
spt
|
||||
)
|
||||
stroke
|
||||
| otherwise
|
||||
= ( field' @"strokePoints" )
|
||||
( subdivideStroke strokeVisible ( "stroke " <> strokeName ) ( Vector2D 0 0 ) )
|
||||
stroke
|
||||
|
||||
updateStroke :: Stroke -> State Bool Stroke
|
||||
updateStroke stroke@( Stroke { strokeVisible } )
|
||||
| Brush <- mode
|
||||
= ( field' @"strokePoints" . traverse )
|
||||
( \ spt ->
|
||||
( field' @"pointData" . field' @"brushShape" )
|
||||
( subdivideStroke strokeVisible ( MkVector2D $ coords spt ) )
|
||||
spt
|
||||
)
|
||||
stroke
|
||||
| otherwise
|
||||
= ( field' @"strokePoints" )
|
||||
( subdivideStroke strokeVisible ( Vector2D 0 0 ) )
|
||||
stroke
|
||||
|
||||
subdivideStroke
|
||||
:: forall pt
|
||||
. Show pt
|
||||
=> Bool
|
||||
-> Vector2D Double
|
||||
-> Seq ( StrokePoint pt )
|
||||
-> State Bool ( Seq ( StrokePoint pt ) )
|
||||
subdivideStroke False _ pts = pure pts
|
||||
subdivideStroke True _ Empty = pure Empty
|
||||
subdivideStroke True offset ( spt :<| spts ) = go spt spts
|
||||
where
|
||||
go :: StrokePoint pt -> Seq ( StrokePoint pt ) -> State Bool ( Seq ( StrokePoint pt ) )
|
||||
go sp0 Empty = pure ( sp0 :<| Empty )
|
||||
-- Line.
|
||||
go sp0 ( sp1 :<| sps )
|
||||
| PathPoint {} <- sp1
|
||||
, let
|
||||
p0, p1, s :: Point2D Double
|
||||
p0 = coords sp0
|
||||
p1 = coords sp1
|
||||
s = closestPointToSegment @( Vector2D Double ) ( invert offset • c ) p0 p1
|
||||
sqDist :: Double
|
||||
sqDist = quadrance @( Vector2D Double ) c ( offset • s )
|
||||
= if sqDist * zoomFactor ^ ( 2 :: Int ) < 16
|
||||
then do
|
||||
put True
|
||||
subdivideStroke
|
||||
:: forall pt
|
||||
. Show pt
|
||||
=> Bool
|
||||
-> Text
|
||||
-> Vector2D Double
|
||||
-> Seq ( StrokePoint pt )
|
||||
-> State ( Maybe Text ) ( Seq ( StrokePoint pt ) )
|
||||
subdivideStroke False _ _ pts = pure pts
|
||||
subdivideStroke True _ _ Empty = pure Empty
|
||||
subdivideStroke True txt offset ( spt :<| spts ) = go spt spts
|
||||
where
|
||||
go :: StrokePoint pt -> Seq ( StrokePoint pt ) -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) )
|
||||
go sp0 Empty = pure ( sp0 :<| Empty )
|
||||
-- Line.
|
||||
go sp0 ( sp1 :<| sps )
|
||||
| PathPoint {} <- sp1
|
||||
, let
|
||||
p0, p1, s :: Point2D Double
|
||||
p0 = coords sp0
|
||||
p1 = coords sp1
|
||||
s = closestPointToSegment @( Vector2D Double ) ( invert offset • c ) p0 p1
|
||||
sqDist :: Double
|
||||
sqDist = quadrance @( Vector2D Double ) c ( offset • s )
|
||||
= if sqDist * zoomFactor ^ ( 2 :: Int ) < 16
|
||||
then do
|
||||
put ( Just txt )
|
||||
-- TODO: interpolate brush instead of using these arbitrary intermediate points
|
||||
pure ( sp0 :<| sp0 { coords = s } :<| sp1 :<| sps )
|
||||
else ( sp0 :<| ) <$> go sp1 sps
|
||||
-- Quadratic Bézier curve.
|
||||
go sp0 ( sp1 :<| sp2 :<| sps )
|
||||
| ControlPoint {} <- sp1
|
||||
, PathPoint {} <- sp2
|
||||
, let
|
||||
p0, p1, p2, s :: Point2D Double
|
||||
p0 = coords sp0
|
||||
p1 = coords sp1
|
||||
p2 = coords sp2
|
||||
bez :: Quadratic.Bezier ( Point2D Double )
|
||||
bez = Quadratic.Bezier {..}
|
||||
sqDist :: Double
|
||||
Min ( Arg sqDist ( t, s ) )
|
||||
= Quadratic.closestPoint @( Vector2D Double ) bez ( invert offset • c )
|
||||
= if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
|
||||
then case Quadratic.subdivide @( Vector2D Double ) bez t of
|
||||
( Quadratic.Bezier _ q1 _, Quadratic.Bezier _ r1 _ ) -> do
|
||||
put ( Just txt )
|
||||
-- TODO: interpolate brush instead of using these arbitrary intermediate points
|
||||
pure ( sp0 :<| sp0 { coords = s } :<| sp1 :<| sps )
|
||||
else ( sp0 :<| ) <$> go sp1 sps
|
||||
-- Quadratic Bézier curve.
|
||||
go sp0 ( sp1 :<| sp2 :<| sps )
|
||||
| ControlPoint {} <- sp1
|
||||
, PathPoint {} <- sp2
|
||||
, let
|
||||
p0, p1, p2, s :: Point2D Double
|
||||
p0 = coords sp0
|
||||
p1 = coords sp1
|
||||
p2 = coords sp2
|
||||
bez :: Quadratic.Bezier ( Point2D Double )
|
||||
bez = Quadratic.Bezier {..}
|
||||
sqDist :: Double
|
||||
Min ( Arg sqDist ( t, s ) )
|
||||
= Quadratic.closestPoint @( Vector2D Double ) bez ( invert offset • c )
|
||||
= if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
|
||||
then case Quadratic.subdivide @( Vector2D Double ) bez t of
|
||||
( Quadratic.Bezier _ q1 _, Quadratic.Bezier _ r1 _ ) -> do
|
||||
put True
|
||||
-- TODO: interpolate brush instead of using these arbitrary intermediate points
|
||||
pure ( sp0 :<| sp1 { coords = q1 } :<| sp2 { coords = s } :<| sp1 { coords = r1 } :<| sp2 :<| sps )
|
||||
else ( ( sp0 :<| ) . ( sp1 :<| ) ) <$> go sp2 sps
|
||||
-- Cubic Bézier curve.
|
||||
go sp0 ( sp1 :<| sp2 :<| sp3 :<| sps )
|
||||
| ControlPoint {} <- sp1
|
||||
, ControlPoint {} <- sp2
|
||||
, PathPoint {} <- sp3
|
||||
, let
|
||||
p0, p1, p2, p3, s :: Point2D Double
|
||||
p0 = coords sp0
|
||||
p1 = coords sp1
|
||||
p2 = coords sp2
|
||||
p3 = coords sp3
|
||||
bez :: Cubic.Bezier ( Point2D Double )
|
||||
bez = Cubic.Bezier {..}
|
||||
Min ( Arg sqDist ( t, s ) )
|
||||
= Cubic.closestPoint @( Vector2D Double ) bez ( invert offset • c )
|
||||
= if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
|
||||
then case Cubic.subdivide @( Vector2D Double ) bez t of
|
||||
( Cubic.Bezier _ q1 q2 _, Cubic.Bezier _ r1 r2 _ ) -> do
|
||||
put True
|
||||
-- TODO: interpolate brush instead of using these arbitrary intermediate points
|
||||
pure
|
||||
( sp0 :<| sp1 { coords = q1 } :<| sp1 { coords = q2 } :<| sp3 { coords = s }
|
||||
:<| sp2 { coords = r1 } :<| sp2 { coords = r2 } :<| sp3 :<| sps
|
||||
)
|
||||
else ( ( sp0 :<| ) . ( sp1 :<| ) . ( sp2 :<| ) ) <$> go sp3 sps
|
||||
go sp0 sps = error ( "subdivideStroke: unrecognised stroke type\n" <> show ( sp0 :<| sps ) )
|
||||
pure ( sp0 :<| sp1 { coords = q1 } :<| sp2 { coords = s } :<| sp1 { coords = r1 } :<| sp2 :<| sps )
|
||||
else ( ( sp0 :<| ) . ( sp1 :<| ) ) <$> go sp2 sps
|
||||
-- Cubic Bézier curve.
|
||||
go sp0 ( sp1 :<| sp2 :<| sp3 :<| sps )
|
||||
| ControlPoint {} <- sp1
|
||||
, ControlPoint {} <- sp2
|
||||
, PathPoint {} <- sp3
|
||||
, let
|
||||
p0, p1, p2, p3, s :: Point2D Double
|
||||
p0 = coords sp0
|
||||
p1 = coords sp1
|
||||
p2 = coords sp2
|
||||
p3 = coords sp3
|
||||
bez :: Cubic.Bezier ( Point2D Double )
|
||||
bez = Cubic.Bezier {..}
|
||||
Min ( Arg sqDist ( t, s ) )
|
||||
= Cubic.closestPoint @( Vector2D Double ) bez ( invert offset • c )
|
||||
= if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
|
||||
then case Cubic.subdivide @( Vector2D Double ) bez t of
|
||||
( Cubic.Bezier _ q1 q2 _, Cubic.Bezier _ r1 r2 _ ) -> do
|
||||
put ( Just txt )
|
||||
-- TODO: interpolate brush instead of using these arbitrary intermediate points
|
||||
pure
|
||||
( sp0 :<| sp1 { coords = q1 } :<| sp1 { coords = q2 } :<| sp3 { coords = s }
|
||||
:<| sp2 { coords = r1 } :<| sp2 { coords = r2 } :<| sp3 :<| sps
|
||||
)
|
||||
else ( ( sp0 :<| ) . ( sp1 :<| ) . ( sp2 :<| ) ) <$> go sp3 sps
|
||||
go sp0 sps = error ( "subdivideStroke: unrecognised stroke type\n" <> show ( sp0 :<| sps ) )
|
||||
|
|
|
|||
|
|
@ -103,7 +103,7 @@ withActiveDocument vars f = traverse f =<< ( fmap present <$> activeDocument var
|
|||
|
||||
data DocChange
|
||||
= TrivialChange { newDocument :: !Document }
|
||||
| HistoryChange { newDocument :: !Document }
|
||||
| HistoryChange { newDocument :: !Document, changeText :: !Text }
|
||||
|
||||
data DocumentUpdate
|
||||
= CloseDocument
|
||||
|
|
@ -168,15 +168,17 @@ modifyingCurrentDocument uiElts@( UIElements { viewport = Viewport {..}, .. } )
|
|||
unique
|
||||
)
|
||||
pure ( pure () )
|
||||
UpdateDocumentTo ( TrivialChange newDoc ) -> do
|
||||
UpdateDocumentTo ( TrivialChange { newDocument } ) -> do
|
||||
STM.modifyTVar' openDocumentsTVar
|
||||
( Map.adjust ( set ( field' @"present" ) newDoc ) unique )
|
||||
( Map.adjust ( set ( field' @"present" ) newDocument ) unique )
|
||||
coerce ( updateUIAction uiElts vars )
|
||||
UpdateDocumentTo ( HistoryChange newDoc ) -> do
|
||||
UpdateDocumentTo ( HistoryChange { newDocument, changeText } ) -> do
|
||||
STM.modifyTVar' openDocumentsTVar
|
||||
( Map.adjust
|
||||
( newFutureStep maxHistSize
|
||||
$ set ( field' @"documentContent" . field' @"unsavedChanges" ) True newDoc
|
||||
. set ( field' @"documentContent" . field' @"unsavedChanges" ) True
|
||||
. set ( field' @"documentContent" . field' @"latestChange" ) changeText
|
||||
$ newDocument
|
||||
)
|
||||
unique
|
||||
)
|
||||
|
|
|
|||
|
|
@ -46,8 +46,8 @@ handleEvents elts@( UIElements { viewport = Viewport {..}, .. } ) vars = do
|
|||
afterWidgetMouseEvent topRulerDrawingArea ( RulerOrigin TopRuler )
|
||||
|
||||
-- Keyboard events
|
||||
void $ GTK.afterWidgetKeyPressEvent window ( handleKeyboardPressEvent elts vars )
|
||||
void $ GTK.afterWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars )
|
||||
void $ GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent elts vars )
|
||||
void $ GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars )
|
||||
|
||||
-- Window quit
|
||||
void $ GTK.onWidgetDestroy window ( quitEverything window )
|
||||
|
|
@ -129,10 +129,10 @@ handleKeyboardPressEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool
|
|||
handleKeyboardPressEvent elts vars evt = do
|
||||
keyCode <- GDK.getEventKeyKeyval evt
|
||||
handleAction elts vars ( KeyboardPress keyCode )
|
||||
pure True
|
||||
pure False -- allow the default handler to run
|
||||
|
||||
handleKeyboardReleaseEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool
|
||||
handleKeyboardReleaseEvent elts vars evt = do
|
||||
keyCode <- GDK.getEventKeyKeyval evt
|
||||
handleAction elts vars ( KeyboardRelease keyCode )
|
||||
pure True
|
||||
pure False -- allow the default handler to run
|
||||
|
|
|
|||
|
|
@ -367,9 +367,9 @@ createMenuBar uiElts@( UIElements { window, titleBar } ) vars colours = do
|
|||
---------------------------------------------------------
|
||||
-- Actions
|
||||
|
||||
_ <- GTK.onButtonClicked closeButton ( quitEverything window )
|
||||
_ <- GTK.onButtonClicked minimiseButton ( GTK.windowIconify window )
|
||||
_ <- GTK.onButtonClicked fullscreenButton do
|
||||
_ <- GTK.onButtonClicked closeButton ( quitEverything window )
|
||||
_ <- GTK.onButtonClicked minimiseButton ( GTK.windowIconify window )
|
||||
_ <- GTK.onButtonClicked fullscreenButton do
|
||||
Just gdkWindow <- GTK.widgetGetWindow window
|
||||
windowState <- GDK.windowGetState gdkWindow
|
||||
if GDK.WindowStateFullscreen `elem` windowState
|
||||
|
|
|
|||
Loading…
Reference in a new issue