mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
365 lines
11 KiB
Haskell
365 lines
11 KiB
Haskell
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE NegativeLiterals #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
module Main
|
|
( main )
|
|
where
|
|
|
|
-- base
|
|
import Control.Monad
|
|
( void )
|
|
import Data.Int
|
|
( Int32 )
|
|
import System.Exit
|
|
( exitSuccess )
|
|
|
|
-- containers
|
|
import Data.Map.Strict
|
|
( Map )
|
|
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 )
|
|
|
|
-- 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 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.Stroke
|
|
( StrokePoint(..) )
|
|
import Math.Vector2D
|
|
( Point2D(..) )
|
|
import MetaBrush.Asset.Brushes
|
|
( ellipse, rect )
|
|
import MetaBrush.Asset.Colours
|
|
( getColours )
|
|
import MetaBrush.Asset.Logo
|
|
( drawLogo )
|
|
import MetaBrush.Context
|
|
( UIElements(..), Variables(..)
|
|
, Modifier(..)
|
|
, HoldAction(..), PartialPath(..)
|
|
, withCurrentDocument
|
|
)
|
|
import MetaBrush.Document
|
|
( Document(..), Stroke(..)
|
|
, FocusState(..)
|
|
, PointData(..), BrushPointData(..)
|
|
)
|
|
import MetaBrush.Event
|
|
( handleEvents )
|
|
import MetaBrush.Render.Document
|
|
( renderDocument, blankRender )
|
|
import MetaBrush.UI.FileBar
|
|
( FileBar(..), createFileBar )
|
|
import MetaBrush.UI.InfoBar
|
|
( 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
|
|
, Unique, unsafeUnique
|
|
, uniqueMapFromList
|
|
)
|
|
import MetaBrush.Util
|
|
( widgetAddClass, widgetAddClasses )
|
|
import qualified Paths_MetaBrush as Cabal
|
|
( getDataFileName )
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
testDocuments :: Map Unique Document
|
|
testDocuments = uniqueMapFromList
|
|
[ Document
|
|
{ displayName = "Closed"
|
|
, mbFilePath = Nothing
|
|
, unsavedChanges = False
|
|
, viewportCenter = Point2D 50 50
|
|
, zoomFactor = 1
|
|
, documentUnique = unsafeUnique 0
|
|
, strokes = [ Stroke
|
|
{ strokeName = "Ellipse"
|
|
, strokeVisible = True
|
|
, strokeUnique = unsafeUnique 10
|
|
, strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) )
|
|
}
|
|
]
|
|
}
|
|
, Document
|
|
{ displayName = "Line"
|
|
, mbFilePath = Nothing
|
|
, unsavedChanges = True
|
|
, viewportCenter = Point2D 0 0
|
|
, zoomFactor = 1
|
|
, documentUnique = unsafeUnique 1
|
|
, strokes = [ Stroke
|
|
{ strokeName = "Line"
|
|
, strokeVisible = True
|
|
, strokeUnique = unsafeUnique 11
|
|
, strokePoints = linePts
|
|
}
|
|
]
|
|
}
|
|
, Document
|
|
{ displayName = "Short line"
|
|
, mbFilePath = Nothing
|
|
, unsavedChanges = False
|
|
, viewportCenter = Point2D 0 0
|
|
, zoomFactor = 1
|
|
, documentUnique = unsafeUnique 2
|
|
, 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
|
|
|
|
---------------------------------------------------------
|
|
-- Initialise state
|
|
|
|
uniqueSupply <- newUniqueSupply
|
|
activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing
|
|
openDocumentsTVar <- STM.newTVarIO @( Map Unique Document ) 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
|
|
|
|
-- 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 { viewportDrawingArea } <- 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 $ withCurrentDocument variables \ doc@( Document { .. } ) -> do
|
|
mbMousePos <- STM.readTVar mousePosTVar
|
|
mbHoldAction <- STM.readTVar mouseHoldTVar
|
|
mbPartialPath <- STM.readTVar partialPathTVar
|
|
mode <- STM.readTVar modeTVar
|
|
pure $
|
|
renderDocument
|
|
colours mode ( viewportWidth, viewportHeight )
|
|
mbMousePos mbHoldAction mbPartialPath
|
|
doc
|
|
case mbRender of
|
|
Just render -> Cairo.renderWithContext render ctx
|
|
Nothing -> Cairo.renderWithContext ( blankRender colours ) ctx
|
|
|
|
pure True
|
|
|
|
---------------------------------------------------------
|
|
-- Tool bar
|
|
|
|
_ <- createToolBar toolTVar modeTVar colours viewportDrawingArea toolBar
|
|
|
|
---------------------------------------------------------
|
|
-- Info bar
|
|
|
|
infoBar@( InfoBar { infoBarArea } ) <- createInfoBar colours
|
|
|
|
---------------------------------------------------------
|
|
-- File bar
|
|
|
|
fileBar@( FileBar { fileBarBox } ) <-
|
|
createFileBar
|
|
variables
|
|
window titleBar title viewportDrawingArea infoBar
|
|
|
|
GTK.boxPackStart mainView fileBarBox False False 0
|
|
GTK.boxPackStart mainView viewportGrid True True 0
|
|
GTK.boxPackStart mainView infoBarArea False False 0
|
|
|
|
let
|
|
uiElements :: UIElements
|
|
uiElements = UIElements { .. }
|
|
|
|
------------
|
|
-- Menu bar
|
|
|
|
_ <- createMenuBar uiElements variables colours
|
|
|
|
---------------------------------------------------------
|
|
-- Panels
|
|
|
|
createPanelBar panelBox
|
|
|
|
---------------------------------------------------------
|
|
-- Actions
|
|
|
|
handleEvents uiElements variables
|
|
|
|
---------------------------------------------------------
|
|
-- GTK main loop
|
|
|
|
GTK.widgetShowAll window
|
|
GTK.main
|
|
|
|
exitSuccess
|