{-# LANGUAGE BlockArguments #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Main ( main ) where -- base import Control.Monad ( void ) import Data.Foldable ( for_ ) import Data.Int ( Int32 ) import System.Exit ( exitSuccess ) -- containers import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map ( empty ) import Data.Sequence ( Seq(..) ) 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 ) -- 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 -- stm import qualified Control.Concurrent.STM as STM ( atomically ) import qualified Control.Concurrent.STM.TVar as STM ( newTVarIO, readTVar ) -- text import qualified Data.Text as Text ( pack ) -- MetaBrush import Math.Bezier.Stroke ( StrokePoint(..) ) import Math.Vector2D ( Point2D(..) ) import MetaBrush.Action ( ActionOrigin(..) ) import MetaBrush.Asset.Brushes ( ellipse, rect ) import MetaBrush.Asset.Colours ( getColours ) import MetaBrush.Asset.Logo ( drawLogo ) import MetaBrush.Context ( UIElements(..), Variables(..) , Modifier(..) , HoldAction(..), PartialPath(..) , withCurrentDocument ) import MetaBrush.Document ( Document(..), emptyDocument , Stroke(..), FocusState(..) , PointData(..), BrushPointData(..) ) import MetaBrush.Event ( handleEvents ) import MetaBrush.Render.Document ( renderDocument, renderGuides, blankRender ) import MetaBrush.UI.FileBar ( FileBar(..), createFileBar ) import MetaBrush.UI.InfoBar ( InfoBar(..), createInfoBar, updateInfoBar ) import MetaBrush.UI.Menu ( createMenuBar --, MenuItem(..), Menu(..), FileMenu(..), EditMenu(..), ViewMenu(..) ) import MetaBrush.UI.Panels ( createPanelBar ) import MetaBrush.UI.ToolBar ( Tool(..), Mode(..), createToolBar ) import MetaBrush.UI.Viewport ( Viewport(..), Ruler(..), createViewport ) import MetaBrush.Unique ( newUniqueSupply , Unique, unsafeUnique , uniqueMapFromList ) import MetaBrush.Util ( widgetAddClass, widgetAddClasses ) import qualified Paths_MetaBrush as Cabal ( getDataFileName ) -------------------------------------------------------------------------------- testDocuments :: Map Unique Document testDocuments = uniqueMapFromList [ ( emptyDocument "Closed" ( unsafeUnique 0 ) ) { strokes = [ Stroke { strokeName = "Ellipse" , strokeVisible = True , strokeUnique = unsafeUnique 10 , strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) ) } ] } , ( emptyDocument "Line" ( unsafeUnique 1 ) ) { strokes = [ Stroke { strokeName = "Line" , strokeVisible = True , strokeUnique = unsafeUnique 11 , strokePoints = linePts } ] } , ( emptyDocument "Short line" ( unsafeUnique 2 ) ) { strokes = [ Stroke { strokeName = "ShortLine" , strokeVisible = True , strokeUnique = unsafeUnique 12 , strokePoints = linePts2 } ] } ] where linePts :: Seq ( StrokePoint PointData ) linePts = Seq.fromList [ PathPoint ( Point2D 0 -100 ) ( PointData Normal ( ellipse 30 8 $ BrushPointData Normal ) ) , ControlPoint ( Point2D 0 -30 ) ( PointData Normal ( ellipse 25 6 $ BrushPointData Normal ) ) , ControlPoint ( Point2D 0 30 ) ( PointData Normal ( ellipse 15 6 $ BrushPointData Normal ) ) , PathPoint ( Point2D 0 100 ) ( PointData Normal ( ellipse 15 6 $ BrushPointData Normal ) ) , ControlPoint ( Point2D 0 150 ) ( PointData Normal ( ellipse 15 6 $ BrushPointData Normal ) ) , ControlPoint ( Point2D 0 200 ) ( PointData Normal ( ellipse 15 6 $ BrushPointData Normal ) ) , PathPoint ( Point2D 0 250 ) ( PointData Normal ( ellipse 10 1 $ BrushPointData Normal ) ) ] linePts2 :: Seq ( StrokePoint PointData ) linePts2 = Seq.fromList [ PathPoint ( Point2D 0 -100 ) ( PointData Normal ( ellipse 20 8 $ BrushPointData Normal ) ) --, ControlPoint ( Point2D 0 0 ) ( PointData Normal ( ellipse 140 8 $ BrushPointData Normal ) ) , PathPoint ( Point2D 0 100 ) ( PointData Normal ( ellipse 20 8 $ BrushPointData Normal ) ) ] -------------------------------------------------------------------------------- main :: IO () main = do --------------------------------------------------------- -- Initialise state uniqueSupply <- newUniqueSupply activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing openDocumentsTVar <- STM.newTVarIO @( Map Unique Document ) testDocuments 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 Path partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing fileBarTabsTVar <- STM.newTVarIO @( Map Unique GTK.Box ) Map.empty -- 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 800 600 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 void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do -- Get the relevant document information viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea mbRender <- STM.atomically $ withCurrentDocument variables \ doc@( Document {..} ) -> do mbMousePos <- STM.readTVar mousePosTVar mbHoldAction <- STM.readTVar mouseHoldTVar mbPartialPath <- STM.readTVar partialPathTVar mode <- STM.readTVar modeTVar pure do renderDocument colours mode ( viewportWidth, viewportHeight ) mbMousePos mbHoldAction mbPartialPath doc renderGuides colours ( viewportWidth, viewportHeight ) ViewportOrigin ( viewportWidth, viewportHeight ) mbMousePos mbHoldAction doc case mbRender of Just render -> Cairo.renderWithContext render ctx Nothing -> Cairo.renderWithContext ( blankRender colours ) 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 $ withCurrentDocument variables \ doc@( Document {..} ) -> do mbMousePos <- STM.readTVar mousePosTVar mbHoldAction <- STM.readTVar mouseHoldTVar pure do renderGuides colours ( viewportWidth, viewportHeight ) ( RulerOrigin ruler ) ( width, height ) mbMousePos mbHoldAction doc for_ mbRender \ render -> Cairo.renderWithContext render ctx pure True --------------------------------------------------------- -- Tool bar _ <- createToolBar toolTVar modeTVar colours viewportDrawingArea toolBar --------------------------------------------------------- -- Info bar infoBar@( InfoBar { infoBarArea } ) <- createInfoBar colours --------------------------------------------------------- -- File bar fileBar@( FileBar { fileBarBox } ) <- createFileBar colours variables window titleBar title viewport infoBar GTK.boxPackStart mainView fileBarBox False False 0 GTK.boxPackStart mainView viewportGrid True True 0 GTK.boxPackStart mainView infoBarArea False False 0 let uiElements :: UIElements uiElements = UIElements {..} ------------ -- Menu bar _menu <- createMenuBar uiElements variables colours --GTK.widgetSetSensitive ( menuItem $ close $ menuItemSubmenu $ file menu ) False --------------------------------------------------------- -- Panels createPanelBar panelBox --------------------------------------------------------- -- Actions handleEvents uiElements variables --------------------------------------------------------- -- GTK main loop GTK.widgetShowAll window updateInfoBar viewportDrawingArea infoBar variables -- need to update the info bar after widgets have been realized GTK.main exitSuccess