metabrush/app/Main.hs

{-# 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.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
  ( 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 )
import qualified Control.Concurrent.STM.TVar as STM
  ( modifyTVar', newTVarIO, readTVar )

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

  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

  void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do
    -- Get the relevant document information
    viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
    viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
    mbDocAndRender <- STM.atomically $ withActiveDocument variables \ doc -> 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

      let
        mbUpdatedDoc :: Maybe Document
        renderDoc, renderAction :: Cairo.Render ()
        ( mbUpdatedDoc, renderDoc ) =
          renderDocument
            colours fitParameters mode debug ( viewportWidth, viewportHeight )
            modifiers mbMousePos mbHoldAction mbPartialPath
            doc
        renderAction = do
          renderDoc
          renderRuler
            colours ( viewportWidth, viewportHeight ) ViewportOrigin ( viewportWidth, viewportHeight )
            mbMousePos mbHoldAction showGuides
            doc
      pure
        ( mbUpdatedDoc, renderAction )

    case mbDocAndRender of
      Just ( mbNewDoc, render ) -> do
        Cairo.renderWithContext render ctx
        for_ mbNewDoc \ newDoc -> STM.atomically do
          mbCurrDocUnique <- STM.readTVar activeDocumentTVar
          for_ mbCurrDocUnique \ currDocUnique -> do
            STM.modifyTVar' openDocumentsTVar ( Map.adjust ( set ( field' @"present" ) newDoc ) currDocUnique )
      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 -> 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