metabrush/app/Main.hs

{-# LANGUAGE BlockArguments    #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms   #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TypeApplications  #-}

module Main
  ( main )
  where

-- base
import Control.Monad
  ( void )
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 )

-- 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(..)
  , Overlay
  )
import MetaBrush.Event
  ( handleEvents )
import MetaBrush.Render.Util
  ( widgetAddClass, widgetAddClasses )
import MetaBrush.Time
  ( Time )
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 Hover
                            , StrokePoint ( Point2D 105 0 ) ControlPoint Normal
                            , StrokePoint ( Point2D 110 0 )    PathPoint Selected
                            ]
                            "Stroke2"
                            True
                         , Stroke
                            [ StrokePoint ( Point2D 0 100 ) PathPoint Normal ]
                            "Stroke3"
                            True
                         , Stroke
                            [ StrokePoint ( Point2D 100 100 )    PathPoint Normal
                            , StrokePoint ( Point2D 105 105 ) ControlPoint Selected
                            , 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 ( Point2D Double, Time ) ) Nothing
  pressedKeysTVar    <- STM.newTVarIO @[ Word32 ]                         []
  toolTVar           <- STM.newTVarIO @Tool                               Selection
  modeTVar           <- STM.newTVarIO @Mode                               Path
  overlayTVar        <- STM.newTVarIO @( Maybe Overlay )                  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
      colours
      activeDocumentTVar
      openDocumentsTVar
      overlayTVar
      viewportGrid

  ---------------------------------------------------------
  -- 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
    overlayTVar
    window viewportDrawingArea infoBarElements

  ---------------------------------------------------------
  -- GTK main loop

  GTK.widgetShowAll window
  GTK.main

  exitSuccess