hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 14:53:37 +00:00
Code Issues Actions Projects Releases Wiki Activity

Implement programmable brush framework

Browse source
This commit is contained in:
sheaf 2020-11-12 17:34:46 +00:00
parent a5ba7dcd33
commit 393ef6f06e
36 changed files with 6304 additions and 1869 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

37
MetaBrush.cabal
View file

@ -27,7 +27,7 @@ common common
build-depends: build-depends:
base base
>= 4.13 && < 4.16 >= 4.13 && < 4.17
, acts , acts
^>= 0.3.1.0 ^>= 0.3.1.0
, containers , containers
@ -77,6 +77,7 @@ library
Math.Bezier.Cubic Math.Bezier.Cubic
, Math.Bezier.Cubic.Fit , Math.Bezier.Cubic.Fit
, Math.Bezier.Quadratic , Math.Bezier.Quadratic
, Math.Bezier.Spline
, Math.Bezier.Stroke , Math.Bezier.Stroke
, Math.Epsilon , Math.Epsilon
, Math.Linear.Solve , Math.Linear.Solve
@ -85,12 +86,14 @@ library
, Math.Vector2D , Math.Vector2D
build-depends: build-depends:
groups-generic bifunctors
^>= 5.5.4
, groups-generic
^>= 0.1.0.0 ^>= 0.1.0.0
, hmatrix , hmatrix
^>= 0.20.0.0 ^>= 0.20.0.0
, monad-par , parallel
^>= 0.3.5 ^>= 3.2.2.0
, prim-instances , prim-instances
^>= 0.2 ^>= 0.2
, vector , vector
@ -128,6 +131,14 @@ executable MetaBrush
, MetaBrush.Document.SubdivideStroke , MetaBrush.Document.SubdivideStroke
, MetaBrush.Document.Update , MetaBrush.Document.Update
, MetaBrush.Event , MetaBrush.Event
, MetaBrush.MetaParameter.AST
, MetaBrush.MetaParameter.Driver
, MetaBrush.MetaParameter.Eval
, MetaBrush.MetaParameter.Interpolation
, MetaBrush.MetaParameter.Parse
, MetaBrush.MetaParameter.PrimOp
, MetaBrush.MetaParameter.Rename
, MetaBrush.MetaParameter.TypeCheck
, MetaBrush.Render.Document , MetaBrush.Render.Document
, MetaBrush.Render.Rulers , MetaBrush.Render.Rulers
, MetaBrush.Time , MetaBrush.Time
@ -153,11 +164,17 @@ executable MetaBrush
, atomic-file-ops , atomic-file-ops
^>= 0.3.0.0 ^>= 0.3.0.0
, bytestring , bytestring
^>= 0.10.10.1 ^>= 0.10.10.0
, directory , directory
>= 1.3.4.0 && < 1.4 >= 1.3.4.0 && < 1.4
, dlist
^>= 1.0
, Earley
^>= 0.13.0.1
, filepath , filepath
^>= 1.4.2.1 ^>= 1.4.2.1
, ghc-typelits-knownnat
^>= 0.7.3
, gi-gdk , gi-gdk
>= 3.0.22 && < 3.1 >= 3.0.22 && < 3.1
, gi-gio , gi-gio
@ -173,16 +190,22 @@ executable MetaBrush
, gi-cairo-connector , gi-cairo-connector
^>= 0.0.1 ^>= 0.0.1
, haskell-gi-base , haskell-gi-base
^>= 0.24 ^>= 0.24.3
, lens , lens
^>= 4.19.2 ^>= 4.19.2
, mtl
^>= 2.2.2
, scientific , scientific
^>= 0.3.6.2 ^>= 0.3.6.2
, stm , stm
^>= 2.5.0.0 ^>= 2.5.0.0
, superrecord
^>= 0.5.1.0
, tardis , tardis
^>= 0.4.1.0 ^>= 0.4.1.0
, text , text
^>= 1.2.3.1 && < 1.2.5 >= 1.2.3.1 && < 1.2.5
, tree-view
^>= 0.5
, waargonaut , waargonaut
^>= 0.8.0.1 ^>= 0.8.0.1

158
app/Main.hs
View file

@ -2,11 +2,13 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Main module Main
( main ) ( main )
@ -30,9 +32,7 @@ import GHC.Conc
import Data.Map.Strict import Data.Map.Strict
( Map ) ( Map )
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
( empty ) ( adjust, empty )
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
( fromList ) ( fromList )
import Data.Set import Data.Set
@ -48,6 +48,10 @@ import qualified System.Directory as Directory
import Data.Generics.Product.Fields import Data.Generics.Product.Fields
( field' ) ( field' )
-- gi-cairo-render
import qualified GI.Cairo.Render as Cairo
( Render )
-- gi-cairo-connector -- gi-cairo-connector
import qualified GI.Cairo.Render.Connector as Cairo import qualified GI.Cairo.Render.Connector as Cairo
( renderWithContext ) ( renderWithContext )
@ -60,13 +64,19 @@ import qualified GI.Gtk as GTK
-- lens -- lens
import Control.Lens import Control.Lens
( (.~) ) ( (.~), set )
-- stm -- stm
import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM as STM
( atomically ) ( atomically )
import qualified Control.Concurrent.STM.TVar as STM import qualified Control.Concurrent.STM.TVar as STM
( newTVarIO, readTVar ) ( modifyTVar', newTVarIO, readTVar )
-- superrecord
import qualified SuperRecord as Super
( Rec )
import qualified SuperRecord
( (:=)(..), (&), rnil )
-- text -- text
import qualified Data.Text as Text import qualified Data.Text as Text
@ -75,14 +85,16 @@ import qualified Data.Text as Text
-- MetaBrush -- MetaBrush
import Math.Bezier.Cubic.Fit import Math.Bezier.Cubic.Fit
( FitParameters(..) ) ( FitParameters(..) )
import Math.Bezier.Spline
( Spline(..), Curves(..), Curve(..), NextPoint(..) )
import Math.Bezier.Stroke import Math.Bezier.Stroke
( StrokePoint(..) ) ( CachedStroke(..) )
import Math.Vector2D import Math.Vector2D
( Point2D(..) ) ( Point2D(..) )
import MetaBrush.Action import MetaBrush.Action
( ActionOrigin(..) ) ( ActionOrigin(..) )
import MetaBrush.Asset.Brushes import qualified MetaBrush.Asset.Brushes as Asset.Brushes
( ellipse, rect ) ( circle )
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( getColours ) ( getColours )
import MetaBrush.Asset.Logo import MetaBrush.Asset.Logo
@ -95,7 +107,7 @@ import MetaBrush.Context
import MetaBrush.Document import MetaBrush.Document
( Document(..), emptyDocument ( Document(..), emptyDocument
, Stroke(..), FocusState(..) , Stroke(..), FocusState(..)
, PointData(..), BrushPointData(..) , PointData(..)
) )
import MetaBrush.Document.History import MetaBrush.Document.History
( DocumentHistory(..), newHistory ) ( DocumentHistory(..), newHistory )
@ -131,56 +143,6 @@ import qualified Paths_MetaBrush as Cabal
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
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 :: IO ()
main = do main = do
@ -199,14 +161,43 @@ main = do
--------------------------------------------------------- ---------------------------------------------------------
-- Initialise state -- Initialise state
uniqueSupply <- newUniqueSupply uniqueSupply <- newUniqueSupply
circleBrush <- Asset.Brushes.circle uniqueSupply
let
testDocuments :: Map Unique DocumentHistory
testDocuments = fmap newHistory $ uniqueMapFromList
[ emptyDocument "Test" ( unsafeUnique 0 )
& ( field' @"documentContent" . field' @"strokes" ) .~
[ Stroke
{ strokeName = "Stroke 1"
, strokeVisible = True
, strokeUnique = unsafeUnique 10
, strokeBrush = circleBrush
, 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 }
]
}
}
]
]
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 activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing
openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments
mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing
mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing
modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty
toolTVar <- STM.newTVarIO @Tool Selection toolTVar <- STM.newTVarIO @Tool Selection
modeTVar <- STM.newTVarIO @Mode Path modeTVar <- STM.newTVarIO @Mode PathMode
debugTVar <- STM.newTVarIO @Bool False debugTVar <- STM.newTVarIO @Bool False
partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing
fileBarTabsTVar <- STM.newTVarIO @( Map Unique ( GTK.Box, GTK.RadioButton ) ) Map.empty fileBarTabsTVar <- STM.newTVarIO @( Map Unique ( GTK.Box, GTK.RadioButton ) ) Map.empty
@ -323,7 +314,7 @@ main = do
--------------------------------------------------------- ---------------------------------------------------------
-- Main viewport -- Main viewport
viewport@( Viewport { .. } ) <- createViewport viewportGrid viewport@( Viewport {..} ) <- createViewport viewportGrid
----------------- -----------------
-- Viewport rendering -- Viewport rendering
@ -332,7 +323,7 @@ main = do
-- Get the relevant document information -- Get the relevant document information
viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
mbRender <- STM.atomically $ withActiveDocument variables \ doc@( Document {..} ) -> do mbDocAndRender <- STM.atomically $ withActiveDocument variables \ doc -> do
modifiers <- STM.readTVar modifiersTVar modifiers <- STM.readTVar modifiersTVar
mbMousePos <- STM.readTVar mousePosTVar mbMousePos <- STM.readTVar mousePosTVar
mbHoldAction <- STM.readTVar mouseHoldTVar mbHoldAction <- STM.readTVar mouseHoldTVar
@ -341,18 +332,33 @@ main = do
debug <- STM.readTVar debugTVar debug <- STM.readTVar debugTVar
showGuides <- STM.readTVar showGuidesTVar showGuides <- STM.readTVar showGuidesTVar
fitParameters <- STM.readTVar fitParametersTVar fitParameters <- STM.readTVar fitParametersTVar
pure do
renderDocument let
colours fitParameters mode debug ( viewportWidth, viewportHeight ) mbUpdatedDoc :: Maybe Document
modifiers mbMousePos mbHoldAction mbPartialPath renderDoc, renderAction :: Cairo.Render ()
doc ( mbUpdatedDoc, renderDoc ) =
renderRuler renderDocument
colours ( viewportWidth, viewportHeight ) ViewportOrigin ( viewportWidth, viewportHeight ) colours fitParameters mode debug ( viewportWidth, viewportHeight )
mbMousePos mbHoldAction showGuides modifiers mbMousePos mbHoldAction mbPartialPath
doc doc
case mbRender of renderAction = do
Just render -> Cairo.renderWithContext render ctx renderDoc
Nothing -> Cairo.renderWithContext ( blankRender colours ) ctx 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 pure True
@ -365,7 +371,7 @@ main = do
viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
width <- GTK.widgetGetAllocatedWidth rulerDrawingArea width <- GTK.widgetGetAllocatedWidth rulerDrawingArea
height <- GTK.widgetGetAllocatedHeight rulerDrawingArea height <- GTK.widgetGetAllocatedHeight rulerDrawingArea
mbRender <- STM.atomically $ withActiveDocument variables \ doc@( Document {..} ) -> do mbRender <- STM.atomically $ withActiveDocument variables \ doc -> do
mbMousePos <- STM.readTVar mousePosTVar mbMousePos <- STM.readTVar mousePosTVar
mbHoldAction <- STM.readTVar mouseHoldTVar mbHoldAction <- STM.readTVar mouseHoldTVar
showGuides <- STM.readTVar showGuidesTVar showGuides <- STM.readTVar showGuidesTVar

19
cabal.project
View file

@ -4,7 +4,8 @@ constraints:
acts -finitary acts -finitary
allow-newer: allow-newer:
waargonaut:* waargonaut:*
-- fixes gi-cairo-render to work with haskell-gi >= 0.24 -- fixes gi-cairo-render to work with haskell-gi >= 0.24
source-repository-package source-repository-package
@ -30,8 +31,18 @@ source-repository-package
location: https://github.com/sheaf/waargonaut location: https://github.com/sheaf/waargonaut
tag: dc835fb86d2592fa2e55753fa4eb7c59d6124699 tag: dc835fb86d2592fa2e55753fa4eb7c59d6124699
-- haskell-gi: add fix for GValue -- instances for CPS Writer / CPS RWST
source-repository-package source-repository-package
type: git type: git
location: https://github.com/haskell-gi/haskell-gi location: https://github.com/haskell/mtl
tag: 6fe7fc271095b5b6115b142f72995ebc11840afb tag: a9023c764a08beedbb1b8ca20bc39103f26529c5
-- patch to superrecord with API improvements
source-repository-package
type: git
location: https://github.com/sheaf/superrecord
tag: 4cecac06afaa3fb60e67cdb273e36eed3f04335d
constraints:
-- fix for Haskell GI GValue bug
haskell-gi >= 0.24.5

448
src/app/MetaBrush/Action.hs
View file

@ -1,4 +1,3 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
@ -23,7 +22,7 @@ import Data.Foldable
import Data.Int import Data.Int
( Int32 ) ( Int32 )
import Data.Maybe import Data.Maybe
( catMaybes, listToMaybe ) ( listToMaybe )
import Data.Traversable import Data.Traversable
( for ) ( for )
import Data.Word import Data.Word
@ -40,10 +39,6 @@ import Data.Act
-- containers -- containers
import qualified Data.Map as Map import qualified Data.Map as Map
( insert, lookup ) ( insert, lookup )
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( fromList )
import qualified Data.Set as Set import qualified Data.Set as Set
( delete, insert ) ( delete, insert )
@ -84,8 +79,12 @@ import qualified Data.Text as Text
( intercalate, pack ) ( intercalate, pack )
-- MetaBrush -- MetaBrush
import Math.Bezier.Spline
( Spline(..), SplineType(Open)
, catMaybesSpline
)
import Math.Bezier.Stroke import Math.Bezier.Stroke
( StrokePoint(..) ) ( CachedStroke(..) )
import Math.Module import Math.Module
( Module((*^)) ) ( Module((*^)) )
import Math.Vector2D import Math.Vector2D
@ -96,11 +95,11 @@ import MetaBrush.Context
, HoldAction(..), GuideAction(..), PartialPath(..) , HoldAction(..), GuideAction(..), PartialPath(..)
) )
import MetaBrush.Document import MetaBrush.Document
( Document(..), DocumentContent(..), PointData(..), FocusState(..) ) ( Document(..), DocumentContent(..), PointData(..), FocusState(..)
, Guide(..), selectedGuide, addGuide
)
import MetaBrush.Document.Draw import MetaBrush.Document.Draw
( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary ) ( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
import MetaBrush.Document
( Guide(..), selectedGuide, addGuide )
import MetaBrush.Document.History import MetaBrush.Document.History
( DocumentHistory(..), newHistory ( DocumentHistory(..), newHistory
, back, fwd , back, fwd
@ -132,7 +131,7 @@ import {-# SOURCE #-} MetaBrush.UI.FileBar
import MetaBrush.UI.Menu import MetaBrush.UI.Menu
( MenuItem(..), Menu(..), ViewMenu(..) ) ( MenuItem(..), Menu(..), ViewMenu(..) )
import MetaBrush.UI.ToolBar import MetaBrush.UI.ToolBar
( Tool(..) ) ( Tool(..), Mode(..) )
import MetaBrush.UI.Viewport import MetaBrush.UI.Viewport
( Viewport(..), Ruler(..) ) ( Viewport(..), Ruler(..) )
import MetaBrush.Unique import MetaBrush.Unique
@ -243,7 +242,6 @@ instance HandleAction OpenFolder where
newDocHist = newHistory doc newDocHist = newHistory doc
newFileTab False uiElts vars ( Just newDocHist ) tabLoc newFileTab False uiElts vars ( Just newDocHist ) tabLoc
updateHistoryState uiElts ( Just newDocHist ) updateHistoryState uiElts ( Just newDocHist )
pure ()
--------------- ---------------
-- Save file -- -- Save file --
@ -253,12 +251,12 @@ data Save = Save
deriving stock Show deriving stock Show
instance HandleAction Save where instance HandleAction Save where
handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ = handleAction uiElts vars _ =
save uiElts vars True save uiElts vars True
save :: UIElements -> Variables -> Bool -> IO () save :: UIElements -> Variables -> Bool -> IO ()
save uiElts vars keepOpen = do save uiElts vars keepOpen = do
mbDoc <- fmap present <$> ( STM.atomically $ activeDocument vars ) mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
for_ mbDoc \case for_ mbDoc \case
doc@( Document { mbFilePath, documentContent } ) doc@( Document { mbFilePath, documentContent } )
| Nothing <- mbFilePath | Nothing <- mbFilePath
@ -285,7 +283,7 @@ instance HandleAction SaveAs where
saveAs :: UIElements -> Variables -> Bool -> IO () saveAs :: UIElements -> Variables -> Bool -> IO ()
saveAs uiElts vars keepOpen = do saveAs uiElts vars keepOpen = do
mbSavePath <- askForSavePath uiElts mbSavePath <- askForSavePath uiElts
for_ mbSavePath \ savePath -> do for_ mbSavePath \ savePath ->
modifyingCurrentDocument uiElts vars \ doc -> do modifyingCurrentDocument uiElts vars \ doc -> do
let let
modif :: DocumentUpdate modif :: DocumentUpdate
@ -332,7 +330,7 @@ pattern CancelClose = 3
instance HandleAction Close where instance HandleAction Close where
handleAction handleAction
uiElts@( UIElements { viewport = Viewport {..}, .. } ) uiElts@( UIElements {..} )
vars@( Variables {..} ) vars@( Variables {..} )
close = do close = do
mbDoc <- case close of mbDoc <- case close of
@ -391,7 +389,7 @@ data SwitchTo = SwitchTo Unique
instance HandleAction SwitchTo where instance HandleAction SwitchTo where
handleAction handleAction
uiElts@( UIElements { viewport = Viewport {..}, .. } ) uiElts
vars@( Variables {..} ) vars@( Variables {..} )
( SwitchTo newUnique ) = do ( SwitchTo newUnique ) = do
uiUpdateAction <- STM.atomically do uiUpdateAction <- STM.atomically do
@ -424,17 +422,17 @@ data Undo = Undo
deriving stock Show deriving stock Show
instance HandleAction Undo where instance HandleAction Undo where
handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ = updateHistory back uiElts vars handleAction uiElts vars _ = updateHistory back uiElts vars
data Redo = Redo data Redo = Redo
deriving stock Show deriving stock Show
instance HandleAction Redo where instance HandleAction Redo where
handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ = updateHistory fwd uiElts vars handleAction uiElts vars _ = updateHistory fwd uiElts vars
updateHistory :: ( DocumentHistory -> DocumentHistory ) -> UIElements -> Variables -> IO () updateHistory :: ( DocumentHistory -> DocumentHistory ) -> UIElements -> Variables -> IO ()
updateHistory f uiElts@( UIElements {..} ) vars@( Variables {..} ) = do updateHistory f uiElts vars@( Variables {..} ) = do
uiUpdateAction <- STM.atomically do uiUpdateAction <- STM.atomically do
mbUnique <- STM.readTVar activeDocumentTVar mbUnique <- STM.readTVar activeDocumentTVar
case mbUnique of case mbUnique of
@ -514,13 +512,14 @@ instance HandleAction Delete where
tool <- STM.readTVarIO toolTVar tool <- STM.readTVarIO toolTVar
mode <- STM.readTVarIO modeTVar mode <- STM.readTVarIO modeTVar
case tool of case tool of
-- Delete selected points on pressing 'Delete'. -- Delete selected points on pressing 'Delete' in path mode.
Selection Selection
| PathMode <- mode
-> modifyingCurrentDocument uiElts vars \ doc -> do -> modifyingCurrentDocument uiElts vars \ doc -> do
let let
newDocument :: Document newDocument :: Document
updateInfo :: UpdateInfo updateInfo :: UpdateInfo
( newDocument, updateInfo ) = deleteSelected mode doc ( newDocument, updateInfo ) = deleteSelected doc
case updateInfo of case updateInfo of
UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected } UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
| null strokesAffected | null strokesAffected
@ -677,105 +676,109 @@ instance HandleAction MouseClick where
pos :: Point2D Double pos :: Point2D Double
pos = toViewport mouseClickCoords pos = toViewport mouseClickCoords
STM.writeTVar mousePosTVar ( Just pos ) STM.writeTVar mousePosTVar ( Just pos )
case actionOrigin of mode <- STM.readTVar modeTVar
case mode of
BrushMode -> pure Don'tModifyDoc -- TODO: brush parameter modification UI
_ ->
case actionOrigin of
ViewportOrigin -> case ty of ViewportOrigin -> case ty of
SingleClick -> do SingleClick -> do
modifiers <- STM.readTVar modifiersTVar modifiers <- STM.readTVar modifiersTVar
tool <- STM.readTVar toolTVar tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
case tool of case tool of
-- Selection mode mouse hold: -- Selection mode mouse hold:
-- --
-- - If holding shift or alt, mouse hold initiates a rectangular selection. -- - If holding shift or alt, mouse hold initiates a rectangular selection.
-- - If not holding shift or alt: -- - If not holding shift or alt:
-- - if mouse click selected an object, initiate a drag move, -- - if mouse click selected an object, initiate a drag move,
-- - otherwise, initiate a rectangular selection. -- - otherwise, initiate a rectangular selection.
Selection -> Selection ->
case selectionMode modifiers of case selectionMode modifiers of
-- Drag move: not holding shift or alt, click has selected something. -- Drag move: not holding shift or alt, click has selected something.
New New
| Just ( dragMove, newDoc ) <- dragMoveSelect mode pos doc | Just ( dragMove, newDoc ) <- dragMoveSelect pos doc
-> do -> do
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove ) STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
case dragMove of case dragMove of
ClickedOnSelected -> ClickedOnSelected ->
pure Don'tModifyDoc
ClickedOnUnselected ->
pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
ClickedOnCurve {} ->
pure Don'tModifyDoc
-- Rectangular selection.
_ -> do
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
pure Don'tModifyDoc pure Don'tModifyDoc
ClickedOnUnselected ->
pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
ClickedOnCurve {} ->
pure Don'tModifyDoc
-- Rectangular selection.
_ -> do
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
pure Don'tModifyDoc
-- Pen tool: start or continue a drawing operation. -- Pen tool: start or continue a drawing operation.
Pen -> do Pen -> do
mbPartialPath <- STM.readTVar partialPathTVar mbPartialPath <- STM.readTVar partialPathTVar
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos ) STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
case mbPartialPath of case mbPartialPath of
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke). -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
Nothing -> do Nothing -> do
( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <- ( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <-
getOrCreateDrawAnchor uniqueSupply pos doc getOrCreateDrawAnchor uniqueSupply pos doc
STM.writeTVar partialPathTVar STM.writeTVar partialPathTVar
( Just $ PartialPath ( Just $ PartialPath
{ partialStartPos = anchorPt { partialStartPos = anchorPt
, partialControlPoint = Nothing , partialControlPoint = Nothing
, partialPathAnchor = drawAnchor , partialPathAnchor = drawAnchor
, firstPoint = True , firstPoint = True
} }
) )
case mbExistingAnchorName of case mbExistingAnchorName of
Nothing -> Nothing ->
let let
changeText :: Text changeText :: Text
changeText = "Begin new stroke" changeText = "Begin new stroke"
in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
Just _ -> Just _ ->
pure Don'tModifyDoc
-- Path already started: indicate that we are continuing a path.
Just pp -> do
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
pure Don'tModifyDoc pure Don'tModifyDoc
-- Path already started: indicate that we are continuing a path.
Just pp -> do
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
pure Don'tModifyDoc
DoubleClick -> do
tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
modifs <- STM.readTVar modifiersTVar
case tool of
Selection
| null modifs
-> do
STM.writeTVar mouseHoldTVar Nothing
case subdivide mode pos doc of
Nothing ->
pure Don'tModifyDoc
Just ( newDocument, loc ) -> do
let
changeText :: Text
changeText = "Subdivide " <> loc
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange { .. } )
-- Ignore double click event otherwise. DoubleClick -> do
_ -> pure Don'tModifyDoc tool <- STM.readTVar toolTVar
modifs <- STM.readTVar modifiersTVar
case tool of
Selection
| PathMode <- mode
, null modifs
-> do
STM.writeTVar mouseHoldTVar Nothing
case subdivide pos doc of
Nothing ->
pure Don'tModifyDoc
Just ( newDocument, loc ) -> do
let
changeText :: Text
changeText = "Subdivide " <> loc
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
-- Ignore double click event otherwise.
_ -> pure Don'tModifyDoc
RulerOrigin ruler -> do RulerOrigin ruler -> do
showGuides <- STM.readTVar showGuidesTVar showGuides <- STM.readTVar showGuidesTVar
when showGuides do when showGuides do
let let
mbGuide :: Maybe Guide mbGuide :: Maybe Guide
mbGuide = selectedGuide pos doc mbGuide = selectedGuide pos doc
guideAction :: GuideAction guideAction :: GuideAction
guideAction guideAction
| Just guide <- mbGuide | Just guide <- mbGuide
= MoveGuide ( guideUnique guide ) = MoveGuide ( guideUnique guide )
| otherwise | otherwise
= CreateGuide ruler = CreateGuide ruler
STM.writeTVar mouseHoldTVar ( Just $ GuideAction { holdStartPos = pos, guideAction } ) STM.writeTVar mouseHoldTVar ( Just $ GuideAction { holdStartPos = pos, guideAction } )
pure Don'tModifyDoc pure Don'tModifyDoc
-- Right mouse button: end partial path. -- Right mouse button: end partial path.
3 -> do 3 -> do
@ -869,111 +872,112 @@ instance HandleAction MouseRelease where
_ -> do _ -> do
tool <- STM.readTVar toolTVar tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar mode <- STM.readTVar modeTVar
case tool of case mode of
BrushMode -> pure Don'tModifyDoc -- TODO: brush parameter modification UI
_ ->
case tool of
Selection -> do Selection -> do
let
selMode :: SelectionMode
selMode = selectionMode modifiers
case mbHoldPos of
Just hold
| DragMoveHold { holdStartPos = pos0, dragAction } <- hold
, pos0 /= pos
-> let
alternateMode :: Bool
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
in case dragUpdate mode pos0 pos dragAction alternateMode doc of
Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd )
Nothing -> pure Don'tModifyDoc
| SelectionHold pos0 <- hold
, pos0 /= pos
-> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle mode selMode pos0 pos doc )
_ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt mode selMode pos doc )
Pen -> do
mbPartialPath <- STM.readTVar partialPathTVar
case mbPartialPath of
-- Normal pen mode mouse click should have created an anchor.
-- If no anchor exists, then just ignore the mouse release event.
Nothing -> pure Don'tModifyDoc
-- Mouse click release possibilities:
--
-- - click was on complementary draw stroke draw anchor to close the path,
-- - release at same point as click: finish current segment,
-- - release at different point as click: finish current segment, adding a control point.
Just
( PartialPath
{ partialStartPos = p1
, partialControlPoint = mbCp2
, partialPathAnchor = anchor
, firstPoint
}
) -> do
let let
pathPoint :: Point2D Double selMode :: SelectionMode
mbControlPoint :: Maybe ( Point2D Double ) selMode = selectionMode modifiers
partialControlPoint :: Maybe ( Point2D Double ) case mbHoldPos of
( pathPoint, mbControlPoint, partialControlPoint ) Just hold
| Just ( DrawHold holdPos ) <- mbHoldPos | DragMoveHold { holdStartPos = pos0, dragAction } <- hold
= ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos ) , pos0 /= pos
| otherwise -> let
= ( pos, Nothing, Nothing ) alternateMode :: Bool
( _, otherAnchor, otherAnchorPt, _ ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
if not firstPoint && anchorsAreComplementary anchor otherAnchor in case dragUpdate pos0 pos dragAction alternateMode doc of
-- Close path. Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd )
then do Nothing -> pure Don'tModifyDoc
STM.writeTVar partialPathTVar Nothing | SelectionHold pos0 <- hold
let , pos0 /= pos
newSegment :: Seq ( StrokePoint PointData ) -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle selMode pos0 pos doc )
newSegment _ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc )
= Seq.fromList
$ catMaybes Pen -> do
[ Just ( PathPoint p1 ( PointData Normal Empty ) ) mbPartialPath <- STM.readTVar partialPathTVar
, do case mbPartialPath of
cp <- mbCp2 -- Normal pen mode mouse click should have created an anchor.
guard ( cp /= p1 ) -- If no anchor exists, then just ignore the mouse release event.
pure $ ControlPoint cp ( PointData Normal Empty ) Nothing -> pure Don'tModifyDoc
, do -- Mouse click release possibilities:
cp <- mbControlPoint --
guard ( cp /= otherAnchorPt ) -- - click was on complementary draw stroke draw anchor to close the path,
pure $ ControlPoint cp ( PointData Normal Empty ) -- - release at same point as click: finish current segment,
, Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) ) -- - release at different point as click: finish current segment, adding a control point.
] Just
newDocument :: Document ( PartialPath
newDocument = addToAnchor anchor newSegment doc { partialStartPos = p1
changeText :: Text , partialControlPoint = mbCp2
changeText = "Close stroke" , partialPathAnchor = anchor
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) , firstPoint
else }
if firstPoint ) -> do
-- Continue current partial path.
then do
STM.writeTVar partialPathTVar ( Just $ PartialPath p1 partialControlPoint anchor False )
pure Don'tModifyDoc
-- Finish current partial path.
else do
STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
let let
newSegment :: Seq ( StrokePoint PointData ) pathPoint :: Point2D Double
newSegment mbControlPoint :: Maybe ( Point2D Double )
= Seq.fromList partialControlPoint :: Maybe ( Point2D Double )
$ catMaybes ( pathPoint, mbControlPoint, partialControlPoint )
[ Just ( PathPoint p1 ( PointData Normal Empty ) ) | Just ( DrawHold holdPos ) <- mbHoldPos
, do = ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos )
cp <- mbCp2 | otherwise
guard ( cp /= p1 ) = ( pos, Nothing, Nothing )
pure $ ControlPoint cp ( PointData Normal Empty ) ( _, otherAnchor, otherAnchorPt, _ ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
, do if not firstPoint && anchorsAreComplementary anchor otherAnchor
cp <- mbControlPoint -- Close path.
guard ( cp /= pathPoint ) then do
pure $ ControlPoint cp ( PointData Normal Empty ) STM.writeTVar partialPathTVar Nothing
, Just ( PathPoint pathPoint ( PointData Normal Empty ) ) let
] newSegment :: Spline Open CachedStroke ( PointData () )
newDocument :: Document newSegment = catMaybesSpline ( CachedStroke Nothing )
newDocument = addToAnchor anchor newSegment doc ( PointData p1 Normal () )
changeText :: Text ( do
changeText = "Continue stroke" cp <- mbCp2
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) guard ( cp /= p1 )
pure ( PointData cp Normal () )
)
( do
cp <- mbControlPoint
guard ( cp /= otherAnchorPt )
pure ( PointData cp Normal () )
)
( PointData otherAnchorPt Normal () )
newDocument :: Document
newDocument = addToAnchor anchor newSegment doc
changeText :: Text
changeText = "Close stroke"
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
else
if firstPoint
-- Continue current partial path.
then do
STM.writeTVar partialPathTVar ( Just $ PartialPath p1 partialControlPoint anchor False )
pure Don'tModifyDoc
-- Finish current partial path.
else do
STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
let
newSegment :: Spline Open CachedStroke ( PointData () )
newSegment = catMaybesSpline ( CachedStroke Nothing )
( PointData p1 Normal () )
( do
cp <- mbCp2
guard ( cp /= p1 )
pure ( PointData cp Normal () )
)
( do
cp <- mbControlPoint
guard ( cp /= pathPoint )
pure ( PointData cp Normal () )
)
( PointData pathPoint Normal () )
newDocument :: Document
newDocument = addToAnchor anchor newSegment doc
changeText :: Text
changeText = "Continue stroke"
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
-- Other mouse buttons: ignored (for the moment at least). -- Other mouse buttons: ignored (for the moment at least).
_ -> pure () _ -> pure ()
@ -987,7 +991,7 @@ data Scroll = Scroll ( Point2D Double ) ( Vector2D Double )
instance HandleAction Scroll where instance HandleAction Scroll where
handleAction handleAction
uiElts@( UIElements { viewport = Viewport {..}, .. } ) uiElts@( UIElements { viewport = Viewport {..} } )
vars@( Variables {..} ) vars@( Variables {..} )
( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do ( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do
@ -1051,12 +1055,12 @@ data KeyboardPress = KeyboardPress Word32
instance HandleAction KeyboardPress where instance HandleAction KeyboardPress where
handleAction handleAction
uiElts@( UIElements { viewport = Viewport {..}, .. } ) uiElts@( UIElements { viewport = Viewport {..} } )
vars@( Variables {..} ) vars@( Variables {..} )
( KeyboardPress keyCode ) = do ( KeyboardPress keyCode ) = do
for_ ( modifierKey keyCode ) \ modifier -> for_ ( modifierKey keyCode )
STM.atomically $ STM.modifyTVar' modifiersTVar ( Set.insert modifier ) ( STM.atomically . STM.modifyTVar' modifiersTVar . Set.insert )
case keyCode of case keyCode of
@ -1096,5 +1100,5 @@ data KeyboardRelease = KeyboardRelease Word32
instance HandleAction KeyboardRelease where instance HandleAction KeyboardRelease where
handleAction _ ( Variables { modifiersTVar } ) ( KeyboardRelease keyCode ) = handleAction _ ( Variables { modifiersTVar } ) ( KeyboardRelease keyCode ) =
for_ ( modifierKey keyCode ) \ modifier -> do for_ ( modifierKey keyCode )
STM.atomically $ STM.modifyTVar' modifiersTVar ( Set.delete modifier ) ( STM.atomically . STM.modifyTVar' modifiersTVar . Set.delete )

154
src/app/MetaBrush/Asset/Brushes.hs
View file

