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.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    = "Document 1"
      , filePath       = Nothing
      , unsavedChanges = False
      , strokes        = [ Stroke ( circle ( PointData Normal ( rect $ BrushPointData Normal ) ) ) "Circle" True ( unsafeUnique 0 )
                         ]
      , bounds         = AABB ( Point2D 0 0 ) ( Point2D 100 100 )
      , viewportCenter = Point2D 50 50
      , zoomFactor     = 1
      }
    , Document
      { displayName    = "Document 2"
      , filePath       = Nothing
      , unsavedChanges = True
      , strokes        = [ ]
      , bounds         = AABB ( Point2D  0  0 ) ( Point2D 50 50 )
      , viewportCenter = Point2D 10 10
      , zoomFactor     = 0.25
      }
    ]

circle :: forall a. a -> Seq ( StrokePoint a )
circle d = Seq.fromList
  [ pp ( Point2D   0    1  )
  , cp ( Point2D   a    1  )
  , cp ( Point2D   1    a  )
  , pp ( Point2D   1    0  )
  , cp ( Point2D   1  (-a) )
  , cp ( Point2D   a  (-1) )
  , pp ( Point2D   0  (-1) )
  , cp ( Point2D (-a) (-1) )
  , cp ( Point2D (-1) (-a) )
  , pp ( Point2D (-1)   0  )
  , cp ( Point2D (-1)   a  )
  , cp ( Point2D (-a)   1  )
  , pp ( Point2D   0    1  )
  ]
  where
    a :: Double
    a = 0.551915024494
    pp, cp :: Point2D Double -> StrokePoint a
    pp p =    PathPoint ( fmap ( * 100 ) p ) d
    cp p = ControlPoint ( fmap ( * 100 ) p ) d

razor :: forall a. a -> Seq ( StrokePoint a )
razor d = Seq.fromList
  [ pp ( Point2D  30  0 )
  , cp ( Point2D  30 -6 )
  , cp ( Point2D -30 -6 )
  , pp ( Point2D -30  0 )
  , cp ( Point2D -30  3 )
  , cp ( Point2D  30  3 )
  , pp ( Point2D  30  0 )
  ]
  where
    pp, cp :: Point2D Double -> StrokePoint a
    pp p =    PathPoint p d
    cp p = ControlPoint p d

rect :: forall a. a -> Seq ( StrokePoint a )
rect d = Seq.fromList
  [ pp ( Point2D  20   5 )
  , pp ( Point2D  20  -5 )
  , pp ( Point2D -20  -5 )
  , pp ( Point2D -20   5 )
  , pp ( Point2D  20   5 )
  ]
  where
    pp :: Point2D Double -> StrokePoint a
    pp p = PathPoint p d

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

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