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

add selection UI

Browse source
This commit is contained in:
sheaf 2020-08-14 00:47:10 +02:00
parent 8d50c92ca9
commit 91e1431306
15 changed files with 560 additions and 160 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
MetaBrush.cabal
View file

@ -30,6 +30,8 @@ common common
>= 4.13 && < 4.16 >= 4.13 && < 4.16
, acts , acts
^>= 0.3.1.0 ^>= 0.3.1.0
, groups
^>= 0.4.1.0
default-language: default-language:
Haskell2010 Haskell2010
@ -66,8 +68,6 @@ library
build-depends: build-depends:
generic-data generic-data
>= 0.8.0.0 && < 0.8.4.0 >= 0.8.0.0 && < 0.8.4.0
, groups
^>= 0.4.1.0
, groups-generic , groups-generic
^>= 0.1.0.0 ^>= 0.1.0.0
@ -92,9 +92,11 @@ executable MetaBrush
, MetaBrush.Asset.Tools , MetaBrush.Asset.Tools
, MetaBrush.Asset.WindowIcons , MetaBrush.Asset.WindowIcons
, MetaBrush.Document , MetaBrush.Document
, MetaBrush.Document.Selection
, MetaBrush.Event , MetaBrush.Event
, MetaBrush.Render.Document , MetaBrush.Render.Document
, MetaBrush.Render.Util , MetaBrush.Render.Util
, MetaBrush.Time
, MetaBrush.UI.Coordinates , MetaBrush.UI.Coordinates
, MetaBrush.UI.FileBar , MetaBrush.UI.FileBar
, MetaBrush.UI.InfoBar , MetaBrush.UI.InfoBar

24
app/Main.hs
View file

@ -58,11 +58,14 @@ import MetaBrush.Asset.Logo
import MetaBrush.Document import MetaBrush.Document
( Document(..), AABB(..) ( Document(..), AABB(..)
, Stroke(..), StrokePoint(..), PointType(..), FocusState(..) , Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
, Overlay
) )
import MetaBrush.Event import MetaBrush.Event
( handleEvents ) ( handleEvents )
import MetaBrush.Render.Util import MetaBrush.Render.Util
( widgetAddClass, widgetAddClasses ) ( widgetAddClass, widgetAddClasses )
import MetaBrush.Time
( Time )
import MetaBrush.UI.FileBar import MetaBrush.UI.FileBar
( createFileBar ) ( createFileBar )
import MetaBrush.UI.InfoBar import MetaBrush.UI.InfoBar
@ -72,7 +75,7 @@ import MetaBrush.UI.Menu
import MetaBrush.UI.Panels import MetaBrush.UI.Panels
( createPanelBar ) ( createPanelBar )
import MetaBrush.UI.ToolBar import MetaBrush.UI.ToolBar
( createToolBar ) ( Tool(..), Mode(..), createToolBar )
import MetaBrush.UI.Viewport import MetaBrush.UI.Viewport
( Viewport(..), createViewport ) ( Viewport(..), createViewport )
import qualified Paths_MetaBrush as Cabal import qualified Paths_MetaBrush as Cabal
@ -140,9 +143,14 @@ main = do
--------------------------------------------------------- ---------------------------------------------------------
-- Initialise state -- Initialise state
activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing
openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments
pressedKeysTVar <- STM.newTVarIO @[ Word32 ] [] 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 -- Initialise GTK
@ -251,7 +259,7 @@ main = do
--------------------------------------------------------- ---------------------------------------------------------
-- Tool bar -- Tool bar
_ <- createToolBar colours toolBar _ <- createToolBar toolTVar modeTVar colours toolBar
--------------------------------------------------------- ---------------------------------------------------------
-- Main viewport -- Main viewport
@ -261,6 +269,7 @@ main = do
colours colours
activeDocumentTVar activeDocumentTVar
openDocumentsTVar openDocumentsTVar
overlayTVar
viewportGrid viewportGrid
--------------------------------------------------------- ---------------------------------------------------------
@ -290,7 +299,10 @@ main = do
-- Actions -- Actions
handleEvents handleEvents
activeDocumentTVar openDocumentsTVar pressedKeysTVar activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar pressedKeysTVar
toolTVar modeTVar
overlayTVar
window viewportDrawingArea infoBarElements window viewportDrawingArea infoBarElements
--------------------------------------------------------- ---------------------------------------------------------

7
assets/theme.css
View file

