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 2020-09-10 21:50:35 +02:00
parent 7e8c2e10d1
commit dc11c1af15
7 changed files with 332 additions and 211 deletions

View file

@ -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

View file

@ -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).

View file

@ -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

View file

@ -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 ) )

View file

@ -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
)

View file

@ -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

View file

@ -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