mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
create/move/delete guides: drag from ruler area
This commit is contained in:
sheaf
parent
930fa0ebf9
commit
031d72a69b
|
|
@ -109,6 +109,7 @@ executable MetaBrush
|
|||
, MetaBrush.Context
|
||||
, MetaBrush.Document
|
||||
, MetaBrush.Document.Draw
|
||||
, MetaBrush.Document.Guide
|
||||
, MetaBrush.Document.Selection
|
||||
, MetaBrush.Document.Serialise
|
||||
, MetaBrush.Event
|
||||
|
|
|
|||
87
app/Main.hs
87
app/Main.hs
|
|
@ -13,6 +13,8 @@ module Main
|
|||
-- base
|
||||
import Control.Monad
|
||||
( void )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
import Data.Int
|
||||
( Int32 )
|
||||
import System.Exit
|
||||
|
|
@ -61,6 +63,8 @@ import Math.Bezier.Stroke
|
|||
( StrokePoint(..) )
|
||||
import Math.Vector2D
|
||||
( Point2D(..) )
|
||||
import MetaBrush.Action
|
||||
( ActionOrigin(..) )
|
||||
import MetaBrush.Asset.Brushes
|
||||
( ellipse, rect )
|
||||
import MetaBrush.Asset.Colours
|
||||
|
|
@ -74,26 +78,28 @@ import MetaBrush.Context
|
|||
, withCurrentDocument
|
||||
)
|
||||
import MetaBrush.Document
|
||||
( Document(..), Stroke(..)
|
||||
, FocusState(..)
|
||||
( Document(..), emptyDocument
|
||||
, Stroke(..), FocusState(..)
|
||||
, PointData(..), BrushPointData(..)
|
||||
)
|
||||
import MetaBrush.Event
|
||||
( handleEvents )
|
||||
import MetaBrush.Render.Document
|
||||
( renderDocument, blankRender )
|
||||
( renderDocument, renderGuides, blankRender )
|
||||
import MetaBrush.UI.FileBar
|
||||
( FileBar(..), createFileBar )
|
||||
import MetaBrush.UI.InfoBar
|
||||
( InfoBar(..), createInfoBar )
|
||||
( InfoBar(..), createInfoBar, updateInfoBar )
|
||||
import MetaBrush.UI.Menu
|
||||
( createMenuBar )
|
||||
( createMenuBar
|
||||
--, MenuItem(..), Menu(..), FileMenu(..), EditMenu(..), ViewMenu(..)
|
||||
)
|
||||
import MetaBrush.UI.Panels
|
||||
( createPanelBar )
|
||||
import MetaBrush.UI.ToolBar
|
||||
( Tool(..), Mode(..), createToolBar )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..), createViewport )
|
||||
( Viewport(..), Ruler(..), createViewport )
|
||||
import MetaBrush.Unique
|
||||
( newUniqueSupply
|
||||
, Unique, unsafeUnique
|
||||
|
|
@ -108,14 +114,9 @@ import qualified Paths_MetaBrush as Cabal
|
|||
|
||||
testDocuments :: Map Unique Document
|
||||
testDocuments = uniqueMapFromList
|
||||
[ Document
|
||||
{ displayName = "Closed"
|
||||
, mbFilePath = Nothing
|
||||
, unsavedChanges = False
|
||||
, viewportCenter = Point2D 50 50
|
||||
, zoomFactor = 1
|
||||
, documentUnique = unsafeUnique 0
|
||||
, strokes = [ Stroke
|
||||
[ ( emptyDocument "Closed" ( unsafeUnique 0 ) )
|
||||
{ strokes =
|
||||
[ Stroke
|
||||
{ strokeName = "Ellipse"
|
||||
, strokeVisible = True
|
||||
, strokeUnique = unsafeUnique 10
|
||||
|
|
@ -123,14 +124,9 @@ testDocuments = uniqueMapFromList
|
|||
}
|
||||
]
|
||||
}
|
||||
, Document
|
||||
{ displayName = "Line"
|
||||
, mbFilePath = Nothing
|
||||
, unsavedChanges = False
|
||||
, viewportCenter = Point2D 0 0
|
||||
, zoomFactor = 1
|
||||
, documentUnique = unsafeUnique 1
|
||||
, strokes = [ Stroke
|
||||
, ( emptyDocument "Line" ( unsafeUnique 1 ) )
|
||||
{ strokes =
|
||||
[ Stroke
|
||||
{ strokeName = "Line"
|
||||
, strokeVisible = True
|
||||
, strokeUnique = unsafeUnique 11
|
||||
|
|
@ -138,14 +134,9 @@ testDocuments = uniqueMapFromList
|
|||
}
|
||||
]
|
||||
}
|
||||
, Document
|
||||
{ displayName = "Short line"
|
||||
, mbFilePath = Nothing
|
||||
, unsavedChanges = False
|
||||
, viewportCenter = Point2D 0 0
|
||||
, zoomFactor = 1
|
||||
, documentUnique = unsafeUnique 2
|
||||
, strokes = [ Stroke
|
||||
, ( emptyDocument "Short line" ( unsafeUnique 2 ) )
|
||||
{ strokes =
|
||||
[ Stroke
|
||||
{ strokeName = "ShortLine"
|
||||
, strokeVisible = True
|
||||
, strokeUnique = unsafeUnique 12
|
||||
|
|
@ -292,7 +283,7 @@ main = do
|
|||
---------------------------------------------------------
|
||||
-- Main viewport
|
||||
|
||||
Viewport { viewportDrawingArea } <- createViewport viewportGrid
|
||||
viewport@( Viewport { .. } ) <- createViewport viewportGrid
|
||||
|
||||
-----------------
|
||||
-- Viewport rendering
|
||||
|
|
@ -306,17 +297,42 @@ main = do
|
|||
mbHoldAction <- STM.readTVar mouseHoldTVar
|
||||
mbPartialPath <- STM.readTVar partialPathTVar
|
||||
mode <- STM.readTVar modeTVar
|
||||
pure $
|
||||
pure do
|
||||
renderDocument
|
||||
colours mode ( viewportWidth, viewportHeight )
|
||||
mbMousePos mbHoldAction mbPartialPath
|
||||
doc
|
||||
renderGuides
|
||||
colours ( viewportWidth, viewportHeight ) ViewportOrigin ( viewportWidth, viewportHeight )
|
||||
mbMousePos mbHoldAction
|
||||
doc
|
||||
case mbRender of
|
||||
Just render -> Cairo.renderWithContext render ctx
|
||||
Nothing -> Cairo.renderWithContext ( blankRender colours ) ctx
|
||||
|
||||
pure True
|
||||
|
||||
for_ [ ( rulerCornerDrawingArea, RulerCorner )
|
||||
, ( topRulerDrawingArea, TopRuler )
|
||||
, ( leftRulerDrawingArea, LeftRuler
|
||||
) ] \ ( rulerDrawingArea, ruler ) -> do
|
||||
void $ GTK.onWidgetDraw rulerDrawingArea \ ctx -> do
|
||||
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
width <- GTK.widgetGetAllocatedWidth rulerDrawingArea
|
||||
height <- GTK.widgetGetAllocatedHeight rulerDrawingArea
|
||||
mbRender <- STM.atomically $ withCurrentDocument variables \ doc@( Document {..} ) -> do
|
||||
mbMousePos <- STM.readTVar mousePosTVar
|
||||
mbHoldAction <- STM.readTVar mouseHoldTVar
|
||||
pure do
|
||||
renderGuides
|
||||
colours ( viewportWidth, viewportHeight ) ( RulerOrigin ruler ) ( width, height )
|
||||
mbMousePos mbHoldAction
|
||||
doc
|
||||
for_ mbRender \ render -> Cairo.renderWithContext render ctx
|
||||
|
||||
pure True
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Tool bar
|
||||
|
||||
|
|
@ -334,7 +350,7 @@ main = do
|
|||
createFileBar
|
||||
colours
|
||||
variables
|
||||
window titleBar title viewportDrawingArea infoBar
|
||||
window titleBar title viewport infoBar
|
||||
|
||||
GTK.boxPackStart mainView fileBarBox False False 0
|
||||
GTK.boxPackStart mainView viewportGrid True True 0
|
||||
|
|
@ -347,7 +363,9 @@ main = do
|
|||
------------
|
||||
-- Menu bar
|
||||
|
||||
_ <- createMenuBar uiElements variables colours
|
||||
_menu <- createMenuBar uiElements variables colours
|
||||
|
||||
--GTK.widgetSetSensitive ( menuItem $ close $ menuItemSubmenu $ file menu ) False
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Panels
|
||||
|
|
@ -363,6 +381,7 @@ main = do
|
|||
-- GTK main loop
|
||||
|
||||
GTK.widgetShowAll window
|
||||
updateInfoBar viewportDrawingArea infoBar variables -- need to update the info bar after widgets have been realized
|
||||
GTK.main
|
||||
|
||||
exitSuccess
|
||||
|
|
|
|||
|
|
@ -75,6 +75,9 @@
|
|||
.tabScrollbar {
|
||||
background-color: rgba(48, 45, 38, 0.66);
|
||||
}
|
||||
.guide {
|
||||
color: rgba(28, 196, 79, 0.66)
|
||||
}
|
||||
.magnifier {
|
||||
color: rgb(236, 223, 210);
|
||||
}
|
||||
|
|
@ -419,3 +422,8 @@ tooltip {
|
|||
font-size: 10px;
|
||||
-GtkWidget-window-dragging: true;
|
||||
}
|
||||
|
||||
.infoBarInfo {
|
||||
margin-left: -4px;
|
||||
padding-right: 16px;
|
||||
}
|
||||
|
|
@ -52,12 +52,22 @@ import System.Directory
|
|||
import System.FilePath
|
||||
( (</>), (<.>), takeExtension )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
( field' )
|
||||
|
||||
-- gi-gdk
|
||||
import qualified GI.Gdk as GDK
|
||||
|
||||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( over, set )
|
||||
import Control.Lens.At
|
||||
( ix, at )
|
||||
|
||||
-- stm
|
||||
import qualified Control.Concurrent.STM as STM
|
||||
( atomically )
|
||||
|
|
@ -74,18 +84,20 @@ import Math.Vector2D
|
|||
import MetaBrush.Context
|
||||
( UIElements(..), Variables(..)
|
||||
, Modifier(..), modifierKey
|
||||
, HoldAction(..), PartialPath(..)
|
||||
, HoldAction(..), GuideAction(..), PartialPath(..)
|
||||
, currentDocument, withCurrentDocument
|
||||
, PureDocModification(..), DocModification(..)
|
||||
, modifyingCurrentDocument
|
||||
, updateTitle
|
||||
)
|
||||
import MetaBrush.Document
|
||||
( Document(..)
|
||||
( Document(..), Guide(..)
|
||||
, PointData(..), FocusState(..)
|
||||
)
|
||||
import MetaBrush.Document.Draw
|
||||
( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
|
||||
import MetaBrush.Document.Guide
|
||||
( selectGuide, addGuide )
|
||||
import MetaBrush.Document.Selection
|
||||
( SelectionMode(..), selectionMode
|
||||
, selectAt, selectRectangle
|
||||
|
|
@ -103,6 +115,8 @@ import {-# SOURCE #-} MetaBrush.UI.FileBar
|
|||
( TabLocation(..), newFileTab, removeFileTab )
|
||||
import MetaBrush.UI.ToolBar
|
||||
( Tool(..) )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..), Ruler(..) )
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
import MetaBrush.Util
|
||||
|
|
@ -287,7 +301,10 @@ pattern SaveAndClose = 2
|
|||
pattern CancelClose = 3
|
||||
|
||||
instance HandleAction Close where
|
||||
handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) close = do
|
||||
handleAction
|
||||
uiElts@( UIElements { viewport = Viewport {..}, .. } )
|
||||
vars@( Variables {..} )
|
||||
close = do
|
||||
mbDoc <- case close of
|
||||
CloseActive -> STM.atomically ( currentDocument vars )
|
||||
CloseThis unique -> Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
|
||||
|
|
@ -334,7 +351,10 @@ data SwitchTo = SwitchTo Unique
|
|||
deriving stock Show
|
||||
|
||||
instance HandleAction SwitchTo where
|
||||
handleAction ( UIElements { .. } ) vars@( Variables { .. } ) ( SwitchTo newUnique ) = do
|
||||
handleAction
|
||||
( UIElements { viewport = Viewport {..}, .. } )
|
||||
vars@( Variables {..} )
|
||||
( SwitchTo newUnique ) = do
|
||||
mbNewDocAndTab <- STM.atomically do
|
||||
STM.writeTVar activeDocumentTVar ( Just newUnique )
|
||||
newDoc <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar
|
||||
|
|
@ -469,7 +489,7 @@ data Confirm = Confirm
|
|||
|
||||
instance HandleAction Confirm where
|
||||
handleAction
|
||||
( UIElements { viewportDrawingArea } )
|
||||
( UIElements { viewport = Viewport {..} } )
|
||||
( Variables {..} )
|
||||
_
|
||||
= do
|
||||
|
|
@ -504,8 +524,8 @@ data MouseMove = MouseMove ( Point2D Double )
|
|||
|
||||
instance HandleAction MouseMove where
|
||||
handleAction
|
||||
( UIElements { viewportDrawingArea, infoBar } )
|
||||
vars@( Variables { mousePosTVar, modifiersTVar, toolTVar, partialPathTVar } )
|
||||
( UIElements { viewport = Viewport {..}, .. } )
|
||||
vars@( Variables {..} )
|
||||
( MouseMove ( Point2D x y ) )
|
||||
= do
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
|
|
@ -532,19 +552,26 @@ instance HandleAction MouseMove where
|
|||
|
||||
updateInfoBar viewportDrawingArea infoBar vars
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
|
||||
GTK.widgetQueueDraw drawingArea
|
||||
|
||||
-----------------
|
||||
-- Mouse click --
|
||||
-----------------
|
||||
|
||||
data MouseClick = MouseClick Word32 ( Point2D Double )
|
||||
data ActionOrigin
|
||||
= ViewportOrigin
|
||||
| RulerOrigin Ruler
|
||||
deriving stock Show
|
||||
|
||||
data MouseClick = MouseClick ActionOrigin Word32 ( Point2D Double )
|
||||
deriving stock Show
|
||||
|
||||
instance HandleAction MouseClick where
|
||||
handleAction
|
||||
uiElts@( UIElements { viewportDrawingArea } )
|
||||
uiElts@( UIElements { viewport = Viewport {..} } )
|
||||
vars@( Variables {..} )
|
||||
( MouseClick button mouseClickCoords )
|
||||
( MouseClick actionOrigin button mouseClickCoords )
|
||||
= case button of
|
||||
|
||||
-- Left mouse button.
|
||||
|
|
@ -558,6 +585,9 @@ instance HandleAction MouseClick where
|
|||
pos :: Point2D Double
|
||||
pos = toViewport mouseClickCoords
|
||||
STM.writeTVar mousePosTVar ( Just pos )
|
||||
case actionOrigin of
|
||||
|
||||
ViewportOrigin -> do
|
||||
modifiers <- STM.readTVar modifiersTVar
|
||||
tool <- STM.readTVar toolTVar
|
||||
mode <- STM.readTVar modeTVar
|
||||
|
|
@ -603,6 +633,19 @@ instance HandleAction MouseClick where
|
|||
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
|
||||
pure Don'tModifyDoc
|
||||
|
||||
RulerOrigin ruler -> do
|
||||
let
|
||||
mbGuide :: Maybe Guide
|
||||
mbGuide = selectGuide pos doc
|
||||
guideAction :: GuideAction
|
||||
guideAction
|
||||
| Just guide <- mbGuide
|
||||
= MoveGuide ( guideUnique guide )
|
||||
| otherwise
|
||||
= CreateGuide ruler
|
||||
STM.writeTVar mouseHoldTVar ( Just $ GuideAction { holdStartPos = pos, guideAction } )
|
||||
pure Don'tModifyDoc
|
||||
|
||||
-- Right mouse button: end partial path.
|
||||
3 -> do
|
||||
STM.atomically $ STM.writeTVar partialPathTVar Nothing
|
||||
|
|
@ -621,7 +664,7 @@ data MouseRelease = MouseRelease Word32 ( Point2D Double )
|
|||
|
||||
instance HandleAction MouseRelease where
|
||||
handleAction
|
||||
uiElts@( UIElements { viewportDrawingArea } )
|
||||
uiElts@( UIElements { viewport = Viewport {..} } )
|
||||
vars@( Variables {..} )
|
||||
( MouseRelease button ( Point2D x y ) )
|
||||
= case button of
|
||||
|
|
@ -639,6 +682,43 @@ instance HandleAction MouseRelease where
|
|||
STM.writeTVar mousePosTVar ( Just pos )
|
||||
modifiers <- STM.readTVar modifiersTVar
|
||||
mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
|
||||
|
||||
case mbHoldPos of
|
||||
Just ( GuideAction { holdStartPos = holdStartPos@( Point2D hx hy ), guideAction } ) -> do
|
||||
newDoc <- case guideAction of
|
||||
CreateGuide ruler
|
||||
| createGuide
|
||||
-> addGuide uniqueSupply ruler pos doc
|
||||
| otherwise
|
||||
-> pure doc
|
||||
where
|
||||
createGuide :: Bool
|
||||
createGuide
|
||||
= x >= 0
|
||||
&& y >= 0
|
||||
&& x <= viewportWidth
|
||||
&& y <= viewportHeight
|
||||
MoveGuide guideUnique
|
||||
| keepGuide
|
||||
-> pure $
|
||||
over
|
||||
( field' @"guides" . ix guideUnique . field' @"guidePoint" )
|
||||
( ( holdStartPos --> pos :: Vector2D Double ) • )
|
||||
doc
|
||||
| otherwise
|
||||
-> pure $ set ( field' @"guides" . at guideUnique ) Nothing doc
|
||||
where
|
||||
l, t :: Double
|
||||
Point2D l t = toViewport ( Point2D 0 0 )
|
||||
keepGuide :: Bool
|
||||
keepGuide
|
||||
= ( x >= 0 || hx < l ) -- mouse hold position (hx,hy) is in document coordinates,
|
||||
&& ( y >= 0 || hy < t ) -- so we must compare it to the point (l,t) instead of (0,0)
|
||||
&& x <= viewportWidth
|
||||
&& y <= viewportHeight
|
||||
pure ( UpdateDocTo ( Just newDoc ) )
|
||||
_ -> do
|
||||
|
||||
tool <- STM.readTVar toolTVar
|
||||
mode <- STM.readTVar modeTVar
|
||||
|
||||
|
|
@ -746,7 +826,10 @@ data Scroll = Scroll ( Point2D Double ) ( Vector2D Double )
|
|||
deriving stock Show
|
||||
|
||||
instance HandleAction Scroll where
|
||||
handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do
|
||||
handleAction
|
||||
uiElts@( UIElements { viewport = Viewport {..}, .. } )
|
||||
vars@( Variables {..} )
|
||||
( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do
|
||||
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
|
|
@ -808,7 +891,10 @@ data KeyboardPress = KeyboardPress Word32
|
|||
deriving stock Show
|
||||
|
||||
instance HandleAction KeyboardPress where
|
||||
handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( KeyboardPress keyCode ) = do
|
||||
handleAction
|
||||
uiElts@( UIElements { viewport = Viewport {..}, .. } )
|
||||
vars@( Variables {..} )
|
||||
( KeyboardPress keyCode ) = do
|
||||
|
||||
modifiers <- STM.atomically do
|
||||
!modifiers <- STM.readTVar modifiersTVar
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ data ColourRecord a
|
|||
, path, brush, brushStroke, brushCenter
|
||||
, pointHover, pointSelected
|
||||
, viewport, viewportScrollbar, tabScrollbar
|
||||
, magnifier, glass
|
||||
, guide, magnifier, glass
|
||||
, selected, selectedOutline :: !a
|
||||
}
|
||||
deriving stock ( Show, Functor, Foldable, Traversable )
|
||||
|
|
@ -78,6 +78,7 @@ colourNames = Colours
|
|||
, viewport = ColourName "viewport" BackgroundColour [ GTK.StateFlagsNormal ]
|
||||
, viewportScrollbar = ColourName "viewportScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]
|
||||
, tabScrollbar = ColourName "tabScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]
|
||||
, guide = ColourName "guide" Colour [ GTK.StateFlagsNormal ]
|
||||
, magnifier = ColourName "magnifier" Colour [ GTK.StateFlagsNormal ]
|
||||
, glass = ColourName "glass" Colour [ GTK.StateFlagsNormal ]
|
||||
, selected = ColourName "selected" Colour [ GTK.StateFlagsNormal ]
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@
|
|||
module MetaBrush.Context
|
||||
( UIElements(..), Variables(..)
|
||||
, LR(..), Modifier(..), modifierKey, modifierType
|
||||
, HoldAction(..), PartialPath(..)
|
||||
, HoldAction(..), GuideAction(..), PartialPath(..)
|
||||
, currentDocument, withCurrentDocument
|
||||
, PureDocModification(..), DocModification(..)
|
||||
, modifyingCurrentDocument
|
||||
|
|
@ -76,6 +76,8 @@ import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
|||
( InfoBar, updateInfoBar )
|
||||
import MetaBrush.UI.ToolBar
|
||||
( Tool, Mode )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..), Ruler(..) )
|
||||
import MetaBrush.Unique
|
||||
( UniqueSupply, Unique )
|
||||
import MetaBrush.Util
|
||||
|
|
@ -89,7 +91,7 @@ data UIElements
|
|||
, title :: !GTK.Label
|
||||
, titleBar :: !GTK.Box
|
||||
, fileBar :: !FileBar
|
||||
, viewportDrawingArea :: !GTK.DrawingArea
|
||||
, viewport :: !Viewport
|
||||
, infoBar :: !InfoBar
|
||||
, colours :: !Colours
|
||||
}
|
||||
|
|
@ -133,15 +135,25 @@ modifierType ( Control _ ) = GDK.ModifierTypeControlMask
|
|||
modifierType ( Alt _ ) = GDK.ModifierTypeMod1Mask
|
||||
modifierType ( Shift _ ) = GDK.ModifierTypeShiftMask
|
||||
|
||||
|
||||
data GuideAction
|
||||
= CreateGuide !Ruler
|
||||
| MoveGuide !Unique
|
||||
deriving stock Show
|
||||
|
||||
-- | Keep track of a mouse hold action:
|
||||
--
|
||||
-- - start a rectangular selection,
|
||||
-- - move objects by dragging,
|
||||
-- - drawing a control point.
|
||||
-- - drawing a control point,
|
||||
-- - create/modify a guide.
|
||||
data HoldAction
|
||||
= SelectionHold { holdStartPos :: !( Point2D Double ) }
|
||||
| DragMoveHold { holdStartPos :: !( Point2D Double ) }
|
||||
| DrawHold { holdStartPos :: !( Point2D Double ) }
|
||||
| GuideAction { holdStartPos :: !( Point2D Double )
|
||||
, guideAction :: !GuideAction
|
||||
}
|
||||
deriving stock Show
|
||||
|
||||
-- | Keep track of a path that is in the middle of being drawn.
|
||||
|
|
@ -197,7 +209,7 @@ instance DocumentModification DocModification where
|
|||
--
|
||||
-- Does nothing if no document is currently active.
|
||||
modifyingCurrentDocument :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO ()
|
||||
modifyingCurrentDocument ( UIElements { .. } ) vars@( Variables { .. } ) f = do
|
||||
modifyingCurrentDocument ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) f = do
|
||||
mbAction <- STM.atomically . runMaybeT $ do
|
||||
unique <- MaybeT ( STM.readTVar activeDocumentTVar )
|
||||
oldDoc <- MaybeT ( Map.lookup unique <$> STM.readTVar openDocumentsTVar )
|
||||
|
|
@ -219,6 +231,8 @@ modifyingCurrentDocument ( UIElements { .. } ) vars@( Variables { .. } ) f = do
|
|||
Just ( Document { displayName, unsavedChanges } ) -> do
|
||||
updateTitle window title ( Just ( displayName, unsavedChanges ) )
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
|
||||
GTK.widgetQueueDraw drawingArea
|
||||
for_ mbActiveTab GTK.widgetQueueDraw
|
||||
sequenceAOf_ actionFold modif
|
||||
sequenceA_ mbAction
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@
|
|||
module MetaBrush.Document
|
||||
( AABB(..)
|
||||
, Document(..), emptyDocument
|
||||
, Stroke(..)
|
||||
, Stroke(..), Guide(..)
|
||||
, PointData(..), BrushPointData(..)
|
||||
, FocusState(..)
|
||||
, _selection, _brush
|
||||
|
|
@ -21,6 +21,10 @@ import GHC.Generics
|
|||
( Generic )
|
||||
|
||||
-- containers
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
( empty )
|
||||
import Data.Sequence
|
||||
( Seq )
|
||||
|
||||
|
|
@ -42,7 +46,7 @@ import Data.Text
|
|||
import Math.Bezier.Stroke
|
||||
( StrokePoint(..) )
|
||||
import Math.Vector2D
|
||||
( Point2D(..) )
|
||||
( Point2D(..), Vector2D(..) )
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
|
|
@ -62,6 +66,7 @@ data Document
|
|||
, zoomFactor :: !Double
|
||||
, documentUnique :: Unique
|
||||
, strokes :: ![ Stroke ]
|
||||
, guides :: !( Map Unique Guide )
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
|
||||
|
|
@ -74,6 +79,14 @@ data Stroke
|
|||
}
|
||||
deriving stock ( Show, Generic )
|
||||
|
||||
data Guide
|
||||
= Guide
|
||||
{ guidePoint :: !( Point2D Double ) -- ^ point on the guide line
|
||||
, guideNormal :: !( Vector2D Double ) -- ^ /normalised/ normal vector of the guide
|
||||
, guideUnique :: Unique
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
|
||||
data PointData
|
||||
= PointData
|
||||
{ pointState :: FocusState
|
||||
|
|
@ -108,4 +121,5 @@ emptyDocument docName unique =
|
|||
, zoomFactor = 1
|
||||
, documentUnique = unique
|
||||
, strokes = []
|
||||
, guides = Map.empty
|
||||
}
|
||||
|
|
|
|||
91
src/app/MetaBrush/Document/Guide.hs
Normal file
91
src/app/MetaBrush/Document/Guide.hs
Normal file
|
|
@ -0,0 +1,91 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module MetaBrush.Document.Guide
|
||||
( selectGuide, addGuide )
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Semigroup
|
||||
( Arg(..), Min(..), ArgMin )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Torsor((-->)) )
|
||||
|
||||
-- containers
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
( insert )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
( field' )
|
||||
|
||||
-- stm
|
||||
import Control.Concurrent.STM
|
||||
( STM )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Module
|
||||
( Inner((^.^)), squaredNorm )
|
||||
import Math.Vector2D
|
||||
( Point2D(..), Vector2D(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..), Guide(..)
|
||||
)
|
||||
import MetaBrush.UI.Viewport
|
||||
( Ruler(..) )
|
||||
import MetaBrush.Unique
|
||||
( UniqueSupply, Unique, freshUnique )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Try to select a guide at the given document coordinates.
|
||||
selectGuide :: Point2D Double -> Document -> Maybe Guide
|
||||
selectGuide c ( Document { zoomFactor, guides } ) = \case { Min ( Arg _ g ) -> g } <$> foldMap f guides
|
||||
where
|
||||
f :: Guide -> Maybe ( ArgMin Double Guide )
|
||||
f guide@( Guide { guidePoint = p, guideNormal = n } )
|
||||
| sqDist * zoomFactor ^ ( 2 :: Int ) < 4
|
||||
= Just ( Min ( Arg sqDist guide ) )
|
||||
| otherwise
|
||||
= Nothing
|
||||
where
|
||||
t :: Double
|
||||
t = ( c --> p ) ^.^ n
|
||||
sqDist :: Double
|
||||
sqDist = t ^ ( 2 :: Int ) / squaredNorm n
|
||||
|
||||
-- | Add new guide after a mouse drag from a ruler area.
|
||||
addGuide :: UniqueSupply -> Ruler -> Point2D Double -> Document -> STM Document
|
||||
addGuide uniqueSupply ruler p = ( field' @"guides" ) insertNewGuides
|
||||
where
|
||||
insertNewGuides :: Map Unique Guide -> STM ( Map Unique Guide )
|
||||
insertNewGuides gs = case ruler of
|
||||
RulerCorner
|
||||
-> do
|
||||
uniq1 <- freshUnique uniqueSupply
|
||||
uniq2 <- freshUnique uniqueSupply
|
||||
let
|
||||
guide1, guide2 :: Guide
|
||||
guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideUnique = uniq1 }
|
||||
guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideUnique = uniq2 }
|
||||
pure ( Map.insert uniq2 guide2 . Map.insert uniq1 guide1 $ gs )
|
||||
TopRuler
|
||||
-> do
|
||||
uniq1 <- freshUnique uniqueSupply
|
||||
let
|
||||
guide1 :: Guide
|
||||
guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideUnique = uniq1 }
|
||||
pure ( Map.insert uniq1 guide1 gs )
|
||||
LeftRuler
|
||||
-> do
|
||||
uniq2 <- freshUnique uniqueSupply
|
||||
let
|
||||
guide2 :: Guide
|
||||
guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideUnique = uniq2 }
|
||||
pure ( Map.insert uniq2 guide2 gs )
|
||||
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
|
@ -11,6 +12,8 @@ module MetaBrush.Document.Serialise
|
|||
where
|
||||
|
||||
-- base
|
||||
import Control.Arrow
|
||||
( (&&&) )
|
||||
import Control.Monad
|
||||
( unless )
|
||||
import qualified Data.Bifunctor as Bifunctor
|
||||
|
|
@ -39,6 +42,10 @@ import qualified Data.ByteString.Lazy.Builder as Lazy.ByteString.Builder
|
|||
( toLazyByteString )
|
||||
|
||||
-- containers
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
( fromList, elems )
|
||||
import Data.Sequence
|
||||
( Seq )
|
||||
import qualified Data.Sequence as Seq
|
||||
|
|
@ -52,6 +59,14 @@ import System.Directory
|
|||
import System.FilePath
|
||||
( takeDirectory )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Typed
|
||||
( HasType(typed) )
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( view )
|
||||
|
||||
-- scientific
|
||||
import qualified Data.Scientific as Scientific
|
||||
( fromFloatDigits, toRealFloat )
|
||||
|
|
@ -102,16 +117,17 @@ import qualified Waargonaut.Prettier as TonyMorris
|
|||
import Math.Bezier.Stroke
|
||||
( StrokePoint(..) )
|
||||
import Math.Vector2D
|
||||
( Point2D(..) )
|
||||
( Point2D(..), Vector2D(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..)
|
||||
, Stroke(..)
|
||||
, Guide(..)
|
||||
, PointData(..)
|
||||
, BrushPointData(..)
|
||||
, FocusState(..)
|
||||
)
|
||||
import MetaBrush.Unique
|
||||
( UniqueSupply, freshUnique )
|
||||
( Unique, UniqueSupply, freshUnique )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -176,7 +192,7 @@ decodePoint2D :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Point2D a )
|
|||
decodePoint2D dec = Point2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" dec
|
||||
|
||||
|
||||
{-
|
||||
|
||||
encodeVector2D :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Vector2D a )
|
||||
encodeVector2D enc = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) ->
|
||||
JSON.Encoder.atKey' "x" enc x
|
||||
|
|
@ -186,7 +202,7 @@ decodeVector2D :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Vector2D a )
|
|||
decodeVector2D dec = Vector2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" dec
|
||||
|
||||
|
||||
|
||||
{-
|
||||
encodeMat22 :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Mat22 a )
|
||||
encodeMat22 enc = JSON.Encoder.mapLikeObj \ ( Mat22 m00 m01 m10 m11 ) ->
|
||||
JSON.Encoder.atKey' "m00" enc m00
|
||||
|
|
@ -282,6 +298,14 @@ decodeSequence dec = Seq.fromList <$> JSON.Decoder.list dec
|
|||
|
||||
|
||||
|
||||
encodeUniqueMap :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Map Unique a )
|
||||
encodeUniqueMap enc = contramap Map.elems ( JSON.Encoder.list enc )
|
||||
|
||||
decodeUniqueMap :: ( Monad m, HasType Unique a ) => JSON.Decoder m a -> JSON.Decoder m ( Map Unique a )
|
||||
decodeUniqueMap dec = Map.fromList . map ( view typed &&& id ) <$> JSON.Decoder.list dec
|
||||
|
||||
|
||||
|
||||
encodePointData :: Applicative f => JSON.Encoder f PointData
|
||||
encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointState, brushShape } ) ->
|
||||
JSON.Encoder.atKey' "focus" encodeFocusState pointState
|
||||
|
|
@ -311,12 +335,27 @@ decodeStroke uniqueSupply = do
|
|||
|
||||
|
||||
|
||||
encodeGuide :: Applicative f => JSON.Encoder f Guide
|
||||
encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) ->
|
||||
JSON.Encoder.atKey' "point" ( encodePoint2D encodeDouble ) guidePoint
|
||||
. JSON.Encoder.atKey' "normal" ( encodeVector2D encodeDouble ) guideNormal
|
||||
|
||||
decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m Guide
|
||||
decodeGuide uniqueSupply = do
|
||||
guidePoint <- JSON.Decoder.atKey "point" ( decodePoint2D decodeDouble )
|
||||
guideNormal <- JSON.Decoder.atKey "normal" ( decodeVector2D decodeDouble )
|
||||
guideUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
|
||||
pure ( Guide { guidePoint, guideNormal, guideUnique } )
|
||||
|
||||
|
||||
|
||||
encodeDocument :: Applicative f => JSON.Encoder f Document
|
||||
encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, strokes } ) ->
|
||||
encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, strokes, guides } ) ->
|
||||
JSON.Encoder.atKey' "name" JSON.Encoder.text displayName
|
||||
. JSON.Encoder.atKey' "center" ( encodePoint2D encodeDouble ) viewportCenter
|
||||
. JSON.Encoder.atKey' "zoom" encodeDouble zoomFactor
|
||||
. JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeStroke ) strokes
|
||||
. JSON.Encoder.atKey' "strokes" ( encodeUniqueMap encodeGuide ) guides
|
||||
|
||||
decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document
|
||||
decodeDocument uniqueSupply mbFilePath = do
|
||||
|
|
@ -328,4 +367,5 @@ decodeDocument uniqueSupply mbFilePath = do
|
|||
zoomFactor <- JSON.Decoder.atKey "zoom" decodeDouble
|
||||
documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
|
||||
strokes <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list ( decodeStroke uniqueSupply ) )
|
||||
pure ( Document { displayName, mbFilePath, unsavedChanges, viewportCenter, zoomFactor, documentUnique, strokes } )
|
||||
guides <- JSON.Decoder.atKey "guides" ( decodeUniqueMap ( decodeGuide uniqueSupply ) )
|
||||
pure ( Document { displayName, mbFilePath, unsavedChanges, viewportCenter, zoomFactor, documentUnique, strokes, guides } )
|
||||
|
|
|
|||
|
|
@ -1,9 +1,15 @@
|
|||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module MetaBrush.Event
|
||||
( handleEvents )
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Monad
|
||||
( void )
|
||||
|
||||
-- gi-gdk
|
||||
import qualified GI.Gdk as GDK
|
||||
|
||||
|
|
@ -15,68 +21,96 @@ import Math.Vector2D
|
|||
( Point2D(..), Vector2D(..) )
|
||||
import MetaBrush.Action
|
||||
( HandleAction(..)
|
||||
, ActionOrigin(..)
|
||||
, MouseMove(..), MouseClick(..), MouseRelease(..)
|
||||
, Scroll(..), KeyboardPress(..), KeyboardRelease(..)
|
||||
, quitEverything
|
||||
)
|
||||
import MetaBrush.Context
|
||||
( UIElements(..), Variables(..) )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..), Ruler(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
handleEvents :: UIElements -> Variables -> IO ()
|
||||
handleEvents elts@( UIElements { window, viewportDrawingArea } ) vars = do
|
||||
handleEvents elts@( UIElements { viewport = Viewport {..}, .. } ) vars = do
|
||||
|
||||
-- Mouse events
|
||||
_ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea ( handleMotionEvent elts vars )
|
||||
_ <- GTK.onWidgetScrollEvent viewportDrawingArea ( handleScrollEvent elts vars )
|
||||
_ <- GTK.onWidgetButtonPressEvent viewportDrawingArea ( handleMouseButtonEvent elts vars )
|
||||
_ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea ( handleMouseButtonRelease elts vars )
|
||||
onWidgetMouseEvent viewportDrawingArea ViewportOrigin
|
||||
onWidgetMouseEvent rulerCornerDrawingArea ( RulerOrigin RulerCorner )
|
||||
onWidgetMouseEvent leftRulerDrawingArea ( RulerOrigin LeftRuler )
|
||||
onWidgetMouseEvent topRulerDrawingArea ( RulerOrigin TopRuler )
|
||||
|
||||
-- Keyboard events
|
||||
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent elts vars )
|
||||
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars )
|
||||
void $ GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent elts vars )
|
||||
void $ GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars )
|
||||
|
||||
-- Window quit
|
||||
_ <- GTK.onWidgetDestroy window ( quitEverything window )
|
||||
void $ GTK.onWidgetDestroy window ( quitEverything window )
|
||||
|
||||
pure ()
|
||||
where
|
||||
onWidgetMouseEvent :: GTK.DrawingArea -> ActionOrigin -> IO ()
|
||||
onWidgetMouseEvent drawingArea eventOrigin = do
|
||||
void $ GTK.onWidgetMotionNotifyEvent drawingArea ( handleMotionEvent elts vars eventOrigin )
|
||||
void $ GTK.onWidgetScrollEvent drawingArea ( handleScrollEvent elts vars eventOrigin )
|
||||
void $ GTK.onWidgetButtonPressEvent drawingArea ( handleMouseButtonEvent elts vars eventOrigin )
|
||||
void $ GTK.onWidgetButtonReleaseEvent drawingArea ( handleMouseButtonRelease elts vars eventOrigin )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Mouse events.
|
||||
|
||||
handleMotionEvent :: UIElements -> Variables -> GDK.EventMotion -> IO Bool
|
||||
handleMotionEvent elts vars eventMotion = do
|
||||
handleMotionEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventMotion -> IO Bool
|
||||
handleMotionEvent elts vars eventOrigin eventMotion = do
|
||||
x <- GDK.getEventMotionX eventMotion
|
||||
y <- GDK.getEventMotionY eventMotion
|
||||
handleAction elts vars ( MouseMove ( Point2D x y ) )
|
||||
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
|
||||
handleAction elts vars ( MouseMove mousePos )
|
||||
pure True
|
||||
|
||||
handleScrollEvent :: UIElements -> Variables -> GDK.EventScroll -> IO Bool
|
||||
handleScrollEvent elts vars scrollEvent = do
|
||||
handleScrollEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventScroll -> IO Bool
|
||||
handleScrollEvent elts vars eventOrigin scrollEvent = do
|
||||
dx <- GDK.getEventScrollDeltaX scrollEvent
|
||||
dy <- GDK.getEventScrollDeltaY scrollEvent
|
||||
x <- GDK.getEventScrollX scrollEvent
|
||||
y <- GDK.getEventScrollY scrollEvent
|
||||
handleAction elts vars ( Scroll ( Point2D x y ) ( Vector2D dx dy ) )
|
||||
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
|
||||
handleAction elts vars ( Scroll mousePos ( Vector2D dx dy ) )
|
||||
pure False
|
||||
|
||||
handleMouseButtonEvent :: UIElements -> Variables -> GDK.EventButton -> IO Bool
|
||||
handleMouseButtonEvent elts vars mouseClickEvent = do
|
||||
handleMouseButtonEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool
|
||||
handleMouseButtonEvent elts vars eventOrigin mouseClickEvent = do
|
||||
button <- GDK.getEventButtonButton mouseClickEvent
|
||||
x <- GDK.getEventButtonX mouseClickEvent
|
||||
y <- GDK.getEventButtonY mouseClickEvent
|
||||
handleAction elts vars ( MouseClick button ( Point2D x y ) )
|
||||
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
|
||||
handleAction elts vars ( MouseClick eventOrigin button mousePos )
|
||||
pure False
|
||||
|
||||
handleMouseButtonRelease :: UIElements -> Variables -> GDK.EventButton -> IO Bool
|
||||
handleMouseButtonRelease elts vars mouseReleaseEvent = do
|
||||
handleMouseButtonRelease :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool
|
||||
handleMouseButtonRelease elts vars eventOrigin mouseReleaseEvent = do
|
||||
button <- GDK.getEventButtonButton mouseReleaseEvent
|
||||
x <- GDK.getEventButtonX mouseReleaseEvent
|
||||
y <- GDK.getEventButtonY mouseReleaseEvent
|
||||
handleAction elts vars ( MouseRelease button ( Point2D x y ) )
|
||||
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
|
||||
handleAction elts vars ( MouseRelease button mousePos )
|
||||
pure False
|
||||
|
||||
adjustMousePosition :: Viewport -> ActionOrigin -> Point2D Double -> IO ( Point2D Double )
|
||||
adjustMousePosition _ ViewportOrigin pt = pure pt
|
||||
adjustMousePosition ( Viewport { .. } ) ( RulerOrigin ruler ) ( Point2D x y ) =
|
||||
case ruler of
|
||||
RulerCorner -> do
|
||||
dx <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth rulerCornerDrawingArea
|
||||
dy <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight rulerCornerDrawingArea
|
||||
pure ( Point2D ( x - dx ) ( y - dy ) )
|
||||
LeftRuler -> do
|
||||
dx <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth leftRulerDrawingArea
|
||||
pure ( Point2D ( x - dx ) y )
|
||||
TopRuler -> do
|
||||
dy <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight topRulerDrawingArea
|
||||
pure ( Point2D x ( y - dy ) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Keyboard events.
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
|
|
@ -8,16 +9,17 @@
|
|||
{-# LANGUAGE NegativeLiterals #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module MetaBrush.Render.Document
|
||||
( renderDocument, blankRender )
|
||||
( renderDocument, renderGuides, blankRender )
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Monad
|
||||
( guard, when, unless )
|
||||
import Data.Foldable
|
||||
( for_, sequenceA_ )
|
||||
( for_, sequenceA_, toList )
|
||||
import Data.Functor.Compose
|
||||
( Compose(..) )
|
||||
import Data.Int
|
||||
|
|
@ -36,6 +38,8 @@ import Data.Act
|
|||
)
|
||||
|
||||
-- containers
|
||||
import qualified Data.Map as Map
|
||||
( adjust )
|
||||
import Data.Sequence
|
||||
( Seq(..) )
|
||||
import qualified Data.Sequence as Seq
|
||||
|
|
@ -46,6 +50,8 @@ import Generic.Data
|
|||
( Generically1(..) )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
( field' )
|
||||
import Data.Generics.Product.Typed
|
||||
( HasType )
|
||||
|
||||
|
|
@ -54,7 +60,7 @@ import qualified GI.Cairo.Render as Cairo
|
|||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( view )
|
||||
( view, over )
|
||||
|
||||
-- MetaBrush
|
||||
import qualified Math.Bezier.Cubic as Cubic
|
||||
|
|
@ -65,13 +71,15 @@ import Math.Bezier.Stroke
|
|||
( StrokePoint(..), stroke )
|
||||
import Math.Vector2D
|
||||
( Point2D(..), Vector2D(..) )
|
||||
import MetaBrush.Action
|
||||
( ActionOrigin(..) )
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours, ColourRecord(..) )
|
||||
import MetaBrush.Context
|
||||
( HoldAction(..), PartialPath(..) )
|
||||
( HoldAction(..), GuideAction(..), PartialPath(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..)
|
||||
, Stroke(..), FocusState(..)
|
||||
, Stroke(..), Guide(..), FocusState(..)
|
||||
, PointData(..), BrushPointData(..)
|
||||
, _selection
|
||||
)
|
||||
|
|
@ -79,6 +87,8 @@ import MetaBrush.Document.Selection
|
|||
( translateSelection )
|
||||
import MetaBrush.UI.ToolBar
|
||||
( Mode(..) )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Ruler(..) )
|
||||
import MetaBrush.Util
|
||||
( withRGBA )
|
||||
|
||||
|
|
@ -176,6 +186,73 @@ renderDocument
|
|||
|
||||
pure ()
|
||||
|
||||
renderGuides
|
||||
:: Colours -> ( Int32, Int32 ) -> ActionOrigin -> ( Int32, Int32 )
|
||||
-> Maybe ( Point2D Double ) -> Maybe HoldAction
|
||||
-> Document
|
||||
-> Cairo.Render ()
|
||||
renderGuides
|
||||
cols ( viewportWidth, viewportHeight ) actionOrigin ( width, height )
|
||||
mbMousePos mbHoldEvent
|
||||
( Document { viewportCenter = Point2D cx cy, zoomFactor, guides } ) = do
|
||||
|
||||
let
|
||||
modifiedGuides :: [ Guide ]
|
||||
modifiedGuides
|
||||
| Just ( GuideAction { holdStartPos = mousePos0, guideAction = act } ) <- mbHoldEvent
|
||||
, Just mousePos <- mbMousePos
|
||||
= case act of
|
||||
MoveGuide guideUnique
|
||||
->
|
||||
let
|
||||
translate :: Point2D Double -> Point2D Double
|
||||
translate = ( ( mousePos0 --> mousePos :: Vector2D Double ) • )
|
||||
in toList ( Map.adjust ( over ( field' @"guidePoint" ) translate ) guideUnique guides )
|
||||
CreateGuide ruler
|
||||
-> let
|
||||
addNewGuides :: [ Guide ] -> [ Guide ]
|
||||
addNewGuides gs = case ruler of
|
||||
RulerCorner
|
||||
-> Guide { guidePoint = mousePos, guideNormal = Vector2D 0 1, guideUnique = undefined }
|
||||
: Guide { guidePoint = mousePos, guideNormal = Vector2D 1 0, guideUnique = undefined }
|
||||
: gs
|
||||
LeftRuler
|
||||
-> Guide { guidePoint = mousePos, guideNormal = Vector2D 1 0, guideUnique = undefined }
|
||||
: gs
|
||||
TopRuler
|
||||
-> Guide { guidePoint = mousePos, guideNormal = Vector2D 0 1, guideUnique = undefined }
|
||||
: gs
|
||||
in addNewGuides ( toList guides )
|
||||
| otherwise
|
||||
= toList guides
|
||||
|
||||
Cairo.save
|
||||
Cairo.translate ( 0.5 * fromIntegral viewportWidth ) ( 0.5 * fromIntegral viewportHeight )
|
||||
additionalAdjustment
|
||||
Cairo.scale zoomFactor zoomFactor
|
||||
Cairo.translate ( -cx ) ( -cy )
|
||||
|
||||
for_ modifiedGuides ( renderGuide cols zoomFactor )
|
||||
|
||||
Cairo.restore
|
||||
|
||||
pure ()
|
||||
|
||||
where
|
||||
dx, dy :: Double
|
||||
dx = fromIntegral width
|
||||
dy = fromIntegral height
|
||||
additionalAdjustment :: Cairo.Render ()
|
||||
additionalAdjustment = case actionOrigin of
|
||||
ViewportOrigin -> pure ()
|
||||
RulerOrigin ruler -> case ruler of
|
||||
RulerCorner -> do
|
||||
Cairo.translate dx dy
|
||||
LeftRuler -> do
|
||||
Cairo.translate dx 0
|
||||
TopRuler -> do
|
||||
Cairo.translate 0 dy
|
||||
|
||||
renderStroke :: Colours -> Mode -> Double -> Stroke -> Compose Renders Cairo.Render ()
|
||||
renderStroke cols@( Colours { brush } ) mode zoom ( Stroke { strokePoints = pts, strokeVisible } )
|
||||
| strokeVisible
|
||||
|
|
@ -276,6 +353,22 @@ renderBrushShape cols zoom pt =
|
|||
*> Compose blank { renderPPts = drawCross cols zoom }
|
||||
*> toAll Cairo.restore
|
||||
|
||||
renderGuide :: Colours -> Double -> Guide -> Cairo.Render ()
|
||||
renderGuide ( Colours {..} ) zoom ( Guide { guidePoint = Point2D x y , guideNormal = Vector2D nx ny } ) = do
|
||||
|
||||
Cairo.save
|
||||
Cairo.translate x y
|
||||
Cairo.scale ( 1 / zoom ) ( 1 / zoom )
|
||||
|
||||
Cairo.setLineWidth 2.0
|
||||
withRGBA guide Cairo.setSourceRGBA
|
||||
|
||||
Cairo.moveTo ( 1e5 * ny ) ( -1e5 * nx )
|
||||
Cairo.lineTo ( -1e5 * ny ) ( 1e5 * nx )
|
||||
Cairo.stroke
|
||||
|
||||
Cairo.restore
|
||||
|
||||
drawPoint :: HasType FocusState d => Colours -> Double -> StrokePoint d -> Cairo.Render ()
|
||||
drawPoint ( Colours {..} ) zoom pt@( PathPoint { coords = Point2D x y } )
|
||||
= do
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ import qualified Math.Bezier.Quadratic as Quadratic
|
|||
import Math.Bezier.Stroke
|
||||
( StrokePoint(..) )
|
||||
import Math.Module
|
||||
( (*^), squaredNorm, closestPointToLine )
|
||||
( (*^), squaredNorm, closestPointToSegment )
|
||||
import Math.Vector2D
|
||||
( Point2D(..), Vector2D(..) )
|
||||
import MetaBrush.Document
|
||||
|
|
@ -55,7 +55,7 @@ closestPoint c ( Stroke { strokePoints = pt0 :<| pts, strokeVisible = True } ) =
|
|||
-- Line.
|
||||
go ( PathPoint { coords = p0 } )
|
||||
( sp1@( PathPoint { coords = p1 } ) :<| ps )
|
||||
= res ( closestPointToLine @( Vector2D Double ) c p0 p1 )
|
||||
= res ( closestPointToSegment @( Vector2D Double ) c p0 p1 )
|
||||
<> go sp1 ps
|
||||
-- Quadratic Bézier curve.
|
||||
go ( PathPoint { coords = p0 } )
|
||||
|
|
|
|||
|
|
@ -49,7 +49,9 @@ import MetaBrush.Context
|
|||
import MetaBrush.Document
|
||||
( Document(..), emptyDocument )
|
||||
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
||||
( InfoBar )
|
||||
( InfoBar, updateInfoBar )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..) )
|
||||
import MetaBrush.Unique
|
||||
( Unique, freshUnique, uniqueText )
|
||||
import MetaBrush.Util
|
||||
|
|
@ -78,7 +80,7 @@ newFileTab
|
|||
-> TabLocation
|
||||
-> IO ()
|
||||
newFileTab
|
||||
uiElts@( UIElements { fileBar = FileBar {..}, .. } )
|
||||
uiElts@( UIElements { fileBar = FileBar {..}, viewport = Viewport {..}, .. } )
|
||||
vars@( Variables {..} )
|
||||
mbDoc
|
||||
newTabLoc
|
||||
|
|
@ -157,6 +159,7 @@ newFileTab
|
|||
STM.writeTVar activeDocumentTVar ( Just newUnique )
|
||||
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
updateInfoBar viewportDrawingArea infoBar vars
|
||||
|
||||
void $ GTK.onButtonClicked pgButton do
|
||||
isActive <- GTK.toggleButtonGetActive pgButton
|
||||
|
|
@ -181,12 +184,12 @@ newFileTab
|
|||
-- Updates the active document when buttons are clicked.
|
||||
createFileBar
|
||||
:: Colours -> Variables
|
||||
-> GTK.Window -> GTK.Box -> GTK.Label -> GTK.DrawingArea -> InfoBar
|
||||
-> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar
|
||||
-> IO FileBar
|
||||
createFileBar
|
||||
colours
|
||||
vars@( Variables { openDocumentsTVar } )
|
||||
window titleBar title viewportDrawingArea infoBar
|
||||
window titleBar title viewport infoBar
|
||||
= do
|
||||
|
||||
-- Create file bar: box containing scrollable tabs, and a "+" button after it.
|
||||
|
|
|
|||
|
|
@ -17,6 +17,8 @@ import MetaBrush.Document
|
|||
( Document )
|
||||
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
||||
( InfoBar )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport )
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
|
|
@ -37,7 +39,7 @@ instance Show TabLocation
|
|||
|
||||
createFileBar
|
||||
:: Colours -> Variables
|
||||
-> GTK.Window -> GTK.Box -> GTK.Label -> GTK.DrawingArea -> InfoBar
|
||||
-> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar
|
||||
-> IO FileBar
|
||||
|
||||
newFileTab
|
||||
|
|
|
|||
|
|
@ -96,7 +96,7 @@ createInfoBar colours = do
|
|||
-- Magnifier
|
||||
|
||||
magnifierArea <- GTK.drawingAreaNew
|
||||
zoomText <- GTK.labelNew ( Just " 100.00%" )
|
||||
zoomText <- GTK.labelNew ( Just na )
|
||||
|
||||
GTK.boxPackStart zoomBox magnifierArea True True 0
|
||||
GTK.boxPackStart zoomBox zoomText True True 0
|
||||
|
|
@ -111,7 +111,7 @@ createInfoBar colours = do
|
|||
-- Cursor position
|
||||
|
||||
cursorPosArea <- GTK.drawingAreaNew
|
||||
cursorPosText <- GTK.labelNew ( Just "x: 0.00\ny: 0.00" )
|
||||
cursorPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na )
|
||||
|
||||
GTK.boxPackStart cursorPosBox cursorPosArea False False 0
|
||||
GTK.boxPackStart cursorPosBox cursorPosText False False 0
|
||||
|
|
@ -126,7 +126,7 @@ createInfoBar colours = do
|
|||
-- Top left position
|
||||
|
||||
topLeftPosArea <- GTK.drawingAreaNew
|
||||
topLeftPosText <- GTK.labelNew ( Just "x: 0.00\ny: 0.00" )
|
||||
topLeftPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na )
|
||||
|
||||
GTK.boxPackStart topLeftPosBox topLeftPosArea False False 0
|
||||
GTK.boxPackStart topLeftPosBox topLeftPosText False False 0
|
||||
|
|
@ -139,7 +139,7 @@ createInfoBar colours = do
|
|||
-- Bottom right position
|
||||
|
||||
botRightPosArea <- GTK.drawingAreaNew
|
||||
botRightPosText <- GTK.labelNew ( Just "x: 0.000\ny: 0.00" )
|
||||
botRightPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na )
|
||||
|
||||
GTK.boxPackStart botRightPosBox botRightPosArea False False 0
|
||||
GTK.boxPackStart botRightPosBox botRightPosText False False 0
|
||||
|
|
@ -167,9 +167,6 @@ updateInfoBar viewportDrawingArea ( InfoBar { .. } ) vars@( Variables { mousePos
|
|||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
mbDoc <- STM.atomically $ currentDocument vars
|
||||
let
|
||||
na :: IsString a => a
|
||||
na = " n/a"
|
||||
case mbDoc of
|
||||
Nothing -> do
|
||||
GTK.labelSetText zoomText $ na
|
||||
|
|
@ -182,7 +179,7 @@ updateInfoBar viewportDrawingArea ( InfoBar { .. } ) vars@( Variables { mousePos
|
|||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||
Point2D l t = toViewport ( Point2D 0 0 )
|
||||
Point2D r b = toViewport ( Point2D viewportWidth viewportHeight )
|
||||
mbMousePos <- fmap toViewport <$> STM.readTVarIO mousePosTVar
|
||||
mbMousePos <- STM.readTVarIO mousePosTVar
|
||||
GTK.labelSetText zoomText $ Text.pack ( fixed 5 2 ( 100 * zoomFactor ) <> "%" )
|
||||
case mbMousePos of
|
||||
Just ( Point2D mx my ) ->
|
||||
|
|
@ -201,3 +198,6 @@ fixed digitsBefore digitsAfter x = case second tail . break ( == '.' ) $ showFFl
|
|||
r = length bs
|
||||
in
|
||||
replicate ( digitsBefore - l ) ' ' <> as <> "." <> bs <> replicate ( digitsAfter - r ) '0'
|
||||
|
||||
na :: IsString a => a
|
||||
na = " n/a"
|
||||
|
|
@ -1,11 +1,19 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module MetaBrush.UI.Viewport
|
||||
( Viewport(..), createViewport )
|
||||
( Viewport(..), createViewport
|
||||
, Ruler(..)
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
|
||||
-- gi-gdk
|
||||
import qualified GI.Gdk as GDK
|
||||
|
||||
|
|
@ -20,7 +28,11 @@ import MetaBrush.Util
|
|||
|
||||
data Viewport
|
||||
= Viewport
|
||||
{ viewportDrawingArea :: !GTK.DrawingArea
|
||||
{ viewportDrawingArea
|
||||
, rulerCornerDrawingArea
|
||||
, leftRulerDrawingArea
|
||||
, topRulerDrawingArea
|
||||
:: !GTK.DrawingArea
|
||||
}
|
||||
|
||||
createViewport :: GTK.Grid -> IO Viewport
|
||||
|
|
@ -61,14 +73,14 @@ createViewport viewportGrid = do
|
|||
GTK.revealerSetTransitionType rvLeftRuler GTK.RevealerTransitionTypeSlideLeft
|
||||
GTK.revealerSetTransitionType rvTopRuler GTK.RevealerTransitionTypeSlideUp
|
||||
|
||||
rulerCornerArea <- GTK.drawingAreaNew
|
||||
GTK.boxPackStart rulerCorner rulerCornerArea True True 0
|
||||
rulerCornerDrawingArea <- GTK.drawingAreaNew
|
||||
GTK.boxPackStart rulerCorner rulerCornerDrawingArea True True 0
|
||||
|
||||
leftRulerArea <- GTK.drawingAreaNew
|
||||
GTK.boxPackStart leftRuler leftRulerArea True True 0
|
||||
leftRulerDrawingArea <- GTK.drawingAreaNew
|
||||
GTK.boxPackStart leftRuler leftRulerDrawingArea True True 0
|
||||
|
||||
topRulerArea <- GTK.drawingAreaNew
|
||||
GTK.boxPackStart topRuler topRulerArea True True 0
|
||||
topRulerDrawingArea <- GTK.drawingAreaNew
|
||||
GTK.boxPackStart topRuler topRulerDrawingArea True True 0
|
||||
|
||||
GTK.widgetSetHexpand rulerCorner False
|
||||
GTK.widgetSetVexpand rulerCorner False
|
||||
|
|
@ -81,12 +93,15 @@ createViewport viewportGrid = do
|
|||
|
||||
viewportDrawingArea <- GTK.drawingAreaNew
|
||||
GTK.setContainerChild viewportOverlay viewportDrawingArea
|
||||
GTK.widgetAddEvents viewportDrawingArea
|
||||
|
||||
for_ [ rulerCornerDrawingArea, leftRulerDrawingArea, topRulerDrawingArea, viewportDrawingArea ] \ drawingArea -> do
|
||||
GTK.widgetAddEvents drawingArea
|
||||
[ GDK.EventMaskPointerMotionMask
|
||||
, GDK.EventMaskButtonPressMask, GDK.EventMaskButtonReleaseMask
|
||||
, GDK.EventMaskScrollMask, GDK.EventMaskSmoothScrollMask
|
||||
]
|
||||
|
||||
{-
|
||||
-----------------
|
||||
-- Viewport scrolling
|
||||
|
||||
|
|
@ -105,4 +120,14 @@ createViewport viewportGrid = do
|
|||
widgetAddClass viewportHScrollbar "viewportScrollbar"
|
||||
widgetAddClass viewportVScrollbar "viewportScrollbar"
|
||||
|
||||
-}
|
||||
|
||||
pure ( Viewport {..} )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Ruler
|
||||
= RulerCorner
|
||||
| LeftRuler
|
||||
| TopRuler
|
||||
deriving stock Show
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ module Math.Module
|
|||
( Module(..), lerp
|
||||
, Inner(..)
|
||||
, squaredNorm, quadrance, distance
|
||||
, proj, projC, closestPointToLine
|
||||
, proj, projC, closestPointToSegment
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -79,11 +79,11 @@ proj x y = projC x y *^ y
|
|||
projC :: forall m r. ( Inner r m, Fractional r ) => m -> m -> r
|
||||
projC x y = x ^.^ y / squaredNorm y
|
||||
|
||||
closestPointToLine
|
||||
closestPointToSegment
|
||||
:: forall v r p
|
||||
. ( Inner r v, Torsor v p, Fractional r, Ord r )
|
||||
=> p -> p -> p -> p
|
||||
closestPointToLine c p0 p1
|
||||
closestPointToSegment c p0 p1
|
||||
| t <= 0
|
||||
= p0
|
||||
| t >= 1
|
||||
|
|
|
|||
Loading…
Reference in a new issue