@ -72,7 +72,12 @@
.glass { .glass {
color: rgba(156, 231, 255, 0.5); color: rgba(156, 231, 255, 0.5);
} }
.selection {
color: rgba(161,201,236,0.5)
}
.selectionOutline {
color: rgb(74,150,218);
}
/* Proper CSS styling */ /* Proper CSS styling */

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

@ -51,6 +51,8 @@ data ColourRecord a
, tabScrollbar :: !a , tabScrollbar :: !a
, magnifier :: !a , magnifier :: !a
, glass :: !a , glass :: !a
, selection :: !a
, selectionOutline :: !a
} }
deriving stock ( Show, Functor, Foldable, Traversable ) deriving stock ( Show, Functor, Foldable, Traversable )
@ -90,6 +92,8 @@ colourNames = Colours
, tabScrollbar = ColourName "tabScrollbar" BackgroundColour [ GTK.StateFlagsNormal ] , tabScrollbar = ColourName "tabScrollbar" BackgroundColour [ 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 ]
, selection = ColourName "selection" Colour [ GTK.StateFlagsNormal ]
, selectionOutline = ColourName "selectionOutline" Colour [ GTK.StateFlagsNormal ]
} }
type Colours = ColourRecord GDK.RGBA type Colours = ColourRecord GDK.RGBA

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

@ -72,6 +72,10 @@ data FocusState
| Selected | Selected
deriving stock Show 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 :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> IO ( Maybe Document )
currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do currentDocument activeDocumentTVar openDocumentsTVar = STM.atomically do
mbActive <- STM.readTVar activeDocumentTVar mbActive <- STM.readTVar activeDocumentTVar

21
src/app/MetaBrush/Document/Selection.hs Normal file
View 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

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

