metabrush/app/Main.hs

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

module Main
  ( main )
  where

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

-- containers
import Data.Map.Strict
  ( Map )
import qualified Data.Map.Strict as Map
  ( adjust, empty )
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-render
import qualified GI.Cairo.Render as Cairo
  ( Render )

-- 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
  ( (.~), set )
import Control.Lens.At
  ( at )

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

-- superrecord
import qualified SuperRecord as Super
  ( Rec )
import qualified SuperRecord
  ( (:=)(..), (&), rnil )

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

-- transformers
import Control.Monad.Trans.Reader
  ( runReaderT )

-- unordered-containers
import Data.HashMap.Strict
  ( HashMap )
import qualified Data.HashMap.Strict as HashMap
  ( fromList )

-- MetaBrush
import Math.Bezier.Cubic.Fit
  ( FitParameters(..) )
import Math.Bezier.Spline
  ( Spline(..), Curves(..), Curve(..), NextPoint(..) )
import Math.Bezier.Stroke
  ( CachedStroke(..) )
import Math.Vector2D
  ( Point2D(..) )
import MetaBrush.Action
  ( ActionOrigin(..) )
import qualified MetaBrush.Asset.Brushes as Asset.Brushes
  ( circle )
import MetaBrush.Asset.Colours
  ( getColours )
import MetaBrush.Asset.Logo
  ( drawLogo )
import MetaBrush.Brush
  ( Brush, newBrushReference )
import MetaBrush.Context
  ( UIElements(..), Variables(..)
  , Modifier(..)
  , HoldAction(..), PartialPath(..)
  )
import MetaBrush.Document
  ( Document(..), emptyDocument
  , Stroke(..), FocusState(..)
  , PointData(..)
  )
import MetaBrush.Document.History
  ( DocumentHistory(..), newHistory )
import MetaBrush.Document.Update
  ( activeDocument, withActiveDocument )
import MetaBrush.Event
  ( handleEvents )
import MetaBrush.Render.Document
  ( blankRender, getDocumentRender )
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, freshUnique
  , uniqueMapFromList
  )
import MetaBrush.Util
  ( widgetAddClass, widgetAddClasses )
import qualified Paths_MetaBrush as Cabal
  ( getDataFileName )

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

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

  circleBrush <- Asset.Brushes.circle uniqueSupply
  circleBrushUnique <- runReaderT freshUnique uniqueSupply
  docUnique         <- runReaderT freshUnique uniqueSupply
  strokeUnique      <- runReaderT freshUnique uniqueSupply

  let

    testBrushes :: HashMap Brush Unique
    testBrushes = HashMap.fromList
      [ ( circleBrush, circleBrushUnique ) ]

    testDocuments :: Map Unique DocumentHistory
    testDocuments = fmap newHistory $ uniqueMapFromList
      [ emptyDocument "Test" docUnique
      & ( field' @"documentContent" . field' @"strokes" ) .~
        [ Stroke
          { strokeName     = "Stroke 1"
          , strokeVisible  = True
          , strokeUnique   = strokeUnique
          , strokeBrushRef = newBrushReference @'[ "r" SuperRecord.:= Double ] circleBrushUnique
          , strokeSpline   =
            Spline
              { splineStart  = mkPoint ( Point2D 10 -20 ) 2
              , splineCurves = OpenCurves $ Seq.fromList
                [ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D  10  10 ) 5 ), curveData = CachedStroke Nothing }
                , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10  10 ) 5 ), curveData = CachedStroke Nothing }
                , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 2 ), curveData = CachedStroke Nothing }
                ]
              }
          }
        ]
      & ( field' @"documentBrushes" . at circleBrushUnique ) .~ ( Just circleBrush )
      ]
        where
          mkPoint :: Point2D Double -> Double -> PointData ( Super.Rec '[ "r" SuperRecord.:= Double ] )
          mkPoint pt r = PointData pt Normal ( #r SuperRecord.:= r SuperRecord.& SuperRecord.rnil )

  recomputeStrokesTVar <- STM.newTVarIO @Bool                                        False
  documentRenderTVar   <- STM.newTVarIO @( Cairo.Render () )                         ( pure () )
  activeDocumentTVar   <- STM.newTVarIO @( Maybe Unique )                            Nothing
  openDocumentsTVar    <- STM.newTVarIO @( Map Unique DocumentHistory )              testDocuments
  brushesTVar          <- STM.newTVarIO @( HashMap Brush Unique )                    testBrushes
  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                                        PathMode
  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

  -- Update the document render data in a separate thread.
  _ <- forkIO $ forever do
      viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
      viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
      ( !mbUpdatedDoc, renderDoc ) <- STM.atomically do
        needsRecomputation <- STM.readTVar recomputeStrokesTVar
        case needsRecomputation of
          False -> STM.retry
          True  -> do
              mbDocNow <- fmap present <$> activeDocument variables
              case mbDocNow of
                Nothing -> pure ( Nothing, blankRender colours )
                Just doc -> do
                  modifiers      <- STM.readTVar modifiersTVar
                  mbMousePos     <- STM.readTVar mousePosTVar
                  mbHoldAction   <- STM.readTVar mouseHoldTVar
                  mbPartialPath  <- STM.readTVar partialPathTVar
                  mode           <- STM.readTVar modeTVar
                  showGuides     <- STM.readTVar showGuidesTVar
                  debug          <- STM.readTVar debugTVar
                  fitParameters  <- STM.readTVar fitParametersTVar
                  STM.writeTVar recomputeStrokesTVar False
                  let
                    addRulers :: ( Maybe Document, Cairo.Render () ) -> Cairo.Render ()
                    addRulers ( Nothing    , newRender ) = newRender
                    addRulers ( Just newDoc, newRender ) = do
                      newRender
                      renderRuler
                        colours ( viewportWidth, viewportHeight ) ViewportOrigin ( viewportWidth, viewportHeight )
                        mbMousePos mbHoldAction showGuides
                        newDoc
                  pure $
                    ( fst &&& addRulers ) $ getDocumentRender
                      colours fitParameters mode debug ( viewportWidth, viewportHeight )
                      modifiers mbMousePos mbHoldAction mbPartialPath
                      doc
      STM.atomically do
        STM.writeTVar documentRenderTVar renderDoc
        for_ mbUpdatedDoc \ newDoc -> do
          mbCurrDocUnique <- STM.readTVar activeDocumentTVar
          for_ mbCurrDocUnique \ currDocUnique -> do
            STM.modifyTVar' openDocumentsTVar ( Map.adjust ( set ( field' @"present" ) newDoc ) currDocUnique )
      GTK.widgetQueueDraw viewportDrawingArea

  -- Render the document using the latest available draw data.
  void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do
    -- Get the Cairo instructions for rendering the current document
    mbDoc <- fmap present <$> STM.atomically ( activeDocument variables )
    render <- case mbDoc of
      Nothing -> pure ( blankRender colours )
      Just _  -> STM.atomically do
        STM.readTVar documentRenderTVar
    Cairo.renderWithContext render 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 -> 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 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