mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
add selection UI
This commit is contained in:
sheaf
parent
8d50c92ca9
commit
91e1431306
|
|
@ -30,6 +30,8 @@ common common
|
|||
>= 4.13 && < 4.16
|
||||
, acts
|
||||
^>= 0.3.1.0
|
||||
, groups
|
||||
^>= 0.4.1.0
|
||||
|
||||
default-language:
|
||||
Haskell2010
|
||||
|
|
@ -66,8 +68,6 @@ library
|
|||
build-depends:
|
||||
generic-data
|
||||
>= 0.8.0.0 && < 0.8.4.0
|
||||
, groups
|
||||
^>= 0.4.1.0
|
||||
, groups-generic
|
||||
^>= 0.1.0.0
|
||||
|
||||
|
|
@ -92,9 +92,11 @@ executable MetaBrush
|
|||
, MetaBrush.Asset.Tools
|
||||
, MetaBrush.Asset.WindowIcons
|
||||
, MetaBrush.Document
|
||||
, MetaBrush.Document.Selection
|
||||
, MetaBrush.Event
|
||||
, MetaBrush.Render.Document
|
||||
, MetaBrush.Render.Util
|
||||
, MetaBrush.Time
|
||||
, MetaBrush.UI.Coordinates
|
||||
, MetaBrush.UI.FileBar
|
||||
, MetaBrush.UI.InfoBar
|
||||
|
|
|
|||
24
app/Main.hs
24
app/Main.hs
|
|
@ -58,11 +58,14 @@ import MetaBrush.Asset.Logo
|
|||
import MetaBrush.Document
|
||||
( Document(..), AABB(..)
|
||||
, Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
|
||||
, Overlay
|
||||
)
|
||||
import MetaBrush.Event
|
||||
( handleEvents )
|
||||
import MetaBrush.Render.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
import MetaBrush.Time
|
||||
( Time )
|
||||
import MetaBrush.UI.FileBar
|
||||
( createFileBar )
|
||||
import MetaBrush.UI.InfoBar
|
||||
|
|
@ -72,7 +75,7 @@ import MetaBrush.UI.Menu
|
|||
import MetaBrush.UI.Panels
|
||||
( createPanelBar )
|
||||
import MetaBrush.UI.ToolBar
|
||||
( createToolBar )
|
||||
( Tool(..), Mode(..), createToolBar )
|
||||
import MetaBrush.UI.Viewport
|
||||
( Viewport(..), createViewport )
|
||||
import qualified Paths_MetaBrush as Cabal
|
||||
|
|
@ -140,9 +143,14 @@ main = do
|
|||
---------------------------------------------------------
|
||||
-- Initialise state
|
||||
|
||||
activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing
|
||||
openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments
|
||||
pressedKeysTVar <- STM.newTVarIO @[ Word32 ] []
|
||||
activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing
|
||||
openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments
|
||||
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
|
||||
mouseHoldTVar <- STM.newTVarIO @( Maybe ( Point2D Double, Time ) ) Nothing
|
||||
pressedKeysTVar <- STM.newTVarIO @[ Word32 ] []
|
||||
toolTVar <- STM.newTVarIO @Tool Selection
|
||||
modeTVar <- STM.newTVarIO @Mode Path
|
||||
overlayTVar <- STM.newTVarIO @( Maybe Overlay ) Nothing
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Initialise GTK
|
||||
|
|
@ -251,7 +259,7 @@ main = do
|
|||
---------------------------------------------------------
|
||||
-- Tool bar
|
||||
|
||||
_ <- createToolBar colours toolBar
|
||||
_ <- createToolBar toolTVar modeTVar colours toolBar
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Main viewport
|
||||
|
|
@ -261,6 +269,7 @@ main = do
|
|||
colours
|
||||
activeDocumentTVar
|
||||
openDocumentsTVar
|
||||
overlayTVar
|
||||
viewportGrid
|
||||
|
||||
---------------------------------------------------------
|
||||
|
|
@ -290,7 +299,10 @@ main = do
|
|||
-- Actions
|
||||
|
||||
handleEvents
|
||||
activeDocumentTVar openDocumentsTVar pressedKeysTVar
|
||||
activeDocumentTVar openDocumentsTVar
|
||||
mousePosTVar mouseHoldTVar pressedKeysTVar
|
||||
toolTVar modeTVar
|
||||
overlayTVar
|
||||
window viewportDrawingArea infoBarElements
|
||||
|
||||
---------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -72,7 +72,12 @@
|
|||
.glass {
|
||||
color: rgba(156, 231, 255, 0.5);
|
||||
}
|
||||
|
||||
.selection {
|
||||
color: rgba(161,201,236,0.5)
|
||||
}
|
||||
.selectionOutline {
|
||||
color: rgb(74,150,218);
|
||||
}
|
||||
|
||||
|
||||
/* Proper CSS styling */
|
||||
|
|
|
|||
|
|
@ -51,6 +51,8 @@ data ColourRecord a
|
|||
, tabScrollbar :: !a
|
||||
, magnifier :: !a
|
||||
, glass :: !a
|
||||
, selection :: !a
|
||||
, selectionOutline :: !a
|
||||
}
|
||||
deriving stock ( Show, Functor, Foldable, Traversable )
|
||||
|
||||
|
|
@ -90,6 +92,8 @@ colourNames = Colours
|
|||
, tabScrollbar = ColourName "tabScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]
|
||||
, magnifier = ColourName "magnifier" Colour [ GTK.StateFlagsNormal ]
|
||||
, glass = ColourName "glass" Colour [ GTK.StateFlagsNormal ]
|
||||
, selection = ColourName "selection" Colour [ GTK.StateFlagsNormal ]
|
||||
, selectionOutline = ColourName "selectionOutline" Colour [ GTK.StateFlagsNormal ]
|
||||
}
|
||||
|
||||
type Colours = ColourRecord GDK.RGBA
|
||||
|
|
|
|||
|
|
@ -72,6 +72,10 @@ data FocusState
|
|||
| Selected
|
||||
deriving stock Show
|
||||
|
||||
data Overlay
|
||||
= SelectionRectangle !( Point2D Double ) !( Point2D Double )
|
||||
deriving stock Show
|
||||
|
||||
currentDocument :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> IO ( Maybe Document )
|
||||
currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do
|
||||
mbActive <- STM.readTVar activeDocumentTVar
|
||||
|
|
|
|||
21
src/app/MetaBrush/Document/Selection.hs
Normal file
21
src/app/MetaBrush/Document/Selection.hs
Normal file
|
|
@ -0,0 +1,21 @@
|
|||
module MetaBrush.Document.Selection
|
||||
( selectAt, selectRectangle )
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Vector2D
|
||||
( Point2D(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
selectAt :: [ Word32 ] -> Point2D Double -> Document -> Document
|
||||
selectAt _ _ doc = doc
|
||||
|
||||
selectRectangle :: [ Word32 ] -> Point2D Double -> Point2D Double -> Document -> Document
|
||||
selectRectangle _ _ _ doc = doc
|
||||
|
|
@ -11,9 +11,6 @@ import Control.Monad
|
|||
( unless )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
-- base
|
||||
import Data.Semigroup
|
||||
( Arg(..), Min(..) )
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
|
||||
|
|
@ -38,10 +35,12 @@ import qualified GI.Gdk as GDK
|
|||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- stm
|
||||
import Control.Concurrent.STM
|
||||
( STM )
|
||||
import qualified Control.Concurrent.STM as STM
|
||||
( atomically )
|
||||
import qualified Control.Concurrent.STM.TVar as STM
|
||||
( TVar, readTVar, readTVarIO, writeTVar )
|
||||
( TVar, readTVar, readTVarIO, writeTVar, swapTVar )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Module
|
||||
|
|
@ -49,139 +48,311 @@ import Math.Module
|
|||
import Math.Vector2D
|
||||
( Point2D(..), Vector2D(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..), currentDocument )
|
||||
( Document(..), Overlay(..) )
|
||||
import MetaBrush.Document.Selection
|
||||
( selectAt, selectRectangle )
|
||||
import MetaBrush.Time
|
||||
( Time, monotonicTime, DTime(DSeconds) )
|
||||
import MetaBrush.UI.Coordinates
|
||||
( closestPoint, toViewportCoordinates )
|
||||
( toViewportCoordinates )
|
||||
import MetaBrush.UI.InfoBar
|
||||
( InfoBar, InfoData(..), updateInfoBar )
|
||||
import MetaBrush.UI.ToolBar
|
||||
( Tool(..), Mode )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
handleEvents :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> STM.TVar [ Word32 ] -> GTK.Window -> GTK.DrawingArea -> InfoBar -> IO ()
|
||||
handleEvents activeDocumentTVar openDocumentsTVar pressedKeysTVar window viewportDrawingArea infoBar = do
|
||||
handleEvents
|
||||
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
|
||||
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ]
|
||||
-> STM.TVar Tool -> STM.TVar Mode
|
||||
-> STM.TVar ( Maybe Overlay )
|
||||
-> GTK.Window -> GTK.DrawingArea -> InfoBar
|
||||
-> IO ()
|
||||
handleEvents
|
||||
activeDocumentTVar openDocumentsTVar
|
||||
mousePosTVar mouseHoldTVar pressedKeysTVar
|
||||
toolTVar _modeTVar
|
||||
overlayTVar
|
||||
window viewportDrawingArea infoBar = do
|
||||
|
||||
-- Mouse events
|
||||
_ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea
|
||||
( handleMotionEvent activeDocumentTVar openDocumentsTVar viewportDrawingArea infoBar )
|
||||
_ <- GTK.onWidgetScrollEvent viewportDrawingArea
|
||||
( handleScrollEvent activeDocumentTVar openDocumentsTVar pressedKeysTVar viewportDrawingArea infoBar )
|
||||
-- Mouse events
|
||||
_ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea
|
||||
( handleMotionEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar toolTVar overlayTVar viewportDrawingArea infoBar )
|
||||
_ <- GTK.onWidgetScrollEvent viewportDrawingArea
|
||||
( handleScrollEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar overlayTVar viewportDrawingArea infoBar )
|
||||
_ <- GTK.onWidgetButtonPressEvent viewportDrawingArea
|
||||
( handleMouseButtonEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar viewportDrawingArea )
|
||||
_ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea
|
||||
( handleMouseButtonRelease activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar overlayTVar viewportDrawingArea )
|
||||
|
||||
-- Keyboard events
|
||||
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar )
|
||||
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar )
|
||||
-- Keyboard events
|
||||
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar )
|
||||
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar )
|
||||
|
||||
-- Window quit
|
||||
_ <- GTK.onWidgetDestroy window GTK.mainQuit
|
||||
-- Window quit
|
||||
_ <- GTK.onWidgetDestroy window GTK.mainQuit
|
||||
|
||||
pure ()
|
||||
pure ()
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Mouse events.
|
||||
|
||||
handleMotionEvent :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> GTK.DrawingArea -> InfoBar -> GDK.EventMotion -> IO Bool
|
||||
handleMotionEvent activeDocumentTVar openDocumentsTVar viewportDrawingArea infoBar eventMotion = do
|
||||
|
||||
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
||||
for_ mbActiveDoc \ i -> do
|
||||
docs <- STM.readTVarIO openDocumentsTVar
|
||||
for_ ( IntMap.lookup i docs ) \ doc@( Document { .. } ) -> do
|
||||
|
||||
----------------------------------------------------------
|
||||
-- Update mouse position in info bar on mouse move event.
|
||||
|
||||
x <- GDK.getEventMotionX eventMotion
|
||||
y <- GDK.getEventMotionY eventMotion
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
let
|
||||
toViewport :: Point2D Double -> Point2D Double
|
||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||
pos :: Point2D Double
|
||||
pos = toViewport ( Point2D x y )
|
||||
infoData :: InfoData
|
||||
infoData =
|
||||
InfoData
|
||||
{ zoom = zoomFactor
|
||||
, mousePos = pos
|
||||
, topLeftPos = toViewport ( Point2D 0 0 )
|
||||
, botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
|
||||
}
|
||||
updateInfoBar infoBar infoData
|
||||
|
||||
pure True
|
||||
handleMotionEvent
|
||||
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
|
||||
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) )
|
||||
-> STM.TVar Tool
|
||||
-> STM.TVar ( Maybe Overlay )
|
||||
-> GTK.DrawingArea -> InfoBar
|
||||
-> GDK.EventMotion
|
||||
-> IO Bool
|
||||
handleMotionEvent
|
||||
activeDocumentTVar openDocumentsTVar
|
||||
mousePosTVar mouseHoldTVar
|
||||
toolTVar
|
||||
overlayTVar
|
||||
viewportDrawingArea infoBar
|
||||
eventMotion
|
||||
= do
|
||||
|
||||
handleScrollEvent :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> STM.TVar [ Word32 ] -> GTK.DrawingArea -> InfoBar -> GDK.EventScroll -> IO Bool
|
||||
handleScrollEvent activeDocumentTVar openDocumentsTVar pressedKeysTVar viewportDrawingArea infoBar scrollEvent = do
|
||||
|
||||
dx <- GDK.getEventScrollDeltaX scrollEvent
|
||||
dy <- GDK.getEventScrollDeltaY scrollEvent
|
||||
x <- GDK.getEventScrollX scrollEvent
|
||||
y <- GDK.getEventScrollY scrollEvent
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
|
||||
unless ( dx == 0 && dy == 0 ) do
|
||||
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
||||
for_ mbActiveDoc \ i -> do
|
||||
docs <- STM.readTVarIO openDocumentsTVar
|
||||
for_ ( IntMap.lookup i docs ) \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
|
||||
pressedKeys <- STM.readTVarIO pressedKeysTVar
|
||||
for_ ( IntMap.lookup i docs ) \ ( Document { .. } ) -> do
|
||||
|
||||
----------------------------------------------------------
|
||||
-- Update mouse position in info bar on mouse move event.
|
||||
|
||||
x <- GDK.getEventMotionX eventMotion
|
||||
y <- GDK.getEventMotionY eventMotion
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
let
|
||||
toViewport :: Point2D Double -> Point2D Double
|
||||
toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter
|
||||
-- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates)
|
||||
mousePos :: Point2D Double
|
||||
mousePos = toViewport ( Point2D x y )
|
||||
newDoc :: Document
|
||||
newDoc
|
||||
-- Zooming using 'Control'.
|
||||
| any ( \ key -> key == Control_L || key == Control_R ) pressedKeys
|
||||
= let
|
||||
newZoomFactor :: Double
|
||||
newZoomFactor
|
||||
| dy > 0
|
||||
= max 0.0078125 ( oldZoomFactor / sqrt 2 )
|
||||
| otherwise
|
||||
= min 256 ( oldZoomFactor * sqrt 2 )
|
||||
newCenter :: Point2D Double
|
||||
newCenter
|
||||
= ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double )
|
||||
• oldCenter
|
||||
in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }
|
||||
-- Vertical scrolling turned into horizontal scrolling using 'Shift'.
|
||||
| dx == 0 && any ( \ key -> key == Shift_L || key == Shift_R ) pressedKeys
|
||||
= let
|
||||
newCenter :: Point2D Double
|
||||
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D ( Point2D dy 0 ) ) • oldCenter
|
||||
in doc { viewportCenter = newCenter }
|
||||
-- Vertical scrolling.
|
||||
| otherwise
|
||||
= let
|
||||
newCenter :: Point2D Double
|
||||
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D ( Point2D dx dy ) ) • oldCenter
|
||||
in doc { viewportCenter = newCenter }
|
||||
docs' :: IntMap Document
|
||||
docs' = IntMap.insert i newDoc docs
|
||||
STM.atomically ( STM.writeTVar openDocumentsTVar docs' )
|
||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||
pos :: Point2D Double
|
||||
pos = toViewport ( Point2D x y )
|
||||
infoData :: InfoData
|
||||
infoData =
|
||||
InfoData
|
||||
{ zoom = zoomFactor
|
||||
, mousePos = pos
|
||||
, topLeftPos = toViewport ( Point2D 0 0 )
|
||||
, botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
|
||||
}
|
||||
updateInfoBar infoBar infoData
|
||||
STM.atomically do
|
||||
STM.writeTVar mousePosTVar ( Just pos )
|
||||
|
||||
----------------------------------------------------------
|
||||
-- Tool dependent updating.
|
||||
updateOverlay mouseHoldTVar toolTVar overlayTVar pos
|
||||
|
||||
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
|
||||
let
|
||||
newZoomFactor :: Double
|
||||
newZoomFactor = zoomFactor newDoc
|
||||
newCenter :: Point2D Double
|
||||
newCenter = viewportCenter newDoc
|
||||
toNewViewport :: Point2D Double -> Point2D Double
|
||||
toNewViewport = toViewportCoordinates newZoomFactor ( viewportWidth, viewportHeight ) newCenter
|
||||
infoData :: InfoData
|
||||
infoData = InfoData
|
||||
{ zoom = zoomFactor newDoc
|
||||
, mousePos
|
||||
, topLeftPos = toNewViewport ( Point2D 0 0 )
|
||||
, botRightPos = toNewViewport ( Point2D viewportWidth viewportHeight )
|
||||
}
|
||||
updateInfoBar infoBar infoData
|
||||
pure True
|
||||
|
||||
pure False
|
||||
handleScrollEvent
|
||||
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
|
||||
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ]
|
||||
-> STM.TVar Tool -> STM.TVar ( Maybe Overlay )
|
||||
-> GTK.DrawingArea -> InfoBar
|
||||
-> GDK.EventScroll
|
||||
-> IO Bool
|
||||
handleScrollEvent
|
||||
activeDocumentTVar openDocumentsTVar
|
||||
mousePosTVar mouseHoldTVar pressedKeysTVar
|
||||
toolTVar overlayTVar
|
||||
viewportDrawingArea infoBar
|
||||
scrollEvent
|
||||
= do
|
||||
|
||||
dx <- GDK.getEventScrollDeltaX scrollEvent
|
||||
dy <- GDK.getEventScrollDeltaY scrollEvent
|
||||
x <- GDK.getEventScrollX scrollEvent
|
||||
y <- GDK.getEventScrollY scrollEvent
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
|
||||
unless ( dx == 0 && dy == 0 ) do
|
||||
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
||||
for_ mbActiveDoc \ i -> do
|
||||
docs <- STM.readTVarIO openDocumentsTVar
|
||||
for_ ( IntMap.lookup i docs ) \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
|
||||
pressedKeys <- STM.readTVarIO pressedKeysTVar
|
||||
let
|
||||
toViewport :: Point2D Double -> Point2D Double
|
||||
toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter
|
||||
-- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates)
|
||||
mousePos :: Point2D Double
|
||||
mousePos = toViewport ( Point2D x y )
|
||||
newDoc :: Document
|
||||
newDoc
|
||||
-- Zooming using 'Control'.
|
||||
| any ( \ key -> key == Control_L || key == Control_R ) pressedKeys
|
||||
= let
|
||||
newZoomFactor :: Double
|
||||
newZoomFactor
|
||||
| dy > 0
|
||||
= max 0.0078125 ( oldZoomFactor / sqrt 2 )
|
||||
| otherwise
|
||||
= min 256 ( oldZoomFactor * sqrt 2 )
|
||||
newCenter :: Point2D Double
|
||||
newCenter
|
||||
= ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double )
|
||||
• oldCenter
|
||||
in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }
|
||||
-- Vertical scrolling turned into horizontal scrolling using 'Shift'.
|
||||
| dx == 0 && any ( \ key -> key == Shift_L || key == Shift_R ) pressedKeys
|
||||
= let
|
||||
newCenter :: Point2D Double
|
||||
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D ( Point2D dy 0 ) ) • oldCenter
|
||||
in doc { viewportCenter = newCenter }
|
||||
-- Vertical scrolling.
|
||||
| otherwise
|
||||
= let
|
||||
newCenter :: Point2D Double
|
||||
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D ( Point2D dx dy ) ) • oldCenter
|
||||
in doc { viewportCenter = newCenter }
|
||||
docs' :: IntMap Document
|
||||
docs' = IntMap.insert i newDoc docs
|
||||
finalZoomFactor :: Double
|
||||
finalZoomFactor = zoomFactor newDoc
|
||||
finalCenter :: Point2D Double
|
||||
finalCenter = viewportCenter newDoc
|
||||
toFinalViewport :: Point2D Double -> Point2D Double
|
||||
toFinalViewport = toViewportCoordinates finalZoomFactor ( viewportWidth, viewportHeight ) finalCenter
|
||||
finalMousePos :: Point2D Double
|
||||
finalMousePos = toFinalViewport ( Point2D x y )
|
||||
infoData :: InfoData
|
||||
infoData = InfoData
|
||||
{ zoom = finalZoomFactor
|
||||
, mousePos = finalMousePos
|
||||
, topLeftPos = toFinalViewport ( Point2D 0 0 )
|
||||
, botRightPos = toFinalViewport ( Point2D viewportWidth viewportHeight )
|
||||
}
|
||||
updateInfoBar infoBar infoData
|
||||
STM.atomically do
|
||||
STM.writeTVar openDocumentsTVar docs'
|
||||
STM.writeTVar mousePosTVar ( Just finalMousePos )
|
||||
updateOverlay mouseHoldTVar toolTVar overlayTVar finalMousePos
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
|
||||
pure False
|
||||
|
||||
handleMouseButtonEvent
|
||||
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
|
||||
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ]
|
||||
-> GTK.DrawingArea
|
||||
-> GDK.EventButton
|
||||
-> IO Bool
|
||||
handleMouseButtonEvent
|
||||
activeDocumentTVar openDocumentsTVar
|
||||
mousePosTVar mouseHoldTVar _pressedKeysTVar
|
||||
viewportDrawingArea
|
||||
mouseClickEvent
|
||||
= do
|
||||
|
||||
button <- GDK.getEventButtonButton mouseClickEvent
|
||||
case button of
|
||||
-- left mouse button
|
||||
1 -> do
|
||||
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
||||
for_ mbActiveDoc \ i -> do
|
||||
docs <- STM.readTVarIO openDocumentsTVar
|
||||
for_ ( IntMap.lookup i docs ) \ ( Document { zoomFactor, viewportCenter } ) -> do
|
||||
x <- GDK.getEventButtonX mouseClickEvent
|
||||
y <- GDK.getEventButtonY mouseClickEvent
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
let
|
||||
toViewport :: Point2D Double -> Point2D Double
|
||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||
pos :: Point2D Double
|
||||
pos = toViewport ( Point2D x y )
|
||||
time <- monotonicTime
|
||||
STM.atomically do
|
||||
STM.writeTVar mousePosTVar ( Just pos )
|
||||
STM.writeTVar mouseHoldTVar ( Just ( pos, time ) )
|
||||
_ -> pure ()
|
||||
|
||||
pure False
|
||||
|
||||
handleMouseButtonRelease
|
||||
:: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
|
||||
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar [ Word32 ]
|
||||
-> STM.TVar Tool
|
||||
-> STM.TVar ( Maybe Overlay )
|
||||
-> GTK.DrawingArea
|
||||
-> GDK.EventButton
|
||||
-> IO Bool
|
||||
handleMouseButtonRelease
|
||||
activeDocumentTVar openDocumentsTVar
|
||||
mousePosTVar mouseHoldTVar pressedKeysTVar
|
||||
toolTVar
|
||||
overlayTVar
|
||||
viewportDrawingArea
|
||||
mouseReleaseEvent
|
||||
= do
|
||||
|
||||
button <- GDK.getEventButtonButton mouseReleaseEvent
|
||||
case button of
|
||||
-- left mouse button
|
||||
1 -> do
|
||||
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
||||
for_ mbActiveDoc \ i -> do
|
||||
docs <- STM.readTVarIO openDocumentsTVar
|
||||
for_ ( IntMap.lookup i docs ) \ doc@( Document { zoomFactor, viewportCenter } ) -> do
|
||||
x <- GDK.getEventButtonX mouseReleaseEvent
|
||||
y <- GDK.getEventButtonY mouseReleaseEvent
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
let
|
||||
toViewport :: Point2D Double -> Point2D Double
|
||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||
pos :: Point2D Double
|
||||
pos = toViewport ( Point2D x y )
|
||||
t <- monotonicTime
|
||||
STM.atomically do
|
||||
pressedKeys <- STM.readTVar pressedKeysTVar
|
||||
mbHoldPos <- STM.swapTVar mouseHoldTVar Nothing
|
||||
STM.writeTVar overlayTVar Nothing
|
||||
tool <- STM.readTVar toolTVar
|
||||
let
|
||||
newDoc :: Document
|
||||
newDoc = case tool of
|
||||
Selection
|
||||
| Just ( pos0, t0 ) <- mbHoldPos
|
||||
, pos0 /= pos
|
||||
, ( t0 --> t ) > DSeconds 0.3
|
||||
-> selectRectangle pressedKeys pos0 pos doc
|
||||
| otherwise
|
||||
-> selectAt pressedKeys pos doc
|
||||
Pen -> doc -- TODO
|
||||
newDocs :: IntMap Document
|
||||
newDocs = IntMap.insert i newDoc docs
|
||||
STM.writeTVar openDocumentsTVar newDocs
|
||||
STM.writeTVar mousePosTVar ( Just pos )
|
||||
GTK.widgetQueueDraw viewportDrawingArea
|
||||
|
||||
-- any other mouse button: no action (for the moment)
|
||||
_ -> pure ()
|
||||
|
||||
pure False
|
||||
|
||||
updateOverlay :: STM.TVar ( Maybe ( Point2D Double, Time ) ) -> STM.TVar Tool -> STM.TVar ( Maybe Overlay ) -> Point2D Double -> STM ()
|
||||
updateOverlay mouseHoldTVar toolTVar overlayTVar p = do
|
||||
tool <- STM.readTVar toolTVar
|
||||
case tool of
|
||||
-- Draw selection rectangle if performing a selection.
|
||||
Selection -> do
|
||||
mbHold <- STM.readTVar mouseHoldTVar
|
||||
case mbHold of
|
||||
Just ( p0, _ ) -> STM.writeTVar overlayTVar ( Just ( SelectionRectangle p0 p ) )
|
||||
Nothing -> STM.writeTVar overlayTVar Nothing
|
||||
-- Pen tool: show preview (TODO).
|
||||
Pen -> STM.writeTVar overlayTVar Nothing
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Keyboard events.
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ module MetaBrush.Render.Document
|
|||
|
||||
-- base
|
||||
import Data.Foldable
|
||||
( traverse_ )
|
||||
( for_, traverse_ )
|
||||
import Data.Functor.Compose
|
||||
( Compose(..) )
|
||||
import Data.Int
|
||||
|
|
@ -32,6 +32,7 @@ import MetaBrush.Asset.Colours
|
|||
import MetaBrush.Document
|
||||
( Document(..)
|
||||
, Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
|
||||
, Overlay(..)
|
||||
)
|
||||
import MetaBrush.Render.Util
|
||||
( withRGBA )
|
||||
|
|
@ -55,8 +56,8 @@ pattern Renders { renderPoints, renderPaths } = Compose ( MkRenders renderPoints
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
renderDocument :: Colours -> ( Int32, Int32 ) -> Document -> Cairo.Render ()
|
||||
renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCenter = Point2D cx cy, .. } ) = do
|
||||
renderDocument :: Colours -> ( Int32, Int32 ) -> Document -> Maybe Overlay -> Cairo.Render ()
|
||||
renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCenter = Point2D cx cy, .. } ) mbOverlay = do
|
||||
|
||||
Cairo.save
|
||||
Cairo.translate ( 0.5 * fromIntegral viewportWidth ) ( 0.5 * fromIntegral viewportHeight )
|
||||
|
|
@ -64,9 +65,10 @@ renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCente
|
|||
Cairo.translate ( -cx ) ( -cy )
|
||||
|
||||
let
|
||||
Renders { renderPoints, renderPaths } = traverse_ ( renderStroke cols zoomFactor ) strokes
|
||||
renderPaths
|
||||
renderPoints
|
||||
Renders rdrPoints rdrPaths = traverse_ ( renderStroke cols zoomFactor ) strokes
|
||||
rdrPaths
|
||||
rdrPoints
|
||||
for_ mbOverlay ( renderOverlay cols zoomFactor )
|
||||
|
||||
Cairo.restore
|
||||
|
||||
|
|
@ -244,3 +246,24 @@ drawCubicBezier ( Colours { path } ) zoom
|
|||
Cairo.stroke
|
||||
|
||||
Cairo.restore
|
||||
|
||||
|
||||
renderOverlay :: Colours -> Double -> Overlay -> Cairo.Render ()
|
||||
renderOverlay ( Colours { .. } ) zoom ( SelectionRectangle ( Point2D x0 y0 ) ( Point2D x1 y1 ) ) = do
|
||||
|
||||
Cairo.save
|
||||
|
||||
Cairo.moveTo x0 y0
|
||||
Cairo.lineTo x1 y0
|
||||
Cairo.lineTo x1 y1
|
||||
Cairo.lineTo x0 y1
|
||||
Cairo.closePath
|
||||
|
||||
Cairo.setLineWidth ( 1 / zoom )
|
||||
withRGBA selection Cairo.setSourceRGBA
|
||||
Cairo.fillPreserve
|
||||
|
||||
withRGBA selectionOutline Cairo.setSourceRGBA
|
||||
Cairo.stroke
|
||||
|
||||
Cairo.restore
|
||||
|
|
|
|||
75
src/app/MetaBrush/Time.hs
Normal file
75
src/app/MetaBrush/Time.hs
Normal file
|
|
@ -0,0 +1,75 @@
|
|||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module MetaBrush.Time
|
||||
( Time(..), DTime(DSeconds, ..), dSeconds
|
||||
, pprSeconds
|
||||
, monotonicTime
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Int
|
||||
( Int64 )
|
||||
import Data.Semigroup
|
||||
( Sum(..) )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Act, Torsor )
|
||||
|
||||
-- gi-glib
|
||||
import qualified GI.GLib.Functions as GLib
|
||||
( getMonotonicTime )
|
||||
|
||||
-- groups
|
||||
import Data.Group
|
||||
( Group )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.IO.Class
|
||||
( MonadIO )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
newtype Time = Seconds { seconds :: Double }
|
||||
deriving newtype ( Eq, Ord )
|
||||
deriving stock Show
|
||||
deriving ( Act DTime, Torsor DTime )
|
||||
via DTime
|
||||
|
||||
newtype DTime = DTime { dTime :: Time }
|
||||
deriving stock Show
|
||||
deriving newtype ( Eq, Ord )
|
||||
deriving ( Semigroup, Monoid, Group )
|
||||
via ( Sum Double )
|
||||
|
||||
{-# COMPLETE DSeconds #-}
|
||||
pattern DSeconds :: Double -> DTime
|
||||
pattern DSeconds secs = DTime ( Seconds secs )
|
||||
|
||||
dSeconds :: DTime -> Double
|
||||
dSeconds ( DSeconds secs ) = secs
|
||||
|
||||
pprSeconds :: ( String, String, String ) -> Time -> String
|
||||
pprSeconds ( h_name, m_name, s_name ) ( Seconds secs ) = pm <> absolute
|
||||
where
|
||||
pm :: String
|
||||
pm
|
||||
| secs <= (-1) = "-"
|
||||
| otherwise = ""
|
||||
h, r, m, s :: Int64
|
||||
(h,r) = ( round $ abs secs ) `divMod` 3600
|
||||
(m,s) = r `divMod` 60
|
||||
fixed2 :: String -> String
|
||||
fixed2 [] = "00"
|
||||
fixed2 [x] = ['0', x]
|
||||
fixed2 xs = xs
|
||||
absolute
|
||||
| h > 0 = show h <> h_name <> fixed2 (show m) <> m_name <> fixed2 (show s) <> s_name
|
||||
| m > 0 = show m <> m_name <> fixed2 (show s) <> s_name
|
||||
| otherwise = show s <> s_name
|
||||
|
||||
monotonicTime :: MonadIO m => m Time
|
||||
monotonicTime = Seconds . ( * 1e-6 ) . fromIntegral <$> GLib.getMonotonicTime
|
||||
|
|
@ -18,14 +18,16 @@ import Data.Act
|
|||
)
|
||||
|
||||
-- MetaBrush
|
||||
import qualified Math.Bezier.Cubic as Cubic
|
||||
( Bezier(..), closestPoint )
|
||||
import qualified Math.Bezier.Quadratic as Quadratic
|
||||
( Bezier(..), closestPoint )
|
||||
import Math.Module
|
||||
( (*^), squaredNorm )
|
||||
( (*^), squaredNorm, closestPointToLine )
|
||||
import Math.Vector2D
|
||||
( Point2D(..), Vector2D(..) )
|
||||
import MetaBrush.Document
|
||||
( Stroke(..) )
|
||||
( Stroke(..), StrokePoint(..), PointType(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -36,15 +38,32 @@ toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCente
|
|||
• viewportCenter
|
||||
|
||||
-- | Find the closest point in a set of strokes.
|
||||
closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Point2D Double )
|
||||
closestPoint = undefined
|
||||
{-
|
||||
closestPoint c ( Stroke pts ) = go pts
|
||||
closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Maybe ( Point2D Double ) )
|
||||
closestPoint c ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible = True } ) = go pt0 pts
|
||||
where
|
||||
go :: [ Point2D Double ] -> ArgMin Double ( Point2D Double )
|
||||
go [] = error "'closestPoint': empty stroke"
|
||||
go [p] = Min ( Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) p )
|
||||
go (p0:p1:p2:ps)
|
||||
= fmap ( fmap snd ) ( Quadratic.closestPoint @(Vector2D Double) ( Quadratic.Bezier { .. } ) c )
|
||||
<> go (p2:ps)
|
||||
-}
|
||||
res :: Point2D Double -> ArgMin Double ( Maybe ( Point2D Double ) )
|
||||
res p = Min $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p )
|
||||
go :: StrokePoint -> [ StrokePoint ] -> ArgMin Double ( Maybe ( Point2D Double ) )
|
||||
go p0 [] = res ( strokePoint p0 )
|
||||
-- Line.
|
||||
go p0 ( p1 : ps )
|
||||
| PathPoint <- pointType p1
|
||||
= res ( closestPointToLine @( Vector2D Double ) c ( strokePoint p0 ) ( strokePoint p1 ) )
|
||||
<> go p1 ps
|
||||
-- Quadratic Bézier curve.
|
||||
go p0 ( p1 : p2 : ps )
|
||||
| ControlPoint <- pointType p1
|
||||
, PathPoint <- pointType p2
|
||||
= fmap ( fmap ( Just . snd ) )
|
||||
( Quadratic.closestPoint @( Vector2D Double ) ( fmap strokePoint $ Quadratic.Bezier { .. } ) c )
|
||||
<> go p2 ps
|
||||
-- Cubic Bézier curve.
|
||||
go p0 ( p1 : p2 : p3 : ps )
|
||||
| ControlPoint <- pointType p1
|
||||
, ControlPoint <- pointType p1
|
||||
, PathPoint <- pointType p3
|
||||
= fmap ( fmap ( Just . snd ) )
|
||||
( Cubic.closestPoint @( Vector2D Double ) ( fmap strokePoint $ Cubic.Bezier { .. } ) c )
|
||||
<> go p3 ps
|
||||
go p0 ps = error $ "closestPoint: unrecognised stroke type\n" <> show ( p0 : ps )
|
||||
closestPoint _ _ = Min $ Arg ( 1 / 0 ) Nothing
|
||||
|
|
|
|||
|
|
@ -1,10 +1,13 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module MetaBrush.UI.ToolBar
|
||||
( ToolBar(..), createToolBar )
|
||||
( Tool(..), Mode(..)
|
||||
, ToolBar(..), createToolBar
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
|
|
@ -20,6 +23,12 @@ import qualified GI.Cairo.Render.Connector as Cairo
|
|||
-- gi-gtk
|
||||
import qualified GI.Gtk as GTK
|
||||
|
||||
-- stm
|
||||
import qualified Control.Concurrent.STM as STM
|
||||
( atomically )
|
||||
import qualified Control.Concurrent.STM.TVar as STM
|
||||
( TVar, writeTVar )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours )
|
||||
|
|
@ -32,6 +41,17 @@ import MetaBrush.Render.Util
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Tool
|
||||
= Selection
|
||||
| Pen
|
||||
deriving stock Show
|
||||
|
||||
data Mode
|
||||
= Path
|
||||
| Brush
|
||||
| Meta
|
||||
deriving stock Show
|
||||
|
||||
data ToolBar
|
||||
= ToolBar
|
||||
{ selectionTool :: !GTK.RadioButton
|
||||
|
|
@ -41,8 +61,8 @@ data ToolBar
|
|||
, metaTool :: !GTK.RadioButton
|
||||
}
|
||||
|
||||
createToolBar :: Colours -> GTK.Box -> IO ToolBar
|
||||
createToolBar colours toolBar = do
|
||||
createToolBar :: STM.TVar Tool -> STM.TVar Mode -> Colours -> GTK.Box -> IO ToolBar
|
||||
createToolBar toolTVar modeTVar colours toolBar = do
|
||||
|
||||
widgetAddClass toolBar "toolBar"
|
||||
|
||||
|
|
@ -52,11 +72,23 @@ createToolBar colours toolBar = do
|
|||
selectionTool <- GTK.radioButtonNew ( [] @GTK.RadioButton )
|
||||
penTool <- GTK.radioButtonNewFromWidget ( Just selectionTool )
|
||||
|
||||
_ <- GTK.onButtonClicked selectionTool
|
||||
( STM.atomically $ STM.writeTVar toolTVar Selection )
|
||||
_ <- GTK.onButtonClicked penTool
|
||||
( STM.atomically $ STM.writeTVar toolTVar Pen )
|
||||
|
||||
toolSep1 <- GTK.boxNew GTK.OrientationVertical 0
|
||||
|
||||
pathTool <- GTK.radioButtonNew ( [] @GTK.RadioButton )
|
||||
brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
|
||||
metaTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
|
||||
|
||||
toolSep1 <- GTK.boxNew GTK.OrientationVertical 0
|
||||
_ <- GTK.onButtonClicked pathTool
|
||||
( STM.atomically $ STM.writeTVar modeTVar Path )
|
||||
_ <- GTK.onButtonClicked brushTool
|
||||
( STM.atomically $ STM.writeTVar modeTVar Brush )
|
||||
_ <- GTK.onButtonClicked metaTool
|
||||
( STM.atomically $ STM.writeTVar modeTVar Meta )
|
||||
|
||||
GTK.boxPackStart toolBar selectionTool True True 0
|
||||
GTK.boxPackStart toolBar penTool True True 0
|
||||
|
|
|
|||
|
|
@ -30,13 +30,15 @@ import qualified GI.Gtk as GTK
|
|||
|
||||
-- stm
|
||||
import qualified Control.Concurrent.STM.TVar as STM
|
||||
( TVar )
|
||||
( TVar, readTVarIO )
|
||||
|
||||
-- MetaBrush
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours )
|
||||
import MetaBrush.Document
|
||||
( Document(..), currentDocument )
|
||||
( Document(..), currentDocument
|
||||
, Overlay
|
||||
)
|
||||
import MetaBrush.Render.Document
|
||||
( renderDocument )
|
||||
import MetaBrush.Render.Util
|
||||
|
|
@ -53,9 +55,10 @@ createViewport
|
|||
:: Colours
|
||||
-> STM.TVar ( Maybe Int )
|
||||
-> STM.TVar ( IntMap Document )
|
||||
-> STM.TVar ( Maybe Overlay )
|
||||
-> GTK.Grid
|
||||
-> IO Viewport
|
||||
createViewport colours activeDocumentTVar openDocumentsTVar viewportGrid = do
|
||||
createViewport colours activeDocumentTVar openDocumentsTVar overlayTVar viewportGrid = do
|
||||
|
||||
widgetAddClass viewportGrid "viewport"
|
||||
|
||||
|
|
@ -142,11 +145,12 @@ createViewport colours activeDocumentTVar openDocumentsTVar viewportGrid = do
|
|||
void $ GTK.onWidgetDraw viewportDrawingArea \ctx -> do
|
||||
-- Get the relevant document information
|
||||
mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar
|
||||
mbOverlay <- STM.readTVarIO overlayTVar
|
||||
for_ mbDoc \ doc -> do
|
||||
( `Cairo.renderWithContext` ctx ) $ do
|
||||
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
|
||||
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
|
||||
renderDocument colours ( viewportWidth, viewportHeight ) doc
|
||||
renderDocument colours ( viewportWidth, viewportHeight ) doc mbOverlay
|
||||
pure True
|
||||
|
||||
pure ( Viewport { .. } )
|
||||
|
|
|
|||
|
|
@ -20,6 +20,8 @@ module Math.Bezier.Cubic
|
|||
-- base
|
||||
import Data.List.NonEmpty
|
||||
( NonEmpty(..) )
|
||||
import Data.Semigroup
|
||||
( ArgMin, Min(..), Arg(..) )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
|
||||
|
|
@ -82,7 +84,7 @@ subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 )
|
|||
pt = lerp @v t q2 r1
|
||||
|
||||
-- | 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 -> ( 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 )
|
||||
where
|
||||
roots :: [ r ]
|
||||
|
|
@ -102,14 +104,14 @@ closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots )
|
|||
a4 = 5 * v'' ^.^ v'''
|
||||
a5 = squaredNorm v'''
|
||||
|
||||
pickClosest :: NonEmpty r -> ( r, p )
|
||||
pickClosest :: NonEmpty r -> ArgMin r ( r, p )
|
||||
pickClosest ( s :| ss ) = go s q nm0 ss
|
||||
where
|
||||
q :: p
|
||||
q = bezier @v pts s
|
||||
nm0 :: r
|
||||
nm0 = squaredNorm ( c --> q :: v )
|
||||
go t p _ [] = ( t, p )
|
||||
go t p nm [] = Min ( Arg nm ( t, p ) )
|
||||
go t p nm ( t' : ts )
|
||||
| nm' < nm = go t' p' nm' ts
|
||||
| otherwise = go t p nm ts
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
module Math.Module
|
||||
( Module(..), lerp
|
||||
, Inner(..), squaredNorm
|
||||
, proj, projC, closestPointToLine
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -44,5 +45,30 @@ class Module r m => Inner r m where
|
|||
(^.^) :: m -> m -> r
|
||||
|
||||
-- | Squared norm of a vector, computed using the inner product.
|
||||
squaredNorm :: Inner r m => m -> r
|
||||
squaredNorm :: forall m r. Inner r m => m -> r
|
||||
squaredNorm v = v ^.^ v
|
||||
|
||||
-- | Projects the first argument onto the second.
|
||||
proj :: forall m r. ( Inner r m, Fractional r ) => m -> m -> m
|
||||
proj x y = projC x y *^ y
|
||||
|
||||
-- | Projection constant: how far along the projection of the first vector lands along the second vector.
|
||||
projC :: forall m r. ( Inner r m, Fractional r ) => m -> m -> r
|
||||
projC x y = x ^.^ y / squaredNorm y
|
||||
|
||||
closestPointToLine
|
||||
:: forall v r p
|
||||
. ( Inner r v, Torsor v p, Fractional r, Ord r )
|
||||
=> p -> p -> p -> p
|
||||
closestPointToLine c p0 p1
|
||||
| t <= 0
|
||||
= p0
|
||||
| t >= 1
|
||||
= p1
|
||||
| otherwise
|
||||
= ( t *^ v01 ) • p0
|
||||
where
|
||||
v01 :: v
|
||||
v01 = p0 --> p1
|
||||
t :: r
|
||||
t = projC ( p0 --> c ) v01
|
||||
|
|
|
|||
|
|
@ -37,12 +37,12 @@ import Math.Module
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
data Point2D a = Point2D !a !a
|
||||
deriving stock ( Show, Generic, Functor, Foldable, Traversable )
|
||||
deriving stock ( Show, Eq, Generic, Functor, Foldable, Traversable )
|
||||
deriving ( Act ( Vector2D a ), Torsor ( Vector2D a ) )
|
||||
via Vector2D a
|
||||
|
||||
newtype Vector2D a = Vector2D { tip :: Point2D a }
|
||||
deriving stock ( Show, Functor, Foldable, Traversable )
|
||||
deriving stock ( Show, Eq, Functor, Foldable, Traversable )
|
||||
deriving ( Semigroup, Monoid, Group )
|
||||
via GenericProduct ( Point2D ( Sum a ) )
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue