hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 23:03:38 +00:00
Code Issues Actions Projects Releases Wiki Activity

create/move/delete guides: drag from ruler area

Browse source
This commit is contained in:
sheaf 2020-09-06 00:35:00 +02:00
parent 930fa0ebf9
commit 031d72a69b
24 changed files with 892 additions and 461 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
MetaBrush.cabal
View file

@ -109,6 +109,7 @@ executable MetaBrush
, MetaBrush.Context , MetaBrush.Context
, MetaBrush.Document , MetaBrush.Document
, MetaBrush.Document.Draw , MetaBrush.Document.Draw
, MetaBrush.Document.Guide
, MetaBrush.Document.Selection , MetaBrush.Document.Selection
, MetaBrush.Document.Serialise , MetaBrush.Document.Serialise
, MetaBrush.Event , MetaBrush.Event

129
app/Main.hs
View file

@ -13,6 +13,8 @@ module Main
-- base -- base
import Control.Monad import Control.Monad
( void ) ( void )
import Data.Foldable
( for_ )
import Data.Int import Data.Int
( Int32 ) ( Int32 )
import System.Exit import System.Exit
@ -61,6 +63,8 @@ import Math.Bezier.Stroke
( StrokePoint(..) ) ( StrokePoint(..) )
import Math.Vector2D import Math.Vector2D
( Point2D(..) ) ( Point2D(..) )
import MetaBrush.Action
( ActionOrigin(..) )
import MetaBrush.Asset.Brushes import MetaBrush.Asset.Brushes
( ellipse, rect ) ( ellipse, rect )
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
@ -74,26 +78,28 @@ import MetaBrush.Context
, withCurrentDocument , withCurrentDocument
) )
import MetaBrush.Document import MetaBrush.Document
( Document(..), Stroke(..) ( Document(..), emptyDocument
, FocusState(..) , Stroke(..), FocusState(..)
, PointData(..), BrushPointData(..) , PointData(..), BrushPointData(..)
) )
import MetaBrush.Event import MetaBrush.Event
( handleEvents ) ( handleEvents )
import MetaBrush.Render.Document import MetaBrush.Render.Document
( renderDocument, blankRender ) ( renderDocument, renderGuides, blankRender )
import MetaBrush.UI.FileBar import MetaBrush.UI.FileBar
( FileBar(..), createFileBar ) ( FileBar(..), createFileBar )
import MetaBrush.UI.InfoBar import MetaBrush.UI.InfoBar
( InfoBar(..), createInfoBar ) ( InfoBar(..), createInfoBar, updateInfoBar )
import MetaBrush.UI.Menu import MetaBrush.UI.Menu
( createMenuBar ) ( createMenuBar
--, MenuItem(..), Menu(..), FileMenu(..), EditMenu(..), ViewMenu(..)
)
import MetaBrush.UI.Panels import MetaBrush.UI.Panels
( createPanelBar ) ( createPanelBar )
import MetaBrush.UI.ToolBar import MetaBrush.UI.ToolBar
( Tool(..), Mode(..), createToolBar ) ( Tool(..), Mode(..), createToolBar )
import MetaBrush.UI.Viewport import MetaBrush.UI.Viewport
( Viewport(..), createViewport ) ( Viewport(..), Ruler(..), createViewport )
import MetaBrush.Unique import MetaBrush.Unique
( newUniqueSupply ( newUniqueSupply
, Unique, unsafeUnique , Unique, unsafeUnique
@ -108,50 +114,35 @@ import qualified Paths_MetaBrush as Cabal
testDocuments :: Map Unique Document testDocuments :: Map Unique Document
testDocuments = uniqueMapFromList testDocuments = uniqueMapFromList
[ Document [ ( emptyDocument "Closed" ( unsafeUnique 0 ) )
{ displayName = "Closed" { strokes =
, mbFilePath = Nothing [ Stroke
, unsavedChanges = False { strokeName = "Ellipse"
, viewportCenter = Point2D 50 50 , strokeVisible = True
, zoomFactor = 1 , strokeUnique = unsafeUnique 10
, documentUnique = unsafeUnique 0 , strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) )
, strokes = [ Stroke }
{ strokeName = "Ellipse" ]
, strokeVisible = True
, strokeUnique = unsafeUnique 10
, strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) )
}
]
} }
, Document , ( emptyDocument "Line" ( unsafeUnique 1 ) )
{ displayName = "Line" { strokes =
, mbFilePath = Nothing [ Stroke
, unsavedChanges = False { strokeName = "Line"
, viewportCenter = Point2D 0 0 , strokeVisible = True
, zoomFactor = 1 , strokeUnique = unsafeUnique 11
, documentUnique = unsafeUnique 1 , strokePoints = linePts
, strokes = [ Stroke }
{ strokeName = "Line" ]
, strokeVisible = True
, strokeUnique = unsafeUnique 11
, strokePoints = linePts
}
]
} }
, Document , ( emptyDocument "Short line" ( unsafeUnique 2 ) )
{ displayName = "Short line" { strokes =
, mbFilePath = Nothing [ Stroke
, unsavedChanges = False { strokeName = "ShortLine"
, viewportCenter = Point2D 0 0 , strokeVisible = True
, zoomFactor = 1 , strokeUnique = unsafeUnique 12
, documentUnique = unsafeUnique 2 , strokePoints = linePts2
, strokes = [ Stroke }
{ strokeName = "ShortLine" ]
, strokeVisible = True
, strokeUnique = unsafeUnique 12
, strokePoints = linePts2
}
]
} }
] ]
where where
@ -194,7 +185,7 @@ main = do
-- Put all these stateful variables in a record for conciseness. -- Put all these stateful variables in a record for conciseness.
let let
variables :: Variables variables :: Variables
variables = Variables { .. } variables = Variables {..}
--------------------------------------------------------- ---------------------------------------------------------
-- Initialise GTK -- Initialise GTK
@ -292,7 +283,7 @@ main = do
--------------------------------------------------------- ---------------------------------------------------------
-- Main viewport -- Main viewport
Viewport { viewportDrawingArea } <- createViewport viewportGrid viewport@( Viewport { .. } ) <- createViewport viewportGrid
----------------- -----------------
-- Viewport rendering -- Viewport rendering
@ -301,22 +292,47 @@ main = do
-- Get the relevant document information -- Get the relevant document information
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- GTK.widgetGetAllocatedHeight 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 mbMousePos <- STM.readTVar mousePosTVar
mbHoldAction <- STM.readTVar mouseHoldTVar mbHoldAction <- STM.readTVar mouseHoldTVar
mbPartialPath <- STM.readTVar partialPathTVar mbPartialPath <- STM.readTVar partialPathTVar
mode <- STM.readTVar modeTVar mode <- STM.readTVar modeTVar
pure $ pure do
renderDocument renderDocument
colours mode ( viewportWidth, viewportHeight ) colours mode ( viewportWidth, viewportHeight )
mbMousePos mbHoldAction mbPartialPath mbMousePos mbHoldAction mbPartialPath
doc doc
renderGuides
colours ( viewportWidth, viewportHeight ) ViewportOrigin ( viewportWidth, viewportHeight )
mbMousePos mbHoldAction
doc
case mbRender of case mbRender of
Just render -> Cairo.renderWithContext render ctx Just render -> Cairo.renderWithContext render ctx
Nothing -> Cairo.renderWithContext ( blankRender colours ) ctx Nothing -> Cairo.renderWithContext ( blankRender colours ) ctx
pure True 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 -- Tool bar
@ -334,7 +350,7 @@ main = do
createFileBar createFileBar
colours colours
variables variables
window titleBar title viewportDrawingArea infoBar window titleBar title viewport infoBar
GTK.boxPackStart mainView fileBarBox False False 0 GTK.boxPackStart mainView fileBarBox False False 0
GTK.boxPackStart mainView viewportGrid True True 0 GTK.boxPackStart mainView viewportGrid True True 0
@ -342,12 +358,14 @@ main = do
let let
uiElements :: UIElements uiElements :: UIElements
uiElements = UIElements { .. } uiElements = UIElements {..}
------------ ------------
-- Menu bar -- Menu bar
_ <- createMenuBar uiElements variables colours _menu <- createMenuBar uiElements variables colours
--GTK.widgetSetSensitive ( menuItem $ close $ menuItemSubmenu $ file menu ) False
--------------------------------------------------------- ---------------------------------------------------------
-- Panels -- Panels
@ -363,6 +381,7 @@ main = do
-- GTK main loop -- GTK main loop
GTK.widgetShowAll window GTK.widgetShowAll window
updateInfoBar viewportDrawingArea infoBar variables -- need to update the info bar after widgets have been realized
GTK.main GTK.main
exitSuccess exitSuccess

8
assets/theme.css
View file

@ -75,6 +75,9 @@
.tabScrollbar { .tabScrollbar {
background-color: rgba(48, 45, 38, 0.66); background-color: rgba(48, 45, 38, 0.66);
} }
.guide {
color: rgba(28, 196, 79, 0.66)
}
.magnifier { .magnifier {
color: rgb(236, 223, 210); color: rgb(236, 223, 210);
} }
@ -419,3 +422,8 @@ tooltip {
font-size: 10px; font-size: 10px;
-GtkWidget-window-dragging: true; -GtkWidget-window-dragging: true;
} }
.infoBarInfo {
margin-left: -4px;
padding-right: 16px;
}

654
src/app/MetaBrush/Action.hs
View file

