mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
431 lines
13 KiB
Haskell
431 lines
13 KiB
Haskell
{-# 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
|
|
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 = 2
|
|
, nbSegments = 13
|
|
, dist_tol = 2e-3
|
|
, t_tol = 5e-4
|
|
, maxIters = 500
|
|
}
|
|
)
|
|
|
|
-- 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 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
|
|
|
|
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
|
|
mbMousePos <- STM.readTVar mousePosTVar
|
|
mbHoldAction <- STM.readTVar mouseHoldTVar
|
|
mbPartialPath <- STM.readTVar partialPathTVar
|
|
mode <- STM.readTVar modeTVar
|
|
showGuides <- STM.readTVar showGuidesTVar
|
|
fitParameters <- STM.readTVar fitParametersTVar
|
|
pure do
|
|
renderDocument
|
|
colours fitParameters mode ( viewportWidth, viewportHeight )
|
|
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 toolTVar modeTVar 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
|