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

138
app/Main.hs
View file

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

17
cabal.project
View file

@ -6,6 +6,7 @@ constraints:
allow-newer:
waargonaut:*
-- fixes gi-cairo-render to work with haskell-gi >= 0.24
source-repository-package
type: git
@ -30,8 +31,18 @@ source-repository-package
location: https://github.com/sheaf/waargonaut
tag: dc835fb86d2592fa2e55753fa4eb7c59d6124699
-- haskell-gi: add fix for GValue
-- instances for CPS Writer / CPS RWST
source-repository-package
type: git
location: https://github.com/haskell-gi/haskell-gi
tag: 6fe7fc271095b5b6115b142f72995ebc11840afb
location: https://github.com/haskell/mtl
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

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

@ -1,4 +1,3 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
@ -23,7 +22,7 @@ import Data.Foldable
import Data.Int
( Int32 )
import Data.Maybe
( catMaybes, listToMaybe )
( listToMaybe )
import Data.Traversable
( for )
import Data.Word
@ -40,10 +39,6 @@ import Data.Act
-- containers
import qualified Data.Map as Map
( insert, lookup )
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( fromList )
import qualified Data.Set as Set
( delete, insert )
@ -84,8 +79,12 @@ import qualified Data.Text as Text
( intercalate, pack )
-- MetaBrush
import Math.Bezier.Spline
( Spline(..), SplineType(Open)
, catMaybesSpline
)
import Math.Bezier.Stroke
( StrokePoint(..) )
( CachedStroke(..) )
import Math.Module
( Module((*^)) )
import Math.Vector2D
@ -96,11 +95,11 @@ import MetaBrush.Context
, HoldAction(..), GuideAction(..), PartialPath(..)
)
import MetaBrush.Document
( Document(..), DocumentContent(..), PointData(..), FocusState(..) )
( Document(..), DocumentContent(..), PointData(..), FocusState(..)
, Guide(..), selectedGuide, addGuide
)
import MetaBrush.Document.Draw
( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary )
import MetaBrush.Document
( Guide(..), selectedGuide, addGuide )
import MetaBrush.Document.History
( DocumentHistory(..), newHistory
, back, fwd
@ -132,7 +131,7 @@ import {-# SOURCE #-} MetaBrush.UI.FileBar
import MetaBrush.UI.Menu
( MenuItem(..), Menu(..), ViewMenu(..) )
import MetaBrush.UI.ToolBar
( Tool(..) )
( Tool(..), Mode(..) )
import MetaBrush.UI.Viewport
( Viewport(..), Ruler(..) )
import MetaBrush.Unique
@ -243,7 +242,6 @@ instance HandleAction OpenFolder where
newDocHist = newHistory doc
newFileTab False uiElts vars ( Just newDocHist ) tabLoc
updateHistoryState uiElts ( Just newDocHist )
pure ()
---------------
-- Save file --
@ -253,12 +251,12 @@ data Save = Save
deriving stock Show
instance HandleAction Save where
handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ =
handleAction uiElts vars _ =
save uiElts vars True
save :: UIElements -> Variables -> Bool -> IO ()
save uiElts vars keepOpen = do
mbDoc <- fmap present <$> ( STM.atomically $ activeDocument vars )
mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
for_ mbDoc \case
doc@( Document { mbFilePath, documentContent } )
| Nothing <- mbFilePath
@ -285,7 +283,7 @@ instance HandleAction SaveAs where
saveAs :: UIElements -> Variables -> Bool -> IO ()
saveAs uiElts vars keepOpen = do
mbSavePath <- askForSavePath uiElts
for_ mbSavePath \ savePath -> do
for_ mbSavePath \ savePath ->
modifyingCurrentDocument uiElts vars \ doc -> do
let
modif :: DocumentUpdate
@ -332,7 +330,7 @@ pattern CancelClose = 3
instance HandleAction Close where
handleAction
uiElts@( UIElements { viewport = Viewport {..}, .. } )
uiElts@( UIElements {..} )
vars@( Variables {..} )
close = do
mbDoc <- case close of
@ -391,7 +389,7 @@ data SwitchTo = SwitchTo Unique
instance HandleAction SwitchTo where
handleAction
uiElts@( UIElements { viewport = Viewport {..}, .. } )
uiElts
vars@( Variables {..} )
( SwitchTo newUnique ) = do
uiUpdateAction <- STM.atomically do
@ -424,17 +422,17 @@ data Undo = Undo
deriving stock Show
instance HandleAction Undo where
handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ = updateHistory back uiElts vars
handleAction uiElts vars _ = updateHistory back uiElts vars
data Redo = Redo
deriving stock Show
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 f uiElts@( UIElements {..} ) vars@( Variables {..} ) = do
updateHistory f uiElts vars@( Variables {..} ) = do
uiUpdateAction <- STM.atomically do
mbUnique <- STM.readTVar activeDocumentTVar
case mbUnique of
@ -514,13 +512,14 @@ instance HandleAction Delete where
tool <- STM.readTVarIO toolTVar
mode <- STM.readTVarIO modeTVar
case tool of
-- Delete selected points on pressing 'Delete'.
-- Delete selected points on pressing 'Delete' in path mode.
Selection
| PathMode <- mode
-> modifyingCurrentDocument uiElts vars \ doc -> do
let
newDocument :: Document
updateInfo :: UpdateInfo
( newDocument, updateInfo ) = deleteSelected mode doc
( newDocument, updateInfo ) = deleteSelected doc
case updateInfo of
UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
| null strokesAffected
@ -677,6 +676,10 @@ instance HandleAction MouseClick where
pos :: Point2D Double
pos = toViewport mouseClickCoords
STM.writeTVar mousePosTVar ( Just pos )
mode <- STM.readTVar modeTVar
case mode of
BrushMode -> pure Don'tModifyDoc -- TODO: brush parameter modification UI
_ ->
case actionOrigin of
ViewportOrigin -> case ty of
@ -684,7 +687,7 @@ instance HandleAction MouseClick where
SingleClick -> do
modifiers <- STM.readTVar modifiersTVar
tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
case tool of
-- Selection mode mouse hold:
--
@ -696,7 +699,7 @@ instance HandleAction MouseClick where
case selectionMode modifiers of
-- Drag move: not holding shift or alt, click has selected something.
New
| Just ( dragMove, newDoc ) <- dragMoveSelect mode pos doc
| Just ( dragMove, newDoc ) <- dragMoveSelect pos doc
-> do
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
case dragMove of
@ -743,14 +746,14 @@ instance HandleAction MouseClick where
DoubleClick -> do
tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
modifs <- STM.readTVar modifiersTVar
case tool of
Selection
| null modifs
| PathMode <- mode
, null modifs
-> do
STM.writeTVar mouseHoldTVar Nothing
case subdivide mode pos doc of
case subdivide pos doc of
Nothing ->
pure Don'tModifyDoc
Just ( newDocument, loc ) -> do
@ -869,6 +872,9 @@ instance HandleAction MouseRelease where
_ -> do
tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
case mode of
BrushMode -> pure Don'tModifyDoc -- TODO: brush parameter modification UI
_ ->
case tool of
Selection -> do
@ -882,13 +888,13 @@ instance HandleAction MouseRelease where
-> let
alternateMode :: Bool
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
in case dragUpdate mode pos0 pos dragAction alternateMode doc of
in case dragUpdate 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 )
-> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle selMode pos0 pos doc )
_ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc )
Pen -> do
mbPartialPath <- STM.readTVar partialPathTVar
@ -924,21 +930,20 @@ instance HandleAction MouseRelease where
then do
STM.writeTVar partialPathTVar Nothing
let
newSegment :: Seq ( StrokePoint PointData )
newSegment
= Seq.fromList
$ catMaybes
[ Just ( PathPoint p1 ( PointData Normal Empty ) )
, do
newSegment :: Spline Open CachedStroke ( PointData () )
newSegment = catMaybesSpline ( CachedStroke Nothing )
( PointData p1 Normal () )
( do
cp <- mbCp2
guard ( cp /= p1 )
pure $ ControlPoint cp ( PointData Normal Empty )
, do
pure ( PointData cp Normal () )
)
( do
cp <- mbControlPoint
guard ( cp /= otherAnchorPt )
pure $ ControlPoint cp ( PointData Normal Empty )
, Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) )
]
pure ( PointData cp Normal () )
)
( PointData otherAnchorPt Normal () )
newDocument :: Document
newDocument = addToAnchor anchor newSegment doc
changeText :: Text
@ -954,21 +959,20 @@ instance HandleAction MouseRelease where
else do
STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
let
newSegment :: Seq ( StrokePoint PointData )
newSegment
= Seq.fromList
$ catMaybes
[ Just ( PathPoint p1 ( PointData Normal Empty ) )
, do
newSegment :: Spline Open CachedStroke ( PointData () )
newSegment = catMaybesSpline ( CachedStroke Nothing )
( PointData p1 Normal () )
( do
cp <- mbCp2
guard ( cp /= p1 )
pure $ ControlPoint cp ( PointData Normal Empty )
, do
pure ( PointData cp Normal () )
)
( do
cp <- mbControlPoint
guard ( cp /= pathPoint )
pure $ ControlPoint cp ( PointData Normal Empty )
, Just ( PathPoint pathPoint ( PointData Normal Empty ) )
]
pure ( PointData cp Normal () )
)
( PointData pathPoint Normal () )
newDocument :: Document
newDocument = addToAnchor anchor newSegment doc
changeText :: Text
@ -987,7 +991,7 @@ data Scroll = Scroll ( Point2D Double ) ( Vector2D Double )
instance HandleAction Scroll where
handleAction
uiElts@( UIElements { viewport = Viewport {..}, .. } )
uiElts@( UIElements { viewport = Viewport {..} } )
vars@( Variables {..} )
( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do
@ -1051,12 +1055,12 @@ data KeyboardPress = KeyboardPress Word32
instance HandleAction KeyboardPress where
handleAction
uiElts@( UIElements { viewport = Viewport {..}, .. } )
uiElts@( UIElements { viewport = Viewport {..} } )
vars@( Variables {..} )
( KeyboardPress keyCode ) = do
for_ ( modifierKey keyCode ) \ modifier ->
STM.atomically $ STM.modifyTVar' modifiersTVar ( Set.insert modifier )
for_ ( modifierKey keyCode )
( STM.atomically . STM.modifyTVar' modifiersTVar . Set.insert )
case keyCode of
@ -1096,5 +1100,5 @@ data KeyboardRelease = KeyboardRelease Word32
instance HandleAction KeyboardRelease where
handleAction _ ( Variables { modifiersTVar } ) ( KeyboardRelease keyCode ) =
for_ ( modifierKey keyCode ) \ modifier -> do
STM.atomically $ STM.modifyTVar' modifiersTVar ( Set.delete modifier )
for_ ( modifierKey keyCode )
( 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 TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module MetaBrush.Asset.Brushes
( ellipse, blob, rect )
where
module MetaBrush.Asset.Brushes where
-- containers
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( fromList )
-- base
import Data.Kind
( Type )
import Data.Type.Equality
( (:~:)(Refl) )
-- superrecord
import qualified SuperRecord
( (:=) )
-- text
import Data.Text
( Text )
import qualified Data.Text as Text
( unpack )
-- MetaBrush
import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Vector2D
( Point2D(..) )
import MetaBrush.Document
( Brush(..) )
import MetaBrush.MetaParameter.AST
( BrushFunction, STypesI(sTypesI), eqTys )
import MetaBrush.MetaParameter.Driver
( SomeBrushFunction(..), interpretBrush )
import MetaBrush.Unique
( UniqueSupply )
--------------------------------------------------------------------------------
ellipse :: forall d. Double -> Double -> d -> Seq ( StrokePoint d )
ellipse w h d = Seq.fromList
[ pp ( Point2D 0 1 )
, cp ( Point2D a 1 )
, cp ( Point2D 1 a )
, pp ( Point2D 1 0 )
, cp ( Point2D 1 (-a) )
, cp ( Point2D a (-1) )
, pp ( Point2D 0 (-1) )
, cp ( Point2D (-a) (-1) )
, cp ( Point2D (-1) (-a) )
, pp ( Point2D (-1) 0 )
, cp ( Point2D (-1) a )
, cp ( Point2D (-a) 1 )
, pp ( Point2D 0 1 )
]
circle
:: forall circleBrushFields
. ( circleBrushFields ~ '[ "r" SuperRecord.:= Double ] )
=> UniqueSupply -> IO ( Brush circleBrushFields )
circle uniqueSupply = mkBrush @circleBrushFields uniqueSupply name code
where
a :: Double
a = 0.551915024494
pp, cp :: Point2D Double -> StrokePoint d
pp ( Point2D x y ) = PathPoint ( Point2D ( w * x ) ( h * y ) ) d
cp ( Point2D x y ) = ControlPoint ( Point2D ( w * x ) ( h * y ) ) d
name, code :: Text
name = "Circle"
code =
"with\n\
\ 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 )
blob w h d = Seq.fromList
[ pp ( Point2D 1 0 )
, cp ( Point2D 1 -1 )
, cp ( Point2D -1 -1 )
, pp ( Point2D -1 0 )
, cp ( Point2D -1 1 )
, cp ( Point2D 1 1 )
, pp ( Point2D 1 0 )
]
rounded
:: forall roundedBrushFields
. ( roundedBrushFields ~ '[ ] ) -- TODO
=> UniqueSupply -> IO ( Brush roundedBrushFields )
rounded uniqueSupply = mkBrush @roundedBrushFields uniqueSupply name code
where
pp, cp :: Point2D Double -> StrokePoint d
pp ( Point2D x y ) = PathPoint ( Point2D ( w * x ) ( h * y ) ) d
cp ( Point2D x y ) = ControlPoint ( Point2D ( w * x ) ( h * y ) ) d
name, code :: Text
name = "Rounded quadrilateral"
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 )
, pp ( Point2D 1 -1 )
, pp ( Point2D -1 -1 )
, pp ( Point2D -1 1 )
, pp ( Point2D 1 1 )
]
where
pp :: Point2D Double -> StrokePoint d
pp ( Point2D x y ) = PathPoint ( Point2D ( w * x ) ( h * y ) ) d
--------------------------------------------------------------------------------
mkBrush
:: forall ( givenBrushFields :: [ Type ] )
. STypesI givenBrushFields
=> UniqueSupply -> Text -> Text
-> IO ( Brush givenBrushFields )
mkBrush uniqSupply brushName brushCode = do
( mbBrush, _ ) <- interpretBrush uniqSupply brushCode
case mbBrush of
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 )
)

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

@ -1,82 +1,118 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Document
( AABB(..), mkAABB
, Document(..), DocumentContent(..)
, emptyDocument
, Stroke(..)
, PointData(..), BrushPointData(..)
, Stroke(..), StrokeSpline, _strokeSpline, overStrokeSpline
, PointData(..), BrushPointData(..), DiffPointData(..)
, Brush(..), emptyBrush
, FocusState(..), Hoverable(..), HoverContext(..)
, _selection, _brush
, Guide(..)
, _selection, _coords, coords
, addGuide, selectedGuide
)
where
-- base
import Data.Coerce
( coerce )
import Data.Functor.Identity
( Identity(..) )
import Data.Kind
( Type )
import Data.Semigroup
( Arg(..), Min(..), ArgMin )
import GHC.Generics
( Generic )
( Generic, Generic1 )
-- acts
import Data.Act
( Act
( (•) )
, Torsor
( (-->) )
)
( Act(..), Torsor(..) )
-- containers
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
( insert )
import qualified Data.Map.Strict as Map
( empty )
import Data.Sequence
( Seq )
( empty, insert )
-- deepseq
import Control.DeepSeq
( NFData )
( NFData(..), NFData1, deepseq )
-- generic-lens
import Data.Generics.Product.Fields
( field' )
import Data.Generics.Product.Typed
( HasType(typed) )
-- groups
import Data.Group
( Group(..) )
-- lens
import Control.Lens
( Lens' )
( Lens'
, set, view, over
)
-- stm
import Control.Concurrent.STM
( STM )
-- superrecord
import qualified SuperRecord as Super
( Rec )
import qualified SuperRecord
( Intersect, rnil )
-- text
import Data.Text
( Text )
import qualified Data.Text as Text
( unpack )
-- transformers
import Control.Monad.Trans.Reader
( ReaderT, runReaderT )
-- MetaBrush
import Math.Bezier.Spline
( Spline(..), KnownSplineType, Curves(..) )
import Math.Bezier.Stroke
( StrokePoint(..) )
( CachedStroke )
import Math.Module
( Inner((^.^)), squaredNorm, quadrance )
( Module
( origin, (^+^), (^-^), (*^) )
, Inner((^.^))
, squaredNorm, quadrance
)
import Math.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
( Ruler(..) )
import MetaBrush.Unique
@ -113,7 +149,7 @@ data Document
deriving stock ( Show, Generic )
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
= Content
{ unsavedChanges :: !Bool
@ -124,20 +160,90 @@ data DocumentContent
deriving stock ( Show, Generic )
deriving anyclass NFData
data Stroke
= Stroke
type StrokeSpline ty brushParams = Spline ty CachedStroke ( PointData brushParams )
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
, strokePoints :: !( Seq ( StrokePoint PointData ) )
, strokeBrush :: Brush brushFields
, strokeSpline :: !( StrokeSpline clo pointParams )
}
deriving stock ( Show, Generic )
deriving anyclass NFData
-> Stroke
deriving stock instance Show Stroke
instance NFData Stroke where
rnf ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline } )
= deepseq strokeSpline
. deepseq strokeUnique
. deepseq strokeVisible
$ rnf strokeName
data PointData
_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
{ pointState :: FocusState
, brushShape :: Seq ( StrokePoint BrushPointData )
{ pointCoords :: !( Point2D Double )
, pointState :: FocusState
, brushParams :: !params
}
deriving stock ( Show, Generic )
deriving anyclass NFData
@ -164,12 +270,6 @@ instance Semigroup FocusState where
instance Monoid FocusState where
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 docName unique =
Document
@ -218,6 +318,74 @@ instance Hoverable ( Point2D Double ) where
| otherwise
= 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.
@ -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.
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
insertNewGuides :: Map Unique Guide -> STM ( Map Unique Guide )
insertNewGuides :: Map Unique Guide -> ReaderT UniqueSupply STM ( Map Unique Guide )
insertNewGuides gs = case ruler of
RulerCorner
-> do
uniq1 <- freshUnique uniqueSupply
uniq2 <- freshUnique uniqueSupply
uniq1 <- freshUnique
uniq2 <- freshUnique
let
guide1, guide2 :: Guide
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 )
TopRuler
-> do
uniq1 <- freshUnique uniqueSupply
uniq1 <- freshUnique
let
guide1 :: Guide
guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideFocus = Normal, guideUnique = uniq1 }
pure ( Map.insert uniq1 guide1 gs )
LeftRuler
-> do
uniq2 <- freshUnique uniqueSupply
uniq2 <- freshUnique
let
guide2 :: Guide
guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideFocus = Normal, guideUnique = uniq2 }

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