@ -52,12 +52,22 @@ import System.Directory
import System.FilePath import System.FilePath
( (</>), (<.>), takeExtension ) ( (</>), (<.>), takeExtension )
-- generic-lens
import Data.Generics.Product.Fields
( field' )
-- gi-gdk -- gi-gdk
import qualified GI.Gdk as GDK import qualified GI.Gdk as GDK
-- gi-gtk -- gi-gtk
import qualified GI.Gtk as GTK import qualified GI.Gtk as GTK
-- lens
import Control.Lens
( over, set )
import Control.Lens.At
( ix, at )
-- stm -- stm
import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM as STM
( atomically ) ( atomically )
@ -74,18 +84,20 @@ import Math.Vector2D
import MetaBrush.Context import MetaBrush.Context
( UIElements(..), Variables(..) ( UIElements(..), Variables(..)
, Modifier(..), modifierKey , Modifier(..), modifierKey
, HoldAction(..), PartialPath(..) , HoldAction(..), GuideAction(..), PartialPath(..)
, currentDocument, withCurrentDocument , currentDocument, withCurrentDocument
, PureDocModification(..), DocModification(..) , PureDocModification(..), DocModification(..)
, modifyingCurrentDocument , modifyingCurrentDocument
, updateTitle , updateTitle
) )
import MetaBrush.Document import MetaBrush.Document
( Document(..) ( Document(..), Guide(..)
, PointData(..), FocusState(..) , PointData(..), FocusState(..)
) )
import MetaBrush.Document.Draw import MetaBrush.Document.Draw
( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary ) ( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
import MetaBrush.Document.Guide
( selectGuide, addGuide )
import MetaBrush.Document.Selection import MetaBrush.Document.Selection
( SelectionMode(..), selectionMode ( SelectionMode(..), selectionMode
, selectAt, selectRectangle , selectAt, selectRectangle
@ -103,6 +115,8 @@ import {-# SOURCE #-} MetaBrush.UI.FileBar
( TabLocation(..), newFileTab, removeFileTab ) ( TabLocation(..), newFileTab, removeFileTab )
import MetaBrush.UI.ToolBar import MetaBrush.UI.ToolBar
( Tool(..) ) ( Tool(..) )
import MetaBrush.UI.Viewport
( Viewport(..), Ruler(..) )
import MetaBrush.Unique import MetaBrush.Unique
( Unique ) ( Unique )
import MetaBrush.Util import MetaBrush.Util
@ -138,7 +152,7 @@ data OpenFile = OpenFile TabLocation
deriving stock Show deriving stock Show
instance HandleAction OpenFile where instance HandleAction OpenFile where
handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( OpenFile tabLoc ) = do handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) ( OpenFile tabLoc ) = do
fileChooser <- fileChooser <-
GTK.fileChooserNativeNew ( Just "Open MetaBrush document..." ) ( Just window ) GTK.fileChooserNativeNew ( Just "Open MetaBrush document..." ) ( Just window )
GTK.FileChooserActionOpen GTK.FileChooserActionOpen
@ -167,7 +181,7 @@ data OpenFolder = OpenFolder TabLocation
deriving stock Show deriving stock Show
instance HandleAction OpenFolder where instance HandleAction OpenFolder where
handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( OpenFolder tabLoc ) = do handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) ( OpenFolder tabLoc ) = do
fileChooser <- fileChooser <-
GTK.fileChooserNativeNew ( Just "Select folder..." ) ( Just window ) GTK.fileChooserNativeNew ( Just "Select folder..." ) ( Just window )
GTK.FileChooserActionSelectFolder GTK.FileChooserActionSelectFolder
@ -197,7 +211,7 @@ data Save = Save
deriving stock Show deriving stock Show
instance HandleAction Save where instance HandleAction Save where
handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) _ = handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ =
save uiElts vars True save uiElts vars True
save :: UIElements -> Variables -> Bool -> IO () save :: UIElements -> Variables -> Bool -> IO ()
@ -249,7 +263,7 @@ saveAs uiElts vars keepOpen = do
pure $ UpdateDocToAndThen Nothing ( saveDocument savePath doc' ) pure $ UpdateDocToAndThen Nothing ( saveDocument savePath doc' )
askForSavePath :: UIElements -> IO ( Maybe FilePath ) askForSavePath :: UIElements -> IO ( Maybe FilePath )
askForSavePath ( UIElements { .. } ) = do askForSavePath ( UIElements {..} ) = do
fileChooser <- fileChooser <-
GTK.fileChooserNativeNew ( Just "Save MetaBrush document..." ) ( Just window ) GTK.fileChooserNativeNew ( Just "Save MetaBrush document..." ) ( Just window )
GTK.FileChooserActionSave GTK.FileChooserActionSave
@ -287,44 +301,47 @@ pattern SaveAndClose = 2
pattern CancelClose = 3 pattern CancelClose = 3
instance HandleAction Close where instance HandleAction Close where
handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) close = do handleAction
mbDoc <- case close of uiElts@( UIElements { viewport = Viewport {..}, .. } )
CloseActive -> STM.atomically ( currentDocument vars ) vars@( Variables {..} )
CloseThis unique -> Map.lookup unique <$> STM.readTVarIO openDocumentsTVar close = do
case mbDoc of mbDoc <- case close of
Nothing -> pure () -- could show a warning message CloseActive -> STM.atomically ( currentDocument vars )
Just ( Document { displayName, documentUnique, unsavedChanges } ) CloseThis unique -> Map.lookup unique <$> STM.readTVarIO openDocumentsTVar
| unsavedChanges case mbDoc of
-> do Nothing -> pure () -- could show a warning message
dialog <- GTK.new GTK.MessageDialog [] Just ( Document { displayName, documentUnique, unsavedChanges } )
GTK.setMessageDialogText dialog ( " \n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?" ) | unsavedChanges
GTK.setMessageDialogMessageType dialog GTK.MessageTypeQuestion -> do
GTK.setWindowResizable dialog False dialog <- GTK.new GTK.MessageDialog []
GTK.setWindowDecorated dialog False GTK.setMessageDialogText dialog ( " \n\"" <> displayName <> "\" contains unsaved changes.\nClose anyway?" )
GTK.windowSetTransientFor dialog ( Just window ) GTK.setMessageDialogMessageType dialog GTK.MessageTypeQuestion
GTK.windowSetModal dialog True GTK.setWindowResizable dialog False
widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ] GTK.setWindowDecorated dialog False
closeButton <- GTK.dialogAddButton dialog "Close" JustClose GTK.windowSetTransientFor dialog ( Just window )
saveButton <- GTK.dialogAddButton dialog "Save and close" SaveAndClose GTK.windowSetModal dialog True
cancelButton <- GTK.dialogAddButton dialog "Cancel" CancelClose widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ]
GTK.dialogSetDefaultResponse dialog 1 closeButton <- GTK.dialogAddButton dialog "Close" JustClose
for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton" saveButton <- GTK.dialogAddButton dialog "Save and close" SaveAndClose
choice <- GTK.dialogRun dialog cancelButton <- GTK.dialogAddButton dialog "Cancel" CancelClose
GTK.widgetDestroy dialog GTK.dialogSetDefaultResponse dialog 1
case choice of for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton"
JustClose -> closeDocument documentUnique choice <- GTK.dialogRun dialog
SaveAndClose -> save uiElts vars False GTK.widgetDestroy dialog
_ -> pure () case choice of
| otherwise JustClose -> closeDocument documentUnique
-> closeDocument documentUnique SaveAndClose -> save uiElts vars False
_ -> pure ()
| otherwise
-> closeDocument documentUnique
where where
closeDocument :: Unique -> IO () closeDocument :: Unique -> IO ()
closeDocument unique = do closeDocument unique = do
removeFileTab vars unique removeFileTab vars unique
updateTitle window title Nothing updateTitle window title Nothing
updateInfoBar viewportDrawingArea infoBar vars updateInfoBar viewportDrawingArea infoBar vars
GTK.widgetQueueDraw viewportDrawingArea GTK.widgetQueueDraw viewportDrawingArea
--------------------- ---------------------
-- Switch document -- -- Switch document --
@ -334,19 +351,22 @@ data SwitchTo = SwitchTo Unique
deriving stock Show deriving stock Show
instance HandleAction SwitchTo where instance HandleAction SwitchTo where
handleAction ( UIElements { .. } ) vars@( Variables { .. } ) ( SwitchTo newUnique ) = do handleAction
mbNewDocAndTab <- STM.atomically do ( UIElements { viewport = Viewport {..}, .. } )
STM.writeTVar activeDocumentTVar ( Just newUnique ) vars@( Variables {..} )
newDoc <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar ( SwitchTo newUnique ) = do
newTab <- Map.lookup newUnique <$> STM.readTVar fileBarTabsTVar mbNewDocAndTab <- STM.atomically do
pure ( (,) <$> newDoc <*> newTab ) STM.writeTVar activeDocumentTVar ( Just newUnique )
case mbNewDocAndTab of newDoc <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar
Nothing -> updateTitle window title Nothing newTab <- Map.lookup newUnique <$> STM.readTVar fileBarTabsTVar
Just ( Document { .. }, tab ) -> do pure ( (,) <$> newDoc <*> newTab )
updateTitle window title ( Just ( displayName, unsavedChanges ) ) case mbNewDocAndTab of
updateInfoBar viewportDrawingArea infoBar vars Nothing -> updateTitle window title Nothing
GTK.widgetQueueDraw tab Just ( Document {..}, tab ) -> do
GTK.widgetQueueDraw viewportDrawingArea updateTitle window title ( Just ( displayName, unsavedChanges ) )
updateInfoBar viewportDrawingArea infoBar vars
GTK.widgetQueueDraw tab
GTK.widgetQueueDraw viewportDrawingArea
-------------- --------------
-- Quitting -- -- Quitting --
@ -469,8 +489,8 @@ data Confirm = Confirm
instance HandleAction Confirm where instance HandleAction Confirm where
handleAction handleAction
( UIElements { viewportDrawingArea } ) ( UIElements { viewport = Viewport {..} } )
( Variables { .. } ) ( Variables {..} )
_ _
= do = do
tool <- STM.readTVarIO toolTVar tool <- STM.readTVarIO toolTVar
@ -504,13 +524,13 @@ data MouseMove = MouseMove ( Point2D Double )
instance HandleAction MouseMove where instance HandleAction MouseMove where
handleAction handleAction
( UIElements { viewportDrawingArea, infoBar } ) ( UIElements { viewport = Viewport {..}, .. } )
vars@( Variables { mousePosTVar, modifiersTVar, toolTVar, partialPathTVar } ) vars@( Variables {..} )
( MouseMove ( Point2D x y ) ) ( MouseMove ( Point2D x y ) )
= do = do
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight 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 modifiers <- STM.readTVar modifiersTVar
let let
toViewport :: Point2D Double -> Point2D Double toViewport :: Point2D Double -> Point2D Double
@ -532,19 +552,26 @@ instance HandleAction MouseMove where
updateInfoBar viewportDrawingArea infoBar vars updateInfoBar viewportDrawingArea infoBar vars
GTK.widgetQueueDraw viewportDrawingArea GTK.widgetQueueDraw viewportDrawingArea
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
GTK.widgetQueueDraw drawingArea
----------------- -----------------
-- Mouse click -- -- 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 deriving stock Show
instance HandleAction MouseClick where instance HandleAction MouseClick where
handleAction handleAction
uiElts@( UIElements { viewportDrawingArea } ) uiElts@( UIElements { viewport = Viewport {..} } )
vars@( Variables { .. } ) vars@( Variables {..} )
( MouseClick button mouseClickCoords ) ( MouseClick actionOrigin button mouseClickCoords )
= case button of = case button of
-- Left mouse button. -- Left mouse button.
@ -558,50 +585,66 @@ instance HandleAction MouseClick where
pos :: Point2D Double pos :: Point2D Double
pos = toViewport mouseClickCoords pos = toViewport mouseClickCoords
STM.writeTVar mousePosTVar ( Just pos ) STM.writeTVar mousePosTVar ( Just pos )
modifiers <- STM.readTVar modifiersTVar case actionOrigin of
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. ViewportOrigin -> do
Pen -> do modifiers <- STM.readTVar modifiersTVar
mbPartialPath <- STM.readTVar partialPathTVar tool <- STM.readTVar toolTVar
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos ) mode <- STM.readTVar modeTVar
case mbPartialPath of case tool of
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke). -- Selection mode mouse hold:
Nothing -> do --
( newDoc, drawAnchor, anchorPt ) <- getOrCreateDrawAnchor uniqueSupply pos doc -- - If holding shift or alt, mouse hold initiates a rectangular selection.
STM.writeTVar partialPathTVar -- - If not holding shift or alt:
( Just $ PartialPath -- - if mouse click selected an object, initiate a drag move,
{ partialStartPos = anchorPt -- - otherwise, initiate a rectangular selection.
, partialControlPoint = Nothing Selection ->
, partialPathAnchor = drawAnchor case selectionMode modifiers of
, firstPoint = True -- Drag move: not holding shift or alt, click has selected something.
} New
) | Just newDoc <- dragMoveSelect mode pos doc
pure ( UpdateDocTo $ Just newDoc ) -> do
-- Path already started: indicate that we are continuing a path. STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos )
Just pp -> do pure ( UpdateDocTo $ Just newDoc )
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } ) -- Rectangular selection.
pure Don'tModifyDoc _ -> 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. -- Right mouse button: end partial path.
3 -> do 3 -> do
@ -621,8 +664,8 @@ data MouseRelease = MouseRelease Word32 ( Point2D Double )
instance HandleAction MouseRelease where instance HandleAction MouseRelease where
handleAction handleAction
uiElts@( UIElements { viewportDrawingArea } ) uiElts@( UIElements { viewport = Viewport {..} } )
vars@( Variables { .. } ) vars@( Variables {..} )
( MouseRelease button ( Point2D x y ) ) ( MouseRelease button ( Point2D x y ) )
= case button of = case button of
@ -639,101 +682,138 @@ instance HandleAction MouseRelease where
STM.writeTVar mousePosTVar ( Just pos ) STM.writeTVar mousePosTVar ( Just pos )
modifiers <- STM.readTVar modifiersTVar modifiers <- STM.readTVar modifiersTVar
mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing 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 tool <- STM.readTVar toolTVar
let mode <- STM.readTVar modeTVar
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 case tool of
mbPartialPath <- STM.readTVar partialPathTVar
case mbPartialPath of Selection -> do
-- 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 let
pathPoint :: Point2D Double selMode :: SelectionMode
mbControlPoint :: Maybe ( Point2D Double ) selMode = selectionMode modifiers
partialControlPoint :: Maybe ( Point2D Double ) case mbHoldPos of
( pathPoint, mbControlPoint, partialControlPoint ) Just hold
| Just ( DrawHold holdPos ) <- mbHoldPos | DragMoveHold pos0 <- hold
= ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos ) , pos0 /= pos
| otherwise -> pure ( UpdateDocTo $ Just $ translateSelection mode ( pos0 --> pos ) doc )
= ( pos, Nothing, Nothing ) | SelectionHold pos0 <- hold
( _, otherAnchor, otherAnchorPt ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc , pos0 /= pos
if not firstPoint && anchorsAreComplementary anchor otherAnchor -> pure ( UpdateDocTo $ Just $ selectRectangle mode selMode pos0 pos doc )
-- Close path. _ -> pure ( UpdateDocTo $ Just $ selectAt mode selMode pos doc )
then do
STM.writeTVar partialPathTVar Nothing Pen -> do
let mbPartialPath <- STM.readTVar partialPathTVar
newSegment :: Seq ( StrokePoint PointData ) case mbPartialPath of
newSegment -- Normal pen mode mouse click should have created an anchor.
= Seq.fromList -- If no anchor exists, then just ignore the mouse release event.
$ catMaybes Nothing -> pure Don'tModifyDoc
[ Just ( PathPoint p1 ( PointData Normal Empty ) ) -- Mouse click release possibilities:
, do --
cp <- mbCp2 -- - click was on complementary draw stroke draw anchor to close the path,
guard ( cp /= p1 ) -- - release at same point as click: finish current segment,
pure $ ControlPoint cp ( PointData Normal Empty ) -- - release at different point as click: finish current segment, adding a control point.
, do Just
cp <- mbControlPoint ( PartialPath
guard ( cp /= otherAnchorPt ) { partialStartPos = p1
pure $ ControlPoint cp ( PointData Normal Empty ) , partialControlPoint = mbCp2
, Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) ) , partialPathAnchor = anchor
] , firstPoint
pure ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc ) }
else ) -> do
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 let
newSegment :: Seq ( StrokePoint PointData ) pathPoint :: Point2D Double
newSegment mbControlPoint :: Maybe ( Point2D Double )
= Seq.fromList partialControlPoint :: Maybe ( Point2D Double )
$ catMaybes ( pathPoint, mbControlPoint, partialControlPoint )
[ Just ( PathPoint p1 ( PointData Normal Empty ) ) | Just ( DrawHold holdPos ) <- mbHoldPos
, do = ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos )
cp <- mbCp2 | otherwise
guard ( cp /= p1 ) = ( pos, Nothing, Nothing )
pure $ ControlPoint cp ( PointData Normal Empty ) ( _, otherAnchor, otherAnchorPt ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
, do if not firstPoint && anchorsAreComplementary anchor otherAnchor
cp <- mbControlPoint -- Close path.
guard ( cp /= pathPoint ) then do
pure $ ControlPoint cp ( PointData Normal Empty ) STM.writeTVar partialPathTVar Nothing
, Just ( PathPoint pathPoint ( PointData Normal Empty ) ) let
] newSegment :: Seq ( StrokePoint PointData )
pure ( UpdateDocTo $ Just $ addToAnchor anchor newSegment doc ) 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). -- Other mouse buttons: ignored (for the moment at least).
_ -> pure () _ -> pure ()
@ -746,59 +826,62 @@ data Scroll = Scroll ( Point2D Double ) ( Vector2D Double )
deriving stock Show deriving stock Show
instance HandleAction Scroll where 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 viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
unless ( dx == 0 && dy == 0 ) do unless ( dx == 0 && dy == 0 ) do
modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
modifiers <- STM.readTVar modifiersTVar modifiers <- STM.readTVar modifiersTVar
let let
toViewport :: Point2D Double -> Point2D Double toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter
-- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates) -- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates)
mousePos :: Point2D Double mousePos :: Point2D Double
mousePos = toViewport ( Point2D x y ) mousePos = toViewport ( Point2D x y )
newDoc :: Document newDoc :: Document
newDoc newDoc
-- Zooming using 'Control'. -- Zooming using 'Control'.
| any ( \ case { Control _ -> True; _ -> False } ) modifiers | any ( \ case { Control _ -> True; _ -> False } ) modifiers
= let = let
newZoomFactor :: Double newZoomFactor :: Double
newZoomFactor newZoomFactor
| dy > 0 | dy > 0
= max 0.0078125 ( oldZoomFactor / sqrt 2 ) = max 0.0078125 ( oldZoomFactor / sqrt 2 )
| otherwise | otherwise
= min 256 ( oldZoomFactor * sqrt 2 ) = min 256 ( oldZoomFactor * sqrt 2 )
newCenter :: Point2D Double newCenter :: Point2D Double
newCenter newCenter
= ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double ) = ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double )
• oldCenter • oldCenter
in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter } in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }
-- Vertical scrolling turned into horizontal scrolling using 'Shift'. -- Vertical scrolling turned into horizontal scrolling using 'Shift'.
| dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers | dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers
= let = let
newCenter :: Point2D Double newCenter :: Point2D Double
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter
in doc { viewportCenter = newCenter } in doc { viewportCenter = newCenter }
-- Vertical scrolling. -- Vertical scrolling.
| otherwise | otherwise
= let = let
newCenter :: Point2D Double newCenter :: Point2D Double
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter
in doc { viewportCenter = newCenter } in doc { viewportCenter = newCenter }
finalZoomFactor :: Double finalZoomFactor :: Double
finalZoomFactor = zoomFactor newDoc finalZoomFactor = zoomFactor newDoc
finalCenter :: Point2D Double finalCenter :: Point2D Double
finalCenter = viewportCenter newDoc finalCenter = viewportCenter newDoc
toFinalViewport :: Point2D Double -> Point2D Double toFinalViewport :: Point2D Double -> Point2D Double
toFinalViewport = toViewportCoordinates finalZoomFactor ( viewportWidth, viewportHeight ) finalCenter toFinalViewport = toViewportCoordinates finalZoomFactor ( viewportWidth, viewportHeight ) finalCenter
finalMousePos :: Point2D Double finalMousePos :: Point2D Double
finalMousePos = toFinalViewport ( Point2D x y ) finalMousePos = toFinalViewport ( Point2D x y )
STM.writeTVar mousePosTVar ( Just finalMousePos ) STM.writeTVar mousePosTVar ( Just finalMousePos )
pure ( UpdateDocTo $ Just newDoc ) pure ( UpdateDocTo $ Just newDoc )
updateInfoBar viewportDrawingArea infoBar vars updateInfoBar viewportDrawingArea infoBar vars
-------------------- --------------------
-- Keyboard press -- -- Keyboard press --
@ -808,47 +891,50 @@ data KeyboardPress = KeyboardPress Word32
deriving stock Show deriving stock Show
instance HandleAction KeyboardPress where 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.atomically do
!modifiers <- STM.readTVar modifiersTVar !modifiers <- STM.readTVar modifiersTVar
for_ ( modifierKey keyCode ) \ modifier -> for_ ( modifierKey keyCode ) \ modifier ->
( STM.writeTVar modifiersTVar ( Set.insert modifier modifiers ) ) ( STM.writeTVar modifiersTVar ( Set.insert modifier modifiers ) )
pure 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
| ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R | ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R
-> do -> do
---------------------------------------------------------- ----------------------------------------------------------
-- With the pen tool, pressing control moves -- With the pen tool, pressing control moves
-- the partial point control point to the mouse position. -- the partial point control point to the mouse position.
tool <- STM.readTVarIO toolTVar tool <- STM.readTVarIO toolTVar
mbMousePos <- STM.readTVarIO mousePosTVar mbMousePos <- STM.readTVarIO mousePosTVar
mbPartialPath <- STM.readTVarIO partialPathTVar mbPartialPath <- STM.readTVarIO partialPathTVar
case tool of case tool of
Pen Pen
| Just mp <- mbMousePos | Just mp <- mbMousePos
, Just pp <- mbPartialPath , Just pp <- mbPartialPath
-> do -> do
STM.atomically $ STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } ) STM.atomically $ STM.writeTVar partialPathTVar ( Just $ pp { partialControlPoint = Just mp } )
GTK.widgetQueueDraw viewportDrawingArea GTK.widgetQueueDraw viewportDrawingArea
_ -> pure () _ -> pure ()
-- todo: these should be handled by accelerator, -- todo: these should be handled by accelerator,
-- but those are not working currently -- but those are not working currently
GDK.KEY_Delete -> handleAction uiElts vars Delete GDK.KEY_Delete -> handleAction uiElts vars Delete
GDK.KEY_s GDK.KEY_s
| any ( \case { Control _ -> True; _ -> False } ) modifiers | any ( \case { Control _ -> True; _ -> False } ) modifiers
-> handleAction uiElts vars Save -> handleAction uiElts vars Save
_ -> pure () _ -> pure ()
---------------------- ----------------------
-- Keyboard release -- -- Keyboard release --

