metabrush/app/Main.hs

{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE NegativeLiterals    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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.Brushes
  ( ellipse, rect )
import MetaBrush.Asset.Colours
  ( getColours )
import MetaBrush.Asset.Logo
  ( drawLogo )
import MetaBrush.Document
  ( Document(..), AABB(..), Stroke(..)
  , FocusState(..)
  , PointData(..), BrushPointData(..)
  , 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    = "Closed"
      , filePath       = Nothing
      , unsavedChanges = False
      , strokes        = [ Stroke ( ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) ) ) "Ellipse" True ( unsafeUnique 0 )
                         ]
      , bounds         = AABB ( Point2D 0 0 ) ( Point2D 100 100 )
      , viewportCenter = Point2D 50 50
      , zoomFactor     = 1
      }
    , Document
      { displayName    = "Line"
      , filePath       = Nothing
      , unsavedChanges = True
      , strokes        = [ Stroke linePts "Line" True ( unsafeUnique 1 ) ]
      , bounds         = AABB ( Point2D  0  0 ) ( Point2D 50 50 )
      , viewportCenter = Point2D 0 0
      , zoomFactor     = 1
      }
    , Document
      { displayName    = "Short line"
      , filePath       = Nothing
      , unsavedChanges = False
      , strokes        = [ Stroke linePts2 "ShortLine" True ( unsafeUnique 2 ) ]
      , bounds         = AABB ( Point2D  0  0 ) ( Point2D 50 50 )
      , viewportCenter = Point2D 0 0
      , zoomFactor     = 1
      }
    ]
  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 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 )

  ---------------------------------------------------------
  -- 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
      mode          <- STM.readTVarIO modeTVar
      viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
      viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
      ( `Cairo.renderWithContext` ctx ) $
        renderDocument
          colours mode ( viewportWidth, viewportHeight )
          mbMousePos mbHoldEvent mbPartialPath
          doc
    pure True

  ---------------------------------------------------------
  -- Tool bar

  _ <- createToolBar toolTVar modeTVar colours viewportDrawingArea toolBar

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