metabrush/app/Main.hs

{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE NegativeLiterals    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE RecursiveDo         #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

module Main
  ( main )
  where

-- base
import Control.Monad
  ( void )
import Data.Foldable
  ( for_ )
import Data.Function
  ( (&) )
import Data.Int
  ( Int32 )
import System.Exit
  ( exitSuccess )
import GHC.Conc
  ( getNumProcessors, setNumCapabilities )

-- containers
import Data.Map.Strict
  ( Map )
import qualified Data.Map.Strict as Map
  ( empty )
import Data.Sequence
  ( Seq(..) )
import qualified Data.Sequence as Seq
  ( fromList )
import Data.Set
  ( Set )
import qualified Data.Set as Set
  ( empty )

-- directory
import qualified System.Directory as Directory
  ( canonicalizePath )

-- generic-lens
import Data.Generics.Product.Fields
  ( field' )

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

-- lens
import Control.Lens
  ( (.~) )

-- stm
import qualified Control.Concurrent.STM as STM
  ( atomically )
import qualified Control.Concurrent.STM.TVar as STM
  ( newTVarIO, readTVar )

-- text
import qualified Data.Text as Text
  ( pack )

-- MetaBrush
import Math.Bezier.Cubic.Fit
  ( FitParameters(..) )
import Math.Bezier.Stroke
  ( StrokePoint(..) )
import Math.Vector2D
  ( Point2D(..) )
import MetaBrush.Action
  ( ActionOrigin(..) )
import MetaBrush.Asset.Brushes
  ( ellipse, rect )
import MetaBrush.Asset.Colours
  ( getColours )
import MetaBrush.Asset.Logo
  ( drawLogo )
import MetaBrush.Context
  ( UIElements(..), Variables(..)
  , Modifier(..)
  , HoldAction(..), PartialPath(..)
  )
import MetaBrush.Document
  ( Document(..), emptyDocument
  , Stroke(..), FocusState(..)
  , PointData(..), BrushPointData(..)
  )
import MetaBrush.Document.History
  ( DocumentHistory(..), newHistory )
import MetaBrush.Document.Update
  ( activeDocument, withActiveDocument )
import MetaBrush.Event
  ( handleEvents )
import MetaBrush.Render.Document
  ( renderDocument, blankRender )
import MetaBrush.Render.Rulers
  ( renderRuler )
import MetaBrush.UI.FileBar
  ( FileBar(..), createFileBar )
import MetaBrush.UI.InfoBar
  ( InfoBar(..), createInfoBar, updateInfoBar )
import MetaBrush.UI.Menu
  ( createMenuBar )
import MetaBrush.UI.Panels
  ( createPanelBar )
import MetaBrush.UI.ToolBar
  ( Tool(..), Mode(..), createToolBar )
import MetaBrush.UI.Viewport
  ( Viewport(..), Ruler(..), createViewport )
import MetaBrush.Unique
  ( newUniqueSupply
  , Unique, unsafeUnique
  , uniqueMapFromList
  )
import MetaBrush.Util
  ( widgetAddClass, widgetAddClasses )
import qualified Paths_MetaBrush as Cabal
  ( getDataFileName )

--------------------------------------------------------------------------------

testDocuments :: Map Unique DocumentHistory
testDocuments = fmap newHistory $ uniqueMapFromList
  [ emptyDocument "Closed" ( unsafeUnique 0 )
  & ( field' @"documentContent" . field' @"strokes" ) .~
    [ Stroke
      { strokeName    = "Ellipse"
      , strokeVisible = True
      , strokeUnique  = unsafeUnique 10
      , strokePoints  = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) )
      }
    ]
  , emptyDocument "Line" ( unsafeUnique 1 )
  & ( field' @"documentContent" . field' @"strokes" ) .~
    [ Stroke
      { strokeName    = "Line"
      , strokeVisible = True
      , strokeUnique  = unsafeUnique 11
      , strokePoints  = linePts
      }
    ]
  , emptyDocument "Short line" ( unsafeUnique 2 )
  & ( field' @"documentContent" . field' @"strokes" ) .~
    [ Stroke
      { strokeName    = "ShortLine"
      , strokeVisible = True
      , strokeUnique  = unsafeUnique 12
      , strokePoints  = linePts2
      }
    ]
  ]
  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

  procs <- getNumProcessors
  let
    caps :: Int
    caps
      | procs >= 6
      = procs - 2
      | procs >= 2
      = procs - 1
      | otherwise
      = procs
  setNumCapabilities caps

  ---------------------------------------------------------
  -- Initialise state

  uniqueSupply       <- newUniqueSupply
  activeDocumentTVar <- STM.newTVarIO @( Maybe Unique )                            Nothing
  openDocumentsTVar  <- STM.newTVarIO @( Map Unique DocumentHistory )              testDocuments
  mousePosTVar       <- STM.newTVarIO @( Maybe ( Point2D Double ) )                Nothing
  mouseHoldTVar      <- STM.newTVarIO @( Maybe HoldAction )                        Nothing
  modifiersTVar      <- STM.newTVarIO @( Set Modifier )                            Set.empty
  toolTVar           <- STM.newTVarIO @Tool                                        Selection
  modeTVar           <- STM.newTVarIO @Mode                                        Path
  debugTVar          <- STM.newTVarIO @Bool                                        False
  partialPathTVar    <- STM.newTVarIO @( Maybe PartialPath )                       Nothing
  fileBarTabsTVar    <- STM.newTVarIO @( Map Unique ( GTK.Box, GTK.RadioButton ) ) Map.empty
  showGuidesTVar     <- STM.newTVarIO @Bool                                        True
  maxHistorySizeTVar <- STM.newTVarIO @Int                                         1000
  fitParametersTVar  <- STM.newTVarIO @FitParameters
    ( FitParameters
      { maxSubdiv  = 6
      , nbSegments = 12
      , dist_tol   = 5e-3
      , t_tol      = 1e-4
      , maxIters   = 100
      }
    )

  -- Put all these stateful variables in a record for conciseness.
  let
    variables :: Variables
    variables = Variables {..}

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

  viewportGrid <- GTK.gridNew

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

  ------------
  -- Title

  title <- GTK.labelNew ( Just "MetaBrush" )
  widgetAddClasses title [ "text", "title", "plain" ]
  GTK.boxSetCenterWidget titleBar ( Just title )

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

  viewport@( Viewport { .. } ) <- createViewport viewportGrid

  -----------------
  -- Viewport rendering

  void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do
    -- Get the relevant document information
    viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
    viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
    mbRender <- STM.atomically $ withActiveDocument variables \ doc@( Document {..} ) -> do
      modifiers      <- STM.readTVar modifiersTVar
      mbMousePos     <- STM.readTVar mousePosTVar
      mbHoldAction   <- STM.readTVar mouseHoldTVar
      mbPartialPath  <- STM.readTVar partialPathTVar
      mode           <- STM.readTVar modeTVar
      debug          <- STM.readTVar debugTVar
      showGuides     <- STM.readTVar showGuidesTVar
      fitParameters  <- STM.readTVar fitParametersTVar
      pure do
        renderDocument
          colours fitParameters mode debug ( viewportWidth, viewportHeight )
          modifiers mbMousePos mbHoldAction mbPartialPath
          doc
        renderRuler
          colours ( viewportWidth, viewportHeight ) ViewportOrigin ( viewportWidth, viewportHeight )
          mbMousePos mbHoldAction showGuides
          doc
    case mbRender of
      Just render -> Cairo.renderWithContext render                  ctx
      Nothing     -> Cairo.renderWithContext ( blankRender colours ) ctx

    pure True

  for_ [ ( rulerCornerDrawingArea, RulerCorner )
       , ( topRulerDrawingArea, TopRuler )
       , ( leftRulerDrawingArea, LeftRuler
       ) ] \ ( rulerDrawingArea, ruler ) -> do
    void $ GTK.onWidgetDraw rulerDrawingArea \ ctx -> do
      viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
      viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
      width  <- GTK.widgetGetAllocatedWidth  rulerDrawingArea
      height <- GTK.widgetGetAllocatedHeight rulerDrawingArea
      mbRender <- STM.atomically $ withActiveDocument variables \ doc@( Document {..} ) -> do
        mbMousePos     <- STM.readTVar mousePosTVar
        mbHoldAction   <- STM.readTVar mouseHoldTVar
        showGuides     <- STM.readTVar showGuidesTVar
        pure do
          renderRuler
            colours ( viewportWidth, viewportHeight ) ( RulerOrigin ruler ) ( width, height )
            mbMousePos mbHoldAction showGuides
            doc
      for_ mbRender \ render -> Cairo.renderWithContext render ctx

      pure True

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

  _ <- createToolBar variables colours viewportDrawingArea toolBar

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

  infoBar@( InfoBar { infoBarArea } ) <- createInfoBar colours

  rec

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

      fileBar@( FileBar { fileBarBox } ) <-
        createFileBar
          colours
          variables
          window titleBar title viewport infoBar menu

    ------------
    -- Menu bar

      let
        uiElements :: UIElements
        uiElements = UIElements { menu, fileBar, .. }

      menu <- createMenuBar uiElements variables colours

  GTK.boxPackStart mainView fileBarBox   False False 0
  GTK.boxPackStart mainView viewportGrid True  True  0
  GTK.boxPackStart mainView infoBarArea  False False 0

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

  createPanelBar panelBox

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

  handleEvents uiElements variables

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

  GTK.widgetShowAll window
  mbDoc <- fmap present <$> ( STM.atomically $ activeDocument variables )
  updateInfoBar viewportDrawingArea infoBar variables mbDoc -- need to update the info bar after widgets have been realized
  GTK.main

  exitSuccess