2
src/app/MetaBrush/Asset/CloseTabButton.hs
View file

@ -22,7 +22,7 @@ import MetaBrush.Util
-- | "Close tab" button. -- | "Close tab" button.
drawCloseTabButton :: Colours -> Bool -> [ GTK.StateFlags ] -> Cairo.Render Bool drawCloseTabButton :: Colours -> Bool -> [ GTK.StateFlags ] -> Cairo.Render Bool
drawCloseTabButton ( Colours { .. } ) unsavedChanges flags = do drawCloseTabButton ( Colours {..} ) unsavedChanges flags = do
Cairo.setLineCap Cairo.LineCapRound Cairo.setLineCap Cairo.LineCapRound
Cairo.setLineJoin Cairo.LineJoinMiter Cairo.setLineJoin Cairo.LineJoinMiter

5
src/app/MetaBrush/Asset/Colours.hs
View file

@ -36,7 +36,7 @@ data ColourRecord a
, path, brush, brushStroke, brushCenter , path, brush, brushStroke, brushCenter
, pointHover, pointSelected , pointHover, pointSelected
, viewport, viewportScrollbar, tabScrollbar , viewport, viewportScrollbar, tabScrollbar
, magnifier, glass , guide, magnifier, glass
, selected, selectedOutline :: !a , selected, selectedOutline :: !a
} }
deriving stock ( Show, Functor, Foldable, Traversable ) deriving stock ( Show, Functor, Foldable, Traversable )
@ -78,6 +78,7 @@ colourNames = Colours
, viewport = ColourName "viewport" BackgroundColour [ GTK.StateFlagsNormal ] , viewport = ColourName "viewport" BackgroundColour [ GTK.StateFlagsNormal ]
, viewportScrollbar = ColourName "viewportScrollbar" BackgroundColour [ GTK.StateFlagsNormal ] , viewportScrollbar = ColourName "viewportScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]
, tabScrollbar = ColourName "tabScrollbar" BackgroundColour [ GTK.StateFlagsNormal ] , tabScrollbar = ColourName "tabScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]
, guide = ColourName "guide" Colour [ GTK.StateFlagsNormal ]
, magnifier = ColourName "magnifier" Colour [ GTK.StateFlagsNormal ] , magnifier = ColourName "magnifier" Colour [ GTK.StateFlagsNormal ]
, glass = ColourName "glass" Colour [ GTK.StateFlagsNormal ] , glass = ColourName "glass" Colour [ GTK.StateFlagsNormal ]
, selected = ColourName "selected" Colour [ GTK.StateFlagsNormal ] , selected = ColourName "selected" Colour [ GTK.StateFlagsNormal ]
@ -88,7 +89,7 @@ type Colours = ColourRecord GDK.RGBA
getColours :: GTK.WidgetPath -> IO Colours getColours :: GTK.WidgetPath -> IO Colours
getColours windowWidgetPath = getColours windowWidgetPath =
for colourNames \ ( ColourName { .. } ) -> do for colourNames \ ( ColourName {..} ) -> do
style <- GTK.styleContextNew style <- GTK.styleContextNew
GTK.styleContextSetPath style windowWidgetPath GTK.styleContextSetPath style windowWidgetPath
GTK.styleContextAddClass style colourName GTK.styleContextAddClass style colourName

