From 031d72a69b5c041fd73cae3277544684b89cef1e Mon Sep 17 00:00:00 2001 From: sheaf Date: Sun, 6 Sep 2020 00:35:00 +0200 Subject: [PATCH] create/move/delete guides: drag from ruler area --- MetaBrush.cabal | 1 + app/Main.hs | 131 +++-- assets/theme.css | 8 + src/app/MetaBrush/Action.hs | 656 ++++++++++++---------- src/app/MetaBrush/Asset/CloseTabButton.hs | 2 +- src/app/MetaBrush/Asset/Colours.hs | 5 +- src/app/MetaBrush/Asset/Tools.hs | 2 +- src/app/MetaBrush/Context.hs | 34 +- src/app/MetaBrush/Document.hs | 18 +- src/app/MetaBrush/Document/Guide.hs | 91 +++ src/app/MetaBrush/Document/Serialise.hs | 52 +- src/app/MetaBrush/Event.hs | 78 ++- src/app/MetaBrush/Render/Document.hs | 113 +++- src/app/MetaBrush/UI/Coordinates.hs | 8 +- src/app/MetaBrush/UI/FileBar.hs | 19 +- src/app/MetaBrush/UI/FileBar.hs-boot | 4 +- src/app/MetaBrush/UI/InfoBar.hs | 20 +- src/app/MetaBrush/UI/Menu.hs | 4 +- src/app/MetaBrush/UI/ToolBar.hs | 2 +- src/app/MetaBrush/UI/Viewport.hs | 59 +- src/lib/Math/Bezier/Cubic.hs | 10 +- src/lib/Math/Bezier/Quadratic.hs | 10 +- src/lib/Math/Bezier/Stroke.hs | 20 +- src/lib/Math/Module.hs | 6 +- 24 files changed, 892 insertions(+), 461 deletions(-) create mode 100644 src/app/MetaBrush/Document/Guide.hs diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 80c3eb8..dc1acc6 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -109,6 +109,7 @@ executable MetaBrush , MetaBrush.Context , MetaBrush.Document , MetaBrush.Document.Draw + , MetaBrush.Document.Guide , MetaBrush.Document.Selection , MetaBrush.Document.Serialise , MetaBrush.Event diff --git a/app/Main.hs b/app/Main.hs index 5ecb85d..66768c3 100644 --- a/app/Main.hs +++ b/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,50 +114,35 @@ 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 - { strokeName = "Ellipse" - , strokeVisible = True - , strokeUnique = unsafeUnique 10 - , strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) ) - } - ] + [ ( emptyDocument "Closed" ( unsafeUnique 0 ) ) + { strokes = + [ Stroke + { strokeName = "Ellipse" + , strokeVisible = True + , strokeUnique = unsafeUnique 10 + , strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) ) + } + ] } - , Document - { displayName = "Line" - , mbFilePath = Nothing - , unsavedChanges = False - , viewportCenter = Point2D 0 0 - , zoomFactor = 1 - , documentUnique = unsafeUnique 1 - , strokes = [ Stroke - { strokeName = "Line" - , strokeVisible = True - , strokeUnique = unsafeUnique 11 - , strokePoints = linePts - } - ] + , ( emptyDocument "Line" ( unsafeUnique 1 ) ) + { strokes = + [ Stroke + { strokeName = "Line" + , strokeVisible = True + , strokeUnique = unsafeUnique 11 + , strokePoints = linePts + } + ] } - , Document - { displayName = "Short line" - , mbFilePath = Nothing - , unsavedChanges = False - , viewportCenter = Point2D 0 0 - , zoomFactor = 1 - , documentUnique = unsafeUnique 2 - , strokes = [ Stroke - { strokeName = "ShortLine" - , strokeVisible = True - , strokeUnique = unsafeUnique 12 - , strokePoints = linePts2 - } - ] + , ( emptyDocument "Short line" ( unsafeUnique 2 ) ) + { strokes = + [ Stroke + { strokeName = "ShortLine" + , strokeVisible = True + , strokeUnique = unsafeUnique 12 + , strokePoints = linePts2 + } + ] } ] where @@ -194,7 +185,7 @@ main = do -- Put all these stateful variables in a record for conciseness. let variables :: Variables - variables = Variables { .. } + variables = Variables {..} --------------------------------------------------------- -- Initialise GTK @@ -292,7 +283,7 @@ main = do --------------------------------------------------------- -- Main viewport - Viewport { viewportDrawingArea } <- createViewport viewportGrid + viewport@( Viewport { .. } ) <- createViewport viewportGrid ----------------- -- Viewport rendering @@ -301,22 +292,47 @@ main = do -- Get the relevant document information viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea - mbRender <- STM.atomically $ withCurrentDocument variables \ doc@( Document { .. } ) -> do + mbRender <- STM.atomically $ withCurrentDocument variables \ doc@( Document {..} ) -> do mbMousePos <- STM.readTVar mousePosTVar 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 @@ -329,12 +345,12 @@ main = do --------------------------------------------------------- -- File bar - + fileBar@( FileBar { fileBarBox } ) <- 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 @@ -342,12 +358,14 @@ main = do let uiElements :: UIElements - uiElements = UIElements { .. } + uiElements = UIElements {..} ------------ -- 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 diff --git a/assets/theme.css b/assets/theme.css index 2c2e8e0..540d06a 100644 --- a/assets/theme.css +++ b/assets/theme.css @@ -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; +} \ No newline at end of file diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index d783709..1ee0f40 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -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 @@ -138,7 +152,7 @@ data OpenFile = OpenFile TabLocation deriving stock Show instance HandleAction OpenFile where - handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( OpenFile tabLoc ) = do + handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) ( OpenFile tabLoc ) = do fileChooser <- GTK.fileChooserNativeNew ( Just "Open MetaBrush document..." ) ( Just window ) GTK.FileChooserActionOpen @@ -167,7 +181,7 @@ data OpenFolder = OpenFolder TabLocation deriving stock Show instance HandleAction OpenFolder where - handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( OpenFolder tabLoc ) = do + handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) ( OpenFolder tabLoc ) = do fileChooser <- GTK.fileChooserNativeNew ( Just "Select folder..." ) ( Just window ) GTK.FileChooserActionSelectFolder @@ -197,7 +211,7 @@ data Save = Save deriving stock Show instance HandleAction Save where - handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) _ = + handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ = save uiElts vars True save :: UIElements -> Variables -> Bool -> IO () @@ -249,7 +263,7 @@ saveAs uiElts vars keepOpen = do pure $ UpdateDocToAndThen Nothing ( saveDocument savePath doc' ) askForSavePath :: UIElements -> IO ( Maybe FilePath ) -askForSavePath ( UIElements { .. } ) = do +askForSavePath ( UIElements {..} ) = do fileChooser <- GTK.fileChooserNativeNew ( Just "Save MetaBrush document..." ) ( Just window ) GTK.FileChooserActionSave @@ -287,44 +301,47 @@ pattern SaveAndClose = 2 pattern CancelClose = 3 instance HandleAction Close where - handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) close = do - mbDoc <- case close of - CloseActive -> STM.atomically ( currentDocument vars ) - CloseThis unique -> Map.lookup unique <$> STM.readTVarIO openDocumentsTVar - case mbDoc of - Nothing -> pure () -- could show a warning message - Just ( Document { displayName, documentUnique, unsavedChanges } ) - | unsavedChanges - -> do - dialog <- GTK.new GTK.MessageDialog [] - GTK.setMessageDialogText dialog ( " \n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?" ) - GTK.setMessageDialogMessageType dialog GTK.MessageTypeQuestion - GTK.setWindowResizable dialog False - GTK.setWindowDecorated dialog False - GTK.windowSetTransientFor dialog ( Just window ) - GTK.windowSetModal dialog True - widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ] - closeButton <- GTK.dialogAddButton dialog "Close" JustClose - saveButton <- GTK.dialogAddButton dialog "Save and close" SaveAndClose - cancelButton <- GTK.dialogAddButton dialog "Cancel" CancelClose - GTK.dialogSetDefaultResponse dialog 1 - for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton" - choice <- GTK.dialogRun dialog - GTK.widgetDestroy dialog - case choice of - JustClose -> closeDocument documentUnique - SaveAndClose -> save uiElts vars False - _ -> pure () - | otherwise - -> closeDocument documentUnique + 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 + case mbDoc of + Nothing -> pure () -- could show a warning message + Just ( Document { displayName, documentUnique, unsavedChanges } ) + | unsavedChanges + -> do + dialog <- GTK.new GTK.MessageDialog [] + GTK.setMessageDialogText dialog ( " \n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?" ) + GTK.setMessageDialogMessageType dialog GTK.MessageTypeQuestion + GTK.setWindowResizable dialog False + GTK.setWindowDecorated dialog False + GTK.windowSetTransientFor dialog ( Just window ) + GTK.windowSetModal dialog True + widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ] + closeButton <- GTK.dialogAddButton dialog "Close" JustClose + saveButton <- GTK.dialogAddButton dialog "Save and close" SaveAndClose + cancelButton <- GTK.dialogAddButton dialog "Cancel" CancelClose + GTK.dialogSetDefaultResponse dialog 1 + for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton" + choice <- GTK.dialogRun dialog + GTK.widgetDestroy dialog + case choice of + JustClose -> closeDocument documentUnique + SaveAndClose -> save uiElts vars False + _ -> pure () + | otherwise + -> closeDocument documentUnique - where - closeDocument :: Unique -> IO () - closeDocument unique = do - removeFileTab vars unique - updateTitle window title Nothing - updateInfoBar viewportDrawingArea infoBar vars - GTK.widgetQueueDraw viewportDrawingArea + where + closeDocument :: Unique -> IO () + closeDocument unique = do + removeFileTab vars unique + updateTitle window title Nothing + updateInfoBar viewportDrawingArea infoBar vars + GTK.widgetQueueDraw viewportDrawingArea --------------------- -- Switch document -- @@ -334,19 +351,22 @@ data SwitchTo = SwitchTo Unique deriving stock Show instance HandleAction SwitchTo where - handleAction ( UIElements { .. } ) vars@( Variables { .. } ) ( SwitchTo newUnique ) = do - mbNewDocAndTab <- STM.atomically do - STM.writeTVar activeDocumentTVar ( Just newUnique ) - newDoc <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar - newTab <- Map.lookup newUnique <$> STM.readTVar fileBarTabsTVar - pure ( (,) <$> newDoc <*> newTab ) - case mbNewDocAndTab of - Nothing -> updateTitle window title Nothing - Just ( Document { .. }, tab ) -> do - updateTitle window title ( Just ( displayName, unsavedChanges ) ) - updateInfoBar viewportDrawingArea infoBar vars - GTK.widgetQueueDraw tab - GTK.widgetQueueDraw viewportDrawingArea + 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 + newTab <- Map.lookup newUnique <$> STM.readTVar fileBarTabsTVar + pure ( (,) <$> newDoc <*> newTab ) + case mbNewDocAndTab of + Nothing -> updateTitle window title Nothing + Just ( Document {..}, tab ) -> do + updateTitle window title ( Just ( displayName, unsavedChanges ) ) + updateInfoBar viewportDrawingArea infoBar vars + GTK.widgetQueueDraw tab + GTK.widgetQueueDraw viewportDrawingArea -------------- -- Quitting -- @@ -469,8 +489,8 @@ data Confirm = Confirm instance HandleAction Confirm where handleAction - ( UIElements { viewportDrawingArea } ) - ( Variables { .. } ) + ( UIElements { viewport = Viewport {..} } ) + ( Variables {..} ) _ = do tool <- STM.readTVarIO toolTVar @@ -504,13 +524,13 @@ 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 viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea - void . STM.atomically $ withCurrentDocument vars \ ( Document { .. } ) -> do + void . STM.atomically $ withCurrentDocument vars \ ( Document {..} ) -> do modifiers <- STM.readTVar modifiersTVar let toViewport :: Point2D Double -> Point2D Double @@ -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 } ) - vars@( Variables { .. } ) - ( MouseClick button mouseClickCoords ) + uiElts@( UIElements { viewport = Viewport {..} } ) + vars@( Variables {..} ) + ( MouseClick actionOrigin button mouseClickCoords ) = case button of -- Left mouse button. @@ -558,50 +585,66 @@ instance HandleAction MouseClick where pos :: Point2D Double pos = toViewport mouseClickCoords STM.writeTVar mousePosTVar ( Just pos ) - modifiers <- STM.readTVar modifiersTVar - tool <- STM.readTVar toolTVar - mode <- STM.readTVar modeTVar - case tool of - -- Selection mode mouse hold: - -- - -- - If holding shift or alt, mouse hold initiates a rectangular selection. - -- - If not holding shift or alt: - -- - if mouse click selected an object, initiate a drag move, - -- - otherwise, initiate a rectangular selection. - Selection -> - case selectionMode modifiers of - -- Drag move: not holding shift or alt, click has selected something. - New - | Just newDoc <- dragMoveSelect mode pos doc - -> do - STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos ) - pure ( UpdateDocTo $ Just newDoc ) - -- Rectangular selection. - _ -> do - STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos ) - pure Don'tModifyDoc + case actionOrigin of - -- Pen tool: start or continue a drawing operation. - Pen -> do - mbPartialPath <- STM.readTVar partialPathTVar - STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos ) - 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 - STM.writeTVar partialPathTVar - ( Just $ PartialPath - { partialStartPos = anchorPt - , partialControlPoint = Nothing - , partialPathAnchor = drawAnchor - , firstPoint = True - } - ) - pure ( UpdateDocTo $ Just newDoc ) - -- Path already started: indicate that we are continuing a path. - Just pp -> do - STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } ) - pure Don'tModifyDoc + ViewportOrigin -> do + modifiers <- STM.readTVar modifiersTVar + tool <- STM.readTVar toolTVar + mode <- STM.readTVar modeTVar + case tool of + -- Selection mode mouse hold: + -- + -- - If holding shift or alt, mouse hold initiates a rectangular selection. + -- - If not holding shift or alt: + -- - if mouse click selected an object, initiate a drag move, + -- - otherwise, initiate a rectangular selection. + Selection -> + case selectionMode modifiers of + -- Drag move: not holding shift or alt, click has selected something. + New + | Just newDoc <- dragMoveSelect mode pos doc + -> do + STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos ) + pure ( UpdateDocTo $ Just newDoc ) + -- Rectangular selection. + _ -> do + STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos ) + pure Don'tModifyDoc + + -- Pen tool: start or continue a drawing operation. + Pen -> do + mbPartialPath <- STM.readTVar partialPathTVar + STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos ) + 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 + STM.writeTVar partialPathTVar + ( Just $ PartialPath + { partialStartPos = anchorPt + , partialControlPoint = Nothing + , partialPathAnchor = drawAnchor + , firstPoint = True + } + ) + pure ( UpdateDocTo $ Just newDoc ) + -- Path already started: indicate that we are continuing a path. + Just pp -> do + 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 @@ -621,8 +664,8 @@ data MouseRelease = MouseRelease Word32 ( Point2D Double ) instance HandleAction MouseRelease where handleAction - uiElts@( UIElements { viewportDrawingArea } ) - vars@( Variables { .. } ) + uiElts@( UIElements { viewport = Viewport {..} } ) + vars@( Variables {..} ) ( MouseRelease button ( Point2D x y ) ) = case button of @@ -639,101 +682,138 @@ instance HandleAction MouseRelease where STM.writeTVar mousePosTVar ( Just pos ) modifiers <- STM.readTVar modifiersTVar mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing - tool <- STM.readTVar toolTVar - mode <- STM.readTVar modeTVar - case tool of + 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 - Selection -> do - let - selMode :: SelectionMode - selMode = selectionMode modifiers - case mbHoldPos of - Just hold - | DragMoveHold pos0 <- hold - , pos0 /= pos - -> pure ( UpdateDocTo $ Just $ translateSelection mode ( pos0 --> pos ) doc ) - | SelectionHold pos0 <- hold - , pos0 /= pos - -> pure ( UpdateDocTo $ Just $ selectRectangle mode selMode pos0 pos doc ) - _ -> pure ( UpdateDocTo $ Just $ selectAt mode selMode pos doc ) + tool <- STM.readTVar toolTVar + mode <- STM.readTVar modeTVar - Pen -> do - mbPartialPath <- STM.readTVar partialPathTVar - case mbPartialPath of - -- Normal pen mode mouse click should have created an anchor. - -- If no anchor exists, then just ignore the mouse release event. - Nothing -> pure Don'tModifyDoc - -- Mouse click release possibilities: - -- - -- - click was on complementary draw stroke draw anchor to close the path, - -- - release at same point as click: finish current segment, - -- - release at different point as click: finish current segment, adding a control point. - Just - ( PartialPath - { partialStartPos = p1 - , partialControlPoint = mbCp2 - , partialPathAnchor = anchor - , firstPoint - } - ) -> do + case tool of + + Selection -> do let - pathPoint :: Point2D Double - mbControlPoint :: Maybe ( Point2D Double ) - partialControlPoint :: Maybe ( Point2D Double ) - ( pathPoint, mbControlPoint, partialControlPoint ) - | Just ( DrawHold holdPos ) <- mbHoldPos - = ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos ) - | otherwise - = ( pos, Nothing, Nothing ) - ( _, otherAnchor, otherAnchorPt ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc - if not firstPoint && anchorsAreComplementary anchor otherAnchor - -- Close path. - then do - STM.writeTVar partialPathTVar Nothing - let - newSegment :: Seq ( StrokePoint PointData ) - newSegment - = Seq.fromList - $ catMaybes - [ Just ( PathPoint p1 ( PointData Normal Empty ) ) - , do - cp <- mbCp2 - guard ( cp /= p1 ) - pure $ ControlPoint cp ( PointData Normal Empty ) - , do - cp <- mbControlPoint - guard ( cp /= otherAnchorPt ) - pure $ ControlPoint cp ( PointData Normal Empty ) - , Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) ) - ] - pure ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc ) - else - if firstPoint - -- Continue current partial path. - then do - STM.writeTVar partialPathTVar ( Just $ PartialPath p1 partialControlPoint anchor False ) - pure Don'tModifyDoc - -- Finish current partial path. - else do - STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False ) - let - newSegment :: Seq ( StrokePoint PointData ) - newSegment - = Seq.fromList - $ catMaybes - [ Just ( PathPoint p1 ( PointData Normal Empty ) ) - , do - cp <- mbCp2 - guard ( cp /= p1 ) - pure $ ControlPoint cp ( PointData Normal Empty ) - , do - cp <- mbControlPoint - guard ( cp /= pathPoint ) - pure $ ControlPoint cp ( PointData Normal Empty ) - , Just ( PathPoint pathPoint ( PointData Normal Empty ) ) - ] - pure ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc ) + selMode :: SelectionMode + selMode = selectionMode modifiers + case mbHoldPos of + Just hold + | DragMoveHold pos0 <- hold + , pos0 /= pos + -> pure ( UpdateDocTo $ Just $ translateSelection mode ( pos0 --> pos ) doc ) + | SelectionHold pos0 <- hold + , pos0 /= pos + -> pure ( UpdateDocTo $ Just $ selectRectangle mode selMode pos0 pos doc ) + _ -> pure ( UpdateDocTo $ Just $ selectAt mode selMode pos doc ) + + Pen -> do + mbPartialPath <- STM.readTVar partialPathTVar + case mbPartialPath of + -- Normal pen mode mouse click should have created an anchor. + -- If no anchor exists, then just ignore the mouse release event. + Nothing -> pure Don'tModifyDoc + -- Mouse click release possibilities: + -- + -- - click was on complementary draw stroke draw anchor to close the path, + -- - release at same point as click: finish current segment, + -- - release at different point as click: finish current segment, adding a control point. + Just + ( PartialPath + { partialStartPos = p1 + , partialControlPoint = mbCp2 + , partialPathAnchor = anchor + , firstPoint + } + ) -> do + let + pathPoint :: Point2D Double + mbControlPoint :: Maybe ( Point2D Double ) + partialControlPoint :: Maybe ( Point2D Double ) + ( pathPoint, mbControlPoint, partialControlPoint ) + | Just ( DrawHold holdPos ) <- mbHoldPos + = ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos ) + | otherwise + = ( pos, Nothing, Nothing ) + ( _, otherAnchor, otherAnchorPt ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc + if not firstPoint && anchorsAreComplementary anchor otherAnchor + -- Close path. + then do + STM.writeTVar partialPathTVar Nothing + let + newSegment :: Seq ( StrokePoint PointData ) + newSegment + = Seq.fromList + $ catMaybes + [ Just ( PathPoint p1 ( PointData Normal Empty ) ) + , do + cp <- mbCp2 + guard ( cp /= p1 ) + pure $ ControlPoint cp ( PointData Normal Empty ) + , do + cp <- mbControlPoint + guard ( cp /= otherAnchorPt ) + pure $ ControlPoint cp ( PointData Normal Empty ) + , Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) ) + ] + pure ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc ) + else + if firstPoint + -- Continue current partial path. + then do + STM.writeTVar partialPathTVar ( Just $ PartialPath p1 partialControlPoint anchor False ) + pure Don'tModifyDoc + -- Finish current partial path. + else do + STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False ) + let + newSegment :: Seq ( StrokePoint PointData ) + newSegment + = Seq.fromList + $ catMaybes + [ Just ( PathPoint p1 ( PointData Normal Empty ) ) + , do + cp <- mbCp2 + guard ( cp /= p1 ) + pure $ ControlPoint cp ( PointData Normal Empty ) + , do + cp <- mbControlPoint + guard ( cp /= pathPoint ) + pure $ ControlPoint cp ( PointData Normal Empty ) + , Just ( PathPoint pathPoint ( PointData Normal Empty ) ) + ] + pure ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc ) -- Other mouse buttons: ignored (for the moment at least). _ -> pure () @@ -746,59 +826,62 @@ 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 + viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea + viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea - unless ( dx == 0 && dy == 0 ) do - modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do - modifiers <- STM.readTVar modifiersTVar - let - toViewport :: Point2D Double -> Point2D Double - toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter - -- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates) - mousePos :: Point2D Double - mousePos = toViewport ( Point2D x y ) - newDoc :: Document - newDoc - -- Zooming using 'Control'. - | any ( \ case { Control _ -> True; _ -> False } ) modifiers - = let - newZoomFactor :: Double - newZoomFactor - | dy > 0 - = max 0.0078125 ( oldZoomFactor / sqrt 2 ) - | otherwise - = min 256 ( oldZoomFactor * sqrt 2 ) - newCenter :: Point2D Double - newCenter - = ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double ) - • oldCenter - in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter } - -- Vertical scrolling turned into horizontal scrolling using 'Shift'. - | dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers - = let - newCenter :: Point2D Double - newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter - in doc { viewportCenter = newCenter } - -- Vertical scrolling. - | otherwise - = let - newCenter :: Point2D Double - newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter - in doc { viewportCenter = newCenter } - finalZoomFactor :: Double - finalZoomFactor = zoomFactor newDoc - finalCenter :: Point2D Double - finalCenter = viewportCenter newDoc - toFinalViewport :: Point2D Double -> Point2D Double - toFinalViewport = toViewportCoordinates finalZoomFactor ( viewportWidth, viewportHeight ) finalCenter - finalMousePos :: Point2D Double - finalMousePos = toFinalViewport ( Point2D x y ) - STM.writeTVar mousePosTVar ( Just finalMousePos ) - pure ( UpdateDocTo $ Just newDoc ) - updateInfoBar viewportDrawingArea infoBar vars + unless ( dx == 0 && dy == 0 ) do + modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do + modifiers <- STM.readTVar modifiersTVar + let + toViewport :: Point2D Double -> Point2D Double + toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter + -- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates) + mousePos :: Point2D Double + mousePos = toViewport ( Point2D x y ) + newDoc :: Document + newDoc + -- Zooming using 'Control'. + | any ( \ case { Control _ -> True; _ -> False } ) modifiers + = let + newZoomFactor :: Double + newZoomFactor + | dy > 0 + = max 0.0078125 ( oldZoomFactor / sqrt 2 ) + | otherwise + = min 256 ( oldZoomFactor * sqrt 2 ) + newCenter :: Point2D Double + newCenter + = ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double ) + • oldCenter + in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter } + -- Vertical scrolling turned into horizontal scrolling using 'Shift'. + | dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers + = let + newCenter :: Point2D Double + newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter + in doc { viewportCenter = newCenter } + -- Vertical scrolling. + | otherwise + = let + newCenter :: Point2D Double + newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter + in doc { viewportCenter = newCenter } + finalZoomFactor :: Double + finalZoomFactor = zoomFactor newDoc + finalCenter :: Point2D Double + finalCenter = viewportCenter newDoc + toFinalViewport :: Point2D Double -> Point2D Double + toFinalViewport = toViewportCoordinates finalZoomFactor ( viewportWidth, viewportHeight ) finalCenter + finalMousePos :: Point2D Double + finalMousePos = toFinalViewport ( Point2D x y ) + STM.writeTVar mousePosTVar ( Just finalMousePos ) + pure ( UpdateDocTo $ Just newDoc ) + updateInfoBar viewportDrawingArea infoBar vars -------------------- -- Keyboard press -- @@ -808,47 +891,50 @@ 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 - for_ ( modifierKey keyCode ) \ modifier -> - ( STM.writeTVar modifiersTVar ( Set.insert modifier modifiers ) ) - pure modifiers + modifiers <- STM.atomically do + !modifiers <- STM.readTVar modifiersTVar + for_ ( modifierKey keyCode ) \ modifier -> + ( STM.writeTVar modifiersTVar ( Set.insert modifier modifiers ) ) + pure modifiers - case keyCode of + case keyCode of - GDK.KEY_Escape -> handleAction uiElts vars Quit + GDK.KEY_Escape -> handleAction uiElts vars Quit - GDK.KEY_Return -> handleAction uiElts vars Confirm + GDK.KEY_Return -> handleAction uiElts vars Confirm - ctrl - | ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R - -> do - ---------------------------------------------------------- - -- With the pen tool, pressing control moves - -- the partial point control point to the mouse position. - tool <- STM.readTVarIO toolTVar - mbMousePos <- STM.readTVarIO mousePosTVar - mbPartialPath <- STM.readTVarIO partialPathTVar - case tool of - Pen - | Just mp <- mbMousePos - , Just pp <- mbPartialPath - -> do - STM.atomically $ STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } ) - GTK.widgetQueueDraw viewportDrawingArea - _ -> pure () + ctrl + | ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R + -> do + ---------------------------------------------------------- + -- With the pen tool, pressing control moves + -- the partial point control point to the mouse position. + tool <- STM.readTVarIO toolTVar + mbMousePos <- STM.readTVarIO mousePosTVar + mbPartialPath <- STM.readTVarIO partialPathTVar + case tool of + Pen + | Just mp <- mbMousePos + , Just pp <- mbPartialPath + -> do + STM.atomically $ STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } ) + GTK.widgetQueueDraw viewportDrawingArea + _ -> pure () - -- todo: these should be handled by accelerator, - -- but those are not working currently - GDK.KEY_Delete -> handleAction uiElts vars Delete + -- todo: these should be handled by accelerator, + -- but those are not working currently + GDK.KEY_Delete -> handleAction uiElts vars Delete - GDK.KEY_s - | any ( \case { Control _ -> True; _ -> False } ) modifiers - -> handleAction uiElts vars Save + GDK.KEY_s + | any ( \case { Control _ -> True; _ -> False } ) modifiers + -> handleAction uiElts vars Save - _ -> pure () + _ -> pure () ---------------------- -- Keyboard release -- diff --git a/src/app/MetaBrush/Asset/CloseTabButton.hs b/src/app/MetaBrush/Asset/CloseTabButton.hs index a2ef709..6862145 100644 --- a/src/app/MetaBrush/Asset/CloseTabButton.hs +++ b/src/app/MetaBrush/Asset/CloseTabButton.hs @@ -22,7 +22,7 @@ import MetaBrush.Util -- | "Close tab" button. drawCloseTabButton :: Colours -> Bool -> [ GTK.StateFlags ] -> Cairo.Render Bool -drawCloseTabButton ( Colours { .. } ) unsavedChanges flags = do +drawCloseTabButton ( Colours {..} ) unsavedChanges flags = do Cairo.setLineCap Cairo.LineCapRound Cairo.setLineJoin Cairo.LineJoinMiter diff --git a/src/app/MetaBrush/Asset/Colours.hs b/src/app/MetaBrush/Asset/Colours.hs index f9767f3..0db2e48 100644 --- a/src/app/MetaBrush/Asset/Colours.hs +++ b/src/app/MetaBrush/Asset/Colours.hs @@ -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 ] @@ -88,7 +89,7 @@ type Colours = ColourRecord GDK.RGBA getColours :: GTK.WidgetPath -> IO Colours getColours windowWidgetPath = - for colourNames \ ( ColourName { .. } ) -> do + for colourNames \ ( ColourName {..} ) -> do style <- GTK.styleContextNew GTK.styleContextSetPath style windowWidgetPath GTK.styleContextAddClass style colourName diff --git a/src/app/MetaBrush/Asset/Tools.hs b/src/app/MetaBrush/Asset/Tools.hs index 5267172..7da0f22 100644 --- a/src/app/MetaBrush/Asset/Tools.hs +++ b/src/app/MetaBrush/Asset/Tools.hs @@ -100,7 +100,7 @@ drawMeta ( Colours { splash } ) = do -- | Path icon. Width = 40 height = 40. drawPath :: Colours -> Cairo.Render Bool -drawPath ( Colours { .. } ) = do +drawPath ( Colours {..} ) = do Cairo.setLineCap Cairo.LineCapRound Cairo.setLineJoin Cairo.LineJoinMiter diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Context.hs index e6dc115..f053d44 100644 --- a/src/app/MetaBrush/Context.hs +++ b/src/app/MetaBrush/Context.hs @@ -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 @@ -85,13 +87,13 @@ import MetaBrush.Util data UIElements = UIElements - { window :: !GTK.Window - , title :: !GTK.Label - , titleBar :: !GTK.Box - , fileBar :: !FileBar - , viewportDrawingArea :: !GTK.DrawingArea - , infoBar :: !InfoBar - , colours :: !Colours + { window :: !GTK.Window + , title :: !GTK.Label + , titleBar :: !GTK.Box + , fileBar :: !FileBar + , viewport :: !Viewport + , infoBar :: !InfoBar + , colours :: !Colours } data Variables @@ -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 diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index b70f0ce..8262ce1 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -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 } diff --git a/src/app/MetaBrush/Document/Guide.hs b/src/app/MetaBrush/Document/Guide.hs new file mode 100644 index 0000000..9f5d195 --- /dev/null +++ b/src/app/MetaBrush/Document/Guide.hs @@ -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 ) diff --git a/src/app/MetaBrush/Document/Serialise.hs b/src/app/MetaBrush/Document/Serialise.hs index f26907e..41df02e 100644 --- a/src/app/MetaBrush/Document/Serialise.hs +++ b/src/app/MetaBrush/Document/Serialise.hs @@ -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 } ) diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index 8a6913a..f17a1a3 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -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. diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index fccf200..8d9fee1 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -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 ) @@ -105,7 +115,7 @@ toAll action = Compose ( pure action ) -------------------------------------------------------------------------------- blankRender :: Colours -> Cairo.Render () -blankRender ( Colours { .. } ) = pure () +blankRender ( Colours {..} ) = pure () renderDocument :: Colours -> Mode -> ( Int32, Int32 ) @@ -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,8 +353,24 @@ 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 } ) +drawPoint ( Colours {..} ) zoom pt@( PathPoint { coords = Point2D x y } ) = do let hsqrt3 :: Double @@ -311,7 +404,7 @@ drawPoint ( Colours { .. } ) zoom pt@( PathPoint { coords = Point2D x y } ) Cairo.restore -drawPoint ( Colours { .. } ) zoom pt@( ControlPoint { coords = Point2D x y } ) +drawPoint ( Colours {..} ) zoom pt@( ControlPoint { coords = Point2D x y } ) = do let selectionState :: FocusState @@ -450,7 +543,7 @@ drawStroke ( Colours { brushStroke } ) strokeData = do go' p0 ps = error $ "drawStroke: unrecognised stroke type\n" <> show ( p0 :<| ps ) drawSelectionRectangle :: Colours -> Double -> Point2D Double -> Point2D Double -> Cairo.Render () -drawSelectionRectangle ( Colours { .. } ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1 ) = do +drawSelectionRectangle ( Colours {..} ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1 ) = do Cairo.save @@ -470,7 +563,7 @@ drawSelectionRectangle ( Colours { .. } ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1 Cairo.restore drawCross :: Colours -> Double -> Cairo.Render () -drawCross ( Colours { .. } ) zoom = do +drawCross ( Colours {..} ) zoom = do Cairo.save Cairo.setLineWidth 1.5 diff --git a/src/app/MetaBrush/UI/Coordinates.hs b/src/app/MetaBrush/UI/Coordinates.hs index 43d5b08..648b3c6 100644 --- a/src/app/MetaBrush/UI/Coordinates.hs +++ b/src/app/MetaBrush/UI/Coordinates.hs @@ -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,19 +55,19 @@ 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 } ) ( ControlPoint { coords = p1 } :<| sp2@( PathPoint { coords = p2 } ) :<| ps ) = fmap ( fmap ( Just . snd ) ) - ( Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier { .. } ) c ) + ( Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier {..} ) c ) <> go sp2 ps -- Cubic Bézier curve. go ( PathPoint { coords = p0 } ) ( PathPoint { coords = p1 } :<| PathPoint { coords = p2 } :<| sp3@( PathPoint { coords = p3 } ) :<| ps ) = fmap ( fmap ( Just . snd ) ) - ( Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier { .. } ) c ) + ( Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier {..} ) c ) <> go sp3 ps go p0 ps = error $ "closestPoint: unrecognised stroke type\n" <> show ( p0 :<| ps ) closestPoint _ _ = Min $ Arg ( 1 / 0 ) Nothing diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs index 1033e3c..1d4da41 100644 --- a/src/app/MetaBrush/UI/FileBar.hs +++ b/src/app/MetaBrush/UI/FileBar.hs @@ -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,8 +80,8 @@ newFileTab -> TabLocation -> IO () newFileTab - uiElts@( UIElements { fileBar = FileBar {..}, .. } ) - vars@( Variables { .. } ) + uiElts@( UIElements { fileBar = FileBar {..}, viewport = Viewport {..}, .. } ) + vars@( Variables {..} ) mbDoc newTabLoc = do @@ -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. @@ -212,9 +215,9 @@ createFileBar let fileBar :: FileBar - fileBar = FileBar { .. } + fileBar = FileBar {..} uiElements :: UIElements - uiElements = UIElements { .. } + uiElements = UIElements {..} documents <- STM.readTVarIO openDocumentsTVar for_ documents \ doc -> @@ -233,7 +236,7 @@ createFileBar -- | Close a document: remove the corresponding file tab from the file bar. removeFileTab :: Variables -> Unique -> IO () -removeFileTab ( Variables { .. } ) docUnique = do +removeFileTab ( Variables {..} ) docUnique = do cleanupAction <- STM.atomically do -- Remove the tab. diff --git a/src/app/MetaBrush/UI/FileBar.hs-boot b/src/app/MetaBrush/UI/FileBar.hs-boot index 378f16f..89451af 100644 --- a/src/app/MetaBrush/UI/FileBar.hs-boot +++ b/src/app/MetaBrush/UI/FileBar.hs-boot @@ -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 diff --git a/src/app/MetaBrush/UI/InfoBar.hs b/src/app/MetaBrush/UI/InfoBar.hs index 8a0d335..3de6aaa 100644 --- a/src/app/MetaBrush/UI/InfoBar.hs +++ b/src/app/MetaBrush/UI/InfoBar.hs @@ -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 @@ -159,17 +159,14 @@ createInfoBar colours = do for_ [ zoomText, cursorPosText, topLeftPosText, botRightPosText ] \ info -> do widgetAddClass info "infoBarInfo" - pure ( InfoBar { .. } ) + pure ( InfoBar {..} ) updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> IO () -updateInfoBar viewportDrawingArea ( InfoBar { .. } ) vars@( Variables { mousePosTVar } ) +updateInfoBar viewportDrawingArea ( InfoBar {..} ) vars@( Variables { mousePosTVar } ) = do 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" \ No newline at end of file diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index 96cd2bd..a1a8c0d 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/src/app/MetaBrush/UI/Menu.hs @@ -233,7 +233,7 @@ newMenuItem -> GTK.AccelGroup -> MenuItem action submenu Description -> m GTK.MenuItem -newMenuItem uiElts vars accelGroup ( MenuItemDescription { .. } ) = do +newMenuItem uiElts vars accelGroup ( MenuItemDescription {..} ) = do menuItem <- GTK.menuItemNewWithLabel menuItemLabel for_ menuItemAccel \ ( key, modifiers ) -> do GTK.widgetAddAccelerator menuItem "activate" accelGroup key ( map modifierType modifiers ) [ GTK.AccelFlagsVisible ] @@ -279,7 +279,7 @@ instance ( HandleAction action, HasConstraints CreateMenuItem ( submenu Descript , menuItemSubmenu = submenuItems } instance CreateMenuItem ( Separator Description ) ( Separator Object ) where - createMenuItem _ _ _ attachToParent ( SeparatorDescription { .. } ) = do + createMenuItem _ _ _ attachToParent ( SeparatorDescription {..} ) = do separator <- GTK.separatorMenuItemNew unless ( null separatorClasses ) do widgetAddClasses separator separatorClasses diff --git a/src/app/MetaBrush/UI/ToolBar.hs b/src/app/MetaBrush/UI/ToolBar.hs index 280feee..124802a 100644 --- a/src/app/MetaBrush/UI/ToolBar.hs +++ b/src/app/MetaBrush/UI/ToolBar.hs @@ -140,4 +140,4 @@ createToolBar toolTVar modeTVar colours drawingArea toolBar = do $ Cairo.renderWithContext ( drawMeta colours ) - pure ( ToolBar { .. } ) + pure ( ToolBar {..} ) diff --git a/src/app/MetaBrush/UI/Viewport.hs b/src/app/MetaBrush/UI/Viewport.hs index 60f22b6..849c7b2 100644 --- a/src/app/MetaBrush/UI/Viewport.hs +++ b/src/app/MetaBrush/UI/Viewport.hs @@ -1,11 +1,19 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} +{-# 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 - [ GDK.EventMaskPointerMotionMask - , GDK.EventMaskButtonPressMask, GDK.EventMaskButtonReleaseMask - , GDK.EventMaskScrollMask, GDK.EventMaskSmoothScrollMask - ] + 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 { .. } ) + -} + + pure ( Viewport {..} ) + +-------------------------------------------------------------------------------- + +data Ruler + = RulerCorner + | LeftRuler + | TopRuler + deriving stock Show diff --git a/src/lib/Math/Bezier/Cubic.hs b/src/lib/Math/Bezier/Cubic.hs index b0c8e41..0774a60 100644 --- a/src/lib/Math/Bezier/Cubic.hs +++ b/src/lib/Math/Bezier/Cubic.hs @@ -77,7 +77,7 @@ deriving via Ap Bezier p -- | Cubic Bézier curve. bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p -bezier ( Bezier { .. } ) t = +bezier ( Bezier {..} ) t = lerp @v t ( Quadratic.bezier @v ( Quadratic.Bezier p0 p1 p2 ) t ) ( Quadratic.bezier @v ( Quadratic.Bezier p1 p2 p3 ) t ) @@ -85,7 +85,7 @@ bezier ( Bezier { .. } ) t = -- | Derivative of cubic Bézier curve. bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v -bezier' ( Bezier { .. } ) t +bezier' ( Bezier {..} ) t = ( 3 *^ ) $ lerp @v t ( lerp @v t ( p0 --> p1 ) ( p1 --> p2 ) ) @@ -93,7 +93,7 @@ bezier' ( Bezier { .. } ) t -- | Subdivide a cubic Bézier curve into two parts. subdivide :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> ( Bezier p, Bezier p ) -subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 ) +subdivide ( Bezier {..} ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 ) where pt, s, q1, q2, r1, r2 :: p q1 = lerp @v t p0 p1 @@ -105,7 +105,7 @@ subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 ) -- | Polynomial coefficients of the derivative of the distance to a cubic Bézier curve. ddist :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> [ r ] -ddist ( Bezier { .. } ) c = [ a0, a1, a2, a3, a4, a5 ] +ddist ( Bezier {..} ) c = [ a0, a1, a2, a3, a4, a5 ] where v, v', v'', v''' :: v v = c --> p0 @@ -123,7 +123,7 @@ ddist ( Bezier { .. } ) c = [ a0, a1, a2, a3, a4, a5 ] -- | Finds the closest point to a given point on a cubic Bézier curve. closestPoint :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> ArgMin r ( r, p ) -closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots ) -- todo: also include the self-intersection point if one exists +closestPoint pts@( Bezier {..} ) c = pickClosest ( 0 :| 1 : roots ) -- todo: also include the self-intersection point if one exists where roots :: [ r ] roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots $ ddist @v pts c ) diff --git a/src/lib/Math/Bezier/Quadratic.hs b/src/lib/Math/Bezier/Quadratic.hs index 9adb36e..4e7b197 100644 --- a/src/lib/Math/Bezier/Quadratic.hs +++ b/src/lib/Math/Bezier/Quadratic.hs @@ -75,15 +75,15 @@ deriving via Ap Bezier p -- | Quadratic Bézier curve. bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p -bezier ( Bezier { .. } ) t = lerp @v t ( lerp @v t p0 p1 ) ( lerp @v t p1 p2 ) +bezier ( Bezier {..} ) t = lerp @v t ( lerp @v t p0 p1 ) ( lerp @v t p1 p2 ) -- | Derivative of quadratic Bézier curve. bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v -bezier' ( Bezier { .. } ) t = 2 *^ lerp @v t ( p0 --> p1 ) ( p1 --> p2 ) +bezier' ( Bezier {..} ) t = 2 *^ lerp @v t ( p0 --> p1 ) ( p1 --> p2 ) -- | Subdivide a quadratic Bézier curve into two parts. subdivide :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> ( Bezier p, Bezier p ) -subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 pt, Bezier pt r1 p2 ) +subdivide ( Bezier {..} ) t = ( Bezier p0 q1 pt, Bezier pt r1 p2 ) where pt, q1, r1 :: p q1 = lerp @v t p0 p1 @@ -92,7 +92,7 @@ subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 pt, Bezier pt r1 p2 ) -- | Polynomial coefficients of the derivative of the distance to a quadratic Bézier curve. ddist :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> [ r ] -ddist ( Bezier { .. } ) c = [ a0, a1, a2, a3 ] +ddist ( Bezier {..} ) c = [ a0, a1, a2, a3 ] where v, v', v'' :: v v = c --> p0 @@ -107,7 +107,7 @@ ddist ( Bezier { .. } ) c = [ a0, a1, a2, a3 ] -- | Finds the closest point to a given point on a quadratic Bézier curve. closestPoint :: forall v r p. ( Torsor v p, Inner r v, RealFloat r ) => Bezier p -> p -> ArgMin r ( r, p ) -closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots ) +closestPoint pts@( Bezier {..} ) c = pickClosest ( 0 :| 1 : roots ) where roots :: [ r ] roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots $ ddist @v pts c ) diff --git a/src/lib/Math/Bezier/Stroke.hs b/src/lib/Math/Bezier/Stroke.hs index fe7c744..4681791 100644 --- a/src/lib/Math/Bezier/Stroke.hs +++ b/src/lib/Math/Bezier/Stroke.hs @@ -227,7 +227,7 @@ stroke allPts@( spt0 :<| spt1 :<| spts ) tgt2 :: Vector2D Double tgt2 = p1 --> p2 bez :: Quadratic.Bezier ( Point2D Double ) - bez = Quadratic.Bezier { .. } + bez = Quadratic.Bezier {..} brush :: Double -> Seq ( StrokePoint () ) brush t = quadraticBezierBrush t ( Quadratic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) ) @@ -261,7 +261,7 @@ stroke allPts@( spt0 :<| spt1 :<| spts ) tgt3 :: Vector2D Double tgt3 = p2 --> p3 bez :: Cubic.Bezier ( Point2D Double ) - bez = Cubic.Bezier { .. } + bez = Cubic.Bezier {..} brush :: Double -> Seq ( StrokePoint () ) brush t = cubicBezierBrush t ( Cubic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) ( brushShape @x sp3 ) ) @@ -313,11 +313,11 @@ quadraticBezierBrush t ( Quadratic.Bezier p0s p1s p2s ) = Seq.zipWith3 f p0s p1s f ( PathPoint { coords = p0 } ) ( PathPoint { coords = p1 } ) ( PathPoint { coords = p2 } ) - = PP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t + = PP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t f ( ControlPoint { coords = p0 } ) ( ControlPoint { coords = p1 } ) ( ControlPoint { coords = p2 } ) - = CP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t + = CP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t f p1 p2 p3 = error $ "stroke: incompatible brushes " <> show [ p1, p2, p3 ] cubicBezierBrush :: forall d. Show d => Double -> Cubic.Bezier ( Seq ( StrokePoint d ) ) -> Seq ( StrokePoint () ) @@ -328,12 +328,12 @@ cubicBezierBrush t ( Cubic.Bezier p0s p1s p2s p3s ) = Seq.zipWith4 f p0s p1s p2s ( PathPoint { coords = p1 } ) ( PathPoint { coords = p2 } ) ( PathPoint { coords = p3 } ) - = PP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier { .. } ) t + = PP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier {..} ) t f ( ControlPoint { coords = p0 } ) ( ControlPoint { coords = p1 } ) ( ControlPoint { coords = p2 } ) ( ControlPoint { coords = p3 } ) - = CP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier { .. } ) t + = CP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier {..} ) t f p1 p2 p3 p4 = error $ "stroke: incompatible brushes " <> show [ p1, p2, p3, p4 ] fitCurve @@ -407,7 +407,7 @@ splitFirstPiece t ( sp0 :<| sp1 :<| sp2 :<| _ ) , let q1, p, r1 :: Point2D Double ( Quadratic.Bezier _ q1 p, Quadratic.Bezier _ r1 _ ) - = Quadratic.subdivide @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t + = Quadratic.subdivide @( Vector2D Double ) ( Quadratic.Bezier {..} ) t = ( PP p0 :<| CP q1 :<| PP p :<| Empty , PP p :<| CP r1 :<| PP p2 :<| Empty ) @@ -420,7 +420,7 @@ splitFirstPiece t ( sp0 :<| sp1 :<| sp2 :<| sp3 :<| _ ) , let q1, q2, p, r1, r2 :: Point2D Double ( Cubic.Bezier _ q1 q2 p, Cubic.Bezier _ r1 r2 _ ) - = Cubic.subdivide @( Vector2D Double ) ( Cubic.Bezier { .. } ) t + = Cubic.subdivide @( Vector2D Double ) ( Cubic.Bezier {..} ) t = ( PP p0 :<| CP q1 :<| CP q2 :<| PP p :<| Empty , PP p :<| CP r1 :<| CP r2 :<| PP p3 :<| Empty ) @@ -463,7 +463,7 @@ withTangent tgt ( spt0 :<| spt1 :<| spts ) = tgt1 :: Vector2D Double tgt1 = p1 --> p2 in case between tgt tgt0 tgt1 of - Just t -> Offset i ( Just t ) ( MkVector2D $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t ) + Just t -> Offset i ( Just t ) ( MkVector2D $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t ) Nothing -> continue ( i + 2 ) tgt1 sp2 ps -- Cubic Bézier curve. go i tgt0 @@ -475,7 +475,7 @@ withTangent tgt ( spt0 :<| spt1 :<| spts ) = tgt1 = p1 --> p2 tgt2 = p2 --> p3 bez :: Cubic.Bezier ( Point2D Double ) - bez = Cubic.Bezier { .. } + bez = Cubic.Bezier {..} c01, c12, c23 :: Double c01 = tgt `cross` tgt0 c12 = tgt `cross` tgt1 diff --git a/src/lib/Math/Module.hs b/src/lib/Math/Module.hs index 5e9bc1f..e1fc8ad 100644 --- a/src/lib/Math/Module.hs +++ b/src/lib/Math/Module.hs @@ -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