{-# 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