mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
332 lines
9.1 KiB
Haskell
332 lines
9.1 KiB
Haskell
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# 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(..)
|
|
, PointData(..), FocusState(..)
|
|
, 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 "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 :: Seq ( StrokePoint PointData )
|
|
circle = 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 PointData
|
|
pp p = PathPoint ( fmap ( * 100 ) p ) ( PointData Normal Empty )
|
|
cp p = ControlPoint ( fmap ( * 100 ) p ) ( PointData Normal Empty )
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
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 )
|
|
|
|
---------------------------------------------------------
|
|
-- Tool bar
|
|
|
|
_ <- createToolBar toolTVar modeTVar colours toolBar
|
|
|
|
---------------------------------------------------------
|
|
-- 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
|
|
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
|
|
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
|
|
( `Cairo.renderWithContext` ctx ) $
|
|
renderDocument
|
|
colours ( viewportWidth, viewportHeight )
|
|
mbMousePos mbHoldEvent mbPartialPath
|
|
doc
|
|
pure True
|
|
|
|
---------------------------------------------------------
|
|
-- 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
|