mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
482 lines
16 KiB
Haskell
482 lines
16 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE NegativeLiterals #-}
|
|
{-# LANGUAGE OverloadedLabels #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE RecursiveDo #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
module Main
|
|
( main )
|
|
where
|
|
|
|
-- base
|
|
import Control.Arrow
|
|
( (&&&) )
|
|
import Control.Monad
|
|
( forever, void )
|
|
import Data.Foldable
|
|
( for_ )
|
|
import Data.Function
|
|
( (&) )
|
|
import Data.Int
|
|
( Int32 )
|
|
import System.Exit
|
|
( exitSuccess )
|
|
import GHC.Conc
|
|
( forkIO, getNumProcessors, setNumCapabilities )
|
|
|
|
-- containers
|
|
import Data.Map.Strict
|
|
( Map )
|
|
import qualified Data.Map.Strict as Map
|
|
( adjust, empty )
|
|
import qualified Data.Sequence as Seq
|
|
( fromList )
|
|
import Data.Set
|
|
( Set )
|
|
import qualified Data.Set as Set
|
|
( empty )
|
|
|
|
-- directory
|
|
import qualified System.Directory as Directory
|
|
( canonicalizePath )
|
|
|
|
-- generic-lens
|
|
import Data.Generics.Product.Fields
|
|
( field' )
|
|
|
|
-- gi-cairo-render
|
|
import qualified GI.Cairo.Render as Cairo
|
|
( Render )
|
|
|
|
-- gi-cairo-connector
|
|
import qualified GI.Cairo.Render.Connector as Cairo
|
|
( renderWithContext )
|
|
|
|
-- gi-gdk
|
|
import qualified GI.Gdk as GDK
|
|
|
|
-- gi-gtk
|
|
import qualified GI.Gtk as GTK
|
|
|
|
-- lens
|
|
import Control.Lens
|
|
( (.~), set )
|
|
import Control.Lens.At
|
|
( at )
|
|
|
|
-- stm
|
|
import qualified Control.Concurrent.STM as STM
|
|
( atomically, retry )
|
|
import qualified Control.Concurrent.STM.TVar as STM
|
|
( modifyTVar', newTVarIO, readTVar, writeTVar )
|
|
|
|
-- superrecord
|
|
import qualified SuperRecord as Super
|
|
( Rec )
|
|
import qualified SuperRecord
|
|
( (:=)(..), (&), rnil )
|
|
|
|
-- text
|
|
import qualified Data.Text as Text
|
|
( pack )
|
|
|
|
-- transformers
|
|
import Control.Monad.Trans.Reader
|
|
( runReaderT )
|
|
|
|
-- unordered-containers
|
|
import Data.HashMap.Strict
|
|
( HashMap )
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
( fromList )
|
|
|
|
-- MetaBrush
|
|
import Math.Bezier.Cubic.Fit
|
|
( FitParameters(..) )
|
|
import Math.Bezier.Spline
|
|
( Spline(..), Curves(..), Curve(..), NextPoint(..) )
|
|
import Math.Bezier.Stroke
|
|
( CachedStroke(..) )
|
|
import Math.Vector2D
|
|
( Point2D(..) )
|
|
import MetaBrush.Action
|
|
( ActionOrigin(..) )
|
|
import qualified MetaBrush.Asset.Brushes as Asset.Brushes
|
|
( circle )
|
|
import MetaBrush.Asset.Colours
|
|
( getColours )
|
|
import MetaBrush.Asset.Logo
|
|
( drawLogo )
|
|
import MetaBrush.Brush
|
|
( Brush, newBrushReference )
|
|
import MetaBrush.Context
|
|
( UIElements(..), Variables(..)
|
|
, Modifier(..)
|
|
, HoldAction(..), PartialPath(..)
|
|
)
|
|
import MetaBrush.Document
|
|
( Document(..), emptyDocument
|
|
, Stroke(..), FocusState(..)
|
|
, PointData(..)
|
|
)
|
|
import MetaBrush.Document.History
|
|
( DocumentHistory(..), newHistory )
|
|
import MetaBrush.Document.Update
|
|
( activeDocument, withActiveDocument )
|
|
import MetaBrush.Event
|
|
( handleEvents )
|
|
import MetaBrush.Render.Document
|
|
( blankRender, getDocumentRender )
|
|
import MetaBrush.Render.Rulers
|
|
( renderRuler )
|
|
import MetaBrush.UI.FileBar
|
|
( FileBar(..), createFileBar )
|
|
import MetaBrush.UI.InfoBar
|
|
( InfoBar(..), createInfoBar, updateInfoBar )
|
|
import MetaBrush.UI.Menu
|
|
( createMenuBar )
|
|
import MetaBrush.UI.Panels
|
|
( createPanelBar )
|
|
import MetaBrush.UI.ToolBar
|
|
( Tool(..), Mode(..), createToolBar )
|
|
import MetaBrush.UI.Viewport
|
|
( Viewport(..), Ruler(..), createViewport )
|
|
import MetaBrush.Unique
|
|
( newUniqueSupply
|
|
, Unique, freshUnique
|
|
, uniqueMapFromList
|
|
)
|
|
import MetaBrush.Util
|
|
( widgetAddClass, widgetAddClasses )
|
|
import qualified Paths_MetaBrush as Cabal
|
|
( getDataFileName )
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
main :: IO ()
|
|
main = do
|
|
|
|
procs <- getNumProcessors
|
|
let
|
|
caps :: Int
|
|
caps
|
|
| procs >= 6
|
|
= procs - 2
|
|
| procs >= 2
|
|
= procs - 1
|
|
| otherwise
|
|
= procs
|
|
setNumCapabilities caps
|
|
|
|
---------------------------------------------------------
|
|
-- Initialise state
|
|
|
|
uniqueSupply <- newUniqueSupply
|
|
|
|
circleBrush <- Asset.Brushes.circle uniqueSupply
|
|
circleBrushUnique <- runReaderT freshUnique uniqueSupply
|
|
docUnique <- runReaderT freshUnique uniqueSupply
|
|
strokeUnique <- runReaderT freshUnique uniqueSupply
|
|
|
|
let
|
|
|
|
testBrushes :: HashMap Brush Unique
|
|
testBrushes = HashMap.fromList
|
|
[ ( circleBrush, circleBrushUnique ) ]
|
|
|
|
testDocuments :: Map Unique DocumentHistory
|
|
testDocuments = fmap newHistory $ uniqueMapFromList
|
|
[ emptyDocument "Test" docUnique
|
|
& ( field' @"documentContent" . field' @"strokes" ) .~
|
|
[ Stroke
|
|
{ strokeName = "Stroke 1"
|
|
, strokeVisible = True
|
|
, strokeUnique = strokeUnique
|
|
, strokeBrushRef = newBrushReference @'[ "r" SuperRecord.:= Double ] circleBrushUnique
|
|
, strokeSpline =
|
|
Spline
|
|
{ splineStart = mkPoint ( Point2D 10 -20 ) 2
|
|
, splineCurves = OpenCurves $ Seq.fromList
|
|
[ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 5 ), curveData = CachedStroke Nothing }
|
|
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = CachedStroke Nothing }
|
|
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 2 ), curveData = CachedStroke Nothing }
|
|
]
|
|
}
|
|
}
|
|
]
|
|
& ( field' @"documentBrushes" . at circleBrushUnique ) .~ ( Just circleBrush )
|
|
]
|
|
where
|
|
mkPoint :: Point2D Double -> Double -> PointData ( Super.Rec '[ "r" SuperRecord.:= Double ] )
|
|
mkPoint pt r = PointData pt Normal ( #r SuperRecord.:= r SuperRecord.& SuperRecord.rnil )
|
|
|
|
recomputeStrokesTVar <- STM.newTVarIO @Bool False
|
|
documentRenderTVar <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () )
|
|
activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing
|
|
openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments
|
|
brushesTVar <- STM.newTVarIO @( HashMap Brush Unique ) testBrushes
|
|
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
|
|
mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing
|
|
modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty
|
|
toolTVar <- STM.newTVarIO @Tool Selection
|
|
modeTVar <- STM.newTVarIO @Mode PathMode
|
|
debugTVar <- STM.newTVarIO @Bool False
|
|
partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing
|
|
fileBarTabsTVar <- STM.newTVarIO @( Map Unique ( GTK.Box, GTK.RadioButton ) ) Map.empty
|
|
showGuidesTVar <- STM.newTVarIO @Bool True
|
|
maxHistorySizeTVar <- STM.newTVarIO @Int 1000
|
|
fitParametersTVar <- STM.newTVarIO @FitParameters
|
|
( FitParameters
|
|
{ maxSubdiv = 6
|
|
, nbSegments = 12
|
|
, dist_tol = 5e-3
|
|
, t_tol = 1e-4
|
|
, maxIters = 100
|
|
}
|
|
)
|
|
|
|
-- Put all these stateful variables in a record for conciseness.
|
|
let
|
|
variables :: Variables
|
|
variables = Variables {..}
|
|
|
|
---------------------------------------------------------
|
|
-- Initialise GTK
|
|
|
|
void $ GTK.init Nothing
|
|
Just screen <- GDK.screenGetDefault
|
|
|
|
themePath <- Text.pack <$> ( Directory.canonicalizePath =<< Cabal.getDataFileName "theme.css" )
|
|
cssProvider <- GTK.cssProviderNew
|
|
GTK.cssProviderLoadFromPath cssProvider themePath
|
|
GTK.styleContextAddProviderForScreen screen cssProvider 1000
|
|
|
|
window <- GTK.windowNew GTK.WindowTypeToplevel
|
|
windowWidgetPath <- GTK.widgetGetPath window
|
|
widgetAddClass window "window"
|
|
GTK.setWindowResizable window True
|
|
GTK.setWindowDecorated window False
|
|
GTK.setWindowTitle window "MetaBrush"
|
|
GTK.windowSetDefaultSize window 1024 768
|
|
GTK.widgetAddEvents window
|
|
[ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ]
|
|
|
|
let
|
|
baseMinWidth, baseMinHeight :: Int32
|
|
baseMinWidth = 480
|
|
baseMinHeight = 240
|
|
|
|
windowGeometry <- GDK.newZeroGeometry
|
|
GDK.setGeometryMinWidth windowGeometry baseMinWidth
|
|
GDK.setGeometryMinHeight windowGeometry baseMinHeight
|
|
GTK.windowSetGeometryHints window ( Nothing @GTK.Widget )
|
|
( Just windowGeometry )
|
|
[ GDK.WindowHintsMinSize ]
|
|
|
|
iconPath <- Directory.canonicalizePath =<< Cabal.getDataFileName "icon.png"
|
|
GTK.windowSetIconFromFile window iconPath
|
|
|
|
colours <- getColours windowWidgetPath
|
|
|
|
---------------------------------------------------------
|
|
-- Create base UI elements
|
|
|
|
baseOverlay <- GTK.overlayNew
|
|
GTK.setContainerChild window baseOverlay
|
|
|
|
uiGrid <- GTK.gridNew
|
|
GTK.setContainerChild baseOverlay uiGrid
|
|
|
|
logo <- GTK.boxNew GTK.OrientationVertical 0
|
|
titleBar <- GTK.boxNew GTK.OrientationHorizontal 0
|
|
toolBar <- GTK.boxNew GTK.OrientationVertical 0
|
|
mainPane <- GTK.panedNew GTK.OrientationHorizontal
|
|
panelBox <- GTK.boxNew GTK.OrientationVertical 0
|
|
|
|
GTK.gridAttach uiGrid logo 0 0 1 2
|
|
GTK.gridAttach uiGrid titleBar 1 0 2 1
|
|
GTK.gridAttach uiGrid toolBar 0 2 2 1
|
|
GTK.gridAttach uiGrid mainPane 2 2 1 1
|
|
|
|
mainView <- GTK.boxNew GTK.OrientationVertical 0
|
|
|
|
GTK.panedPack1 mainPane mainView True False
|
|
GTK.panedPack2 mainPane panelBox False False
|
|
|
|
viewportGrid <- GTK.gridNew
|
|
|
|
---------------------------------------------------------
|
|
-- Background
|
|
|
|
widgetAddClass uiGrid "bg"
|
|
|
|
---------------------------------------------------------
|
|
-- Title bar
|
|
|
|
widgetAddClass titleBar "titleBar"
|
|
|
|
--------
|
|
-- Logo
|
|
|
|
widgetAddClass logo "logo"
|
|
|
|
logoArea <- GTK.drawingAreaNew
|
|
GTK.boxPackStart logo logoArea True True 0
|
|
|
|
void $ GTK.onWidgetDraw logoArea
|
|
$ Cairo.renderWithContext ( drawLogo colours )
|
|
|
|
------------
|
|
-- Title
|
|
|
|
title <- GTK.labelNew ( Just "MetaBrush" )
|
|
widgetAddClasses title [ "text", "title", "plain" ]
|
|
GTK.boxSetCenterWidget titleBar ( Just title )
|
|
|
|
---------------------------------------------------------
|
|
-- Main viewport
|
|
|
|
viewport@( Viewport {..} ) <- createViewport viewportGrid
|
|
|
|
-----------------
|
|
-- Viewport rendering
|
|
|
|
-- Update the document render data in a separate thread.
|
|
_ <- forkIO $ forever do
|
|
( !mbUpdatedDoc, renderDoc ) <- STM.atomically do
|
|
needsRecomputation <- STM.readTVar recomputeStrokesTVar
|
|
case needsRecomputation of
|
|
False -> STM.retry
|
|
True -> do
|
|
mbDocNow <- fmap present <$> activeDocument variables
|
|
case mbDocNow of
|
|
Nothing -> pure ( Nothing, const $ blankRender colours )
|
|
Just doc -> do
|
|
modifiers <- STM.readTVar modifiersTVar
|
|
mbMousePos <- STM.readTVar mousePosTVar
|
|
mbHoldAction <- STM.readTVar mouseHoldTVar
|
|
mbPartialPath <- STM.readTVar partialPathTVar
|
|
mode <- STM.readTVar modeTVar
|
|
showGuides <- STM.readTVar showGuidesTVar
|
|
debug <- STM.readTVar debugTVar
|
|
fitParameters <- STM.readTVar fitParametersTVar
|
|
STM.writeTVar recomputeStrokesTVar False
|
|
let
|
|
addRulers :: ( Maybe Document, ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () )
|
|
addRulers ( Nothing , newRender ) viewportSize = newRender viewportSize
|
|
addRulers ( Just newDoc, newRender ) viewportSize = do
|
|
newRender viewportSize
|
|
renderRuler
|
|
colours viewportSize ViewportOrigin viewportSize
|
|
mbMousePos mbHoldAction showGuides
|
|
newDoc
|
|
pure $
|
|
( fst &&& addRulers ) $ getDocumentRender
|
|
colours fitParameters mode debug
|
|
modifiers mbMousePos mbHoldAction mbPartialPath
|
|
doc
|
|
STM.atomically do
|
|
STM.writeTVar documentRenderTVar renderDoc
|
|
for_ mbUpdatedDoc \ newDoc -> do
|
|
mbCurrDocUnique <- STM.readTVar activeDocumentTVar
|
|
for_ mbCurrDocUnique \ currDocUnique -> do
|
|
STM.modifyTVar' openDocumentsTVar ( Map.adjust ( set ( field' @"present" ) newDoc ) currDocUnique )
|
|
GTK.widgetQueueDraw viewportDrawingArea
|
|
|
|
-- Render the document using the latest available draw data.
|
|
void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do
|
|
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
|
|
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
|
|
-- Get the Cairo instructions for rendering the current document
|
|
mbDoc <- fmap present <$> STM.atomically ( activeDocument variables )
|
|
render <- case mbDoc of
|
|
Nothing -> pure ( blankRender colours )
|
|
Just _ -> STM.atomically do
|
|
render <- STM.readTVar documentRenderTVar
|
|
pure ( render ( viewportWidth, viewportHeight ) )
|
|
Cairo.renderWithContext render ctx
|
|
pure True
|
|
|
|
for_ [ ( rulerCornerDrawingArea , RulerCorner )
|
|
, ( topRulerDrawingArea , TopRuler )
|
|
, ( leftRulerDrawingArea , LeftRuler )
|
|
] \ ( rulerDrawingArea, ruler ) -> do
|
|
void $ GTK.onWidgetDraw rulerDrawingArea \ ctx -> do
|
|
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
|
|
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
|
|
width <- GTK.widgetGetAllocatedWidth rulerDrawingArea
|
|
height <- GTK.widgetGetAllocatedHeight rulerDrawingArea
|
|
mbRender <- STM.atomically $ withActiveDocument variables \ doc -> do
|
|
mbMousePos <- STM.readTVar mousePosTVar
|
|
mbHoldAction <- STM.readTVar mouseHoldTVar
|
|
showGuides <- STM.readTVar showGuidesTVar
|
|
pure do
|
|
renderRuler
|
|
colours ( viewportWidth, viewportHeight ) ( RulerOrigin ruler ) ( width, height )
|
|
mbMousePos mbHoldAction showGuides
|
|
doc
|
|
for_ mbRender \ render -> Cairo.renderWithContext render ctx
|
|
|
|
pure True
|
|
|
|
---------------------------------------------------------
|
|
-- Tool bar
|
|
|
|
_ <- createToolBar variables colours toolBar
|
|
|
|
---------------------------------------------------------
|
|
-- Info bar
|
|
|
|
infoBar@( InfoBar { infoBarArea } ) <- createInfoBar colours
|
|
|
|
rec
|
|
|
|
---------------------------------------------------------
|
|
-- File bar
|
|
|
|
fileBar@( FileBar { fileBarBox } ) <-
|
|
createFileBar
|
|
colours
|
|
variables
|
|
window titleBar title viewport infoBar menu
|
|
|
|
------------
|
|
-- Menu bar
|
|
|
|
let
|
|
uiElements :: UIElements
|
|
uiElements = UIElements { menu, fileBar, .. }
|
|
|
|
menu <- createMenuBar uiElements variables colours
|
|
|
|
GTK.boxPackStart mainView fileBarBox False False 0
|
|
GTK.boxPackStart mainView viewportGrid True True 0
|
|
GTK.boxPackStart mainView infoBarArea False False 0
|
|
|
|
---------------------------------------------------------
|
|
-- Panels
|
|
|
|
createPanelBar panelBox
|
|
|
|
---------------------------------------------------------
|
|
-- Actions
|
|
|
|
handleEvents uiElements variables
|
|
|
|
---------------------------------------------------------
|
|
-- GTK main loop
|
|
|
|
GTK.widgetShowAll window
|
|
mbDoc <- fmap present <$> ( STM.atomically $ activeDocument variables )
|
|
updateInfoBar viewportDrawingArea infoBar variables mbDoc -- need to update the info bar after widgets have been realized
|
|
GTK.main
|
|
|
|
exitSuccess
|