2
src/app/MetaBrush/Asset/Tools.hs
View file

@ -100,7 +100,7 @@ drawMeta ( Colours { splash } ) = do
-- | Path icon. Width = 40 height = 40. -- | Path icon. Width = 40 height = 40.
drawPath :: Colours -> Cairo.Render Bool drawPath :: Colours -> Cairo.Render Bool
drawPath ( Colours { .. } ) = do drawPath ( Colours {..} ) = do
Cairo.setLineCap Cairo.LineCapRound Cairo.setLineCap Cairo.LineCapRound
Cairo.setLineJoin Cairo.LineJoinMiter Cairo.setLineJoin Cairo.LineJoinMiter

34
src/app/MetaBrush/Context.hs
View file

@ -11,7 +11,7 @@
module MetaBrush.Context module MetaBrush.Context
( UIElements(..), Variables(..) ( UIElements(..), Variables(..)
, LR(..), Modifier(..), modifierKey, modifierType , LR(..), Modifier(..), modifierKey, modifierType
, HoldAction(..), PartialPath(..) , HoldAction(..), GuideAction(..), PartialPath(..)
, currentDocument, withCurrentDocument , currentDocument, withCurrentDocument
, PureDocModification(..), DocModification(..) , PureDocModification(..), DocModification(..)
, modifyingCurrentDocument , modifyingCurrentDocument
@ -76,6 +76,8 @@ import {-# SOURCE #-} MetaBrush.UI.InfoBar
( InfoBar, updateInfoBar ) ( InfoBar, updateInfoBar )
import MetaBrush.UI.ToolBar import MetaBrush.UI.ToolBar
( Tool, Mode ) ( Tool, Mode )
import MetaBrush.UI.Viewport
( Viewport(..), Ruler(..) )
import MetaBrush.Unique import MetaBrush.Unique
( UniqueSupply, Unique ) ( UniqueSupply, Unique )
import MetaBrush.Util import MetaBrush.Util
@ -85,13 +87,13 @@ import MetaBrush.Util
data UIElements data UIElements
= UIElements = UIElements
{ window :: !GTK.Window { window :: !GTK.Window
, title :: !GTK.Label , title :: !GTK.Label
, titleBar :: !GTK.Box , titleBar :: !GTK.Box
, fileBar :: !FileBar , fileBar :: !FileBar
, viewportDrawingArea :: !GTK.DrawingArea , viewport :: !Viewport
, infoBar :: !InfoBar , infoBar :: !InfoBar
, colours :: !Colours , colours :: !Colours
} }
data Variables data Variables
@ -133,15 +135,25 @@ modifierType ( Control _ ) = GDK.ModifierTypeControlMask
modifierType ( Alt _ ) = GDK.ModifierTypeMod1Mask modifierType ( Alt _ ) = GDK.ModifierTypeMod1Mask
modifierType ( Shift _ ) = GDK.ModifierTypeShiftMask modifierType ( Shift _ ) = GDK.ModifierTypeShiftMask
data GuideAction
= CreateGuide !Ruler
| MoveGuide !Unique
deriving stock Show
-- | Keep track of a mouse hold action: -- | Keep track of a mouse hold action:
-- --
-- - start a rectangular selection, -- - start a rectangular selection,
-- - move objects by dragging, -- - move objects by dragging,
-- - drawing a control point. -- - drawing a control point,
-- - create/modify a guide.
data HoldAction data HoldAction
= SelectionHold { holdStartPos :: !( Point2D Double ) } = SelectionHold { holdStartPos :: !( Point2D Double ) }
| DragMoveHold { holdStartPos :: !( Point2D Double ) } | DragMoveHold { holdStartPos :: !( Point2D Double ) }
| DrawHold { holdStartPos :: !( Point2D Double ) } | DrawHold { holdStartPos :: !( Point2D Double ) }
| GuideAction { holdStartPos :: !( Point2D Double )
, guideAction :: !GuideAction
}
deriving stock Show deriving stock Show
-- | Keep track of a path that is in the middle of being drawn. -- | 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. -- Does nothing if no document is currently active.
modifyingCurrentDocument :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO () 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 mbAction <- STM.atomically . runMaybeT $ do
unique <- MaybeT ( STM.readTVar activeDocumentTVar ) unique <- MaybeT ( STM.readTVar activeDocumentTVar )
oldDoc <- MaybeT ( Map.lookup unique <$> STM.readTVar openDocumentsTVar ) oldDoc <- MaybeT ( Map.lookup unique <$> STM.readTVar openDocumentsTVar )
@ -219,6 +231,8 @@ modifyingCurrentDocument ( UIElements { .. } ) vars@( Variables { .. } ) f = do
Just ( Document { displayName, unsavedChanges } ) -> do Just ( Document { displayName, unsavedChanges } ) -> do
updateTitle window title ( Just ( displayName, unsavedChanges ) ) updateTitle window title ( Just ( displayName, unsavedChanges ) )
GTK.widgetQueueDraw viewportDrawingArea GTK.widgetQueueDraw viewportDrawingArea
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
GTK.widgetQueueDraw drawingArea
for_ mbActiveTab GTK.widgetQueueDraw for_ mbActiveTab GTK.widgetQueueDraw
sequenceAOf_ actionFold modif sequenceAOf_ actionFold modif
sequenceA_ mbAction sequenceA_ mbAction

18
src/app/MetaBrush/Document.hs
View file

@ -9,7 +9,7 @@
module MetaBrush.Document module MetaBrush.Document
( AABB(..) ( AABB(..)
, Document(..), emptyDocument , Document(..), emptyDocument
, Stroke(..) , Stroke(..), Guide(..)
, PointData(..), BrushPointData(..) , PointData(..), BrushPointData(..)
, FocusState(..) , FocusState(..)
, _selection, _brush , _selection, _brush
@ -21,6 +21,10 @@ import GHC.Generics
( Generic ) ( Generic )
-- containers -- containers
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
( empty )
import Data.Sequence import Data.Sequence
( Seq ) ( Seq )
@ -42,7 +46,7 @@ import Data.Text
import Math.Bezier.Stroke import Math.Bezier.Stroke
( StrokePoint(..) ) ( StrokePoint(..) )
import Math.Vector2D import Math.Vector2D
( Point2D(..) ) ( Point2D(..), Vector2D(..) )
import MetaBrush.Unique import MetaBrush.Unique
( Unique ) ( Unique )
@ -62,6 +66,7 @@ data Document
, zoomFactor :: !Double , zoomFactor :: !Double
, documentUnique :: Unique , documentUnique :: Unique
, strokes :: ![ Stroke ] , strokes :: ![ Stroke ]
, guides :: !( Map Unique Guide )
} }
deriving stock ( Show, Generic ) deriving stock ( Show, Generic )
@ -74,6 +79,14 @@ data Stroke
} }
deriving stock ( Show, Generic ) 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 data PointData
= PointData = PointData
{ pointState :: FocusState { pointState :: FocusState
@ -108,4 +121,5 @@ emptyDocument docName unique =
, zoomFactor = 1 , zoomFactor = 1
, documentUnique = unique , documentUnique = unique
, strokes = [] , strokes = []
, guides = Map.empty
} }

91
src/app/MetaBrush/Document/Guide.hs Normal file
View 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 )