@ -11,9 +11,6 @@ import Control.Monad
( unless ) ( unless )
import Data.Foldable import Data.Foldable
( for_ ) ( for_ )
-- base
import Data.Semigroup
( Arg(..), Min(..) )
import Data.Word import Data.Word
( Word32 ) ( Word32 )
@ -38,10 +35,12 @@ import qualified GI.Gdk as GDK
import qualified GI.Gtk as GTK import qualified GI.Gtk as GTK
-- stm -- stm
import Control.Concurrent.STM
( STM )
import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM as STM
( atomically ) ( atomically )
import qualified Control.Concurrent.STM.TVar as STM import qualified Control.Concurrent.STM.TVar as STM
( TVar, readTVar, readTVarIO, writeTVar ) ( TVar, readTVar, readTVarIO, writeTVar, swapTVar )
-- MetaBrush -- MetaBrush
import Math.Module import Math.Module
@ -49,139 +48,311 @@ import Math.Module
import Math.Vector2D import Math.Vector2D
( Point2D(..), Vector2D(..) ) ( Point2D(..), Vector2D(..) )
import MetaBrush.Document import MetaBrush.Document
( Document(..), currentDocument ) ( Document(..), Overlay(..) )
import MetaBrush.Document.Selection
( selectAt, selectRectangle )
import MetaBrush.Time
( Time, monotonicTime, DTime(DSeconds) )
import MetaBrush.UI.Coordinates import MetaBrush.UI.Coordinates
( closestPoint, toViewportCoordinates ) ( toViewportCoordinates )
import MetaBrush.UI.InfoBar import MetaBrush.UI.InfoBar
( InfoBar, InfoData(..), updateInfoBar ) ( 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
handleEvents activeDocumentTVar openDocumentsTVar pressedKeysTVar window viewportDrawingArea infoBar = do :: 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 -- Mouse events
_ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea _ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea
( handleMotionEvent activeDocumentTVar openDocumentsTVar viewportDrawingArea infoBar ) ( handleMotionEvent activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar toolTVar overlayTVar viewportDrawingArea infoBar )
_ <- GTK.onWidgetScrollEvent viewportDrawingArea _ <- GTK.onWidgetScrollEvent viewportDrawingArea
( handleScrollEvent activeDocumentTVar openDocumentsTVar pressedKeysTVar viewportDrawingArea infoBar ) ( 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 -- Keyboard events
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar ) _ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar )
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar ) _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar )
-- Window quit -- Window quit
_ <- GTK.onWidgetDestroy window GTK.mainQuit _ <- GTK.onWidgetDestroy window GTK.mainQuit
pure () pure ()
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Mouse events. -- Mouse events.
handleMotionEvent :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document ) -> GTK.DrawingArea -> InfoBar -> GDK.EventMotion -> IO Bool handleMotionEvent
handleMotionEvent activeDocumentTVar openDocumentsTVar viewportDrawingArea infoBar eventMotion = do :: STM.TVar ( Maybe Int ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe ( Point2D Double ) ) -> STM.TVar ( Maybe ( Point2D Double, Time ) )
mbActiveDoc <- STM.readTVarIO activeDocumentTVar -> STM.TVar Tool
for_ mbActiveDoc \ i -> do -> STM.TVar ( Maybe Overlay )
docs <- STM.readTVarIO openDocumentsTVar -> GTK.DrawingArea -> InfoBar
for_ ( IntMap.lookup i docs ) \ doc@( Document { .. } ) -> do -> GDK.EventMotion
-> IO Bool
---------------------------------------------------------- handleMotionEvent
-- Update mouse position in info bar on mouse move event. activeDocumentTVar openDocumentsTVar
mousePosTVar mouseHoldTVar
x <- GDK.getEventMotionX eventMotion toolTVar
y <- GDK.getEventMotionY eventMotion overlayTVar
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea viewportDrawingArea infoBar
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea eventMotion
let = do
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
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 mbActiveDoc <- STM.readTVarIO activeDocumentTVar
for_ mbActiveDoc \ i -> do for_ mbActiveDoc \ i -> do
docs <- STM.readTVarIO openDocumentsTVar docs <- STM.readTVarIO openDocumentsTVar
for_ ( IntMap.lookup i docs ) \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do for_ ( IntMap.lookup i docs ) \ ( Document { .. } ) -> do
pressedKeys <- STM.readTVarIO pressedKeysTVar
----------------------------------------------------------
-- 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 let
toViewport :: Point2D Double -> Point2D Double toViewport :: Point2D Double -> Point2D Double
toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
-- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates) pos :: Point2D Double
mousePos :: Point2D Double pos = toViewport ( Point2D x y )
mousePos = toViewport ( Point2D x y ) infoData :: InfoData
newDoc :: Document infoData =
newDoc InfoData
-- Zooming using 'Control'. { zoom = zoomFactor
| any ( \ key -> key == Control_L || key == Control_R ) pressedKeys , mousePos = pos
= let , topLeftPos = toViewport ( Point2D 0 0 )
newZoomFactor :: Double , botRightPos = toViewport ( Point2D viewportWidth viewportHeight )
newZoomFactor }
| dy > 0 updateInfoBar infoBar infoData
= max 0.0078125 ( oldZoomFactor / sqrt 2 ) STM.atomically do
| otherwise STM.writeTVar mousePosTVar ( Just pos )
= min 256 ( oldZoomFactor * sqrt 2 )
newCenter :: Point2D Double ----------------------------------------------------------
newCenter -- Tool dependent updating.
= ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double ) updateOverlay mouseHoldTVar toolTVar overlayTVar pos
• 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 GTK.widgetQueueDraw viewportDrawingArea
let pure True
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 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. -- Keyboard events.

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

@ -11,7 +11,7 @@ module MetaBrush.Render.Document
-- base -- base
import Data.Foldable import Data.Foldable
( traverse_ ) ( for_, traverse_ )
import Data.Functor.Compose import Data.Functor.Compose
( Compose(..) ) ( Compose(..) )
import Data.Int import Data.Int
@ -32,6 +32,7 @@ import MetaBrush.Asset.Colours
import MetaBrush.Document import MetaBrush.Document
( Document(..) ( Document(..)
, Stroke(..), StrokePoint(..), PointType(..), FocusState(..) , Stroke(..), StrokePoint(..), PointType(..), FocusState(..)
, Overlay(..)
) )
import MetaBrush.Render.Util import MetaBrush.Render.Util
( withRGBA ) ( withRGBA )
@ -55,8 +56,8 @@ pattern Renders { renderPoints, renderPaths } = Compose ( MkRenders renderPoints
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
renderDocument :: Colours -> ( Int32, Int32 ) -> Document -> Cairo.Render () renderDocument :: Colours -> ( Int32, Int32 ) -> Document -> Maybe Overlay -> Cairo.Render ()
renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCenter = Point2D cx cy, .. } ) = do renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCenter = Point2D cx cy, .. } ) mbOverlay = do
Cairo.save Cairo.save
Cairo.translate ( 0.5 * fromIntegral viewportWidth ) ( 0.5 * fromIntegral viewportHeight ) Cairo.translate ( 0.5 * fromIntegral viewportWidth ) ( 0.5 * fromIntegral viewportHeight )
@ -64,9 +65,10 @@ renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCente
Cairo.translate ( -cx ) ( -cy ) Cairo.translate ( -cx ) ( -cy )
let let
Renders { renderPoints, renderPaths } = traverse_ ( renderStroke cols zoomFactor ) strokes Renders rdrPoints rdrPaths = traverse_ ( renderStroke cols zoomFactor ) strokes
renderPaths rdrPaths
renderPoints rdrPoints
for_ mbOverlay ( renderOverlay cols zoomFactor )
Cairo.restore Cairo.restore
@ -244,3 +246,24 @@ drawCubicBezier ( Colours { path } ) zoom
Cairo.stroke Cairo.stroke
Cairo.restore 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
View 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

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

