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(..)
  )
import MetaBrush.Event
  ( handleEvents )
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
  ( 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 [ Point2D 0 0 ]
                         , Stroke [ Point2D 100 0, Point2D 105 0, Point2D 110 0 ]
                         , Stroke [ Point2D 0 100 ]
                         , Stroke [ Point2D 100 100, Point2D 105 105, Point2D 110 100 ]
                         ]
      , bounds         = AABB ( Point2D  0  0 ) ( Point2D 100 100 )
      , viewportCenter = Point2D 50 50
      , zoomFactor     = 1
      }
    , Document
      { displayName    = "Document 2"
      , filePath       = Nothing
      , unsavedChanges = True
      , strokes        = [ Stroke [ Point2D 0 0, Point2D 10 10, Point2D 20 20 ] ]
      , 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
  pressedKeysTVar    <- STM.newTVarIO @[ Word32 ]          []

  ---------------------------------------------------------
  -- 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 colours toolBar

  ---------------------------------------------------------
  -- Main viewport

  Viewport { viewportDrawingArea } <-
    createViewport
      colours
      activeDocumentTVar
      openDocumentsTVar
      viewportGrid

  ---------------------------------------------------------
  -- Info bar

  infoBarElements <- createInfoBar colours infoBar

  ---------------------------------------------------------
  -- File bar

  _ <-
    createFileBar
      activeDocumentTVar
      openDocumentsTVar
      window
      title
      viewportDrawingArea
      infoBarElements
      fileBar

  ---------------------------------------------------------
  -- Panels

  createPanelBar panelBox

  ---------------------------------------------------------
  -- Actions

  handleEvents
    activeDocumentTVar openDocumentsTVar pressedKeysTVar
    window viewportDrawingArea infoBarElements

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

  GTK.widgetShowAll window
  GTK.main

  exitSuccess