52
src/app/MetaBrush/Document/Serialise.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
@ -11,6 +12,8 @@ module MetaBrush.Document.Serialise
where where
-- base -- base
import Control.Arrow
( (&&&) )
import Control.Monad import Control.Monad
( unless ) ( unless )
import qualified Data.Bifunctor as Bifunctor import qualified Data.Bifunctor as Bifunctor
@ -39,6 +42,10 @@ import qualified Data.ByteString.Lazy.Builder as Lazy.ByteString.Builder
( toLazyByteString ) ( toLazyByteString )
-- containers -- containers
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
( fromList, elems )
import Data.Sequence import Data.Sequence
( Seq ) ( Seq )
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
@ -52,6 +59,14 @@ import System.Directory
import System.FilePath import System.FilePath
( takeDirectory ) ( takeDirectory )
-- generic-lens
import Data.Generics.Product.Typed
( HasType(typed) )
-- lens
import Control.Lens
( view )
-- scientific -- scientific
import qualified Data.Scientific as Scientific import qualified Data.Scientific as Scientific
( fromFloatDigits, toRealFloat ) ( fromFloatDigits, toRealFloat )
@ -102,16 +117,17 @@ import qualified Waargonaut.Prettier as TonyMorris
import Math.Bezier.Stroke import Math.Bezier.Stroke
( StrokePoint(..) ) ( StrokePoint(..) )
import Math.Vector2D import Math.Vector2D
( Point2D(..) ) ( Point2D(..), Vector2D(..) )
import MetaBrush.Document import MetaBrush.Document
( Document(..) ( Document(..)
, Stroke(..) , Stroke(..)
, Guide(..)
, PointData(..) , PointData(..)
, BrushPointData(..) , BrushPointData(..)
, FocusState(..) , FocusState(..)
) )
import MetaBrush.Unique 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 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 :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Vector2D a )
encodeVector2D enc = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) -> encodeVector2D enc = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) ->
JSON.Encoder.atKey' "x" enc x 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 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 :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Mat22 a )
encodeMat22 enc = JSON.Encoder.mapLikeObj \ ( Mat22 m00 m01 m10 m11 ) -> encodeMat22 enc = JSON.Encoder.mapLikeObj \ ( Mat22 m00 m01 m10 m11 ) ->
JSON.Encoder.atKey' "m00" enc m00 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 :: Applicative f => JSON.Encoder f PointData
encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointState, brushShape } ) -> encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointState, brushShape } ) ->
JSON.Encoder.atKey' "focus" encodeFocusState pointState 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 :: 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' "name" JSON.Encoder.text displayName
. JSON.Encoder.atKey' "center" ( encodePoint2D encodeDouble ) viewportCenter . JSON.Encoder.atKey' "center" ( encodePoint2D encodeDouble ) viewportCenter
. JSON.Encoder.atKey' "zoom" encodeDouble zoomFactor . JSON.Encoder.atKey' "zoom" encodeDouble zoomFactor
. JSON.Encoder.atKey' "strokes" ( JSON.Encoder.list encodeStroke ) strokes . 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 :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document
decodeDocument uniqueSupply mbFilePath = do decodeDocument uniqueSupply mbFilePath = do
@ -328,4 +367,5 @@ decodeDocument uniqueSupply mbFilePath = do
zoomFactor <- JSON.Decoder.atKey "zoom" decodeDouble zoomFactor <- JSON.Decoder.atKey "zoom" decodeDouble
documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply ) documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
strokes <- JSON.Decoder.atKey "strokes" ( JSON.Decoder.list ( decodeStroke 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 } )

78
src/app/MetaBrush/Event.hs
View file

@ -1,9 +1,15 @@
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Event module MetaBrush.Event
( handleEvents ) ( handleEvents )
where where
-- base
import Control.Monad
( void )
-- gi-gdk -- gi-gdk
import qualified GI.Gdk as GDK import qualified GI.Gdk as GDK
@ -15,68 +21,96 @@ import Math.Vector2D
( Point2D(..), Vector2D(..) ) ( Point2D(..), Vector2D(..) )
import MetaBrush.Action import MetaBrush.Action
( HandleAction(..) ( HandleAction(..)
, ActionOrigin(..)
, MouseMove(..), MouseClick(..), MouseRelease(..) , MouseMove(..), MouseClick(..), MouseRelease(..)
, Scroll(..), KeyboardPress(..), KeyboardRelease(..) , Scroll(..), KeyboardPress(..), KeyboardRelease(..)
, quitEverything , quitEverything
) )
import MetaBrush.Context import MetaBrush.Context
( UIElements(..), Variables(..) ) ( UIElements(..), Variables(..) )
import MetaBrush.UI.Viewport
( Viewport(..), Ruler(..) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
handleEvents :: UIElements -> Variables -> IO () handleEvents :: UIElements -> Variables -> IO ()
handleEvents elts@( UIElements { window, viewportDrawingArea } ) vars = do handleEvents elts@( UIElements { viewport = Viewport {..}, .. } ) vars = do
-- Mouse events -- Mouse events
_ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea ( handleMotionEvent elts vars ) onWidgetMouseEvent viewportDrawingArea ViewportOrigin
_ <- GTK.onWidgetScrollEvent viewportDrawingArea ( handleScrollEvent elts vars ) onWidgetMouseEvent rulerCornerDrawingArea ( RulerOrigin RulerCorner )
_ <- GTK.onWidgetButtonPressEvent viewportDrawingArea ( handleMouseButtonEvent elts vars ) onWidgetMouseEvent leftRulerDrawingArea ( RulerOrigin LeftRuler )
_ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea ( handleMouseButtonRelease elts vars ) onWidgetMouseEvent topRulerDrawingArea ( RulerOrigin TopRuler )
-- Keyboard events -- Keyboard events
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent elts vars ) void $ GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent elts vars )
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars ) void $ GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars )
-- Window quit -- 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. -- Mouse events.
handleMotionEvent :: UIElements -> Variables -> GDK.EventMotion -> IO Bool handleMotionEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventMotion -> IO Bool
handleMotionEvent elts vars eventMotion = do handleMotionEvent elts vars eventOrigin eventMotion = do
x <- GDK.getEventMotionX eventMotion x <- GDK.getEventMotionX eventMotion
y <- GDK.getEventMotionY 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 pure True
handleScrollEvent :: UIElements -> Variables -> GDK.EventScroll -> IO Bool handleScrollEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventScroll -> IO Bool
handleScrollEvent elts vars scrollEvent = do handleScrollEvent elts vars eventOrigin scrollEvent = do
dx <- GDK.getEventScrollDeltaX scrollEvent dx <- GDK.getEventScrollDeltaX scrollEvent
dy <- GDK.getEventScrollDeltaY scrollEvent dy <- GDK.getEventScrollDeltaY scrollEvent
x <- GDK.getEventScrollX scrollEvent x <- GDK.getEventScrollX scrollEvent
y <- GDK.getEventScrollY 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 pure False
handleMouseButtonEvent :: UIElements -> Variables -> GDK.EventButton -> IO Bool handleMouseButtonEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool
handleMouseButtonEvent elts vars mouseClickEvent = do handleMouseButtonEvent elts vars eventOrigin mouseClickEvent = do
button <- GDK.getEventButtonButton mouseClickEvent button <- GDK.getEventButtonButton mouseClickEvent
x <- GDK.getEventButtonX mouseClickEvent x <- GDK.getEventButtonX mouseClickEvent
y <- GDK.getEventButtonY 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 pure False
handleMouseButtonRelease :: UIElements -> Variables -> GDK.EventButton -> IO Bool handleMouseButtonRelease :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool
handleMouseButtonRelease elts vars mouseReleaseEvent = do handleMouseButtonRelease elts vars eventOrigin mouseReleaseEvent = do
button <- GDK.getEventButtonButton mouseReleaseEvent button <- GDK.getEventButtonButton mouseReleaseEvent
x <- GDK.getEventButtonX mouseReleaseEvent x <- GDK.getEventButtonX mouseReleaseEvent
y <- GDK.getEventButtonY 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 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. -- Keyboard events.