@ -18,14 +18,16 @@ import Data.Act
) )
-- MetaBrush -- MetaBrush
import qualified Math.Bezier.Cubic as Cubic
( Bezier(..), closestPoint )
import qualified Math.Bezier.Quadratic as Quadratic import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..), closestPoint ) ( Bezier(..), closestPoint )
import Math.Module import Math.Module
( (*^), squaredNorm ) ( (*^), squaredNorm, closestPointToLine )
import Math.Vector2D import Math.Vector2D
( Point2D(..), Vector2D(..) ) ( Point2D(..), Vector2D(..) )
import MetaBrush.Document import MetaBrush.Document
( Stroke(..) ) ( Stroke(..), StrokePoint(..), PointType(..) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -36,15 +38,32 @@ toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCente
• viewportCenter • viewportCenter
-- | Find the closest point in a set of strokes. -- | Find the closest point in a set of strokes.
closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Point2D Double ) closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Maybe ( Point2D Double ) )
closestPoint = undefined closestPoint c ( Stroke { strokePoints = ( pt0 : pts ), strokeVisible = True } ) = go pt0 pts
{-
closestPoint c ( Stroke pts ) = go pts
where where
go :: [ Point2D Double ] -> ArgMin Double ( Point2D Double ) res :: Point2D Double -> ArgMin Double ( Maybe ( Point2D Double ) )
go [] = error "'closestPoint': empty stroke" res p = Min $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p )
go [p] = Min ( Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) p ) go :: StrokePoint -> [ StrokePoint ] -> ArgMin Double ( Maybe ( Point2D Double ) )
go (p0:p1:p2:ps) go p0 [] = res ( strokePoint p0 )
= fmap ( fmap snd ) ( Quadratic.closestPoint @(Vector2D Double) ( Quadratic.Bezier { .. } ) c ) -- Line.
<> go (p2:ps) 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

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

@ -1,10 +1,13 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.UI.ToolBar module MetaBrush.UI.ToolBar
( ToolBar(..), createToolBar ) ( Tool(..), Mode(..)
, ToolBar(..), createToolBar
)
where where
-- base -- base
@ -20,6 +23,12 @@ import qualified GI.Cairo.Render.Connector as Cairo
-- gi-gtk -- gi-gtk
import qualified GI.Gtk as 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 -- MetaBrush
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( 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 data ToolBar
= ToolBar = ToolBar
{ selectionTool :: !GTK.RadioButton { selectionTool :: !GTK.RadioButton
@ -41,8 +61,8 @@ data ToolBar
, metaTool :: !GTK.RadioButton , metaTool :: !GTK.RadioButton
} }
createToolBar :: Colours -> GTK.Box -> IO ToolBar createToolBar :: STM.TVar Tool -> STM.TVar Mode -> Colours -> GTK.Box -> IO ToolBar
createToolBar colours toolBar = do createToolBar toolTVar modeTVar colours toolBar = do
widgetAddClass toolBar "toolBar" widgetAddClass toolBar "toolBar"
@ -52,11 +72,23 @@ createToolBar colours toolBar = do
selectionTool <- GTK.radioButtonNew ( [] @GTK.RadioButton ) selectionTool <- GTK.radioButtonNew ( [] @GTK.RadioButton )
penTool <- GTK.radioButtonNewFromWidget ( Just selectionTool ) 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 ) pathTool <- GTK.radioButtonNew ( [] @GTK.RadioButton )
brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool ) brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
metaTool <- 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 selectionTool True True 0
GTK.boxPackStart toolBar penTool True True 0 GTK.boxPackStart toolBar penTool True True 0

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