@ -1,70 +1,108 @@
{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module MetaBrush.Asset.Brushes module MetaBrush.Asset.Brushes where
( ellipse, blob, rect )
where
-- containers -- base
import Data.Sequence import Data.Kind
( Seq(..) ) ( Type )
import qualified Data.Sequence as Seq import Data.Type.Equality
( fromList ) ( (:~:)(Refl) )
-- superrecord
import qualified SuperRecord
( (:=) )
-- text
import Data.Text
( Text )
import qualified Data.Text as Text
( unpack )
-- MetaBrush -- MetaBrush
import Math.Bezier.Stroke import MetaBrush.Document
( StrokePoint(..) ) ( Brush(..) )
import Math.Vector2D import MetaBrush.MetaParameter.AST
( Point2D(..) ) ( BrushFunction, STypesI(sTypesI), eqTys )
import MetaBrush.MetaParameter.Driver
( SomeBrushFunction(..), interpretBrush )
import MetaBrush.Unique
( UniqueSupply )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
ellipse :: forall d. Double -> Double -> d -> Seq ( StrokePoint d ) circle
ellipse w h d = Seq.fromList :: forall circleBrushFields
[ pp ( Point2D 0 1 ) . ( circleBrushFields ~ '[ "r" SuperRecord.:= Double ] )
, cp ( Point2D a 1 ) => UniqueSupply -> IO ( Brush circleBrushFields )
, cp ( Point2D 1 a ) circle uniqueSupply = mkBrush @circleBrushFields uniqueSupply name code
, 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 where
a :: Double name, code :: Text
a = 0.551915024494 name = "Circle"
pp, cp :: Point2D Double -> StrokePoint d code =
pp ( Point2D x y ) = PathPoint ( Point2D ( w * x ) ( h * y ) ) d "with\n\
cp ( Point2D x y ) = ControlPoint ( Point2D ( w * x ) ( h * y ) ) d \ r = 1\n\
\satisfying\n\
\ r > 0\n\
\define\n\
\ let c = kappa in\n\
\ [ (r,0) -- ( r , r*c) -- ( r*c, r ) -> ( 0, r)\n\
\ -- (-r*c, r ) -- (-r , r*c) -> (-r, 0)\n\
\ -- (-r ,-r*c) -- (-r*c,-r ) -> ( 0,-r)\n\
\ -- ( r*c,-r ) -- ( r ,-r*c) -> . ]"
blob :: forall d. Double -> Double -> d -> Seq ( StrokePoint d ) rounded
blob w h d = Seq.fromList :: forall roundedBrushFields
[ pp ( Point2D 1 0 ) . ( roundedBrushFields ~ '[ ] ) -- TODO
, cp ( Point2D 1 -1 ) => UniqueSupply -> IO ( Brush roundedBrushFields )
, cp ( Point2D -1 -1 ) rounded uniqueSupply = mkBrush @roundedBrushFields uniqueSupply name code
, pp ( Point2D -1 0 )
, cp ( Point2D -1 1 )
, cp ( Point2D 1 1 )
, pp ( Point2D 1 0 )
]
where where
pp, cp :: Point2D Double -> StrokePoint d name, code :: Text
pp ( Point2D x y ) = PathPoint ( Point2D ( w * x ) ( h * y ) ) d name = "Rounded quadrilateral"
cp ( Point2D x y ) = ControlPoint ( Point2D ( w * x ) ( h * y ) ) d code =
"with\n\
\ tr = (1,-2)\n\
\ rt = (2,-1)\n\
\ br = (1,2)\n\
\ rb = (2,1)\n\
\ bl = (-1,2)\n\
\ lb = (-2,1)\n\
\ tl = (-1,-2)\n\
\ lt = (-2,-1)\n\
\define\n\
\ let c = kappa in\n\
\ [ tr -- lerp c tr ( project rt onto [ tl -> tr ] ) -- lerp c rt ( project tr onto [ rb -> rt ] ) -> rt\n\
\ -> rb\n\
\ -- lerp c rb ( project br onto [ rt -> rb ] ) -- lerp c br ( project rb onto [ bl -> br ] ) -> br\n\
\ -> bl\n\
\ -- lerp c bl ( project lb onto [ br -> bl ] ) -- lerp c lb ( project bl onto [ lt -> lb ] ) -> lb\n\
\ -> lt\n\
\ -- lerp c lt ( project tl onto [ lb -> lt ] ) -- lerp c tl ( project lt onto [ tr -> tl ] ) -> tl\n\
\ -> .]"
rect :: forall d. Double -> Double -> d -> Seq ( StrokePoint d ) --------------------------------------------------------------------------------
rect w h d = Seq.fromList
[ pp ( Point2D 1 1 ) mkBrush
, pp ( Point2D 1 -1 ) :: forall ( givenBrushFields :: [ Type ] )
, pp ( Point2D -1 -1 ) . STypesI givenBrushFields
, pp ( Point2D -1 1 ) => UniqueSupply -> Text -> Text
, pp ( Point2D 1 1 ) -> IO ( Brush givenBrushFields )
] mkBrush uniqSupply brushName brushCode = do
where ( mbBrush, _ ) <- interpretBrush uniqSupply brushCode
pp :: Point2D Double -> StrokePoint d case mbBrush of
pp ( Point2D x y ) = PathPoint ( Point2D ( w * x ) ( h * y ) ) d Left err -> error ( "Could not interpret '" <> Text.unpack brushName <> "' brush:\n" <> show err )
Right ( SomeBrushFunction ( brushFunction :: BrushFunction inferredBrushFields ) ) ->
case eqTys @givenBrushFields @inferredBrushFields of
Just Refl -> pure ( BrushData { brushName, brushCode, brushFunction } )
Nothing ->
error
( "Incorrect record type for '" <> Text.unpack brushName <> "' brush:\n\
\Expected: " <> show ( sTypesI @givenBrushFields ) <> "\n\
\ Actual: " <> show ( sTypesI @inferredBrushFields )
)

260
src/app/MetaBrush/Document.hs
View file

@ -1,82 +1,118 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Document module MetaBrush.Document
( AABB(..), mkAABB ( AABB(..), mkAABB
, Document(..), DocumentContent(..) , Document(..), DocumentContent(..)
, emptyDocument , emptyDocument
, Stroke(..) , Stroke(..), StrokeSpline, _strokeSpline, overStrokeSpline
, PointData(..), BrushPointData(..) , PointData(..), BrushPointData(..), DiffPointData(..)
, Brush(..), emptyBrush
, FocusState(..), Hoverable(..), HoverContext(..) , FocusState(..), Hoverable(..), HoverContext(..)
, _selection, _brush
, Guide(..) , Guide(..)
, _selection, _coords, coords
, addGuide, selectedGuide , addGuide, selectedGuide
) )
where where
-- base -- base
import Data.Coerce
( coerce )
import Data.Functor.Identity
( Identity(..) )
import Data.Kind
( Type )
import Data.Semigroup import Data.Semigroup
( Arg(..), Min(..), ArgMin ) ( Arg(..), Min(..), ArgMin )
import GHC.Generics import GHC.Generics
( Generic ) ( Generic, Generic1 )
-- acts -- acts
import Data.Act import Data.Act
( Act ( Act(..), Torsor(..) )
( (•) )
, Torsor
( (-->) )
)
-- containers -- containers
import Data.Map.Strict import Data.Map.Strict
( Map ) ( Map )
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
( insert ) ( empty, insert )
import qualified Data.Map.Strict as Map
( empty )
import Data.Sequence
( Seq )
-- deepseq -- deepseq
import Control.DeepSeq import Control.DeepSeq
( NFData ) ( NFData(..), NFData1, deepseq )
-- generic-lens -- generic-lens
import Data.Generics.Product.Fields import Data.Generics.Product.Fields
( field' ) ( field' )
import Data.Generics.Product.Typed
( HasType(typed) ) -- groups
import Data.Group
( Group(..) )
-- lens -- lens
import Control.Lens import Control.Lens
( Lens' ) ( Lens'
, set, view, over
)
-- stm -- stm
import Control.Concurrent.STM import Control.Concurrent.STM
( STM ) ( STM )
-- superrecord
import qualified SuperRecord as Super
( Rec )
import qualified SuperRecord
( Intersect, rnil )
-- text -- text
import Data.Text import Data.Text
( Text ) ( Text )
import qualified Data.Text as Text
( unpack )
-- transformers
import Control.Monad.Trans.Reader
( ReaderT, runReaderT )
-- MetaBrush -- MetaBrush
import Math.Bezier.Spline
( Spline(..), KnownSplineType, Curves(..) )
import Math.Bezier.Stroke import Math.Bezier.Stroke
( StrokePoint(..) ) ( CachedStroke )
import Math.Module import Math.Module
( Inner((^.^)), squaredNorm, quadrance ) ( Module
( origin, (^+^), (^-^), (*^) )
, Inner((^.^))
, squaredNorm, quadrance
)
import Math.Vector2D import Math.Vector2D
( Point2D(..), Vector2D(..) ) ( Point2D(..), Vector2D(..) )
import {-# SOURCE #-} MetaBrush.Document.Serialise
( Serialisable(..) )
import MetaBrush.MetaParameter.AST
( STypesI, Adapted, AdaptableFunction(..), BrushFunction )
import MetaBrush.MetaParameter.Interpolation
( Interpolatable(..) ) -- + orphan instances
import MetaBrush.UI.Viewport import MetaBrush.UI.Viewport
( Ruler(..) ) ( Ruler(..) )
import MetaBrush.Unique import MetaBrush.Unique
@ -113,7 +149,7 @@ data Document
deriving stock ( Show, Generic ) deriving stock ( Show, Generic )
deriving anyclass NFData deriving anyclass NFData
-- | Main content of document (data which we keept track of throughout history). -- | Main content of document (data which we kept track of throughout history).
data DocumentContent data DocumentContent
= Content = Content
{ unsavedChanges :: !Bool { unsavedChanges :: !Bool
@ -124,20 +160,90 @@ data DocumentContent
deriving stock ( Show, Generic ) deriving stock ( Show, Generic )
deriving anyclass NFData deriving anyclass NFData
data Stroke type StrokeSpline ty brushParams = Spline ty CachedStroke ( PointData brushParams )
= Stroke
{ strokeName :: Text
, strokeVisible :: !Bool
, strokeUnique :: Unique
, strokePoints :: !( Seq ( StrokePoint PointData ) )
}
deriving stock ( Show, Generic )
deriving anyclass NFData
data PointData data Stroke where
Stroke
:: ( KnownSplineType clo
, pointParams ~ Super.Rec pointFields, STypesI pointFields
, brushParams ~ Super.Rec brushFields, STypesI brushFields
, usedParams ~ Super.Rec usedFields , STypesI usedFields
, usedFields ~ ( brushFields `SuperRecord.Intersect` pointFields )
, Show brushParams, NFData brushParams
, Show pointParams, NFData pointParams
, Interpolatable pointParams
, Interpolatable usedParams
, Serialisable pointParams
, Adapted brushFields pointFields usedFields
)
=>
{ strokeName :: Text
, strokeVisible :: !Bool
, strokeUnique :: Unique
, strokeBrush :: Brush brushFields
, strokeSpline :: !( StrokeSpline clo pointParams )
}
-> Stroke
deriving stock instance Show Stroke
instance NFData Stroke where
rnf ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline } )
= deepseq strokeSpline
. deepseq strokeUnique
. deepseq strokeVisible
$ rnf strokeName
_strokeSpline
:: forall f
. Functor f
=> ( forall clo pointParams pointFields
. ( KnownSplineType clo
, Show pointParams, NFData pointParams
, pointParams ~ Super.Rec pointFields, STypesI pointFields
, Interpolatable pointParams
, Serialisable pointParams
)
=> StrokeSpline clo pointParams
-> f ( StrokeSpline clo pointParams )
)
-> Stroke -> f Stroke
_strokeSpline f ( Stroke { strokeSpline = oldStrokeSpline, .. } )
= ( \ newSpline -> Stroke { strokeSpline = newSpline, .. } ) <$> f oldStrokeSpline
overStrokeSpline
:: ( forall clo pointParams pointFields
. ( KnownSplineType clo
, Show pointParams, NFData pointParams
, pointParams ~ Super.Rec pointFields, STypesI pointFields
, Interpolatable pointParams
, Serialisable pointParams
)
=> StrokeSpline clo pointParams
-> StrokeSpline clo pointParams
)
-> Stroke -> Stroke
overStrokeSpline f = coerce ( _strokeSpline @Identity ( coerce . f ) )
data Brush ( brushFields :: [ Type ] )
= BrushData
{ brushName :: !Text
, brushCode :: !Text
, brushFunction :: !( BrushFunction brushFields )
}
instance Show ( Brush brushFields ) where
show ( BrushData { brushName } ) = Text.unpack brushName
-- Brush parameters using open records.
emptyBrush :: Brush '[]
emptyBrush = BrushData "Empty brush" ""
( AdaptableFunction ( const SuperRecord.rnil, const $ Spline ( Point2D 0 0 ) NoCurves ) )
data PointData params
= PointData = PointData
{ pointState :: FocusState { pointCoords :: !( Point2D Double )
, brushShape :: Seq ( StrokePoint BrushPointData ) , pointState :: FocusState
, brushParams :: !params
} }
deriving stock ( Show, Generic ) deriving stock ( Show, Generic )
deriving anyclass NFData deriving anyclass NFData
@ -164,12 +270,6 @@ instance Semigroup FocusState where
instance Monoid FocusState where instance Monoid FocusState where
mempty = Normal mempty = Normal
_selection :: HasType FocusState pt => Lens' ( StrokePoint pt ) FocusState
_selection = field' @"pointData" . typed @FocusState
_brush :: Lens' ( StrokePoint PointData ) ( Seq ( StrokePoint BrushPointData ) )
_brush = field' @"pointData" . field' @"brushShape"
emptyDocument :: Text -> Unique -> Document emptyDocument :: Text -> Unique -> Document
emptyDocument docName unique = emptyDocument docName unique =
Document Document
@ -218,6 +318,74 @@ instance Hoverable ( Point2D Double ) where
| otherwise | otherwise
= Normal = Normal
class HasSelection pt where
_selection :: Lens' pt FocusState
instance HasSelection ( PointData brushParams ) where
_selection = field' @"pointState"
instance HasSelection BrushPointData where
_selection = field' @"brushPointState"
_coords :: Lens' ( PointData brushParams ) ( Point2D Double )
_coords = field' @"pointCoords"
coords :: PointData brushParams -> Point2D Double
coords = view _coords
data FocusDifference
= DifferentFocus
| SameFocus
deriving stock ( Show, Generic )
deriving anyclass NFData
instance Semigroup FocusDifference where
SameFocus <> SameFocus = SameFocus
_ <> _ = DifferentFocus
instance Monoid FocusDifference where
mempty = SameFocus
instance Group FocusDifference where
invert = id
data DiffPointData diffBrushParams
= DiffPointData
{ diffVector :: !( Vector2D Double )
, diffParams :: !diffBrushParams
, diffState :: !FocusDifference
}
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
deriving anyclass ( NFData, NFData1 )
instance Module Double diffBrushParams => Semigroup ( DiffPointData diffBrushParams ) where
DiffPointData v1 p1 s1 <> DiffPointData v2 p2 s2 =
DiffPointData ( v1 <> v2 ) ( p1 ^+^ p2 ) ( s1 <> s2 )
instance Module Double diffBrushParams => Monoid ( DiffPointData diffBrushParams ) where
mempty = DiffPointData mempty origin mempty
instance Module Double diffBrushParams => Group ( DiffPointData diffBrushParams ) where
invert ( DiffPointData v1 p1 s1 ) =
DiffPointData ( invert v1 ) ( (-1) *^ p1 ) ( invert s1 )
instance ( Module Double diffBrushParams, Act diffBrushParams brushParams )
=> Act ( DiffPointData diffBrushParams ) ( PointData brushParams ) where
(•) ( DiffPointData { diffVector = dp, diffParams = db, diffState = focusDiff } )
= over _coords ( dp • )
. over ( field' @"brushParams" ) ( db • )
. ( case focusDiff of { SameFocus -> id; DifferentFocus -> set ( field' @"pointState" ) Normal } )
instance ( Module Double diffBrushParams, Torsor diffBrushParams brushParams )
=> Torsor ( DiffPointData diffBrushParams ) ( PointData brushParams ) where
( PointData { pointCoords = p1, brushParams = b1, pointState = s1 } ) <-- ( PointData { pointCoords = p2, brushParams = b2, pointState = s2 } ) =
DiffPointData
{ diffVector = p1 <-- p2
, diffParams = b1 <-- b2
, diffState = if s1 == s2 then SameFocus else DifferentFocus
}
instance Module Double brushParams => Module Double ( DiffPointData brushParams ) where
origin = mempty
(^+^) = (<>)
x ^-^ y = x <> invert y
d *^ DiffPointData v1 p1 s1 = DiffPointData ( d *^ v1 ) ( d *^ p1 ) s1
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Guides. -- Guides.
@ -250,14 +418,14 @@ selectGuide_maybe c zoom guide@( Guide { guidePoint = p, guideNormal = n } )
-- | Add new guide after a mouse drag from a ruler area. -- | Add new guide after a mouse drag from a ruler area.
addGuide :: UniqueSupply -> Ruler -> Point2D Double -> Document -> STM Document addGuide :: UniqueSupply -> Ruler -> Point2D Double -> Document -> STM Document
addGuide uniqueSupply ruler p = ( field' @"documentContent" . field' @"guides" ) insertNewGuides addGuide uniqueSupply ruler p doc = ( `runReaderT` uniqueSupply ) $ ( field' @"documentContent" . field' @"guides" ) insertNewGuides doc
where where
insertNewGuides :: Map Unique Guide -> STM ( Map Unique Guide ) insertNewGuides :: Map Unique Guide -> ReaderT UniqueSupply STM ( Map Unique Guide )
insertNewGuides gs = case ruler of insertNewGuides gs = case ruler of
RulerCorner RulerCorner
-> do -> do
uniq1 <- freshUnique uniqueSupply uniq1 <- freshUnique
uniq2 <- freshUnique uniqueSupply uniq2 <- freshUnique
let let
guide1, guide2 :: Guide guide1, guide2 :: Guide
guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideFocus = Normal, guideUnique = uniq1 } guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideFocus = Normal, guideUnique = uniq1 }
@ -265,14 +433,14 @@ addGuide uniqueSupply ruler p = ( field' @"documentContent" . field' @"guides" )
pure ( Map.insert uniq2 guide2 . Map.insert uniq1 guide1 $ gs ) pure ( Map.insert uniq2 guide2 . Map.insert uniq1 guide1 $ gs )
TopRuler TopRuler
-> do -> do
uniq1 <- freshUnique uniqueSupply uniq1 <- freshUnique
let let
guide1 :: Guide guide1 :: Guide
guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideFocus = Normal, guideUnique = uniq1 } guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideFocus = Normal, guideUnique = uniq1 }
pure ( Map.insert uniq1 guide1 gs ) pure ( Map.insert uniq1 guide1 gs )
LeftRuler LeftRuler
-> do -> do
uniq2 <- freshUnique uniqueSupply uniq2 <- freshUnique
let let
guide2 :: Guide guide2 :: Guide
guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideFocus = Normal, guideUnique = uniq2 } guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideFocus = Normal, guideUnique = uniq2 }

174
src/app/MetaBrush/Document/Draw.hs
View file

@ -1,8 +1,10 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module MetaBrush.Document.Draw module MetaBrush.Document.Draw
@ -22,12 +24,10 @@ import Data.Act
-- containers -- containers
import Data.Sequence import Data.Sequence
( Seq(..) ) ( Seq(..) )
import qualified Data.Sequence as Seq
( singleton, reverse, take, drop, length )
-- generic-lens -- generic-lens
import Data.Generics.Product.Fields import Data.Generics.Product.Fields
( field' ) ( field, field' )
-- lens -- lens
import Control.Lens import Control.Lens
@ -37,6 +37,12 @@ import Control.Lens
import Control.Concurrent.STM import Control.Concurrent.STM
( STM ) ( STM )
-- superrecord
import qualified SuperRecord as Super
( Rec )
import qualified SuperRecord
( rnil )
-- text -- text
import Data.Text import Data.Text
( Text ) ( Text )
@ -44,17 +50,27 @@ import Data.Text
-- transformers -- transformers
import Control.Monad.Trans.State.Strict import Control.Monad.Trans.State.Strict
( State, runState, get, put ) ( State, runState, get, put )
import Control.Monad.Trans.Reader
( runReaderT )
-- MetaBrush -- MetaBrush
import Math.Bezier.Stroke import Math.Bezier.Spline
( StrokePoint(..) ) ( Spline(..), Curves(..)
, SplineType(..), SSplineType(..)
, SplineTypeI(ssplineType)
, reverseSpline, splineEnd
, openCurveEnd
)
import Math.Module import Math.Module
( squaredNorm ) ( squaredNorm )
import Math.Vector2D import Math.Vector2D
( Point2D(..), Vector2D(..) ) ( Point2D(..), Vector2D(..) )
import MetaBrush.Document import MetaBrush.Document
( Document(..), Stroke(..), FocusState(..), PointData(..) ( Document(..), Stroke(..), StrokeSpline
, _selection , FocusState(..), PointData(..)
, emptyBrush
, _selection, _strokeSpline
, coords, overStrokeSpline
) )
import MetaBrush.Unique import MetaBrush.Unique
( Unique, UniqueSupply, freshUnique, uniqueText ) ( Unique, UniqueSupply, freshUnique, uniqueText )
@ -81,75 +97,115 @@ getOrCreateDrawAnchor
-> Point2D Double -> Point2D Double
-> Document -> Document
-> STM ( Document, DrawAnchor, Point2D Double, Maybe Text ) -> STM ( Document, DrawAnchor, Point2D Double, Maybe Text )
getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
case ( `runState` Nothing ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc of case
( `runState` Nothing )
$ ( field' @"documentContent" . field' @"strokes" . traverse )
updateStroke doc
of
-- Anchor found: use it. -- Anchor found: use it.
( newDoc, Just ( ( anchor, anchorPt ), anchorName ) ) -> do ( newDoc, Just ( ( anchor, anchorPt ), anchorName ) ) ->
pure ( newDoc, anchor, anchorPt, Just anchorName ) pure ( newDoc, anchor, anchorPt, Just anchorName )
-- No anchor found: start a new stroke (on a new stroke layer). -- No anchor found: start a new stroke (on a new stroke layer).
( newDoc, Nothing ) -> do ( newDoc, Nothing ) -> do
uniq <- freshUnique uniqueSupply uniq <- runReaderT freshUnique uniqueSupply
let let
newSpline :: StrokeSpline Open ( Super.Rec '[] )
newSpline =
Spline { splineStart = PointData c Normal ( SuperRecord.rnil )
, splineCurves = OpenCurves Empty
}
newStroke :: Stroke
newStroke =
Stroke
{ strokeName = "Stroke " <> uniqueText uniq
, strokeVisible = True
, strokeUnique = uniq
, strokeSpline = newSpline
, strokeBrush = emptyBrush
}
newDoc' :: Document newDoc' :: Document
newDoc' newDoc'
= over ( field' @"documentContent" . field' @"strokes" ) = over ( field' @"documentContent" . field' @"strokes" )
( Stroke ( newStroke : )
{ strokeName = "Stroke " <> uniqueText uniq
, strokeVisible = True
, strokeUnique = uniq
, strokePoints = Seq.singleton $ PathPoint c ( PointData Normal Empty )
}
: )
newDoc newDoc
pure ( newDoc', AnchorAtEnd uniq, c, Nothing ) pure ( newDoc', AnchorAtEnd uniq, c, Nothing )
where where
-- Deselect all points, and try to find a valid anchor for drawing -- Deselect all points, and try to find a valid anchor for drawing
-- (a path start/end point at mouse click point). -- (a path start/end point at mouse click point).
updateStroke :: Stroke -> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) Stroke updateStroke :: Stroke -> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) Stroke
updateStroke stroke@( Stroke { strokeName, strokeVisible, strokePoints, strokeUnique } ) = do updateStroke stroke@( Stroke { strokeName, strokeVisible, strokeUnique } ) = _strokeSpline updateStrokeSpline stroke
mbAnchor <- get where
case mbAnchor of updateStrokeSpline
-- If we haven't already found an anchor, :: forall clo brushParams
-- and the current point is a valid candidate, . SplineTypeI clo
-- then select it as an anchor for the drawing operation. => StrokeSpline clo brushParams
Nothing -> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) ( StrokeSpline clo brushParams )
| strokeVisible updateStrokeSpline spline = do
, Just anchor <- endpointAnchor strokeUnique strokePoints
-> put ( Just ( anchor, strokeName ) )
$> set ( field' @"strokePoints" . mapped . _selection ) Normal stroke
-- Otherwise, just deselect.
_ -> pure $ set ( field' @"strokePoints" . mapped . _selection ) Normal stroke
-- See if we can anchor a drawing operation on a given (visible) stroke.
endpointAnchor :: Unique -> Seq ( StrokePoint PointData ) -> Maybe ( DrawAnchor, Point2D Double )
endpointAnchor _ ( PathPoint { coords = p0 } :<| ( _ :|> PathPoint { coords = pn } ) )
| p0 == pn
= Nothing
endpointAnchor uniq (PathPoint { coords = p0 } :<| _ )
| inPointClickRange p0
= Just ( AnchorAtStart uniq, p0 )
endpointAnchor uniq ( _ :|> PathPoint { coords = pn } )
| inPointClickRange pn
= Just ( AnchorAtEnd uniq, pn )
endpointAnchor _ _ = Nothing
inPointClickRange :: Point2D Double -> Bool
inPointClickRange p =
squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
addToAnchor :: DrawAnchor -> Seq ( StrokePoint PointData ) -> Document -> Document mbAnchor <- get
addToAnchor anchor newPts = over ( field' @"documentContent" . field' @"strokes" . mapped ) addToStroke case mbAnchor of
-- If we haven't already found an anchor,
-- and the current point is a valid candidate,
-- then select it as an anchor for the drawing operation.
Nothing
| strokeVisible
, Just anchor <- endpointAnchor strokeUnique spline
-> put ( Just ( anchor, strokeName ) )
$> set ( mapped . _selection ) Normal spline
-- Otherwise, just deselect.
_ -> pure $ set ( mapped . _selection ) Normal spline
where
-- See if we can anchor a drawing operation on a given (visible) stroke.
endpointAnchor :: Unique -> StrokeSpline clo brushParams -> Maybe ( DrawAnchor, Point2D Double )
endpointAnchor uniq ( Spline { splineStart, splineCurves } ) = case ssplineType @clo of
SOpen
| let
p0 :: Point2D Double
p0 = coords splineStart
, inPointClickRange p0
-> Just ( AnchorAtStart uniq, p0 )
| OpenCurves ( _ :|> lastCurve ) <- splineCurves
, let
pn :: Point2D Double
pn = coords ( openCurveEnd lastCurve )
, inPointClickRange pn
-> Just ( AnchorAtEnd uniq, pn )
_ -> Nothing
inPointClickRange :: Point2D Double -> Bool
inPointClickRange p =
squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
addToAnchor :: DrawAnchor -> StrokeSpline Open () -> Document -> Document
addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strokes" . mapped ) addToStroke
where where
addToStroke :: Stroke -> Stroke addToStroke :: Stroke -> Stroke
addToStroke stroke@( Stroke { strokeUnique, strokePoints = pts } ) addToStroke stroke@( Stroke { strokeUnique } )
| strokeUnique == anchorStrokeUnique anchor | strokeUnique == anchorStrokeUnique anchor
= case anchor of =
AnchorAtStart _ -> stroke { strokePoints = Seq.reverse newPts <> Seq.drop 1 pts } let
AnchorAtEnd _ -> stroke { strokePoints = dropEnd 1 pts <> newPts } updateSpline
:: forall clo brushData
. SplineTypeI clo
=> StrokeSpline clo brushData -> StrokeSpline clo brushData
updateSpline prevSpline
| SOpen <- ssplineType @clo
= case anchor of
AnchorAtStart _ ->
let
setBrushData :: PointData () -> PointData brushData
setBrushData = set ( field @"brushParams" ) ( brushParams ( splineStart prevSpline ) )
in fmap setBrushData ( reverseSpline newSpline ) <> prevSpline
AnchorAtEnd _ ->
let
setBrushData :: PointData () -> PointData brushData
setBrushData = set ( field @"brushParams" ) ( brushParams ( splineEnd prevSpline ) )
in prevSpline <> fmap setBrushData newSpline
| otherwise
= error "addToAnchor: trying to add to a closed spline"
in
overStrokeSpline updateSpline stroke
| otherwise | otherwise
= stroke = stroke
dropEnd :: Int -> Seq a -> Seq a
dropEnd i as = Seq.take ( n - i ) as
where
n :: Int
n = Seq.length as

3
src/app/MetaBrush/Document/History.hs
View file

@ -1,13 +1,10 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DerivingVia #-}
{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}

952
src/app/MetaBrush/Document/Selection.hs
View file

File diff suppressed because it is too large Load diff

774
src/app/MetaBrush/Document/Serialise.hs
View file

@ -1,12 +1,26 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
module MetaBrush.Document.Serialise module MetaBrush.Document.Serialise
( documentToJSON, documentFromJSON ( Serialisable(..)
, documentToJSON, documentFromJSON
, saveDocument, loadDocument , saveDocument, loadDocument
) )
where where
@ -24,6 +38,24 @@ import Data.Functor.Contravariant
( contramap ) ( contramap )
import Data.Functor.Identity import Data.Functor.Identity
( Identity(..) ) ( Identity(..) )
import Data.Kind
( Type )
import Data.List
( sortBy )
import Data.Ord
( comparing )
import Data.Proxy
( Proxy(Proxy) )
import Data.Type.Equality
( (:~:)(Refl) )
import Data.Typeable
( Typeable, eqT )
import GHC.Exts
( Proxy#, proxy# )
import GHC.TypeLits
( symbolVal', KnownSymbol, SomeSymbol(..), someSymbolVal, sameSymbol )
import GHC.TypeNats
( KnownNat )
import Unsafe.Coerce import Unsafe.Coerce
( unsafeCoerce ) -- Tony Morris special ( unsafeCoerce ) -- Tony Morris special
@ -51,6 +83,10 @@ import Data.Sequence
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
( fromList ) ( fromList )
-- deepseq
import Control.DeepSeq
( NFData(..) )
-- directory -- directory
import System.Directory import System.Directory
( canonicalizePath, createDirectoryIfMissing, doesFileExist ) ( canonicalizePath, createDirectoryIfMissing, doesFileExist )
@ -63,10 +99,18 @@ import System.FilePath
import Data.Generics.Product.Typed import Data.Generics.Product.Typed
( HasType(typed) ) ( HasType(typed) )
-- groups
import Data.Group
( Group )
-- lens -- lens
import Control.Lens import Control.Lens
( view ) ( view )
-- mtl
import Control.Monad.Except
( MonadError(throwError) )
-- scientific -- scientific
import qualified Data.Scientific as Scientific import qualified Data.Scientific as Scientific
( fromFloatDigits, toRealFloat ) ( fromFloatDigits, toRealFloat )
@ -75,13 +119,29 @@ import qualified Data.Scientific as Scientific
import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM as STM
( atomically ) ( atomically )
-- superrecord
import qualified SuperRecord as Super
( Rec )
import qualified SuperRecord
( Has, RecTy, (:=), FldProxy(..)
, RecSize, RecApply(..), RecVecIdxPos, UnsafeRecBuild(..)
, TraversalCHelper, RemoveAccessTo, Intersect
, reflectRec
)
import SuperRecord
( ConstC, Tuple22C )
-- text -- text
import Data.Text import Data.Text
( Text ) ( Text )
import qualified Data.Text as Text
( pack, unpack, unwords )
-- transformers -- transformers
import Control.Monad.IO.Class import Control.Monad.IO.Class
( MonadIO(liftIO) ) ( MonadIO(liftIO) )
import Control.Monad.Trans.Reader
( runReaderT )
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
( MonadTrans(lift) ) ( MonadTrans(lift) )
@ -91,14 +151,14 @@ import qualified Waargonaut.Attoparsec as JSON.Decoder
import qualified Waargonaut.Decode as JSON import qualified Waargonaut.Decode as JSON
( Decoder ) ( Decoder )
import qualified Waargonaut.Decode.Error as JSON import qualified Waargonaut.Decode.Error as JSON
( DecodeError ) ( DecodeError(ParseFailed) )
import qualified Waargonaut.Decode as JSON.Decoder import qualified Waargonaut.Decode as JSON.Decoder
( atKey, bool, list, oneOf, scientific, text ) ( atKey, atKeyOptional, bool, list, objectAsKeyValues, scientific, text )
import qualified Waargonaut.Encode as JSON import qualified Waargonaut.Encode as JSON
( Encoder, Encoder' ) ( Encoder )
import qualified Waargonaut.Encode as JSON.Encoder import qualified Waargonaut.Encode as JSON.Encoder
( runEncoder ( runEncoder, runPureEncoder
, atKey', bool, list, mapLikeObj, scientific, text , atKey', bool, json, keyValueTupleFoldable, list, mapLikeObj, scientific, text, either
) )
import qualified Waargonaut.Encode.Builder as JSON.Builder import qualified Waargonaut.Encode.Builder as JSON.Builder
( waargonautBuilder, bsBuilder ) ( waargonautBuilder, bsBuilder )
@ -112,20 +172,40 @@ import qualified Waargonaut.Prettier as JSON
( prettyJson ) ( prettyJson )
import qualified Waargonaut.Prettier as TonyMorris import qualified Waargonaut.Prettier as TonyMorris
( Natural ) ( Natural )
import Waargonaut.Types.Json
( Json )
-- MetaBrush -- MetaBrush
import Math.Bezier.Stroke import qualified Math.Bezier.Cubic as Cubic
( StrokePoint(..) ) ( Bezier )
import Math.Vector2D import qualified Math.Bezier.Quadratic as Quadratic
( Point2D(..), Vector2D(..) ) ( Bezier )
import MetaBrush.Document import Math.Bezier.Spline
( Document(..), DocumentContent(..) ( Spline(..), SplinePts, SplineType(..), SSplineType(..), SplineTypeI(..)
, Guide(..) , Curves(..), Curve(..), NextPoint(..)
, Stroke(..)
, PointData(..)
, BrushPointData(..)
, FocusState(..)
) )
import Math.Bezier.Stroke
( CachedStroke(..) )
import Math.Module
( Module )
import Math.Vector2D
( Point2D(..), Vector2D(..), Segment )
import MetaBrush.Document
( Document(..), DocumentContent(..), Guide(..)
, Stroke(..), StrokeSpline
, PointData(..), Brush(..) , FocusState(..)
)
import MetaBrush.MetaParameter.AST
( SType(..), STypeI(..), STypes(..), STypesI(..)
, SomeSType(..), someSTypes
, Adapted, AdaptableFunction(..), BrushFunction
, MapFields, UniqueField, UseFieldsInBrush
, eqTy, eqTys
)
import MetaBrush.MetaParameter.Driver
( SomeBrushFunction(..), interpretBrush )
import MetaBrush.MetaParameter.Interpolation
( Interpolatable(..), MapDiff, HasDiff', HasTorsor )
import MetaBrush.Unique import MetaBrush.Unique
( Unique, UniqueSupply, freshUnique ) ( Unique, UniqueSupply, freshUnique )
@ -176,31 +256,53 @@ loadDocument uniqueSupply fp = do
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
encodeDouble :: Applicative f => JSON.Encoder f Double class Serialisable a where
encodeDouble = contramap Scientific.fromFloatDigits JSON.Encoder.scientific encoder :: Monad f => JSON.Encoder f a
decoder :: Monad m => JSON.Decoder m a
decodeDouble :: Monad m => JSON.Decoder m Double instance Serialisable Double where
decodeDouble = fmap Scientific.toRealFloat JSON.Decoder.scientific encoder = contramap Scientific.fromFloatDigits JSON.Encoder.scientific
decoder = fmap Scientific.toRealFloat JSON.Decoder.scientific
instance Serialisable a => Serialisable ( Point2D a ) where
encoder = JSON.Encoder.mapLikeObj \ ( Point2D x y ) ->
JSON.Encoder.atKey' "x" encoder x
. JSON.Encoder.atKey' "y" encoder y
decoder = Point2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
instance Serialisable a => Serialisable ( Vector2D a ) where
encoder = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) ->
JSON.Encoder.atKey' "x" encoder x
. JSON.Encoder.atKey' "y" encoder y
decoder = Vector2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
encodePoint2D :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Point2D a ) instance ( SuperRecord.RecApply flds flds ( ConstC Serialisable )
encodePoint2D enc = JSON.Encoder.mapLikeObj \ ( Point2D x y ) -> , SuperRecord.UnsafeRecBuild flds flds ( ConstC Serialisable )
JSON.Encoder.atKey' "x" enc x . JSON.Encoder.atKey' "y" enc y , KnownNat ( SuperRecord.RecSize flds )
)
=> Serialisable ( Super.Rec flds ) where
encoder :: forall f. Monad f => JSON.Encoder f ( Super.Rec flds )
encoder = contramap ( SuperRecord.reflectRec @( ConstC Serialisable ) keyVal ) ( JSON.Encoder.keyValueTupleFoldable JSON.Encoder.json )
where
keyVal :: forall k v. ( KnownSymbol k, Serialisable v ) => SuperRecord.FldProxy k -> v -> ( Text, Json )
keyVal _ v = let k = symbolVal' ( proxy# :: Proxy# k ) in ( Text.pack k, JSON.Encoder.runPureEncoder ( encoder @v ) v )
decodePoint2D :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Point2D a ) decoder :: forall m. Monad m => JSON.Decoder m ( Super.Rec flds )
decodePoint2D dec = Point2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" dec decoder = SuperRecord.unsafeRecBuild @flds @flds @( ConstC Serialisable ) decodeAndWrite
where
decodeAndWrite
:: forall k v
encodeVector2D :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Vector2D a ) . ( KnownSymbol k, Serialisable v )
encodeVector2D enc = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) -> => SuperRecord.FldProxy k -> Proxy# v
JSON.Encoder.atKey' "x" enc x -> JSON.Decoder m v
. JSON.Encoder.atKey' "y" enc y decodeAndWrite _ _ = do
let
decodeVector2D :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Vector2D a ) k :: Text
decodeVector2D dec = Vector2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" dec k = Text.pack ( symbolVal' ( proxy# :: Proxy# k ) )
val <- JSON.Decoder.atKey k ( decoder @v @m )
pure val
--------------------------------------------------------------------------------
{- {-
encodeMat22 :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Mat22 a ) encodeMat22 :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Mat22 a )
@ -238,30 +340,115 @@ decodeAABB = do
-} -}
encodeStrokePoint :: Applicative f => JSON.Encoder' d -> JSON.Encoder f ( StrokePoint d ) encodeCurve
encodeStrokePoint enc = JSON.Encoder.mapLikeObj \case :: forall clo crvData ptData f
PathPoint { coords, pointData } -> . ( SplineTypeI clo, Applicative f )
JSON.Encoder.atKey' "coords" ( encodePoint2D encodeDouble ) coords => JSON.Encoder Identity ptData
. JSON.Encoder.atKey' "data" enc pointData -> JSON.Encoder f ( Curve clo crvData ptData )
. JSON.Encoder.atKey' "type" JSON.Encoder.text "path" encodeCurve encodePtData = case ssplineType @clo of
ControlPoint { coords, pointData } -> SOpen -> JSON.Encoder.mapLikeObj \case
JSON.Encoder.atKey' "coords" ( encodePoint2D encodeDouble ) coords LineTo ( NextPoint p1 ) _ ->
. JSON.Encoder.atKey' "data" enc pointData JSON.Encoder.atKey' "p1" encodePtData p1
. JSON.Encoder.atKey' "type" JSON.Encoder.text "control" Bezier2To p1 ( NextPoint p2 ) _ ->
JSON.Encoder.atKey' "p1" encodePtData p1
. JSON.Encoder.atKey' "p2" encodePtData p2
Bezier3To p1 p2 ( NextPoint p3 ) _ ->
JSON.Encoder.atKey' "p1" encodePtData p1
. JSON.Encoder.atKey' "p2" encodePtData p2
. JSON.Encoder.atKey' "p3" encodePtData p3
SClosed -> JSON.Encoder.mapLikeObj \case
LineTo BackToStart _ -> id
Bezier2To p1 BackToStart _ ->
JSON.Encoder.atKey' "p1" encodePtData p1
Bezier3To p1 p2 BackToStart _ ->
JSON.Encoder.atKey' "p1" encodePtData p1
. JSON.Encoder.atKey' "p2" encodePtData p2
decodeStrokePointTypeIsPath :: Monad m => JSON.Decoder m Bool decodeCurve
decodeStrokePointTypeIsPath = JSON.Decoder.oneOf JSON.Decoder.text "StrokePoint Type" :: forall clo ptData m
[ ( "path", True ), ( "control", False ) ] . ( SplineTypeI clo, Monad m )
=> JSON.Decoder m ptData
-> JSON.Decoder m ( Curve clo CachedStroke ptData )
decodeCurve decodePtData = case ssplineType @clo of
SOpen -> do
p1 <- JSON.Decoder.atKey "p1" decodePtData
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
case mb_p2 of
Nothing ->
pure ( LineTo ( NextPoint p1 ) ( CachedStroke Nothing ) )
Just p2 -> do
mb_p3 <- JSON.Decoder.atKeyOptional "p3" decodePtData
case mb_p3 of
Nothing -> pure ( Bezier2To p1 ( NextPoint p2 ) ( CachedStroke Nothing ) )
Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) ( CachedStroke Nothing ) )
SClosed -> do
mb_p1 <- JSON.Decoder.atKeyOptional "p1" decodePtData
case mb_p1 of
Nothing ->
pure ( LineTo BackToStart ( CachedStroke Nothing ) )
Just p1 -> do
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
case mb_p2 of
Nothing -> pure ( Bezier2To p1 BackToStart ( CachedStroke Nothing ) )
Just p2 -> pure ( Bezier3To p1 p2 BackToStart ( CachedStroke Nothing ) )
decodeStrokePoint :: Monad m => JSON.Decoder m d -> JSON.Decoder m ( StrokePoint d )
decodeStrokePoint dec = do
coords <- JSON.Decoder.atKey "coords" ( decodePoint2D decodeDouble )
pointData <- JSON.Decoder.atKey "data" dec
isPathPoint <- JSON.Decoder.atKey "type" decodeStrokePointTypeIsPath
if isPathPoint
then pure ( PathPoint { coords, pointData } )
else pure ( ControlPoint { coords, pointData } )
encodeCurves
:: forall clo crvData ptData f
. ( SplineTypeI clo, Applicative f )
=> JSON.Encoder Identity ptData
-> JSON.Encoder f ( Curves clo crvData ptData )
encodeCurves encodePtData = case ssplineType @clo of
SOpen -> contramap ( openCurves ) ( encodeSequence $ encodeCurve @Open encodePtData )
SClosed -> contramap ( \case { NoCurves -> Left (); ClosedCurves prevs lst -> Right ( prevs, lst ) } ) ( JSON.Encoder.either encodeL encodeR )
where
encodeL :: JSON.Encoder f ()
encodeL = contramap ( const "NoCurves" ) JSON.Encoder.text
encodeR :: JSON.Encoder f ( Seq ( Curve Open crvData ptData ), Curve Closed crvData ptData )
encodeR = JSON.Encoder.mapLikeObj \ ( openCurves, closedCurve ) ->
JSON.Encoder.atKey' "prevOpenCurves" ( encodeSequence $ encodeCurve @Open encodePtData ) openCurves
. JSON.Encoder.atKey' "lastClosedCurve" ( encodeCurve @Closed encodePtData ) closedCurve
decodeCurves
:: forall clo ptData m
. ( SplineTypeI clo, Monad m )
=> JSON.Decoder m ptData
-> JSON.Decoder m ( Curves clo CachedStroke ptData )
decodeCurves decodePtData = case ssplineType @clo of
SOpen -> OpenCurves <$> decodeSequence ( decodeCurve @Open decodePtData )
SClosed -> do
mbNoCurves <- JSON.Decoder.atKeyOptional "NoCurves" ( JSON.Decoder.text )
case mbNoCurves of
Just _ -> pure NoCurves
Nothing -> do
prevCurves <- JSON.Decoder.atKey "prevOpenCurves" ( decodeSequence $ decodeCurve @Open decodePtData )
lastCurve <- JSON.Decoder.atKey "lastClosedCurve" ( decodeCurve @Closed decodePtData )
pure ( ClosedCurves prevCurves lastCurve )
encodeSpline
:: forall clo crvData ptData f
. ( SplineTypeI clo, Applicative f )
=> JSON.Encoder Identity ptData
-> JSON.Encoder f ( Spline clo crvData ptData )
encodeSpline encodePtData = JSON.Encoder.mapLikeObj \ ( Spline { splineStart, splineCurves } ) ->
JSON.Encoder.atKey' "splineStart" encodePtData splineStart
. JSON.Encoder.atKey' "splineCurves" ( encodeCurves @clo encodePtData ) splineCurves
decodeSpline
:: forall clo ptData m
. ( SplineTypeI clo, Monad m )
=> JSON.Decoder m ptData
-> JSON.Decoder m ( Spline clo CachedStroke ptData )
decodeSpline decodePtData = do
splineStart <- JSON.Decoder.atKey "splineStart" decodePtData
splineCurves <- JSON.Decoder.atKey "splineCurves" ( decodeCurves @clo decodePtData )
pure ( Spline { splineStart, splineCurves } )
{-
encodeFocusState :: Applicative f => JSON.Encoder f FocusState encodeFocusState :: Applicative f => JSON.Encoder f FocusState
encodeFocusState = contramap focusText JSON.Encoder.text encodeFocusState = contramap focusText JSON.Encoder.text
where where
@ -287,7 +474,7 @@ decodeBrushPointData :: Monad m => JSON.Decoder m BrushPointData
decodeBrushPointData = do decodeBrushPointData = do
brushPointState <- JSON.Decoder.atKey "focus" decodeFocusState brushPointState <- JSON.Decoder.atKey "focus" decodeFocusState
pure ( BrushPointData { brushPointState } ) pure ( BrushPointData { brushPointState } )
-}
encodeSequence :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Seq a ) encodeSequence :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Seq a )
@ -306,50 +493,269 @@ decodeUniqueMap dec = Map.fromList . map ( view typed &&& id ) <$> JSON.Decoder.
encodePointData :: Applicative f => JSON.Encoder f PointData encodePointData
encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointState, brushShape } ) -> :: forall f flds brushParams
JSON.Encoder.atKey' "focus" encodeFocusState pointState . ( Applicative f
. JSON.Encoder.atKey' "brush" ( encodeSequence ( encodeStrokePoint encodeBrushPointData ) ) brushShape , brushParams ~ Super.Rec flds
, Serialisable ( Super.Rec flds )
)
=> JSON.Encoder f ( PointData brushParams )
encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointCoords, brushParams } ) ->
JSON.Encoder.atKey' "coords" ( encoder @( Point2D Double ) ) pointCoords
. JSON.Encoder.atKey' "brushParams" ( encoder @( Super.Rec flds ) ) brushParams
decodePointData :: Monad m => JSON.Decoder m PointData decodePointData
:: forall m flds brushParams
. ( Monad m
, brushParams ~ Super.Rec flds
, Serialisable ( Super.Rec flds )
)
=> JSON.Decoder m ( PointData brushParams )
decodePointData = do decodePointData = do
pointState <- JSON.Decoder.atKey "focus" decodeFocusState pointCoords <- JSON.Decoder.atKey "coords" ( decoder @( Point2D Double ) )
brushShape <- JSON.Decoder.atKey "brush" ( decodeSequence ( decodeStrokePoint decodeBrushPointData ) ) let
pure ( PointData { pointState, brushShape } ) pointState :: FocusState
pointState = Normal
brushParams <- JSON.Decoder.atKey "brushParams" ( decoder @( Super.Rec flds ) )
pure ( PointData { pointCoords, pointState, brushParams } )
encodeStroke :: Applicative f => JSON.Encoder f Stroke encodeSomeSType :: Applicative f => JSON.Encoder f SomeSType
encodeStroke = JSON.Encoder.mapLikeObj \ ( Stroke { strokeName, strokeVisible, strokePoints } ) -> encodeSomeSType = JSON.Encoder.mapLikeObj \ ( SomeSType ( _ :: Proxy# ty ) ) ->
JSON.Encoder.atKey' "name" JSON.Encoder.text strokeName case sTypeI @ty of
. JSON.Encoder.atKey' "visible" JSON.Encoder.bool strokeVisible sFunTy@SFunTy | ( _ :: SType ( a -> b ) ) <- sFunTy
. JSON.Encoder.atKey' "points" ( encodeSequence ( encodeStrokePoint encodePointData ) ) strokePoints -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "fun"
. JSON.Encoder.atKey' "arg" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) )
. JSON.Encoder.atKey' "res" encodeSomeSType ( SomeSType ( proxy# :: Proxy# b ) )
STyBool
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bool"
STyDouble
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "double"
sTyPoint@STyPoint | ( _ :: SType ( Point2D a ) ) <- sTyPoint
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "point"
. JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) )
sTyLine@STyLine | ( _ :: SType ( Segment a ) ) <- sTyLine
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "line"
. JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) )
sTyBez2@STyBez2 | ( _ :: SType ( Quadratic.Bezier a ) ) <- sTyBez2
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bez2"
. JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) )
sTyBez3@STyBez3 | ( _ :: SType ( Cubic.Bezier a ) ) <- sTyBez3
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bez3"
. JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) )
sTySpline@STySpline | ( _ :: SType ( SplinePts clo ) ) <- sTySpline
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "spline"
. JSON.Encoder.atKey' "closed" JSON.Encoder.bool ( case ssplineType @clo of { SOpen -> False; SClosed -> True } )
sTyRecord@STyWithFn | ( _ :: SType ( AdaptableFunction kvs res ) ) <- sTyRecord
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "adaptableFun"
. JSON.Encoder.atKey' "fields" encodeFieldTypes ( someSTypes @kvs )
. JSON.Encoder.atKey' "res" encodeSomeSType ( SomeSType ( proxy# :: Proxy# res ) )
{-
decodeSomeSType :: Monad m => JSON.Decoder m SomeSType
decodeSomeSType = do
tag <- JSON.Decoder.atKey "tag" JSON.Decoder.text
case tag of
"fun" -> do
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "arg" decodeSomeSType
( SomeSType ( _ :: Proxy# b ) ) <- JSON.Decoder.atKey "res" decodeSomeSType
pure ( SomeSType ( proxy# :: Proxy# ( a -> b ) ) )
"bool" -> pure ( SomeSType ( proxy# :: Proxy# Bool ) )
"double" -> pure ( SomeSType ( proxy# :: Proxy# Double ) )
"point" -> do
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
pure ( SomeSType ( proxy# :: Proxy# ( Point2D a ) ) )
"line" -> do
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
pure ( SomeSType ( proxy# :: Proxy# ( Segment a ) ) )
"bez2" -> do
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
pure ( SomeSType ( proxy# :: Proxy# ( Quadratic.Bezier a ) ) )
"bez3" -> do
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
pure ( SomeSType ( proxy# :: Proxy# ( Cubic.Bezier a ) ) )
"spline" -> do
closed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool
case closed of
True -> pure ( SomeSType ( proxy# :: Proxy# ( SplinePts Closed ) ) )
False -> pure ( SomeSType ( proxy# :: Proxy# ( SplinePts Open ) ) )
"adaptableFun" -> do
( SomeBrushFields ( _ :: Proxy# kvs ) ) <- JSON.Decoder.atKey "fields" decodeFieldTypes
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "res" decodeSomeSType
pure ( SomeSType ( proxy# :: Proxy# ( AdaptableFunction kvs a ) ) )
-}
decodeSomeFieldSType :: Monad m => JSON.Decoder m SomeFieldSType
decodeSomeFieldSType = do
tag <- JSON.Decoder.atKey "tag" JSON.Decoder.text
case tag of
"double" -> pure ( SomeFieldSType ( proxy# :: Proxy# Double ) )
"point" -> do
( SomeFieldSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeFieldSType
case eqT @a @Double of
Just Refl -> pure ( SomeFieldSType ( proxy# :: Proxy# ( Point2D Double ) ) )
Nothing -> throwError ( JSON.ParseFailed "Point2D: non-Double coordinate type" )
_ -> throwError ( JSON.ParseFailed $ "Unsupported record field type with tag " <> tag )
decodeStroke :: MonadIO m => UniqueSupply -> JSON.Decoder m Stroke
encodeFieldTypes :: Monad f => JSON.Encoder f ( [ ( Text, SomeSType ) ] )
encodeFieldTypes = JSON.Encoder.keyValueTupleFoldable encodeSomeSType
decodeFieldTypes :: Monad m => JSON.Decoder m SomeBrushFields
decodeFieldTypes = do
fields <- JSON.Decoder.objectAsKeyValues JSON.Decoder.text decodeSomeFieldSType
let
sortedFields :: [ ( Text, SomeFieldSType ) ]
sortedFields = sortBy ( comparing fst ) fields
duplicates :: [ Text ]
duplicates = duplicatesAcc [] [] sortedFields
duplicatesAcc :: [ Text ] -> [ Text ] -> [ ( Text, SomeFieldSType ) ] -> [ Text ]
duplicatesAcc _ dups [] = dups
duplicatesAcc seen dups ( ( k, _ ) : kvs )
| k `elem` seen
= duplicatesAcc seen ( k : dups ) kvs
| otherwise
= duplicatesAcc ( k : seen ) dups kvs
case duplicates of
[] -> pure ( mkBrushFields sortedFields )
[dup] -> throwError ( JSON.ParseFailed $ "Duplicate field name " <> dup <> " in brush record type" )
dups -> throwError ( JSON.ParseFailed $ "Duplicate field names in brush record type:\n" <> Text.unwords dups )
where
mkBrushFields :: [ ( Text, SomeFieldSType ) ] -> SomeBrushFields
mkBrushFields = fromSomeBrushFieldsList . mkBrushFieldsList
mkBrushFieldsList :: [ ( Text, SomeFieldSType ) ] -> SomeBrushFieldsList
mkBrushFieldsList [] = SomeBrushFieldsList NilFields
mkBrushFieldsList ( ( k, SomeFieldSType ( _ :: Proxy# v ) ) : kvs )
| SomeBrushFieldsList ( kvs_list :: BrushFieldsList kvs ) <- mkBrushFieldsList kvs
, SomeSymbol ( _ :: Proxy k ) <- someSymbolVal ( Text.unpack k )
-- deduce RecSize ( MapDiff kvs ) ~ RecSize kvs
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize ( MapDiff kvs ) :~: SuperRecord.RecSize kvs )
-- compute indexing into record list (with SuperRecord, the index is the number of fields remaining)
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k ( ( k SuperRecord.:= v ) : kvs ) :~: SuperRecord.RecSize kvs )
= SomeBrushFieldsList ( ConsFields ( proxy# :: Proxy# k ) ( proxy# :: Proxy# v ) kvs_list )
fromSomeBrushFieldsList :: SomeBrushFieldsList -> SomeBrushFields
fromSomeBrushFieldsList ( SomeBrushFieldsList ( kvs :: BrushFieldsList kvs ) ) = case go @kvs kvs of
SomeClassyBrushFieldsList ( _ :: Proxy# kvs ) ( _ :: Proxy# kvs ) ->
SomeBrushFields ( proxy# :: Proxy# kvs )
where
go :: forall ( rts :: [ Type ] ) ( lts :: [ Type ] )
. ( STypesI rts, KnownNat ( SuperRecord.RecSize rts ), KnownNat ( SuperRecord.RecSize ( MapDiff rts ) ) )
=> BrushFieldsList lts -> SomeClassyBrushFieldsList rts lts
go NilFields =
SomeClassyBrushFieldsList ( proxy# :: Proxy# rts ) ( proxy# :: Proxy# '[] )
go ( ConsFields ( _ :: Proxy# k ) ( _ :: Proxy# a ) kvs' )
| ( SomeClassyBrushFieldsList _ ( _ :: Proxy# lts' ) ) <- go @rts kvs'
-- Assert some facts that result from the field names being distinct:
-- - current field name does not re-occur later on
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k lts' :~: lts' )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k ( MapDiff lts' ) :~: MapDiff lts' )
-- - looking up the type associated with the current field name returns the current type
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k rts :~: Just a )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k ( MapDiff rts ) :~: Just ( Diff a ) )
-- - MapDiff preserves length
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize ( MapDiff lts' ) :~: SuperRecord.RecSize lts' )
-- - compute the index (which is the number of fields remaining, i.e. the indexing starts counting from 0 from the right)
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k rts :~: SuperRecord.RecSize lts' )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k ( MapDiff rts ) :~: SuperRecord.RecSize lts' )
= SomeClassyBrushFieldsList ( proxy# :: Proxy# rts ) ( proxy# :: Proxy# ( ( k SuperRecord.:= a ) ': lts' ) )
encodeBrush :: Applicative f => JSON.Encoder f ( Brush brushParams )
encodeBrush = JSON.Encoder.mapLikeObj \ ( BrushData { brushName, brushCode } ) ->
JSON.Encoder.atKey' "name" JSON.Encoder.text brushName
. JSON.Encoder.atKey' "code" JSON.Encoder.text brushCode
decodeBrush
:: forall m flds. ( MonadIO m, STypesI flds )
=> UniqueSupply
-> JSON.Decoder m ( Brush flds )
decodeBrush uniqSupply = do
brushName <- JSON.Decoder.atKey "name" JSON.Decoder.text
brushCode <- JSON.Decoder.atKey "code" JSON.Decoder.text
( mbBrush, _ ) <- lift ( liftIO $ interpretBrush uniqSupply brushCode )
case mbBrush of
Left err -> throwError ( JSON.ParseFailed ( "Failed to interpret brush code:\n" <> ( Text.pack $ show err ) ) )
Right ( SomeBrushFunction ( brushFunction :: BrushFunction brushParams ) ) ->
case eqTys @flds @brushParams of
Just Refl -> pure ( BrushData { brushName, brushCode, brushFunction } )
Nothing ->
throwError
( JSON.ParseFailed $
"Brush has unexpected input record type:\n\
\Expected: " <> Text.pack ( show ( sTypesI @flds ) ) <> "\n\
\ Actual: " <> Text.pack ( show ( sTypesI @brushParams ) )
)
encodeStroke :: Monad f => JSON.Encoder f Stroke
encodeStroke = JSON.Encoder.mapLikeObj
\ ( Stroke
{ strokeName
, strokeVisible
, strokeSpline = strokeSpline :: StrokeSpline clo ( Super.Rec pointFields )
, strokeBrush = strokeBrush :: Brush brushFields
}
) ->
let
closed :: Bool
closed = case ssplineType @clo of
SClosed -> True
SOpen -> False
in
JSON.Encoder.atKey' "name" JSON.Encoder.text strokeName
. JSON.Encoder.atKey' "visible" JSON.Encoder.bool strokeVisible
. JSON.Encoder.atKey' "closed" JSON.Encoder.bool closed
. JSON.Encoder.atKey' "brushFields" encodeFieldTypes ( someSTypes @brushFields )
. JSON.Encoder.atKey' "pointFields" encodeFieldTypes ( someSTypes @pointFields )
. JSON.Encoder.atKey' "usedFields" encodeFieldTypes ( someSTypes @( brushFields `SuperRecord.Intersect` pointFields ) )
. JSON.Encoder.atKey' "brush" encodeBrush strokeBrush
. JSON.Encoder.atKey' "spline" ( encodeSpline encodePointData ) strokeSpline
decodeStroke :: forall m. MonadIO m => UniqueSupply -> JSON.Decoder m Stroke
decodeStroke uniqueSupply = do decodeStroke uniqueSupply = do
strokeName <- JSON.Decoder.atKey "name" JSON.Decoder.text strokeName <- JSON.Decoder.atKey "name" JSON.Decoder.text
strokeVisible <- JSON.Decoder.atKey "visible" JSON.Decoder.bool strokeVisible <- JSON.Decoder.atKey "visible" JSON.Decoder.bool
strokeUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply ) strokeUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
strokePoints <- JSON.Decoder.atKey "points" ( decodeSequence ( decodeStrokePoint decodePointData ) ) strokeClosed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool
pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokePoints } ) SomeBrushFields ( _ :: Proxy# brushFields ) <- JSON.Decoder.atKey "brushFields" decodeFieldTypes
SomeBrushFields ( _ :: Proxy# pointFields ) <- JSON.Decoder.atKey "pointFields" decodeFieldTypes
SomeBrushFields ( _ :: Proxy# usedFields ) <- JSON.Decoder.atKey "usedFields" decodeFieldTypes
strokeBrush <- JSON.Decoder.atKey "brush" ( decodeBrush @m @brushFields uniqueSupply )
case proveAdapted @brushFields @pointFields @usedFields of
Nothing -> throwError ( JSON.ParseFailed "Stroke: 'usedFields' is not equal to 'brushFields `Intersect` pointFields'" )
Just Dict ->
case strokeClosed of
True -> do
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Super.Rec pointFields ) ) decodePointData )
pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush } )
False -> do
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open @( PointData ( Super.Rec pointFields ) ) decodePointData )
pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush } )
encodeGuide :: Applicative f => JSON.Encoder f Guide encodeGuide :: Applicative f => JSON.Encoder f Guide
encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal, guideFocus } ) -> encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) ->
JSON.Encoder.atKey' "point" ( encodePoint2D encodeDouble ) guidePoint JSON.Encoder.atKey' "point" ( encoder @( Point2D Double ) ) guidePoint
. JSON.Encoder.atKey' "normal" ( encodeVector2D encodeDouble ) guideNormal . JSON.Encoder.atKey' "normal" ( encoder @( Vector2D Double ) ) guideNormal
. JSON.Encoder.atKey' "focus" encodeFocusState guideFocus
decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m Guide decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m Guide
decodeGuide uniqueSupply = do decodeGuide uniqueSupply = do
guidePoint <- JSON.Decoder.atKey "point" ( decodePoint2D decodeDouble ) guidePoint <- JSON.Decoder.atKey "point" ( decoder @( Point2D Double ) )
guideNormal <- JSON.Decoder.atKey "normal" ( decodeVector2D decodeDouble ) guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( Vector2D Double ) )
guideFocus <- JSON.Decoder.atKey "focus" decodeFocusState let
guideUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply ) guideFocus :: FocusState
guideFocus = Normal
guideUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
pure ( Guide { guidePoint, guideNormal, guideFocus, guideUnique } ) pure ( Guide { guidePoint, guideNormal, guideFocus, guideUnique } )
encodeDocumentContent :: Applicative f => JSON.Encoder f DocumentContent encodeDocumentContent :: Applicative f => JSON.Encoder f DocumentContent
encodeDocumentContent = JSON.Encoder.mapLikeObj \ ( Content { guides, strokes } ) -> encodeDocumentContent = JSON.Encoder.mapLikeObj \ ( Content { guides, strokes } ) ->
JSON.Encoder.atKey' "guides" ( encodeUniqueMap encodeGuide ) guides JSON.Encoder.atKey' "guides" ( encodeUniqueMap encodeGuide ) guides
@ -370,16 +776,188 @@ decodeDocumentContent uniqueSupply = do
encodeDocument :: Applicative f => JSON.Encoder f Document encodeDocument :: Applicative f => JSON.Encoder f Document
encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, documentContent } ) -> encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, documentContent } ) ->
JSON.Encoder.atKey' "name" JSON.Encoder.text displayName JSON.Encoder.atKey' "name" JSON.Encoder.text displayName
. JSON.Encoder.atKey' "center" ( encodePoint2D encodeDouble ) viewportCenter . JSON.Encoder.atKey' "center" ( encoder @( Point2D Double ) ) viewportCenter
. JSON.Encoder.atKey' "zoom" encodeDouble zoomFactor . JSON.Encoder.atKey' "zoom" ( encoder @Double ) zoomFactor
. JSON.Encoder.atKey' "content" encodeDocumentContent documentContent . JSON.Encoder.atKey' "content" encodeDocumentContent documentContent
decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document
decodeDocument uniqueSupply mbFilePath = do decodeDocument uniqueSupply mbFilePath = do
displayName <- JSON.Decoder.atKey "name" JSON.Decoder.text displayName <- JSON.Decoder.atKey "name" JSON.Decoder.text
viewportCenter <- JSON.Decoder.atKey "center" ( decodePoint2D decodeDouble ) viewportCenter <- JSON.Decoder.atKey "center" ( decoder @( Point2D Double ) )
zoomFactor <- JSON.Decoder.atKey "zoom" decodeDouble zoomFactor <- JSON.Decoder.atKey "zoom" ( decoder @Double )
documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply ) documentUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
documentContent <- JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply ) documentContent <- JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply )
pure ( Document { displayName, mbFilePath, viewportCenter, zoomFactor, documentUnique, documentContent } ) pure ( Document { displayName, mbFilePath, viewportCenter, zoomFactor, documentUnique, documentContent } )
--------------------------------------------------------------------------------
-- Various auxiliary types.
-- | Existential type over an allowed record field type used in brushes, such as Double and Point2D Double.
data SomeFieldSType where
SomeFieldSType
:: ( STypeI a, Show a, NFData a, Serialisable a, Interpolatable a, Typeable a )
=> Proxy# a -> SomeFieldSType
-- | Existential type for allowed fields of a brush record.
data SomeBrushFields where
SomeBrushFields
:: forall kvs rec
. ( STypesI kvs
, rec ~ Super.Rec kvs
, Show rec, NFData rec
, Interpolatable rec
, Serialisable rec
)
=> Proxy# kvs -> SomeBrushFields
instance Show SomeBrushFields where
show ( SomeBrushFields ( _ :: Proxy# kvs ) ) = show ( sTypesI @kvs )
-- | Auxiliary datatype used to create a proof that record fields have the required instances.
data BrushFieldsList kvs where
NilFields :: BrushFieldsList '[]
ConsFields
::
( KnownSymbol k
, Show a, NFData a, Serialisable a
, Interpolatable a
, STypesI kvs
, KnownNat ( SuperRecord.RecSize kvs )
, SuperRecord.Has ( k SuperRecord.:= a ': kvs ) k a
)
=> Proxy# k -> Proxy# a -> BrushFieldsList kvs -> BrushFieldsList ( k SuperRecord.:= a ': kvs )
-- | Existential type used in the process of proving that record fields have the required instances.
data SomeBrushFieldsList where
SomeBrushFieldsList
:: ( STypesI kvs
, KnownNat ( SuperRecord.RecSize kvs )
, KnownNat ( SuperRecord.RecSize ( MapDiff kvs ) )
)
=> BrushFieldsList kvs -> SomeBrushFieldsList
-- | Type used to backtrack instance resolution in the SuperRecord library,
-- to witness the required typeclass instances by induction on the record fields.
data SomeClassyBrushFieldsList rts lts where
SomeClassyBrushFieldsList
:: forall rts lts drts dlts
. ( drts ~ MapDiff rts
, dlts ~ MapDiff lts
, KnownNat ( SuperRecord.RecSize rts )
, KnownNat ( SuperRecord.RecSize drts )
, SuperRecord.UnsafeRecBuild rts lts ( ConstC Serialisable )
, SuperRecord.UnsafeRecBuild drts dlts ( ConstC ( Module Double ) )
, SuperRecord.UnsafeRecBuild drts dlts ( ConstC Monoid )
, SuperRecord.RecApply rts lts ( ConstC Show )
, SuperRecord.RecApply rts lts ( ConstC NFData )
, SuperRecord.RecApply rts lts ( ConstC Serialisable )
, SuperRecord.RecApply drts dlts ( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has drts ) )
, SuperRecord.RecApply drts dlts ( Tuple22C ( ConstC Semigroup ) ( SuperRecord.Has drts ) )
, SuperRecord.RecApply drts dlts ( Tuple22C ( ConstC Group ) ( SuperRecord.Has drts ) )
, SuperRecord.RecApply drts dlts ( HasDiff' rts )
, SuperRecord.TraversalCHelper dlts rts drts ( HasTorsor rts )
)
=> Proxy# rts -> Proxy# lts -> SomeClassyBrushFieldsList rts lts
proveAdapted
:: forall brushFields givenFields usedFields
. ( STypesI brushFields, STypesI givenFields, STypesI usedFields )
=> Maybe ( Dict ( Adapted brushFields givenFields usedFields ) )
proveAdapted
| Just Dict <- proveUnsafeRecBuild @usedFields
, Just Dict <- proveRecApply @brushFields ( size @usedFields )
, Refl <- ( unsafeCoerce Refl :: usedFields :~: ( brushFields `SuperRecord.Intersect` givenFields ) )
= Just Dict
| otherwise
= Nothing
where
-- Provide evidence that each field of "used" appears in "given".
proveUnsafeRecBuild
:: forall lts_used
. ( STypesI lts_used )
=> Maybe ( Dict ( SuperRecord.UnsafeRecBuild usedFields lts_used ( SuperRecord.Has givenFields ) ) )
proveUnsafeRecBuild = case sTypesI @lts_used of
STyNil -> Just Dict
sTyCons@STyCons
| ( _ :: STypes ( k SuperRecord.:= v ': tail_lts_used ) ) <- sTyCons
, SomeIndex ( _ :: Proxy# i ) <- lookupIndex @k @v @givenFields
, Just Dict <- proveUnsafeRecBuild @tail_lts_used
-> Just Dict
| otherwise
-> Nothing
-- Provide evidence whether each field of "brush" appears in "used" or not.
-- Additionally checks that "used" is a subset of "brush".
proveRecApply
:: forall lts_brush
. ( STypesI lts_brush )
=> Int
-> Maybe ( Dict ( SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField lts_brush ) ( UseFieldsInBrush usedFields ) ) )
proveRecApply nbUnseen = case sTypesI @lts_brush of
STyNil -> if nbUnseen < 1 then Just Dict else Nothing
sTyCons@STyCons
| ( _ :: STypes ( k SuperRecord.:= v ': tail_lts_brush ) ) <- sTyCons
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize ( MapFields UniqueField brushFields ) :~: SuperRecord.RecSize brushFields )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k ( MapFields UniqueField brushFields ) :~: SuperRecord.RecSize tail_lts_brush )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k ( MapFields UniqueField brushFields ) :~: Just ( UniqueField v ) )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k ( MapFields UniqueField tail_lts_brush ) :~: MapFields UniqueField tail_lts_brush )
-> case lookupIndex @k @v @usedFields of
SomeIndex ( _ :: Proxy# i ) ->
case proveRecApply @tail_lts_brush ( nbUnseen - 1 ) of
Just Dict -> Just Dict
Nothing -> Nothing
NoIndex ->
case proveRecApply @tail_lts_brush nbUnseen of
Just Dict -> Just Dict
Nothing -> Nothing
data LookupResult k v kvs where
NoIndex
:: forall k v kvs
. ( SuperRecord.RecTy k kvs ~ Nothing )
=> LookupResult k v kvs
SomeIndex
:: forall k v kvs i
. ( SuperRecord.RecTy k kvs ~ Just v
, SuperRecord.RecVecIdxPos k kvs ~ i
, KnownNat i
)
=> Proxy# i -> LookupResult k v kvs
lookupIndex
:: forall k v kvs
. ( STypesI kvs, KnownSymbol k, STypeI v )
=> LookupResult k v kvs
lookupIndex = case sTypesI @kvs of
STyNil -> NoIndex
sTyCons@STyCons
| ( _ :: STypes ( ( l SuperRecord.:= w ) ': tail_kvs ) ) <- sTyCons
-> case sameSymbol ( Proxy :: Proxy k ) ( Proxy :: Proxy l ) of
Just Refl
| Just Refl <- eqTy @v @w
, ( index_proxy :: Proxy# i ) <- ( proxy# :: Proxy# ( SuperRecord.RecSize tail_kvs ) )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k kvs :~: i )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k kvs :~: Just v )
-> SomeIndex index_proxy
_ -> case lookupIndex @k @v @tail_kvs of
NoIndex
| Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k kvs :~: Nothing )
-> NoIndex
SomeIndex ( px_j :: Proxy# j )
| Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k kvs :~: Just v )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k kvs :~: j )
-> SomeIndex px_j
size :: forall kvs. STypesI kvs => Int
size = case sTypesI @kvs of
STyNil -> 0
sTyCons@STyCons
| ( _ :: STypes ( head_kvs ': tail_kvs ) ) <- sTyCons
-> 1 + size @tail_kvs
data Dict c where
Dict :: c => Dict c
type family FromJust ( x :: Maybe a ) where
FromJust ( Just a ) = a

15
src/app/MetaBrush/Document/Serialise.hs-boot Normal file
View file

@ -0,0 +1,15 @@
module MetaBrush.Document.Serialise
( Serialisable(..) )
where
-- waargonaut
import qualified Waargonaut.Decode as JSON
( Decoder )
import qualified Waargonaut.Encode as JSON
( Encoder )
--------------------------------------------------------------------------------
class Serialisable a where
encoder :: Monad f => JSON.Encoder f a
decoder :: Monad m => JSON.Decoder m a

201
src/app/MetaBrush/Document/SubdivideStroke.hs
View file

@ -1,4 +1,6 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
@ -11,6 +13,8 @@ module MetaBrush.Document.SubdivideStroke
where where
-- base -- base
import Data.Functor
( ($>) )
import Data.Semigroup import Data.Semigroup
( Min(..), Arg(..) ) ( Min(..), Arg(..) )
@ -21,6 +25,8 @@ import Data.Act
-- containers -- containers
import Data.Sequence import Data.Sequence
( Seq(..) ) ( Seq(..) )
import qualified Data.Sequence as Seq
( singleton )
-- generic-lens -- generic-lens
import Data.Generics.Product.Fields import Data.Generics.Product.Fields
@ -43,22 +49,29 @@ import qualified Math.Bezier.Cubic as Cubic
( Bezier(..), closestPoint, subdivide ) ( Bezier(..), closestPoint, subdivide )
import qualified Math.Bezier.Quadratic as Quadratic import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..), closestPoint, subdivide ) ( Bezier(..), closestPoint, subdivide )
import Math.Bezier.Spline
( Spline(..), SplineType(..), Curve(..), Curves(..), NextPoint(..)
, KnownSplineType(bifoldSpline, adjustSplineType)
)
import Math.Bezier.Stroke import Math.Bezier.Stroke
( StrokePoint(..) ) ( CachedStroke, discardCache )
import Math.Module import Math.Module
( quadrance, closestPointToSegment ) ( lerp, quadrance, closestPointOnSegment )
import Math.Vector2D import Math.Vector2D
( Point2D(..), Vector2D(..) ) ( Point2D(..), Vector2D(..), Segment(..) )
import MetaBrush.Document import MetaBrush.Document
( Document(..), Stroke(..) ) ( Document(..), Stroke(..), StrokeSpline
import MetaBrush.UI.ToolBar , PointData(..), DiffPointData(..)
( Mode(..) ) , coords, _strokeSpline
)
import MetaBrush.MetaParameter.Interpolation
( Interpolatable(Diff) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Subdivide a path at the given center, provided a path indeed lies there. -- | Subdivide a path at the given center, provided a path indeed lies there.
subdivide :: Mode -> Point2D Double -> Document -> Maybe ( Document, Text ) subdivide :: Point2D Double -> Document -> Maybe ( Document, Text )
subdivide mode c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc subdivide c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc
where where
updatedDoc :: Document updatedDoc :: Document
mbSubdivLoc :: Maybe Text mbSubdivLoc :: Maybe Text
@ -69,95 +82,87 @@ subdivide mode c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdiv
doc doc
updateStroke :: Stroke -> State ( Maybe Text ) Stroke updateStroke :: Stroke -> State ( Maybe Text ) Stroke
updateStroke stroke@( Stroke { strokeVisible, strokeName } ) updateStroke stroke@( Stroke { strokeVisible, strokeName } ) = _strokeSpline updateSpline stroke
| Brush <- mode
= ( field' @"strokePoints" . traverse )
( \ spt ->
( field' @"pointData" . field' @"brushShape" )
( subdivideStroke strokeVisible ( "brush shape of stroke " <> strokeName ) ( MkVector2D $ coords spt ) )
spt
)
stroke
| otherwise
= ( field' @"strokePoints" )
( subdivideStroke strokeVisible ( "stroke " <> strokeName ) ( Vector2D 0 0 ) )
stroke
subdivideStroke
:: forall pt
. Show pt
=> Bool
-> Text
-> Vector2D Double
-> Seq ( StrokePoint pt )
-> State ( Maybe Text ) ( Seq ( StrokePoint pt ) )
subdivideStroke False _ _ pts = pure pts
subdivideStroke True _ _ Empty = pure Empty
subdivideStroke True txt offset ( spt :<| spts ) = go spt spts
where where
go :: StrokePoint pt -> Seq ( StrokePoint pt ) -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) ) updateSpline
go sp0 Empty = pure ( sp0 :<| Empty ) :: forall clo brushParams
-- Line. . ( KnownSplineType clo, Interpolatable brushParams )
go sp0 ( sp1 :<| sps ) => StrokeSpline clo brushParams -> State ( Maybe Text ) ( StrokeSpline clo brushParams )
| PathPoint {} <- sp1 updateSpline spline@( Spline { splineStart } )
, let | not strokeVisible
p0, p1, s :: Point2D Double = pure spline
t :: Double | otherwise
p0 = coords sp0 = fmap ( \ curves -> adjustSplineType @clo $ Spline { splineStart, splineCurves = OpenCurves curves } )
p1 = coords sp1 $ bifoldSpline
( t, s ) = closestPointToSegment @( Vector2D Double ) ( invert offset • c ) p0 p1 ( updateCurve ( "stroke " <> strokeName ) ( Vector2D 0 0 ) )
sqDist :: Double ( const $ pure Empty )
sqDist = quadrance @( Vector2D Double ) c ( offset • s ) ( adjustSplineType @Open spline )
= if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
then do where
put ( Just txt ) updateCurve
-- TODO: interpolate brush instead of using these arbitrary intermediate points :: Text
pure ( sp0 :<| sp0 { coords = s } :<| sp1 :<| sps ) -> Vector2D Double
else ( sp0 :<| ) <$> go sp1 sps -> PointData brushParams
-- Quadratic Bézier curve. -> Curve Open CachedStroke ( PointData brushParams )
go sp0 ( sp1 :<| sp2 :<| sps ) -> State ( Maybe Text )
| ControlPoint {} <- sp1 ( Seq ( Curve Open CachedStroke ( PointData brushParams ) ) )
, PathPoint {} <- sp2 updateCurve txt offset sp0 curve = case curve of
, let line@( LineTo ( NextPoint sp1 ) dat ) ->
p0, p1, p2, s :: Point2D Double let
p0 = coords sp0 p0, p1, s :: Point2D Double
p1 = coords sp1 t :: Double
p2 = coords sp2 p0 = coords sp0
bez :: Quadratic.Bezier ( Point2D Double ) p1 = coords sp1
bez = Quadratic.Bezier {..} ( t, s ) = closestPointOnSegment @( Vector2D Double ) ( invert offset • c ) ( Segment p0 p1 )
sqDist :: Double sqDist :: Double
Min ( Arg sqDist ( t, s ) ) sqDist = quadrance @( Vector2D Double ) c ( offset • s )
= Quadratic.closestPoint @( Vector2D Double ) bez ( invert offset • c ) in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
= if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 then
then case Quadratic.subdivide @( Vector2D Double ) bez t of let
( Quadratic.Bezier _ q1 _, Quadratic.Bezier _ r1 _ ) -> do subdiv :: PointData brushParams
put ( Just txt ) subdiv = lerp @( DiffPointData ( Diff brushParams ) ) t sp0 sp1
-- TODO: interpolate brush instead of using these arbitrary intermediate points dat' :: CachedStroke
pure ( sp0 :<| sp1 { coords = q1 } :<| sp2 { coords = s } :<| sp1 { coords = r1 } :<| sp2 :<| sps ) dat' = discardCache dat
else ( ( sp0 :<| ) . ( sp1 :<| ) ) <$> go sp2 sps in put ( Just txt ) $> ( LineTo ( NextPoint subdiv ) dat' :<| LineTo ( NextPoint sp1 ) dat' :<| Empty )
-- Cubic Bézier curve. else pure $ Seq.singleton line
go sp0 ( sp1 :<| sp2 :<| sp3 :<| sps ) bez2@( Bezier2To sp1 ( NextPoint sp2 ) dat ) ->
| ControlPoint {} <- sp1 let
, ControlPoint {} <- sp2 p0, p1, p2 :: Point2D Double
, PathPoint {} <- sp3 p0 = coords sp0
, let p1 = coords sp1
p0, p1, p2, p3, s :: Point2D Double p2 = coords sp2
p0 = coords sp0 sqDist :: Double
p1 = coords sp1 Min ( Arg sqDist ( t, _ ) )
p2 = coords sp2 = Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier {..} ) ( invert offset • c )
p3 = coords sp3 in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
bez :: Cubic.Bezier ( Point2D Double ) then case Quadratic.subdivide @( DiffPointData ( Diff brushParams ) ) ( Quadratic.Bezier sp0 sp1 sp2 ) t of
bez = Cubic.Bezier {..} ( Quadratic.Bezier _ q1 subdiv, Quadratic.Bezier _ r1 _ ) ->
Min ( Arg sqDist ( t, s ) ) let
= Cubic.closestPoint @( Vector2D Double ) bez ( invert offset • c ) dat' :: CachedStroke
= if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 dat' = discardCache dat
then case Cubic.subdivide @( Vector2D Double ) bez t of bez_start, bez_end :: Curve Open CachedStroke ( PointData brushParams )
( Cubic.Bezier _ q1 q2 _, Cubic.Bezier _ r1 r2 _ ) -> do bez_start = Bezier2To q1 ( NextPoint subdiv ) dat'
put ( Just txt ) bez_end = Bezier2To r1 ( NextPoint sp2 ) dat'
-- TODO: interpolate brush instead of using these arbitrary intermediate points in put ( Just txt ) $> ( bez_start :<| bez_end :<| Empty )
pure else pure $ Seq.singleton bez2
( sp0 :<| sp1 { coords = q1 } :<| sp1 { coords = q2 } :<| sp3 { coords = s } bez3@( Bezier3To sp1 sp2 ( NextPoint sp3 ) dat ) ->
:<| sp2 { coords = r1 } :<| sp2 { coords = r2 } :<| sp3 :<| sps let
) p0, p1, p2, p3 :: Point2D Double
else ( ( sp0 :<| ) . ( sp1 :<| ) . ( sp2 :<| ) ) <$> go sp3 sps p0 = coords sp0
go sp0 sps = error ( "subdivideStroke: unrecognised stroke type\n" <> show ( sp0 :<| sps ) ) p1 = coords sp1
p2 = coords sp2
p3 = coords sp3
Min ( Arg sqDist ( t, _ ) )
= Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier {..} ) ( invert offset • c )
in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16
then case Cubic.subdivide @( DiffPointData ( Diff brushParams ) ) ( Cubic.Bezier sp0 sp1 sp2 sp3 ) t of
( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) ->
let
dat' :: CachedStroke
dat' = discardCache dat
bez_start, bez_end :: Curve Open CachedStroke ( PointData brushParams )
bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) dat'
bez_end = Bezier3To r1 r2 ( NextPoint sp2 ) dat'
in put ( Just txt ) $> ( bez_start :<| bez_end :<| Empty )
else pure $ Seq.singleton bez3

2
src/app/MetaBrush/Document/Update.hs
View file

@ -145,7 +145,7 @@ instance DocumentModification DocModification where
-- --
-- Does nothing if no document is currently active. -- Does nothing if no document is currently active.
modifyingCurrentDocument :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO () modifyingCurrentDocument :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO ()
modifyingCurrentDocument uiElts@( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) f = do modifyingCurrentDocument uiElts@( UIElements { .. } ) vars@( Variables {..} ) f = do
mbAction <- STM.atomically . runMaybeT $ do mbAction <- STM.atomically . runMaybeT $ do
unique <- MaybeT ( STM.readTVar activeDocumentTVar ) unique <- MaybeT ( STM.readTVar activeDocumentTVar )
oldDoc <- MaybeT ( fmap present . Map.lookup unique <$> STM.readTVar openDocumentsTVar ) oldDoc <- MaybeT ( fmap present . Map.lookup unique <$> STM.readTVar openDocumentsTVar )

2
src/app/MetaBrush/Event.hs
View file

@ -109,7 +109,7 @@ handleMouseButtonRelease elts vars eventOrigin mouseReleaseEvent = do
adjustMousePosition :: Viewport -> ActionOrigin -> Point2D Double -> IO ( Point2D Double ) adjustMousePosition :: Viewport -> ActionOrigin -> Point2D Double -> IO ( Point2D Double )
adjustMousePosition _ ViewportOrigin pt = pure pt adjustMousePosition _ ViewportOrigin pt = pure pt
adjustMousePosition ( Viewport { .. } ) ( RulerOrigin ruler ) ( Point2D x y ) = adjustMousePosition ( Viewport {..} ) ( RulerOrigin ruler ) ( Point2D x y ) =
case ruler of case ruler of
RulerCorner -> do RulerCorner -> do
dx <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth rulerCornerDrawingArea dx <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth rulerCornerDrawingArea

625
src/app/MetaBrush/MetaParameter/AST.hs Normal file
View file

@ -0,0 +1,625 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
module MetaBrush.MetaParameter.AST
( Span(..), Located(.., Location)
, Term(..), Pat(..), Decl(..)
, toTreeArgsTerm, toTreeTerm, toTreePat, toTreeDecl
, termSpan
, TypedTerm(..), TypedPat(..)
, SType(..), STypeI(..), SomeSType(..)
, STypes(..), STypesI(..), someSTypes
, eqSTy, eqTy, eqSTys, eqTys
, Pass(..), Name, UniqueName(..), Loc
, Ext_With(..), X_With(..)
, MapFields, IsUniqueTerm, IsUniqueTerm2, UseFieldsInBrush
, UniqueField(..), GetUniqueField, UniqueTerm, GetUniqueTerm
, Adapted, AdaptableFunction(..), BrushFunction
, X_Ext(..)
, Expr, EPat, RnExpr, RnPat
)
where
-- base
import Data.Functor.Compose
( Compose(..) )
import Data.Functor.Identity
( Identity(..) )
import Data.Kind
( Type, Constraint )
import Data.Proxy
( Proxy(..) )
import Data.Type.Equality
( (:~:)(Refl) )
import GHC.Exts
( Proxy#, proxy# )
import GHC.Generics
( Generic )
import GHC.TypeLits
( Symbol, KnownSymbol, symbolVal', sameSymbol )
import GHC.TypeNats
( KnownNat )
-- containers
import Data.Tree
( Tree(Node) )
-- deepseq
import Control.DeepSeq
( NFData(..) )
-- superrecord
import qualified SuperRecord as Super
( Rec )
import qualified SuperRecord
( (:=), RecApply, UnsafeRecBuild, Has, TraversalC
, Intersect, Lookup, RecTy, RecSize, reflectRec
)
-- text
import Data.Text
( Text )
import qualified Data.Text as Text
( pack )
-- MetaBrush
import Math.Vector2D
( Point2D(..), Segment(..) )
import qualified Math.Bezier.Cubic as Cubic
( Bezier(..) )
import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..) )
import Math.Bezier.Spline
( Spline(..), SplinePts, SplineType(..)
, SSplineType(..), SplineTypeI(ssplineType), KnownSplineType(bifoldSpline)
, Curve(..), NextPoint(..)
)
import MetaBrush.Unique
( Unique )
--------------------------------------------------------------------------------
---------------------
-- Source locations.
data Span = Span
{ startRow :: !Int
, startCol :: !Int
, endRow :: !Int
, endCol :: !Int
} deriving stock ( Eq, Ord )
instance Show Span where
show ( Span sr sc er ec ) =
"l" <> show sr <> "c" <> show sc <> " -- " <> "l" <> show er <> "c" <> show ec
instance Semigroup Span where
Span 0 0 0 0 <> s = s
s <> Span 0 0 0 0 = s
Span sr1 sc1 er1 ec1 <> Span sr2 sc2 er2 ec2
= case ( compare ( sr1, sc1 ) ( sr2, sc2 ), compare ( er1, ec1 ) ( er2, ec2 ) ) of
( LT, LT ) -> Span sr1 sc1 er2 ec2
( LT, _ ) -> Span sr1 sc1 er1 ec1
( _ , LT ) -> Span sr2 sc2 er2 ec2
_ -> Span sr2 sc2 er1 ec1
instance Monoid Span where
mempty = Span 0 0 0 0
data Located a =
Located
{ location :: !Span
, located :: !a
}
deriving stock Show
{-# COMPLETE Location #-}
pattern Location :: Span -> Located ()
pattern Location loc = Located loc ()
----------
-- Types.
data SType ( ty :: Type ) where
SFunTy :: ( STypeI a, STypeI b ) => SType ( a -> b )
STyBool :: SType Bool
STyDouble :: SType Double
STyPoint :: STypeI a => SType ( Point2D a )
STyLine :: STypeI a => SType ( Segment a )
STyBez2 :: STypeI a => SType ( Quadratic.Bezier a )
STyBez3 :: STypeI a => SType ( Cubic.Bezier a )
STySpline :: KnownSplineType clo => SType ( SplinePts clo )
STyWithFn :: ( STypesI kvs, STypeI a ) => SType ( AdaptableFunction kvs a )
-- reminder: update eqSTy when adding new constructors
deriving stock instance Show ( SType ty )
class STypeI ty where
sTypeI :: SType ty
instance ( STypeI a, STypeI b ) => STypeI ( a -> b ) where
sTypeI = SFunTy
instance STypeI Bool where
sTypeI = STyBool
instance STypeI Double where
sTypeI = STyDouble
instance STypeI a => STypeI ( Point2D a ) where
sTypeI = STyPoint
instance STypeI a => STypeI ( Segment a ) where
sTypeI = STyLine
instance STypeI a => STypeI ( Quadratic.Bezier a ) where
sTypeI = STyBez2
instance STypeI a => STypeI ( Cubic.Bezier a ) where
sTypeI = STyBez3
instance KnownSplineType clo => STypeI ( SplinePts clo ) where
sTypeI = STySpline
instance ( STypesI kvs, STypeI a ) => STypeI ( AdaptableFunction kvs a ) where
sTypeI = STyWithFn
data STypes ( kvs :: [ Type ] ) where
STyNil :: STypes '[]
STyCons :: ( kv ~ ( k SuperRecord.:= v ), KnownSymbol k, STypeI v, STypesI kvs ) => STypes ( kv ': kvs )
deriving stock instance Show ( STypes kvs )
class KnownNat ( SuperRecord.RecSize kvs ) => STypesI kvs where
sTypesI :: STypes kvs
instance STypesI '[] where
sTypesI = STyNil
-- Warning: this instance is somewhat overly general as it doesn't check that the names are ordered.
instance ( kv ~ ( k SuperRecord.:= v ), KnownSymbol k, STypeI v, STypesI kvs ) => STypesI ( kv ': kvs ) where
sTypesI = STyCons
data SomeSType where
SomeSType :: STypeI a => Proxy# a -> SomeSType
instance Show SomeSType where
show ( SomeSType ( _ :: Proxy# a ) ) = show ( sTypeI @a )
eqSTy :: SType a -> SType b -> Maybe ( a :~: b )
eqSTy sTy_a@SFunTy sTy_b@SFunTy
| ( _ :: SType ( a1 -> b1 ) ) <- sTy_a
, ( _ :: SType ( a2 -> b2 ) ) <- sTy_b
, Just Refl <- eqTy @a1 @a2
, Just Refl <- eqTy @b1 @b2
= Just Refl
eqSTy STyBool STyBool = Just Refl
eqSTy STyDouble STyDouble = Just Refl
eqSTy sTy_a@STyPoint sTy_b@STyPoint
| ( _ :: SType ( Point2D l ) ) <- sTy_a
, ( _ :: SType ( Point2D r ) ) <- sTy_b
, Just Refl <- eqTy @l @r
= Just Refl
eqSTy sTy_a@STyLine sTy_b@STyLine
| ( _ :: SType ( Segment l ) ) <- sTy_a
, ( _ :: SType ( Segment r ) ) <- sTy_b
, Just Refl <- eqTy @l @r
= Just Refl
eqSTy sTy_a@STyBez2 sTy_b@STyBez2
| ( _ :: SType ( Quadratic.Bezier l ) ) <- sTy_a
, ( _ :: SType ( Quadratic.Bezier r ) ) <- sTy_b
, Just Refl <- eqTy @l @r
= Just Refl
eqSTy sTy_a@STyBez3 sTy_b@STyBez3
| ( _ :: SType ( Cubic.Bezier l ) ) <- sTy_a
, ( _ :: SType ( Cubic.Bezier r ) ) <- sTy_b
, Just Refl <- eqTy @l @r
= Just Refl
eqSTy sTy_a@STySpline sTy_b@STySpline
| ( _ :: SType ( SplinePts clo1 ) ) <- sTy_a
, ( _ :: SType ( SplinePts clo2 ) ) <- sTy_b
= case ( ssplineType @clo1, ssplineType @clo2 ) of
( SOpen , SOpen ) -> Just Refl
( SClosed, SClosed ) -> Just Refl
_ -> Nothing
eqSTy sTy_a@STyWithFn sTy_b@STyWithFn
| ( _ :: SType ( AdaptableFunction kvs a ) ) <- sTy_a
, ( _ :: SType ( AdaptableFunction lvs b ) ) <- sTy_b
, Just Refl <- eqTys @kvs @lvs
, Just Refl <- eqTy @a @b
= Just Refl
eqSTy _ _ = Nothing
eqTy :: forall a b. ( STypeI a, STypeI b ) => Maybe ( a :~: b )
eqTy = eqSTy ( sTypeI @a ) ( sTypeI @b )
eqSTys :: STypes as -> STypes bs -> Maybe ( as :~: bs )
eqSTys STyNil STyNil = Just Refl
eqSTys sTyCons1@STyCons sTyCons2@STyCons
| ( _ :: STypes ( ( l1 SuperRecord.:= v1 ) ': as' ) ) <- sTyCons1
, ( _ :: STypes ( ( l2 SuperRecord.:= v2 ) ': bs' ) ) <- sTyCons2
, Just Refl <- sameSymbol ( Proxy :: Proxy l1 ) ( Proxy :: Proxy l2 )
, Just Refl <- eqTy @v1 @v2
, Just Refl <- eqTys @as' @bs'
= Just Refl
eqSTys _ _ = Nothing
eqTys :: forall as bs. ( STypesI as, STypesI bs ) => Maybe ( as :~: bs )
eqTys = eqSTys ( sTypesI @as ) ( sTypesI @bs )
someSTypes :: forall kvs. STypesI kvs => [ ( Text, SomeSType ) ]
someSTypes = go ( sTypesI @kvs )
where
go :: forall lvs. STypes lvs -> [ ( Text, SomeSType ) ]
go STyNil = []
go sTyCons@STyCons
| ( _ :: STypes ( ( l SuperRecord.:= v ) ': lvs' ) ) <- sTyCons
= ( Text.pack $ symbolVal' ( proxy# :: Proxy# l ), SomeSType ( proxy# :: Proxy# v ) )
: go ( sTypesI @lvs' )
------------------------------------------------
-- AST. --
----------
data Pass = P | Rn | Tc
deriving stock Show
type family K ( p :: Pass ) :: Type where
K P = ()
K Rn = ()
K Tc = Type
type family Ks ( p :: Pass ) :: Type where
Ks P = ()
Ks Rn = ()
Ks Tc = [Type]
type family T ( p :: Pass ) ( t :: Type ) :: K p where
T P _ = '()
T Rn _ = '()
T Tc a = a
type family Ts ( p :: Pass ) ( as :: [ Type ] ) :: Ks p where
Ts P _ = '()
Ts Rn _ = '()
Ts Tc '[] = '[]
Ts Tc ( a ': as ) = T Tc a ': Ts Tc as
type family R ( p :: Pass ) ( kvs :: [ Type ] ) :: Ks p where
R P _ = '()
R Rn _ = '()
R Tc kvs = kvs
type family C ( p :: Pass ) ( ct :: Constraint ) :: Constraint where
C P _ = ()
C Rn _ = ()
C Tc ct = ct
-- C p ct: constraint for which evidence is generated at Tc stage
-- ct: constraint for which evidence is provided from the start
infixl 9 :$
data Term ( p :: Pass ) ( kind :: K p ) where
(:$) :: C p ( STypeI a )
=> Term p ( T p ( a -> b ) )
-> Term p ( T p a )
-> Term p ( T p b )
Var :: { varName :: !( Loc p ( Name p ) ) }
-> Term p ( T p a )
Let :: { let_loc :: ![ Loc p () ]
, let_decls :: ![ Decl p ]
, let_body :: !( Term p ( T p a ) )
}
-> Term p ( T p a )
With :: forall ( p :: Pass ) ( kvs :: [ Type ] ) ( a :: Type )
. C p ( STypeI a )
=> ![ Loc p () ]
-> !( X_With p ( R p kvs ) )
-> ![ Term p ( T p Bool ) ]
-> !( Term p ( T p a ) )
-> Term p ( T p ( AdaptableFunction kvs a ) )
Lit :: ( Show a, STypeI a )
=> !( Loc p ( Maybe Text ) )
-> !a
-> Term p ( T p a )
Op :: STypeI a
=> ![ Loc p () ] -> !Text -> a -> Term p ( T p a )
Point :: ( C p ( STypeI a ), pt ~ Term p ( T p ( Point2D a ) ) )
=> ![ Loc p () ]
-> !( Term p ( T p a ) ) -> !( Term p ( T p a ) )
-> Term p ( T p ( Point2D a ) )
Line :: ( C p ( STypeI a ), pt ~ Term p ( T p a ) )
=> ![ Loc p () ]
-> !pt -> !pt
-> Term p ( T p ( Segment a ) )
Bez2 :: ( C p ( STypeI a ), pt ~ Term p ( T p a ) )
=> ![ Loc p () ]
-> !pt -> !pt -> !pt
-> Term p ( T p ( Quadratic.Bezier a ) )
Bez3 :: ( C p ( STypeI a ), pt ~ Term p ( T p a ) )
=> ![ Loc p () ]
-> !pt -> !pt -> !pt -> !pt
-> Term p ( T p ( Cubic.Bezier a ) )
PolyBez
:: ( KnownSplineType clo, C p ( STypeI a ) )
=> ![ Loc p () ]
-> Spline clo [ Loc p () ] ( Term p ( T p a ) )
-> Term p ( T p ( Spline clo () a ) )
CExt :: !( X_Ext p ( T p a ) ) -> Term p ( T p a )
data Decl ( p :: Pass ) where
Decl :: C p ( STypeI a )
=> !( Loc p () )
-> !( Pat p ( T p a ) ) -> !( Term p ( T p a ) )
-> Decl p
data Pat ( p :: Pass ) ( kind :: K p ) where
PName :: { patName :: !( Loc p ( Name p ) ) }
-> Pat p ( T p a )
PPoint :: ![ Loc p () ]
-> !( Pat p ( T p a ) )
-> !( Pat p ( T p a ) )
-> Pat p ( T p ( Point2D a ) )
PWild :: { wildName :: !( Loc p Text ) }
-> Pat p ( T p a )
AsPat :: { atSymbol :: !( Loc p () )
, asPatName :: !( Loc p ( Name p ) )
, asPat :: !( Pat p ( T p a ) )
}
-> Pat p ( T p a )
type Expr = Term P '()
type EPat = Pat P '()
type RnExpr = Term Rn '()
type RnPat = Pat Rn '()
data TypedTerm where
TypedTerm :: STypeI a => Term Tc a -> TypedTerm
data TypedPat where
TypedPat :: STypeI a => Pat Tc a -> TypedPat
---------------------
-- Extension fields
data UniqueName
= UniqueName
{ occName :: !Text
, nameUnique :: !Unique
}
deriving stock ( Show, Generic )
type family Name ( p :: Pass ) :: Type
type instance Name P = Text
type instance Name Rn = UniqueName
type instance Name Tc = UniqueName
type family Loc ( p :: Pass ) ( a :: Type ) :: Type
type instance Loc p a = Located a
class Ext_With ( p :: Pass ) ( kvs :: Ks p ) where
data family X_With p kvs :: Type
toTreeWith :: forall ( lvs :: Ks p ). Ext_With p lvs => X_With p kvs -> [ Tree String ]
instance Ext_With P kvs where
newtype X_With P _ = P_With [ Decl P ]
toTreeWith ( P_With decls ) = map toTreeDecl decls
instance Ext_With Rn kvs where
newtype X_With Rn _ = Rn_With [ Decl Rn ]
toTreeWith ( Rn_With decls ) = map toTreeDecl decls
instance Ext_With Tc kvs where
data X_With Tc kvs where
Tc_With
:: ( ts ~ MapFields UniqueTerm kvs
, fs ~ MapFields UniqueField kvs
, SuperRecord.RecApply ts ts IsUniqueTerm
, SuperRecord.TraversalC IsUniqueTerm2 ts fs
)
=> Super.Rec ts -> X_With Tc kvs
toTreeWith ( Tc_With decls ) =
SuperRecord.reflectRec @IsUniqueTerm
( \ _ ( Compose ( UniqueField { uniqueField = a } ) ) -> toTreeTerm @Tc a )
decls
data UniqueField a =
UniqueField { uniqueFieldName :: !UniqueName, uniqueField :: !a }
type UniqueTerm = Compose UniqueField ( Term Tc )
type family MapFields ( f :: Type -> Type ) ( kvs :: [ Type ] ) = ( r :: [ Type ] ) | r -> kvs where
MapFields _ '[] = '[]
MapFields f ( ( k SuperRecord.:= v ) ': kvs ) = ( k SuperRecord.:= f v ) ': MapFields f kvs
type family GetUniqueField ( uniqueField :: Type ) :: Type where
GetUniqueField ( UniqueField a ) = a
type family GetUniqueTerm ( uniqueTerm :: Type ) :: Type where
GetUniqueTerm ( Compose UniqueField ( Term Tc ) a ) = a
class ( STypeI ( GetUniqueTerm t )
, t ~ UniqueTerm ( GetUniqueTerm t )
)
=> IsUniqueTerm ( k :: Symbol ) t
where
instance ( STypeI ( GetUniqueTerm t )
, t ~ UniqueTerm ( GetUniqueTerm t )
)
=> IsUniqueTerm ( k :: Symbol ) t
where
class ( IsUniqueTerm k t
, a ~ UniqueField ( GetUniqueField a )
, GetUniqueTerm t ~ GetUniqueField a
)
=> IsUniqueTerm2 k t a
where
instance ( IsUniqueTerm k t
, a ~ UniqueField ( GetUniqueField a )
, GetUniqueTerm t ~ GetUniqueField a
)
=> IsUniqueTerm2 k t a
where
class ( STypeI ( GetUniqueField t )
, t ~ UniqueField ( GetUniqueField t )
, SuperRecord.Lookup kvs k ( GetUniqueField t )
( SuperRecord.RecTy k kvs )
)
=> UseFieldsInBrush ( kvs :: [ Type ] ) ( k :: Symbol ) t
instance ( STypeI ( GetUniqueField t )
, t ~ UniqueField ( GetUniqueField t )
, SuperRecord.Lookup kvs k ( GetUniqueField t )
( SuperRecord.RecTy k kvs )
)
=> UseFieldsInBrush ( kvs :: [ Type ] ) ( k :: Symbol ) t
class ( usedFields ~ ( brushFields `SuperRecord.Intersect` givenFields )
, SuperRecord.UnsafeRecBuild usedFields usedFields ( SuperRecord.Has givenFields )
, SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField brushFields )
( UseFieldsInBrush usedFields )
)
=> Adapted brushFields givenFields usedFields | givenFields brushFields -> usedFields
instance ( usedFields ~ ( brushFields `SuperRecord.Intersect` givenFields )
, SuperRecord.UnsafeRecBuild usedFields usedFields ( SuperRecord.Has givenFields )
, SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField brushFields )
( UseFieldsInBrush usedFields )
)
=> Adapted brushFields givenFields usedFields
type BrushFunction brushFields = AdaptableFunction brushFields ( SplinePts Closed )
newtype AdaptableFunction brushFields a
= AdaptableFunction
( forall givenFields usedFields
. Adapted brushFields givenFields usedFields
=> ( Super.Rec givenFields -> Super.Rec usedFields
, Super.Rec usedFields -> a
)
)
class Ext ( p :: Pass ) ( a :: K p ) where
data family X_Ext ( p :: Pass ) a :: Type
toTreeArgsExt :: [ Tree String ] -> X_Ext p a -> Tree String
instance Ext P a where
data instance X_Ext P a
toTreeArgsExt _ x = case x of {}
instance Ext Rn a where
data instance X_Ext Rn a
toTreeArgsExt _ x = case x of {}
instance Ext Tc a where
newtype instance X_Ext Tc a = Val a
deriving stock ( Generic, Show )
deriving newtype NFData
toTreeArgsExt as ( Val _ ) = Node "Value..." as
------------------------------------------------
-- Printing AST. --
-------------------
termSpan :: Term p a -> Span
termSpan ( f :$ a ) = termSpan f <> termSpan a
termSpan ( Var ( Located l _ ) ) = l
termSpan ( Let locs _ body ) = foldMap ( \ ( Located l _ ) -> l ) locs <> termSpan body
termSpan ( With locs _ _ body ) = foldMap ( \ ( Located l _ ) -> l ) locs <> termSpan body
termSpan ( Lit ( Located l _ ) _ ) = l
termSpan ( Op locs _ _ ) = foldMap ( \ ( Located l _ ) -> l ) locs
termSpan ( Point locs x y ) = foldMap ( \ ( Located l _ ) -> l ) locs <> termSpan x <> termSpan y
termSpan ( Line locs _ _ ) = foldMap ( \ ( Located l _ ) -> l ) locs
termSpan ( Bez2 locs _ _ _ ) = foldMap ( \ ( Located l _ ) -> l ) locs
termSpan ( Bez3 locs _ _ _ _ ) = foldMap ( \ ( Located l _ ) -> l ) locs
termSpan ( PolyBez locs _ ) = foldMap ( \ ( Located l _ ) -> l ) locs
termSpan ( CExt _ ) = mempty
toTreeTerm
:: forall ( p :: Pass ) ( a :: K p )
. ( Show ( Name p ), forall x. Ext p x, forall kvs. Ext_With p kvs )
=> Term p a
-> Tree String
toTreeTerm = toTreeArgsTerm @p @a []
toTreeArgsTerm
:: forall ( p :: Pass ) ( a :: K p )
. ( Show ( Name p ), forall x. Ext p x, forall (kvs :: Ks p). Ext_With p kvs )
=> [ Tree String ]
-> Term p a
-> Tree String
toTreeArgsTerm as ( f :$ a ) = toTreeArgsTerm ( toTreeTerm a : as ) f
toTreeArgsTerm as ( Op _ nm _ ) = Node ( "Op " <> show nm ) as
toTreeArgsTerm as ( Var nm ) = Node ( "Var " <> show nm ) as
toTreeArgsTerm as ( Lit loc a ) =
case loc of
Located l Nothing -> Node ( "Lit " <> show ( Located l a ) ) as
Located l ( Just nm ) -> Node ( "Lit " <> show ( Located l nm ) ) as
toTreeArgsTerm as ( Point _ p1 p2 ) = Node "(,)" ( toTreeTerm p1 : toTreeTerm p2 : as )
toTreeArgsTerm as ( Line _ p0 p1 ) = Node "Line" ( toTreeTerm p0 : toTreeTerm p1 : as )
toTreeArgsTerm as ( Bez2 _ p0 p1 p2 ) = Node "Bez2" ( toTreeTerm p0 : toTreeTerm p1 : toTreeTerm p2 : as )
toTreeArgsTerm as ( Bez3 _ p0 p1 p2 p3 ) = Node "Bez3" ( toTreeTerm p0 : toTreeTerm p1 : toTreeTerm p2 : toTreeTerm p3 : as )
toTreeArgsTerm as ( PolyBez _ spline ) = Node "Spline"
( ( runIdentity
$ ( bifoldSpline @_ @Identity @[ Tree String ] @_ )
( const ( toTreeCurve @p ) )
( Identity . (:[]) . toTreeTerm )
spline
)
<> as
)
toTreeArgsTerm as ( Let _ ds a ) =
Node "Let"
( Node "Decls" ( map ( toTreeDecl @p ) ds )
: Node "In" [ toTreeTerm a ]
: as
)
toTreeArgsTerm as ( With _ args conds body ) =
Node "With"
( Node "Params" ( toTreeWith @p args )
: Node "Conds" ( map toTreeTerm conds )
: Node "Define" [ toTreeTerm body ]
: as
)
toTreeArgsTerm as ( CExt ext ) = toTreeArgsExt as ext
toTreeDecl
:: forall ( p :: Pass )
. ( Show ( Name p ), forall x. Ext p x, forall (kvs :: Ks p). Ext_With p kvs )
=> Decl p
-> Tree String
toTreeDecl ( Decl _ lhs rhs ) = Node "(=)" [ toTreePat lhs, toTreeTerm rhs ]
toTreePat :: Show ( Name p ) => Pat p a -> Tree String
toTreePat ( PName nm ) = Node ( show nm ) [ ]
toTreePat ( PPoint _ pl pr ) = Node "(_,_)" [ toTreePat pl, toTreePat pr ]
toTreePat ( PWild nm ) = Node ( show nm ) [ ]
toTreePat ( AsPat _ nm pat ) = Node "(@)" [ Node ( show nm ) [], toTreePat pat ]
toTreeCurve
:: forall ( p :: Pass ) ( clo :: SplineType ) ( crvData :: Type ) ( a :: K p )
. ( SplineTypeI clo, Show ( Name p ), forall x. Ext p x, forall (kvs :: Ks p). Ext_With p kvs )
=> Curve clo crvData ( Term p a )
-> Identity [ Tree String ]
toTreeCurve curve = Identity . (:[]) $ case ssplineType @clo of
SOpen -> case curve of
( LineTo ( NextPoint p1 ) _ ) -> Node "LineTo" [ toTreeTerm p1 ]
( Bezier2To p1 ( NextPoint p2 ) _ ) -> Node "Bezier2To" [ toTreeTerm p1, toTreeTerm p2 ]
( Bezier3To p1 p2 ( NextPoint p3 ) _ ) -> Node "Bezier3To" [ toTreeTerm p1, toTreeTerm p2, toTreeTerm p3 ]
SClosed -> case curve of
( LineTo BackToStart _ ) -> Node "LineTo" [ Node "cycle" [] ]
( Bezier2To p1 BackToStart _ ) -> Node "Bezier2To" [ toTreeTerm p1, Node "cycle" [] ]
( Bezier3To p1 p2 BackToStart _ ) -> Node "Bezier3To" [ toTreeTerm p1, toTreeTerm p2, Node "cycle" [] ]

116
src/app/MetaBrush/MetaParameter/Driver.hs Normal file
View file

@ -0,0 +1,116 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.MetaParameter.Driver where
-- base
import GHC.Exts
( Proxy#, proxy# )
-- dlist
import qualified Data.DList as DList
( toList )
-- Earley
import qualified Text.Earley as Earley
( Report(..), fullParses, parser )
-- text
import Data.Text
( Text )
-- transformers
import Control.Monad.Trans.Except
( runExceptT )
import Control.Monad.Trans.Reader
( runReaderT )
import Control.Monad.Trans.RWS.CPS
( runRWST )
import Control.Monad.Trans.State.Strict
( evalState )
-- MetaBrush
import Math.Bezier.Spline
( SplinePts, SSplineType(SClosed), SplineTypeI(ssplineType) )
import MetaBrush.MetaParameter.AST
( Located
, Term, TypedTerm(..)
, SType(..), STypeI(sTypeI)
, SomeSType(..), STypesI
, Pass(Tc)
, AdaptableFunction(..), BrushFunction
)
import MetaBrush.MetaParameter.Eval
( EvalState(..), eval )
import MetaBrush.MetaParameter.Parse
( grammar, Token, tokenize )
import MetaBrush.MetaParameter.Rename
( rename, RnM, RnMessage, RnError, emptyRnState )
import MetaBrush.MetaParameter.TypeCheck
( typeCheck, TcM, TcMessage, TcError, emptyTcState )
import MetaBrush.Unique
( UniqueSupply, MonadUnique(freshUnique) )
--------------------------------------------------------------------------------
data DriverError
= ParseError !( Earley.Report Text [ Located Token ] )
| RenameError !RnError
| TypeCheckError !TcError
| NonBrushType !SomeSType
deriving stock Show
data DriverMessage
= RenameMessage !RnMessage
| TypeCheckMessage !TcMessage
data SomeBrushFunction where
SomeBrushFunction
:: forall brushParams
. ( STypesI brushParams )
=> BrushFunction brushParams
-> SomeBrushFunction
interpretBrush
:: UniqueSupply
-> Text
-> IO
( Either DriverError SomeBrushFunction
, [ DriverMessage ]
)
interpretBrush uniqSupply sourceText = case Earley.fullParses ( Earley.parser grammar ) $ tokenize sourceText of
( [], parserReport ) -> pure ( Left ( ParseError parserReport ), [] )
( parsedExpr : _, _ ) -> do
( renamedExpr, _, rnMessages ) <- runRWST ( rename @RnM parsedExpr ) uniqSupply emptyRnState
( tcResult , _, tcMessages ) <- runRWST ( runExceptT $ typeCheck @TcM renamedExpr ) uniqSupply emptyTcState
let
messages :: [ DriverMessage ]
messages = DList.toList ( fmap RenameMessage rnMessages <> fmap TypeCheckMessage tcMessages )
case tcResult of
Left err -> pure ( Left ( TypeCheckError err ), messages )
-- Type checking succeeded: check that the type of the given program
-- is indeed a function that takes in a record of parameters and returns
-- a closed brush shape.
Right ( TypedTerm ( term :: Term Tc v ) )
| sTyWithFn@STyWithFn <- sTypeI @v
, ( _ :: SType ( AdaptableFunction kvs b ) ) <- sTyWithFn
, sTySpline@STySpline <- sTypeI @b
, ( _ :: SType ( SplinePts clo ) ) <- sTySpline
, SClosed <- ssplineType @clo
-> do
uniq <- ( `runReaderT` uniqSupply ) freshUnique
let
initEvalState :: EvalState
initEvalState =
EvalState { evalHeap = mempty, nextUnique = uniq }
val :: BrushFunction kvs
val = ( `evalState` initEvalState ) $ eval term
pure ( Right ( SomeBrushFunction @kvs val ), messages )
| otherwise
-> pure ( Left ( NonBrushType ( SomeSType ( proxy# :: Proxy# v ) ) ), messages )

234
src/app/MetaBrush/MetaParameter/Eval.hs Normal file
View file

@ -0,0 +1,234 @@
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module MetaBrush.MetaParameter.Eval
( EvalState(..), eval )
where
-- base
import Data.Foldable
( for_ )
import Data.Functor.Compose
( Compose(..) )
import Data.Type.Equality
( (:~:)(Refl) )
import GHC.Generics
( Generic )
-- containers
import Data.Map
( Map )
import qualified Data.Map.Strict as Map
( insert, lookup, union, fromList )
-- generic-lens
import Data.Generics.Product.Fields
( field' )
-- lens
import Control.Lens
( assign, modifying, use )
-- mtl
import Control.Monad.State
( get )
-- superrecord
import qualified SuperRecord as Super
( Rec )
import qualified SuperRecord
( RecApply(..), Lookup(..), Has, UnsafeRecBuild, traverseC, project )
-- text
import Data.Text
( Text )
import qualified Data.Text as Text
( pack )
-- transformers
import Control.Monad.Trans.State.Strict
( State, evalState )
-- MetaBrush
import qualified Math.Bezier.Cubic as Cubic
( Bezier(..) )
import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..) )
import Math.Bezier.Spline
( KnownSplineType(bitraverseSpline), bitraverseCurve )
import Math.Vector2D
( Point2D(..), Segment(..) )
import MetaBrush.MetaParameter.AST
( Term(..), Pat(..), Decl(..)
, TypedTerm(..), STypeI(..), SType(..)
, Pass(Tc), X_Ext(..), X_With(..)
, Span(..), Located(..)
, MapFields, AdaptableFunction(..)
, UniqueField(..), UniqueTerm, IsUniqueTerm2, UseFieldsInBrush
, eqTy
)
import MetaBrush.MetaParameter.Rename
( UniqueName(..) )
import MetaBrush.Unique
( Unique )
--------------------------------------------------------------------------------
data EvalState
= EvalState
{ evalHeap :: !( Map Unique TypedTerm )
, nextUnique :: !Unique
}
deriving stock Generic
eval :: forall a. STypeI a => Term Tc a -> State EvalState a
eval ( f :$ a ) = eval f <*> eval a
eval ( Lit _ x ) = pure x
eval ( Op _ _ f ) = pure f
eval ( Point _ x y ) = Point2D <$> eval x <*> eval y
eval ( Line _ p q ) = Segment <$> eval p <*> eval q
eval ( Bez2 _ p q r ) = Quadratic.Bezier <$> eval p <*> eval q <*> eval r
eval ( Bez3 _ p q r s ) = Cubic.Bezier <$> eval p <*> eval q <*> eval r <*> eval s
eval ( PolyBez _ spline ) =
bitraverseSpline
( const $ bitraverseCurve ( const $ pure () ) ( const eval ) )
eval
spline
eval ( Let _ decls a ) = declare decls *> eval a
eval ( With _ ( Tc_With ( withDeclsRecord :: Super.Rec ( MapFields UniqueTerm brushFields ) ) ) _ ( body :: Term Tc r ) ) = do
defaultParamsRecord <-
SuperRecord.traverseC @IsUniqueTerm2 @( State EvalState ) @( MapFields UniqueTerm brushFields ) @( MapFields UniqueField brushFields )
( \ _ ( Compose ( UniqueField uniq term ) ) -> UniqueField uniq <$> eval term )
withDeclsRecord
EvalState { evalHeap, nextUnique } <- get
let
toBrushParameters
:: forall givenFields usedFields
. ( SuperRecord.UnsafeRecBuild usedFields usedFields
( SuperRecord.Has givenFields )
)
=> Super.Rec givenFields -> Super.Rec usedFields
toBrushParameters = SuperRecord.project
brushFunction
:: forall usedFields
. ( SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField brushFields )
( UseFieldsInBrush usedFields )
)
=> Super.Rec usedFields -> r
brushFunction usedParamsRecord =
let
updatedHeap :: Map Unique TypedTerm
updatedHeap = bindRecordValues @brushFields @usedFields defaultParamsRecord usedParamsRecord evalHeap
in
( `evalState` ( EvalState { evalHeap = updatedHeap, nextUnique } ) ) $ eval body
pure ( AdaptableFunction ( toBrushParameters, brushFunction ) )
eval ( Var var@( Located _ ( UniqueName _ varUniq ) ) ) = do
vars <- use ( field' @"evalHeap" )
case Map.lookup varUniq vars of
Nothing -> error ( "eval: out of scope variable " <> show var )
Just ( TypedTerm ( r :: Term Tc b ) )
| Just Refl <- eqTy @a @b
-> do
res <- eval r
modifying ( field' @"evalHeap" )
( Map.insert varUniq ( TypedTerm $ CExt @Tc @a ( Val res ) ) )
pure res
| otherwise
-> error
( "eval: unexpected type of variable read from environment.\n\
\Expected: " <> show ( sTypeI @a ) <> "\n\
\ Actual: " <> show ( sTypeI @b )
)
eval ( CExt ( Val v ) ) = pure v
declare :: [ Decl Tc ] -> State EvalState ()
declare [] = pure ()
declare ( Decl _ pat t : next ) = go pat t *> declare next
where
go :: forall a. STypeI a => Pat Tc a -> Term Tc a -> State EvalState ( Maybe UniqueName )
go ( PName ( Located _ patUniqName@( UniqueName _ patUniq ) ) ) r = do
modifying ( field' @"evalHeap" )
( Map.insert patUniq $ TypedTerm r )
pure ( Just patUniqName )
go ( PPoint _ lpat rpat ) r = do
case sTypeI @a of
sTyPoint@STyPoint
| ( _ :: SType ( Point2D x ) ) <- sTyPoint
-> do
nextUnique <- use ( field' @"nextUnique" )
let
uniq1, uniq2, uniq3, nextUnique' :: Unique
uniq1 = nextUnique
uniq2 = succ uniq1
uniq3 = succ uniq2
nextUnique' = succ uniq3
assign ( field' @"nextUnique" ) nextUnique'
let
pairText :: Text
pairText = "$pair%" <> Text.pack ( show uniq1 )
pairName, fstName, sndName :: UniqueName
pairName = UniqueName pairText uniq1
fstName = UniqueName ( pairText <> "$fst" ) uniq2
sndName = UniqueName ( pairText <> "$snd" ) uniq3
var_l, var_r :: Term Tc x
var_l = Var ( Located noSpan fstName )
var_r = Var ( Located noSpan sndName )
modifying ( field' @"evalHeap" )
( Map.union
$ Map.fromList
[ ( uniq1, TypedTerm $ Point [] var_l var_r )
, ( uniq2, TypedTerm $ ( Op @( a -> x ) [] "fst" ( \ ~( Point2D x _ ) -> x ) ) :$ r )
, ( uniq3, TypedTerm $ ( Op @( a -> x ) [] "snd" ( \ ~( Point2D _ y ) -> y ) ) :$ r )
]
)
go lpat var_l
go rpat var_r
pure ( Just pairName )
go ( AsPat _ ( Located _ asUniqName@( UniqueName _ asUniq ) ) patt ) r = do
mbNm <- go patt r
for_ mbNm \ nm ->
modifying ( field' @"evalHeap" )
( Map.insert asUniq ( TypedTerm $ Var @Tc @a ( Located noSpan nm ) ) )
pure ( Just asUniqName )
go ( PWild _ ) _ = pure Nothing
bindRecordValues
:: forall brushFields usedFields defaultFields
. ( defaultFields ~ MapFields UniqueField brushFields
, SuperRecord.RecApply defaultFields defaultFields ( UseFieldsInBrush usedFields )
)
=> Super.Rec defaultFields
-> Super.Rec usedFields
-> Map Unique TypedTerm
-> Map Unique TypedTerm
bindRecordValues defaultValues usedValues heap = do
SuperRecord.recApply @defaultFields @defaultFields @( UseFieldsInBrush usedFields )
( \ k ( UniqueField ( UniqueName _ uniq ) ( defaultVal :: a ) ) prevState ->
let
val :: a
val = SuperRecord.lookupWithDefault k defaultVal usedValues
updatedHeap :: Map Unique TypedTerm
updatedHeap = Map.insert uniq ( TypedTerm $ CExt @Tc @a ( Val val ) ) prevState
in updatedHeap
)
defaultValues
heap
noSpan :: Span
noSpan = Span 0 0 0 0

141
src/app/MetaBrush/MetaParameter/Interpolation.hs Normal file
View file

@ -0,0 +1,141 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module MetaBrush.MetaParameter.Interpolation
( Interpolatable(..), MapDiff, HasDiff', HasTorsor )
where
-- base
import Data.Functor.Identity
( Identity(..) )
import Data.Kind
( Type )
import Data.Monoid
( Sum )
import GHC.TypeLits
( Symbol )
-- acts
import Data.Act
( Act(..), Torsor(..) )
-- groups
import Data.Group
( Group(..) )
-- superrecord
import qualified SuperRecord as Super
( Rec )
import qualified SuperRecord
( (:=), Has, RecTy, RecApply(..), UnsafeRecBuild(..), TraversalC, traverseC
, get, set, modify
)
import SuperRecord
( ConstC, Tuple22C )
-- MetaBrush
import Math.Module
( Module(..) )
import Math.Vector2D
( Point2D, Vector2D )
--------------------------------------------------------------------------------
class ( Module Double ( Diff a ), Torsor ( Diff a ) a ) => Interpolatable a where
type Diff a = ( d :: Type ) | d -> a
instance ( a ~ Double ) => Interpolatable ( Point2D a ) where
type Diff ( Point2D a ) = Vector2D a
instance Interpolatable Double where
type Diff Double = Sum Double
instance ( dvs ~ MapDiff kvs
, SuperRecord.UnsafeRecBuild dvs dvs ( ConstC Monoid )
, SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has dvs ) )
, SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC Semigroup ) ( SuperRecord.Has dvs ) )
, SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC Group ) ( SuperRecord.Has dvs ) )
, SuperRecord.RecApply dvs dvs ( HasDiff' kvs )
, SuperRecord.TraversalC ( HasTorsor kvs ) kvs dvs
, Module Double ( Super.Rec ( MapDiff kvs ) )
)
=> Interpolatable ( Super.Rec kvs )
where
type Diff ( Super.Rec kvs ) = Super.Rec ( MapDiff kvs )
type family MapDiff ( kvs :: [ Type ] ) = ( lvs :: [ Type ] ) | lvs -> kvs where
MapDiff '[] = '[]
MapDiff ( k SuperRecord.:= v ': kvs ) = ( k SuperRecord.:= Diff v ': MapDiff kvs )
instance ( Monoid ( Super.Rec kvs )
, SuperRecord.RecApply kvs kvs
( Tuple22C ( ConstC Group ) ( SuperRecord.Has kvs ) )
)
=> Group ( Super.Rec kvs )
where
invert r = SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC Group ) ( SuperRecord.Has kvs ) )
( \ lbl v res -> SuperRecord.set lbl ( invert v ) res ) r r
instance ( SuperRecord.RecApply kvs kvs
( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) )
, SuperRecord.UnsafeRecBuild kvs kvs ( ConstC ( Module Double ) )
)
=> Module Double ( Super.Rec kvs )
where
origin = runIdentity $ SuperRecord.unsafeRecBuild @kvs @kvs @( ConstC ( Module Double ) ) ( \ _ _ -> Identity origin )
r1 ^+^ r2 =
SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) )
( \ lbl v1 res -> SuperRecord.modify lbl ( v1 ^+^ ) res ) r1 r2
r1 ^-^ r2 =
SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) )
( \ lbl v1 res -> SuperRecord.modify lbl ( v1 ^-^ ) res ) r1 r2
k *^ r =
SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) )
( \ lbl v1 res -> SuperRecord.set lbl ( k *^ v1 ) res ) r r
class ( SuperRecord.Has kvs k t, Interpolatable t, d ~ Diff t, Just t ~ SuperRecord.RecTy k kvs )
=> HasDiff ( kvs :: [ Type ] ) ( t :: Type ) ( k :: Symbol ) ( d :: Type )
instance ( SuperRecord.Has kvs k t, Interpolatable t, d ~ Diff t, Just t ~ SuperRecord.RecTy k kvs )
=> HasDiff kvs t k d
type family FromJust ( a :: Maybe k ) :: k where
FromJust ( Just a ) = a
class HasDiff kvs ( FromJust ( SuperRecord.RecTy k kvs ) ) k d => HasDiff' kvs k d
instance HasDiff kvs ( FromJust ( SuperRecord.RecTy k kvs ) ) k d => HasDiff' kvs k d
instance ( dvs ~ MapDiff kvs
, SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC Semigroup ) ( SuperRecord.Has dvs ) )
, SuperRecord.RecApply dvs dvs ( HasDiff' kvs )
)
=> Act ( Super.Rec dvs ) ( Super.Rec kvs )
where
ds • as = SuperRecord.recApply @dvs @dvs @( HasDiff' kvs )
( \ lbl d1 res -> SuperRecord.modify lbl ( d1 • ) res ) ds as
class ( d ~ Diff t, Torsor d t, SuperRecord.Has kvs k t ) => HasTorsor ( kvs :: [Type] ) ( k :: Symbol ) t d where
instance ( d ~ Diff t, Torsor d t, SuperRecord.Has kvs k t ) => HasTorsor kvs k t d where
instance ( dvs ~ MapDiff kvs
, SuperRecord.TraversalC ( HasTorsor kvs ) kvs dvs
, Act ( Super.Rec dvs ) ( Super.Rec kvs )
, Group ( Super.Rec dvs )
)
=> Torsor ( Super.Rec dvs ) ( Super.Rec kvs ) where
as <-- bs =
runIdentity $ SuperRecord.traverseC @( HasTorsor kvs ) @Identity @kvs @dvs
( \ lbl a -> Identity ( a <-- SuperRecord.get lbl bs ) )
as

828
src/app/MetaBrush/MetaParameter/Parse.hs Normal file
View file

@ -0,0 +1,828 @@
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module MetaBrush.MetaParameter.Parse where
-- base
import Control.Applicative
( Alternative
( (<|>), some, many )
, optional
)
import Control.Category
( (>>>) )
import Control.Monad
( void )
import qualified Data.Char as Char
( isAlpha, isAlphaNum, isDigit, isSpace, isSymbol, isPunctuation, toLower )
import Data.Foldable
( for_ )
-- containers
import Data.Set
( Set )
import qualified Data.Set as Set
( member, fromList )
import qualified Data.Sequence as Seq
( fromList )
-- Earley
import qualified Text.Earley as Earley
import Text.Earley
( (<?>) )
import qualified Text.Earley.Mixfix as Earley
-- text
import Data.Text.Internal
( Text(..) )
import qualified Data.Text as Text
( all, break, cons, foldl'
, length, map, null
, singleton, span
, uncons, unpack
)
import qualified Data.Text.Read as Text.Read
( double )
-- tree-view
import Data.Tree.View
( drawTree )
-- MetaBrush
import Math.Bezier.Spline
( SplineType(..), SSplineType(..), SplineTypeI(ssplineType)
, Spline(..), Curves(..), Curve(..), NextPoint(..)
)
import MetaBrush.MetaParameter.AST
( Span(..), Located(..)
, Expr, EPat
, Term(..), Pat(..), Decl(..)
, X_With(..)
, toTreeTerm
)
import MetaBrush.MetaParameter.PrimOp
( Orientation(..), kappa
, rotate_around_by, rotate_by
, scale_around_by, scale_by
, shear_from_by, shear_by
, translate_by
)
--------------------------------------------------------------------------------
-- Parsing using the language grammar.
parse :: Text -> ( [ ( Expr, Int ) ], Earley.Report Text [ Located Token ] )
parse = Earley.allParses ( Earley.parser grammar ) . tokenize
showParses :: Text -> IO ()
showParses x = do
let
( parses, report ) = parse x
putStrLn "Report:\n"
print report
putStrLn "\n\n"
putStrLn "Parses:\n"
for_ parses \ ( expr, _ ) -> do
let
tree = toTreeTerm expr
drawTree tree
examples :: [ Located Token ] -> Int -> IO ()
examples inputToks n =
for_ ( Earley.exactly n ( Earley.generator grammar inputToks ) ) \ ( expr, toks ) -> do
for_ toks ( located >>> showToken >>> ( <> " " ) >>> putStr )
putStrLn ""
drawTree ( toTreeTerm expr )
putStrLn "\n\n"
someToks :: [ Located Token ]
someToks = map ( Located mempty )
[ TokAlphabetic "x"
, TokAlphabetic "let"
, TokAlphabetic "in"
, TokSpecial '['
, TokSpecial ']'
, TokSpecial '('
, TokSpecial ')'
, TokSymbolic "="
, TokSymbolic "--"
, TokSymbolic "->"
, TokSymbolic "."
]
test1 :: Text
test1 =
" let\n\
\ q = rotate p around c CW by theta + 3 * theta2\n\
\ r = scale ( translate q by t ) by (7,11)\n\
\ in rotate q around p CW by phi"
test2 :: Text
test2 =
" let\n\
\ p = (3,3)\n\
\ q = (1,1)\n\
\ in\n\
\ rotate p\n\
\ around q\n\
\ CCW by\n\
\ let\n\
\ q = pi / 2 \n\
\ in q"
test3 :: Text
test3 =
" let\n\
\ p = (1,1)\n\
\ in\n\
\ [ p -- c1 -- c2 -> q\n\
\ -- c3 -- c4 -> r\n\
\ -> s -> .\n\
\ ]"
--------------------------------------------------------------------------------
-- Language grammar.
grammar :: forall r. Earley.Grammar r ( Earley.Prod r Text ( Located Token ) Expr )
grammar = mdo
pair <- Earley.rule $
do
lp <- special '('
l <- expr
anyWhitespace
comma <- special ','
r <- expr
anyWhitespace
rp <- special ')'
pure $
Point
[ Location ( location lp )
, Location ( location comma )
, Location ( location rp ) ]
l r
<?> "pair"
atom <- Earley.rule
( identifier
<|> pair
<|> ( special '(' *> expr <* anyWhitespace <* special ')' )
<|> spline
)
app <- Earley.rule ( atom <|> (:$) <$> app <*> ( anyWhitespace *> atom ) )
pairPattern <- Earley.rule
( do
openLoc <- special '('
anyWhitespace
l <- anyPattern
anyWhitespace
commaLoc <- special ','
anyWhitespace
r <- anyPattern
anyWhitespace
closeLoc <- special ')'
pure $ PPoint
[ Location ( location openLoc )
, Location ( location commaLoc )
, Location ( location closeLoc )
]
l r
<?> "pair"
)
basicPattern <- Earley.rule
( wildcard
<|> ( PName <$> alphabeticName
<?> "pattern name"
)
<|> pairPattern
)
asPattern <- Earley.rule
( do
n <- alphabeticName <?> "pattern name"
asLoc <- symbol "@"
pat <- anyPattern
pure $
AsPat ( Location ( location asLoc ) ) n pat
<?> "as pattern"
)
anyPattern <- Earley.rule ( ( basicPattern <|> asPattern ) <?> "pattern" )
declaration <-
Earley.rule
( do
p <- anyPattern
anyWhitespace
eqLoc <- symbol "="
e <- expr
pure ( Location ( location eqLoc ), p, e )
<?> "declaration"
)
moreDeclarations <- Earley.rule
( do
separator
decl <- declaration
more <- moreDeclarations
pure $ ( \ ( l, p, e ) -> Decl l p e : more ) decl
<|> pure []
)
declarations <-
Earley.rule
( do
decl <- declaration
more <- moreDeclarations
pure $ ( \ ( l, p, e ) -> Decl l p e : more ) decl
<|> pure []
)
let_statement <-
Earley.rule
( do
loc_let <- tokAlpha "let"
anyWhitespace
decls <- declarations <?> "declarations"
anyWhitespace
loc_in <- tokAlpha "in"
e <- expr
pure $
Let
[ Location ( location loc_let )
, Location ( location loc_in ) ]
decls
e
<?> "let statement"
)
moreProperties <- Earley.rule
( do
separator
prop <- expr
more <- moreProperties
pure ( prop : more )
<|> pure []
)
properties <-
Earley.rule
( do
prop <- expr
more <- moreProperties
pure ( prop : more )
<|> pure []
)
with_statement <-
Earley.rule
( do
loc_with <- tokAlpha "with"
anyWhitespace
decls <- declarations <?> "parameter default definitions"
mbProps <- optional do
anyWhitespace
loc_sats <- tokAlpha "satisfying"
props <- properties <?> "parameter range properties"
pure ( loc_sats, props )
anyWhitespace
loc_def <- tokAlpha "define"
e <- expr
pure $
let
( locs, props ) = case mbProps of
Nothing ->
( [ Location ( location loc_with )
, Location ( location loc_def ) ]
, []
)
Just ( loc_sats, sat_props ) ->
( [ Location ( location loc_with )
, Location ( location loc_sats )
, Location ( location loc_def ) ]
, sat_props
)
in
With locs ( P_With decls ) props e
<?> "with statement"
)
spline <-
Earley.rule
( do
start <- special '['
p0 <- expr <?> "first point of spline"
openCurves <- many $ curveTo @Open expr <?> "open curve to"
mbClosed <- optional $ curveTo @Closed expr <?> "closed curve"
anyWhitespace
end <- special ']'
pure $
( \ opens -> \ case
Nothing ->
PolyBez
[ Location ( location start ), Location ( location end ) ]
( Spline p0 ( OpenCurves opens ) )
Just closed ->
PolyBez
[ Location ( location start ), Location ( location end ) ]
( Spline p0 ( ClosedCurves opens closed ) )
) ( Seq.fromList openCurves ) mbClosed
<?> "spline" )
simpleExpr <- Earley.rule do
anyWhitespace
res <- app <|> let_statement
pure res
expr <- Earley.mixfixExpressionSeparate mixfixTable simpleExpr
pure ( with_statement <|> expr )
-- | Reserved alphabetic identifiers.
reserved :: Set Text
reserved
= Set.fromList
[ "let", "in"
, "with", "set", "satisfying"
, "around", "by", "rotate", "scale", "shear", "translate", "transform"
, "cw", "ccw"
, "pi", "tau", "kappa"
]
{-
[ "=", "_", "@", "--", "->" ]
-}
dots :: Earley.Prod r Text ( Located Token ) ( Located Token )
dots = Earley.satisfy ( located >>> \case { TokSymbolic s | Text.all ( == '.' ) s -> True; _ -> False } )
locatedToken :: Token -> Earley.Prod r Text ( Located Token ) ( Located Token )
locatedToken t = Earley.satisfy ( located >>> ( == t ) )
tokAlpha, ws_tokAlpha :: Text -> Earley.Prod r Text ( Located Token ) ( Located Token )
tokAlpha t = Earley.satisfy
( located >>> \case { TokAlphabetic a | Text.map Char.toLower a == t -> True; _ -> False } )
<?> t
ws_tokAlpha t = anyWhitespace *> tokAlpha t
tokSymbol, ws_tokSymbol :: Text -> Earley.Prod r Text ( Located Token ) ( Located Token )
tokSymbol t = locatedToken ( TokSymbolic t ) <?> t
ws_tokSymbol t = anyWhitespace *> tokSymbol t
tokOrientation :: Earley.Prod r Text ( Located Token ) ( Located Token )
tokOrientation = anyWhitespace *> ( tokAlpha "ccw" <|> tokAlpha "cw" )
orientation :: Token -> Orientation
orientation ( TokAlphabetic ori )
| Text.map Char.toLower ori == "ccw"
= CCW
| Text.map Char.toLower ori == "cw"
= CW
orientation tok = error ( "orientation: unexpected token " <> show tok )
curveTo
:: forall clo r
. SplineTypeI clo
=> Earley.Prod r Text ( Located Token ) Expr
-> Earley.Prod r Text ( Located Token ) ( Curve clo [ Located () ] Expr )
curveTo expr = do
anyWhitespace
cps <- optional do
locTo1 <- symbol "--"
cp1 <- expr
anyWhitespace
mb_cp2 <- optional do
locTo2 <- symbol "--"
cp2 <- expr
anyWhitespace
pure ( locTo2, cp2 )
pure ( ( locTo1, cp1), mb_cp2 )
locTo3 <- symbol "->"
mkCurve <- case ssplineType @clo of
SClosed ->
let
mkCurve
:: Located Token
-> Maybe ( ( Located Token, Expr ), Maybe ( Located Token, Expr ) )
-> Span
-> Curve Closed [ Located () ] Expr
mkCurve ( Located dotsLoc _ ) mbCps loc3 = case mbCps of
Nothing ->
LineTo BackToStart [ Location loc3, Location dotsLoc ]
Just ( ( Located loc1 _, cp1 ), Nothing ) ->
Bezier2To cp1 BackToStart [ Location loc1, Location loc3, Location dotsLoc ]
Just ( ( Located loc1 _, cp1 ), Just ( Located loc2 _, cp2 ) ) ->
Bezier3To cp1 cp2 BackToStart [ Location loc1, Location loc2, Location loc3, Location dotsLoc ]
in do
anyWhitespace
locatedDots <- dots
pure ( mkCurve locatedDots )
SOpen ->
let
mkCurve
:: Expr
-> Maybe ( ( Located Token, Expr ), Maybe ( Located Token, Expr ) )
-> Span
-> Curve Open [ Located () ] Expr
mkCurve p mbCps loc3 = case mbCps of
Nothing ->
LineTo ( NextPoint p ) [ Location loc3 ]
Just ( ( Located loc1 _, cp1 ), Nothing ) ->
Bezier2To cp1 ( NextPoint p ) [ Location loc1, Location loc3 ]
Just ( ( Located loc1 _, cp1 ), Just ( Located loc2 _, cp2 ) ) ->
Bezier3To cp1 cp2 ( NextPoint p ) [ Location loc1, Location loc2, Location loc3 ]
in do
p <- expr
pure ( mkCurve p )
pure ( mkCurve cps ( location locTo3 ) )
mixfixTable
:: [ [
( Earley.Holey ( Earley.Prod r Text ( Located Token ) ( Located Token ) )
, Earley.Associativity
, Earley.Holey ( Located Token ) -> [ Expr ] -> Expr
)
] ]
mixfixTable
= [ [ ( [ Just $ ws_tokAlpha "rotate", Nothing, Just $ ws_tokAlpha "around", Nothing, Just tokOrientation, Just $ ws_tokAlpha "by", Nothing ]
, Earley.NonAssoc
, \ [ Just ( Located lr _ ), _, Just ( Located la _ ), _, Just ( Located lo ori_tok ), Just ( Located lb _ ), _ ] [ p, c, theta ] ->
let
ori :: Orientation
ori = orientation ori_tok
opName :: Text
opName = case ori of { CW -> "rotate_around_cwby_"; CCW -> "rotate_around_ccwby_" }
in
Op [ Location lr, Location la, Location lo, Location lb ]
opName ( rotate_around_by ori )
:$ p :$ c :$ theta
)
, ( [ Just $ ws_tokAlpha "scale", Nothing, Just $ ws_tokAlpha "around", Nothing, Just $ ws_tokAlpha "by", Nothing ]
, Earley.NonAssoc
, \ [ Just ( Located ls _ ), _, Just ( Located la _ ), _, Just ( Located lb _ ), _ ] [ p, c, r ] ->
Op [ Location ls, Location la, Location lb ]
"scale_around_by_" scale_around_by
:$ p :$ c :$ r
)
, ( [ Just $ ws_tokAlpha "shear", Nothing, Just $ ws_tokAlpha "from", Nothing, Just $ ws_tokAlpha "by", Nothing ]
, Earley.NonAssoc
, \ [ Just ( Located ls _ ), _, Just ( Located lf _ ), _, Just ( Located lb _ ), _ ] [ p, c, v ] ->
Op [ Location ls, Location lf, Location lb ]
"shear_from_by_" shear_from_by
:$ p :$ c :$ v
)
]
, [ ( [ Just $ ws_tokAlpha "rotate", Nothing, Just tokOrientation, Just $ ws_tokAlpha "by", Nothing ]
, Earley.NonAssoc
, \ [ Just ( Located lr _ ), _, Just ( Located lo ori_tok ), Just ( Located lb _), _ ] [ p, theta ] ->
let
ori :: Orientation
ori = orientation ori_tok
opName :: Text
opName = case ori of { CW -> "rotate_around_cw_"; CCW -> "rotate_around_ccw_" }
in
Op [ Location lr, Location lo, Location lb ]
opName ( rotate_by ori )
:$ p :$ theta
)
, ( [ Just $ ws_tokAlpha "scale", Nothing, Just $ ws_tokAlpha "by", Nothing ]
, Earley.NonAssoc
, \ [ Just ( Located ls _ ), _, Just ( Located lb _ ), _ ] [ p, r ] ->
Op [ Location ls, Location lb ]
"scale_by_" scale_by
:$ p :$ r
)
, ( [ Just $ ws_tokAlpha "shear", Nothing, Just $ ws_tokAlpha "along", Nothing, Just $ ws_tokAlpha "by", Nothing ]
, Earley.NonAssoc
, \ [ Just ( Located ls _ ), _, Just ( Located lb _ ), _ ] [ p, v ] ->
Op [ Location ls, Location lb ]
"shear_along_by_" shear_by
:$ p :$ v
)
, ( [ Just $ ws_tokAlpha "translate", Nothing, Just $ ws_tokAlpha "by", Nothing ]
, Earley.NonAssoc
, \ [ Just ( Located lt _ ), _, Just ( Located lb _ ), _ ] [ p, t ] ->
Op [ Location lt, Location lb ]
"translate_by_" translate_by
:$ p :$ t
)
]
, [ ( [ Nothing, Just $ ws_tokSymbol "||", Nothing ]
, Earley.RightAssoc
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
Op [ Location l ]
"(||)" (||)
:$ a :$ b
)
]
, [ ( [ Nothing, Just $ ws_tokSymbol "&&", Nothing ]
, Earley.RightAssoc
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
Op [ Location l ]
"(&&)" (&&)
:$ a :$ b
)
]
, [ ( [ Nothing, Just $ ws_tokSymbol "<", Nothing ]
, Earley.NonAssoc
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
Op [ Location l ]
"(<)" ( (<) @Double )
:$ a :$ b
)
, ( [ Nothing, Just $ ws_tokSymbol "<=", Nothing ]
, Earley.NonAssoc
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
Op [ Location l ]
"(<=)" ( (<=) @Double )
:$ a :$ b
)
, ( [ Nothing, Just $ ws_tokSymbol ">", Nothing ]
, Earley.NonAssoc
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
Op [ Location l ]
"(>)" ( (>) @Double )
:$ a :$ b
)
, ( [ Nothing, Just $ ws_tokSymbol ">=", Nothing ]
, Earley.NonAssoc
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
Op [ Location l ]
"(>=)" ( (>=) @Double )
:$ a :$ b
)
, ( [ Nothing, Just $ ws_tokSymbol "==", Nothing ]
, Earley.NonAssoc
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
Op [ Location l ]
"(==)" ( (==) @Double )
:$ a :$ b
)
]
, [ ( [ Nothing, Just $ ws_tokSymbol "+", Nothing ]
, Earley.LeftAssoc
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
Op [ Location l ]
"(+)" ( (+) @Double )
:$ a :$ b
)
, ( [ Nothing, Just $ ws_tokSymbol "-", Nothing ]
, Earley.LeftAssoc
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
Op [ Location l ]
"(-)" ( (-) @Double )
:$ a :$ b
)
, ( [ Just $ ws_tokSymbol "-", Nothing ]
, Earley.RightAssoc
, \ [ Just ( Located l _ ), _ ] [ a ] ->
Op [ Location l ]
"negate" ( negate @Double )
:$ a
)
]
, [ ( [ Nothing, Just $ ws_tokSymbol "*", Nothing ]
, Earley.LeftAssoc
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
Op [ Location l ]
"(*)" ( (*) @Double )
:$ a :$ b
)
, ( [ Nothing, Just $ ws_tokSymbol "/", Nothing ]
, Earley.LeftAssoc
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
Op [ Location l ]
"(/)" ( (/) @Double )
:$ a :$ b
)
]
, [ ( [ Nothing, Just $ ws_tokSymbol "^", Nothing ]
, Earley.RightAssoc
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
Op [ Location l ]
"(^)" ( (**) @Double )
:$ a :$ b
)
]
]
numericLiteral :: Located Token -> Maybe Expr
numericLiteral ( Located l ( TokNumeric x ) ) = Just $ Lit @Double ( Located l Nothing ) x
numericLiteral _ = Nothing
number :: Earley.Prod r Text ( Located Token ) Expr
number = Earley.terminal numericLiteral
<?> "number"
identifier :: Earley.Prod r Text ( Located Token ) Expr
identifier =
number
<|> ( \ ( Located l _ ) -> Lit @Double ( Located l ( Just "pi" ) ) pi ) <$> tokAlpha "pi"
<|> ( \ ( Located l _ ) -> Lit @Double ( Located l ( Just "tau" ) ) ( 2 * pi ) ) <$> tokAlpha "tau"
<|> ( \ ( Located l _ ) -> Lit @Double ( Located l ( Just "kappa" ) ) kappa ) <$> tokAlpha "kappa"
<|> ( ( \ n -> Var n ) <$> alphabeticName
<?> "identifier"
)
whitespace, anyWhitespace :: Earley.Prod r Text ( Located Token ) ()
whitespace = Earley.terminal $ located >>> \case { TokWhitespace _ -> Just (); _ -> Nothing }
anyWhitespace = void $ many whitespace
significantWhitespace :: Earley.Prod r Text ( Located Token ) ()
significantWhitespace = Earley.terminal ( located >>> \case { TokWhitespace True -> Just (); _ -> Nothing } )
<?> "newline"
separator :: Earley.Prod r Text ( Located Token ) ()
separator =
( void ( some significantWhitespace )
<|> ( void ( anyWhitespace *> special ';' <* anyWhitespace ) )
)
<?> "separator"
alphabeticName :: Earley.Prod r Text ( Located Token ) ( Located Text )
alphabeticName =
Earley.terminal \case
Located l ( TokAlphabetic x )
| not ( x `Set.member` reserved )
-> Just ( Located l x )
_ -> Nothing
special :: Char -> Earley.Prod r Text ( Located Token ) ( Located Token )
special c = locatedToken ( TokSpecial c ) <?> Text.singleton c
symbol :: Text -> Earley.Prod r Text ( Located Token ) ( Located Token )
symbol s = locatedToken ( TokSymbolic s ) <?> s
wildcard :: Earley.Prod r Text ( Located Token ) EPat
wildcard = Earley.terminal
\case
Located l ( TokWildcard x ) -> Just ( PWild ( Located l x ) )
_ -> Nothing
<?> "wildcard pattern"
--------------------------------------------------------------------------------
-- Tokenizer.
isSpecial :: Char -> Bool
isSpecial c = Set.member c ( Set.fromList "(){}[],;`\"" )
data Token
= TokWhitespace Bool
| TokSpecial Char
| TokAlphabetic Text
| TokNumeric Double
| TokWildcard Text
| TokSymbolic Text
| OtherTok Text
deriving stock ( Show, Eq, Ord )
showToken :: Token -> String
showToken ( TokWhitespace False ) = " "
showToken ( TokWhitespace True ) = "\n"
showToken ( TokSpecial s ) = [s]
showToken ( TokAlphabetic a ) = Text.unpack a
showToken ( TokNumeric x ) = show x
showToken ( TokWildcard w ) = Text.unpack w
showToken ( TokSymbolic s ) = Text.unpack s
showToken ( OtherTok t ) = Text.unpack t
tokenize :: Text -> [ Located Token ]
tokenize = go 1 1
where
go :: Int -> Int -> Text -> [ Located Token ]
go sr sc t = case Text.uncons t of
Nothing -> []
Just ( x, xs )
-- White space.
| Char.isSpace x
, let
( ys, rest ) = Text.span Char.isSpace xs
( er1, er2, ec ) =
Text.foldl'
( \ (r1,r2,c) -> \ case
'\n' -> (r1+1,r2,1)
'\r' -> (r1,r2+1,1)
'\t' -> (r1,r2,c+2)
'\f' -> (r1,r2,c)
'\v' -> (r1,r2,c)
_ -> (r1,r2,c+1)
)
(sr,sr,sc)
( x `Text.cons` ys )
er = max er1 er2
-> if er > sr
then Located ( Span sr sc er ec ) ( TokWhitespace True ) : go er ec rest
else Located ( Span sr sc er ec ) ( TokWhitespace False ) : go er ec rest
-- Special characters.
| isSpecial x
-> Located ( Span sr sc sr ( sc + 1 ) ) ( TokSpecial x )
: go sr ( sc + 1 ) xs
-- Alphabetic identifier.
| Char.isAlpha x
, let
( ys, rest ) = Text.span ( \case { '\'' -> True; '_' -> True; y | Char.isAlphaNum y -> True; _ -> False } ) xs
tok = x `Text.cons` ys
l = Text.length tok
-> Located ( Span sr sc sr ( sc + l ) ) ( TokAlphabetic tok )
: go sr ( sc + l ) rest
-- Numeric identifier.
| Just ( locTok@Located { location = Span { endRow, endCol } }, rest ) <- tokenizeNumeric sr sc t
-> locTok
: go endRow endCol rest
-- Wildcard.
| '_' <- x
, let
( ys, rest ) = Text.span ( \case { '_' -> True; y | Char.isAlphaNum y -> True; _ -> False } ) xs
tok :: Text
tok = x `Text.cons` ys
l = Text.length tok
-> Located ( Span sr sc sr ( sc + l ) ) ( TokWildcard tok )
: go sr ( sc + l ) rest
-- Symbolic identifier.
| Char.isSymbol x || Char.isPunctuation x
, let
( ys, rest ) = Text.break ( \ c -> isSpecial c || Char.isSpace c || Char.isAlphaNum c ) xs
tok = x `Text.cons` ys
l = Text.length tok
-> Located ( Span sr sc sr ( sc + l ) ) ( TokSymbolic tok )
: go sr ( sc + l ) rest
-- Fallback.
| let
( ys, rest ) = Text.break ( \ c -> isSpecial c || Char.isSpace c ) xs
tok = x `Text.cons` ys
l = Text.length tok
-> Located ( Span sr sc sr ( sc + l ) ) ( OtherTok tok )
: go sr ( sc + l ) rest
-- Tokenize a numeric literal (without any leading sign).
tokenizeNumeric :: Int -> Int -> Text -> Maybe ( Located Token, Text )
tokenizeNumeric sr sc t = case Text.span Char.isDigit t of
-- Integer part of the mantissa.
( integ, rest )
| not ( Text.null integ )
-> case Text.uncons rest of
Just ( c, rest' )
-- Fraction.
| c == '.'
->
-- Fractional part of the mantissa.
let ( frac, rest'' ) = Text.span Char.isDigit rest'
in case Text.uncons rest'' of
Just ( c', rest''' )
-- Fraction followed by exponent.
| c' == 'e' || c' == 'E'
, Just ( expo, rest'''' ) <- spanExponent rest'''
, Right ( r, leftover ) <- Text.Read.double ( integ <> "." <> frac <> "e" <> expo )
, Text.null leftover
, let
l = Text.length integ + 1 + Text.length frac + 1 + Text.length expo
-> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest'''' )
-- Simple fraction (no exponent).
_ | Right ( r, leftover ) <- Text.Read.double ( integ <> "." <> frac )
, Text.null leftover
, let
l = Text.length integ + 1 + Text.length frac
-> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest'' )
_ -> Nothing
-- Positive integer followed by exponent.
| c == 'e' || c == 'E'
, Just ( expo, rest'' ) <- spanExponent rest'
, Right ( r, leftover ) <- Text.Read.double ( integ <> "e" <> expo )
, Text.null leftover
, let
l = Text.length integ + 1 + Text.length expo
-> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest'' )
-- Simple positive integer (no fractional part or exponent).
_ | Right ( r, leftover ) <- Text.Read.double integ
, Text.null leftover
, let
l = Text.length integ
-> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest )
_ -> Nothing
_ -> Nothing
spanExponent :: Text -> Maybe ( Text, Text )
spanExponent t = case Text.uncons t of
Just ( x, xs )
| x == '+' || x == '-' || Char.isDigit x
, let
( ds, rest ) = Text.span Char.isDigit xs
-> Just ( Text.cons x ds, rest )
_ -> Nothing

42
src/app/MetaBrush/MetaParameter/PrimOp.hs Normal file
View file

@ -0,0 +1,42 @@
{-# LANGUAGE DerivingStrategies #-}
module MetaBrush.MetaParameter.PrimOp where
-- MetaBrush
import Math.Vector2D
( Point2D(..) )
--------------------------------------------------------------------------------
-- Operations supported by the DSL.
data Orientation = CCW | CW
deriving stock Show
kappa :: Double
kappa = 0.5519150244935105707435627227925
-- root of (Sqrt[2] (4 + 3 κ) - 16) (2 - 3 κ)^2 - 8 (1 - 3 κ) Sqrt[8 - 24 κ + 12 κ^2 + 8 κ^3 + 3 κ^4]
rotate_around_by :: Orientation -> Point2D Double -> Point2D Double -> Double -> Point2D Double
rotate_around_by ori ( Point2D px py ) ( Point2D cx cy ) theta =
translate_by ( rotate_by ori ( Point2D ( px - cx ) ( py - cy ) ) theta ) ( Point2D cx cy )
rotate_by :: Orientation -> Point2D Double -> Double -> Point2D Double
rotate_by CCW ( Point2D px py ) theta = Point2D ( c * px - s * py ) ( c * py + s * px )
where
c, s :: Double
c = cos theta
s = sin theta
rotate_by CW p theta = rotate_by CCW p ( -theta )
scale_around_by :: Point2D Double -> Point2D Double -> Point2D Double -> Point2D Double
scale_around_by ( Point2D px py ) ( Point2D cx cy ) ( Point2D rx ry ) = Point2D ( rx * ( px - cx ) + cx ) ( ry * ( py - cy ) + cy )
scale_by :: Point2D Double -> Point2D Double -> Point2D Double
scale_by ( Point2D px py ) ( Point2D rx ry ) = Point2D ( rx * px ) ( ry * py )
shear_from_by :: Point2D Double -> Point2D Double -> Point2D Double -> Point2D Double
shear_from_by ( Point2D px py ) ( Point2D cx cy ) v =
translate_by ( shear_by ( Point2D ( px - cx ) ( py - cy ) ) v ) ( Point2D cx cy )
shear_by :: Point2D Double -> Point2D Double -> Point2D Double
shear_by ( Point2D px py ) ( Point2D vx vy ) = undefined
translate_by :: Point2D Double -> Point2D Double -> Point2D Double
translate_by ( Point2D px py ) ( Point2D tx ty ) = Point2D ( px + tx ) ( py + ty )

240
src/app/MetaBrush/MetaParameter/Rename.hs Normal file
View file

@ -0,0 +1,240 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module MetaBrush.MetaParameter.Rename
( rename, MonadRn, RnM
, RnMessage, RnError
, RnState, emptyRnState
, Env(..), UniqueName(..)
)
where
-- base
import Data.Foldable
( for_ )
import GHC.Generics
( Generic )
-- containers
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
( lookup )
-- dlist
import Data.DList
( DList )
import qualified Data.DList as DList
( singleton )
-- generic-lens
import Data.Generics.Product.Fields
( field' )
-- lens
import Control.Lens
( assign, at, modifying, use )
-- mtl
import Control.Monad.State
( MonadState(..) )
import Control.Monad.Writer
( MonadWriter(..) )
-- text
import Data.Text
( Text )
-- transformers
import Control.Monad.Trans.RWS.CPS
( RWST )
-- MetaBrush
import Math.Bezier.Spline
( KnownSplineType(bitraverseSpline), bitraverseCurve )
import MetaBrush.MetaParameter.AST
( Located(..)
, Pass(P,Rn), Name, UniqueName(..), X_With(..)
, Term(..), Decl(..), Pat(..)
)
import MetaBrush.MetaParameter.Parse
( ) -- AST type family instances for parsing pass
import MetaBrush.Unique
( UniqueSupply, MonadUnique(freshUnique)
, Unique
)
--------------------------------------------------------------------------------
-- Renaming pass.
rename :: MonadRn m => Term P '() -> m ( Term Rn '() )
rename ( f :$ a ) = (:$) <$> locally ( rename f ) <*> locally ( rename a )
rename ( Var locv@( Located l v ) ) = do
mbRes <- use ( field' @"localEnv" . field' @"rnLocalVars" . at v )
case mbRes of
Nothing -> do
rnError ( OutOfScope locv )
uniq' <- freshUnique
pure $ Var ( Located l ( UniqueName v uniq' ) )
Just uniq ->
pure $ Var ( Located l ( UniqueName v uniq ) )
rename ( Lit l a ) = pure ( Lit l a )
rename ( Op locs nm op ) = pure ( Op locs nm op )
rename ( Point locs a b ) = Point locs <$> locally ( rename a ) <*> locally ( rename b )
rename ( Line locs p1 p2 ) = Line locs <$> locally ( rename p1 ) <*> locally ( rename p2 )
rename ( Bez2 locs p1 p2 p3 ) = Bez2 locs <$> locally ( rename p1 ) <*> locally ( rename p2 ) <*> locally ( rename p3 )
rename ( Bez3 locs p1 p2 p3 p4 ) = Bez3 locs <$> locally ( rename p1 ) <*> locally ( rename p2 ) <*> locally ( rename p3 ) <*> locally ( rename p4 )
rename ( PolyBez locs spline ) = PolyBez locs <$>
bitraverseSpline
( const $ bitraverseCurve pure ( const $ locally . rename ) )
( locally . rename )
spline
rename ( Let locs decls body ) = do
decls' <- renameDecls decls
body' <- rename body
pure ( Let locs decls' body' )
rename ( With locs ( P_With decls ) conds body ) = do
decls' <- renameDecls decls
conds' <- traverse ( locally . rename ) conds
body' <- rename body
pure ( With locs ( Rn_With decls' ) conds' body' )
renameDecls :: forall m. MonadRn m => [ Decl P ] -> m [ Decl Rn ]
renameDecls decls = do
outerLocalVars <- use ( field' @"localEnv" . field' @"rnLocalVars" )
assign ( field' @"localEnv" . field' @"rnLocalVars" ) mempty
decls' <- go outerLocalVars decls
pure decls'
where
go :: Map Text Unique -> [ Decl P ] -> m [ Decl Rn ]
go outerLocalVars ( Decl loc lhs rhs : next ) = do
-- Collect all the declarations from the left-hand sides.
lhs' <- renameLhs outerLocalVars lhs
next' <- go outerLocalVars next
-- Now rename each right-hand side with the full LHS info.
rhs' <- locally ( rename rhs )
pure $ Decl loc lhs' rhs' : next'
go outerLocalVars [] = do
-- Finished handling all the left-hand sides:
-- add all the declared names to the existing (outer) names,
-- shadowing the outer names if necessary.
modifying ( field' @"localEnv" . field' @"rnLocalVars" ) ( <> outerLocalVars )
pure []
renameLhs :: Map Text Unique -> Pat P '() -> m ( Pat Rn '() )
renameLhs outerLocalVars ( PName locPat@( Located l nm ) ) = do
mbUniq <- use ( field' @"localEnv" . field' @"rnLocalVars" . at nm )
case mbUniq of
Just uniq -> do
rnError ( DuplicateDecl uniq locPat )
uniq' <- freshUnique
pure $ PName ( Located l ( UniqueName nm uniq' ) )
Nothing -> do
let
mbPrevUniq :: Maybe Unique
mbPrevUniq = Map.lookup nm outerLocalVars
uniq <- freshUnique
for_ mbPrevUniq \ prevUniq -> do
rnWarning ( NameShadowing prevUniq ( Located l ( UniqueName nm uniq ) ) )
assign ( field' @"localEnv" . field' @"rnLocalVars" . at nm ) ( Just uniq )
assign ( field' @"globalEnv" . field' @"rnGlobalVars" . at uniq ) ( Just locPat )
pure $ PName ( Located l ( UniqueName nm uniq ) )
renameLhs outerLocalVars ( PPoint l p1 p2 ) = PPoint l <$> renameLhs outerLocalVars p1 <*> renameLhs outerLocalVars p2
renameLhs _ ( PWild wild ) = pure ( PWild wild )
renameLhs outerLocalVars ( AsPat atLoc locName pat ) = do
name' <- renameLhs outerLocalVars ( PName locName )
case name' of
PName locName' -> do
pat' <- renameLhs outerLocalVars pat
pure $ AsPat atLoc locName' pat'
_ -> error "renameLHS: internal error"
--------------------------------------------------------------------------------
-- Renamer-specific data and instances.
data RnLocalEnv
= RnLocalEnv
{ rnLocalVars :: !( Map Text Unique ) }
deriving stock ( Show, Generic )
data RnGlobalEnv
= RnGlobalEnv
{ rnGlobalVars :: !( Map Unique ( Located Text ) ) }
deriving stock ( Show, Generic )
data Env global local
= Env
{ globalEnv :: !global
, localEnv :: !local
}
deriving stock ( Show, Generic )
type RnState = Env RnGlobalEnv RnLocalEnv
emptyRnState :: RnState
emptyRnState = Env ( RnGlobalEnv mempty ) ( RnLocalEnv mempty )
locally :: MonadState ( Env global local ) m => m a -> m a
locally action = do
Env { localEnv } <- get
res <- action
assign ( field' @"localEnv" ) localEnv
pure res
data RnMessage
= RnWarningMessage
{ rnWarningMessage :: !RnWarning
, rnMessageState :: !RnState
}
| RnErrorMessage
{ rnErrorMessage :: !RnError
, rnMessageState :: !RnState
}
deriving stock ( Show, Generic )
data RnError
= OutOfScope !( Located Text )
| DuplicateDecl
{ prevDecl :: !Unique
, dupDecl :: !( Located Text )
}
deriving stock ( Show, Generic )
data RnWarning
= NameShadowing
{ shadowedUnique :: !Unique
, shadowingName :: !( Located UniqueName )
}
deriving stock ( Show, Generic )
rnError
:: ( MonadState RnState m , MonadWriter ( DList RnMessage ) m )
=> RnError -> m ()
rnError err = do
st <- get
tell ( DList.singleton $ RnErrorMessage err st )
rnWarning
:: ( MonadState RnState m , MonadWriter ( DList RnMessage ) m )
=> RnWarning -> m ()
rnWarning warn = do
st <- get
tell ( DList.singleton $ RnWarningMessage warn st )
type RnM = RWST UniqueSupply ( DList RnMessage ) RnState IO
type MonadRn m = ( MonadUnique m, MonadState RnState m, MonadWriter ( DList RnMessage ) m )
type instance Name Rn = UniqueName

446
src/app/MetaBrush/MetaParameter/TypeCheck.hs Normal file
View file

@ -0,0 +1,446 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
module MetaBrush.MetaParameter.TypeCheck
( typeCheck, MonadTc, TcM
, TcMessage, TcError
, TcState, emptyTcState
)
where
import Data.Kind
( Type )
-- base
import Data.Either
( partitionEithers )
import Data.Functor.Compose
( Compose(..) )
import Data.List
( sortBy )
import Data.Ord
( comparing )
import Data.Proxy
( Proxy )
import Data.Type.Equality
( (:~:)(Refl) )
import GHC.Exts
( Proxy#, proxy# )
import GHC.Generics
( Generic )
import GHC.TypeLits
( someSymbolVal, SomeSymbol(..) )
import GHC.TypeNats
( KnownNat )
import Unsafe.Coerce
( unsafeCoerce )
-- containers
import Data.Map.Strict
( Map )
import Data.Sequence
( Seq(..) )
-- dlist
import Data.DList
( DList )
-- generic-lens
import Data.Generics.Product.Fields
( field' )
-- lens
import Control.Lens
( assign, at, use )
-- mtl
import Control.Monad.Except
( MonadError(..) )
import Control.Monad.State
( MonadState(..) )
import Control.Monad.Writer
( MonadWriter(..) )
-- superrecord
import qualified SuperRecord as Super
( Rec )
import qualified SuperRecord
( (:=)(..), FldProxy(..), RecSize, RecApply
, RecTy, RemoveAccessTo, RecVecIdxPos
, TraversalCHelper
, unsafeRNil, unsafeRCons
)
-- text
import Data.Text
( Text )
import qualified Data.Text as Text
( unpack )
-- transformers
import Control.Monad.Trans.RWS.CPS
( RWST )
import Control.Monad.Trans.Except
( ExceptT )
-- MetaBrush
import Math.Bezier.Spline
( Spline(..), Curve(..), Curves(..)
, SSplineType(..), SplineTypeI(ssplineType)
, bitraverseCurve, KnownSplineType(bitraverseSpline)
, NextPoint(..)
)
import Math.Vector2D
( Point2D(..) )
import MetaBrush.MetaParameter.AST
( Span(..), Located(..)
, Pass(Rn,Tc)
, Pat(..), Decl(..)
, X_With(..), MapFields
, UniqueTerm, UniqueField(..), IsUniqueTerm, IsUniqueTerm2
, SType(..), STypeI(sTypeI), SomeSType(..)
, STypes(..), STypesI(..)
, Term(..), TypedTerm(..), eqTy
, termSpan
)
import MetaBrush.MetaParameter.Rename
( Env(..), UniqueName(..) )
import MetaBrush.Unique
( UniqueSupply, MonadUnique, Unique )
--------------------------------------------------------------------------------
typeCheckAt
:: forall ( a :: Type ) m
. ( STypeI a, MonadTc m )
=> Text
-> Term Rn '() -> m ( Term Tc a )
typeCheckAt mismatchMessage term = do
TypedTerm ( x :: Term Tc x ) <- typeCheck term
case eqTy @a @x of
Just Refl -> pure x
Nothing ->
tcError $
UnexpectedType
mismatchMessage
( "Expected: ", SomeSType ( proxy# :: Proxy# a ) )
( " Actual: ", Located ( termSpan term ) $ SomeSType ( proxy# :: Proxy# x ) )
typeCheck :: forall m. MonadTc m => Term Rn '() -> m TypedTerm
typeCheck ( uf :$ ua ) = do
TypedTerm ( f :: Term Tc f ) <- typeCheck uf
case sTypeI @f of
sFunTy@SFunTy | ( _ :: SType ( b -> c ) ) <- sFunTy
-> do
TypedTerm ( a :: Term Tc a ) <- typeCheck ua
case eqTy @a @b of
Just Refl -> pure ( TypedTerm @c ( f :$ a ) )
Nothing -> tcError $
UnexpectedType
"Unexpected function argument type"
( "Expected: ", SomeSType ( proxy# :: Proxy# b ) )
( " Actual: ", Located ( termSpan ua ) $ SomeSType ( proxy# :: Proxy# a ) )
_ -> tcError $
OverSaturatedFunctionApplication
( Located ( termSpan uf ) ( SomeSType ( proxy# :: Proxy# f ) ) )
( termSpan ua )
typeCheck ( Var locVar@( Located _ ( UniqueName _ uniq ) ) ) = do
mbType <- use ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq )
case mbType of
Just ( SomeSType ( _ :: Proxy# a ) ) -> pure ( TypedTerm ( Var locVar :: Term Tc a ) )
Nothing -> tcError ( OutOfScope locVar )
typeCheck ( Let loc decls body ) = do
decls' <- typeCheckDecls decls
TypedTerm body' <- typeCheck body
pure ( TypedTerm $ Let loc decls' body' )
typeCheck ( With locs ( Rn_With decls ) conds body ) = do
decls' <- typeCheckDecls decls
conds' <- traverse ( typeCheckAt @Bool "Expected Boolean condition, but expression has the wrong type." ) conds
TypedTerm body' <- typeCheck body
withDeclsRecord decls' \ ( decls'Record :: Super.Rec ( MapFields UniqueTerm kvs ) ) -> do
case unsafeCoerce Refl :: SuperRecord.RecSize ( MapFields UniqueTerm kvs ) :~: SuperRecord.RecSize kvs of
Refl ->
case treeArgsDict @kvs @kvs of
RecTreeArgsDict ->
TypedTerm $ With locs ( Tc_With decls'Record ) conds' body'
typeCheck ( Lit loc a ) = pure ( TypedTerm $ Lit loc a )
typeCheck ( Op locs nm op ) = pure ( TypedTerm $ Op locs nm op )
typeCheck ( Point locs a b ) = do
TypedTerm ( a' :: Term Tc a ) <- typeCheck a
TypedTerm ( b' :: Term Tc b ) <- typeCheck b
case eqTy @a @b of
Just Refl -> pure ( TypedTerm $ Point locs a' b' )
Nothing ->
tcError $
MismatchedTypes
"Components of a point with different types."
( "1st component: ", Located ( termSpan a ) ( SomeSType ( proxy# :: Proxy# a ) ) )
( "2nd component: ", Located ( termSpan b ) ( SomeSType ( proxy# :: Proxy# b ) ) )
typeCheck ( Line {} ) = error "typeCheck: error, unexpected 'line'"
typeCheck ( Bez2 {} ) = error "typeCheck: error, unexpected 'bez2'"
typeCheck ( Bez3 {} ) = error "typeCheck: error, unexpected 'bez3'"
typeCheck ( PolyBez locs spline@( Spline { splineStart, splineCurves } :: Spline clo [ Located () ] ( Term Rn '() ) ) ) = do
TypedTerm ( start' :: Term Tc pt ) <- typeCheck splineStart
case sTypeI @pt of
sTy@STyPoint
| ( _ :: SType ( Point2D a ) ) <- sTy
-> case sTypeI @a of
STyDouble -> let
tcPoint :: Term Rn '() -> m ( Term Tc pt )
tcPoint = typeCheckAt @pt "Unexpected Bézier spline coordinate type"
in case ssplineType @clo of
SClosed -> do
spline' <-
bitraverseSpline
( const $ bitraverseCurve pure ( const tcPoint ) ) tcPoint spline
pure ( TypedTerm $ PolyBez locs spline' )
SOpen -> case splineCurves of
OpenCurves Empty ->
pure ( TypedTerm $ PolyBez locs ( Spline start' ( OpenCurves Empty ) ) )
OpenCurves ( crv :<| Empty ) -> case crv of
LineTo ( NextPoint p1 ) _ -> do
p1' <- tcPoint p1
pure ( TypedTerm $ Line locs start' p1' )
Bezier2To p1 ( NextPoint p2 ) _ -> do
p1' <- tcPoint p1
p2' <- tcPoint p2
pure ( TypedTerm $ Bez2 locs start' p1' p2' )
Bezier3To p1 p2 ( NextPoint p3 ) _ -> do
p1' <- tcPoint p1
p2' <- tcPoint p2
p3' <- tcPoint p3
pure ( TypedTerm $ Bez3 locs start' p1' p2' p3' )
OpenCurves crvs -> do
crvs' <- traverse ( traverse tcPoint ) crvs
pure ( TypedTerm $ PolyBez locs ( Spline start' ( OpenCurves crvs' ) ) )
_ ->
tcError $
UnexpectedType
"Unexpected Bézier spline coordinate type"
( "Expected: ", SomeSType ( proxy# :: Proxy# Double ) )
( " Actual: ", Located ( termSpan splineStart ) $ SomeSType ( proxy# :: Proxy# a ) )
_ -> tcError $
UnexpectedType
"Unexpected Bézier spline point type"
( "Expected: ", SomeSType ( proxy# :: Proxy# ( Point2D Double ) ) )
( " Actual: ", Located ( termSpan splineStart ) $ SomeSType ( proxy# :: Proxy# pt ) )
typeCheckDecls :: forall m. MonadTc m => [ Decl Rn ] -> m [ Decl Tc ]
typeCheckDecls = go []
where
go :: [ Decl Tc ] -> [ Decl Rn ] -> m [ Decl Tc ]
go dones [] = pure dones
go dones todos = do
( not_oks, oks ) <-
partitionEithers
<$> traverse
( \ decl -> ( `catchError` ( catchOutOfScope decl ) ) ( fmap Right $ typeCheckDecl decl ) )
todos
case oks of
[] -> traverse ( throwError . snd ) not_oks
_ -> go ( dones ++ oks ) ( fmap fst not_oks )
catchOutOfScope :: Decl Rn -> TcError -> m ( Either ( Decl Rn, TcError ) ( Decl Tc ) )
catchOutOfScope decl err@( OutOfScope {} ) = pure ( Left ( decl, err ) )
catchOutOfScope _ err = throwError err
typeCheckDecl :: MonadTc m => Decl Rn -> m ( Decl Tc )
typeCheckDecl ( Decl loc lhs rhs ) = do
TypedTerm ( rhs' :: Term Tc a ) <- typeCheck rhs
lhs' <- typeCheckPatAt @a lhs
pure ( Decl loc lhs' rhs' )
typeCheckPatAt :: forall ( a :: Type ) m. ( STypeI a, MonadTc m ) => Pat Rn '() -> m ( Pat Tc a )
typeCheckPatAt ( PName nm@( Located _ ( UniqueName _ uniq ) ) ) = do
assign ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq ) ( Just $ SomeSType ( proxy# :: Proxy# a ) )
pure ( PName nm )
typeCheckPatAt ( PPoint locs pat1 pat2 ) = case sTypeI @a of
sTyPair@STyPoint | ( _ :: SType ( Point2D c ) ) <- sTyPair
-> do
pat1' <- typeCheckPatAt @c pat1
pat2' <- typeCheckPatAt @c pat2
pure ( PPoint locs pat1' pat2' )
_ -> tcError $
UnexpectedPatType
"RHS of let binding does not have the expected type"
( "Expected type: ", Located ( foldMap location locs ) $ SomeSType ( proxy# :: Proxy# ( Point2D Double ) ) )
( " Actual type: ", SomeSType ( proxy# :: Proxy# a ) )
typeCheckPatAt ( PWild nm ) = pure ( PWild nm )
typeCheckPatAt ( AsPat symbLoc nm@( Located _ ( UniqueName _ uniq ) ) pat ) = do
pat' <- typeCheckPatAt @a pat
assign ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq ) ( Just $ SomeSType ( proxy# :: Proxy# a ) )
pure ( AsPat symbLoc nm pat' )
withDeclsRecord
:: forall r m
. ( MonadTc m )
=> [ Decl Tc ]
-> ( forall kvs. STypesI kvs => Super.Rec ( MapFields UniqueTerm kvs ) -> r )
-> m r
withDeclsRecord decls f = do
TypedTermsRecord record <- go ( TypedTermsRecord $ SuperRecord.unsafeRNil lg ) <$> ( revSortDecls decls )
pure ( f record )
where
lg :: Int
lg = length decls
-- This list cannot have duplicate names,
-- as these would have been caught by the renamer.
-- Sort in reverse order as we must add elements in decreasing label order.
revSortDecls :: [ Decl Tc ] -> m [ ( Text, ( UniqueName, TypedTerm ) ) ]
revSortDecls = fmap ( sortBy ( flip $ comparing fst ) ) . traverse getDeclName
getDeclName :: Decl Tc -> m ( Text, ( UniqueName, TypedTerm ) )
getDeclName ( Decl ( Located loc _ ) pat term ) = case pat of
PName ( Located _ uniq@( UniqueName nm _ ) ) -> pure ( nm, ( uniq, TypedTerm term ) )
AsPat _ ( Located _ uniq@( UniqueName nm _ ) ) _ -> pure ( nm, ( uniq, TypedTerm term ) )
_ -> tcError $ NoPatternName loc
go :: TypedTermsRecord -> [ ( Text, ( UniqueName, TypedTerm ) ) ] -> TypedTermsRecord
go record [] = record
go ( TypedTermsRecord ( record :: Super.Rec ( MapFields UniqueTerm kvs ) ) )
( ( nm, ( uniq, TypedTerm ( t :: Term Tc a ) ) ) : ps )
= case someSymbolVal ( Text.unpack nm ) of
SomeSymbol ( _ :: Proxy nm ) ->
go
( TypedTermsRecord @( ( nm SuperRecord.:= a ) ': kvs )
$ SuperRecord.unsafeRCons @nm @( UniqueTerm a ) @( MapFields UniqueTerm kvs )
( SuperRecord.FldProxy @nm SuperRecord.:= Compose ( UniqueField uniq t ) )
record
)
ps
data TypedTermsRecord where
TypedTermsRecord
:: ( STypesI kvs, ts ~ MapFields UniqueTerm kvs, KnownNat ( SuperRecord.RecSize ts ) )
=> Super.Rec ts -> TypedTermsRecord
data RecTreeArgsDict rts lts where
RecTreeArgsDict
:: forall rts lts trts tlts frts flts
. ( trts ~ MapFields UniqueTerm rts, tlts ~ MapFields UniqueTerm lts
, frts ~ MapFields UniqueField rts, flts ~ MapFields UniqueField lts
, SuperRecord.RecApply trts tlts IsUniqueTerm
, SuperRecord.TraversalCHelper flts trts frts IsUniqueTerm2
)
=> RecTreeArgsDict rts lts
treeArgsDict
:: forall rts lts trts tlts frts flts
. ( trts ~ MapFields UniqueTerm rts, tlts ~ MapFields UniqueTerm lts
, frts ~ MapFields UniqueField rts, flts ~ MapFields UniqueField lts
, STypesI lts
, KnownNat ( SuperRecord.RecSize rts )
)
=> RecTreeArgsDict rts lts
treeArgsDict = case sTypesI @lts of
STyNil
| Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize frts :~: SuperRecord.RecSize rts )
-> RecTreeArgsDict
sTyCons@STyCons
| ( _ :: STypes ( ( l SuperRecord.:= v ) ': lvs ) ) <- sTyCons
, Refl <- ( unsafeCoerce Refl :: MapFields UniqueTerm lvs :~: SuperRecord.RemoveAccessTo l ( MapFields UniqueTerm lvs ) )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy l trts :~: Just ( UniqueTerm v ) )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos l trts :~: SuperRecord.RecSize lvs )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize trts :~: SuperRecord.RecSize rts )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize lvs :~: SuperRecord.RecSize ( MapFields UniqueField lvs ) )
-> case treeArgsDict @rts @lvs of
RecTreeArgsDict -> RecTreeArgsDict
--------------------------------------------------------------------------------
-- Type-checker-specific data and instances.
data TcLocalEnv
= TcLocalEnv
deriving stock ( Show, Generic )
data TcGlobalEnv
= TcGlobalEnv
{ tcGlobalVarTys :: !( Map Unique SomeSType )
, tyGlovalVars :: !( Map Unique ( Located Text ) )
}
deriving stock ( Show, Generic )
data TcMessage
= TcWarningMessage
{ tcWarningMessage :: !TcWarning
, tcMessageState :: !TcState
}
| TcErrorMessage
{ tcErrorMessage :: !TcError
, tcMessageState :: !TcState
}
deriving stock ( Show, Generic )
data TcError
= MismatchedTypes
{ additionalErrorText :: !Text
, expectedLType :: !( Text, Located SomeSType )
, actualLType :: !( Text, Located SomeSType )
}
| UnexpectedType
{ additionalErrorText :: !Text
, expectedType :: !( Text, SomeSType )
, actualLType :: !( Text, Located SomeSType )
}
| UnexpectedPatType
{ additionaLErrorText :: !Text
, expectedPatType :: !( Text, Located SomeSType )
, actualRHSType :: !( Text, SomeSType )
}
| OverSaturatedFunctionApplication
{ functionLType :: !( Located SomeSType )
, argument :: !Span
}
| NoPatternName
{ declarationSpan :: !Span
}
| OutOfScope
{ outOfScopeVar :: !( Located UniqueName ) }
deriving stock ( Show, Generic )
data TcWarning = TcWarning
deriving stock ( Show, Generic )
type TcState = Env TcGlobalEnv TcLocalEnv
emptyTcState :: TcState
emptyTcState = Env ( TcGlobalEnv mempty mempty ) TcLocalEnv
type TcM = ExceptT TcError ( RWST UniqueSupply ( DList TcMessage ) TcState IO )
type MonadTc m =
( MonadUnique m
, MonadState TcState m
, MonadWriter ( DList TcMessage ) m
, MonadError TcError m
)
tcError
:: ( MonadError TcError m )
=> TcError -> m a
tcError err = throwError err
{-
tcWarning
:: ( MonadState TcState m, MonadWriter ( DList TcMessage ) m )
=> TcWarning -> m ()
tcWarning warn = do
st <- get
tell ( DList.singleton $ TcWarningMessage warn st )
-}

433
src/app/MetaBrush/Render/Document.hs
View file

@ -5,13 +5,16 @@
{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module MetaBrush.Render.Document module MetaBrush.Render.Document
( renderDocument, blankRender ) ( renderDocument, blankRender )
@ -28,8 +31,8 @@ import Data.Functor.Compose
( Compose(..) ) ( Compose(..) )
import Data.Int import Data.Int
( Int32 ) ( Int32 )
import Data.Maybe import GHC.Exts
( catMaybes ) ( Proxy#, proxy# )
import GHC.Generics import GHC.Generics
( Generic, Generic1 ) ( Generic, Generic1 )
@ -44,8 +47,6 @@ import Data.Act
-- containers -- containers
import Data.Sequence import Data.Sequence
( Seq(..) ) ( Seq(..) )
import qualified Data.Sequence as Seq
( fromList )
import Data.Set import Data.Set
( Set ) ( Set )
@ -54,15 +55,21 @@ import Generic.Data
( Generically1(..) ) ( Generically1(..) )
-- generic-lens -- generic-lens
import Data.Generics.Product.Typed import Data.Generics.Product.Fields
( HasType ) ( field' )
-- gi-cairo-render -- gi-cairo-render
import qualified GI.Cairo.Render as Cairo import qualified GI.Cairo.Render as Cairo
-- lens -- lens
import Control.Lens import Control.Lens
( view ) ( view, set )
-- superrecord
import qualified SuperRecord as Super
( Rec )
import qualified SuperRecord
( Intersect, rnil )
-- transformers -- transformers
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
@ -77,8 +84,15 @@ import Math.Bezier.Cubic.Fit
( FitPoint(..), FitParameters ) ( FitPoint(..), FitParameters )
import qualified Math.Bezier.Quadratic as Quadratic import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..) ) ( Bezier(..) )
import Math.Bezier.Spline
( Spline(..), SplinePts, PointType(..)
, SplineType(..), SplineTypeI, KnownSplineType(bifoldSpline)
, Curve(..)
, fromNextPoint
, catMaybesSpline
)
import Math.Bezier.Stroke import Math.Bezier.Stroke
( StrokePoint(..), stroke ) ( CachedStroke(..), computeStrokeOutline )
import Math.Vector2D import Math.Vector2D
( Point2D(..), Vector2D(..) ) ( Point2D(..), Vector2D(..) )
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
@ -90,15 +104,23 @@ import MetaBrush.Context
import MetaBrush.Document import MetaBrush.Document
( Document(..), DocumentContent(..) ( Document(..), DocumentContent(..)
, mkAABB , mkAABB
, Stroke(..), FocusState(..) , Stroke(..), StrokeSpline
, FocusState(..)
, HoverContext(..), Hoverable(..) , HoverContext(..), Hoverable(..)
, PointData(..), BrushPointData(..) , PointData(..), Brush(..), emptyBrush
, _selection , _selection
, coords
) )
import MetaBrush.Document.Selection import MetaBrush.Document.Selection
( dragUpdate ) ( dragUpdate )
import MetaBrush.Document.Serialise
( ) -- 'Serialisable' instances
import MetaBrush.Document.Update import MetaBrush.Document.Update
( DocChange(..) ) ( DocChange(..) )
import MetaBrush.MetaParameter.AST
( AdaptableFunction(..), BrushFunction )
import MetaBrush.MetaParameter.Interpolation
( MapDiff )
import MetaBrush.UI.ToolBar import MetaBrush.UI.ToolBar
( Mode(..) ) ( Mode(..) )
import MetaBrush.Util import MetaBrush.Util
@ -127,25 +149,32 @@ toAll action = Compose ( pure action )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
blankRender :: Colours -> Cairo.Render () blankRender :: Colours -> Cairo.Render ()
blankRender ( Colours {..} ) = pure () blankRender _ = pure ()
renderDocument renderDocument
:: Colours -> FitParameters -> Mode -> Bool -> ( Int32, Int32 ) :: Colours -> FitParameters -> Mode -> Bool -> ( Int32, Int32 )
-> Set Modifier -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath -> Set Modifier -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath
-> Document -> Document
-> Cairo.Render () -> ( Maybe Document, Cairo.Render () )
renderDocument renderDocument
cols params mode debug ( viewportWidth, viewportHeight ) cols fitParams mode debug ( viewportWidth, viewportHeight )
modifiers mbMousePos mbHoldEvent mbPartialPath modifiers mbMousePos mbHoldEvent mbPartialPath
doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content } ) doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content } )
= do = ( mbUpdatedDoc, drawingInstructions )
Cairo.save where
Cairo.translate ( 0.5 + 0.5 * fromIntegral viewportWidth ) ( 0.5 + 0.5 * fromIntegral viewportHeight )
Cairo.scale zoomFactor zoomFactor drawingInstructions :: Cairo.Render ()
Cairo.translate ( -cx ) ( -cy ) drawingInstructions = do
Cairo.save
Cairo.translate ( 0.5 + 0.5 * fromIntegral viewportWidth ) ( 0.5 + 0.5 * fromIntegral viewportHeight )
Cairo.scale zoomFactor zoomFactor
Cairo.translate ( -cx ) ( -cy )
for_ strokesWithOutlineInfo
( compositeRenders . getCompose . renderStroke cols mbHoverContext mode debug zoomFactor )
renderSelectionRect
Cairo.restore
let
renderSelectionRect :: Cairo.Render () renderSelectionRect :: Cairo.Render ()
mbHoverContext :: Maybe HoverContext mbHoverContext :: Maybe HoverContext
( renderSelectionRect, mbHoverContext ) ( renderSelectionRect, mbHoverContext )
@ -156,16 +185,19 @@ renderDocument
= ( pure (), MouseHover <$> mbMousePos ) = ( pure (), MouseHover <$> mbMousePos )
modifiedStrokes :: [ Stroke ] modifiedStrokes :: [ Stroke ]
modifiedStrokes noModifiedStrokes :: Bool
| Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent ( modifiedStrokes, noModifiedStrokes )
| PathMode <- mode
, Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent
, Just p1 <- mbMousePos , Just p1 <- mbMousePos
, p0 /= p1 , p0 /= p1
, let , let
alternateMode :: Bool alternateMode :: Bool
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
, Just docUpdate <- dragUpdate mode p0 p1 dragAction alternateMode doc , Just docUpdate <- dragUpdate p0 p1 dragAction alternateMode doc
= strokes . documentContent $ newDocument docUpdate = ( strokes . documentContent $ newDocument docUpdate, False )
| Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath | PathMode <- mode
, Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath
, let , let
mbFinalPoint :: Maybe ( Point2D Double ) mbFinalPoint :: Maybe ( Point2D Double )
mbControlPoint :: Maybe ( Point2D Double ) mbControlPoint :: Maybe ( Point2D Double )
@ -176,139 +208,210 @@ renderDocument
= ( mbMousePos, Nothing ) = ( mbMousePos, Nothing )
, Just finalPoint <- mbFinalPoint , Just finalPoint <- mbFinalPoint
, let , let
previewPts :: Seq ( StrokePoint PointData ) previewSpline :: Spline Open CachedStroke ( PointData ( Super.Rec '[] ) )
previewPts previewSpline = catMaybesSpline ( CachedStroke Nothing )
= Seq.fromList ( PointData p0 Normal SuperRecord.rnil )
$ catMaybes ( do
[ Just ( PathPoint p0 ( PointData Normal Empty ) )
, do
cp <- cp0 cp <- cp0
guard ( cp /= p0 ) guard ( cp /= p0 )
pure $ ControlPoint cp ( PointData Normal Empty ) pure ( PointData cp Normal SuperRecord.rnil )
, do )
( do
cp <- mbControlPoint cp <- mbControlPoint
guard ( cp /= finalPoint ) guard ( cp /= finalPoint )
pure $ ControlPoint cp ( PointData Normal Empty ) pure ( PointData cp Normal SuperRecord.rnil )
, Just ( PathPoint finalPoint ( PointData Normal Empty ) ) )
] ( PointData finalPoint Normal SuperRecord.rnil )
= ( Stroke { strokePoints = previewPts, strokeVisible = True, strokeUnique = undefined, strokeName = undefined } ) = ( ( Stroke
: strokes content { strokeSpline = previewSpline
, strokeVisible = True
, strokeUnique = undefined
, strokeName = undefined
, strokeBrush = emptyBrush
}
)
: strokes content
, False
)
| otherwise | otherwise
= strokes content = ( strokes content, True )
for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols mbHoverContext params mode debug zoomFactor )
renderSelectionRect
Cairo.restore strokesWithOutlineInfo :: [ ( Stroke, Maybe ( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed ), Seq FitPoint ) ) ]
strokesWithOutlineInfo =
pure () fmap
( \ stroke@(
Stroke
{ strokeSpline = spline :: StrokeSpline clo ( Super.Rec pointFields )
, strokeBrush =
strokeBrush@(
BrushData { brushFunction = ( AdaptableFunction brushFn ) :: BrushFunction brushFields }
)
, ..
} ) ->
if strokeVisible
then
case ( proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields ) ) of
( _ :: Proxy# usedFields ) ->
let
-- Get the adaptable brush shape (function),
-- specialising it to the type we are using.
toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields
brushShapeFn :: Super.Rec usedFields -> SplinePts Closed
( toUsedParams, brushShapeFn ) = brushFn @pointFields @usedFields
renderStroke :: Colours -> Maybe HoverContext -> FitParameters -> Mode -> Bool -> Double -> Stroke -> Compose Renders Cairo.Render () -- Compute the outline using the brush function.
renderStroke cols@( Colours { brush } ) mbHoverContext params mode debug zoom ( Stroke { strokePoints = pts, strokeVisible } ) newSpline :: Spline clo CachedStroke ( PointData ( Super.Rec pointFields ) )
| strokeVisible outline :: Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
= renderStrokePoints cols mode mbHoverContext zoom fitPts :: Seq FitPoint
( when ( mode == Brush ) . renderBrushShape ( cols { path = brush } ) mbHoverContext ( 1.5 * zoom ) ) ( newSpline, outline, fitPts ) =
pts computeStrokeOutline @( Super.Rec ( MapDiff usedFields ) ) @clo @( Super.Rec usedFields )
*> Compose blank { renderStrokes = drawStroke cols debug zoom ( stroke params pts ) } fitParams ( toUsedParams . brushParams ) brushShapeFn spline
| otherwise in ( Stroke { strokeSpline = newSpline, .. } , Just ( outline, fitPts ) )
= pure () else ( stroke , Nothing )
)
modifiedStrokes
mbUpdatedDoc :: Maybe Document
mbUpdatedDoc
| noModifiedStrokes
= let
newDoc :: Document
newDoc =
set ( field' @"documentContent" . field' @"strokes" )
( modifiedStrokes )
doc
in Just newDoc
| otherwise
= Nothing -- TODO: update the original document in this case too (by undoing the modifications)
renderStroke
:: Colours -> Maybe HoverContext -> Mode -> Bool -> Double
-> ( Stroke, Maybe ( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed ), Seq FitPoint ) )
-> Compose Renders Cairo.Render ()
renderStroke cols@( Colours { brush } ) mbHoverContext mode debug zoom
( Stroke
{ strokeSpline = strokeSpline :: StrokeSpline clo ( Super.Rec pointFields )
, strokeVisible
, strokeBrush = BrushData { brushFunction = ( AdaptableFunction brushFn ) :: BrushFunction brushFields }
}
, mbOutlineData )
| strokeVisible
, ( _ :: Proxy# usedFields ) <- proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields )
, let
-- Get the adaptable brush shape (function),
-- specialising it to the type we are using.
toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields
brushShapeFn :: Super.Rec usedFields -> SplinePts Closed
( toUsedParams, brushShapeFn ) = brushFn @pointFields @usedFields
= renderStrokeSpline cols mode mbHoverContext zoom
( when ( mode == BrushMode ) . renderBrushShape ( cols { path = brush } ) mbHoverContext ( 1.5 * zoom ) ( brushShapeFn . toUsedParams ) )
strokeSpline
*> for_ mbOutlineData \outlineData ->
Compose blank { renderStrokes = drawOutline cols debug zoom outlineData }
| otherwise
= pure ()
-- | Render a sequence of stroke points. -- | Render a sequence of stroke points.
-- --
-- Accepts a sub-function for additional rendering of each stroke point -- Accepts a sub-function for additional rendering of each stroke point
-- (e.g. overlay a brush shape over each stroke point). -- (e.g. overlay a brush shape over each stroke point).
renderStrokePoints renderStrokeSpline
:: forall d :: forall clo crvData pointData
. ( Show d, HasType FocusState d ) . ( Show pointData, KnownSplineType clo )
=> Colours -> Mode -> Maybe HoverContext -> Double => Colours -> Mode -> Maybe HoverContext -> Double
-> ( StrokePoint d -> Compose Renders Cairo.Render () ) -> ( PointData pointData -> Compose Renders Cairo.Render () )
-> Seq ( StrokePoint d ) -> Spline clo crvData ( PointData pointData )
-> Compose Renders Cairo.Render () -> Compose Renders Cairo.Render ()
renderStrokePoints _ _ _ _ _ Empty = pure () renderStrokeSpline cols mode mbHover zoom renderSubcontent spline =
renderStrokePoints cols mode mbHover zoom renderSubcontent ( pt0 :<| pts ) = bifoldSpline ( renderSplineCurve ( splineStart spline ) ) renderSplinePoint spline
Compose blank { renderPPts = when ( mode == Path ) $ drawPoint cols mbHover zoom pt0 }
*> renderSubcontent pt0
*> go pt0 pts
where
go :: StrokePoint d -> Seq ( StrokePoint d ) -> Compose Renders Cairo.Render ()
go _ Empty = pure ()
go ( ControlPoint {} ) _ = error "renderStrokePoints: path starts with a control point"
-- Line.
go p0 ( p1 :<| ps )
| PathPoint {} <- p1
= Compose blank
{ renderPPts
= when ( mode == Path ) $ drawPoint cols mbHover zoom p1
, renderPath
= unless ( mode == Meta ) $ drawLine cols zoom p0 p1
}
*> renderSubcontent p1
*> go p1 ps
-- Quadratic Bézier curve.
go p0 ( p1 :<| p2 :<| ps )
| ControlPoint {} <- p1
, PathPoint {} <- p2
= Compose blank
{ renderCLines
= when ( mode == Path ) do
drawLine cols zoom p0 p1
drawLine cols zoom p1 p2
, renderCPts
= when ( mode == Path ) $ drawPoint cols mbHover zoom p1
, renderPPts
= when ( mode == Path ) $ drawPoint cols mbHover zoom p2
, renderPath
= unless ( mode == Meta ) $ drawQuadraticBezier cols zoom ( coords <$> Quadratic.Bezier { p0, p1, p2 } )
}
*> renderSubcontent p1
*> renderSubcontent p2
*> go p2 ps
-- Cubic Bézier curve.
go p0 ( p1 :<| p2 :<| p3 :<| ps )
| ControlPoint {} <- p1
, ControlPoint {} <- p2
, PathPoint {} <- p3
= Compose blank
{ renderCLines
= when ( mode == Path ) do
drawLine cols zoom p0 p1
drawLine cols zoom p2 p3
, renderCPts
= when ( mode == Path ) do
drawPoint cols mbHover zoom p1
drawPoint cols mbHover zoom p2
, renderPPts
= when ( mode == Path ) $ drawPoint cols mbHover zoom p3
, renderPath
= unless ( mode == Meta ) $ drawCubicBezier cols zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 } )
}
*> renderSubcontent p1
*> renderSubcontent p2
*> renderSubcontent p3
*> go p3 ps
go p0 ps = error $ "renderStroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
renderBrushShape :: Colours -> Maybe HoverContext -> Double -> StrokePoint PointData -> Compose Renders Cairo.Render () where
renderBrushShape cols mbHoverContext zoom pt = renderSplinePoint :: PointData pointData -> Compose Renders Cairo.Render ()
renderSplinePoint sp0
= Compose blank { renderPPts = when ( mode == PathMode ) $ drawPoint cols mbHover zoom PathPoint sp0 }
*> renderSubcontent sp0
renderSplineCurve
:: forall clo'
. SplineTypeI clo'
=> PointData pointData -> PointData pointData -> Curve clo' crvData ( PointData pointData ) -> Compose Renders Cairo.Render ()
renderSplineCurve start p0 ( LineTo np1 _ )
= Compose blank
{ renderPPts =
when ( mode == PathMode ) $
for_ np1 \ p1 ->
drawPoint cols mbHover zoom PathPoint p1
, renderPath =
unless ( mode == MetaMode ) $
drawLine cols zoom PathPoint p0 ( fromNextPoint start np1 )
}
*> for_ np1 \ p1 -> renderSubcontent p1
renderSplineCurve start p0 ( Bezier2To p1 np2 _ )
= Compose blank
{ renderCLines
= when ( mode == PathMode ) do
drawLine cols zoom ControlPoint p0 p1
drawLine cols zoom ControlPoint p1 ( fromNextPoint start np2 )
, renderCPts
= when ( mode == PathMode ) $ drawPoint cols mbHover zoom ControlPoint p1
, renderPPts
= when ( mode == PathMode ) $
for_ np2 \ p2 ->
drawPoint cols mbHover zoom PathPoint p2
, renderPath
= unless ( mode == MetaMode ) $ drawQuadraticBezier cols zoom ( coords <$> Quadratic.Bezier { p0, p1, p2 = fromNextPoint start np2 } )
}
*> renderSubcontent p1
*> for_ np2 \ p2 -> renderSubcontent p2
renderSplineCurve start p0 ( Bezier3To p1 p2 np3 _ )
= Compose blank
{ renderCLines
= when ( mode == PathMode ) do
drawLine cols zoom ControlPoint p0 p1
drawLine cols zoom ControlPoint p2 ( fromNextPoint start np3 )
, renderCPts
= when ( mode == PathMode ) do
drawPoint cols mbHover zoom ControlPoint p1
drawPoint cols mbHover zoom ControlPoint p2
, renderPPts
= when ( mode == PathMode ) $
for_ np3 \ p3 ->
drawPoint cols mbHover zoom PathPoint p3
, renderPath
= unless ( mode == MetaMode ) $ drawCubicBezier cols zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 = fromNextPoint start np3 } )
}
*> renderSubcontent p1
*> renderSubcontent p2
*> for_ np3 \ p3 -> renderSubcontent p3
renderBrushShape
:: Colours -> Maybe HoverContext -> Double
-> ( brushParams -> SplinePts Closed )
-> PointData brushParams
-> Compose Renders Cairo.Render ()
renderBrushShape cols mbHoverContext zoom brushFn pt =
let let
x, y :: Double x, y :: Double
Point2D x y = coords pt Point2D x y = coords pt
brushPts :: Seq ( StrokePoint BrushPointData ) brushPts :: SplinePts Closed
brushPts = brushShape ( pointData pt ) brushPts = brushFn ( brushParams pt )
mbHoverContext' :: Maybe HoverContext mbHoverContext' :: Maybe HoverContext
mbHoverContext' = Vector2D (-x) (-y) • mbHoverContext mbHoverContext' = Vector2D (-x) (-y) • mbHoverContext
in in
toAll do toAll do
Cairo.save Cairo.save
Cairo.translate x y Cairo.translate x y
*> renderStrokePoints cols Path mbHoverContext' zoom ( const $ pure () ) brushPts *> renderStrokeSpline cols PathMode mbHoverContext' zoom ( const $ pure () )
( fmap ( \ p -> PointData p Normal () ) brushPts )
*> Compose blank { renderPPts = drawCross cols zoom } *> Compose blank { renderPPts = drawCross cols zoom }
*> toAll Cairo.restore *> toAll Cairo.restore
drawPoint :: HasType FocusState d => Colours -> Maybe HoverContext -> Double -> StrokePoint d -> Cairo.Render () drawPoint :: Colours -> Maybe HoverContext -> Double -> PointType -> PointData brushData -> Cairo.Render ()
drawPoint ( Colours {..} ) mbHover zoom pt@( PathPoint { coords = Point2D x y } ) drawPoint ( Colours {..} ) mbHover zoom PathPoint pt
= do = do
let let
x, y :: Double
Point2D x y = coords pt
hsqrt3 :: Double hsqrt3 :: Double
hsqrt3 = sqrt 0.75 hsqrt3 = sqrt 0.75
selectionState :: FocusState selectionState :: FocusState
@ -340,9 +443,11 @@ drawPoint ( Colours {..} ) mbHover zoom pt@( PathPoint { coords = Point2D x y }
Cairo.restore Cairo.restore
drawPoint ( Colours {..} ) mbHover zoom pt@( ControlPoint { coords = Point2D x y } ) drawPoint ( Colours {..} ) mbHover zoom ControlPoint pt
= do = do
let let
x, y :: Double
Point2D x y = coords pt
selectionState :: FocusState selectionState :: FocusState
selectionState = view _selection pt <> hovered mbHover zoom ( Point2D x y ) selectionState = view _selection pt <> hovered mbHover zoom ( Point2D x y )
@ -369,8 +474,8 @@ drawPoint ( Colours {..} ) mbHover zoom pt@( ControlPoint { coords = Point2D x y
Cairo.restore Cairo.restore
drawLine :: Colours -> Double -> StrokePoint d -> StrokePoint d -> Cairo.Render () drawLine :: Colours -> Double -> PointType -> PointData b -> PointData b -> Cairo.Render ()
drawLine ( Colours { path, controlPoint } ) zoom p1 p2 = do drawLine ( Colours { path, controlPoint } ) zoom pointType p1 p2 = do
let let
x1, y1, x2, y2 :: Double x1, y1, x2, y2 :: Double
Point2D x1 y1 = coords p1 Point2D x1 y1 = coords p1
@ -380,11 +485,11 @@ drawLine ( Colours { path, controlPoint } ) zoom p1 p2 = do
Cairo.moveTo x1 y1 Cairo.moveTo x1 y1
Cairo.lineTo x2 y2 Cairo.lineTo x2 y2
case ( p1, p2 ) of case pointType of
( PathPoint {}, PathPoint {} ) -> do PathPoint -> do
Cairo.setLineWidth ( 5 / zoom ) Cairo.setLineWidth ( 5 / zoom )
withRGBA path Cairo.setSourceRGBA withRGBA path Cairo.setSourceRGBA
_ -> do ControlPoint -> do
Cairo.setLineWidth ( 3 / zoom ) Cairo.setLineWidth ( 3 / zoom )
withRGBA controlPoint Cairo.setSourceRGBA withRGBA controlPoint Cairo.setSourceRGBA
Cairo.stroke Cairo.stroke
@ -418,16 +523,16 @@ drawCubicBezier ( Colours { path } ) zoom
Cairo.restore Cairo.restore
drawStroke drawOutline
:: Colours -> Bool -> Double :: Colours -> Bool -> Double
-> ( Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ), Seq FitPoint ) -> ( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed ), Seq FitPoint )
-> Cairo.Render () -> Cairo.Render ()
drawStroke cols@( Colours {..} ) debug zoom strokeData = do drawOutline cols@( Colours {..} ) debug zoom strokeData = do
Cairo.save Cairo.save
withRGBA brushStroke Cairo.setSourceRGBA withRGBA brushStroke Cairo.setSourceRGBA
case strokeData of case strokeData of
( Left outline, fitPts ) -> do ( Left outline, fitPts ) -> do
go outline makeOutline outline
case debug of case debug of
False -> Cairo.fill False -> Cairo.fill
True -> do True -> do
@ -437,8 +542,8 @@ drawStroke cols@( Colours {..} ) debug zoom strokeData = do
Cairo.stroke Cairo.stroke
( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts ( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts
( Right ( fwd, bwd ), fitPts ) -> do ( Right ( fwd, bwd ), fitPts ) -> do
go fwd makeOutline fwd
go bwd makeOutline bwd
case debug of case debug of
False -> Cairo.fill False -> Cairo.fill
True -> do True -> do
@ -448,36 +553,30 @@ drawStroke cols@( Colours {..} ) debug zoom strokeData = do
Cairo.stroke Cairo.stroke
( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts ( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts
Cairo.restore Cairo.restore
where where
go :: Seq ( StrokePoint () ) -> Cairo.Render () makeOutline :: SplinePts Closed -> Cairo.Render ()
go ( p@( PP ( Point2D x y ) ) :<| ps ) = Cairo.moveTo x y *> go' p ps makeOutline spline = bifoldSpline
go _ = pure () ( drawCurve ( splineStart spline ) )
( \ ( Point2D x y ) -> Cairo.moveTo x y )
spline
go' :: StrokePoint () -> Seq ( StrokePoint () ) -> Cairo.Render () drawCurve :: forall clo. SplineTypeI clo => Point2D Double -> Point2D Double -> Curve clo () ( Point2D Double ) -> Cairo.Render ()
go' _ Empty = pure () drawCurve start ( Point2D x0 y0 ) crv = case crv of
-- Line. LineTo mp1 _ ->
go' _ ( p1@( PP ( Point2D x1 y1 ) ) :<| ps ) = let Point2D x1 y1 = fromNextPoint start mp1
do in Cairo.lineTo x1 y1
Cairo.lineTo x1 y1 Bezier2To ( Point2D x1 y1 ) mp2 _ ->
go' p1 ps let Point2D x2 y2 = fromNextPoint start mp2
-- Quadratic Bézier curve. in Cairo.curveTo
go' ( PP ( Point2D x0 y0 ) ) ( CP ( Point2D x1 y1 ) :<| p2@( PP ( Point2D x2 y2 ) ) :<| ps ) = ( ( 2 * x1 + x0 ) / 3 ) ( ( 2 * y1 + y0 ) / 3 )
do ( ( 2 * x1 + x2 ) / 3 ) ( ( 2 * y1 + y2 ) / 3 )
Cairo.curveTo x2 y2
( ( 2 * x1 + x0 ) / 3 ) ( ( 2 * y1 + y0 ) / 3 ) Bezier3To ( Point2D x1 y1 ) ( Point2D x2 y2 ) mp3 _ ->
( ( 2 * x1 + x2 ) / 3 ) ( ( 2 * y1 + y2 ) / 3 ) let Point2D x3 y3 = fromNextPoint start mp3
x2 y2 in Cairo.curveTo x1 y1 x2 y2 x3 y3
go' p2 ps
-- Cubic Bézier curve.
go' _ ( CP ( Point2D x1 y1 ) :<| CP ( Point2D x2 y2 ) :<| p3@( PP ( Point2D x3 y3 ) ) :<| ps ) =
do
Cairo.curveTo x1 y1 x2 y2 x3 y3
go' p3 ps
go' p0 ps = error $ "drawStroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
drawFitPoint :: Colours -> Double -> FitPoint -> StateT Double Cairo.Render () drawFitPoint :: Colours -> Double -> FitPoint -> StateT Double Cairo.Render ()
drawFitPoint ( Colours {..} ) zoom ( FitPoint { fitPoint = Point2D x y } ) = do drawFitPoint _ zoom ( FitPoint { fitPoint = Point2D x y } ) = do
hue <- get hue <- get
put ( hue + 0.01 ) put ( hue + 0.01 )
@ -492,7 +591,7 @@ drawFitPoint ( Colours {..} ) zoom ( FitPoint { fitPoint = Point2D x y } ) = do
Cairo.fill Cairo.fill
Cairo.restore Cairo.restore
drawFitPoint ( Colours {..} ) zoom ( FitTangent { fitPoint = Point2D x y, fitTangent = Vector2D tx ty } ) = do drawFitPoint _ zoom ( FitTangent { fitPoint = Point2D x y, fitTangent = Vector2D tx ty } ) = do
hue <- get hue <- get
put ( hue + 0.01 ) put ( hue + 0.01 )

8
src/app/MetaBrush/Render/Rulers.hs
View file

@ -230,7 +230,7 @@ renderRuler
start = truncateWith bigSpacing left start = truncateWith bigSpacing left
setTickRenderContext setTickRenderContext
traverse_ renderTickV $ traverse_ renderTickV $
[ Tick { .. } [ Tick {..}
| ( i :: Int ) <- [ 0, 1 .. ceiling ( ( right - start ) / smallSpacing ) ] | ( i :: Int ) <- [ 0, 1 .. ceiling ( ( right - start ) / smallSpacing ) ]
, let , let
( tickSize, tickHasLabel ) = subdivAt i increasingSubdivs ( tickSize, tickHasLabel ) = subdivAt i increasingSubdivs
@ -242,7 +242,7 @@ renderRuler
start = truncateWith bigSpacing top start = truncateWith bigSpacing top
setTickRenderContext setTickRenderContext
traverse_ renderTickH $ traverse_ renderTickH $
[ Tick { .. } [ Tick {..}
| ( i :: Int ) <- [ 0, 1 .. ceiling ( ( bottom - start ) / smallSpacing ) ] | ( i :: Int ) <- [ 0, 1 .. ceiling ( ( bottom - start ) / smallSpacing ) ]
, let , let
( tickSize, tickHasLabel ) = subdivAt i increasingSubdivs ( tickSize, tickHasLabel ) = subdivAt i increasingSubdivs
@ -250,7 +250,7 @@ renderRuler
] ]
renderTickV, renderTickH :: Tick -> Cairo.Render () renderTickV, renderTickH :: Tick -> Cairo.Render ()
renderTickV ( Tick { .. } ) = do renderTickV ( Tick {..} ) = do
Cairo.save Cairo.save
Cairo.translate tickPosition top Cairo.translate tickPosition top
Cairo.scale ( 1 / zoomFactor ) ( 1 / zoomFactor ) Cairo.scale ( 1 / zoomFactor ) ( 1 / zoomFactor )
@ -262,7 +262,7 @@ renderRuler
Cairo.moveTo 0 0 Cairo.moveTo 0 0
Cairo.showText ( show $ round @_ @Int tickPosition ) Cairo.showText ( show $ round @_ @Int tickPosition )
Cairo.restore Cairo.restore
renderTickH ( Tick { .. } ) = do renderTickH ( Tick {..} ) = do
Cairo.save Cairo.save
Cairo.translate left tickPosition Cairo.translate left tickPosition
Cairo.scale ( 1 / zoomFactor ) ( 1 / zoomFactor ) Cairo.scale ( 1 / zoomFactor ) ( 1 / zoomFactor )

92
src/app/MetaBrush/UI/Coordinates.hs
View file

@ -1,11 +1,20 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.UI.Coordinates module MetaBrush.UI.Coordinates
( toViewportCoordinates, closestPoint ) ( toViewportCoordinates, closestPoint )
where where
-- base -- base
import Data.Coerce
( coerce )
import Data.Functor.Identity
( Identity(..) )
import Data.Semigroup import Data.Semigroup
( ArgMin, Arg(..), Min(..) ) ( ArgMin, Arg(..), Min(..) )
@ -17,23 +26,23 @@ import Data.Act
( (-->) ) ( (-->) )
) )
-- containers
import Data.Sequence
( Seq(..) )
-- MetaBrush -- MetaBrush
import qualified Math.Bezier.Cubic as Cubic import qualified Math.Bezier.Cubic as Cubic
( Bezier(..), closestPoint ) ( Bezier(..), closestPoint )
import qualified Math.Bezier.Quadratic as Quadratic import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..), closestPoint ) ( Bezier(..), closestPoint )
import Math.Bezier.Stroke import Math.Bezier.Spline
( StrokePoint(..) ) ( Curve(..), Spline(..), SplineTypeI, KnownSplineType(bifoldSpline)
, fromNextPoint
)
import Math.Module import Math.Module
( (*^), squaredNorm, closestPointToSegment ) ( (*^), squaredNorm, closestPointOnSegment )
import Math.Vector2D import Math.Vector2D
( Point2D(..), Vector2D(..) ) ( Point2D(..), Vector2D(..), Segment(..) )
import MetaBrush.Document import MetaBrush.Document
( Stroke(..), PointData(..) ) ( Stroke(..), PointData(..)
, coords
)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -45,29 +54,40 @@ toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCente
-- | Find the closest point in a set of strokes. -- | Find the closest point in a set of strokes.
closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Maybe ( Point2D Double ) ) closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Maybe ( Point2D Double ) )
closestPoint c ( Stroke { strokePoints = pt0 :<| pts, strokeVisible = True } ) = go pt0 pts closestPoint c ( Stroke { strokeSpline, strokeVisible = True } ) =
coerce $
bifoldSpline @_ @Identity
( closestPointToCurve ( splineStart strokeSpline ) )
( res . coords )
strokeSpline
where where
res :: Point2D Double -> ArgMin Double ( Maybe ( Point2D Double ) ) res :: Point2D Double -> Identity ( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) )
res p = Min $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p ) res p = coerce $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p )
go :: StrokePoint PointData -> Seq ( StrokePoint PointData ) -> ArgMin Double ( Maybe ( Point2D Double ) )
go ( ControlPoint {} ) _ = error "closestPoint: path starts with a control point" closestPointToCurve
go p0 Empty = res ( coords p0 ) :: forall clo crvData brushParams
-- Line. . SplineTypeI clo
go ( PathPoint { coords = p0 } ) => PointData brushParams
( sp1@( PathPoint { coords = p1 } ) :<| ps ) -> PointData brushParams
= res ( snd $ closestPointToSegment @( Vector2D Double ) c p0 p1 ) -> Curve clo crvData ( PointData brushParams )
<> go sp1 ps -> Identity ( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) )
-- Quadratic Bézier curve. closestPointToCurve start p0 ( LineTo p1 _ ) =
go ( PathPoint { coords = p0 } ) res ( snd $ closestPointOnSegment @( Vector2D Double ) c ( Segment (coords p0 ) ( coords $ fromNextPoint start p1 ) ) )
( ControlPoint { coords = p1 } :<| sp2@( PathPoint { coords = p2 } ) :<| ps ) closestPointToCurve start p0 ( Bezier2To p1 p2 _ ) = coerce $
= fmap ( fmap ( Just . snd ) ) fmap ( fmap ( Just . snd ) )
( Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier {..} ) c ) ( Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier ( coords p0 ) ( coords p1 ) ( coords $ fromNextPoint start p2 ) ) c )
<> go sp2 ps closestPointToCurve start p0 ( Bezier3To p1 p2 p3 _ ) = coerce $
-- Cubic Bézier curve. fmap ( fmap ( Just . snd ) )
go ( PathPoint { coords = p0 } ) ( Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier ( coords p0 ) ( coords p1 ) ( coords p2 ) ( coords $ fromNextPoint start p3 ) ) c )
( PathPoint { coords = p1 } :<| PathPoint { coords = p2 } :<| sp3@( PathPoint { coords = p3 } ) :<| ps ) closestPoint _ _ = coerce $ mempty @( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) )
= fmap ( fmap ( Just . snd ) )
( Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier {..} ) c ) -- Messing around to emulate a `Monoid` instance for `ArgMin Double ( Maybe ( Point2D Double ) )`
<> go sp3 ps newtype BoundedDouble = BoundedDouble Double
go p0 ps = error $ "closestPoint: unrecognised stroke type\n" <> show ( p0 :<| ps ) deriving stock Show
closestPoint _ _ = Min $ Arg ( 1 / 0 ) Nothing deriving newtype ( Eq, Ord )
instance Bounded BoundedDouble where
minBound = BoundedDouble ( -1 / 0 )
maxBound = BoundedDouble ( 1 / 0 )
instance Bounded ( Arg BoundedDouble ( Maybe b ) ) where
minBound = Arg minBound Nothing
maxBound = Arg maxBound Nothing

8
src/app/MetaBrush/UI/FileBar.hs
View file

@ -44,6 +44,10 @@ import qualified Control.Concurrent.STM as STM
import qualified Control.Concurrent.STM.TVar as STM import qualified Control.Concurrent.STM.TVar as STM
( writeTVar, readTVar, readTVarIO, modifyTVar' ) ( writeTVar, readTVar, readTVarIO, modifyTVar' )
-- transformers
import Control.Monad.Trans.Reader
( runReaderT )
-- MetaBrush -- MetaBrush
import MetaBrush.Action import MetaBrush.Action
( SwitchTo(..), Close(..), handleAction ) ( SwitchTo(..), Close(..), handleAction )
@ -97,7 +101,7 @@ newFileTab
-> IO () -> IO ()
newFileTab newFileTab
initialStage initialStage
uiElts@( UIElements { fileBar = FileBar {..}, viewport = Viewport {..}, .. } ) uiElts@( UIElements { fileBar = FileBar {..}, .. } )
vars@( Variables {..} ) vars@( Variables {..} )
mbDocHist mbDocHist
newTabLoc newTabLoc
@ -108,7 +112,7 @@ newFileTab
Just docHist -> do pure docHist Just docHist -> do pure docHist
-- Create a new empty document. -- Create a new empty document.
Nothing -> do Nothing -> do
newDocUniq <- STM.atomically $ freshUnique uniqueSupply newDocUniq <- STM.atomically $ runReaderT freshUnique uniqueSupply
pure ( newHistory $ emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq ) pure ( newHistory $ emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq )
let let

12
src/app/MetaBrush/UI/ToolBar.hs
View file

@ -49,9 +49,9 @@ data Tool
deriving stock ( Show, Eq ) deriving stock ( Show, Eq )
data Mode data Mode
= Path = PathMode
| Brush | BrushMode
| Meta | MetaMode
deriving stock ( Show, Eq ) deriving stock ( Show, Eq )
data ToolBar data ToolBar
@ -82,13 +82,13 @@ createToolBar ( Variables {..} ) colours drawingArea toolBar = do
metaTool <- GTK.radioButtonNewFromWidget ( Just pathTool ) metaTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
_ <- GTK.onButtonClicked pathTool do _ <- GTK.onButtonClicked pathTool do
STM.atomically $ STM.writeTVar modeTVar Path STM.atomically $ STM.writeTVar modeTVar PathMode
GTK.widgetQueueDraw drawingArea GTK.widgetQueueDraw drawingArea
_ <- GTK.onButtonClicked brushTool do _ <- GTK.onButtonClicked brushTool do
STM.atomically $ STM.writeTVar modeTVar Brush STM.atomically $ STM.writeTVar modeTVar BrushMode
GTK.widgetQueueDraw drawingArea GTK.widgetQueueDraw drawingArea
_ <- GTK.onButtonClicked metaTool do _ <- GTK.onButtonClicked metaTool do
STM.atomically $ STM.writeTVar modeTVar Meta STM.atomically $ STM.writeTVar modeTVar MetaMode
GTK.widgetQueueDraw drawingArea GTK.widgetQueueDraw drawingArea

6
src/app/MetaBrush/UI/ToolBar.hs-boot
View file

@ -16,9 +16,9 @@ data Tool
instance Show Tool instance Show Tool
data Mode data Mode
= Path = PathMode
| Brush | BrushMode
| Meta | MetaMode
instance Show Mode instance Show Mode

50
src/app/MetaBrush/Unique.hs
View file

@ -1,13 +1,18 @@
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Unique module MetaBrush.Unique
( Unique, unsafeUnique ( MonadUnique(freshUnique)
, freshUnique, uniqueText , Unique, unsafeUnique
, uniqueText
, UniqueSupply, newUniqueSupply , UniqueSupply, newUniqueSupply
, uniqueMapFromList , uniqueMapFromList
) )
@ -41,9 +46,15 @@ import Data.Generics.Product.Typed
import Control.Lens import Control.Lens
( view ) ( view )
-- mtl
import Control.Monad.Reader
( MonadReader(..) )
-- stm -- stm
import Control.Concurrent.STM import Control.Concurrent.STM
( STM ) ( STM )
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TVar as STM import qualified Control.Concurrent.STM.TVar as STM
( TVar, newTVarIO, readTVar, writeTVar ) ( TVar, newTVarIO, readTVar, writeTVar )
@ -53,11 +64,19 @@ import Data.Text
import qualified Data.Text as Text import qualified Data.Text as Text
( pack ) ( pack )
-- transformers
import Control.Monad.IO.Class
( MonadIO(..) )
import Control.Monad.Trans.Class
( lift )
import Control.Monad.Trans.Reader
( ReaderT )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
newtype Unique = Unique { unique :: Int64 } newtype Unique = Unique { unique :: Int64 }
deriving stock Show deriving stock Show
deriving newtype ( Eq, Ord, Storable, NFData ) deriving newtype ( Eq, Ord, Enum, Storable, NFData )
unsafeUnique :: Word32 -> Unique unsafeUnique :: Word32 -> Unique
unsafeUnique i = Unique ( - fromIntegral i - 1 ) unsafeUnique i = Unique ( - fromIntegral i - 1 )
@ -71,14 +90,29 @@ uniqueText ( Unique i )
newtype UniqueSupply = UniqueSupply { uniqueSupplyTVar :: STM.TVar Unique } newtype UniqueSupply = UniqueSupply { uniqueSupplyTVar :: STM.TVar Unique }
freshUnique :: UniqueSupply -> STM Unique instance Show UniqueSupply where { show _ = "Unique supply" }
freshUnique ( UniqueSupply { uniqueSupplyTVar } ) = do
uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar
STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) )
pure uniq
newUniqueSupply :: IO UniqueSupply newUniqueSupply :: IO UniqueSupply
newUniqueSupply = UniqueSupply <$> STM.newTVarIO ( Unique 1 ) newUniqueSupply = UniqueSupply <$> STM.newTVarIO ( Unique 1 )
uniqueMapFromList :: HasType Unique a => [ a ] -> Map Unique a uniqueMapFromList :: HasType Unique a => [ a ] -> Map Unique a
uniqueMapFromList = Map.fromList . map ( view typed &&& id ) uniqueMapFromList = Map.fromList . map ( view typed &&& id )
class Monad m => MonadUnique m where
freshUnique :: m Unique
instance {-# OVERLAPPABLE #-} ( Monad m, MonadReader r m, HasType UniqueSupply r, MonadIO m ) => MonadUnique m where
freshUnique = do
UniqueSupply { uniqueSupplyTVar } <- view ( typed @UniqueSupply ) <$> ask
liftIO $ STM.atomically do
uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar
STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) )
pure uniq
instance MonadUnique ( ReaderT UniqueSupply STM ) where
freshUnique = do
UniqueSupply { uniqueSupplyTVar } <- ask
lift do
uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar
STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) )
pure uniq

2
src/lib/Math/Bezier/Cubic.hs
View file

@ -179,7 +179,7 @@ ddist ( Bezier {..} ) c = [ a5, a4, a3, a2, a1, a0 ]
closestPoint closestPoint
:: forall v r p. ( Torsor v p, Inner r v, RealFloat r, Prim r ) :: forall v r p. ( Torsor v p, Inner r v, RealFloat r, Prim r )
=> Bezier p -> p -> ArgMin r ( r, p ) => Bezier p -> p -> ArgMin r ( r, p )
closestPoint pts@( Bezier {..} ) c = pickClosest ( 0 :| 1 : roots ) -- todo: also include the self-intersection point if one exists closestPoint pts c = pickClosest ( 0 :| 1 : roots ) -- todo: also include the self-intersection point if one exists
where where
roots :: [ r ] roots :: [ r ]
roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots 2000 $ ddist @v pts c ) roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots 2000 $ ddist @v pts c )

35
src/lib/Math/Bezier/Cubic/Fit.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
@ -40,12 +41,16 @@ import Data.Act
import Data.Sequence import Data.Sequence
( Seq(..) ) ( Seq(..) )
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
( fromList, singleton ) ( fromList )
-- deepseq -- deepseq
import Control.DeepSeq import Control.DeepSeq
( NFData ) ( NFData )
-- parallel
import qualified Control.Parallel.Strategies as Parallel.Strategy
( rdeepseq, parTuple2, using )
-- primitive -- primitive
import Data.Primitive.PrimArray import Data.Primitive.PrimArray
( primArrayFromListN, unsafeThawPrimArray ) ( primArrayFromListN, unsafeThawPrimArray )
@ -67,6 +72,10 @@ import qualified Data.Vector.Unboxed as Unboxed.Vector
-- MetaBrush -- MetaBrush
import qualified Math.Bezier.Cubic as Cubic import qualified Math.Bezier.Cubic as Cubic
( Bezier(..), bezier, ddist ) ( Bezier(..), bezier, ddist )
import Math.Bezier.Spline
( SplineType(..), SplinePts
, openCubicBezierCurveSpline
)
import Math.Epsilon import Math.Epsilon
( epsilon ) ( epsilon )
import Math.Linear.Solve import Math.Linear.Solve
@ -119,7 +128,7 @@ data FitPoint
fitSpline fitSpline
:: FitParameters :: FitParameters
-> ( Double -> ( Point2D Double, Vector2D Double ) ) -- ^ curve \( t \mapsto ( C(t), C'(t) ) \) to fit -> ( Double -> ( Point2D Double, Vector2D Double ) ) -- ^ curve \( t \mapsto ( C(t), C'(t) ) \) to fit
-> ( Seq ( Cubic.Bezier ( Point2D Double ) ), Seq FitPoint ) -> ( SplinePts Open, Seq FitPoint )
fitSpline ( FitParameters {..} ) = go 0 fitSpline ( FitParameters {..} ) = go 0
where where
dt :: Double dt :: Double
@ -127,26 +136,32 @@ fitSpline ( FitParameters {..} ) = go 0
go go
:: Int :: Int
-> ( Double -> ( Point2D Double, Vector2D Double ) ) -> ( Double -> ( Point2D Double, Vector2D Double ) )
-> ( Seq ( Cubic.Bezier ( Point2D Double ) ), Seq FitPoint ) -> ( SplinePts Open, Seq FitPoint )
go subdiv curve = go subdiv curveFn =
let let
p, r :: Point2D Double p, r :: Point2D Double
tp, tr :: Vector2D Double tp, tr :: Vector2D Double
qs :: [ Point2D Double ] qs :: [ Point2D Double ]
(p, tp) = curve 0 (p, tp) = curveFn 0
(r, tr) = curve 1 (r, tr) = curveFn 1
qs = [ fst $ curve ( dt * fromIntegral j ) | j <- [ 1 .. nbSegments - 1 ] ] qs = [ fst $ curveFn ( dt * fromIntegral j ) | j <- [ 1 .. nbSegments - 1 ] ]
in in
case fitPiece dist_tol t_tol maxIters p tp qs r tr of case fitPiece dist_tol t_tol maxIters p tp qs r tr of
( bez, Max ( Arg max_sq_error t_split ) ) ( bez, Max ( Arg max_sq_error t_split ) )
| subdiv >= maxSubdiv | subdiv >= maxSubdiv
|| max_sq_error <= dist_tol ^ ( 2 :: Int ) || max_sq_error <= dist_tol ^ ( 2 :: Int )
-> ( Seq.singleton bez, ( FitTangent p tp :<| Seq.fromList ( map FitPoint qs ) ) :|> FitTangent r tr ) -> ( openCubicBezierCurveSpline () bez, ( FitTangent p tp :<| Seq.fromList ( map FitPoint qs ) ) :|> FitTangent r tr )
| let | let
t_split_eff :: Double t_split_eff :: Double
t_split_eff = min ( 1 - dt ) $ max dt t_split t_split_eff = min ( 1 - dt ) $ max dt t_split
-> go ( subdiv + 1 ) ( \ t -> curve $ t * t_split_eff ) c1, c2 :: SplinePts Open
<> go ( subdiv + 1 ) ( \ t -> curve $ t_split_eff + t * ( 1 - t_split_eff ) ) ps1, ps2 :: Seq FitPoint
( ( c1, ps1 ), ( c2, ps2 ) )
= ( go ( subdiv + 1 ) ( \ t -> curveFn $ t * t_split_eff )
, go ( subdiv + 1 ) ( \ t -> curveFn $ t_split_eff + t * ( 1 - t_split_eff ) )
) `Parallel.Strategy.using`
( Parallel.Strategy.parTuple2 Parallel.Strategy.rdeepseq Parallel.Strategy.rdeepseq )
-> ( c1 <> c2, ps1 <> ps2 )
-- | Fits a single cubic Bézier curve to the given data. -- | Fits a single cubic Bézier curve to the given data.
-- --

2
src/lib/Math/Bezier/Quadratic.hs
View file

@ -147,7 +147,7 @@ ddist ( Bezier {..} ) c = [ a3, a2, a1, a0 ]
closestPoint closestPoint
:: forall v r p. ( Torsor v p, Inner r v, RealFloat r, Prim r ) :: forall v r p. ( Torsor v p, Inner r v, RealFloat r, Prim r )
=> Bezier p -> p -> ArgMin r ( r, p ) => Bezier p -> p -> ArgMin r ( r, p )
closestPoint pts@( Bezier {..} ) c = pickClosest ( 0 :| 1 : roots ) closestPoint pts c = pickClosest ( 0 :| 1 : roots )
where where
roots :: [ r ] roots :: [ r ]
roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots 2000 $ ddist @v pts c ) roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots 2000 $ ddist @v pts c )

523
src/lib/Math/Bezier/Spline.hs Normal file
View file

@ -0,0 +1,523 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Math.Bezier.Spline where
-- base
import Data.Bifoldable
( Bifoldable(..) )
import Data.Bifunctor
( Bifunctor(..) )
import Data.Bitraversable
( Bitraversable(..) )
import Data.Coerce
( coerce )
import Data.Functor.Const
( Const(..) )
import Data.Functor.Identity
( Identity(..) )
import Data.Kind
( Constraint )
import Data.Monoid
( Ap(..) )
import Data.Semigroup
( First(..) )
import GHC.Generics
( Generic, Generic1 )
-- bifunctors
import qualified Data.Bifunctor.Tannen as Biff
( Tannen(..) )
-- containers
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( singleton, drop, splitAt )
-- deepseq
import Control.DeepSeq
( NFData, NFData1 )
-- generic-lens
import Data.Generics.Product.Fields
( field )
import Data.GenericLens.Internal
( set )
-- transformers
import Control.Monad.Trans.Class
( lift )
import Control.Monad.Trans.State.Strict
( StateT(runStateT), modify' )
-- MetaBrush
import qualified Math.Bezier.Cubic as Cubic
( Bezier(..) )
import Math.Vector2D
( Point2D )
--------------------------------------------------------------------------------
data PointType
= PathPoint
| ControlPoint
deriving stock Show
data SplineType = Open | Closed
data SSplineType ( clo :: SplineType ) where
SOpen :: SSplineType Open
SClosed :: SSplineType Closed
class ( Traversable ( NextPoint clo )
, forall crvData. Traversable ( Curves clo crvData )
, Bitraversable ( Curves clo )
, forall ptData. Show ptData => Show ( NextPoint clo ptData )
, forall ptData crvData. ( Show ptData, Show crvData ) => Show ( Curves clo crvData ptData )
, forall ptData. NFData ptData => NFData ( NextPoint clo ptData )
, forall ptData crvData. ( NFData ptData, NFData crvData ) => NFData ( Curves clo crvData ptData )
)
=> SplineTypeI ( clo :: SplineType ) where
-- | Singleton for the spline type
ssplineType :: SSplineType clo
instance SplineTypeI Open where
ssplineType = SOpen
instance SplineTypeI Closed where
ssplineType = SClosed
data family NextPoint ( clo :: SplineType ) ptData
newtype instance NextPoint Open ptData = NextPoint { nextPoint :: ptData }
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
deriving anyclass ( NFData, NFData1 )
data instance NextPoint Closed ptData = BackToStart
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
deriving anyclass ( NFData, NFData1 )
fromNextPoint :: forall clo ptData. SplineTypeI clo => ptData -> NextPoint clo ptData -> ptData
fromNextPoint pt nxt
| SOpen <- ssplineType @clo
= case nxt of { NextPoint q -> q }
| otherwise
= pt
toNextPoint :: forall clo ptData. SplineTypeI clo => ptData -> NextPoint clo ptData
toNextPoint pt = case ssplineType @clo of
SOpen -> NextPoint pt
SClosed -> BackToStart
data Curve ( clo :: SplineType ) crvData ptData
= LineTo
{ curveEnd :: !( NextPoint clo ptData )
, curveData :: !crvData
}
| Bezier2To
{ controlPoint :: !ptData
, curveEnd :: !( NextPoint clo ptData )
, curveData :: !crvData
}
| Bezier3To
{ controlPoint1 :: !ptData
, controlPoint2 :: !ptData
, curveEnd :: !( NextPoint clo ptData )
, curveData :: !crvData
}
deriving stock ( Generic, Generic1 )
deriving stock instance ( Show ptData, Show crvData, Show ( NextPoint clo ptData ) ) => Show ( Curve clo crvData ptData )
deriving anyclass instance ( NFData ptData, NFData crvData, NFData ( NextPoint clo ptData ) ) => NFData ( Curve clo crvData ptData )
deriving stock instance Functor ( NextPoint clo ) => Functor ( Curve clo crvData )
deriving stock instance Foldable ( NextPoint clo ) => Foldable ( Curve clo crvData )
deriving stock instance Traversable ( NextPoint clo ) => Traversable ( Curve clo crvData )
instance Functor ( NextPoint clo ) => Bifunctor ( Curve clo ) where
bimap f g ( LineTo np d ) = LineTo ( fmap g np ) ( f d )
bimap f g ( Bezier2To cp np d ) = Bezier2To ( g cp ) ( fmap g np ) ( f d )
bimap f g ( Bezier3To cp1 cp2 np d ) = Bezier3To ( g cp1 ) ( g cp2 ) ( fmap g np ) ( f d )
instance Foldable ( NextPoint clo ) => Bifoldable ( Curve clo ) where
bifoldMap f g ( LineTo np d ) = foldMap g np <> f d
bifoldMap f g ( Bezier2To cp np d ) = g cp <> foldMap g np <> f d
bifoldMap f g ( Bezier3To cp1 cp2 np d ) = g cp1 <> g cp2 <> foldMap g np <> f d
instance Traversable ( NextPoint clo ) => Bitraversable ( Curve clo ) where
bitraverse f g ( LineTo np d ) = LineTo <$> traverse g np <*> f d
bitraverse f g ( Bezier2To cp np d ) = Bezier2To <$> g cp <*> traverse g np <*> f d
bitraverse f g ( Bezier3To cp1 cp2 np d ) = Bezier3To <$> g cp1 <*> g cp2 <*> traverse g np <*> f d
openCurveEnd :: Curve Open crvData ptData -> ptData
openCurveEnd = nextPoint . curveEnd
openCurveStart :: Curve Open crvData ptData -> ptData
openCurveStart ( LineTo ( NextPoint p ) _ ) = p
openCurveStart ( Bezier2To p _ _ ) = p
openCurveStart ( Bezier3To p _ _ _ ) = p
data family Curves ( clo :: SplineType ) crvData ptData
newtype instance Curves Open crvData ptData
= OpenCurves { openCurves :: Seq ( Curve Open crvData ptData ) }
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
deriving newtype ( Semigroup, Monoid, NFData )
deriving via Biff.Tannen Seq ( Curve Open )
instance Bifunctor ( Curves Open )
deriving via Biff.Tannen Seq ( Curve Open )
instance Bifoldable ( Curves Open )
instance Bitraversable ( Curves Open ) where
bitraverse f g ( OpenCurves { openCurves = curves } )
= OpenCurves <$> traverse ( bitraverse f g ) curves
data instance Curves Closed crvData ptData
= NoCurves
| ClosedCurves
{ prevOpenCurves :: !( Seq ( Curve Open crvData ptData ) )
, lastClosedCurve :: !( Curve Closed crvData ptData )
}
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
deriving anyclass NFData
instance Bifunctor ( Curves Closed ) where
bimap _ _ NoCurves = NoCurves
bimap f g ( ClosedCurves p l ) = ClosedCurves ( fmap ( bimap f g ) p ) ( bimap f g l )
instance Bifoldable ( Curves Closed ) where
bifoldMap _ _ NoCurves = mempty
bifoldMap f g ( ClosedCurves p l ) = foldMap ( bifoldMap f g ) p <> bifoldMap f g l
instance Bitraversable ( Curves Closed ) where
bitraverse _ _ NoCurves = pure NoCurves
bitraverse f g ( ClosedCurves p l )
= ClosedCurves <$> ( traverse ( bitraverse f g ) p ) <*> bitraverse f g l
data Spline ( clo :: SplineType ) crvData ptData
= Spline
{ splineStart :: !ptData
, splineCurves :: !( Curves clo crvData ptData )
}
deriving stock ( Generic, Generic1 )
deriving stock instance ( Show ptData, Show ( Curves clo crvData ptData ) )
=> Show ( Spline clo crvData ptData )
deriving anyclass instance ( NFData ptData, NFData ( Curves clo crvData ptData ) )
=> NFData ( Spline clo crvData ptData )
deriving stock instance Functor ( Curves clo crvData ) => Functor ( Spline clo crvData )
deriving stock instance Foldable ( Curves clo crvData ) => Foldable ( Spline clo crvData )
deriving stock instance Traversable ( Curves clo crvData ) => Traversable ( Spline clo crvData )
instance KnownSplineType clo => Bifunctor ( Spline clo ) where
bimap fc fp = bimapSpline ( const $ bimap fc fp ) fp
instance KnownSplineType clo => Bifoldable ( Spline clo ) where
bifoldMap fc fp = runIdentity . bifoldSpline @_ @Identity ( const $ bifoldMap ( coerce fc ) ( coerce fp ) ) ( coerce fp )
instance KnownSplineType clo => Bitraversable ( Spline clo ) where
bitraverse fc fp = bitraverseSpline ( const $ bitraverse fc fp ) fp
type SplinePts clo = Spline clo () ( Point2D Double )
bimapCurve
:: Functor ( NextPoint clo )
=> ( crvData -> crvData' ) -> ( PointType -> ptData -> ptData' )
-> Curve clo crvData ptData -> Curve clo crvData' ptData'
bimapCurve f g ( LineTo p1 d ) = LineTo ( g PathPoint <$> p1 ) ( f d )
bimapCurve f g ( Bezier2To p1 p2 d ) = Bezier2To ( g ControlPoint p1 ) ( g PathPoint <$> p2 ) ( f d )
bimapCurve f g ( Bezier3To p1 p2 p3 d ) = Bezier3To ( g ControlPoint p1 ) ( g ControlPoint p2 ) ( g PathPoint <$> p3 ) ( f d )
bifoldMapCurve
:: forall m clo crvData ptData
. ( Monoid m, Foldable ( NextPoint clo ) )
=> ( crvData -> m ) -> ( PointType -> ptData -> m )
-> Curve clo crvData ptData -> m
bifoldMapCurve f g ( LineTo p1 d ) = ( foldMap ( g PathPoint ) p1 ) <> f d
bifoldMapCurve f g ( Bezier2To p1 p2 d ) = g ControlPoint p1 <> ( foldMap ( g PathPoint ) p2 ) <> f d
bifoldMapCurve f g ( Bezier3To p1 p2 p3 d ) = g ControlPoint p1 <> g ControlPoint p2 <> ( foldMap ( g PathPoint ) p3 ) <> f d
bitraverseCurve
:: forall f clo crvData crvData' ptData ptData'
. ( Applicative f, Traversable ( NextPoint clo ) )
=> ( crvData -> f crvData' ) -> ( PointType -> ptData -> f ptData' )
-> Curve clo crvData ptData -> f ( Curve clo crvData' ptData' )
bitraverseCurve f g ( LineTo p1 d ) = LineTo <$> traverse ( g PathPoint ) p1 <*> f d
bitraverseCurve f g ( Bezier2To p1 p2 d ) = Bezier2To <$> g ControlPoint p1 <*> traverse ( g PathPoint ) p2 <*> f d
bitraverseCurve f g ( Bezier3To p1 p2 p3 d ) = Bezier3To <$> g ControlPoint p1 <*> g ControlPoint p2 <*> traverse ( g PathPoint ) p3 <*> f d
dropCurves :: Int -> Spline Open crvData ptData -> Maybe ( Spline Open crvData ptData )
dropCurves i ( Spline { splineCurves = OpenCurves curves } ) = case Seq.drop ( i - 1 ) curves of
prev :<| next -> Just $ Spline { splineStart = openCurveEnd prev, splineCurves = OpenCurves next }
_ -> Nothing
splitSplineAt :: Int -> Spline Open crvData ptData -> ( Spline Open crvData ptData, Spline Open crvData ptData )
splitSplineAt i ( Spline { splineStart, splineCurves = OpenCurves curves } ) = case Seq.splitAt i curves of
( Empty, next ) ->
( Spline { splineStart, splineCurves = OpenCurves Empty }, Spline { splineStart, splineCurves = OpenCurves next } )
( prev@( _ :|> lastPrev ), next ) ->
( Spline { splineStart, splineCurves = OpenCurves prev }, Spline { splineStart = openCurveEnd lastPrev, splineCurves = OpenCurves next } )
reverseSpline :: forall crvData ptData. Spline Open crvData ptData -> Spline Open crvData ptData
reverseSpline spline@( Spline { splineStart = p0, splineCurves = OpenCurves curves } ) = case curves of
Empty -> spline
prev :|> lst -> Spline { splineStart = openCurveEnd lst, splineCurves = OpenCurves ( go prev lst ) }
where
go :: Seq ( Curve Open crvData ptData ) -> Curve Open crvData ptData -> Seq ( Curve Open crvData ptData )
go Empty ( LineTo _ dat ) = Empty :|> LineTo ( NextPoint p0 ) dat
go Empty ( Bezier2To p1 _ dat ) = Empty :|> Bezier2To p0 ( NextPoint p1 ) dat
go Empty ( Bezier3To p1 p2 _ dat ) = Empty :|> Bezier3To p0 p1 ( NextPoint p2 ) dat
go ( crvs :|> crv ) ( LineTo _ dat ) = go crvs crv :|> LineTo ( curveEnd crv ) dat
go ( crvs :|> crv ) ( Bezier2To p1 _ dat ) = go crvs crv :|> Bezier2To ( openCurveEnd crv ) ( NextPoint p1 ) dat
go ( crvs :|> crv ) ( Bezier3To p1 p2 _ dat ) = go crvs crv :|> Bezier3To ( openCurveEnd crv ) p1 ( NextPoint p2 ) dat
splineEnd :: Spline Open crvData ptData -> ptData
splineEnd ( Spline { splineStart, splineCurves = OpenCurves curves } ) = case curves of
Empty -> splineStart
_ :|> lastCurve -> openCurveEnd lastCurve
catMaybesSpline :: crvData -> ptData -> Maybe ptData -> Maybe ptData -> ptData -> Spline Open crvData ptData
catMaybesSpline dat p0 Nothing Nothing p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( LineTo ( NextPoint p3 ) dat ) }
catMaybesSpline dat p0 ( Just p1 ) Nothing p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To p1 ( NextPoint p3 ) dat ) }
catMaybesSpline dat p0 Nothing ( Just p2 ) p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To p2 ( NextPoint p3 ) dat ) }
catMaybesSpline dat p0 ( Just p1 ) ( Just p2 ) p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier3To p1 p2 ( NextPoint p3 ) dat ) }
-- | Connect two open curves.
--
-- It is assumed (not checked) that the end of the first curve is the start of the second curve.
instance Semigroup ( Spline Open crvData ptData ) where
spline1@( Spline { splineStart, splineCurves = segs1 } ) <> spline2@( Spline { splineCurves = segs2 } )
| null segs1 = spline2
| null segs2 = spline1
| otherwise = Spline { splineStart, splineCurves = segs1 <> segs2 }
-- | Create a curve containing a single (open) cubic Bézier segment.
openCubicBezierCurveSpline :: crvData -> Cubic.Bezier ptData -> Spline Open crvData ptData
openCubicBezierCurveSpline crvData ( Cubic.Bezier {..} )
= Spline
{ splineStart = p0
, splineCurves = OpenCurves . Seq.singleton $
Bezier3To
{ controlPoint1 = p1
, controlPoint2 = p2
, curveEnd = NextPoint p3
, curveData = crvData
}
}
-- | Drop the end of an open curve segment to create a "closed" curve (i.e. one that returns to the start).
dropCurveEnd :: Curve Open crvData ptData -> Curve Closed crvData ptData
dropCurveEnd ( LineTo _ dat ) = LineTo BackToStart dat
dropCurveEnd ( Bezier2To cp _ dat ) = Bezier2To cp BackToStart dat
dropCurveEnd ( Bezier3To cp1 cp2 _ dat ) = Bezier3To cp1 cp2 BackToStart dat
class SplineTypeI clo => KnownSplineType clo where
type TraversalCt clo ( clo' :: SplineType ) :: Constraint
-- | Last point of a spline.
lastPoint :: Spline clo crvData ptData -> ptData
-- | Close a spline if necessary.
adjustSplineType :: forall clo' crvData ptData. SplineTypeI clo' => Spline clo' crvData ptData -> Spline clo crvData ptData
-- | Indexed traversal of a spline.
ibitraverseSpline
:: forall f crvData ptData crvData' ptData'
. Applicative f
=> ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
=> Int -> ptData -> Curve clo' crvData ptData -> f ( Curve clo' crvData' ptData' )
)
-> ( ptData -> f ptData' )
-> Spline clo crvData ptData
-> f ( Spline clo crvData' ptData' )
-- | Bi-witherable traversal of a spline.
biwitherSpline
:: forall f crvData ptData crvData' ptData'
. Monad f
=> ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
=> Maybe ptData' -> Curve clo' crvData ptData -> f ( Maybe ( Curve clo' crvData' ptData' ) )
)
-> ( ptData -> f ( Maybe ptData' ) )
-> Spline clo crvData ptData
-> f ( Maybe ( Spline clo crvData' ptData' ) )
-- | Traversal of a spline.
bitraverseSpline
:: forall f crvData ptData crvData' ptData'
. Applicative f
=> ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
=> ptData -> Curve clo' crvData ptData -> f ( Curve clo' crvData' ptData' )
)
-> ( ptData -> f ptData' )
-> Spline clo crvData ptData
-> f ( Spline clo crvData' ptData' )
bitraverseSpline fc fp = ibitraverseSpline ( const fc ) fp
-- | Indexed fold of a spline.
ibifoldSpline
:: forall f m crvData ptData
. ( Applicative f, Monoid m )
=> ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
=> Int -> ptData -> Curve clo' crvData ptData -> f m
)
-> ( ptData -> f m )
-> Spline clo crvData ptData
-> f m
ibifoldSpline fc fp
= coerce
. ibitraverseSpline @clo @( Const ( Ap f m ) ) ( coerce fc ) ( coerce fp )
-- | Fold of a spline.
bifoldSpline
:: forall f m crvData ptData
. ( Applicative f, Monoid m )
=> ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
=> ptData -> Curve clo' crvData ptData -> f m )
-> ( ptData -> f m )
-> Spline clo crvData ptData
-> f m
bifoldSpline fc fp = ibifoldSpline ( const fc ) fp
-- | Bifunctor fmap of a spline.
bimapSpline
:: forall crvData ptData crvData' ptData'
. ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' )
=> ptData -> Curve clo' crvData ptData -> Curve clo' crvData' ptData'
)
-> ( ptData -> ptData' )
-> Spline clo crvData ptData
-> Spline clo crvData' ptData'
bimapSpline fc fp
= runIdentity
. bitraverseSpline @clo @Identity ( coerce fc ) ( coerce fp )
instance KnownSplineType Open where
type TraversalCt Open clo' = clo' ~ Open
lastPoint ( Spline { splineStart, splineCurves = OpenCurves curves } ) =
case curves of
Empty -> splineStart
_ :|> lastCurve -> openCurveEnd lastCurve
adjustSplineType :: forall clo' crvData ptData. SplineTypeI clo' => Spline clo' crvData ptData -> Spline Open crvData ptData
adjustSplineType spline@( Spline { splineStart, splineCurves } ) = case ssplineType @clo' of
SOpen -> spline
SClosed -> case splineCurves of
NoCurves -> Spline { splineStart, splineCurves = OpenCurves Empty }
ClosedCurves prev lst -> Spline { splineStart, splineCurves = OpenCurves $ prev :|> set ( field @"curveEnd" ) ( NextPoint splineStart ) lst }
ibitraverseSpline fc fp ( Spline { splineStart, splineCurves = OpenCurves curves } ) =
( \ p cs -> Spline p ( OpenCurves cs ) ) <$> fp splineStart <*> go 0 splineStart curves
where
go _ _ Empty = pure Empty
go i p ( seg :<| segs ) = (:<|) <$> fc i p seg <*> go ( i + 1 ) ( openCurveEnd seg ) segs
biwitherSpline
:: forall f crvData ptData crvData' ptData'
. Monad f
=> ( Maybe ptData' -> Curve Open crvData ptData -> f ( Maybe ( Curve Open crvData' ptData' ) ) )
-> ( ptData -> f ( Maybe ptData' ) )
-> Spline Open crvData ptData
-> f ( Maybe ( Spline Open crvData' ptData' ) )
biwitherSpline fc fp ( Spline { splineStart, splineCurves = OpenCurves curves } ) = do
mbStart' <- fp splineStart
( curves', mbStart'' ) <- ( `runStateT` ( fmap First mbStart' ) ) $ go mbStart' curves
case mbStart'' of
Nothing -> pure Nothing
Just ( First start' ) ->
pure ( Just $ Spline { splineStart = start', splineCurves = OpenCurves curves' } )
where
go :: Maybe ptData' -> Seq ( Curve Open crvData ptData ) -> StateT ( Maybe ( First ptData' ) ) f ( Seq ( Curve Open crvData' ptData' ) )
go _ Empty = pure Empty
go mbStart ( crv :<| crvs ) = do
mbCrv' <- lift $ fc mbStart crv
case mbCrv' of
Nothing -> go mbStart crvs
Just crv' -> do
let
endpoint = openCurveEnd crv'
modify' ( <> Just ( First endpoint ) )
( crv' :<| ) <$> go ( Just endpoint ) crvs
instance KnownSplineType Closed where
type TraversalCt Closed clo' = ()
lastPoint ( Spline { splineStart } ) = splineStart
adjustSplineType :: forall clo' crvData ptData. SplineTypeI clo' => Spline clo' crvData ptData -> Spline Closed crvData ptData
adjustSplineType spline@( Spline { splineStart, splineCurves } ) = case ssplineType @clo' of
SClosed -> spline
SOpen -> case splineCurves of
OpenCurves ( Empty ) -> Spline { splineStart, splineCurves = NoCurves }
OpenCurves ( prev :|> lst ) -> Spline { splineStart, splineCurves = ClosedCurves prev ( set ( field @"curveEnd" ) BackToStart lst ) }
ibitraverseSpline
:: forall f crvData ptData crvData' ptData'
. Applicative f
=> ( forall clo'. ( SplineTypeI clo', Traversable ( NextPoint clo' ) )
=> Int -> ptData -> Curve clo' crvData ptData -> f ( Curve clo' crvData' ptData' )
)
-> ( ptData -> f ptData' )
-> Spline Closed crvData ptData
-> f ( Spline Closed crvData' ptData' )
ibitraverseSpline _ fp ( Spline { splineStart = p0, splineCurves = NoCurves } ) = ( \ p -> Spline p NoCurves ) <$> fp p0
ibitraverseSpline fc fp ( Spline { splineStart = p0, splineCurves = ClosedCurves prevCurves lastCurve } ) =
( \ p cs lst -> Spline p ( ClosedCurves cs lst ) ) <$> fp p0 <*> go 0 p0 prevCurves <*> fc n pn lastCurve
where
n :: Int
n = length prevCurves
pn :: ptData
pn = case prevCurves of
Empty -> p0
_ :|> lastPrev -> openCurveEnd lastPrev
go _ _ Empty = pure Empty
go i p ( seg :<| segs ) = (:<|) <$> fc i p seg <*> go ( i + 1 ) ( openCurveEnd seg ) segs
biwitherSpline _ fp ( Spline { splineStart, splineCurves = NoCurves } ) = fmap ( \ p -> Spline p NoCurves ) <$> fp splineStart
biwitherSpline fc fp ( Spline { splineStart, splineCurves = ClosedCurves prevCurves lastCurve } ) = do
mbSpline' <- biwitherSpline fc fp ( Spline { splineStart, splineCurves = OpenCurves prevCurves } )
case mbSpline' of
Nothing -> do
_ <- fc Nothing lastCurve
pure Nothing
Just ( Spline { splineStart = start', splineCurves = OpenCurves prevCurves' } ) ->
case prevCurves' of
Empty -> do
mbLastCurve' <- fc ( Just start' ) lastCurve
case mbLastCurve' of
Nothing ->
pure ( Just $ Spline { splineStart = start', splineCurves = NoCurves } )
Just lastCurve' ->
pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves Empty lastCurve' } )
( prevPrevCurves' :|> prevLastCurve' ) -> do
let
prevPt' = openCurveEnd prevLastCurve'
mbLastCurve' <- fc ( Just prevPt' ) lastCurve
case mbLastCurve' of
Nothing ->
pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevPrevCurves' ( dropCurveEnd prevLastCurve' ) } )
Just lastCurve' ->
pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevCurves' lastCurve' } )

1040
src/lib/Math/Bezier/Stroke.hs
View file

File diff suppressed because it is too large Load diff

56
src/lib/Math/Module.hs
View file

@ -10,7 +10,8 @@ module Math.Module
( Module(..), lerp ( Module(..), lerp
, Inner(..) , Inner(..)
, squaredNorm, quadrance, distance , squaredNorm, quadrance, distance
, proj, projC, closestPointToSegment , proj, projC, closestPointOnSegment
, cross
) )
where where
@ -18,7 +19,7 @@ module Math.Module
import Control.Applicative import Control.Applicative
( liftA2 ) ( liftA2 )
import Data.Monoid import Data.Monoid
( Ap(..) ) ( Ap(..), Sum(..) )
-- acts -- acts
import Data.Act import Data.Act
@ -28,6 +29,14 @@ import Data.Act
( (-->) ) ( (-->) )
) )
-- groups
import Data.Group
( invert )
-- MetaBrush
import Math.Vector2D
( Vector2D(..), Segment(..) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
infixl 6 ^+^, ^-^ infixl 6 ^+^, ^-^
@ -35,8 +44,9 @@ infix 9 ^*, *^
class Num r => Module r m | m -> r where class Num r => Module r m | m -> r where
{-# MINIMAL (^+^), ( (^*) | (*^) ) #-} {-# MINIMAL origin, (^+^), ( (^*) | (*^) ) #-}
origin :: m
(^+^) :: m -> m -> m (^+^) :: m -> m -> m
(^-^) :: m -> m -> m (^-^) :: m -> m -> m
(*^) :: r -> m -> m (*^) :: r -> m -> m
@ -47,6 +57,7 @@ class Num r => Module r m | m -> r where
m ^-^ n = m ^+^ (-1) *^ n m ^-^ n = m ^+^ (-1) *^ n
instance ( Applicative f, Module r m ) => Module r ( Ap f m ) where instance ( Applicative f, Module r m ) => Module r ( Ap f m ) where
origin = pure origin
(^+^) = liftA2 (^+^) (^+^) = liftA2 (^+^)
(^-^) = liftA2 (^-^) (^-^) = liftA2 (^-^)
(*^) r = fmap ( r *^ ) (*^) r = fmap ( r *^ )
@ -79,11 +90,11 @@ proj x y = projC x y *^ y
projC :: forall m r. ( Inner r m, Fractional r ) => m -> m -> r projC :: forall m r. ( Inner r m, Fractional r ) => m -> m -> r
projC x y = x ^.^ y / squaredNorm y projC x y = x ^.^ y / squaredNorm y
closestPointToSegment closestPointOnSegment
:: forall v r p :: forall v r p
. ( Inner r v, Torsor v p, Fractional r, Ord r ) . ( Inner r v, Torsor v p, Fractional r, Ord r )
=> p -> p -> p -> ( r, p ) => p -> Segment p -> ( r, p )
closestPointToSegment c p0 p1 closestPointOnSegment c ( Segment p0 p1 )
| t <= 0 | t <= 0
= ( 0, p0 ) = ( 0, p0 )
| t >= 1 | t >= 1
@ -95,3 +106,36 @@ closestPointToSegment c p0 p1
v01 = p0 --> p1 v01 = p0 --> p1
t :: r t :: r
t = projC ( p0 --> c ) v01 t = projC ( p0 --> c ) v01
instance Num a => Module a ( Sum a ) where
origin = Sum 0
(^+^) = (<>)
( Sum x ) ^-^ ( Sum y ) = Sum ( x - y )
c *^ ( Sum x ) = Sum ( c * x )
( Sum x ) ^* c = Sum ( x * c )
instance Num a => Inner a ( Sum a ) where
Sum a ^.^ Sum b = a * b
instance Num a => Module a ( Vector2D a ) where
origin = pure 0
(^+^) = (<>)
p ^-^ q = p <> invert q
c *^ p = fmap ( c * ) p
p ^* c = fmap ( * c ) p
instance Num a => Inner a ( Vector2D a ) where
( Vector2D x1 y1 ) ^.^ ( Vector2D x2 y2 )
= x1 * x2 + y1 * y2
cross :: Num a => Vector2D a -> Vector2D a -> a
cross ( Vector2D x1 y1 ) ( Vector2D x2 y2 )
= x1 * y2 - x2 * y1

35
src/lib/Math/Vector2D.hs
View file

@ -9,7 +9,7 @@
module Math.Vector2D module Math.Vector2D
( Point2D(..), Vector2D(.., Vector2D), Mat22(..) ( Point2D(..), Vector2D(.., Vector2D), Mat22(..)
, cross , Segment(..)
) )
where where
@ -33,16 +33,12 @@ import Generic.Data
-- groups -- groups
import Data.Group import Data.Group
( Group ( invert ) ) ( Group )
-- groups-generic -- groups-generic
import Data.Group.Generics import Data.Group.Generics
( ) ( )
-- MetaBrush
import Math.Module
( Module(..), Inner(..) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data Point2D a = Point2D !a !a data Point2D a = Point2D !a !a
@ -63,24 +59,21 @@ newtype Vector2D a = MkVector2D { tip :: Point2D a }
pattern Vector2D :: a -> a -> Vector2D a pattern Vector2D :: a -> a -> Vector2D a
pattern Vector2D x y = MkVector2D ( Point2D x y ) pattern Vector2D x y = MkVector2D ( Point2D x y )
instance Num a => Module a ( Vector2D a ) where
(^+^) = (<>)
p ^-^ q = p <> invert q
c *^ p = fmap ( c * ) p
p ^* c = fmap ( * c ) p
instance Num a => Inner a ( Vector2D a ) where
( Vector2D x1 y1 ) ^.^ ( Vector2D x2 y2 )
= x1 * x2 + y1 * y2
cross :: Num a => Vector2D a -> Vector2D a -> a
cross ( Vector2D x1 y1 ) ( Vector2D x2 y2 )
= x1 * y2 - x2 * y1
data Mat22 a data Mat22 a
= Mat22 !a !a !a !a = Mat22 !a !a !a !a
deriving stock ( Show, Eq, Generic, Generic1, Functor, Foldable, Traversable ) deriving stock ( Show, Eq, Generic, Generic1, Functor, Foldable, Traversable )
deriving Applicative deriving Applicative
via Generically1 Mat22 via Generically1 Mat22
deriving anyclass ( NFData, NFData1 ) deriving anyclass ( NFData, NFData1 )
data Segment p =
Segment
{ segmentStart :: !p
, segmentEnd :: !p
}
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
deriving ( Semigroup, Monoid, Group )
via GenericProduct ( Segment p )
deriving Applicative
via Generically1 Segment
deriving anyclass ( NFData, NFData1 )