113
src/app/MetaBrush/Render/Document.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DerivingVia #-}
@ -8,16 +9,17 @@
{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Render.Document module MetaBrush.Render.Document
( renderDocument, blankRender ) ( renderDocument, renderGuides, blankRender )
where where
-- base -- base
import Control.Monad import Control.Monad
( guard, when, unless ) ( guard, when, unless )
import Data.Foldable import Data.Foldable
( for_, sequenceA_ ) ( for_, sequenceA_, toList )
import Data.Functor.Compose import Data.Functor.Compose
( Compose(..) ) ( Compose(..) )
import Data.Int import Data.Int
@ -36,6 +38,8 @@ import Data.Act
) )
-- containers -- containers
import qualified Data.Map as Map
( adjust )
import Data.Sequence import Data.Sequence
( Seq(..) ) ( Seq(..) )
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
@ -46,6 +50,8 @@ import Generic.Data
( Generically1(..) ) ( Generically1(..) )
-- generic-lens -- generic-lens
import Data.Generics.Product.Fields
( field' )
import Data.Generics.Product.Typed import Data.Generics.Product.Typed
( HasType ) ( HasType )
@ -54,7 +60,7 @@ import qualified GI.Cairo.Render as Cairo
-- lens -- lens
import Control.Lens import Control.Lens
( view ) ( view, over )
-- MetaBrush -- MetaBrush
import qualified Math.Bezier.Cubic as Cubic import qualified Math.Bezier.Cubic as Cubic
@ -65,13 +71,15 @@ import Math.Bezier.Stroke
( StrokePoint(..), stroke ) ( StrokePoint(..), stroke )
import Math.Vector2D import Math.Vector2D
( Point2D(..), Vector2D(..) ) ( Point2D(..), Vector2D(..) )
import MetaBrush.Action
( ActionOrigin(..) )
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( Colours, ColourRecord(..) ) ( Colours, ColourRecord(..) )
import MetaBrush.Context import MetaBrush.Context
( HoldAction(..), PartialPath(..) ) ( HoldAction(..), GuideAction(..), PartialPath(..) )
import MetaBrush.Document import MetaBrush.Document
( Document(..) ( Document(..)
, Stroke(..), FocusState(..) , Stroke(..), Guide(..), FocusState(..)
, PointData(..), BrushPointData(..) , PointData(..), BrushPointData(..)
, _selection , _selection
) )
@ -79,6 +87,8 @@ import MetaBrush.Document.Selection
( translateSelection ) ( translateSelection )
import MetaBrush.UI.ToolBar import MetaBrush.UI.ToolBar
( Mode(..) ) ( Mode(..) )
import MetaBrush.UI.Viewport
( Ruler(..) )
import MetaBrush.Util import MetaBrush.Util
( withRGBA ) ( withRGBA )
@ -105,7 +115,7 @@ toAll action = Compose ( pure action )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
blankRender :: Colours -> Cairo.Render () blankRender :: Colours -> Cairo.Render ()
blankRender ( Colours { .. } ) = pure () blankRender ( Colours {..} ) = pure ()
renderDocument renderDocument
:: Colours -> Mode -> ( Int32, Int32 ) :: Colours -> Mode -> ( Int32, Int32 )
@ -176,6 +186,73 @@ renderDocument
pure () 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 :: Colours -> Mode -> Double -> Stroke -> Compose Renders Cairo.Render ()
renderStroke cols@( Colours { brush } ) mode zoom ( Stroke { strokePoints = pts, strokeVisible } ) renderStroke cols@( Colours { brush } ) mode zoom ( Stroke { strokePoints = pts, strokeVisible } )
| strokeVisible | strokeVisible
@ -276,8 +353,24 @@ renderBrushShape cols zoom pt =
*> Compose blank { renderPPts = drawCross cols zoom } *> Compose blank { renderPPts = drawCross cols zoom }
*> toAll Cairo.restore *> 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 :: 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 = do
let let
hsqrt3 :: Double hsqrt3 :: Double
@ -311,7 +404,7 @@ drawPoint ( Colours { .. } ) zoom pt@( PathPoint { coords = Point2D x y } )
Cairo.restore Cairo.restore
drawPoint ( Colours { .. } ) zoom pt@( ControlPoint { coords = Point2D x y } ) drawPoint ( Colours {..} ) zoom pt@( ControlPoint { coords = Point2D x y } )
= do = do
let let
selectionState :: FocusState selectionState :: FocusState
@ -450,7 +543,7 @@ drawStroke ( Colours { brushStroke } ) strokeData = do
go' p0 ps = error $ "drawStroke: unrecognised stroke type\n" <> show ( p0 :<| ps ) go' p0 ps = error $ "drawStroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
drawSelectionRectangle :: Colours -> Double -> Point2D Double -> Point2D Double -> Cairo.Render () 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 Cairo.save
@ -470,7 +563,7 @@ drawSelectionRectangle ( Colours { .. } ) zoom ( Point2D x0 y0 ) ( Point2D x1 y1
Cairo.restore Cairo.restore
drawCross :: Colours -> Double -> Cairo.Render () drawCross :: Colours -> Double -> Cairo.Render ()
drawCross ( Colours { .. } ) zoom = do drawCross ( Colours {..} ) zoom = do
Cairo.save Cairo.save
Cairo.setLineWidth 1.5 Cairo.setLineWidth 1.5

8
src/app/MetaBrush/UI/Coordinates.hs
View file

@ -29,7 +29,7 @@ import qualified Math.Bezier.Quadratic as Quadratic
import Math.Bezier.Stroke import Math.Bezier.Stroke
( StrokePoint(..) ) ( StrokePoint(..) )
import Math.Module import Math.Module
( (*^), squaredNorm, closestPointToLine ) ( (*^), squaredNorm, closestPointToSegment )
import Math.Vector2D import Math.Vector2D
( Point2D(..), Vector2D(..) ) ( Point2D(..), Vector2D(..) )
import MetaBrush.Document import MetaBrush.Document
@ -55,19 +55,19 @@ closestPoint c ( Stroke { strokePoints = pt0 :<| pts, strokeVisible = True } ) =
-- Line. -- Line.
go ( PathPoint { coords = p0 } ) go ( PathPoint { coords = p0 } )
( sp1@( PathPoint { coords = p1 } ) :<| ps ) ( sp1@( PathPoint { coords = p1 } ) :<| ps )
= res ( closestPointToLine @( Vector2D Double ) c p0 p1 ) = res ( closestPointToSegment @( Vector2D Double ) c p0 p1 )
<> go sp1 ps <> go sp1 ps
-- Quadratic Bézier curve. -- Quadratic Bézier curve.
go ( PathPoint { coords = p0 } ) go ( PathPoint { coords = p0 } )
( ControlPoint { coords = p1 } :<| sp2@( PathPoint { coords = p2 } ) :<| ps ) ( ControlPoint { coords = p1 } :<| sp2@( PathPoint { coords = p2 } ) :<| ps )
= fmap ( fmap ( Just . snd ) ) = fmap ( fmap ( Just . snd ) )
( Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier { .. } ) c ) ( Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier {..} ) c )
<> go sp2 ps <> go sp2 ps
-- Cubic Bézier curve. -- Cubic Bézier curve.
go ( PathPoint { coords = p0 } ) go ( PathPoint { coords = p0 } )
( PathPoint { coords = p1 } :<| PathPoint { coords = p2 } :<| sp3@( PathPoint { coords = p3 } ) :<| ps ) ( PathPoint { coords = p1 } :<| PathPoint { coords = p2 } :<| sp3@( PathPoint { coords = p3 } ) :<| ps )
= fmap ( fmap ( Just . snd ) ) = fmap ( fmap ( Just . snd ) )
( Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier { .. } ) c ) ( Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier {..} ) c )
<> go sp3 ps <> go sp3 ps
go p0 ps = error $ "closestPoint: unrecognised stroke type\n" <> show ( p0 :<| ps ) go p0 ps = error $ "closestPoint: unrecognised stroke type\n" <> show ( p0 :<| ps )
closestPoint _ _ = Min $ Arg ( 1 / 0 ) Nothing closestPoint _ _ = Min $ Arg ( 1 / 0 ) Nothing

19
src/app/MetaBrush/UI/FileBar.hs
View file

