mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
add root solving code, coalesce event handling
This commit is contained in:
sheaf
parent
d74d4fd5cc
commit
2bd6847e78
1
.gitignore
vendored
1
.gitignore
vendored
|
|
@ -3,6 +3,7 @@ cabal.project.local
|
|||
|
||||
assets/*.svg
|
||||
assets/*/
|
||||
refs/
|
||||
|
||||
*.txt
|
||||
*.md
|
||||
|
|
|
|||
|
|
@ -60,6 +60,7 @@ library
|
|||
, Math.Bezier.Stroke
|
||||
, Math.Bezier.Subdivision
|
||||
, Math.Module
|
||||
, Math.RealRoots
|
||||
, Math.Vector2D
|
||||
|
||||
build-depends:
|
||||
|
|
|
|||
23
app/Main.hs
23
app/Main.hs
|
|
@ -61,11 +61,9 @@ import MetaBrush.Document
|
|||
, Stroke(..)
|
||||
)
|
||||
import MetaBrush.Event
|
||||
( handleKeyboardPressEvent, handleKeyboardReleaseEvent )
|
||||
( handleEvents )
|
||||
import MetaBrush.Render.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
import MetaBrush.UI.Coordinates
|
||||
( keepViewportCoordinatesUpdated )
|
||||
import MetaBrush.UI.FileBar
|
||||
( createFileBar )
|
||||
import MetaBrush.UI.InfoBar
|
||||
|
|
@ -140,6 +138,8 @@ main = do
|
|||
GTK.setWindowDecorated window False
|
||||
GTK.setWindowTitle window "MetaBrush"
|
||||
GTK.windowSetDefaultSize window 800 600
|
||||
GTK.widgetAddEvents window
|
||||
[ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ]
|
||||
|
||||
let
|
||||
baseMinWidth, baseMinHeight :: Int32
|
||||
|
|
@ -244,13 +244,6 @@ main = do
|
|||
|
||||
infoBarElements <- createInfoBar colours infoBar
|
||||
|
||||
keepViewportCoordinatesUpdated
|
||||
activeDocumentTVar
|
||||
openDocumentsTVar
|
||||
pressedKeysTVar
|
||||
infoBarElements
|
||||
viewportDrawingArea
|
||||
|
||||
---------------------------------------------------------
|
||||
-- File bar
|
||||
|
||||
|
|
@ -261,6 +254,7 @@ main = do
|
|||
window
|
||||
title
|
||||
viewportDrawingArea
|
||||
infoBarElements
|
||||
fileBar
|
||||
|
||||
---------------------------------------------------------
|
||||
|
|
@ -271,12 +265,9 @@ main = do
|
|||
---------------------------------------------------------
|
||||
-- Actions
|
||||
|
||||
GTK.widgetAddEvents window
|
||||
[ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ]
|
||||
|
||||
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar )
|
||||
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar )
|
||||
_ <- GTK.onWidgetDestroy window GTK.mainQuit
|
||||
handleEvents
|
||||
activeDocumentTVar openDocumentsTVar pressedKeysTVar
|
||||
window viewportDrawingArea infoBarElements
|
||||
|
||||
---------------------------------------------------------
|
||||
-- GTK main loop
|
||||
|
|
|
|||
|
|
@ -1,12 +1,33 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module MetaBrush.Event where
|
||||
|
||||
-- base
|
||||
import Control.Monad
|
||||
( unless )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Act
|
||||
( (•) )
|
||||
, Torsor
|
||||
( (-->) )
|
||||
)
|
||||
|
||||
-- containers
|
||||
import Data.IntMap.Strict
|
||||
( IntMap )
|
||||
import qualified Data.IntMap.Strict as IntMap
|
||||
( insert, lookup )
|
||||
|
||||
-- gi-gdk
|
||||
import qualified GI.Gdk as GDK
|
||||
|
||||
|
|
@ -17,10 +38,147 @@ import qualified GI.Gtk as GTK
|
|||
import qualified Control.Concurrent.STM as STM
|
||||
( atomically )
|
||||
import qualified Control.Concurrent.STM.TVar as STM
|
||||
( TVar, readTVar, writeTVar )
|
||||
( TVar, readTVar, readTVarIO, writeTVar )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Module
|
||||
( (*^) )
|
||||
import Math.Vector2D
|
||||
( Point2D(..), Vector2D(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..), currentDocument )
|
||||
import MetaBrush.UI.Coordinates
|
||||
( toViewportCoordinates )
|
||||
import MetaBrush.UI.InfoBar
|
||||
( InfoBar, InfoData(..), updateInfoBar )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
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
|
||||
|
||||
-- Mouse events
|
||||
_ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea
|
||||
( handleMotionEvent activeDocumentTVar openDocumentsTVar viewportDrawingArea infoBar )
|
||||
_ <- GTK.onWidgetScrollEvent viewportDrawingArea
|
||||
( handleScrollEvent activeDocumentTVar openDocumentsTVar pressedKeysTVar viewportDrawingArea infoBar )
|
||||
|
||||
-- Keyboard events
|
||||
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar )
|
||||
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar )
|
||||
|
||||
-- Window quit
|
||||
_ <- GTK.onWidgetDestroy window GTK.mainQuit
|
||||
|
||||
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
|
||||
|
||||
mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar
|
||||
for_ mbDoc \ ( 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
|
||||
infoData :: InfoData
|
||||
infoData =
|
||||
InfoData
|
||||
{ zoom = zoomFactor
|
||||
, mousePos = toViewport ( Point2D x y )
|
||||
, topLeftPos = toViewport ( Point2D 0 0 )
|
||||
, botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
|
||||
}
|
||||
updateInfoBar infoBar infoData
|
||||
|
||||
pure False
|
||||
|
||||
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
|
||||
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' )
|
||||
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 False
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Keyboard events.
|
||||
|
||||
handleKeyboardPressEvent, handleKeyboardReleaseEvent :: STM.TVar [ Word32 ] -> GDK.EventKey -> IO Bool
|
||||
handleKeyboardPressEvent pressedKeysTVar evt = do
|
||||
keyCode <- GDK.getEventKeyKeyval evt
|
||||
|
|
@ -37,6 +195,9 @@ handleKeyboardReleaseEvent pressedKeysTVar evt = do
|
|||
STM.writeTVar pressedKeysTVar ( filter ( /= keyCode ) pressedKeys )
|
||||
pure True
|
||||
|
||||
--------------------
|
||||
-- GDK keycodes.
|
||||
|
||||
pattern Escape :: Word32
|
||||
pattern Escape = 0xff1b
|
||||
pattern Delete :: Word32
|
||||
|
|
|
|||
|
|
@ -1,21 +1,7 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module MetaBrush.UI.Coordinates
|
||||
( keepViewportCoordinatesUpdated )
|
||||
( toViewportCoordinates )
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Monad
|
||||
( unless, void )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Act
|
||||
|
|
@ -24,169 +10,14 @@ import Data.Act
|
|||
( (-->) )
|
||||
)
|
||||
|
||||
-- containers
|
||||
import Data.IntMap.Strict
|
||||
( IntMap )
|
||||
import qualified Data.IntMap.Strict as IntMap
|
||||
( insert, lookup )
|
||||
|
||||
-- gi-gdk
|
||||
import qualified GI.Gdk as GDK
|
||||
|
||||
-- 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, readTVarIO, writeTVar )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Module
|
||||
( (*^) )
|
||||
import Math.Vector2D
|
||||
( Point2D(..), Vector2D(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..), currentDocument )
|
||||
import MetaBrush.Event
|
||||
( pattern Control_L, pattern Control_R
|
||||
, pattern Shift_L, pattern Shift_R
|
||||
)
|
||||
import MetaBrush.UI.InfoBar
|
||||
( InfoBar, InfoData(..), updateInfoBar )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Updates viewport coordinates on mouse motion / mouse scroll.
|
||||
--
|
||||
-- * On a scroll event, modifies the viewport coordinates as required.
|
||||
-- * On a scroll event or a mouse motion event, updates the info bar coordinate display.
|
||||
--
|
||||
-- TODO: also update on change of document.
|
||||
keepViewportCoordinatesUpdated
|
||||
:: STM.TVar ( Maybe Int )
|
||||
-> STM.TVar ( IntMap Document )
|
||||
-> STM.TVar [ Word32 ]
|
||||
-> InfoBar
|
||||
-> GTK.DrawingArea
|
||||
-> IO ()
|
||||
keepViewportCoordinatesUpdated
|
||||
activeDocumentTVar
|
||||
openDocumentsTVar
|
||||
pressedKeysTVar
|
||||
infoBar
|
||||
viewportDrawingArea = do
|
||||
|
||||
-----------------------------------------------------------------
|
||||
-- Update mouse position on mouse move event.
|
||||
|
||||
void $ GTK.onWidgetMotionNotifyEvent viewportDrawingArea \ eventMotion -> do
|
||||
mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar
|
||||
infoData <- case mbDoc of
|
||||
Nothing ->
|
||||
pure $
|
||||
InfoData
|
||||
{ zoom = 1
|
||||
, mousePos = Point2D 0 0
|
||||
, topLeftPos = Point2D 0 0
|
||||
, botRightPos = Point2D 0 0
|
||||
}
|
||||
Just ( Document { .. } ) -> do
|
||||
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
|
||||
pure $
|
||||
InfoData
|
||||
{ zoom = zoomFactor
|
||||
, mousePos = toViewport ( Point2D x y )
|
||||
, topLeftPos = toViewport ( Point2D 0 0 )
|
||||
, botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
|
||||
}
|
||||
|
||||
updateInfoBar infoBar infoData
|
||||
pure False
|
||||
|
||||
-----------------------------------------------------------------
|
||||
-- Update coordinates on scroll event.
|
||||
|
||||
void $ GTK.onWidgetScrollEvent viewportDrawingArea \ 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
|
||||
STM.atomically ( STM.writeTVar openDocumentsTVar docs' )
|
||||
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
|
||||
|
||||
|
||||
toViewportCoordinates :: Double -> ( Double, Double ) -> Point2D Double -> Point2D Double -> Point2D Double
|
||||
toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter ( Point2D x y )
|
||||
= ( recip zoomFactor *^ ( Point2D ( 0.5 * viewportWidth ) ( 0.5 * viewportHeight ) --> Point2D x y :: Vector2D Double ) )
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module MetaBrush.UI.FileBar
|
||||
|
|
@ -35,23 +36,32 @@ import Data.Text
|
|||
( Text )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Vector2D
|
||||
( Point2D(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..) )
|
||||
import MetaBrush.Render.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
import MetaBrush.UI.Coordinates
|
||||
( toViewportCoordinates )
|
||||
import MetaBrush.UI.InfoBar
|
||||
( InfoBar, InfoData(..), updateInfoBar )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Add the file bar: tabs allowing selection of the active document.
|
||||
--
|
||||
-- Updates the active document when buttons are clicked.
|
||||
createFileBar
|
||||
:: STM.TVar ( Maybe Int )
|
||||
-> STM.TVar ( IntMap Document )
|
||||
-> GTK.Window
|
||||
-> GTK.Label
|
||||
-> GTK.DrawingArea
|
||||
-> InfoBar
|
||||
-> GTK.ScrolledWindow
|
||||
-> IO ( IntMap GTK.RadioButton )
|
||||
createFileBar activeDocumentTVar openDocumentsTVar window title viewportArea fileBar = do
|
||||
createFileBar activeDocumentTVar openDocumentsTVar window title viewportArea infoBar fileBar = do
|
||||
|
||||
widgetAddClass fileBar "fileBar"
|
||||
|
||||
|
|
@ -64,9 +74,9 @@ createFileBar activeDocumentTVar openDocumentsTVar window title viewportArea fil
|
|||
-- TODO: currently using static list of documents.
|
||||
-- Need to dynamically update this widget as the user opens/closes documents.
|
||||
documents <- STM.readTVarIO openDocumentsTVar
|
||||
fileButtons <- ( `IntMap.traverseWithKey` documents ) \ i ( Document { displayName, unsavedChanges } ) -> do
|
||||
fileButtons <- ( `IntMap.traverseWithKey` documents ) \ i ( Document { displayName = currDisplayName } ) -> do
|
||||
-- File tab elements.
|
||||
pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) displayName
|
||||
pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) currDisplayName
|
||||
GTK.toggleButtonSetMode pgButton False -- don't display radio indicator
|
||||
closeFileButton <- GTK.buttonNewWithLabel "x"
|
||||
|
||||
|
|
@ -95,7 +105,7 @@ createFileBar activeDocumentTVar openDocumentsTVar window title viewportArea fil
|
|||
Nothing -> do
|
||||
GTK.labelSetText title "MetaBrush"
|
||||
GTK.setWindowTitle window "MetaBrush"
|
||||
Just ( Document { displayName, unsavedChanges } ) -> do
|
||||
Just ( Document { .. } ) -> do
|
||||
let
|
||||
titleText :: Text
|
||||
titleText
|
||||
|
|
@ -105,6 +115,20 @@ createFileBar activeDocumentTVar openDocumentsTVar window title viewportArea fil
|
|||
= displayName <> " – MetaBrush"
|
||||
GTK.labelSetText title titleText
|
||||
GTK.setWindowTitle window titleText
|
||||
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportArea
|
||||
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportArea
|
||||
let
|
||||
toViewport :: Point2D Double -> Point2D Double
|
||||
toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
|
||||
infoData :: InfoData
|
||||
infoData =
|
||||
InfoData
|
||||
{ zoom = zoomFactor
|
||||
, mousePos = Point2D 0 0
|
||||
, topLeftPos = toViewport ( Point2D 0 0 )
|
||||
, botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
|
||||
}
|
||||
updateInfoBar infoBar infoData
|
||||
else do
|
||||
GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
|
||||
GTK.labelSetText title "MetaBrush"
|
||||
|
|
|
|||
|
|
@ -13,10 +13,13 @@ module Math.Bezier.Cubic
|
|||
( Bezier(..)
|
||||
, bezier, bezier'
|
||||
, subdivide
|
||||
, closestPoint
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.List.NonEmpty
|
||||
( NonEmpty(..) )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
|
||||
|
|
@ -27,12 +30,15 @@ import Data.Act
|
|||
)
|
||||
|
||||
-- MetaBrush
|
||||
import qualified Math.Bezier.Quadratic as Quadratic
|
||||
( Bezier(Bezier), bezier )
|
||||
import Math.Module
|
||||
( Module (..)
|
||||
, lerp
|
||||
, Inner(..), squaredNorm
|
||||
)
|
||||
import qualified Math.Bezier.Quadratic as Quadratic
|
||||
( Bezier(Bezier), bezier )
|
||||
import Math.RealRoots
|
||||
( realRoots )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -74,3 +80,41 @@ subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 )
|
|||
q2 = lerp @v t q1 s
|
||||
r1 = lerp @v t s r2
|
||||
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 pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots )
|
||||
where
|
||||
roots :: [ r ]
|
||||
roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots [ a0, a1, a2, a3, a4, a5 ] )
|
||||
|
||||
v, v', v'', v''' :: v
|
||||
v = c --> p0
|
||||
v' = p0 --> p1
|
||||
v'' = p1 --> p0 ^+^ p1 --> p2
|
||||
v''' = p0 --> p3 ^+^ 3 *^ ( p2 --> p1 )
|
||||
|
||||
a0, a1, a2, a3, a4, a5 :: r
|
||||
a0 = v ^.^ v'
|
||||
a1 = 3 * squaredNorm v' + 2 * v ^.^ v''
|
||||
a2 = 9 * v' ^.^ v'' + 3 * v ^.^ v'''
|
||||
a3 = 6 * squaredNorm v'' + 4 * v' ^.^ v'''
|
||||
a4 = 5 * v'' ^.^ v'''
|
||||
a5 = squaredNorm v'''
|
||||
|
||||
pickClosest :: NonEmpty 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 ( t' : ts )
|
||||
| nm' < nm = go t' p' nm' ts
|
||||
| otherwise = go t p nm ts
|
||||
where
|
||||
p' :: p
|
||||
p' = bezier @v pts t'
|
||||
nm' :: r
|
||||
nm' = squaredNorm ( c --> p' :: v )
|
||||
|
|
|
|||
|
|
@ -13,10 +13,13 @@ module Math.Bezier.Quadratic
|
|||
( Bezier(..)
|
||||
, bezier, bezier'
|
||||
, subdivide
|
||||
, closestPoint
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.List.NonEmpty
|
||||
( NonEmpty(..) )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
|
||||
|
|
@ -30,7 +33,10 @@ import Data.Act
|
|||
import Math.Module
|
||||
( Module (..)
|
||||
, lerp
|
||||
, Inner(..), squaredNorm
|
||||
)
|
||||
import Math.RealRoots
|
||||
( realRoots )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -61,3 +67,38 @@ subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 pt, Bezier pt r1 p2 )
|
|||
q1 = lerp @v t p0 p1
|
||||
r1 = lerp @v t p1 p2
|
||||
pt = lerp @v t q1 r1
|
||||
|
||||
-- | 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 -> ( r, p )
|
||||
closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots )
|
||||
where
|
||||
roots :: [ r ]
|
||||
roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots [ a0, a1, a2, a3 ] )
|
||||
|
||||
v, v', v'' :: v
|
||||
v = c --> p0
|
||||
v' = p0 --> p1
|
||||
v'' = p1 --> p0 ^+^ p1 --> p2
|
||||
|
||||
a0, a1, a2, a3 :: r
|
||||
a0 = v ^.^ v'
|
||||
a1 = v ^.^ v'' + 2 * squaredNorm v'
|
||||
a2 = 3 * ( v' ^.^ v'' )
|
||||
a3 = squaredNorm v''
|
||||
|
||||
pickClosest :: NonEmpty 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 ( t' : ts )
|
||||
| nm' < nm = go t' p' nm' ts
|
||||
| otherwise = go t p nm ts
|
||||
where
|
||||
p' :: p
|
||||
p' = bezier @v pts t'
|
||||
nm' :: r
|
||||
nm' = squaredNorm ( c --> p' :: v )
|
||||
|
|
|
|||
|
|
@ -4,8 +4,8 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Math.Module
|
||||
( Module(..)
|
||||
, lerp
|
||||
( Module(..), lerp
|
||||
, Inner(..), squaredNorm
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -20,7 +20,7 @@ import Data.Act
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
infixl 6 ^+^, ^-^
|
||||
infix 8 ^*, *^
|
||||
infix 9 ^*, *^
|
||||
|
||||
class Num r => Module r m | m -> r where
|
||||
|
||||
|
|
@ -37,3 +37,12 @@ class Num r => Module r m | m -> r where
|
|||
|
||||
lerp :: forall v r p. ( Module r v, Torsor v p ) => r -> p -> p -> p
|
||||
lerp t p0 p1 = ( t *^ ( p0 --> p1 :: v ) ) • p0
|
||||
|
||||
infixl 8 ^.^
|
||||
|
||||
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 v = v ^.^ v
|
||||
|
|
|
|||
115
src/lib/Math/RealRoots.hs
Normal file
115
src/lib/Math/RealRoots.hs
Normal file
|
|
@ -0,0 +1,115 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Math.RealRoots
|
||||
( realRoots )
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Complex
|
||||
( Complex(..), magnitude )
|
||||
import Data.List.NonEmpty
|
||||
( NonEmpty(..), toList )
|
||||
import Data.Maybe
|
||||
( mapMaybe )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Find real roots of a polynomial.
|
||||
realRoots :: forall r. RealFloat r => [ r ] -> [ r ]
|
||||
realRoots p = mapMaybe isReal ( roots eps 10000 ( map (:+ 0) p ) )
|
||||
where
|
||||
isReal :: Complex r -> Maybe r
|
||||
isReal ( a :+ b )
|
||||
| abs b < eps = Just a
|
||||
| otherwise = Nothing
|
||||
eps :: r
|
||||
eps = encodeFloat 1 ( 5 - floatDigits ( 0 :: r ) )
|
||||
|
||||
-- | Compute all roots of a polynomial using Laguerre's method and (forward) deflation.
|
||||
--
|
||||
-- Polynomial coefficients are given in order of ascending degree (e.g. constant coefficient first).
|
||||
--
|
||||
-- N.B. The forward deflation process is only guaranteed to be numerically stable
|
||||
-- if Laguerre's method finds roots in increasing order of magnitude.
|
||||
roots :: forall a. RealFloat a => a -> Int -> [ Complex a ] -> [ Complex a ]
|
||||
roots eps maxIters p = go p []
|
||||
where
|
||||
go :: [ Complex a ] -> [ Complex a ] -> [ Complex a ]
|
||||
go q rs
|
||||
| length q <= 2 = r : rs
|
||||
| otherwise = go ( deflate r q ) ( r : rs )
|
||||
where
|
||||
r :: Complex a
|
||||
r = laguerre eps maxIters q 0
|
||||
-- Start the iteration at 0 for best chance of numerical stability.
|
||||
|
||||
-- | Deflate a polynomial: factor out a root of the polynomial.
|
||||
--
|
||||
-- The polynomial must have degree at least 2.
|
||||
deflate :: forall a. Num a => a -> [ a ] -> [ a ]
|
||||
deflate r ( _ : c : cs ) = toList $ go ( c :| cs )
|
||||
where
|
||||
go :: NonEmpty a -> NonEmpty a
|
||||
go ( a :| [] ) = a :| []
|
||||
go ( a :| a' : as ) = case go ( a' :| as ) of
|
||||
( b' :| bs ) -> ( a + r * b' ) :| ( b' : bs )
|
||||
deflate _ _ = error "deflate: polynomial of degree < 2"
|
||||
|
||||
-- | Laguerre's method.
|
||||
laguerre
|
||||
:: forall a. RealFloat a
|
||||
=> a -- ^ error tolerance
|
||||
-> Int -- ^ max number of iterations
|
||||
-> [ Complex a ] -- ^ polynomial
|
||||
-> Complex a -- ^ initial point
|
||||
-> Complex a
|
||||
laguerre eps maxIters p x0 = go maxIters x0
|
||||
where
|
||||
p', p'' :: [ Complex a ]
|
||||
p' = derivative p
|
||||
p'' = derivative p'
|
||||
go :: Int -> Complex a -> Complex a
|
||||
go iterationsLeft x
|
||||
| iterationsLeft <= 0 = x
|
||||
| magnitude ( x' - x ) < eps = x'
|
||||
| otherwise = go ( iterationsLeft - 1 ) x'
|
||||
where
|
||||
x' :: Complex a
|
||||
x' = laguerreStep eps p p' p'' x
|
||||
|
||||
-- | Take a single step in Laguerre's method.
|
||||
laguerreStep
|
||||
:: forall a. RealFloat a
|
||||
=> a -- ^ error tolerance
|
||||
-> [ Complex a ] -- ^ polynomial
|
||||
-> [ Complex a ] -- ^ first derivative of polynomial
|
||||
-> [ Complex a ] -- ^ second derivative of polynomial
|
||||
-> Complex a -- ^ initial point
|
||||
-> Complex a
|
||||
laguerreStep eps p p' p'' x
|
||||
| magnitude px < eps = x
|
||||
| otherwise = x - n / denom
|
||||
where
|
||||
n = fromIntegral ( length p )
|
||||
px = eval p x
|
||||
p'x = eval p' x
|
||||
p''x = eval p'' x
|
||||
g = p'x / px
|
||||
g² = g * g
|
||||
h = g² - p''x / px
|
||||
delta = sqrt $ ( n - 1 ) * ( n * h - g² )
|
||||
gp = g + delta
|
||||
gm = g - delta
|
||||
denom
|
||||
| magnitude gm > magnitude gp
|
||||
= gm
|
||||
| otherwise
|
||||
= gp
|
||||
|
||||
-- | Evaluate a polynomial.
|
||||
eval :: Num a => [ a ] -> a -> a
|
||||
eval as x = foldr ( \ a b -> a + x * b ) 0 as
|
||||
|
||||
-- | Derivative of a polynomial.
|
||||
derivative :: Num a => [ a ] -> [ a ]
|
||||
derivative as = zipWith ( \ i a -> fromIntegral i * a ) [ ( 1 :: Int ) .. ] ( tail as )
|
||||
|
|
@ -32,7 +32,7 @@ import Data.Group.Generics
|
|||
|
||||
-- MetaBrush
|
||||
import Math.Module
|
||||
( Module (..) )
|
||||
( Module(..), Inner(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -52,3 +52,7 @@ instance Num a => Module a ( Vector2D a ) where
|
|||
|
||||
c *^ p = fmap ( c * ) p
|
||||
p ^* c = fmap ( * c ) p
|
||||
|
||||
instance Num a => Inner a ( Vector2D a ) where
|
||||
( Vector2D ( Point2D x1 y1 ) ) ^.^ ( Vector2D ( Point2D x2 y2 ) )
|
||||
= x1 * x2 + y1 * y2
|
||||
|
|
|
|||
Loading…
Reference in a new issue