{-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# 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 ) -- 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.Vector2D ( Point2D(..) ) import MetaBrush.Asset.Colours ( getColours ) import MetaBrush.Asset.Logo ( drawLogo ) import MetaBrush.Document ( Document(..), AABB(..) , Stroke(..), StrokePoint(..), PointType(..), FocusState(..) , currentDocument ) import MetaBrush.Event ( HoldEvent, 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 qualified Paths_MetaBrush as Cabal ( getDataFileName ) -------------------------------------------------------------------------------- testDocuments :: IntMap Document testDocuments = IntMap.fromList $ zip [0..] [ Document { displayName = "Document 1" , filePath = Nothing , unsavedChanges = False , strokes = [ Stroke [ StrokePoint ( Point2D 0 0 ) PathPoint Normal ] "Stroke1" False , Stroke [ StrokePoint ( Point2D 100 0 ) PathPoint Normal , StrokePoint ( Point2D 105 0 ) ControlPoint Normal , StrokePoint ( Point2D 110 0 ) PathPoint Normal ] "Stroke2" True , Stroke [ StrokePoint ( Point2D 0 100 ) PathPoint Normal ] "Stroke3" True , Stroke [ StrokePoint ( Point2D 100 100 ) PathPoint Normal , StrokePoint ( Point2D 105 105 ) ControlPoint Normal , StrokePoint ( Point2D 110 100 ) PathPoint Normal ] "Stroke4" True ] , bounds = AABB ( Point2D 0 0 ) ( Point2D 100 100 ) , viewportCenter = Point2D 50 50 , zoomFactor = 1 } , Document { displayName = "Document 2" , filePath = Nothing , unsavedChanges = True , strokes = [ Stroke [ StrokePoint ( Point2D 0 0 ) PathPoint Normal , StrokePoint ( Point2D 10 10 ) ControlPoint Normal , StrokePoint ( Point2D 20 20 ) PathPoint Normal ] "Stroke1" True ] , 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 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 --------------------------------------------------------- -- 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 mousePos <- STM.readTVarIO mousePosTVar holdEvent <- STM.readTVarIO mouseHoldTVar let mbHoldEvent :: Maybe ( HoldEvent, Point2D Double ) mbHoldEvent = (,) <$> holdEvent <*> mousePos viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea ( `Cairo.renderWithContext` ctx ) $ renderDocument colours ( viewportWidth, viewportHeight ) mbHoldEvent doc pure True --------------------------------------------------------- -- Info bar infoBarElements <- createInfoBar colours infoBar --------------------------------------------------------- -- File bar _ <- createFileBar activeDocumentTVar openDocumentsTVar window title viewportDrawingArea infoBarElements fileBar --------------------------------------------------------- -- Panels createPanelBar panelBox --------------------------------------------------------- -- Actions handleEvents activeDocumentTVar openDocumentsTVar mousePosTVar mouseHoldTVar pressedKeysTVar toolTVar modeTVar window viewportDrawingArea infoBarElements --------------------------------------------------------- -- GTK main loop GTK.widgetShowAll window GTK.main exitSuccess