@ -49,7 +49,9 @@ import MetaBrush.Context
import MetaBrush.Document import MetaBrush.Document
( Document(..), emptyDocument ) ( Document(..), emptyDocument )
import {-# SOURCE #-} MetaBrush.UI.InfoBar import {-# SOURCE #-} MetaBrush.UI.InfoBar
( InfoBar ) ( InfoBar, updateInfoBar )
import MetaBrush.UI.Viewport
( Viewport(..) )
import MetaBrush.Unique import MetaBrush.Unique
( Unique, freshUnique, uniqueText ) ( Unique, freshUnique, uniqueText )
import MetaBrush.Util import MetaBrush.Util
@ -78,8 +80,8 @@ newFileTab
-> TabLocation -> TabLocation
-> IO () -> IO ()
newFileTab newFileTab
uiElts@( UIElements { fileBar = FileBar {..}, .. } ) uiElts@( UIElements { fileBar = FileBar {..}, viewport = Viewport {..}, .. } )
vars@( Variables { .. } ) vars@( Variables {..} )
mbDoc mbDoc
newTabLoc newTabLoc
= do = do
@ -157,6 +159,7 @@ newFileTab
STM.writeTVar activeDocumentTVar ( Just newUnique ) STM.writeTVar activeDocumentTVar ( Just newUnique )
GTK.widgetQueueDraw viewportDrawingArea GTK.widgetQueueDraw viewportDrawingArea
updateInfoBar viewportDrawingArea infoBar vars
void $ GTK.onButtonClicked pgButton do void $ GTK.onButtonClicked pgButton do
isActive <- GTK.toggleButtonGetActive pgButton isActive <- GTK.toggleButtonGetActive pgButton
@ -181,12 +184,12 @@ newFileTab
-- Updates the active document when buttons are clicked. -- Updates the active document when buttons are clicked.
createFileBar createFileBar
:: Colours -> Variables :: Colours -> Variables
-> GTK.Window -> GTK.Box -> GTK.Label -> GTK.DrawingArea -> InfoBar -> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar
-> IO FileBar -> IO FileBar
createFileBar createFileBar
colours colours
vars@( Variables { openDocumentsTVar } ) vars@( Variables { openDocumentsTVar } )
window titleBar title viewportDrawingArea infoBar window titleBar title viewport infoBar
= do = do
-- Create file bar: box containing scrollable tabs, and a "+" button after it. -- Create file bar: box containing scrollable tabs, and a "+" button after it.
@ -212,9 +215,9 @@ createFileBar
let let
fileBar :: FileBar fileBar :: FileBar
fileBar = FileBar { .. } fileBar = FileBar {..}
uiElements :: UIElements uiElements :: UIElements
uiElements = UIElements { .. } uiElements = UIElements {..}
documents <- STM.readTVarIO openDocumentsTVar documents <- STM.readTVarIO openDocumentsTVar
for_ documents \ doc -> for_ documents \ doc ->
@ -233,7 +236,7 @@ createFileBar
-- | Close a document: remove the corresponding file tab from the file bar. -- | Close a document: remove the corresponding file tab from the file bar.
removeFileTab :: Variables -> Unique -> IO () removeFileTab :: Variables -> Unique -> IO ()
removeFileTab ( Variables { .. } ) docUnique = do removeFileTab ( Variables {..} ) docUnique = do
cleanupAction <- STM.atomically do cleanupAction <- STM.atomically do
-- Remove the tab. -- Remove the tab.

4
src/app/MetaBrush/UI/FileBar.hs-boot
View file

@ -17,6 +17,8 @@ import MetaBrush.Document
( Document ) ( Document )
import {-# SOURCE #-} MetaBrush.UI.InfoBar import {-# SOURCE #-} MetaBrush.UI.InfoBar
( InfoBar ) ( InfoBar )
import MetaBrush.UI.Viewport
( Viewport )
import MetaBrush.Unique import MetaBrush.Unique
( Unique ) ( Unique )
@ -37,7 +39,7 @@ instance Show TabLocation
createFileBar createFileBar
:: Colours -> Variables :: Colours -> Variables
-> GTK.Window -> GTK.Box -> GTK.Label -> GTK.DrawingArea -> InfoBar -> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar
-> IO FileBar -> IO FileBar
newFileTab newFileTab

20
src/app/MetaBrush/UI/InfoBar.hs
View file

@ -96,7 +96,7 @@ createInfoBar colours = do
-- Magnifier -- Magnifier
magnifierArea <- GTK.drawingAreaNew magnifierArea <- GTK.drawingAreaNew
zoomText <- GTK.labelNew ( Just " 100.00%" ) zoomText <- GTK.labelNew ( Just na )
GTK.boxPackStart zoomBox magnifierArea True True 0 GTK.boxPackStart zoomBox magnifierArea True True 0
GTK.boxPackStart zoomBox zoomText True True 0 GTK.boxPackStart zoomBox zoomText True True 0
@ -111,7 +111,7 @@ createInfoBar colours = do
-- Cursor position -- Cursor position
cursorPosArea <- GTK.drawingAreaNew 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 cursorPosArea False False 0
GTK.boxPackStart cursorPosBox cursorPosText False False 0 GTK.boxPackStart cursorPosBox cursorPosText False False 0
@ -126,7 +126,7 @@ createInfoBar colours = do
-- Top left position -- Top left position
topLeftPosArea <- GTK.drawingAreaNew 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 topLeftPosArea False False 0
GTK.boxPackStart topLeftPosBox topLeftPosText False False 0 GTK.boxPackStart topLeftPosBox topLeftPosText False False 0
@ -139,7 +139,7 @@ createInfoBar colours = do
-- Bottom right position -- Bottom right position
botRightPosArea <- GTK.drawingAreaNew 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 botRightPosArea False False 0
GTK.boxPackStart botRightPosBox botRightPosText False False 0 GTK.boxPackStart botRightPosBox botRightPosText False False 0
@ -159,17 +159,14 @@ createInfoBar colours = do
for_ [ zoomText, cursorPosText, topLeftPosText, botRightPosText ] \ info -> do for_ [ zoomText, cursorPosText, topLeftPosText, botRightPosText ] \ info -> do
widgetAddClass info "infoBarInfo" widgetAddClass info "infoBarInfo"
pure ( InfoBar { .. } ) pure ( InfoBar {..} )
updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> IO () updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> IO ()
updateInfoBar viewportDrawingArea ( InfoBar { .. } ) vars@( Variables { mousePosTVar } ) updateInfoBar viewportDrawingArea ( InfoBar {..} ) vars@( Variables { mousePosTVar } )
= do = do
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
mbDoc <- STM.atomically $ currentDocument vars mbDoc <- STM.atomically $ currentDocument vars
let
na :: IsString a => a
na = " n/a"
case mbDoc of case mbDoc of
Nothing -> do Nothing -> do
GTK.labelSetText zoomText $ na GTK.labelSetText zoomText $ na
@ -182,7 +179,7 @@ updateInfoBar viewportDrawingArea ( InfoBar { .. } ) vars@( Variables { mousePos
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
Point2D l t = toViewport ( Point2D 0 0 ) Point2D l t = toViewport ( Point2D 0 0 )
Point2D r b = toViewport ( Point2D viewportWidth viewportHeight ) 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 ) <> "%" ) GTK.labelSetText zoomText $ Text.pack ( fixed 5 2 ( 100 * zoomFactor ) <> "%" )
case mbMousePos of case mbMousePos of
Just ( Point2D mx my ) -> Just ( Point2D mx my ) ->
@ -201,3 +198,6 @@ fixed digitsBefore digitsAfter x = case second tail . break ( == '.' ) $ showFFl
r = length bs r = length bs
in in
replicate ( digitsBefore - l ) ' ' <> as <> "." <> bs <> replicate ( digitsAfter - r ) '0' replicate ( digitsBefore - l ) ' ' <> as <> "." <> bs <> replicate ( digitsAfter - r ) '0'
na :: IsString a => a
na = " n/a"

4
src/app/MetaBrush/UI/Menu.hs
View file

@ -233,7 +233,7 @@ newMenuItem
-> GTK.AccelGroup -> GTK.AccelGroup
-> MenuItem action submenu Description -> MenuItem action submenu Description
-> m GTK.MenuItem -> m GTK.MenuItem
newMenuItem uiElts vars accelGroup ( MenuItemDescription { .. } ) = do newMenuItem uiElts vars accelGroup ( MenuItemDescription {..} ) = do
menuItem <- GTK.menuItemNewWithLabel menuItemLabel menuItem <- GTK.menuItemNewWithLabel menuItemLabel
for_ menuItemAccel \ ( key, modifiers ) -> do for_ menuItemAccel \ ( key, modifiers ) -> do
GTK.widgetAddAccelerator menuItem "activate" accelGroup key ( map modifierType modifiers ) [ GTK.AccelFlagsVisible ] GTK.widgetAddAccelerator menuItem "activate" accelGroup key ( map modifierType modifiers ) [ GTK.AccelFlagsVisible ]
@ -279,7 +279,7 @@ instance ( HandleAction action, HasConstraints CreateMenuItem ( submenu Descript
, menuItemSubmenu = submenuItems , menuItemSubmenu = submenuItems
} }
instance CreateMenuItem ( Separator Description ) ( Separator Object ) where instance CreateMenuItem ( Separator Description ) ( Separator Object ) where
createMenuItem _ _ _ attachToParent ( SeparatorDescription { .. } ) = do createMenuItem _ _ _ attachToParent ( SeparatorDescription {..} ) = do
separator <- GTK.separatorMenuItemNew separator <- GTK.separatorMenuItemNew
unless ( null separatorClasses ) do unless ( null separatorClasses ) do
widgetAddClasses separator separatorClasses widgetAddClasses separator separatorClasses

2
src/app/MetaBrush/UI/ToolBar.hs
View file

@ -140,4 +140,4 @@ createToolBar toolTVar modeTVar colours drawingArea toolBar = do
$ Cairo.renderWithContext $ Cairo.renderWithContext
( drawMeta colours ) ( drawMeta colours )
pure ( ToolBar { .. } ) pure ( ToolBar {..} )

59
src/app/MetaBrush/UI/Viewport.hs
View file

@ -1,11 +1,19 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.UI.Viewport module MetaBrush.UI.Viewport
( Viewport(..), createViewport ) ( Viewport(..), createViewport
, Ruler(..)
)
where where
-- base
import Data.Foldable
( for_ )
-- gi-gdk -- gi-gdk
import qualified GI.Gdk as GDK import qualified GI.Gdk as GDK
@ -20,7 +28,11 @@ import MetaBrush.Util
data Viewport data Viewport
= Viewport = Viewport
{ viewportDrawingArea :: !GTK.DrawingArea { viewportDrawingArea
, rulerCornerDrawingArea
, leftRulerDrawingArea
, topRulerDrawingArea
:: !GTK.DrawingArea
} }
createViewport :: GTK.Grid -> IO Viewport createViewport :: GTK.Grid -> IO Viewport
@ -61,14 +73,14 @@ createViewport viewportGrid = do
GTK.revealerSetTransitionType rvLeftRuler GTK.RevealerTransitionTypeSlideLeft GTK.revealerSetTransitionType rvLeftRuler GTK.RevealerTransitionTypeSlideLeft
GTK.revealerSetTransitionType rvTopRuler GTK.RevealerTransitionTypeSlideUp GTK.revealerSetTransitionType rvTopRuler GTK.RevealerTransitionTypeSlideUp
rulerCornerArea <- GTK.drawingAreaNew rulerCornerDrawingArea <- GTK.drawingAreaNew
GTK.boxPackStart rulerCorner rulerCornerArea True True 0 GTK.boxPackStart rulerCorner rulerCornerDrawingArea True True 0
leftRulerArea <- GTK.drawingAreaNew leftRulerDrawingArea <- GTK.drawingAreaNew
GTK.boxPackStart leftRuler leftRulerArea True True 0 GTK.boxPackStart leftRuler leftRulerDrawingArea True True 0
topRulerArea <- GTK.drawingAreaNew topRulerDrawingArea <- GTK.drawingAreaNew
GTK.boxPackStart topRuler topRulerArea True True 0 GTK.boxPackStart topRuler topRulerDrawingArea True True 0
GTK.widgetSetHexpand rulerCorner False GTK.widgetSetHexpand rulerCorner False
GTK.widgetSetVexpand rulerCorner False GTK.widgetSetVexpand rulerCorner False
@ -81,12 +93,15 @@ createViewport viewportGrid = do
viewportDrawingArea <- GTK.drawingAreaNew viewportDrawingArea <- GTK.drawingAreaNew
GTK.setContainerChild viewportOverlay viewportDrawingArea 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 -- Viewport scrolling
@ -105,4 +120,14 @@ createViewport viewportGrid = do
widgetAddClass viewportHScrollbar "viewportScrollbar" widgetAddClass viewportHScrollbar "viewportScrollbar"
widgetAddClass viewportVScrollbar "viewportScrollbar" widgetAddClass viewportVScrollbar "viewportScrollbar"
pure ( Viewport { .. } ) -}
pure ( Viewport {..} )
--------------------------------------------------------------------------------
data Ruler
= RulerCorner
| LeftRuler
| TopRuler
deriving stock Show

10
src/lib/Math/Bezier/Cubic.hs
View file

@ -77,7 +77,7 @@ deriving via Ap Bezier p
-- | Cubic Bézier curve. -- | Cubic Bézier curve.
bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p
bezier ( Bezier { .. } ) t = bezier ( Bezier {..} ) t =
lerp @v t lerp @v t
( Quadratic.bezier @v ( Quadratic.Bezier p0 p1 p2 ) t ) ( Quadratic.bezier @v ( Quadratic.Bezier p0 p1 p2 ) t )
( Quadratic.bezier @v ( Quadratic.Bezier p1 p2 p3 ) t ) ( Quadratic.bezier @v ( Quadratic.Bezier p1 p2 p3 ) t )
@ -85,7 +85,7 @@ bezier ( Bezier { .. } ) t =
-- | Derivative of cubic Bézier curve. -- | Derivative of cubic Bézier curve.
bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v
bezier' ( Bezier { .. } ) t bezier' ( Bezier {..} ) t
= ( 3 *^ ) = ( 3 *^ )
$ lerp @v t $ lerp @v t
( lerp @v t ( p0 --> p1 ) ( p1 --> p2 ) ) ( lerp @v t ( p0 --> p1 ) ( p1 --> p2 ) )
@ -93,7 +93,7 @@ bezier' ( Bezier { .. } ) t
-- | Subdivide a cubic Bézier curve into two parts. -- | 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 :: 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 where
pt, s, q1, q2, r1, r2 :: p pt, s, q1, q2, r1, r2 :: p
q1 = lerp @v t p0 p1 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. -- | 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 :: 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 where
v, v', v'', v''' :: v v, v', v'', v''' :: v
v = c --> p0 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. -- | 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 :: 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 where
roots :: [ r ] roots :: [ r ]
roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots $ ddist @v pts c ) roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots $ ddist @v pts c )