@ -30,13 +30,15 @@ import qualified GI.Gtk as GTK
-- stm -- stm
import qualified Control.Concurrent.STM.TVar as STM import qualified Control.Concurrent.STM.TVar as STM
( TVar ) ( TVar, readTVarIO )
-- MetaBrush -- MetaBrush
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( Colours ) ( Colours )
import MetaBrush.Document import MetaBrush.Document
( Document(..), currentDocument ) ( Document(..), currentDocument
, Overlay
)
import MetaBrush.Render.Document import MetaBrush.Render.Document
( renderDocument ) ( renderDocument )
import MetaBrush.Render.Util import MetaBrush.Render.Util
@ -53,9 +55,10 @@ createViewport
:: Colours :: Colours
-> STM.TVar ( Maybe Int ) -> STM.TVar ( Maybe Int )
-> STM.TVar ( IntMap Document ) -> STM.TVar ( IntMap Document )
-> STM.TVar ( Maybe Overlay )
-> GTK.Grid -> GTK.Grid
-> IO Viewport -> IO Viewport
createViewport colours activeDocumentTVar openDocumentsTVar viewportGrid = do createViewport colours activeDocumentTVar openDocumentsTVar overlayTVar viewportGrid = do
widgetAddClass viewportGrid "viewport" widgetAddClass viewportGrid "viewport"
@ -142,11 +145,12 @@ createViewport colours activeDocumentTVar openDocumentsTVar viewportGrid = do
void $ GTK.onWidgetDraw viewportDrawingArea \ctx -> do void $ GTK.onWidgetDraw viewportDrawingArea \ctx -> do
-- Get the relevant document information -- Get the relevant document information
mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar
mbOverlay <- STM.readTVarIO overlayTVar
for_ mbDoc \ doc -> do for_ mbDoc \ doc -> do
( `Cairo.renderWithContext` ctx ) $ do ( `Cairo.renderWithContext` ctx ) $ do
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
renderDocument colours ( viewportWidth, viewportHeight ) doc renderDocument colours ( viewportWidth, viewportHeight ) doc mbOverlay
pure True pure True
pure ( Viewport { .. } ) pure ( Viewport { .. } )

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

@ -20,6 +20,8 @@ module Math.Bezier.Cubic
-- base -- base
import Data.List.NonEmpty import Data.List.NonEmpty
( NonEmpty(..) ) ( NonEmpty(..) )
import Data.Semigroup
( ArgMin, Min(..), Arg(..) )
import GHC.Generics import GHC.Generics
( Generic ) ( Generic )
@ -82,7 +84,7 @@ subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 )
pt = lerp @v t q2 r1 pt = lerp @v t q2 r1
-- | 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 -> ( 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 ]
@ -102,14 +104,14 @@ closestPoint pts@( Bezier { .. } ) c = pickClosest ( 0 :| 1 : roots )
a4 = 5 * v'' ^.^ v''' a4 = 5 * v'' ^.^ v'''
a5 = squaredNorm v''' a5 = squaredNorm v'''
pickClosest :: NonEmpty r -> ( r, p ) pickClosest :: NonEmpty r -> ArgMin r ( r, p )
pickClosest ( s :| ss ) = go s q nm0 ss pickClosest ( s :| ss ) = go s q nm0 ss
where where
q :: p q :: p
q = bezier @v pts s q = bezier @v pts s
nm0 :: r nm0 :: r
nm0 = squaredNorm ( c --> q :: v ) 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 ) go t p nm ( t' : ts )
| nm' < nm = go t' p' nm' ts | nm' < nm = go t' p' nm' ts
| otherwise = go t p nm ts | otherwise = go t p nm ts

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

@ -6,6 +6,7 @@
module Math.Module module Math.Module
( Module(..), lerp ( Module(..), lerp
, Inner(..), squaredNorm , Inner(..), squaredNorm
, proj, projC, closestPointToLine
) )
where where
@ -44,5 +45,30 @@ class Module r m => Inner r m where
(^.^) :: m -> m -> r (^.^) :: m -> m -> r
-- | Squared norm of a vector, computed using the inner product. -- | 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 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

4
src/lib/Math/Vector2D.hs
View file

@ -37,12 +37,12 @@ import Math.Module
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data Point2D a = Point2D !a !a 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 ) ) deriving ( Act ( Vector2D a ), Torsor ( Vector2D a ) )
via Vector2D a via Vector2D a
newtype Vector2D a = Vector2D { tip :: Point2D 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 ) deriving ( Semigroup, Monoid, Group )
via GenericProduct ( Point2D ( Sum a ) ) via GenericProduct ( Point2D ( Sum a ) )