{-# LANGUAGE BlockArguments #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module Main ( main ) where -- base import Control.Monad ( void ) import Data.Foldable ( for_ ) import Data.Int ( Int32 ) import Data.Word ( Word32 ) import System.Exit ( exitSuccess ) -- containers import Data.IntMap.Strict ( IntMap ) import qualified Data.IntMap.Strict as IntMap ( fromList ) import Data.Sequence ( Seq(..) ) import qualified Data.Sequence as Seq ( fromList ) -- 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.TVar as STM ( newTVarIO, readTVarIO ) -- text import qualified Data.Text as Text ( pack ) -- MetaBrush import Math.Bezier.Stroke ( StrokePoint(..) ) import Math.Vector2D ( Point2D(..) ) import MetaBrush.Asset.Colours ( getColours ) import MetaBrush.Asset.Logo ( drawLogo ) import MetaBrush.Document ( Document(..), AABB(..), Stroke(..) , PointData(..), FocusState(..) , currentDocument ) import MetaBrush.Event ( HoldEvent, PartialPath , handleEvents ) import MetaBrush.Render.Document ( renderDocument ) import MetaBrush.Render.Util ( widgetAddClass, widgetAddClasses ) import MetaBrush.UI.FileBar ( createFileBar ) import MetaBrush.UI.InfoBar ( createInfoBar ) import MetaBrush.UI.Menu ( createMenuBar ) import MetaBrush.UI.Panels ( createPanelBar ) import MetaBrush.UI.ToolBar ( Tool(..), Mode(..), createToolBar ) import MetaBrush.UI.Viewport ( Viewport(..), createViewport ) import MetaBrush.Unique ( newUniqueSupply, unsafeUnique ) import qualified Paths_MetaBrush as Cabal ( getDataFileName ) -------------------------------------------------------------------------------- testDocuments :: IntMap Document testDocuments = IntMap.fromList $ zip [0..] [ Document { displayName = "Document 1" , filePath = Nothing , unsavedChanges = False , strokes = [ Stroke circle "Circle" True ( unsafeUnique 0 ) ] , bounds = AABB ( Point2D 0 0 ) ( Point2D 100 100 ) , viewportCenter = Point2D 50 50 , zoomFactor = 1 } , Document { displayName = "Document 2" , filePath = Nothing , unsavedChanges = True , strokes = [ ] , bounds = AABB ( Point2D 0 0 ) ( Point2D 50 50 ) , viewportCenter = Point2D 10 10 , zoomFactor = 0.25 } ] circle :: Seq ( StrokePoint PointData ) circle = Seq.fromList [ pp ( Point2D 0 1 ) , cp ( Point2D a 1 ) , cp ( Point2D 1 a ) , pp ( Point2D 1 0 ) , cp ( Point2D 1 (-a) ) , cp ( Point2D a (-1) ) , pp ( Point2D 0 (-1) ) , cp ( Point2D (-a) (-1) ) , cp ( Point2D (-1) (-a) ) , pp ( Point2D (-1) 0 ) , cp ( Point2D (-1) a ) , cp ( Point2D (-a) 1 ) , pp ( Point2D 0 1 ) ] where a :: Double a = 0.551915024494 pp, cp :: Point2D Double -> StrokePoint PointData pp p = PathPoint ( fmap ( * 100 ) p ) ( PointData Normal Empty ) cp p = ControlPoint ( fmap ( * 100 ) p ) ( PointData Normal Empty ) -------------------------------------------------------------------------------- main :: IO () main = do --------------------------------------------------------- -- Initialise state uniqueSupply <- newUniqueSupply activeDocumentTVar <- STM.newTVarIO @( Maybe Int ) Nothing openDocumentsTVar <- STM.newTVarIO @( IntMap Document ) testDocuments mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing mouseHoldTVar <- STM.newTVarIO @( Maybe HoldEvent ) Nothing pressedKeysTVar <- STM.newTVarIO @[ Word32 ] [] toolTVar <- STM.newTVarIO @Tool Selection modeTVar <- STM.newTVarIO @Mode Path partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing --------------------------------------------------------- -- 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 fileBar <- GTK.scrolledWindowNew ( Nothing @GTK.Adjustment ) ( Nothing @GTK.Adjustment ) viewportGrid <- GTK.gridNew infoBar <- GTK.boxNew GTK.OrientationHorizontal 0 GTK.boxPackStart mainView fileBar False False 0 GTK.boxPackStart mainView viewportGrid True True 0 GTK.boxPackStart mainView infoBar False False 0 --------------------------------------------------------- -- 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 ) ------------ -- Menu bar _ <- createMenuBar colours window titleBar ------------ -- Title title <- GTK.labelNew ( Just "MetaBrush" ) widgetAddClasses title [ "text", "title", "plain" ] GTK.boxSetCenterWidget titleBar ( Just title ) --------------------------------------------------------- -- Tool bar _ <- createToolBar toolTVar modeTVar colours toolBar --------------------------------------------------------- -- Main viewport Viewport { viewportDrawingArea } <- createViewport viewportGrid ----------------- -- Viewport rendering void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do -- Get the relevant document information mbDoc <- currentDocument activeDocumentTVar openDocumentsTVar for_ mbDoc \ doc -> do mbMousePos <- STM.readTVarIO mousePosTVar mbHoldEvent <- STM.readTVarIO mouseHoldTVar mbPartialPath <- STM.readTVarIO partialPathTVar viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea ( `Cairo.renderWithContext` ctx ) $ renderDocument colours ( viewportWidth, viewportHeight ) mbMousePos mbHoldEvent mbPartialPath doc pure True --------------------------------------------------------- -- Info bar infoBarElements <- createInfoBar colours infoBar --------------------------------------------------------- -- File bar _ <- createFileBar activeDocumentTVar openDocumentsTVar window title viewportDrawingArea infoBarElements fileBar --------------------------------------------------------- -- Panels createPanelBar panelBox --------------------------------------------------------- -- Actions handleEvents uniqueSupply activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar modeTVar partialPathTVar window viewportDrawingArea infoBarElements --------------------------------------------------------- -- GTK main loop GTK.widgetShowAll window GTK.main exitSuccess