mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
basic rendering, mousewheel scrolling
This commit is contained in:
sheaf
parent
8e051c0f14
commit
9fc7b8acb3
|
|
@ -28,6 +28,8 @@ common common
|
|||
build-depends:
|
||||
base
|
||||
>= 4.13 && < 4.16
|
||||
, acts
|
||||
^>= 0.3.1.0
|
||||
|
||||
default-language:
|
||||
Haskell2010
|
||||
|
|
@ -61,9 +63,7 @@ library
|
|||
, Math.Vector2D
|
||||
|
||||
build-depends:
|
||||
acts
|
||||
^>= 0.3.1.0
|
||||
, generic-data
|
||||
generic-data
|
||||
>= 0.8.0.0 && < 0.8.4.0
|
||||
, groups
|
||||
^>= 0.4.1.0
|
||||
|
|
@ -92,8 +92,8 @@ executable MetaBrush
|
|||
, MetaBrush.Asset.WindowIcons
|
||||
, MetaBrush.Document
|
||||
, MetaBrush.Event
|
||||
, MetaBrush.Render.Document
|
||||
, MetaBrush.Render.Util
|
||||
, MetaBrush.Stroke
|
||||
, MetaBrush.UI.Menu
|
||||
, Paths_MetaBrush
|
||||
|
||||
|
|
@ -105,8 +105,12 @@ executable MetaBrush
|
|||
|
||||
build-depends:
|
||||
MetaBrush
|
||||
, containers
|
||||
>= 0.6.0.1 && < 0.6.4
|
||||
, directory
|
||||
>= 1.3.4.0 && < 1.4
|
||||
--, fingertree
|
||||
-- >= 0.1.4.2 && < 0.2
|
||||
, generic-lens
|
||||
>= 1.2.0.1 && < 2.0
|
||||
, gi-gdk
|
||||
|
|
@ -123,5 +127,7 @@ executable MetaBrush
|
|||
^>= 0.0.1
|
||||
, haskell-gi-base
|
||||
^>= 0.24
|
||||
, stm
|
||||
^>= 2.5.0.0
|
||||
, text
|
||||
^>= 1.2.3.1 && < 1.2.5
|
||||
|
|
|
|||
273
app/Main.hs
273
app/Main.hs
|
|
@ -2,8 +2,10 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE NegativeLiterals #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
|
|
@ -13,14 +15,28 @@ module Main
|
|||
|
||||
-- base
|
||||
import Control.Monad
|
||||
( void )
|
||||
( void, unless )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
import Data.Int
|
||||
( Int32 )
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
import System.Exit
|
||||
( exitSuccess )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Act
|
||||
( (•) )
|
||||
)
|
||||
|
||||
-- containers
|
||||
import Data.IntMap.Strict
|
||||
( IntMap )
|
||||
import qualified Data.IntMap.Strict as IntMap
|
||||
( fromList, lookup, insert, traverseWithKey )
|
||||
|
||||
-- directory
|
||||
import qualified System.Directory as Directory
|
||||
( canonicalizePath )
|
||||
|
|
@ -38,11 +54,21 @@ 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
|
||||
( newTVarIO, writeTVar, readTVarIO )
|
||||
|
||||
-- text
|
||||
import qualified Data.Text as Text
|
||||
( pack )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Module
|
||||
( (*^) )
|
||||
import Math.Vector2D
|
||||
( Point2D(..), Vector2D(..) )
|
||||
import MetaBrush.Asset.Colours
|
||||
( getColours )
|
||||
import MetaBrush.Asset.Cursor
|
||||
|
|
@ -55,8 +81,18 @@ import MetaBrush.Asset.Tools
|
|||
( drawBrush, drawMeta, drawPath, drawPen )
|
||||
import MetaBrush.Asset.WindowIcons
|
||||
( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
|
||||
import MetaBrush.Document
|
||||
( Document(..)
|
||||
, AABB(..)
|
||||
, Stroke(..)
|
||||
)
|
||||
import MetaBrush.Event
|
||||
( handleKeyboardPressEvent, handleKeyboardReleaseEvent )
|
||||
( handleKeyboardPressEvent, handleKeyboardReleaseEvent
|
||||
, pattern Control_L, pattern Control_R
|
||||
, pattern Shift_L, pattern Shift_R
|
||||
)
|
||||
import MetaBrush.Render.Document
|
||||
( renderDocument )
|
||||
import MetaBrush.Render.Util
|
||||
( widgetAddClass, widgetAddClasses )
|
||||
import MetaBrush.UI.Menu
|
||||
|
|
@ -66,9 +102,41 @@ import qualified Paths_MetaBrush as Cabal
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
testDocuments :: IntMap Document
|
||||
testDocuments = IntMap.fromList
|
||||
$ zip [0..]
|
||||
[ Document
|
||||
{ displayName = "Document 1"
|
||||
, filePath = Nothing
|
||||
, unsavedChanges = False
|
||||
, strokes = [ Stroke [ Point2D 10 10, Point2D 30 30, Point2D 40 70 ] ]
|
||||
, bounds = AABB ( Point2D 0 0 ) ( Point2D 100 100 )
|
||||
, viewportCenter = Point2D 50 50
|
||||
, zoomFactor = 1
|
||||
}
|
||||
, Document
|
||||
{ displayName = "Document 2"
|
||||
, filePath = Nothing
|
||||
, unsavedChanges = True
|
||||
, strokes = [ Stroke [ Point2D 0 0, Point2D 10 10, Point2D 20 20 ] ]
|
||||
, bounds = AABB ( Point2D 0 0 ) ( Point2D 50 50 )
|
||||
, viewportCenter = Point2D 10 10
|
||||
, zoomFactor = 0.25
|
||||
}
|
||||
]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Initialise state
|
||||
|
||||
activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing
|
||||
openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments
|
||||
pressedKeysTVar <- STM.newTVarIO @[ Word32 ] []
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Initialise GTK
|
||||
|
||||
|
|
@ -84,7 +152,7 @@ main = do
|
|||
windowWidgetPath <- GTK.widgetGetPath window
|
||||
widgetAddClass window "window"
|
||||
GTK.setWindowResizable window True
|
||||
GTK.setWindowDecorated window True
|
||||
GTK.setWindowDecorated window False
|
||||
GTK.setWindowTitle window "MetaBrush"
|
||||
GTK.windowSetDefaultSize window 800 600
|
||||
|
||||
|
|
@ -219,7 +287,6 @@ main = do
|
|||
$ Cairo.renderWithContext
|
||||
( drawClose colours )
|
||||
|
||||
|
||||
for_ [ minimiseButton, fullscreenButton, closeButton ] \ button -> do
|
||||
widgetAddClass button "windowIcon"
|
||||
|
||||
|
|
@ -293,61 +360,7 @@ main = do
|
|||
$ Cairo.renderWithContext
|
||||
( drawMeta colours )
|
||||
|
||||
---------------------------------------------------------
|
||||
-- File bar
|
||||
|
||||
widgetAddClass fileBar "fileBar"
|
||||
|
||||
fileTabs <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
GTK.containerAdd fileBar fileTabs
|
||||
widgetAddClasses fileTabs [ "fileBar", "plain", "text" ]
|
||||
|
||||
fileBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton )
|
||||
|
||||
for_ [ 1 .. 12 ] \ i -> do
|
||||
-- File tab elements.
|
||||
pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) ( "New Document (" <> Text.pack ( show i ) <> ")" )
|
||||
GTK.toggleButtonSetMode pgButton False -- don't display radio indicator
|
||||
closeFileButton <- GTK.buttonNewWithLabel "x"
|
||||
|
||||
-- Create box for file tab elements.
|
||||
tab <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
widgetAddClasses tab [ "fileBarTab" ]
|
||||
GTK.boxPackStart fileTabs tab False False 0
|
||||
GTK.boxPackStart tab pgButton True True 0
|
||||
GTK.boxPackStart tab closeFileButton False False 0
|
||||
|
||||
widgetAddClasses pgButton [ "fileBarTabButton" ]
|
||||
widgetAddClasses closeFileButton [ "fileBarCloseButton" ]
|
||||
|
||||
-- Make both file tab elements activate styling on the whole tab
|
||||
-- (e.g. hovering over the close file button should highlight the whole tab).
|
||||
void $ GTK.onButtonClicked pgButton do
|
||||
isActive <- GTK.toggleButtonGetActive pgButton
|
||||
flags <- GTK.widgetGetStateFlags tab
|
||||
if isActive
|
||||
then GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True
|
||||
else GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
|
||||
|
||||
{-
|
||||
void $ GTK.onButtonClicked closeFileButton do
|
||||
closeFileDialog ...
|
||||
-}
|
||||
|
||||
for_ @_ @_ @_ @() [ Exists @GTK.IsWidget pgButton, Exists @GTK.IsWidget closeFileButton ] \ ( Exists button ) -> do
|
||||
void $ GTK.onWidgetEnterNotifyEvent button \ _ -> do
|
||||
flags <- GTK.widgetGetStateFlags tab
|
||||
GTK.widgetSetStateFlags tab ( GTK.StateFlagsPrelight : flags ) True
|
||||
pure False
|
||||
void $ GTK.onWidgetLeaveNotifyEvent button \ _ -> do
|
||||
flags <- GTK.widgetGetStateFlags tab
|
||||
GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsPrelight ) flags ) True
|
||||
pure False
|
||||
|
||||
GTK.scrolledWindowSetPolicy fileBar GTK.PolicyTypeAutomatic GTK.PolicyTypeNever
|
||||
GTK.scrolledWindowSetOverlayScrolling fileBar True
|
||||
|
||||
---------------------------------------------------------
|
||||
---------------------------------------------------------
|
||||
-- Main viewport
|
||||
|
||||
widgetAddClass viewportGrid "viewport"
|
||||
|
|
@ -362,6 +375,9 @@ main = do
|
|||
GTK.gridAttach viewportGrid rvTopRuler 1 0 1 1
|
||||
GTK.gridAttach viewportGrid viewportOverlay 1 1 1 1
|
||||
|
||||
----------
|
||||
-- Rulers
|
||||
|
||||
rulerCorner <- GTK.boxNew GTK.OrientationVertical 0
|
||||
leftRuler <- GTK.boxNew GTK.OrientationVertical 0
|
||||
topRuler <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
|
|
@ -403,8 +419,12 @@ main = do
|
|||
viewportArea <- GTK.drawingAreaNew
|
||||
GTK.setContainerChild viewportOverlay viewportArea
|
||||
|
||||
-----------------
|
||||
-- Viewport scrolling
|
||||
|
||||
viewportScrollbarGrid <- GTK.gridNew
|
||||
GTK.overlayAddOverlay viewportOverlay viewportScrollbarGrid
|
||||
GTK.overlaySetOverlayPassThrough viewportOverlay viewportScrollbarGrid True
|
||||
|
||||
viewportHScrollbar <- GTK.scrollbarNew GTK.OrientationHorizontal ( Nothing @GTK.Adjustment )
|
||||
viewportVScrollbar <- GTK.scrollbarNew GTK.OrientationVertical ( Nothing @GTK.Adjustment )
|
||||
|
|
@ -417,6 +437,129 @@ main = do
|
|||
widgetAddClass viewportHScrollbar "viewportScrollbar"
|
||||
widgetAddClass viewportVScrollbar "viewportScrollbar"
|
||||
|
||||
void $ GTK.onWidgetScrollEvent viewportArea \ scrollEvent -> do
|
||||
|
||||
dx <- GDK.getEventScrollDeltaX scrollEvent
|
||||
dy <- GDK.getEventScrollDeltaY scrollEvent
|
||||
--GDK.getEventScrollDirection scrollEvent
|
||||
--GDK.getEventScrollType scrollEvent
|
||||
--GDK.getEventScrollX scrollEvent
|
||||
--GDK.getEventScrollY scrollEvent
|
||||
|
||||
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, zoomFactor } ) ) -> do
|
||||
pressedKeys <- STM.readTVarIO pressedKeysTVar
|
||||
let
|
||||
newDoc :: Document
|
||||
newDoc
|
||||
-- Zooming using 'Control'.
|
||||
| any ( \ key -> key == Control_L || key == Control_R ) pressedKeys
|
||||
= let
|
||||
newZoomFactor :: Double
|
||||
newZoomFactor
|
||||
| dy > 0
|
||||
= max 0.0078125 ( zoomFactor / 2 )
|
||||
| otherwise
|
||||
= zoomFactor * 2
|
||||
in doc { zoomFactor = newZoomFactor }
|
||||
-- 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 / zoomFactor ) *^ Vector2D ( Point2D dy 0 ) ) • viewportCenter
|
||||
in doc { viewportCenter = newCenter }
|
||||
-- Vertical scrolling.
|
||||
| otherwise
|
||||
= let
|
||||
newCenter :: Point2D Double
|
||||
newCenter = ( ( 25 / zoomFactor ) *^ Vector2D ( Point2D dx dy ) ) • viewportCenter
|
||||
in doc { viewportCenter = newCenter }
|
||||
docs' :: IntMap Document
|
||||
docs' = IntMap.insert i newDoc docs
|
||||
STM.atomically ( STM.writeTVar openDocumentsTVar docs' )
|
||||
GTK.widgetQueueDraw viewportArea
|
||||
pure True
|
||||
|
||||
-----------------
|
||||
-- Rendering
|
||||
|
||||
void $ GTK.onWidgetDraw viewportArea \ctx -> do
|
||||
-- Get the relevant document information
|
||||
mbActiveDoc <- STM.readTVarIO activeDocumentTVar
|
||||
for_ mbActiveDoc \ i -> do
|
||||
docs <- STM.readTVarIO openDocumentsTVar
|
||||
for_ ( IntMap.lookup i docs ) \ doc -> do
|
||||
( `Cairo.renderWithContext` ctx ) $ do
|
||||
viewportWidth <- GTK.widgetGetAllocatedWidth viewportArea
|
||||
viewportHeight <- GTK.widgetGetAllocatedHeight viewportArea
|
||||
renderDocument colours ( viewportWidth, viewportHeight ) doc
|
||||
pure True
|
||||
|
||||
---------------------------------------------------------
|
||||
-- File bar
|
||||
|
||||
widgetAddClass fileBar "fileBar"
|
||||
|
||||
fileTabs <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
GTK.containerAdd fileBar fileTabs
|
||||
widgetAddClasses fileTabs [ "fileBar", "plain", "text" ]
|
||||
|
||||
fileBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton )
|
||||
|
||||
-- TODO: currently using static list of documents.
|
||||
-- Need to dynamically update this widget as the user opens/closes documents.
|
||||
fileButtons <- ( `IntMap.traverseWithKey` testDocuments ) \ i ( Document { displayName, unsavedChanges } ) -> do
|
||||
-- File tab elements.
|
||||
pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) displayName
|
||||
GTK.toggleButtonSetMode pgButton False -- don't display radio indicator
|
||||
closeFileButton <- GTK.buttonNewWithLabel "x"
|
||||
|
||||
-- Create box for file tab elements.
|
||||
tab <- GTK.boxNew GTK.OrientationHorizontal 0
|
||||
widgetAddClasses tab [ "fileBarTab" ]
|
||||
GTK.boxPackStart fileTabs tab False False 0
|
||||
GTK.boxPackStart tab pgButton True True 0
|
||||
GTK.boxPackStart tab closeFileButton False False 0
|
||||
|
||||
widgetAddClasses pgButton [ "fileBarTabButton" ]
|
||||
widgetAddClasses closeFileButton [ "fileBarCloseButton" ]
|
||||
|
||||
-- Make both file tab elements activate styling on the whole tab
|
||||
-- (e.g. hovering over the close file button should highlight the whole tab).
|
||||
void $ GTK.onButtonClicked pgButton do
|
||||
isActive <- GTK.toggleButtonGetActive pgButton
|
||||
flags <- GTK.widgetGetStateFlags tab
|
||||
if isActive
|
||||
then do
|
||||
GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True
|
||||
STM.atomically ( STM.writeTVar activeDocumentTVar ( Just i ) )
|
||||
GTK.widgetQueueDraw viewportArea
|
||||
else
|
||||
GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
|
||||
|
||||
{-
|
||||
void $ GTK.onButtonClicked closeFileButton do
|
||||
closeFileDialog ...
|
||||
-}
|
||||
|
||||
for_ @_ @_ @_ @() [ Exists @GTK.IsWidget pgButton, Exists @GTK.IsWidget closeFileButton ] \ ( Exists button ) -> do
|
||||
void $ GTK.onWidgetEnterNotifyEvent button \ _ -> do
|
||||
flags <- GTK.widgetGetStateFlags tab
|
||||
GTK.widgetSetStateFlags tab ( GTK.StateFlagsPrelight : flags ) True
|
||||
pure False
|
||||
void $ GTK.onWidgetLeaveNotifyEvent button \ _ -> do
|
||||
flags <- GTK.widgetGetStateFlags tab
|
||||
GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsPrelight ) flags ) True
|
||||
pure False
|
||||
|
||||
pure pgButton
|
||||
|
||||
GTK.scrolledWindowSetPolicy fileBar GTK.PolicyTypeAutomatic GTK.PolicyTypeNever
|
||||
GTK.scrolledWindowSetOverlayScrolling fileBar True
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Panels
|
||||
|
||||
|
|
@ -469,7 +612,6 @@ main = do
|
|||
GTK.boxPackStart brushesPanel brushesContent True True 0
|
||||
GTK.boxPackStart transformPanel transformContent True True 0
|
||||
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Info bar
|
||||
|
||||
|
|
@ -554,7 +696,10 @@ main = do
|
|||
---------------------------------------------------------
|
||||
-- Actions
|
||||
|
||||
GTK.widgetAddEvents window [GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask]
|
||||
GTK.widgetAddEvents window
|
||||
[ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ]
|
||||
GTK.widgetAddEvents viewportArea
|
||||
[ GDK.EventMaskScrollMask, GDK.EventMaskSmoothScrollMask ]
|
||||
|
||||
_ <- GTK.onButtonClicked closeButton GTK.mainQuit
|
||||
_ <- GTK.onButtonClicked minimiseButton ( GTK.windowIconify window )
|
||||
|
|
@ -568,8 +713,8 @@ main = do
|
|||
then GTK.windowUnmaximize window
|
||||
else GTK.windowMaximize window
|
||||
|
||||
_ <- GTK.onWidgetKeyPressEvent window handleKeyboardPressEvent
|
||||
_ <- GTK.onWidgetKeyReleaseEvent window handleKeyboardReleaseEvent
|
||||
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent pressedKeysTVar )
|
||||
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent pressedKeysTVar )
|
||||
_ <- GTK.onWidgetDestroy window GTK.mainQuit
|
||||
|
||||
---------------------------------------------------------
|
||||
|
|
@ -580,6 +725,8 @@ main = do
|
|||
|
||||
exitSuccess
|
||||
|
||||
---------------------------------------------------------
|
||||
-- Utils.
|
||||
|
||||
data Exists c where
|
||||
Exists :: c a => a -> Exists c
|
||||
|
|
@ -2,7 +2,6 @@ packages: .
|
|||
|
||||
constraints:
|
||||
acts -finitary
|
||||
, haskell-gi >= 0.24
|
||||
|
||||
-- fixes gi-cairo-render to work with haskell-gi >= 0.24
|
||||
source-repository-package
|
||||
|
|
|
|||
|
|
@ -1,14 +1,38 @@
|
|||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
module MetaBrush.Document where
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Vector2D
|
||||
( Point2D )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{-
|
||||
data AABB
|
||||
= AABB
|
||||
{ topLeft :: !( Point2D Double )
|
||||
, botRight :: !( Point2D Double )
|
||||
}
|
||||
deriving stock Show
|
||||
|
||||
data Document
|
||||
= Document
|
||||
{ displayName :: !Text
|
||||
, filePath :: !(Maybe FilePath)
|
||||
, filePath :: !( Maybe FilePath )
|
||||
, unsavedChanges :: !Bool
|
||||
, viewport :: !AABB
|
||||
, strokes :: !(Set Stroke)
|
||||
, strokes :: ![ Stroke ]
|
||||
, bounds :: !AABB
|
||||
, viewportCenter :: !( Point2D Double )
|
||||
, zoomFactor :: !Double
|
||||
}
|
||||
-}
|
||||
deriving stock Show
|
||||
|
||||
data Stroke
|
||||
= Stroke
|
||||
{ strokePoints :: ![ Point2D Double ] }
|
||||
deriving stock Show
|
||||
|
|
|
|||
|
|
@ -1,8 +1,11 @@
|
|||
module MetaBrush.Event
|
||||
( handleKeyboardPressEvent
|
||||
, handleKeyboardReleaseEvent
|
||||
)
|
||||
where
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module MetaBrush.Event where
|
||||
|
||||
-- base
|
||||
import Data.Word
|
||||
( Word32 )
|
||||
|
||||
-- gi-gdk
|
||||
import qualified GI.Gdk as GDK
|
||||
|
|
@ -10,14 +13,67 @@ 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, readTVar, writeTVar )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
handleKeyboardPressEvent, handleKeyboardReleaseEvent :: GDK.EventKey -> IO Bool
|
||||
handleKeyboardPressEvent evt = do
|
||||
handleKeyboardPressEvent, handleKeyboardReleaseEvent :: STM.TVar [ Word32 ] -> GDK.EventKey -> IO Bool
|
||||
handleKeyboardPressEvent pressedKeysTVar evt = do
|
||||
keyCode <- GDK.getEventKeyKeyval evt
|
||||
case keyCode of
|
||||
-- escape
|
||||
0xff1b -> GTK.mainQuit
|
||||
_ -> pure ()
|
||||
Escape -> GTK.mainQuit
|
||||
_ -> STM.atomically do
|
||||
pressedKeys <- STM.readTVar pressedKeysTVar
|
||||
STM.writeTVar pressedKeysTVar ( keyCode : pressedKeys )
|
||||
pure True
|
||||
handleKeyboardReleaseEvent _ = pure True
|
||||
handleKeyboardReleaseEvent pressedKeysTVar evt = do
|
||||
keyCode <- GDK.getEventKeyKeyval evt
|
||||
STM.atomically do
|
||||
pressedKeys <- STM.readTVar pressedKeysTVar
|
||||
STM.writeTVar pressedKeysTVar ( filter ( /= keyCode ) pressedKeys )
|
||||
pure True
|
||||
|
||||
pattern Escape :: Word32
|
||||
pattern Escape = 0xff1b
|
||||
pattern Delete :: Word32
|
||||
pattern Delete = 0xffff
|
||||
pattern BackSpace :: Word32
|
||||
pattern BackSpace = 0xff08
|
||||
pattern Tab :: Word32
|
||||
pattern Tab = 0xff09
|
||||
pattern Return :: Word32
|
||||
pattern Return = 0xff0d
|
||||
pattern Pause :: Word32
|
||||
pattern Pause = 0xff13
|
||||
pattern Left :: Word32
|
||||
pattern Left = 0xff51
|
||||
pattern Up :: Word32
|
||||
pattern Up = 0xff52
|
||||
pattern Right :: Word32
|
||||
pattern Right = 0xff53
|
||||
pattern Down :: Word32
|
||||
pattern Down = 0xff54
|
||||
pattern PageUp :: Word32
|
||||
pattern PageUp = 0xff55
|
||||
pattern Next :: Word32
|
||||
pattern Next = 0xff56
|
||||
pattern PageDown :: Word32
|
||||
pattern PageDown = 0xff56
|
||||
pattern End :: Word32
|
||||
pattern End = 0xff57
|
||||
pattern Shift_L :: Word32
|
||||
pattern Shift_L = 0xffe1
|
||||
pattern Shift_R :: Word32
|
||||
pattern Shift_R = 0xffe2
|
||||
pattern Control_L :: Word32
|
||||
pattern Control_L = 0xffe3
|
||||
pattern Control_R :: Word32
|
||||
pattern Control_R = 0xffe4
|
||||
pattern Alt_L :: Word32
|
||||
pattern Alt_L = 0xffe9
|
||||
pattern Alt_R :: Word32
|
||||
pattern Alt_R = 0xffea
|
||||
|
|
|
|||
125
src/app/MetaBrush/Render/Document.hs
Normal file
125
src/app/MetaBrush/Render/Document.hs
Normal file
|
|
@ -0,0 +1,125 @@
|
|||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE NegativeLiterals #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module MetaBrush.Render.Document
|
||||
( renderDocument )
|
||||
where
|
||||
|
||||
-- base
|
||||
import Control.Monad
|
||||
( when )
|
||||
import Data.Int
|
||||
( Int32 )
|
||||
|
||||
-- gi-cairo-render
|
||||
import qualified GI.Cairo.Render as Cairo
|
||||
|
||||
-- MetaBrush
|
||||
import qualified Math.Bezier.Quadratic as Quadratic
|
||||
( Bezier(..) )
|
||||
import Math.Vector2D
|
||||
( Point2D(..) )
|
||||
import MetaBrush.Asset.Colours
|
||||
( Colours, ColourRecord(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..), Stroke(..) )
|
||||
import MetaBrush.Render.Util
|
||||
( withRGBA )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
renderDocument :: Colours -> ( Int32, Int32 ) -> Document -> Cairo.Render ()
|
||||
renderDocument cols ( viewportWidth, viewportHeight ) ( Document { viewportCenter = Point2D cx cy, .. } ) = do
|
||||
|
||||
Cairo.save
|
||||
Cairo.translate ( 0.5 * fromIntegral viewportWidth ) ( 0.5 * fromIntegral viewportHeight )
|
||||
Cairo.scale zoomFactor zoomFactor
|
||||
Cairo.translate ( -cx ) ( -cy )
|
||||
|
||||
let
|
||||
( renderPoints, renderPath ) = renderStrokes cols zoomFactor strokes
|
||||
renderPath
|
||||
renderPoints
|
||||
|
||||
Cairo.restore
|
||||
|
||||
pure ()
|
||||
|
||||
renderStrokes :: Colours -> Double -> [ Stroke ] -> ( Cairo.Render (), Cairo.Render () )
|
||||
renderStrokes _ _ [] = ( pure (), pure () )
|
||||
renderStrokes cols zoom ( s : ss ) = ( points1 *> points2, path1 *> path2 )
|
||||
where
|
||||
( points1, path1 ) = renderStroke cols zoom s
|
||||
( points2, path2 ) = renderStrokes cols zoom ss
|
||||
|
||||
renderStroke :: Colours -> Double -> Stroke -> ( Cairo.Render (), Cairo.Render () )
|
||||
renderStroke cols zoom ( Stroke strokePts ) = go True strokePts
|
||||
where
|
||||
go :: Bool -> [ Point2D Double ] -> ( Cairo.Render (), Cairo.Render () )
|
||||
go drawFirstPoint pts = case pts of
|
||||
[] -> ( pure (), pure () )
|
||||
[p0] -> ( when drawFirstPoint ( drawPoint cols zoom p0 ), pure () )
|
||||
[_,_] -> error "'renderStroke': unexpected pair of points"
|
||||
( p0 : p1 : p2 : ps ) ->
|
||||
let
|
||||
drawPoints, drawNextPoints, drawPath, drawNextPath :: Cairo.Render ()
|
||||
( drawNextPoints, drawNextPath ) = go False ( p2 : ps )
|
||||
drawPoints = do
|
||||
when drawFirstPoint ( drawPoint cols zoom p0 )
|
||||
drawControl cols zoom p1
|
||||
drawPoint cols zoom p2
|
||||
drawNextPoints
|
||||
drawPath = do
|
||||
drawQuadraticBezier cols zoom ( Quadratic.Bezier p0 p1 p2 )
|
||||
drawNextPath
|
||||
in ( drawPoints, drawPath )
|
||||
|
||||
|
||||
drawPoint, drawControl :: Colours -> Double -> Point2D Double -> Cairo.Render ()
|
||||
drawPoint ( Colours { pathPoint, pathPointOutline } ) zoom ( Point2D x y ) = do
|
||||
|
||||
let
|
||||
hsqrt3 :: Double
|
||||
hsqrt3 = sqrt 0.75
|
||||
|
||||
Cairo.save
|
||||
Cairo.translate x y
|
||||
Cairo.scale ( 4 / zoom ) ( 4 / zoom )
|
||||
|
||||
Cairo.moveTo 1 0
|
||||
Cairo.lineTo 0.5 hsqrt3
|
||||
Cairo.lineTo -0.5 hsqrt3
|
||||
Cairo.lineTo -1 0
|
||||
Cairo.lineTo -0.5 (-hsqrt3)
|
||||
Cairo.lineTo 0.5 (-hsqrt3)
|
||||
Cairo.closePath
|
||||
|
||||
Cairo.setLineWidth 1
|
||||
withRGBA pathPointOutline Cairo.setSourceRGBA
|
||||
Cairo.strokePreserve
|
||||
|
||||
withRGBA pathPoint Cairo.setSourceRGBA
|
||||
Cairo.fill
|
||||
|
||||
Cairo.restore
|
||||
|
||||
drawControl ( Colours { controlPoint, controlPointOutline } ) zoom ( Point2D x y ) = do
|
||||
|
||||
Cairo.save
|
||||
Cairo.translate x y
|
||||
Cairo.scale ( 4 / zoom ) ( 4 / zoom )
|
||||
|
||||
Cairo.arc 0 0 1 0 ( 2 * pi )
|
||||
|
||||
Cairo.setLineWidth 1
|
||||
withRGBA controlPointOutline Cairo.setSourceRGBA
|
||||
Cairo.strokePreserve
|
||||
|
||||
withRGBA controlPoint Cairo.setSourceRGBA
|
||||
Cairo.fill
|
||||
|
||||
Cairo.restore
|
||||
|
||||
drawQuadraticBezier :: Colours -> Double -> Quadratic.Bezier ( Point2D Double ) -> Cairo.Render ()
|
||||
drawQuadraticBezier _ _ _ = pure ()
|
||||
|
|
@ -14,6 +14,7 @@
|
|||
module Math.Bezier.Cubic
|
||||
( Bezier(..)
|
||||
, bezier, bezier'
|
||||
, subdivide
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -49,10 +50,6 @@ data Bezier p
|
|||
}
|
||||
deriving stock ( Show, Generic, Functor, Foldable, Traversable )
|
||||
|
||||
instance Module r p => Module r ( Bezier p ) where
|
||||
( Bezier p0 p1 p2 p3 ) ^+^ ( Bezier q0 q1 q2 q3 ) = Bezier ( p0 ^+^ q0 ) ( p1 ^+^ q1 ) ( p2 ^+^ q2 ) ( p3 ^+^ q3 )
|
||||
r *^ bz = fmap ( r *^ ) bz
|
||||
|
||||
-- | Cubic Bézier curve.
|
||||
bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p
|
||||
bezier ( Bezier { .. } ) t =
|
||||
|
|
@ -67,3 +64,15 @@ bezier' ( Bezier { .. } ) t
|
|||
$ lerp @v t
|
||||
( lerp @v t ( p0 --> p1 ) ( p1 --> p2 ) )
|
||||
( lerp @v t ( p1 --> p2 ) ( p2 --> p3 ) )
|
||||
|
||||
-- | Subdivide a cubic Bézier curve into two parts.
|
||||
subdivide :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> ( Bezier p, Bezier p )
|
||||
subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 q2 pt, Bezier pt r1 r2 p3 )
|
||||
where
|
||||
pt, s, q1, q2, r1, r2 :: p
|
||||
q1 = lerp @v t p0 p1
|
||||
s = lerp @v t p1 p2
|
||||
r2 = lerp @v t p2 p3
|
||||
q2 = lerp @v t q1 s
|
||||
r1 = lerp @v t s r2
|
||||
pt = lerp @v t q2 r1
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@
|
|||
module Math.Bezier.Quadratic
|
||||
( Bezier(..)
|
||||
, bezier, bezier'
|
||||
, subdivide
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -46,10 +47,6 @@ data Bezier p
|
|||
}
|
||||
deriving stock ( Show, Generic, Functor, Foldable, Traversable )
|
||||
|
||||
instance Module r p => Module r ( Bezier p ) where
|
||||
( Bezier p0 p1 p2 ) ^+^ ( Bezier q0 q1 q2 ) = Bezier ( p0 ^+^ q0 ) ( p1 ^+^ q1 ) ( p2 ^+^ q2 )
|
||||
r *^ bz = fmap ( r *^ ) bz
|
||||
|
||||
-- | Quadratic Bézier curve.
|
||||
bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p
|
||||
bezier ( Bezier { .. } ) t = lerp @v t ( lerp @v t p0 p1 ) ( lerp @v t p1 p2 )
|
||||
|
|
@ -57,3 +54,12 @@ bezier ( Bezier { .. } ) t = lerp @v t ( lerp @v t p0 p1 ) ( lerp @v t p1 p2 )
|
|||
-- | Derivative of quadratic Bézier curve.
|
||||
bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v
|
||||
bezier' ( Bezier { .. } ) t = 2 *^ lerp @v t ( p0 --> p1 ) ( p1 --> p2 )
|
||||
|
||||
-- | Subdivide a quadratic Bézier curve into two parts.
|
||||
subdivide :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> ( Bezier p, Bezier p )
|
||||
subdivide ( Bezier { .. } ) t = ( Bezier p0 q1 pt, Bezier pt r1 p2 )
|
||||
where
|
||||
pt, q1, r1 :: p
|
||||
q1 = lerp @v t p0 p1
|
||||
r1 = lerp @v t p1 p2
|
||||
pt = lerp @v t q1 r1
|
||||
|
|
|
|||
Loading…
Reference in a new issue