@ -1,8 +1,10 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Document.Draw
@ -22,12 +24,10 @@ import Data.Act
-- containers
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( singleton, reverse, take, drop, length )
-- generic-lens
import Data.Generics.Product.Fields
( field' )
( field, field' )
-- lens
import Control.Lens
@ -37,6 +37,12 @@ import Control.Lens
import Control.Concurrent.STM
( STM )
-- superrecord
import qualified SuperRecord as Super
( Rec )
import qualified SuperRecord
( rnil )
-- text
import Data.Text
( Text )
@ -44,17 +50,27 @@ import Data.Text
-- transformers
import Control.Monad.Trans.State.Strict
( State, runState, get, put )
import Control.Monad.Trans.Reader
( runReaderT )
-- MetaBrush
import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Bezier.Spline
( Spline(..), Curves(..)
, SplineType(..), SSplineType(..)
, SplineTypeI(ssplineType)
, reverseSpline, splineEnd
, openCurveEnd
)
import Math.Module
( squaredNorm )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Document(..), Stroke(..), FocusState(..), PointData(..)
, _selection
( Document(..), Stroke(..), StrokeSpline
, FocusState(..), PointData(..)
, emptyBrush
, _selection, _strokeSpline
, coords, overStrokeSpline
)
import MetaBrush.Unique
( Unique, UniqueSupply, freshUnique, uniqueText )
@ -82,31 +98,51 @@ getOrCreateDrawAnchor
-> Document
-> STM ( Document, DrawAnchor, Point2D Double, Maybe Text )
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.
( newDoc, Just ( ( anchor, anchorPt ), anchorName ) ) -> do
( newDoc, Just ( ( anchor, anchorPt ), anchorName ) ) ->
pure ( newDoc, anchor, anchorPt, Just anchorName )
-- No anchor found: start a new stroke (on a new stroke layer).
( newDoc, Nothing ) -> do
uniq <- freshUnique uniqueSupply
uniq <- runReaderT freshUnique uniqueSupply
let
newDoc' :: Document
newDoc'
= over ( field' @"documentContent" . field' @"strokes" )
( Stroke
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
, strokePoints = Seq.singleton $ PathPoint c ( PointData Normal Empty )
, strokeSpline = newSpline
, strokeBrush = emptyBrush
}
: )
newDoc' :: Document
newDoc'
= over ( field' @"documentContent" . field' @"strokes" )
( newStroke : )
newDoc
pure ( newDoc', AnchorAtEnd uniq, c, Nothing )
where
-- Deselect all points, and try to find a valid anchor for drawing
-- (a path start/end point at mouse click point).
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
where
updateStrokeSpline
:: forall clo brushParams
. SplineTypeI clo
=> StrokeSpline clo brushParams
-> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) ( StrokeSpline clo brushParams )
updateStrokeSpline spline = do
mbAnchor <- get
case mbAnchor of
@ -115,41 +151,61 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
-- then select it as an anchor for the drawing operation.
Nothing
| strokeVisible
, Just anchor <- endpointAnchor strokeUnique strokePoints
, Just anchor <- endpointAnchor strokeUnique spline
-> put ( Just ( anchor, strokeName ) )
$> set ( field' @"strokePoints" . mapped . _selection ) Normal stroke
$> set ( mapped . _selection ) Normal spline
-- Otherwise, just deselect.
_ -> pure $ set ( field' @"strokePoints" . mapped . _selection ) Normal stroke
_ -> pure $ set ( mapped . _selection ) Normal spline
where
-- 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
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 -> Seq ( StrokePoint PointData ) -> Document -> Document
addToAnchor anchor newPts = over ( field' @"documentContent" . field' @"strokes" . mapped ) addToStroke
addToAnchor :: DrawAnchor -> StrokeSpline Open () -> Document -> Document
addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strokes" . mapped ) addToStroke
where
addToStroke :: Stroke -> Stroke
addToStroke stroke@( Stroke { strokeUnique, strokePoints = pts } )
addToStroke stroke@( Stroke { strokeUnique } )
| strokeUnique == anchorStrokeUnique anchor
=
let
updateSpline
:: forall clo brushData
. SplineTypeI clo
=> StrokeSpline clo brushData -> StrokeSpline clo brushData
updateSpline prevSpline
| SOpen <- ssplineType @clo
= case anchor of
AnchorAtStart _ -> stroke { strokePoints = Seq.reverse newPts <> Seq.drop 1 pts }
AnchorAtEnd _ -> stroke { strokePoints = dropEnd 1 pts <> newPts }
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
= 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 DeriveTraversable #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

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

@ -4,12 +4,12 @@
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
@ -25,8 +25,6 @@ module MetaBrush.Document.Selection
where
-- base
import Control.Category
( (>>>) )
import Control.Monad
( guard )
import Data.Functor
@ -63,12 +61,6 @@ import Generic.Data
-- generic-lens
import Data.Generics.Product.Fields
( field' )
import Data.Generics.Product.Typed
( HasType )
-- groups
import Data.Group
( invert )
-- lens
import Control.Lens
@ -78,9 +70,7 @@ import Control.Lens
import Control.Monad.Trans.Tardis
( Tardis )
import qualified Control.Monad.Trans.Tardis as Tardis
( TardisT(..)
, getPast, getFuture, sendPast, sendFuture
)
( runTardisT, getPast, getFuture, sendPast, sendFuture )
-- text
import Data.Text
@ -91,34 +81,49 @@ import qualified Data.Text as Text
-- transformers
import Control.Monad.Trans.Class
( lift )
import Control.Monad.Trans.Maybe
( MaybeT(..) )
import Control.Monad.Trans.State.Strict
( StateT(..), State, runState, evalState
, get, put, modify
( StateT, State
, runState, evalState, evalStateT
, get, put, modify'
)
import Control.Monad.Trans.Writer.CPS
( WriterT, runWriterT, tell )
-- MetaBrush
import qualified Math.Bezier.Cubic as Cubic
( Bezier(..), closestPoint, fromQuadratic, drag )
( Bezier(..), bezier, closestPoint, fromQuadratic, drag )
import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..), closestPoint, interpolate )
import Math.Bezier.Spline
( Spline(..), SplineType(..), SSplineType(..), NextPoint(..)
, Curve(..), Curves(..), PointType(..)
, splitSplineAt
, SplineTypeI(ssplineType)
, KnownSplineType
( lastPoint, adjustSplineType, biwitherSpline, ibitraverseSpline, bitraverseSpline )
, fromNextPoint
)
import Math.Bezier.Stroke
( StrokePoint(..) )
( CachedStroke(..), discardCache )
import Math.Module
( squaredNorm, closestPointToSegment )
( lerp, squaredNorm, closestPointOnSegment )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
( Point2D(..), Vector2D(..), Segment(..) )
import {-# SOURCE #-} MetaBrush.Context
( Modifier(..) )
import MetaBrush.Document
( Document(..), Stroke(..)
, PointData(..), DiffPointData
, FocusState(..), _selection
, StrokeSpline, _strokeSpline, overStrokeSpline
, _coords, coords
)
import {-# SOURCE #-} MetaBrush.Document.Update
( DocChange(..) )
import {-# SOURCE #-} MetaBrush.UI.ToolBar
( Mode(..) )
import MetaBrush.MetaParameter.Interpolation
( Interpolatable(Diff) )
import MetaBrush.Unique
( Unique )
@ -147,30 +152,25 @@ selectionMode = foldMap \case
_ -> New
-- | Updates the selected objects on a single click selection event.
selectAt :: Mode -> SelectionMode -> Point2D Double -> Document -> Document
selectAt mode selMode c doc@( Document { zoomFactor } ) =
selectAt :: SelectionMode -> Point2D Double -> Document -> Document
selectAt selMode c doc@( Document { zoomFactor } ) =
( `evalState` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
where
updateStroke :: Stroke -> State Bool Stroke
updateStroke stroke@( Stroke { strokeVisible } )
| Brush <- mode
= ( field' @"strokePoints" . traverse )
( \ spt ->
( field' @"pointData" . field' @"brushShape" )
( traverse ( updatePoint strokeVisible ( MkVector2D $ coords spt ) )
>>> fmap matchEndpoints
)
spt
)
stroke
| otherwise
= ( field' @"strokePoints" )
( traverse ( updatePoint strokeVisible ( Vector2D 0 0 ) )
>>> fmap matchEndpoints
)
stroke
updatePoint :: HasType FocusState pt => Bool -> Vector2D Double -> StrokePoint pt -> State Bool ( StrokePoint pt )
updatePoint isVisible offset pt = do
updateStroke stroke@( Stroke { strokeVisible } ) = _strokeSpline updateSpline stroke
where
updateSpline
:: forall clo brushParams
. ( KnownSplineType clo )
=> StrokeSpline clo brushParams -> State Bool ( StrokeSpline clo brushParams )
updateSpline oldSpline =
bitraverseSpline
( const pure )
( updateSplinePoint strokeVisible )
oldSpline
updateSplinePoint :: Bool -> PointData brushParams -> State Bool ( PointData brushParams )
updateSplinePoint isVisible pt = do
anotherPointHasAlreadyBeenSelected <- get
if selected && not anotherPointHasAlreadyBeenSelected
then put True $> case selMode of
@ -183,13 +183,7 @@ selectAt mode selMode c doc@( Document { zoomFactor } ) =
selected :: Bool
selected
| not isVisible = False
| otherwise = squaredNorm ( c --> ( offset • coords pt ) :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16
-- Ensure consistency of selection at endpoints for closed loops.
matchEndpoints :: HasType FocusState pt => Seq ( StrokePoint pt ) -> Seq ( StrokePoint pt )
matchEndpoints ( p0 :<| ( ps :|> pn ) )
| coords p0 == coords pn
= p0 :<| ( ps :|> set _selection ( view _selection p0 ) pn )
matchEndpoints ps = ps
| otherwise = squaredNorm ( c --> coords pt :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16
-- | Type of a drag move selection:
--
@ -203,7 +197,6 @@ data DragMoveSelect
{ dragStrokeUnique :: !Unique
, dragSegmentIndex :: !Int
, dragSegmentParameter :: !Double
, dragBrushCenter :: !( Maybe ( Point2D Double ) )
}
deriving stock Show
@ -220,8 +213,8 @@ instance Semigroup DragMoveSelect where
-- | Checks whether a mouse click can initiate a drag move event,
-- and if so returns an updated document with the selection modified from the start of the drag move.
dragMoveSelect :: Mode -> Point2D Double -> Document -> Maybe ( DragMoveSelect, Document )
dragMoveSelect mode c doc@( Document { zoomFactor } ) =
dragMoveSelect :: Point2D Double -> Document -> Maybe ( DragMoveSelect, Document )
dragMoveSelect c doc@( Document { zoomFactor } ) =
let
res :: WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) Document
res = do
@ -235,53 +228,31 @@ dragMoveSelect mode c doc@( Document { zoomFactor } ) =
where
updateStroke :: Stroke -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) Stroke
updateStroke stroke@( Stroke { strokeVisible, strokeUnique } )
| Brush <- mode
= ( field' @"strokePoints" . traverse )
( \ spt ->
( field' @"pointData" . field' @"brushShape" )
( updateStrokePoints strokeVisible strokeUnique ( coords spt )
>>> fmap matchEndpoints
)
spt
)
stroke
| otherwise
= ( field' @"strokePoints" )
( updateStrokePoints strokeVisible strokeUnique ( Point2D 0 0 )
>>> fmap matchEndpoints
)
stroke
-- Ensure consistency of selection at endpoints for closed loops.
matchEndpoints :: HasType FocusState pt => Seq ( StrokePoint pt ) -> Seq ( StrokePoint pt )
matchEndpoints ( p0 :<| ( ps :|> pn ) )
| coords p0 == coords pn
= p0 :<| ( ps :|> set _selection ( view _selection p0 ) pn )
matchEndpoints ps = ps
updateStrokePoints
:: forall pt
. ( Show pt, HasType FocusState pt )
=> Bool
-> Unique
-> Point2D Double
-> Seq ( StrokePoint pt )
-> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) ( Seq ( StrokePoint pt ) )
updateStrokePoints _ _ _ Empty = pure Empty
updateStrokePoints isVisible uniq offset ( spt :<| spts ) = go 0 spt spts
updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = _strokeSpline updateSpline stroke
where
inSelectionRange :: Point2D Double -> Bool
inSelectionRange p
| not isVisible = False
| otherwise = squaredNorm ( c --> ( MkVector2D offset • p ) :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16
go :: Int -> StrokePoint pt -> Seq ( StrokePoint pt )
-> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) ( Seq ( StrokePoint pt ) )
go _ sp0 Empty = ( :<| Empty ) <$> updatePoint sp0
-- Line.
go i sp0 ( sp1 :<| sps )
| PathPoint {} <- sp1
= do
updateSpline
:: forall clo brushParams
. KnownSplineType clo
=> StrokeSpline clo brushParams
-> WriterT ( Maybe DragMoveSelect )
( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) )
( StrokeSpline clo brushParams )
updateSpline oldSpline =
ibitraverseSpline
( updateSplineCurve ( splineStart oldSpline ) strokeVisible strokeUnique )
( updateSplinePoint strokeVisible )
oldSpline
updateSplineCurve
:: forall clo' brushParams
. ( SplineTypeI clo', Traversable ( NextPoint clo' ) )
=> PointData brushParams -> Bool -> Unique
-> Int -> PointData brushParams -> Curve clo' CachedStroke ( PointData brushParams )
-> WriterT ( Maybe DragMoveSelect )
( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) )
( Curve clo' CachedStroke ( PointData brushParams ) )
updateSplineCurve start isVisible uniq i sp0 curve = case curve of
line@( LineTo sp1 _ ) -> do
let
mbCurveDrag :: Maybe DragMoveSelect
mbCurveDrag = do
@ -289,82 +260,77 @@ dragMoveSelect mode c doc@( Document { zoomFactor } ) =
t :: Double
p :: Point2D Double
( t, p )
= closestPointToSegment @( Vector2D Double ) ( invert ( MkVector2D offset ) • c ) ( coords sp0 ) ( coords sp1 )
guard ( inSelectionRange p )
= closestPointOnSegment @( Vector2D Double ) c ( Segment ( coords sp0 ) ( coords $ fromNextPoint start sp1 ) )
guard ( inSelectionRange isVisible p )
pure $
ClickedOnCurve
{ dragStrokeUnique = uniq
, dragSegmentIndex = i
, dragSegmentParameter = t
, dragBrushCenter = case mode of { Brush -> Just offset; _ -> Nothing }
}
tell mbCurveDrag
sp0' <- updatePoint sp0
( sp0' :<| ) <$> go ( i + 1 ) sp1 sps
-- Quadratic Bézier curve.
go i sp0 ( sp1 :<| sp2 :<| sps )
| ControlPoint {} <- sp1
, PathPoint {} <- sp2
= do
sp1' <- traverse ( updateSplinePoint isVisible ) sp1
pure ( line { curveEnd = sp1' } )
bez2@( Bezier2To sp1 sp2 _ ) -> do
let
mbCurveDrag :: Maybe DragMoveSelect
mbCurveDrag = do
let
bez :: Quadratic.Bezier ( Point2D Double )
bez = Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 )
bez = Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords $ fromNextPoint start sp2 )
sq_d :: Double
t :: Double
Min ( Arg sq_d (t, _) )
= Quadratic.closestPoint @( Vector2D Double ) bez ( invert ( MkVector2D offset ) • c )
= Quadratic.closestPoint @( Vector2D Double ) bez c
guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 )
pure $
ClickedOnCurve
{ dragStrokeUnique = uniq
, dragSegmentIndex = i
, dragSegmentParameter = t
, dragBrushCenter = case mode of { Brush -> Just offset; _ -> Nothing }
}
tell mbCurveDrag
sp0' <- updatePoint sp0
sp1' <- updatePoint sp1
( ( sp0' :<| ) . ( sp1' :<| ) ) <$> go ( i + 2 ) sp2 sps
-- Cubic Bézier curve.
go i sp0 ( sp1 :<| sp2 :<| sp3 :<| sps )
| ControlPoint {} <- sp1
, ControlPoint {} <- sp2
, PathPoint {} <- sp3
= do
sp1' <- updateSplinePoint isVisible sp1
sp2' <- traverse ( updateSplinePoint isVisible ) sp2
pure ( bez2 { controlPoint = sp1', curveEnd = sp2' } )
bez3@( Bezier3To sp1 sp2 sp3 _ ) -> do
let
mbCurveDrag :: Maybe DragMoveSelect
mbCurveDrag = do
let
bez :: Cubic.Bezier ( Point2D Double )
bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 )
bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords $ fromNextPoint start sp3 )
sq_d :: Double
t :: Double
Min ( Arg sq_d (t, _) )
= Cubic.closestPoint @( Vector2D Double ) bez ( invert ( MkVector2D offset ) • c )
= Cubic.closestPoint @( Vector2D Double ) bez c
guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 )
pure $
ClickedOnCurve
{ dragStrokeUnique = uniq
, dragSegmentIndex = i
, dragSegmentParameter = t
, dragBrushCenter = case mode of { Brush -> Just offset; _ -> Nothing }
}
tell mbCurveDrag
sp0' <- updatePoint sp0
sp1' <- updatePoint sp1
sp2' <- updatePoint sp2
( ( sp0' :<| ) . ( sp1' :<| ) . ( sp2' :<| ) ) <$> go ( i + 3 ) sp3 sps
go _ sp0 sps = error ( "dragMoveSelect: unrecognised stroke type\n" <> show ( sp0 :<| sps ) )
updatePoint
:: StrokePoint pt
-> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) ( StrokePoint pt )
updatePoint pt
| inSelectionRange ( coords pt )
sp1' <- updateSplinePoint isVisible sp1
sp2' <- updateSplinePoint isVisible sp2
sp3' <- traverse ( updateSplinePoint isVisible ) sp3
pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3' } )
inSelectionRange :: Bool -> Point2D Double -> Bool
inSelectionRange isVisible p
| not isVisible = False
| otherwise = squaredNorm ( c --> p :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16
updateSplinePoint
:: Bool -> PointData brushParams
-> WriterT ( Maybe DragMoveSelect )
( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) )
( PointData brushParams )
updateSplinePoint strokeVisible pt
| inSelectionRange strokeVisible ( coords pt )
= do
mbPreviousSelect <- lift $ Tardis.getPast
mbPreviousSelect <- lift Tardis.getPast
case mbPreviousSelect of
-- Already clicked on a point: don't select further points.
Just dragSelect
@ -379,13 +345,13 @@ dragMoveSelect mode c doc@( Document { zoomFactor } ) =
mbDrag = case view _selection pt of
Selected -> Just ClickedOnSelected
_ -> Just ClickedOnUnselected
lift $ Tardis.sendFuture mbDrag
lift ( Tardis.sendFuture mbDrag )
tell mbDrag
-- Select this point (whether it was previously selected or not).
pure ( set _selection Selected pt )
| otherwise
= do
mbDragClick <- lift $ Tardis.getFuture
mbDragClick <- lift Tardis.getFuture
let
-- needs to be lazy
newPointState :: FocusState
@ -401,8 +367,8 @@ dragMoveSelect mode c doc@( Document { zoomFactor } ) =
pure ( set _selection newPointState pt )
-- | Updates the selected objects on a rectangular selection event.
selectRectangle :: Mode -> SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document
selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 )
selectRectangle :: SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document
selectRectangle selMode ( Point2D x0 y0 ) ( Point2D x1 y1 )
= over ( field' @"documentContent" . field' @"strokes" . mapped )
updateStroke
where
@ -410,21 +376,12 @@ selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 )
( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 )
( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 )
updateStroke :: Stroke -> Stroke
updateStroke stroke@( Stroke { strokeVisible } )
| Brush <- mode
= over ( field' @"strokePoints" . mapped )
( \ spt ->
over ( field' @"pointData" . field' @"brushShape" . mapped )
( updatePoint strokeVisible ( MkVector2D $ coords spt ) )
spt
)
updateStroke stroke@( Stroke { strokeVisible } ) =
overStrokeSpline
( fmap ( updateSplinePoint strokeVisible ) )
stroke
| otherwise
= over ( field' @"strokePoints" . mapped )
( updatePoint strokeVisible ( Vector2D 0 0 ) )
stroke
updatePoint :: HasType FocusState pt => Bool -> Vector2D Double -> StrokePoint pt -> StrokePoint pt
updatePoint isVisible offset pt
updateSplinePoint :: Bool -> PointData brushParams -> PointData brushParams
updateSplinePoint isVisible pt
| selected = case selMode of
Subtract -> set _selection Normal pt
_ -> set _selection Selected pt
@ -433,7 +390,7 @@ selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 )
_ -> pt
where
x, y :: Double
Point2D x y = offset • coords pt
Point2D x y = coords pt
selected :: Bool
selected
| not isVisible = False
@ -449,123 +406,237 @@ data UpdateInfo
deriving ( Semigroup, Monoid )
via Generically UpdateInfo
-- Update the info to record a modification.
--
-- Needs to be lazy in the given Boolean, to avoid time paradoxes.
recordPointUpdate :: Monad m => Bool -> Unique -> StrokePoint d -> StateT UpdateInfo m ()
recordPointUpdate doUpdate uniq ( PathPoint {} ) = modify $
if doUpdate
then
( over ( field' @"pathPointsAffected" ) (<>1)
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
)
else id
recordPointUpdate doUpdate uniq ( ControlPoint {} ) = modify $
if doUpdate
then
( over ( field' @"controlPointsAffected" ) (<>1)
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
)
else id
-- | Translate all selected points by the given vector.
--
-- Returns the updated doucment, together with info about how many points were translated.
translateSelection :: Mode -> Vector2D Double -> Document -> ( Document, UpdateInfo )
translateSelection mode t doc =
( `runState` mempty ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
-- Returns the updated document, together with info about how many points were translated.
translateSelection :: Vector2D Double -> Document -> ( Document, UpdateInfo )
translateSelection t doc =
( `runState` mempty ) . ( `evalStateT` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
where
updateStroke :: Stroke -> State UpdateInfo Stroke
updateStroke stroke@( Stroke { strokeVisible, strokeUnique } )
updateStroke :: Stroke -> StateT Bool ( State UpdateInfo ) Stroke
updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = _strokeSpline updateSpline stroke
where
updateSpline
:: forall clo brushParams
. KnownSplineType clo
=> StrokeSpline clo brushParams
-> StateT Bool ( State UpdateInfo ) ( StrokeSpline clo brushParams )
updateSpline oldSpline
| not strokeVisible
= pure stroke
| Brush <- mode
= ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" . traverse )
( updateStrokePoint strokeUnique )
stroke
= pure oldSpline
| otherwise
= ( field' @"strokePoints" . traverse )
( updateStrokePoint strokeUnique )
stroke
= bitraverseSpline
( const $ updateSplineCurve ( splineStart oldSpline ) )
( updatePoint PathPoint )
oldSpline
where
updateSplineCurve
:: forall clo'
. SplineTypeI clo'
=> PointData brushParams
-> Curve clo' CachedStroke ( PointData brushParams )
-> StateT Bool ( State UpdateInfo ) ( Curve clo' CachedStroke ( PointData brushParams ) )
updateSplineCurve start crv = do
prevMod <- get
case crv of
LineTo p1 dat -> do
p1' <- traverse ( updatePoint PathPoint ) p1
pure $ LineTo p1' dat'
where
dat' :: CachedStroke
dat'
| prevMod || ( view _selection ( fromNextPoint start p1 ) == Selected )
= discardCache dat
| otherwise
= dat
Bezier2To p1 p2 dat -> do
p1' <- updatePoint ControlPoint p1
p2' <- traverse ( updatePoint PathPoint ) p2
pure $ Bezier2To p1' p2' dat'
where
dat' :: CachedStroke
dat'
| prevMod || any ( \ pt -> view _selection pt == Selected ) [ p1, fromNextPoint start p2 ]
= discardCache dat
| otherwise
= dat
Bezier3To p1 p2 p3 dat -> do
p1' <- updatePoint ControlPoint p1
p2' <- updatePoint ControlPoint p2
p3' <- traverse ( updatePoint PathPoint ) p3
pure $ Bezier3To p1' p2' p3' dat'
where
dat' :: CachedStroke
dat'
| prevMod || any ( \ pt -> view _selection pt == Selected ) [ p1, p2, fromNextPoint start p3 ]
= discardCache dat
| otherwise
= dat
updateStrokePoint :: HasType FocusState pt => Unique -> StrokePoint pt -> State UpdateInfo ( StrokePoint pt )
updateStrokePoint uniq pt
updatePoint :: PointType -> PointData brushParams -> StateT Bool ( State UpdateInfo ) ( PointData brushParams )
updatePoint PathPoint pt
| Selected <- view _selection pt
= recordPointUpdate True uniq pt
$> pt { coords = t • coords pt }
= do
lift . modify' $
( over ( field' @"pathPointsAffected" ) (<>1)
. over ( field' @"strokesAffected" ) ( Set.insert strokeUnique )
)
put True $> over _coords ( t • ) pt
| otherwise
= put False $> pt
updatePoint ControlPoint pt
| Selected <- view _selection pt
= do
lift . modify' $
( over ( field' @"controlPointsAffected" ) (<>1)
. over ( field' @"strokesAffected" ) ( Set.insert strokeUnique )
)
pure $ over _coords ( t • ) pt
| otherwise
= pure pt
-- | Delete the selected points.
--
-- Returns the updated document, together with info about how many points were deleted.
deleteSelected :: Mode -> Document -> ( Document, UpdateInfo )
deleteSelected mode doc = deletionResult
deleteSelected :: Document -> ( Document, UpdateInfo )
deleteSelected doc = deletionResult
where
deletionResult :: ( Document, UpdateInfo )
deletionResult
= fst . runIdentity . ( `Tardis.runTardisT` ( False, False ) ) . ( `runStateT` mempty )
$ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
= ( `runState` mempty )
$ ( field' @"documentContent" . field' @"strokes" )
( fmap catMaybes . traverse updateStroke )
doc
updateStroke :: Stroke -> StateT UpdateInfo ( Tardis Bool Bool ) Stroke
updateStroke stroke@( Stroke { strokeVisible, strokeUnique } )
| not strokeVisible
= pure stroke
| Brush <- mode
= ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" )
( updateStrokePoints strokeUnique )
stroke
| otherwise
= ( field' @"strokePoints" )
( updateStrokePoints strokeUnique )
stroke
updateStrokePoints
:: forall pt
. HasType FocusState pt
=> Unique -> Seq ( StrokePoint pt )
-> StateT UpdateInfo ( Tardis Bool Bool ) ( Seq ( StrokePoint pt ) )
updateStrokePoints _ Empty = pure Empty
updateStrokePoints uniq ( p :<| ps ) = case p of
PathPoint {}
| Selected <- selectionState
-> do
lift ( Tardis.sendPast True )
lift ( Tardis.sendFuture True )
recordPointUpdate True uniq p
updateStrokePoints uniq ps
| otherwise
-> do
lift ( Tardis.sendPast False )
lift ( Tardis.sendFuture False )
( p :<| ) <$> updateStrokePoints uniq ps
_ -> do
prevPathPointDeleted <- lift Tardis.getPast
nextPathPointDeleted <- lift Tardis.getFuture
rest <- updateStrokePoints uniq ps
let
-- Control point must be deleted:
-- - if it is selected,
-- - if the previous path point was deleted,
-- - if the next path point is going to be deleted.
--
-- Need to be lazy in "nextPathPointDeleted" to avoid looping.
needsDeletion :: Bool
needsDeletion
= selectionState == Selected
|| prevPathPointDeleted
|| nextPathPointDeleted
recordPointUpdate needsDeletion uniq p
pure $ if needsDeletion then rest else ( p :<| rest )
updateStroke :: Stroke -> State UpdateInfo ( Maybe Stroke )
updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = runMaybeT $ _strokeSpline updateSpline stroke
where
selectionState :: FocusState
selectionState = view _selection p
updateSpline
:: forall clo brushParams
. KnownSplineType clo
=> StrokeSpline clo brushParams
-> MaybeT ( State UpdateInfo ) ( StrokeSpline clo brushParams )
updateSpline oldSpline
| not strokeVisible
= pure oldSpline
| otherwise
= MaybeT
$ biwitherSpline
( updateSplineCurve strokeUnique )
( updateSplinePoint strokeUnique )
oldSpline
where
noDat :: CachedStroke
noDat = CachedStroke Nothing
updateSplinePoint
:: Unique
-> PointData brushParams
-> State UpdateInfo
( Maybe ( PointData brushParams ) )
updateSplinePoint uniq pt
| Selected <- view _selection pt
= do
modify'
( over ( field' @"pathPointsAffected" ) ( <> 1 )
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
)
pure Nothing
| otherwise
= do
pure ( Just pt )
updateSplineCurve
:: forall clo'. SplineTypeI clo'
=> Unique
-> Maybe ( PointData brushParams )
-> Curve clo' CachedStroke ( PointData brushParams )
-> State UpdateInfo
( Maybe ( Curve clo' CachedStroke ( PointData brushParams ) ) )
updateSplineCurve uniq mbPrevPt crv =
case crv of
LineTo p1 _ ->
case ssplineType @clo' of
SOpen
| NextPoint pt <- p1
, Selected <- view _selection pt
-> do
modify'
( over ( field' @"pathPointsAffected" ) ( <> 1 )
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
)
pure Nothing
_ ->
case mbPrevPt of
Nothing -> pure ( Just $ LineTo p1 noDat ) -- no need to update "strokesAffected"
Just _ -> pure ( Just crv )
Bezier2To cp1 p2 _ ->
case ssplineType @clo' of
SOpen
| NextPoint pt <- p2
, Selected <- view _selection pt
-> do
modify'
( over ( field' @"pathPointsAffected" ) ( <> 1 )
. over ( field' @"controlPointsAffected" ) ( <> 1 )
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
)
pure Nothing
_ ->
case mbPrevPt of
Just _ | Normal <- view _selection cp1
-> pure ( Just crv )
_ -> do
modify'
( over ( field' @"controlPointsAffected" ) ( <> 1 )
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
)
pure ( Just $ LineTo p2 noDat )
Bezier3To cp1 cp2 p3 _ ->
case ssplineType @clo' of
SOpen
| NextPoint pt <- p3
, Selected <- view _selection pt
-> do
modify'
( over ( field' @"pathPointsAffected" ) ( <> 1 )
. over ( field' @"controlPointsAffected" ) ( <> 2 )
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
)
pure Nothing
_ ->
case mbPrevPt of
Just _
| Normal <- view _selection cp1
, Normal <- view _selection cp2
-> pure ( Just crv )
| Normal <- view _selection cp1
-> do
modify'
( over ( field' @"controlPointsAffected" ) ( <> 1 )
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
)
pure ( Just $ Bezier2To cp1 p3 noDat )
| Normal <- view _selection cp2
-> do
modify'
( over ( field' @"controlPointsAffected" ) ( <> 1 )
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
)
pure ( Just $ Bezier2To cp2 p3 noDat )
_ -> do
modify'
( over ( field' @"controlPointsAffected" ) ( <> 2 )
. over ( field' @"strokesAffected" ) ( Set.insert uniq )
)
pure ( Just $ LineTo p3 noDat )
-- | Perform a drag move action on a document.
dragUpdate :: Mode -> Point2D Double -> Point2D Double -> DragMoveSelect -> Bool -> Document -> Maybe DocChange
dragUpdate mode p0 p PointDrag _ doc = case updateInfo of
dragUpdate :: Point2D Double -> Point2D Double -> DragMoveSelect -> Bool -> Document -> Maybe DocChange
dragUpdate p0 p PointDrag _ doc = case updateInfo of
UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected }
| null strokesAffected
-> Nothing
@ -589,8 +660,8 @@ dragUpdate mode p0 p PointDrag _ doc = case updateInfo of
where
newDocument :: Document
updateInfo :: UpdateInfo
( newDocument, updateInfo ) = translateSelection mode ( p0 --> p ) doc
dragUpdate mode _ p ( ClickedOnCurve {..} ) alternateMode doc
( newDocument, updateInfo ) = translateSelection ( p0 --> p ) doc
dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmentParameter } ) alternateMode doc
| Just name <- mbStrokeName
, let
changeText :: Text
@ -602,124 +673,93 @@ dragUpdate mode _ p ( ClickedOnCurve {..} ) alternateMode doc
newDocument :: Document
mbStrokeName :: Maybe Text
( newDocument, mbStrokeName )
= ( `runState` Nothing )
$ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
= ( `runState` Nothing ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc
updateStroke :: Stroke -> State ( Maybe Text ) Stroke
updateStroke stroke@( Stroke { strokeUnique, strokeName } )
| strokeUnique /= dragStrokeUnique
= pure stroke
| Brush <- mode
= ( field' @"strokePoints" . traverse )
( \ spt ->
if dragBrushCenter /= Just ( coords spt )
then -- only update the correct brush path
pure spt
else
( field' @"pointData" . field' @"brushShape" )
( updateStrokePoints strokeName ( MkVector2D $ coords spt ) )
spt
)
stroke
| otherwise
= ( field' @"strokePoints" )
( updateStrokePoints strokeName ( Vector2D 0 0 ) )
stroke
updateStrokePoints
:: forall pt. Show pt
=> Text -> Vector2D Double
-> Seq ( StrokePoint pt ) -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) )
updateStrokePoints _ _ Empty = pure Empty
updateStrokePoints name offset ( spt :<| spts ) = go 0 spt spts
= _strokeSpline updateSpline stroke
where
p_eff :: Point2D Double
p_eff = invert offset • p
go :: Int -> StrokePoint pt -> Seq ( StrokePoint pt ) -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) )
go _ sp0 Empty = pure ( sp0 :<| Empty )
-- Line.
go i sp0 ( sp1 :<| sps )
| PathPoint {} <- sp1
= case compare i dragSegmentIndex of
GT -> pure ( sp0 :<| sp1 :<| sps )
LT -> ( sp0 :<| ) <$> go ( i + 1 ) sp1 sps
EQ -> do
updateSpline
:: forall clo pointParams
. ( KnownSplineType clo, Interpolatable pointParams )
=> StrokeSpline clo pointParams
-> State ( Maybe Text ) ( StrokeSpline clo pointParams )
updateSpline
= fmap ( adjustSplineType @clo )
. updateSplineCurves strokeName
. adjustSplineType @Open
where
updateSplineCurves
:: Text
-> StrokeSpline Open pointParams
-> State ( Maybe Text ) ( StrokeSpline Open pointParams)
updateSplineCurves name spline = case splitSplineAt dragSegmentIndex spline of
( _ , Spline { splineCurves = OpenCurves Empty } ) -> pure spline
( bef, Spline { splineStart, splineCurves = OpenCurves ( curve :<| next ) } ) -> do
put ( Just name )
pure ( bef <> Spline { splineStart, splineCurves = OpenCurves $ updateCurve ( lastPoint bef ) curve :<| next } )
where
updateCurve
:: PointData pointParams
-> Curve Open CachedStroke ( PointData pointParams )
-> Curve Open CachedStroke ( PointData pointParams )
updateCurve sp0 curve = case curve of
LineTo ( NextPoint sp1 ) dat -> do
let
bez2 :: Quadratic.Bezier ( PointData pointParams )
bez2 = Quadratic.Bezier sp0 ( lerp @( DiffPointData ( Diff pointParams ) ) dragSegmentParameter sp0 sp1 ) sp1
if alternateMode
then
then quadraticDragCurve dat bez2
else cubicDragCurve dat ( Cubic.fromQuadratic @( DiffPointData ( Diff pointParams ) ) bez2 )
Bezier2To sp1 ( NextPoint sp2 ) dat -> do
let
p1 :: Point2D Double
Quadratic.Bezier { p1 } =
Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp1 ) dragSegmentParameter p_eff
cp :: StrokePoint pt
cp = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate
in pure ( sp0 :<| cp :<| sp1 :<| sps )
else
let
bez :: Cubic.Bezier ( Point2D Double )
bez = Cubic.Bezier ( coords sp0 ) ( coords sp0 ) ( coords sp1 ) ( coords sp1 )
p1, p2 :: Point2D Double
Cubic.Bezier { p1, p2 } =
Cubic.drag @( Vector2D Double ) bez dragSegmentParameter p_eff
cp1, cp2 :: StrokePoint pt
cp1 = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate
cp2 = ControlPoint { coords = p2, pointData = pointData sp1 } -- TODO: interpolate
in pure ( sp0 :<| cp1 :<| cp2 :<| sp1 :<| sps )
-- Quadratic Bézier curve.
go i sp0 ( sp1 :<| sp2 :<| sps )
| ControlPoint {} <- sp1
, PathPoint {} <- sp2
= case compare i dragSegmentIndex of
GT -> pure ( sp0 :<| sp1 :<| sp2 :<| sps )
LT -> ( ( sp0 :<| ) . ( sp1 :<| ) ) <$> go ( i + 2 ) sp2 sps
EQ -> do
put ( Just name )
if not alternateMode -- switch alternate mode for quadratic Bézier case...
then
let
p1 :: Point2D Double
Quadratic.Bezier { p1 } =
Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp2 ) dragSegmentParameter p_eff
cp :: StrokePoint pt
cp = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate
in pure ( sp0 :<| cp :<| sp2 :<| sps )
else
let
bez :: Cubic.Bezier ( Point2D Double )
bez = Cubic.fromQuadratic @( Vector2D Double ) ( Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) )
p1, p2 :: Point2D Double
Cubic.Bezier { p1, p2 } =
Cubic.drag @( Vector2D Double ) bez dragSegmentParameter p_eff
cp1, cp2 :: StrokePoint pt
cp1 = sp1 { coords = p1 } -- TODO: interpolate
cp2 = sp1 { coords = p2 } -- TODO: interpolate
in pure ( sp0 :<| cp1 :<| cp2 :<| sp2 :<| sps )
-- Cubic Bézier curve.
go i sp0 ( sp1 :<| sp2 :<| sp3 :<| sps )
| ControlPoint {} <- sp1
, ControlPoint {} <- sp2
, PathPoint {} <- sp3
= case compare i dragSegmentIndex of
GT -> pure ( sp0 :<| sp1 :<| sp2 :<| sp3 :<| sps )
LT -> ( ( sp0 :<| ) . ( sp1 :<| ) . ( sp2 :<| ) ) <$> go ( i + 3 ) sp3 sps
EQ -> do
put ( Just name )
bez2 :: Quadratic.Bezier ( PointData pointParams )
bez2 = Quadratic.Bezier sp0 sp1 sp2
if alternateMode
then
then cubicDragCurve dat $ Cubic.fromQuadratic @( DiffPointData ( Diff pointParams ) ) bez2
else quadraticDragCurve dat ( Quadratic.Bezier sp0 sp1 sp2 )
Bezier3To sp1 sp2 ( NextPoint sp3 ) dat -> do
let
p1 :: Point2D Double
Quadratic.Bezier { p1 } =
Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp3 ) dragSegmentParameter p_eff
cp :: StrokePoint pt
cp = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate
in pure ( sp0 :<| cp :<| sp3 :<| sps )
else
bez3 :: Cubic.Bezier ( PointData pointParams )
bez3 = Cubic.Bezier sp0 sp1 sp2 sp3
if alternateMode
then quadraticDragCurve dat
( Quadratic.Bezier
sp0
( Cubic.bezier @( DiffPointData ( Diff pointParams ) ) bez3 dragSegmentParameter )
sp3
)
else cubicDragCurve dat bez3
where
quadraticDragCurve
:: CachedStroke
-> Quadratic.Bezier ( PointData pointParams )
-> Curve Open CachedStroke ( PointData pointParams )
quadraticDragCurve dat ( Quadratic.Bezier { Quadratic.p1 = sp1, Quadratic.p2 = sp2 } ) =
let
bez :: Cubic.Bezier ( Point2D Double )
bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 )
p1, p2 :: Point2D Double
Cubic.Bezier { p1, p2 } =
Cubic.drag @( Vector2D Double ) bez dragSegmentParameter p_eff
cp1, cp2 :: StrokePoint pt
cp1 = sp1 { coords = p1 } -- TODO: interpolate
cp2 = sp2 { coords = p2 } -- TODO: interpolate
in pure ( sp0 :<| cp1 :<| cp2 :<| sp3 :<| sps )
go _ sp0 sps = error ( "dragUpdate: unrecognised stroke type\n" <> show ( sp0 :<| sps ) )
cp :: Point2D Double
Quadratic.Bezier { Quadratic.p1 = cp } =
Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp2 ) dragSegmentParameter p
dat' :: CachedStroke
dat' = discardCache dat
in Bezier2To ( set _coords cp sp1 ) ( NextPoint sp2 ) dat'
cubicDragCurve
:: CachedStroke
-> Cubic.Bezier ( PointData pointParams )
-> Curve Open CachedStroke ( PointData pointParams )
cubicDragCurve dat ( Cubic.Bezier { Cubic.p1 = sp1, Cubic.p2 = sp2, Cubic.p3 = sp3 } ) =
let
cp1, cp2 :: Point2D Double
Cubic.Bezier { Cubic.p1 = cp1, Cubic.p2 = cp2 } =
Cubic.drag @( Vector2D Double )
( Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 ) )
dragSegmentParameter
p
dat' :: CachedStroke
dat' = discardCache dat
in Bezier3To ( set _coords cp1 sp1 ) ( set _coords cp2 sp2 ) ( NextPoint sp3 ) dat'

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

@ -1,12 +1,26 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# 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
( documentToJSON, documentFromJSON
( Serialisable(..)
, documentToJSON, documentFromJSON
, saveDocument, loadDocument
)
where
@ -24,6 +38,24 @@ import Data.Functor.Contravariant
( contramap )
import Data.Functor.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
( unsafeCoerce ) -- Tony Morris special
@ -51,6 +83,10 @@ import Data.Sequence
import qualified Data.Sequence as Seq
( fromList )
-- deepseq
import Control.DeepSeq
( NFData(..) )
-- directory
import System.Directory
( canonicalizePath, createDirectoryIfMissing, doesFileExist )
@ -63,10 +99,18 @@ import System.FilePath
import Data.Generics.Product.Typed
( HasType(typed) )
-- groups
import Data.Group
( Group )
-- lens
import Control.Lens
( view )
-- mtl
import Control.Monad.Except
( MonadError(throwError) )
-- scientific
import qualified Data.Scientific as Scientific
( fromFloatDigits, toRealFloat )
@ -75,13 +119,29 @@ import qualified Data.Scientific as Scientific
import qualified Control.Concurrent.STM as STM
( 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
import Data.Text
( Text )
import qualified Data.Text as Text
( pack, unpack, unwords )
-- transformers
import Control.Monad.IO.Class
( MonadIO(liftIO) )
import Control.Monad.Trans.Reader
( runReaderT )
import Control.Monad.Trans.Class
( MonadTrans(lift) )
@ -91,14 +151,14 @@ import qualified Waargonaut.Attoparsec as JSON.Decoder
import qualified Waargonaut.Decode as JSON
( Decoder )
import qualified Waargonaut.Decode.Error as JSON
( DecodeError )
( DecodeError(ParseFailed) )
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
( Encoder, Encoder' )
( Encoder )
import qualified Waargonaut.Encode as JSON.Encoder
( runEncoder
, atKey', bool, list, mapLikeObj, scientific, text
( runEncoder, runPureEncoder
, atKey', bool, json, keyValueTupleFoldable, list, mapLikeObj, scientific, text, either
)
import qualified Waargonaut.Encode.Builder as JSON.Builder
( waargonautBuilder, bsBuilder )
@ -112,20 +172,40 @@ import qualified Waargonaut.Prettier as JSON
( prettyJson )
import qualified Waargonaut.Prettier as TonyMorris
( Natural )
import Waargonaut.Types.Json
( Json )
-- MetaBrush
import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Document
( Document(..), DocumentContent(..)
, Guide(..)
, Stroke(..)
, PointData(..)
, BrushPointData(..)
, FocusState(..)
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(..)
, Curves(..), Curve(..), NextPoint(..)
)
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
( Unique, UniqueSupply, freshUnique )
@ -176,31 +256,53 @@ loadDocument uniqueSupply fp = do
--------------------------------------------------------------------------------
encodeDouble :: Applicative f => JSON.Encoder f Double
encodeDouble = contramap Scientific.fromFloatDigits JSON.Encoder.scientific
class Serialisable a where
encoder :: Monad f => JSON.Encoder f a
decoder :: Monad m => JSON.Decoder m a
decodeDouble :: Monad m => JSON.Decoder m Double
decodeDouble = fmap Scientific.toRealFloat JSON.Decoder.scientific
instance Serialisable Double where
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 )
encodePoint2D enc = JSON.Encoder.mapLikeObj \ ( Point2D x y ) ->
JSON.Encoder.atKey' "x" enc x . JSON.Encoder.atKey' "y" enc y
instance ( SuperRecord.RecApply flds flds ( ConstC Serialisable )
, SuperRecord.UnsafeRecBuild flds flds ( ConstC Serialisable )
, 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 )
decodePoint2D dec = Point2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" dec
encodeVector2D :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Vector2D a )
encodeVector2D enc = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) ->
JSON.Encoder.atKey' "x" enc x
. JSON.Encoder.atKey' "y" enc y
decodeVector2D :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Vector2D a )
decodeVector2D dec = Vector2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" dec
decoder :: forall m. Monad m => JSON.Decoder m ( Super.Rec flds )
decoder = SuperRecord.unsafeRecBuild @flds @flds @( ConstC Serialisable ) decodeAndWrite
where
decodeAndWrite
:: forall k v
. ( KnownSymbol k, Serialisable v )
=> SuperRecord.FldProxy k -> Proxy# v
-> JSON.Decoder m v
decodeAndWrite _ _ = do
let
k :: Text
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 )
@ -238,30 +340,115 @@ decodeAABB = do
-}
encodeStrokePoint :: Applicative f => JSON.Encoder' d -> JSON.Encoder f ( StrokePoint d )
encodeStrokePoint enc = JSON.Encoder.mapLikeObj \case
PathPoint { coords, pointData } ->
JSON.Encoder.atKey' "coords" ( encodePoint2D encodeDouble ) coords
. JSON.Encoder.atKey' "data" enc pointData
. JSON.Encoder.atKey' "type" JSON.Encoder.text "path"
ControlPoint { coords, pointData } ->
JSON.Encoder.atKey' "coords" ( encodePoint2D encodeDouble ) coords
. JSON.Encoder.atKey' "data" enc pointData
. JSON.Encoder.atKey' "type" JSON.Encoder.text "control"
encodeCurve
:: forall clo crvData ptData f
. ( SplineTypeI clo, Applicative f )
=> JSON.Encoder Identity ptData
-> JSON.Encoder f ( Curve clo crvData ptData )
encodeCurve encodePtData = case ssplineType @clo of
SOpen -> JSON.Encoder.mapLikeObj \case
LineTo ( NextPoint p1 ) _ ->
JSON.Encoder.atKey' "p1" encodePtData p1
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
decodeStrokePointTypeIsPath = JSON.Decoder.oneOf JSON.Decoder.text "StrokePoint Type"
[ ( "path", True ), ( "control", False ) ]
decodeCurve
:: forall clo ptData m
. ( 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 = contramap focusText JSON.Encoder.text
where
@ -287,7 +474,7 @@ decodeBrushPointData :: Monad m => JSON.Decoder m BrushPointData
decodeBrushPointData = do
brushPointState <- JSON.Decoder.atKey "focus" decodeFocusState
pure ( BrushPointData { brushPointState } )
-}
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 = JSON.Encoder.mapLikeObj \ ( PointData { pointState, brushShape } ) ->
JSON.Encoder.atKey' "focus" encodeFocusState pointState
. JSON.Encoder.atKey' "brush" ( encodeSequence ( encodeStrokePoint encodeBrushPointData ) ) brushShape
encodePointData
:: forall f flds brushParams
. ( Applicative f
, 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
pointState <- JSON.Decoder.atKey "focus" decodeFocusState
brushShape <- JSON.Decoder.atKey "brush" ( decodeSequence ( decodeStrokePoint decodeBrushPointData ) )
pure ( PointData { pointState, brushShape } )
pointCoords <- JSON.Decoder.atKey "coords" ( decoder @( Point2D Double ) )
let
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
encodeStroke = JSON.Encoder.mapLikeObj \ ( Stroke { strokeName, strokeVisible, strokePoints } ) ->
encodeSomeSType :: Applicative f => JSON.Encoder f SomeSType
encodeSomeSType = JSON.Encoder.mapLikeObj \ ( SomeSType ( _ :: Proxy# ty ) ) ->
case sTypeI @ty of
sFunTy@SFunTy | ( _ :: SType ( a -> b ) ) <- sFunTy
-> 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 )
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' "points" ( encodeSequence ( encodeStrokePoint encodePointData ) ) strokePoints
. 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 :: MonadIO m => UniqueSupply -> JSON.Decoder m Stroke
decodeStroke :: forall m. MonadIO m => UniqueSupply -> JSON.Decoder m Stroke
decodeStroke uniqueSupply = do
strokeName <- JSON.Decoder.atKey "name" JSON.Decoder.text
strokeVisible <- JSON.Decoder.atKey "visible" JSON.Decoder.bool
strokeUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
strokePoints <- JSON.Decoder.atKey "points" ( decodeSequence ( decodeStrokePoint decodePointData ) )
pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokePoints } )
strokeUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
strokeClosed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool
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 = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal, guideFocus } ) ->
JSON.Encoder.atKey' "point" ( encodePoint2D encodeDouble ) guidePoint
. JSON.Encoder.atKey' "normal" ( encodeVector2D encodeDouble ) guideNormal
. JSON.Encoder.atKey' "focus" encodeFocusState guideFocus
encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) ->
JSON.Encoder.atKey' "point" ( encoder @( Point2D Double ) ) guidePoint
. JSON.Encoder.atKey' "normal" ( encoder @( Vector2D Double ) ) guideNormal
decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m Guide
decodeGuide uniqueSupply = do
guidePoint <- JSON.Decoder.atKey "point" ( decodePoint2D decodeDouble )
guideNormal <- JSON.Decoder.atKey "normal" ( decodeVector2D decodeDouble )
guideFocus <- JSON.Decoder.atKey "focus" decodeFocusState
guideUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
guidePoint <- JSON.Decoder.atKey "point" ( decoder @( Point2D Double ) )
guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( Vector2D Double ) )
let
guideFocus :: FocusState
guideFocus = Normal
guideUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
pure ( Guide { guidePoint, guideNormal, guideFocus, guideUnique } )
encodeDocumentContent :: Applicative f => JSON.Encoder f DocumentContent
encodeDocumentContent = JSON.Encoder.mapLikeObj \ ( Content { guides, strokes } ) ->
JSON.Encoder.atKey' "guides" ( encodeUniqueMap encodeGuide ) guides
@ -371,15 +777,187 @@ decodeDocumentContent uniqueSupply = do
encodeDocument :: Applicative f => JSON.Encoder f Document
encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, documentContent } ) ->
JSON.Encoder.atKey' "name" JSON.Encoder.text displayName
. JSON.Encoder.atKey' "center" ( encodePoint2D encodeDouble ) viewportCenter
. JSON.Encoder.atKey' "zoom" encodeDouble zoomFactor
. JSON.Encoder.atKey' "center" ( encoder @( Point2D Double ) ) viewportCenter
. JSON.Encoder.atKey' "zoom" ( encoder @Double ) zoomFactor
. JSON.Encoder.atKey' "content" encodeDocumentContent documentContent
decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document
decodeDocument uniqueSupply mbFilePath = do
displayName <- JSON.Decoder.atKey "name" JSON.Decoder.text
viewportCenter <- JSON.Decoder.atKey "center" ( decodePoint2D decodeDouble )
zoomFactor <- JSON.Decoder.atKey "zoom" decodeDouble
documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
viewportCenter <- JSON.Decoder.atKey "center" ( decoder @( Point2D Double ) )
zoomFactor <- JSON.Decoder.atKey "zoom" ( decoder @Double )
documentUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
documentContent <- JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply )
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

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

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

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 )
-}

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

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

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

@ -1,4 +1,9 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.UI.Coordinates
@ -6,6 +11,10 @@ module MetaBrush.UI.Coordinates
where
-- base
import Data.Coerce
( coerce )
import Data.Functor.Identity
( Identity(..) )
import Data.Semigroup
( ArgMin, Arg(..), Min(..) )
@ -17,23 +26,23 @@ import Data.Act
( (-->) )
)
-- containers
import Data.Sequence
( Seq(..) )
-- MetaBrush
import qualified Math.Bezier.Cubic as Cubic
( Bezier(..), closestPoint )
import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..), closestPoint )
import Math.Bezier.Stroke
( StrokePoint(..) )
import Math.Bezier.Spline
( Curve(..), Spline(..), SplineTypeI, KnownSplineType(bifoldSpline)
, fromNextPoint
)
import Math.Module
( (*^), squaredNorm, closestPointToSegment )
( (*^), squaredNorm, closestPointOnSegment )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
( Point2D(..), Vector2D(..), Segment(..) )
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.
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
res :: Point2D Double -> ArgMin Double ( Maybe ( Point2D Double ) )
res p = Min $ 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"
go p0 Empty = res ( coords p0 )
-- Line.
go ( PathPoint { coords = p0 } )
( sp1@( PathPoint { coords = p1 } ) :<| ps )
= res ( snd $ closestPointToSegment @( Vector2D Double ) c p0 p1 )
<> go sp1 ps
-- Quadratic Bézier curve.
go ( PathPoint { coords = p0 } )
( ControlPoint { coords = p1 } :<| sp2@( PathPoint { coords = p2 } ) :<| ps )
= fmap ( fmap ( Just . snd ) )
( Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier {..} ) c )
<> go sp2 ps
-- Cubic Bézier curve.
go ( PathPoint { coords = p0 } )
( PathPoint { coords = p1 } :<| PathPoint { coords = p2 } :<| sp3@( PathPoint { coords = p3 } ) :<| ps )
= fmap ( fmap ( Just . snd ) )
( Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier {..} ) c )
<> go sp3 ps
go p0 ps = error $ "closestPoint: unrecognised stroke type\n" <> show ( p0 :<| ps )
closestPoint _ _ = Min $ Arg ( 1 / 0 ) Nothing
res :: Point2D Double -> Identity ( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) )
res p = coerce $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p )
closestPointToCurve
:: forall clo crvData brushParams
. SplineTypeI clo
=> PointData brushParams
-> PointData brushParams
-> Curve clo crvData ( PointData brushParams )
-> Identity ( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) )
closestPointToCurve start p0 ( LineTo p1 _ ) =
res ( snd $ closestPointOnSegment @( Vector2D Double ) c ( Segment (coords p0 ) ( coords $ fromNextPoint start p1 ) ) )
closestPointToCurve start p0 ( Bezier2To p1 p2 _ ) = coerce $
fmap ( fmap ( Just . snd ) )
( Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier ( coords p0 ) ( coords p1 ) ( coords $ fromNextPoint start p2 ) ) c )
closestPointToCurve start p0 ( Bezier3To p1 p2 p3 _ ) = coerce $
fmap ( fmap ( Just . snd ) )
( Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier ( coords p0 ) ( coords p1 ) ( coords p2 ) ( coords $ fromNextPoint start p3 ) ) c )
closestPoint _ _ = coerce $ mempty @( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) )
-- Messing around to emulate a `Monoid` instance for `ArgMin Double ( Maybe ( Point2D Double ) )`
newtype BoundedDouble = BoundedDouble Double
deriving stock Show
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
( writeTVar, readTVar, readTVarIO, modifyTVar' )
-- transformers
import Control.Monad.Trans.Reader
( runReaderT )
-- MetaBrush
import MetaBrush.Action
( SwitchTo(..), Close(..), handleAction )
@ -97,7 +101,7 @@ newFileTab
-> IO ()
newFileTab
initialStage
uiElts@( UIElements { fileBar = FileBar {..}, viewport = Viewport {..}, .. } )
uiElts@( UIElements { fileBar = FileBar {..}, .. } )
vars@( Variables {..} )
mbDocHist
newTabLoc
@ -108,7 +112,7 @@ newFileTab
Just docHist -> do pure docHist
-- Create a new empty document.
Nothing -> do
newDocUniq <- STM.atomically $ freshUnique uniqueSupply
newDocUniq <- STM.atomically $ runReaderT freshUnique uniqueSupply
pure ( newHistory $ emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq )
let

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

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

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

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

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

@ -1,13 +1,18 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Unique
( Unique, unsafeUnique
, freshUnique, uniqueText
( MonadUnique(freshUnique)
, Unique, unsafeUnique
, uniqueText
, UniqueSupply, newUniqueSupply
, uniqueMapFromList
)
@ -41,9 +46,15 @@ import Data.Generics.Product.Typed
import Control.Lens
( view )
-- mtl
import Control.Monad.Reader
( MonadReader(..) )
-- stm
import Control.Concurrent.STM
( STM )
import qualified Control.Concurrent.STM as STM
( atomically )
import qualified Control.Concurrent.STM.TVar as STM
( TVar, newTVarIO, readTVar, writeTVar )
@ -53,11 +64,19 @@ import Data.Text
import qualified Data.Text as Text
( 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 }
deriving stock Show
deriving newtype ( Eq, Ord, Storable, NFData )
deriving newtype ( Eq, Ord, Enum, Storable, NFData )
unsafeUnique :: Word32 -> Unique
unsafeUnique i = Unique ( - fromIntegral i - 1 )
@ -71,14 +90,29 @@ uniqueText ( Unique i )
newtype UniqueSupply = UniqueSupply { uniqueSupplyTVar :: STM.TVar Unique }
freshUnique :: UniqueSupply -> STM Unique
freshUnique ( UniqueSupply { uniqueSupplyTVar } ) = do
uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar
STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) )
pure uniq
instance Show UniqueSupply where { show _ = "Unique supply" }
newUniqueSupply :: IO UniqueSupply
newUniqueSupply = UniqueSupply <$> STM.newTVarIO ( Unique 1 )
uniqueMapFromList :: HasType Unique a => [ a ] -> Map Unique a
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
:: forall v r p. ( Torsor v p, Inner r v, RealFloat r, Prim r )
=> 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
roots :: [ r ]
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 DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
@ -40,12 +41,16 @@ import Data.Act
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( fromList, singleton )
( fromList )
-- deepseq
import Control.DeepSeq
( NFData )
-- parallel
import qualified Control.Parallel.Strategies as Parallel.Strategy
( rdeepseq, parTuple2, using )
-- primitive
import Data.Primitive.PrimArray
( primArrayFromListN, unsafeThawPrimArray )
@ -67,6 +72,10 @@ import qualified Data.Vector.Unboxed as Unboxed.Vector
-- MetaBrush
import qualified Math.Bezier.Cubic as Cubic
( Bezier(..), bezier, ddist )
import Math.Bezier.Spline
( SplineType(..), SplinePts
, openCubicBezierCurveSpline
)
import Math.Epsilon
( epsilon )
import Math.Linear.Solve
@ -119,7 +128,7 @@ data FitPoint
fitSpline
:: FitParameters
-> ( 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
where
dt :: Double
@ -127,26 +136,32 @@ fitSpline ( FitParameters {..} ) = go 0
go
:: Int
-> ( Double -> ( Point2D Double, Vector2D Double ) )
-> ( Seq ( Cubic.Bezier ( Point2D Double ) ), Seq FitPoint )
go subdiv curve =
-> ( SplinePts Open, Seq FitPoint )
go subdiv curveFn =
let
p, r :: Point2D Double
tp, tr :: Vector2D Double
qs :: [ Point2D Double ]
(p, tp) = curve 0
(r, tr) = curve 1
qs = [ fst $ curve ( dt * fromIntegral j ) | j <- [ 1 .. nbSegments - 1 ] ]
(p, tp) = curveFn 0
(r, tr) = curveFn 1
qs = [ fst $ curveFn ( dt * fromIntegral j ) | j <- [ 1 .. nbSegments - 1 ] ]
in
case fitPiece dist_tol t_tol maxIters p tp qs r tr of
( bez, Max ( Arg max_sq_error t_split ) )
| subdiv >= maxSubdiv
|| 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
t_split_eff :: Double
t_split_eff = min ( 1 - dt ) $ max dt t_split
-> go ( subdiv + 1 ) ( \ t -> curve $ t * t_split_eff )
<> go ( subdiv + 1 ) ( \ t -> curve $ t_split_eff + t * ( 1 - t_split_eff ) )
c1, c2 :: SplinePts Open
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.
--

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

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

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

@ -3,34 +3,45 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module Math.Bezier.Stroke
( StrokePoint(PP, CP, ..)
, Offset(..)
, stroke, joinWithBrush
( Offset(..)
, CachedStroke(..), discardCache
, computeStrokeOutline, joinWithBrush
, withTangent
, between, parallel
)
where
-- base
import Prelude
hiding ( unzip )
import Control.Arrow
( first )
( first, (***) )
import Control.Monad
( guard )
( guard, unless )
import Data.Bifunctor
( Bifunctor(bimap) )
import Data.Foldable
( for_ )
import Data.List.NonEmpty
( unzip )
import Data.Maybe
( fromMaybe, mapMaybe )
import GHC.Generics
( Generic )
( Generic, Generic1 )
-- acts
import Data.Act
@ -44,189 +55,220 @@ import Data.Act
import Data.Sequence
( Seq(..) )
import qualified Data.Sequence as Seq
( splitAt, drop, dropWhileL
, zipWith, zipWith3, zipWith4
)
( singleton )
-- deepseq
import Control.DeepSeq
( NFData )
( NFData, NFData1 )
-- generic-lens
import Data.Generics.Product.Fields
( field, field' )
import Data.Generics.Product.Typed
( HasType(typed) )
import Data.GenericLens.Internal
( set, over, view )
( set, view )
-- monad-par
import Control.Monad.Par
( Par )
import qualified Control.Monad.Par as Par
( get, runPar, spawn, spawnP )
-- groups
import Data.Group
( Group )
-- parallel
import qualified Control.Parallel.Strategies as Strats
( rdeepseq, parTuple2, using )
-- transformers
import Control.Monad.Trans.Class
( lift )
import Control.Monad.Trans.Except
( Except, runExcept, throwE )
import Control.Monad.Trans.State.Strict
( StateT, runStateT, evalStateT, get, put )
import Control.Monad.Trans.Writer.CPS
( Writer, runWriter, tell )
-- MetaBrush
import qualified Math.Bezier.Cubic as Cubic
import Math.Bezier.Cubic.Fit
( FitPoint, FitParameters, fitSpline )
import Math.Bezier.Spline
( SplineType(..), SSplineType(..), SplineTypeI
, ssplineType, adjustSplineType
, NextPoint(..), fromNextPoint
, KnownSplineType
( bitraverseSpline, ibifoldSpline, bimapSpline )
, Spline(..), SplinePts, Curves(..), Curve(..)
, openCurveStart, openCurveEnd
, splitSplineAt, dropCurves
)
import qualified Math.Bezier.Quadratic as Quadratic
import Math.Epsilon
( epsilon )
import Math.Module
( Module((^-^), (*^)), Inner((^.^))
, lerp, squaredNorm
, lerp, squaredNorm, cross
)
import Math.Roots
( solveQuadratic )
import Math.Vector2D
( Point2D(..), Vector2D(..), cross )
( Point2D(..), Vector2D(..) )
--------------------------------------------------------------------------------
data StrokePoint d
= PathPoint
{ coords :: !( Point2D Double )
, pointData :: d
}
| ControlPoint
{ coords :: !( Point2D Double )
, pointData :: d
}
deriving stock ( Show, Generic )
deriving anyclass NFData
instance Act ( Vector2D Double ) ( StrokePoint d ) where
(•) v = over ( field' @"coords" ) ( v • )
instance Act ( Vector2D Double ) ( Seq ( StrokePoint d ) ) where
(•) v = fmap ( v • )
pattern PP, CP :: Point2D Double -> StrokePoint ()
pattern PP p = PathPoint p ()
pattern CP p = ControlPoint p ()
data Offset
= Offset
{ offsetIndex :: !Int
, offsetParameter :: !( Maybe Double )
, offset :: !( Vector2D Double )
--, curvature :: !Double
}
deriving stock ( Show, Generic )
deriving anyclass NFData
data TwoSided a
= TwoSided
{ fwd :: !a
, bwd :: !a
}
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
deriving anyclass ( NFData, NFData1 )
type OutlineData = TwoSided ( SplinePts Open, Seq FitPoint )
instance Semigroup OutlineData where
TwoSided ( fwdSpline1, fwdPts1 ) ( bwdSpline1, bwdPts1 ) <> TwoSided ( fwdSpline2, fwdPts2 ) ( bwdSpline2, bwdPts2 ) =
TwoSided
( fwdSpline1 <> fwdSpline2, fwdPts1 <> fwdPts2 )
( bwdSpline2 <> bwdSpline1, bwdPts2 <> bwdPts1 )
instance Monoid OutlineData where
mempty = TwoSided empt empt
where
empt :: ( SplinePts Open, Seq FitPoint )
empt = ( Spline { splineStart = Point2D 0 0, splineCurves = OpenCurves Empty }, Empty )
newtype CachedStroke = CachedStroke { upToDateFit :: Maybe OutlineData }
deriving stock ( Show, Generic )
deriving anyclass NFData
discardCache :: HasType CachedStroke crvData => crvData -> crvData
discardCache = set ( typed @CachedStroke ) ( CachedStroke Nothing )
coords :: forall ptData. HasType ( Point2D Double ) ptData => ptData -> Point2D Double
coords = view typed
--------------------------------------------------------------------------------
stroke
:: forall x d
. ( Show x, Show d
, HasType ( Seq ( StrokePoint x ) ) d
computeStrokeOutline ::
forall diffParams ( clo :: SplineType ) brushParams crvData ptData
. ( KnownSplineType clo
, Group diffParams, Module Double diffParams
, Torsor diffParams brushParams
, HasType ( Point2D Double ) ptData
, HasType CachedStroke crvData
, NFData ptData, NFData crvData
)
=> FitParameters
-> Seq ( StrokePoint d )
-> ( Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ), Seq FitPoint )
stroke _ Empty = ( Left Empty, Empty )
stroke _ ( spt0 :<| Empty ) = ( Left . removePointData $ ( Point2D 0 0 --> coords spt0 :: Vector2D Double ) • brushShape @x spt0, Empty )
stroke params allPts@( spt0 :<| spt1 :<| spts )
| isClosed
= if null ( brushShape @x spt0 )
then ( Right mempty, mempty )
else ( Right ( fwdPts, bwdPts ), fwdFits <> bwdFits )
| otherwise
= if null ( brushShape @x spt0 )
then ( Left Empty, Empty )
else ( Left ( startingCap <> fwdPts <> bwdPts ), fwdFits <> bwdFits )
where
startOffset, endOffset :: Vector2D Double
tgt_start, tgt_end :: Vector2D Double
brush_start, brush_end :: Seq ( StrokePoint x )
startOffset = Point2D 0 0 --> coords spt0
tgt_start = coords spt0 --> coords spt1
( tgt_end, endOffset, brush_end ) = case allPts of
_ :|> sptnm1 :|> sptn -> ( coords sptnm1 --> coords sptn, Point2D 0 0 --> coords sptn, brushShape @x sptn )
_ -> error "impossible"
brush_start = brushShape @x spt0
isClosed :: Bool
isClosed = case ( spt1 :<| spts ) of
( _ :|> PathPoint { coords = lpt } )
| lpt == coords spt0
-> True
_ -> False
fwdPts, bwdPts :: Seq ( StrokePoint () )
fwdFits, bwdFits :: Seq FitPoint
( ( fwdPts, fwdFits ), ( bwdPts, bwdFits ) ) = Par.runPar $ go spt0 ( spt1 :<| spts )
(<~>)
:: ( Monoid a, Monoid b )
=> ( a, b )
-> ( a, b )
-> ( a, b )
(a1, b1) <~> (a2, b2) = ( a1 <> a2, b2 <> b1 )
-- Connecting paths at a point of discontinuity of the tangent vector direction (G1 discontinuity).
-- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction).
joinAndContinue
:: Vector2D Double
-> StrokePoint d
-> Seq ( StrokePoint d )
-> Par ( ( Seq ( StrokePoint () ), Seq FitPoint ), ( Seq ( StrokePoint () ), Seq FitPoint ) )
joinAndContinue tgt sp0 ( sp1 :<| sps )
| tgt' `parallel` tgt
= go sp0 ( sp1 :<| sps )
| let
ptOffset :: Vector2D Double
ptOffset = Point2D 0 0 --> coords sp0
= do
let
brushJoin :: ( ( Seq ( StrokePoint () ), Seq FitPoint ), ( Seq ( StrokePoint () ), Seq FitPoint ) )
brushJoin =
( ( ptOffset • joinWithBrush ( withTangent tgt brush0 ) ( withTangent tgt' brush0 ) brush0, Empty )
, ( ptOffset • joinWithBrush ( withTangent ( (-1) *^ tgt' ) brush0 ) ( withTangent ( (-1) *^ tgt ) brush0 ) brush0, Empty )
-> ( ptData -> brushParams )
-> ( brushParams -> SplinePts Closed )
-> Spline clo crvData ptData
-> ( Spline clo crvData ptData
, Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed )
, Seq FitPoint
)
next <- go sp0 ( sp1 :<| sps )
pure ( brushJoin <~> next )
where
tgt' :: Vector2D Double
tgt' = coords sp0 --> coords sp1
brush0 :: Seq ( StrokePoint () )
brush0 = removePointData $ brushShape @x sp0
joinAndContinue _ _ Empty
-- Closed curve.
| isClosed
= pure $
if parallel tgt_start tgt_end
then mempty
else ( ( startOffset • joinWithBrush ( withTangent tgt_start brush_start ) ( withTangent tgt_end brush_start ) brush_start, Empty )
, ( startOffset • joinWithBrush ( withTangent ( (-1) *^ tgt_start ) brush_start ) ( withTangent ( (-1) *^ tgt_end ) brush_start ) brush_start, Empty )
)
-- Open curve.
| otherwise
= pure
( ( endOffset • joinWithBrush ( withTangent tgt_end brush_end ) ( withTangent ( (-1) *^ tgt_end ) brush_end ) brush_end, Empty )
, ( Empty, Empty ) -- handled separately: see 'startingCap' below
)
-- Final cap for an open curve. Handled separately for correct stroke order.
startingCap :: Seq ( StrokePoint () )
startingCap
= startOffset • joinWithBrush ( withTangent ( (-1) *^ tgt_start ) brush_start ) ( withTangent tgt_start brush_start ) brush_start
go :: StrokePoint d -> Seq ( StrokePoint d ) -> Par ( ( Seq ( StrokePoint () ), Seq FitPoint ), ( Seq ( StrokePoint () ), Seq FitPoint ) )
go _ Empty = pure mempty
-- Line.
go sp0 ( sp1 :<| sps )
| PathPoint {} <- sp1
computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart = spt0, splineCurves } ) = case ssplineType @clo of
-- Open brush path with at least one segment.
SOpen
| OpenCurves curves <- splineCurves
, firstCurve :<| _ <- curves
, prevCurves :|> lastCurve <- curves
, let
endPt :: ptData
endPt = openCurveEnd lastCurve
startTgt, endTgt :: Vector2D Double
startTgt = coords spt0 --> coords ( openCurveStart firstCurve )
endTgt = case prevCurves of
Empty -> endTangent spt0 spt0 lastCurve
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
startBrush, endBrush :: SplinePts Closed
startBrush = brushShape spt0
endBrush = brushShape endPt
fwdPts, bwdPts :: SplinePts Open
fwdFits, bwdFits :: Seq FitPoint
newSpline :: Spline clo crvData ptData
( newSpline, TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) )
= updateSpline startTgt
startCap, endCap :: SplinePts Open
startCap
= fmap ( MkVector2D ( coords spt0 ) • )
$ joinWithBrush ( withTangent ( (-1) *^ startTgt ) startBrush ) ( withTangent startTgt startBrush ) startBrush
endCap
= fmap ( MkVector2D ( coords endPt ) • )
$ joinWithBrush ( withTangent endTgt endBrush ) ( withTangent ( (-1) *^ endTgt ) endBrush ) endBrush
-> ( newSpline
, Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts )
, fwdFits <> bwdFits
)
-- Closed brush path with at least one segment.
SClosed
| ClosedCurves prevCurves lastCurve <- splineCurves
, let
startTgt, endTgt :: Vector2D Double
startTgt = case prevCurves of
Empty -> startTangent spt0 spt0 lastCurve
firstCrv :<| _ -> startTangent spt0 spt0 firstCrv
endTgt = case prevCurves of
Empty -> endTangent spt0 spt0 lastCurve
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
fwdPts, bwdPts :: SplinePts Open
fwdFits, bwdFits :: Seq FitPoint
newSpline :: Spline clo crvData ptData
( newSpline, TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) )
= updateSpline endTgt
fwdStartCap, bwdStartCap :: SplinePts Open
TwoSided fwdStartCap bwdStartCap
= fmap fst . snd . runWriter
$ tellBrushJoin endTgt spt0 startTgt
-> ( newSpline
, Right ( adjustSplineType @Closed ( fwdStartCap <> fwdPts ), adjustSplineType @Closed ( bwdPts <> bwdStartCap ) )
, fwdFits <> bwdFits
)
-- Single point.
_ -> ( spline
, Left $ bimapSpline ( const id ) ( MkVector2D ( coords spt0 ) • ) ( brushShape spt0 )
, Empty
)
where
brushShape :: ptData -> SplinePts Closed
brushShape pt = brushFn ( ptParams pt )
updateSpline :: Vector2D Double -> ( Spline clo crvData ptData, OutlineData )
updateSpline lastTgt
= runWriter
. ( `evalStateT` lastTgt )
$ fmap ( adjustSplineType @clo )
$ bitraverseSpline
( \ ptData curve -> do
prev_tgt <- get
let
tgt :: Vector2D Double
tgt = startTangent spt0 ptData curve
lift $ tellBrushJoin prev_tgt ptData tgt
curve' <- lift $ strokeOutline ptData curve
put ( endTangent spt0 ptData curve )
pure curve'
)
pure
( adjustSplineType @Open spline )
strokeOutline
:: ptData -> Curve Open crvData ptData
-> Writer OutlineData ( Curve Open crvData ptData )
strokeOutline sp0 line@( LineTo { curveEnd = NextPoint sp1, curveData } ) =
let
p0, p1 :: Point2D Double
p0 = coords sp0
p1 = coords sp1
tgt :: Vector2D Double
tgt = p0 --> p1
brush :: Double -> Seq ( StrokePoint () )
brush t = lerpBrush t ( brushShape @x sp0 ) ( brushShape @x sp1 )
brush :: Double -> SplinePts Closed
brush t = brushFn ( lerp @diffParams t ( ptParams sp0 ) ( ptParams sp1 ) )
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
fwd t
= ( off t
@ -256,30 +298,21 @@ stroke params allPts@( spt0 :<| spt1 :<| spts )
= 1e9 *^ ( off s --> off (s + 1e-9) )
| otherwise
= 1e9 *^ ( off (s - 1e-9) --> off s )
= do
fwdIVar <- Par.spawnP ( fitCurve fwd )
bwdIVar <- Par.spawnP ( fitCurve bwd )
nextIVar <- Par.spawn ( joinAndContinue tgt sp1 sps )
fwdCurve <- Par.get fwdIVar
bwdCurve <- Par.get bwdIVar
next <- Par.get nextIVar
pure $ ( fwdCurve, bwdCurve ) <~> next
-- Quadratic Bézier curve.
go sp0 ( sp1 :<| sp2 :<| sps )
| ControlPoint {} <- sp1
, PathPoint {} <- sp2
, let
in do
crvData' <- updateCurveData curveData fwd bwd
pure ( line { curveData = crvData' } )
strokeOutline sp0 bez2@( Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2, curveData } ) =
let
p0, p1, p2 :: Point2D Double
p0 = coords sp0
p1 = coords sp1
p2 = coords sp2
tgt2 :: Vector2D Double
tgt2 = p1 --> p2
bez :: Quadratic.Bezier ( Point2D Double )
bez = Quadratic.Bezier {..}
brush :: Double -> Seq ( StrokePoint () )
brush t = quadraticBezierBrush t
( Quadratic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) )
brush :: Double -> SplinePts Closed
brush t = brushFn
$ Quadratic.bezier @diffParams
( Quadratic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ) t
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
fwd t
= ( off t
@ -309,32 +342,22 @@ stroke params allPts@( spt0 :<| spt1 :<| spts )
= 1e9 *^ ( off s --> off (s + 1e-9) )
| otherwise
= 1e9 *^ ( off (s - 1e-9) --> off s )
= do
fwdIVar <- Par.spawnP ( fitCurve fwd )
bwdIVar <- Par.spawnP ( fitCurve bwd )
nextIVar <- Par.spawn ( joinAndContinue tgt2 sp2 sps )
fwdCurve <- Par.get fwdIVar
bwdCurve <- Par.get bwdIVar
next <- Par.get nextIVar
pure $ ( fwdCurve, bwdCurve ) <~> next
-- Cubic Bézier curve.
go sp0 ( sp1 :<| sp2 :<| sp3 :<| sps )
| ControlPoint {} <- sp1
, ControlPoint {} <- sp2
, PathPoint {} <- sp3
, let
in do
crvData' <- updateCurveData curveData fwd bwd
pure ( bez2 { curveData = crvData' } )
strokeOutline sp0 bez3@( Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3, curveData } ) =
let
p0, p1, p2, p3 :: Point2D Double
p0 = coords sp0
p1 = coords sp1
p2 = coords sp2
p3 = coords sp3
tgt3 :: Vector2D Double
tgt3 = p2 --> p3
bez :: Cubic.Bezier ( Point2D Double )
bez = Cubic.Bezier {..}
brush :: Double -> Seq ( StrokePoint () )
brush t = cubicBezierBrush t
( Cubic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) ( brushShape @x sp3 ) )
brush :: Double -> SplinePts Closed
brush t = brushFn
$ Cubic.bezier @diffParams
( Cubic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ( ptParams sp3 ) ) t
fwd, bwd :: Double -> ( Point2D Double, Vector2D Double )
fwd t
= ( off t
@ -364,204 +387,283 @@ stroke params allPts@( spt0 :<| spt1 :<| spts )
= 1e9 *^ ( off s --> off (s + 1e-9) )
| otherwise
= 1e9 *^ ( off (s - 1e-9) --> off s )
= do
fwdIVar <- Par.spawnP ( fitCurve fwd )
bwdIVar <- Par.spawnP ( fitCurve bwd )
nextIVar <- Par.spawn ( joinAndContinue tgt3 sp3 sps )
fwdCurve <- Par.get fwdIVar
bwdCurve <- Par.get bwdIVar
next <- Par.get nextIVar
pure $ ( fwdCurve, bwdCurve ) <~> next
go p0 ps = error $ "stroke: unrecognised stroke type\n" <> show ( p0 :<| ps )
in do
crvData' <- updateCurveData curveData fwd bwd
pure ( bez3 { curveData = crvData' } )
fitCurve
:: ( Double -> ( Point2D Double, Vector2D Double ) )
-> ( Seq ( StrokePoint () ), Seq FitPoint )
fitCurve = first splinePoints . fitSpline params
updateCurveData
:: crvData
-> ( Double -> ( Point2D Double, Vector2D Double ) )
-> ( Double -> ( Point2D Double, Vector2D Double ) )
-> Writer OutlineData crvData
updateCurveData curveData fwd bwd = case upToDateFit $ view ( typed @CachedStroke ) curveData of
-- Cached fit data is available: use it.
Just ( TwoSided fwdData bwdData ) -> do
tell ( TwoSided fwdData bwdData )
pure curveData
-- No cached fit: compute the fit anew.
Nothing -> do
let
fwdData, bwdData :: ( SplinePts Open, Seq FitPoint )
( fwdData, bwdData ) =
( fitSpline fitParams fwd, fitSpline fitParams bwd )
`Strats.using`
( Strats.parTuple2 Strats.rdeepseq Strats.rdeepseq )
outlineData :: OutlineData
outlineData = TwoSided fwdData bwdData
tell ( outlineData )
pure ( set ( typed @CachedStroke ) ( CachedStroke $ Just outlineData ) curveData )
-- Connecting paths at a point of discontinuity of the tangent vector direction (G1 discontinuity).
-- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction).
tellBrushJoin
:: Vector2D Double
-> ptData
-> Vector2D Double
-> Writer OutlineData ()
tellBrushJoin prevTgt sp0 tgt
| tgt `parallel` prevTgt
= pure ()
| otherwise
= tell brushJoin
where
ptOffset :: Vector2D Double
ptOffset = Point2D 0 0 --> coords sp0
brush0 :: SplinePts Closed
brush0 = brushShape sp0
fwdJoin, bwdJoin :: SplinePts Open
fwdJoin
= fmap ( ptOffset • )
$ joinWithBrush ( withTangent prevTgt brush0 ) ( withTangent tgt brush0 ) brush0
bwdJoin
= fmap ( ptOffset • )
$ joinWithBrush ( withTangent ( (-1) *^ tgt ) brush0 ) ( withTangent ( (-1) *^ prevTgt ) brush0 ) brush0
brushJoin :: OutlineData
brushJoin = TwoSided ( fwdJoin, Empty ) ( bwdJoin, Empty )
-----------------------------------
-- Various utility functions
-- used in the "stroke" function.
-----
brushShape :: forall x d. HasType ( Seq ( StrokePoint x ) ) d => StrokePoint d -> Seq ( StrokePoint x )
brushShape = view typed . pointData
removePointData :: Seq ( StrokePoint d ) -> Seq ( StrokePoint () )
removePointData = fmap ( set ( field @"pointData" ) () )
startTangent, endTangent :: ( SplineTypeI clo, HasType ( Point2D Double ) ptData ) => ptData -> ptData -> Curve clo crvData ptData -> Vector2D Double
startTangent sp p0 ( LineTo mp1 _ ) = coords p0 --> coords ( fromNextPoint sp mp1 )
startTangent _ p0 ( Bezier2To p1 _ _ ) = coords p0 --> coords p1
startTangent _ p0 ( Bezier3To p1 _ _ _ ) = coords p0 --> coords p1
endTangent sp p0 ( LineTo mp1 _ ) = coords p0 --> coords ( fromNextPoint sp mp1 )
endTangent sp _ ( Bezier2To p0 mp1 _ ) = coords p0 --> coords ( fromNextPoint sp mp1 )
endTangent sp _ ( Bezier3To _ p0 mp1 _ ) = coords p0 --> coords ( fromNextPoint sp mp1 )
lerpBrush :: forall d. Show d => Double -> Seq ( StrokePoint d ) -> Seq ( StrokePoint d ) -> Seq ( StrokePoint () )
lerpBrush t p0s p1s = Seq.zipWith f p0s p1s
where
f :: StrokePoint d -> StrokePoint d -> StrokePoint ()
f ( PathPoint { coords = p0 } )
( PathPoint { coords = p1 } )
= PP $ lerp @( Vector2D Double ) t p0 p1
f ( ControlPoint { coords = p0 } )
( ControlPoint { coords = p1 } )
= CP $ lerp @( Vector2D Double ) t p0 p1
f p1 p2 = error $ "stroke: incompatible brushes " <> show [ p1, p2 ]
quadraticBezierBrush :: forall d. Show d => Double -> Quadratic.Bezier ( Seq ( StrokePoint d ) ) -> Seq ( StrokePoint () )
quadraticBezierBrush t ( Quadratic.Bezier p0s p1s p2s ) = Seq.zipWith3 f p0s p1s p2s
where
f :: StrokePoint d -> StrokePoint d -> StrokePoint d -> StrokePoint ()
f ( PathPoint { coords = p0 } )
( PathPoint { coords = p1 } )
( PathPoint { coords = p2 } )
= PP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t
f ( ControlPoint { coords = p0 } )
( ControlPoint { coords = p1 } )
( ControlPoint { coords = p2 } )
= CP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t
f p1 p2 p3 = error $ "stroke: incompatible brushes " <> show [ p1, p2, p3 ]
cubicBezierBrush :: forall d. Show d => Double -> Cubic.Bezier ( Seq ( StrokePoint d ) ) -> Seq ( StrokePoint () )
cubicBezierBrush t ( Cubic.Bezier p0s p1s p2s p3s ) = Seq.zipWith4 f p0s p1s p2s p3s
where
f :: StrokePoint d -> StrokePoint d -> StrokePoint d -> StrokePoint d -> StrokePoint ()
f ( PathPoint { coords = p0 } )
( PathPoint { coords = p1 } )
( PathPoint { coords = p2 } )
( PathPoint { coords = p3 } )
= PP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier {..} ) t
f ( ControlPoint { coords = p0 } )
( ControlPoint { coords = p1 } )
( ControlPoint { coords = p2 } )
( ControlPoint { coords = p3 } )
= CP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier {..} ) t
f p1 p2 p3 p4 = error $ "stroke: incompatible brushes " <> show [ p1, p2, p3, p4 ]
splinePoints :: Seq ( Cubic.Bezier ( Point2D Double ) ) -> Seq ( StrokePoint () )
splinePoints Empty = Empty
splinePoints ps@( Cubic.Bezier p0 _ _ _ :<| _ ) = PP p0 :<| go ps
where
go :: Seq ( Cubic.Bezier ( Point2D Double ) ) -> Seq ( StrokePoint () )
go Empty = Empty
go ( Cubic.Bezier _ p1 p2 p3 :<| pts ) = CP p1 :<| CP p2 :<| PP p3 :<| go pts
lastTangent :: HasType ( Point2D Double ) ptData => Spline Closed crvData ptData -> Maybe ( Vector2D Double )
lastTangent ( Spline { splineCurves = NoCurves } ) = Nothing
lastTangent ( Spline { splineStart, splineCurves = ClosedCurves Empty lst } ) = Just $ endTangent splineStart splineStart lst
lastTangent ( Spline { splineStart, splineCurves = ClosedCurves ( _ :|> prev ) lst } ) = Just $ endTangent splineStart ( openCurveEnd prev ) lst
--------------------------------------------------------------------------------
-- | Compute the join at a point of discontinuity of the tangent vector direction (G1 discontinuity).
joinWithBrush :: forall d. Show d => Offset -> Offset -> Seq ( StrokePoint d ) -> Seq ( StrokePoint () )
joinWithBrush :: forall crvData ptData. HasType ( Point2D Double ) ptData => Offset -> Offset -> Spline Closed crvData ptData -> SplinePts Open
joinWithBrush
( Offset { offsetIndex = i1, offsetParameter = mb_t1 } )
( Offset { offsetIndex = i2, offsetParameter = mb_t2 } )
pts
spline
| i2 > i1
= let
pcs, lastAndRest :: Seq ( StrokePoint d )
( pcs, lastAndRest ) = Seq.splitAt ( i2 - i1 ) $ Seq.drop i1 pts
pcs, lastAndRest :: Maybe ( SplinePts Open )
( pcs, lastAndRest )
= unzip
$ ( discardCurveData *** discardCurveData )
. splitSplineAt ( i2 - i1 )
<$> dropCurves i1 openSpline
in
snd ( splitFirstPiece t1 pcs ) <> dropFirstPiece pcs <> fst ( splitFirstPiece t2 lastAndRest )
fromMaybe empty $
mconcat
[ snd <$> ( splitFirstPiece t1 =<< pcs )
, dropFirstPiece =<< pcs
, fst <$> ( splitFirstPiece t2 =<< lastAndRest )
]
| i2 == i1 && mb_t2 >= mb_t1
= let
pcs :: Seq ( StrokePoint d )
pcs = Seq.drop i1 pts
pcs :: Maybe ( SplinePts Open )
pcs = discardCurveData <$> dropCurves i1 openSpline
in
fst ( splitFirstPiece t2 $ snd ( splitFirstPiece t1 pcs ) )
fromMaybe empty
( fst <$> ( splitFirstPiece t2 =<< snd <$> ( splitFirstPiece t1 =<< pcs ) ) )
| otherwise
= let
start, middle, end :: Seq ( StrokePoint d )
( ( middle, end ), start ) = first ( Seq.splitAt i2 ) $ Seq.splitAt i1 pts
start, middle, end :: SplinePts Open
( ( middle, end ), start )
= ( ( discardCurveData *** discardCurveData ) *** discardCurveData )
$ first ( splitSplineAt i2 )
$ splitSplineAt i1 openSpline
in
snd ( splitFirstPiece t1 start ) <> dropFirstPiece start <> removePointData middle <> fst ( splitFirstPiece t2 end )
fromMaybe empty $
mconcat
[ snd <$> splitFirstPiece t1 start
, dropFirstPiece start
, Just middle
, fst <$> splitFirstPiece t2 end
]
where
empty :: SplinePts Open
empty = Spline { splineStart = Point2D 0 0, splineCurves = OpenCurves Empty }
openSpline :: Spline Open crvData ptData
openSpline = adjustSplineType spline
t1, t2 :: Double
t1 = fromMaybe 0.5 mb_t1
t2 = fromMaybe 0.5 mb_t2
-- | Drop the first piece in a sequence of Bézier pieces.
dropFirstPiece :: Seq ( StrokePoint d ) -> Seq ( StrokePoint () )
dropFirstPiece
= removePointData
. Seq.dropWhileL ( \case { ControlPoint {} -> True; _ -> False } )
. Seq.drop 1
discardCurveData
:: ( Bifunctor f, HasType ( Point2D Double ) ptData )
=> f crvData ptData -> f () ( Point2D Double )
discardCurveData = bimap ( const () ) coords
-- | Drop the first curve in a Bézier spline.
dropFirstPiece :: HasType ( Point2D Double ) ptData => Spline Open crvData ptData -> Maybe ( SplinePts Open )
dropFirstPiece ( Spline { splineCurves = OpenCurves curves } ) = case curves of
Empty -> Nothing
fstPiece :<| laterPieces ->
Just $ Spline
{ splineStart = coords ( openCurveEnd fstPiece )
, splineCurves = OpenCurves $ fmap discardCurveData laterPieces
}
-- | Subdivide the first piece at the given parameter, discarding the subsequent pieces.
splitFirstPiece :: Show d => Double -> Seq ( StrokePoint d ) -> ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) )
-- Line.
splitFirstPiece t ( sp0 :<| sp1 :<| _ )
| PathPoint { coords = p0 } <- sp0
, PathPoint { coords = p1 } <- sp1
, let
p :: Point2D Double
splitFirstPiece :: HasType ( Point2D Double ) ptData => Double -> Spline Open crvData ptData -> Maybe ( SplinePts Open, SplinePts Open )
splitFirstPiece t ( Spline { splineStart = sp0, splineCurves = OpenCurves curves } ) = case curves of
Empty -> Nothing
fstPiece :<| _ -> case fstPiece of
LineTo { curveEnd = NextPoint sp1 } ->
let
p1, p :: Point2D Double
p1 = coords sp1
p = lerp @( Vector2D Double ) t p0 p1
= ( PP p0 :<| PP p :<| Empty
, PP p :<| PP p1 :<| Empty
in
Just
( Spline
{ splineStart = p0
, splineCurves = OpenCurves . Seq.singleton
$ LineTo { curveEnd = NextPoint p , curveData = () }
}
, Spline
{ splineStart = p
, splineCurves = OpenCurves . Seq.singleton
$ LineTo { curveEnd = NextPoint p1, curveData = () }
}
)
-- Quadratic Bézier curve.
splitFirstPiece t ( sp0 :<| sp1 :<| sp2 :<| _ )
| PathPoint { coords = p0 } <- sp0
, ControlPoint { coords = p1 } <- sp1
, PathPoint { coords = p2 } <- sp2
, let
q1, p, r1 :: Point2D Double
Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2 } ->
let
p1, p2, q1, p, r1 :: Point2D Double
p1 = coords sp1
p2 = coords sp2
( Quadratic.Bezier _ q1 p, Quadratic.Bezier _ r1 _ )
= Quadratic.subdivide @( Vector2D Double ) ( Quadratic.Bezier {..} ) t
= ( PP p0 :<| CP q1 :<| PP p :<| Empty
, PP p :<| CP r1 :<| PP p2 :<| Empty
in
Just
( Spline
{ splineStart = p0
, splineCurves = OpenCurves . Seq.singleton
$ Bezier2To { controlPoint = q1, curveEnd = NextPoint p , curveData = () }
}
, Spline
{ splineStart = p
, splineCurves = OpenCurves . Seq.singleton
$ Bezier2To { controlPoint = r1, curveEnd = NextPoint p2, curveData = () }
}
)
-- Cubic Bézier curve.
splitFirstPiece t ( sp0 :<| sp1 :<| sp2 :<| sp3 :<| _ )
| PathPoint { coords = p0 } <- sp0
, ControlPoint { coords = p1 } <- sp1
, ControlPoint { coords = p2 } <- sp2
, PathPoint { coords = p3 } <- sp3
, let
q1, q2, p, r1, r2 :: Point2D Double
Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3 } ->
let
p1, p2, p3, q1, q2, p, r1, r2 :: Point2D Double
p1 = coords sp1
p2 = coords sp2
p3 = coords sp3
( Cubic.Bezier _ q1 q2 p, Cubic.Bezier _ r1 r2 _ )
= Cubic.subdivide @( Vector2D Double ) ( Cubic.Bezier {..} ) t
= ( PP p0 :<| CP q1 :<| CP q2 :<| PP p :<| Empty
, PP p :<| CP r1 :<| CP r2 :<| PP p3 :<| Empty
in
Just
( Spline
{ splineStart = p0
, splineCurves = OpenCurves . Seq.singleton
$ Bezier3To { controlPoint1 = q1, controlPoint2 = q2, curveEnd = NextPoint p , curveData = () }
}
, Spline
{ splineStart = p
, splineCurves = OpenCurves . Seq.singleton
$ Bezier3To { controlPoint1 = r1, controlPoint2 = r2, curveEnd = NextPoint p3, curveData = () }
}
)
-- Anything else.
splitFirstPiece _ _ = ( Empty, Empty ) -- error ( "splitFirstPiece: unexpected stroke point data" <> show pcs )
where
p0 :: Point2D Double
p0 = coords sp0
--------------------------------------------------------------------------------
-- | Finds the point at which a convex nib (given by a piecewise Bézier curve) has the given tangent vector.
--
-- Does /not/ check that the provided nib shape is convex.
withTangent :: forall d. Vector2D Double -> Seq ( StrokePoint d ) -> Offset
withTangent tgt ( spt0 :<| spt1 :<| spts ) =
let
tgt0 :: Vector2D Double
tgt0 = coords spt0 --> coords spt1
in
if parallel tgt tgt0
then Offset 0 ( Just 0 ) ( MkVector2D $ coords spt0 )
else go 0 tgt0 spt0 spt1 spts
withTangent
:: forall crvData ptData
. ( HasType ( Point2D Double ) ptData, Show crvData, Show ptData )
=> Vector2D Double -> Spline Closed crvData ptData -> Offset
withTangent tgt_wanted spline@( Spline { splineStart } ) = case lastTangent spline of
Nothing ->
Offset { offsetIndex = 0, offsetParameter = Just 0, offset = MkVector2D ( coords splineStart ) }
Just tgt_last ->
case runExcept . ( `runStateT` tgt_last ) $ ibifoldSpline go ( \ _ -> pure () ) $ adjustSplineType @Open spline of
Left off -> off
_ -> error $
"withTangent: could not find any point with given tangent vector\n\
\tangent vector: " <> show tgt_wanted <> "\n\
\spline: " <> show spline <> "\n"
where
go :: Int -> Vector2D Double -> StrokePoint d -> StrokePoint d -> Seq ( StrokePoint d ) -> Offset
go _ _ ( ControlPoint { } ) _ _ = error "withTangent: path starts with a control point"
-- Line.
go i tgt0
( PathPoint { coords = p0 } )
( sp1@( PathPoint { coords = p1 } ) )
ps
| parallel tgt tgt0
= Offset i Nothing ( MkVector2D $ lerp @( Vector2D Double ) 0.5 p0 p1 )
go :: Int -> ptData -> Curve Open crvData ptData -> StateT ( Vector2D Double ) ( Except Offset ) ()
go i cp cseg = do
tgt_prev <- get
let
p :: Point2D Double
p = coords cp
seg :: Curve Open crvData ( Point2D Double )
seg = fmap coords cseg
tgt_start, tgt_end :: Vector2D Double
tgt_start = startTangent splineStart cp cseg
tgt_end = endTangent splineStart cp cseg
-- Handle corner.
unless ( parallel tgt_prev tgt_start ) do
for_ ( between tgt_wanted tgt_prev tgt_start ) \ _ ->
lift . throwE $
Offset
{ offsetIndex = i
, offsetParameter = Just 0
, offset = MkVector2D p
}
-- Handle segment.
lift $ handleSegment i p seg tgt_start
put tgt_end
handleSegment :: Int -> Point2D Double -> Curve Open crvData ( Point2D Double ) -> Vector2D Double -> Except Offset ()
handleSegment i p0 ( LineTo ( NextPoint p1 ) _ ) tgt0
| parallel tgt_wanted tgt0
, let
offset :: Vector2D Double
offset = MkVector2D $ lerp @( Vector2D Double ) 0.5 p0 p1
= throwE ( Offset { offsetIndex = i, offsetParameter = Nothing, offset } )
| otherwise
= continue ( i + 1 ) tgt0 sp1 ps
-- Quadratic Bézier curve.
go i tgt0
( PathPoint { coords = p0 } )
( ControlPoint { coords = p1 } )
( sp2@( PathPoint { coords = p2 } ) :<| ps ) =
= pure ()
handleSegment i p0 ( Bezier2To p1 ( NextPoint p2 ) _ ) tgt0 =
let
tgt1 :: Vector2D Double
tgt1 = p1 --> p2
in case between tgt tgt0 tgt1 of
Just t -> Offset i ( Just t ) ( MkVector2D $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t )
Nothing -> continue ( i + 2 ) tgt1 sp2 ps
-- Cubic Bézier curve.
go i tgt0
( PathPoint { coords = p0 } )
( ControlPoint { coords = p1 } )
( ControlPoint { coords = p2 } :<| sp3@( PathPoint { coords = p3 } ) :<| ps ) =
in for_ ( between tgt_wanted tgt0 tgt1 ) \ t ->
throwE $
Offset
{ offsetIndex = i
, offsetParameter = Just t
, offset = MkVector2D $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t
}
handleSegment i p0 ( Bezier3To p1 p2 ( NextPoint p3 ) _ ) tgt0 =
let
tgt1, tgt2 :: Vector2D Double
tgt1 = p1 --> p2
@ -569,42 +671,30 @@ withTangent tgt ( spt0 :<| spt1 :<| spts ) =
bez :: Cubic.Bezier ( Point2D Double )
bez = Cubic.Bezier {..}
c01, c12, c23 :: Double
c01 = tgt `cross` tgt0
c12 = tgt `cross` tgt1
c23 = tgt `cross` tgt2
c01 = tgt_wanted `cross` tgt0
c12 = tgt_wanted `cross` tgt1
c23 = tgt_wanted `cross` tgt2
correctTangentParam :: Double -> Maybe Double
correctTangentParam t
| t > -epsilon && t < 1 + epsilon
, tgt ^.^ Cubic.bezier' bez t > epsilon
, tgt_wanted ^.^ Cubic.bezier' bez t > epsilon
= Just ( max 0 ( min 1 t ) )
| otherwise
= Nothing
in
case mapMaybe correctTangentParam $ solveQuadratic c01 ( 2 * ( c12 - c01 ) ) ( c01 + c23 - 2 * c12 ) of
( t : _ )
-> Offset i ( Just t ) ( MkVector2D $ Cubic.bezier @( Vector2D Double ) bez t )
_
| Just s <- between tgt tgt0 tgt2
-- Fallback in case we couldn't solve the quadratic for some reason.
-> Offset i ( Just s ) ( MkVector2D $ Cubic.bezier @( Vector2D Double ) bez s )
-- Otherwise: go to next piece of the curve.
| otherwise
-> continue ( i + 3 ) tgt2 sp3 ps
go _ _ _ _ _
= error "withTangent: unrecognised path type (more than two consecutive control points)"
-- Handles corners in the Bézier curve.
continue :: Int -> Vector2D Double -> StrokePoint d -> Seq ( StrokePoint d ) -> Offset
continue _ _ _ Empty = Offset 0 ( Just 0 ) ( MkVector2D $ coords spt0 )
continue i ptgt p0 ( p1 :<| ps ) =
let
tgt0 :: Vector2D Double
tgt0 = coords p0 --> coords p1
in case between tgt ptgt tgt0 of
Just _ -> Offset i ( Just 0 ) ( MkVector2D $ coords p0 )
Nothing -> go i tgt0 p0 p1 ps
withTangent _ _ = error $ "withTangent: invalid path (fewer than 2 points)"
mbParam :: Maybe Double
mbParam =
case mapMaybe correctTangentParam $ solveQuadratic c01 ( 2 * ( c12 - c01 ) ) ( c01 + c23 - 2 * c12 ) of
( t : _ ) -> Just t
_ -> between tgt_wanted tgt0 tgt2 -- fallback in case we couldn't solve the quadratic for some reason
in for_ mbParam \ t ->
throwE $
Offset
{ offsetIndex = i
, offsetParameter = Just t
, offset = MkVector2D $ Cubic.bezier @( Vector2D Double ) bez t
}
-- | Finds whether the query vector @ u @ lies between the two provided vectors @ v0 @, @ v1 @.
--

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

@ -10,7 +10,8 @@ module Math.Module
( Module(..), lerp
, Inner(..)
, squaredNorm, quadrance, distance
, proj, projC, closestPointToSegment
, proj, projC, closestPointOnSegment
, cross
)
where
@ -18,7 +19,7 @@ module Math.Module
import Control.Applicative
( liftA2 )
import Data.Monoid
( Ap(..) )
( Ap(..), Sum(..) )
-- acts
import Data.Act
@ -28,6 +29,14 @@ import Data.Act
( (-->) )
)
-- groups
import Data.Group
( invert )
-- MetaBrush
import Math.Vector2D
( Vector2D(..), Segment(..) )
--------------------------------------------------------------------------------
infixl 6 ^+^, ^-^
@ -35,8 +44,9 @@ infix 9 ^*, *^
class Num r => Module r m | m -> r where
{-# MINIMAL (^+^), ( (^*) | (*^) ) #-}
{-# MINIMAL origin, (^+^), ( (^*) | (*^) ) #-}
origin :: m
(^+^) :: m -> m -> m
(^-^) :: m -> m -> m
(*^) :: r -> m -> m
@ -47,6 +57,7 @@ class Num r => Module r m | m -> r where
m ^-^ n = m ^+^ (-1) *^ n
instance ( Applicative f, Module r m ) => Module r ( Ap f m ) where
origin = pure origin
(^+^) = liftA2 (^+^)
(^-^) = liftA2 (^-^)
(*^) 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 x y = x ^.^ y / squaredNorm y
closestPointToSegment
closestPointOnSegment
:: forall v r p
. ( Inner r v, Torsor v p, Fractional r, Ord r )
=> p -> p -> p -> ( r, p )
closestPointToSegment c p0 p1
=> p -> Segment p -> ( r, p )
closestPointOnSegment c ( Segment p0 p1 )
| t <= 0
= ( 0, p0 )
| t >= 1
@ -95,3 +106,36 @@ closestPointToSegment c p0 p1
v01 = p0 --> p1
t :: r
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
( Point2D(..), Vector2D(.., Vector2D), Mat22(..)
, cross
, Segment(..)
)
where
@ -33,16 +33,12 @@ import Generic.Data
-- groups
import Data.Group
( Group ( invert ) )
( Group )
-- groups-generic
import Data.Group.Generics
( )
-- MetaBrush
import Math.Module
( Module(..), Inner(..) )
--------------------------------------------------------------------------------
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 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
= Mat22 !a !a !a !a
deriving stock ( Show, Eq, Generic, Generic1, Functor, Foldable, Traversable )
deriving Applicative
via Generically1 Mat22
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 )