10
src/lib/Math/Bezier/Quadratic.hs
View file

@ -75,15 +75,15 @@ deriving via Ap Bezier p
-- | Quadratic Bézier curve. -- | Quadratic Bézier curve.
bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p 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. -- | Derivative of quadratic Bézier curve.
bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v 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 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 :: 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 where
pt, q1, r1 :: p pt, q1, r1 :: p
q1 = lerp @v t p0 p1 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. -- | 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 :: 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 where
v, v', v'' :: v v, v', v'' :: v
v = c --> p0 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. -- | 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 :: 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 where
roots :: [ r ] roots :: [ r ]
roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots $ ddist @v pts c ) roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots $ ddist @v pts c )

20
src/lib/Math/Bezier/Stroke.hs
View file

@ -227,7 +227,7 @@ stroke allPts@( spt0 :<| spt1 :<| spts )
tgt2 :: Vector2D Double tgt2 :: Vector2D Double
tgt2 = p1 --> p2 tgt2 = p1 --> p2
bez :: Quadratic.Bezier ( Point2D Double ) bez :: Quadratic.Bezier ( Point2D Double )
bez = Quadratic.Bezier { .. } bez = Quadratic.Bezier {..}
brush :: Double -> Seq ( StrokePoint () ) brush :: Double -> Seq ( StrokePoint () )
brush t = quadraticBezierBrush t brush t = quadraticBezierBrush t
( Quadratic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) ) ( Quadratic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) )
@ -261,7 +261,7 @@ stroke allPts@( spt0 :<| spt1 :<| spts )
tgt3 :: Vector2D Double tgt3 :: Vector2D Double
tgt3 = p2 --> p3 tgt3 = p2 --> p3
bez :: Cubic.Bezier ( Point2D Double ) bez :: Cubic.Bezier ( Point2D Double )
bez = Cubic.Bezier { .. } bez = Cubic.Bezier {..}
brush :: Double -> Seq ( StrokePoint () ) brush :: Double -> Seq ( StrokePoint () )
brush t = cubicBezierBrush t brush t = cubicBezierBrush t
( Cubic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) ( brushShape @x sp3 ) ) ( 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 } ) f ( PathPoint { coords = p0 } )
( PathPoint { coords = p1 } ) ( PathPoint { coords = p1 } )
( PathPoint { coords = p2 } ) ( PathPoint { coords = p2 } )
= PP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier { .. } ) t = PP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t
f ( ControlPoint { coords = p0 } ) f ( ControlPoint { coords = p0 } )
( ControlPoint { coords = p1 } ) ( ControlPoint { coords = p1 } )
( ControlPoint { coords = p2 } ) ( 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 ] 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 () ) 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 = p1 } )
( PathPoint { coords = p2 } ) ( PathPoint { coords = p2 } )
( PathPoint { coords = p3 } ) ( PathPoint { coords = p3 } )
= PP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier { .. } ) t = PP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier {..} ) t
f ( ControlPoint { coords = p0 } ) f ( ControlPoint { coords = p0 } )
( ControlPoint { coords = p1 } ) ( ControlPoint { coords = p1 } )
( ControlPoint { coords = p2 } ) ( ControlPoint { coords = p2 } )
( ControlPoint { coords = p3 } ) ( 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 ] f p1 p2 p3 p4 = error $ "stroke: incompatible brushes " <> show [ p1, p2, p3, p4 ]
fitCurve fitCurve
@ -407,7 +407,7 @@ splitFirstPiece t ( sp0 :<| sp1 :<| sp2 :<| _ )
, let , let
q1, p, r1 :: Point2D Double q1, p, r1 :: Point2D Double
( Quadratic.Bezier _ q1 p, Quadratic.Bezier _ r1 _ ) ( 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 p0 :<| CP q1 :<| PP p :<| Empty
, PP p :<| CP r1 :<| PP p2 :<| Empty , PP p :<| CP r1 :<| PP p2 :<| Empty
) )
@ -420,7 +420,7 @@ splitFirstPiece t ( sp0 :<| sp1 :<| sp2 :<| sp3 :<| _ )
, let , let
q1, q2, p, r1, r2 :: Point2D Double q1, q2, p, r1, r2 :: Point2D Double
( Cubic.Bezier _ q1 q2 p, Cubic.Bezier _ r1 r2 _ ) ( 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 p0 :<| CP q1 :<| CP q2 :<| PP p :<| Empty
, PP p :<| CP r1 :<| CP r2 :<| PP p3 :<| Empty , PP p :<| CP r1 :<| CP r2 :<| PP p3 :<| Empty
) )
@ -463,7 +463,7 @@ withTangent tgt ( spt0 :<| spt1 :<| spts ) =
tgt1 :: Vector2D Double tgt1 :: Vector2D Double
tgt1 = p1 --> p2 tgt1 = p1 --> p2
in case between tgt tgt0 tgt1 of 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 Nothing -> continue ( i + 2 ) tgt1 sp2 ps
-- Cubic Bézier curve. -- Cubic Bézier curve.
go i tgt0 go i tgt0
@ -475,7 +475,7 @@ withTangent tgt ( spt0 :<| spt1 :<| spts ) =
tgt1 = p1 --> p2 tgt1 = p1 --> p2
tgt2 = p2 --> p3 tgt2 = p2 --> p3
bez :: Cubic.Bezier ( Point2D Double ) bez :: Cubic.Bezier ( Point2D Double )
bez = Cubic.Bezier { .. } bez = Cubic.Bezier {..}
c01, c12, c23 :: Double c01, c12, c23 :: Double
c01 = tgt `cross` tgt0 c01 = tgt `cross` tgt0
c12 = tgt `cross` tgt1 c12 = tgt `cross` tgt1

6
src/lib/Math/Module.hs
View file

@ -10,7 +10,7 @@ module Math.Module
( Module(..), lerp ( Module(..), lerp
, Inner(..) , Inner(..)
, squaredNorm, quadrance, distance , squaredNorm, quadrance, distance
, proj, projC, closestPointToLine , proj, projC, closestPointToSegment
) )
where 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 :: forall m r. ( Inner r m, Fractional r ) => m -> m -> r
projC x y = x ^.^ y / squaredNorm y projC x y = x ^.^ y / squaredNorm y
closestPointToLine closestPointToSegment
:: forall v r p :: forall v r p
. ( Inner r v, Torsor v p, Fractional r, Ord r ) . ( Inner r v, Torsor v p, Fractional r, Ord r )
=> p -> p -> p -> p => p -> p -> p -> p
closestPointToLine c p0 p1 closestPointToSegment c p0 p1
| t <= 0 | t <= 0
= p0 = p0
| t >= 1 | t >= 1