hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-23 15:34:06 +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

158
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
@ -199,14 +161,43 @@ main = do
---------------------------------------------------------
-- Initialise state
uniqueSupply <- newUniqueSupply
uniqueSupply <- newUniqueSupply
circleBrush <- Asset.Brushes.circle uniqueSupply
let
testDocuments :: Map Unique DocumentHistory
testDocuments = fmap newHistory $ uniqueMapFromList
[ emptyDocument "Test" ( unsafeUnique 0 )
& ( field' @"documentContent" . field' @"strokes" ) .~
[ Stroke
{ strokeName = "Stroke 1"
, strokeVisible = True
, strokeUnique = unsafeUnique 10
, strokeBrush = circleBrush
, strokeSpline =
Spline
{ splineStart = mkPoint ( Point2D 10 -20 ) 2
, splineCurves = OpenCurves $ Seq.fromList
[ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 5 ), curveData = CachedStroke Nothing }
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = CachedStroke Nothing }
, LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 2 ), curveData = CachedStroke Nothing }
]
}
}
]
]
where
mkPoint :: Point2D Double -> Double -> PointData ( Super.Rec '[ "r" SuperRecord.:= Double ] )
mkPoint pt r = PointData pt Normal ( #r SuperRecord.:= r SuperRecord.& SuperRecord.rnil )
activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing
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
@ -323,7 +314,7 @@ main = do
---------------------------------------------------------
-- Main viewport
viewport@( Viewport { .. } ) <- createViewport viewportGrid
viewport@( Viewport {..} ) <- createViewport viewportGrid
-----------------
-- Viewport rendering
@ -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
renderDocument
colours fitParameters mode debug ( viewportWidth, viewportHeight )
modifiers mbMousePos mbHoldAction mbPartialPath
doc
renderRuler
colours ( viewportWidth, viewportHeight ) ViewportOrigin ( viewportWidth, viewportHeight )
mbMousePos mbHoldAction showGuides
doc
case mbRender of
Just render -> Cairo.renderWithContext render ctx
Nothing -> Cairo.renderWithContext ( blankRender colours ) ctx
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
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

19
cabal.project
View file

@ -4,7 +4,8 @@ constraints:
acts -finitary
allow-newer:
waargonaut:*
waargonaut:*
-- fixes gi-cairo-render to work with haskell-gi >= 0.24
source-repository-package
@ -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

448
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,105 +676,109 @@ instance HandleAction MouseClick where
pos :: Point2D Double
pos = toViewport mouseClickCoords
STM.writeTVar mousePosTVar ( Just pos )
case actionOrigin of
mode <- STM.readTVar modeTVar
case mode of
BrushMode -> pure Don'tModifyDoc -- TODO: brush parameter modification UI
_ ->
case actionOrigin of
ViewportOrigin -> case ty of
ViewportOrigin -> case ty of
SingleClick -> do
modifiers <- STM.readTVar modifiersTVar
tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
case tool of
-- Selection mode mouse hold:
--
-- - If holding shift or alt, mouse hold initiates a rectangular selection.
-- - If not holding shift or alt:
-- - if mouse click selected an object, initiate a drag move,
-- - otherwise, initiate a rectangular selection.
Selection ->
case selectionMode modifiers of
-- Drag move: not holding shift or alt, click has selected something.
New
| Just ( dragMove, newDoc ) <- dragMoveSelect mode pos doc
-> do
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
case dragMove of
ClickedOnSelected ->
SingleClick -> do
modifiers <- STM.readTVar modifiersTVar
tool <- STM.readTVar toolTVar
case tool of
-- Selection mode mouse hold:
--
-- - If holding shift or alt, mouse hold initiates a rectangular selection.
-- - If not holding shift or alt:
-- - if mouse click selected an object, initiate a drag move,
-- - otherwise, initiate a rectangular selection.
Selection ->
case selectionMode modifiers of
-- Drag move: not holding shift or alt, click has selected something.
New
| Just ( dragMove, newDoc ) <- dragMoveSelect pos doc
-> do
STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove )
case dragMove of
ClickedOnSelected ->
pure Don'tModifyDoc
ClickedOnUnselected ->
pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
ClickedOnCurve {} ->
pure Don'tModifyDoc
-- Rectangular selection.
_ -> do
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
pure Don'tModifyDoc
ClickedOnUnselected ->
pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
ClickedOnCurve {} ->
pure Don'tModifyDoc
-- Rectangular selection.
_ -> do
STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos )
pure Don'tModifyDoc
-- Pen tool: start or continue a drawing operation.
Pen -> do
mbPartialPath <- STM.readTVar partialPathTVar
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
case mbPartialPath of
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
Nothing -> do
( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <-
getOrCreateDrawAnchor uniqueSupply pos doc
STM.writeTVar partialPathTVar
( Just $ PartialPath
{ partialStartPos = anchorPt
, partialControlPoint = Nothing
, partialPathAnchor = drawAnchor
, firstPoint = True
}
)
case mbExistingAnchorName of
Nothing ->
let
changeText :: Text
changeText = "Begin new stroke"
in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
Just _ ->
-- Pen tool: start or continue a drawing operation.
Pen -> do
mbPartialPath <- STM.readTVar partialPathTVar
STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos )
case mbPartialPath of
-- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke).
Nothing -> do
( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <-
getOrCreateDrawAnchor uniqueSupply pos doc
STM.writeTVar partialPathTVar
( Just $ PartialPath
{ partialStartPos = anchorPt
, partialControlPoint = Nothing
, partialPathAnchor = drawAnchor
, firstPoint = True
}
)
case mbExistingAnchorName of
Nothing ->
let
changeText :: Text
changeText = "Begin new stroke"
in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
Just _ ->
pure Don'tModifyDoc
-- Path already started: indicate that we are continuing a path.
Just pp -> do
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
pure Don'tModifyDoc
-- Path already started: indicate that we are continuing a path.
Just pp -> do
STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } )
pure Don'tModifyDoc
DoubleClick -> do
tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
modifs <- STM.readTVar modifiersTVar
case tool of
Selection
| null modifs
-> do
STM.writeTVar mouseHoldTVar Nothing
case subdivide mode pos doc of
Nothing ->
pure Don'tModifyDoc
Just ( newDocument, loc ) -> do
let
changeText :: Text
changeText = "Subdivide " <> loc
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange { .. } )
-- Ignore double click event otherwise.
_ -> pure Don'tModifyDoc
DoubleClick -> do
tool <- STM.readTVar toolTVar
modifs <- STM.readTVar modifiersTVar
case tool of
Selection
| PathMode <- mode
, null modifs
-> do
STM.writeTVar mouseHoldTVar Nothing
case subdivide pos doc of
Nothing ->
pure Don'tModifyDoc
Just ( newDocument, loc ) -> do
let
changeText :: Text
changeText = "Subdivide " <> loc
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
-- Ignore double click event otherwise.
_ -> pure Don'tModifyDoc
RulerOrigin ruler -> do
showGuides <- STM.readTVar showGuidesTVar
when showGuides do
let
mbGuide :: Maybe Guide
mbGuide = selectedGuide pos doc
guideAction :: GuideAction
guideAction
| Just guide <- mbGuide
= MoveGuide ( guideUnique guide )
| otherwise
= CreateGuide ruler
STM.writeTVar mouseHoldTVar ( Just $ GuideAction { holdStartPos = pos, guideAction } )
pure Don'tModifyDoc
RulerOrigin ruler -> do
showGuides <- STM.readTVar showGuidesTVar
when showGuides do
let
mbGuide :: Maybe Guide
mbGuide = selectedGuide pos doc
guideAction :: GuideAction
guideAction
| Just guide <- mbGuide
= MoveGuide ( guideUnique guide )
| otherwise
= CreateGuide ruler
STM.writeTVar mouseHoldTVar ( Just $ GuideAction { holdStartPos = pos, guideAction } )
pure Don'tModifyDoc
-- Right mouse button: end partial path.
3 -> do
@ -869,111 +872,112 @@ instance HandleAction MouseRelease where
_ -> do
tool <- STM.readTVar toolTVar
mode <- STM.readTVar modeTVar
case tool of
case mode of
BrushMode -> pure Don'tModifyDoc -- TODO: brush parameter modification UI
_ ->
case tool of
Selection -> do
let
selMode :: SelectionMode
selMode = selectionMode modifiers
case mbHoldPos of
Just hold
| DragMoveHold { holdStartPos = pos0, dragAction } <- hold
, pos0 /= pos
-> let
alternateMode :: Bool
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
in case dragUpdate mode pos0 pos dragAction alternateMode doc of
Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd )
Nothing -> pure Don'tModifyDoc
| SelectionHold pos0 <- hold
, pos0 /= pos
-> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle mode selMode pos0 pos doc )
_ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt mode selMode pos doc )
Pen -> do
mbPartialPath <- STM.readTVar partialPathTVar
case mbPartialPath of
-- Normal pen mode mouse click should have created an anchor.
-- If no anchor exists, then just ignore the mouse release event.
Nothing -> pure Don'tModifyDoc
-- Mouse click release possibilities:
--
-- - click was on complementary draw stroke draw anchor to close the path,
-- - release at same point as click: finish current segment,
-- - release at different point as click: finish current segment, adding a control point.
Just
( PartialPath
{ partialStartPos = p1
, partialControlPoint = mbCp2
, partialPathAnchor = anchor
, firstPoint
}
) -> do
Selection -> do
let
pathPoint :: Point2D Double
mbControlPoint :: Maybe ( Point2D Double )
partialControlPoint :: Maybe ( Point2D Double )
( pathPoint, mbControlPoint, partialControlPoint )
| Just ( DrawHold holdPos ) <- mbHoldPos
= ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos )
| otherwise
= ( pos, Nothing, Nothing )
( _, otherAnchor, otherAnchorPt, _ ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
if not firstPoint && anchorsAreComplementary anchor otherAnchor
-- Close path.
then do
STM.writeTVar partialPathTVar Nothing
let
newSegment :: Seq ( StrokePoint PointData )
newSegment
= Seq.fromList
$ catMaybes
[ Just ( PathPoint p1 ( PointData Normal Empty ) )
, do
cp <- mbCp2
guard ( cp /= p1 )
pure $ ControlPoint cp ( PointData Normal Empty )
, do
cp <- mbControlPoint
guard ( cp /= otherAnchorPt )
pure $ ControlPoint cp ( PointData Normal Empty )
, Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) )
]
newDocument :: Document
newDocument = addToAnchor anchor newSegment doc
changeText :: Text
changeText = "Close stroke"
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
else
if firstPoint
-- Continue current partial path.
then do
STM.writeTVar partialPathTVar ( Just $ PartialPath p1 partialControlPoint anchor False )
pure Don'tModifyDoc
-- Finish current partial path.
else do
STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
selMode :: SelectionMode
selMode = selectionMode modifiers
case mbHoldPos of
Just hold
| DragMoveHold { holdStartPos = pos0, dragAction } <- hold
, pos0 /= pos
-> let
alternateMode :: Bool
alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers
in case dragUpdate 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 selMode pos0 pos doc )
_ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc )
Pen -> do
mbPartialPath <- STM.readTVar partialPathTVar
case mbPartialPath of
-- Normal pen mode mouse click should have created an anchor.
-- If no anchor exists, then just ignore the mouse release event.
Nothing -> pure Don'tModifyDoc
-- Mouse click release possibilities:
--
-- - click was on complementary draw stroke draw anchor to close the path,
-- - release at same point as click: finish current segment,
-- - release at different point as click: finish current segment, adding a control point.
Just
( PartialPath
{ partialStartPos = p1
, partialControlPoint = mbCp2
, partialPathAnchor = anchor
, firstPoint
}
) -> do
let
newSegment :: Seq ( StrokePoint PointData )
newSegment
= Seq.fromList
$ catMaybes
[ Just ( PathPoint p1 ( PointData Normal Empty ) )
, do
cp <- mbCp2
guard ( cp /= p1 )
pure $ ControlPoint cp ( PointData Normal Empty )
, do
cp <- mbControlPoint
guard ( cp /= pathPoint )
pure $ ControlPoint cp ( PointData Normal Empty )
, Just ( PathPoint pathPoint ( PointData Normal Empty ) )
]
newDocument :: Document
newDocument = addToAnchor anchor newSegment doc
changeText :: Text
changeText = "Continue stroke"
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
pathPoint :: Point2D Double
mbControlPoint :: Maybe ( Point2D Double )
partialControlPoint :: Maybe ( Point2D Double )
( pathPoint, mbControlPoint, partialControlPoint )
| Just ( DrawHold holdPos ) <- mbHoldPos
= ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos )
| otherwise
= ( pos, Nothing, Nothing )
( _, otherAnchor, otherAnchorPt, _ ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc
if not firstPoint && anchorsAreComplementary anchor otherAnchor
-- Close path.
then do
STM.writeTVar partialPathTVar Nothing
let
newSegment :: Spline Open CachedStroke ( PointData () )
newSegment = catMaybesSpline ( CachedStroke Nothing )
( PointData p1 Normal () )
( do
cp <- mbCp2
guard ( cp /= p1 )
pure ( PointData cp Normal () )
)
( do
cp <- mbControlPoint
guard ( cp /= otherAnchorPt )
pure ( PointData cp Normal () )
)
( PointData otherAnchorPt Normal () )
newDocument :: Document
newDocument = addToAnchor anchor newSegment doc
changeText :: Text
changeText = "Close stroke"
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
else
if firstPoint
-- Continue current partial path.
then do
STM.writeTVar partialPathTVar ( Just $ PartialPath p1 partialControlPoint anchor False )
pure Don'tModifyDoc
-- Finish current partial path.
else do
STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False )
let
newSegment :: Spline Open CachedStroke ( PointData () )
newSegment = catMaybesSpline ( CachedStroke Nothing )
( PointData p1 Normal () )
( do
cp <- mbCp2
guard ( cp /= p1 )
pure ( PointData cp Normal () )
)
( do
cp <- mbControlPoint
guard ( cp /= pathPoint )
pure ( PointData cp Normal () )
)
( PointData pathPoint Normal () )
newDocument :: Document
newDocument = addToAnchor anchor newSegment doc
changeText :: Text
changeText = "Continue stroke"
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
-- Other mouse buttons: ignored (for the moment at least).
_ -> pure ()
@ -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 )
)

260
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
{ strokeName :: Text
, strokeVisible :: !Bool
, strokeUnique :: Unique
, strokePoints :: !( Seq ( StrokePoint PointData ) )
}
deriving stock ( Show, Generic )
deriving anyclass NFData
type StrokeSpline ty brushParams = Spline ty CachedStroke ( PointData brushParams )
data PointData
data Stroke where
Stroke
:: ( KnownSplineType clo
, pointParams ~ Super.Rec pointFields, STypesI pointFields
, brushParams ~ Super.Rec brushFields, STypesI brushFields
, usedParams ~ Super.Rec usedFields , STypesI usedFields
, usedFields ~ ( brushFields `SuperRecord.Intersect` pointFields )
, Show brushParams, NFData brushParams
, Show pointParams, NFData pointParams
, Interpolatable pointParams
, Interpolatable usedParams
, Serialisable pointParams
, Adapted brushFields pointFields usedFields
)
=>
{ strokeName :: Text
, strokeVisible :: !Bool
, strokeUnique :: Unique
, strokeBrush :: Brush brushFields
, strokeSpline :: !( StrokeSpline clo pointParams )
}
-> Stroke
deriving stock instance Show Stroke
instance NFData Stroke where
rnf ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline } )
= deepseq strokeSpline
. deepseq strokeUnique
. deepseq strokeVisible
$ rnf strokeName
_strokeSpline
:: forall f
. Functor f
=> ( forall clo pointParams pointFields
. ( KnownSplineType clo
, Show pointParams, NFData pointParams
, pointParams ~ Super.Rec pointFields, STypesI pointFields
, Interpolatable pointParams
, Serialisable pointParams
)
=> StrokeSpline clo pointParams
-> f ( StrokeSpline clo pointParams )
)
-> Stroke -> f Stroke
_strokeSpline f ( Stroke { strokeSpline = oldStrokeSpline, .. } )
= ( \ newSpline -> Stroke { strokeSpline = newSpline, .. } ) <$> f oldStrokeSpline
overStrokeSpline
:: ( forall clo pointParams pointFields
. ( KnownSplineType clo
, Show pointParams, NFData pointParams
, pointParams ~ Super.Rec pointFields, STypesI pointFields
, Interpolatable pointParams
, Serialisable pointParams
)
=> StrokeSpline clo pointParams
-> StrokeSpline clo pointParams
)
-> Stroke -> Stroke
overStrokeSpline f = coerce ( _strokeSpline @Identity ( coerce . f ) )
data Brush ( brushFields :: [ Type ] )
= BrushData
{ brushName :: !Text
, brushCode :: !Text
, brushFunction :: !( BrushFunction brushFields )
}
instance Show ( Brush brushFields ) where
show ( BrushData { brushName } ) = Text.unpack brushName
-- Brush parameters using open records.
emptyBrush :: Brush '[]
emptyBrush = BrushData "Empty brush" ""
( AdaptableFunction ( const SuperRecord.rnil, const $ Spline ( Point2D 0 0 ) NoCurves ) )
data PointData params
= PointData
{ 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 }

174
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 )
@ -81,75 +97,115 @@ getOrCreateDrawAnchor
-> Point2D Double
-> 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
getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
case
( `runState` Nothing )
$ ( field' @"documentContent" . field' @"strokes" . traverse )
updateStroke doc
of
-- Anchor found: use it.
( newDoc, Just ( ( anchor, anchorPt ), anchorName ) ) -> do
pure ( newDoc, anchor, anchorPt, Just anchorName )
( 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
newSpline :: StrokeSpline Open ( Super.Rec '[] )
newSpline =
Spline { splineStart = PointData c Normal ( SuperRecord.rnil )
, splineCurves = OpenCurves Empty
}
newStroke :: Stroke
newStroke =
Stroke
{ strokeName = "Stroke " <> uniqueText uniq
, strokeVisible = True
, strokeUnique = uniq
, strokeSpline = newSpline
, strokeBrush = emptyBrush
}
newDoc' :: Document
newDoc'
= over ( field' @"documentContent" . field' @"strokes" )
( Stroke
{ strokeName = "Stroke " <> uniqueText uniq
, strokeVisible = True
, strokeUnique = uniq
, strokePoints = Seq.singleton $ PathPoint c ( PointData Normal Empty )
}
: )
( 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
mbAnchor <- get
case mbAnchor of
-- If we haven't already found an anchor,
-- and the current point is a valid candidate,
-- then select it as an anchor for the drawing operation.
Nothing
| strokeVisible
, Just anchor <- endpointAnchor strokeUnique strokePoints
-> put ( Just ( anchor, strokeName ) )
$> set ( field' @"strokePoints" . mapped . _selection ) Normal stroke
-- Otherwise, just deselect.
_ -> pure $ set ( field' @"strokePoints" . mapped . _selection ) Normal stroke
-- See if we can anchor a drawing operation on a given (visible) stroke.
endpointAnchor :: Unique -> Seq ( StrokePoint PointData ) -> Maybe ( DrawAnchor, Point2D Double )
endpointAnchor _ ( PathPoint { coords = p0 } :<| ( _ :|> PathPoint { coords = pn } ) )
| p0 == pn
= Nothing
endpointAnchor uniq (PathPoint { coords = p0 } :<| _ )
| inPointClickRange p0
= Just ( AnchorAtStart uniq, p0 )
endpointAnchor uniq ( _ :|> PathPoint { coords = pn } )
| inPointClickRange pn
= Just ( AnchorAtEnd uniq, pn )
endpointAnchor _ _ = Nothing
inPointClickRange :: Point2D Double -> Bool
inPointClickRange p =
squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
where
updateStrokeSpline
:: forall clo brushParams
. SplineTypeI clo
=> StrokeSpline clo brushParams
-> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) ( StrokeSpline clo brushParams )
updateStrokeSpline spline = do
addToAnchor :: DrawAnchor -> Seq ( StrokePoint PointData ) -> Document -> Document
addToAnchor anchor newPts = over ( field' @"documentContent" . field' @"strokes" . mapped ) addToStroke
mbAnchor <- get
case mbAnchor of
-- If we haven't already found an anchor,
-- and the current point is a valid candidate,
-- then select it as an anchor for the drawing operation.
Nothing
| strokeVisible
, Just anchor <- endpointAnchor strokeUnique spline
-> put ( Just ( anchor, strokeName ) )
$> set ( mapped . _selection ) Normal spline
-- Otherwise, just deselect.
_ -> pure $ set ( mapped . _selection ) Normal spline
where
-- See if we can anchor a drawing operation on a given (visible) stroke.
endpointAnchor :: Unique -> StrokeSpline clo brushParams -> Maybe ( DrawAnchor, Point2D Double )
endpointAnchor uniq ( Spline { splineStart, splineCurves } ) = case ssplineType @clo of
SOpen
| let
p0 :: Point2D Double
p0 = coords splineStart
, inPointClickRange p0
-> Just ( AnchorAtStart uniq, p0 )
| OpenCurves ( _ :|> lastCurve ) <- splineCurves
, let
pn :: Point2D Double
pn = coords ( openCurveEnd lastCurve )
, inPointClickRange pn
-> Just ( AnchorAtEnd uniq, pn )
_ -> Nothing
inPointClickRange :: Point2D Double -> Bool
inPointClickRange p =
squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor )
addToAnchor :: DrawAnchor -> StrokeSpline Open () -> Document -> Document
addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strokes" . mapped ) addToStroke
where
addToStroke :: Stroke -> Stroke
addToStroke stroke@( Stroke { strokeUnique, strokePoints = pts } )
addToStroke stroke@( Stroke { strokeUnique } )
| strokeUnique == anchorStrokeUnique anchor
= case anchor of
AnchorAtStart _ -> stroke { strokePoints = Seq.reverse newPts <> Seq.drop 1 pts }
AnchorAtEnd _ -> stroke { strokePoints = dropEnd 1 pts <> newPts }
=
let
updateSpline
:: forall clo brushData
. SplineTypeI clo
=> StrokeSpline clo brushData -> StrokeSpline clo brushData
updateSpline prevSpline
| SOpen <- ssplineType @clo
= case anchor of
AnchorAtStart _ ->
let
setBrushData :: PointData () -> PointData brushData
setBrushData = set ( field @"brushParams" ) ( brushParams ( splineStart prevSpline ) )
in fmap setBrushData ( reverseSpline newSpline ) <> prevSpline
AnchorAtEnd _ ->
let
setBrushData :: PointData () -> PointData brushData
setBrushData = set ( field @"brushParams" ) ( brushParams ( splineEnd prevSpline ) )
in prevSpline <> fmap setBrushData newSpline
| otherwise
= error "addToAnchor: trying to add to a closed spline"
in
overStrokeSpline updateSpline stroke
| otherwise
= 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 #-}

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

File diff suppressed because it is too large Load diff

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

@ -1,12 +1,26 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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 } ) ->
JSON.Encoder.atKey' "name" JSON.Encoder.text strokeName
. JSON.Encoder.atKey' "visible" JSON.Encoder.bool strokeVisible
. JSON.Encoder.atKey' "points" ( encodeSequence ( encodeStrokePoint encodePointData ) ) 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 )
decodeStroke :: MonadIO m => UniqueSupply -> JSON.Decoder m Stroke
encodeFieldTypes :: Monad f => JSON.Encoder f ( [ ( Text, SomeSType ) ] )
encodeFieldTypes = JSON.Encoder.keyValueTupleFoldable encodeSomeSType
decodeFieldTypes :: Monad m => JSON.Decoder m SomeBrushFields
decodeFieldTypes = do
fields <- JSON.Decoder.objectAsKeyValues JSON.Decoder.text decodeSomeFieldSType
let
sortedFields :: [ ( Text, SomeFieldSType ) ]
sortedFields = sortBy ( comparing fst ) fields
duplicates :: [ Text ]
duplicates = duplicatesAcc [] [] sortedFields
duplicatesAcc :: [ Text ] -> [ Text ] -> [ ( Text, SomeFieldSType ) ] -> [ Text ]
duplicatesAcc _ dups [] = dups
duplicatesAcc seen dups ( ( k, _ ) : kvs )
| k `elem` seen
= duplicatesAcc seen ( k : dups ) kvs
| otherwise
= duplicatesAcc ( k : seen ) dups kvs
case duplicates of
[] -> pure ( mkBrushFields sortedFields )
[dup] -> throwError ( JSON.ParseFailed $ "Duplicate field name " <> dup <> " in brush record type" )
dups -> throwError ( JSON.ParseFailed $ "Duplicate field names in brush record type:\n" <> Text.unwords dups )
where
mkBrushFields :: [ ( Text, SomeFieldSType ) ] -> SomeBrushFields
mkBrushFields = fromSomeBrushFieldsList . mkBrushFieldsList
mkBrushFieldsList :: [ ( Text, SomeFieldSType ) ] -> SomeBrushFieldsList
mkBrushFieldsList [] = SomeBrushFieldsList NilFields
mkBrushFieldsList ( ( k, SomeFieldSType ( _ :: Proxy# v ) ) : kvs )
| SomeBrushFieldsList ( kvs_list :: BrushFieldsList kvs ) <- mkBrushFieldsList kvs
, SomeSymbol ( _ :: Proxy k ) <- someSymbolVal ( Text.unpack k )
-- deduce RecSize ( MapDiff kvs ) ~ RecSize kvs
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize ( MapDiff kvs ) :~: SuperRecord.RecSize kvs )
-- compute indexing into record list (with SuperRecord, the index is the number of fields remaining)
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k ( ( k SuperRecord.:= v ) : kvs ) :~: SuperRecord.RecSize kvs )
= SomeBrushFieldsList ( ConsFields ( proxy# :: Proxy# k ) ( proxy# :: Proxy# v ) kvs_list )
fromSomeBrushFieldsList :: SomeBrushFieldsList -> SomeBrushFields
fromSomeBrushFieldsList ( SomeBrushFieldsList ( kvs :: BrushFieldsList kvs ) ) = case go @kvs kvs of
SomeClassyBrushFieldsList ( _ :: Proxy# kvs ) ( _ :: Proxy# kvs ) ->
SomeBrushFields ( proxy# :: Proxy# kvs )
where
go :: forall ( rts :: [ Type ] ) ( lts :: [ Type ] )
. ( STypesI rts, KnownNat ( SuperRecord.RecSize rts ), KnownNat ( SuperRecord.RecSize ( MapDiff rts ) ) )
=> BrushFieldsList lts -> SomeClassyBrushFieldsList rts lts
go NilFields =
SomeClassyBrushFieldsList ( proxy# :: Proxy# rts ) ( proxy# :: Proxy# '[] )
go ( ConsFields ( _ :: Proxy# k ) ( _ :: Proxy# a ) kvs' )
| ( SomeClassyBrushFieldsList _ ( _ :: Proxy# lts' ) ) <- go @rts kvs'
-- Assert some facts that result from the field names being distinct:
-- - current field name does not re-occur later on
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k lts' :~: lts' )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k ( MapDiff lts' ) :~: MapDiff lts' )
-- - looking up the type associated with the current field name returns the current type
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k rts :~: Just a )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k ( MapDiff rts ) :~: Just ( Diff a ) )
-- - MapDiff preserves length
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize ( MapDiff lts' ) :~: SuperRecord.RecSize lts' )
-- - compute the index (which is the number of fields remaining, i.e. the indexing starts counting from 0 from the right)
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k rts :~: SuperRecord.RecSize lts' )
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k ( MapDiff rts ) :~: SuperRecord.RecSize lts' )
= SomeClassyBrushFieldsList ( proxy# :: Proxy# rts ) ( proxy# :: Proxy# ( ( k SuperRecord.:= a ) ': lts' ) )
encodeBrush :: Applicative f => JSON.Encoder f ( Brush brushParams )
encodeBrush = JSON.Encoder.mapLikeObj \ ( BrushData { brushName, brushCode } ) ->
JSON.Encoder.atKey' "name" JSON.Encoder.text brushName
. JSON.Encoder.atKey' "code" JSON.Encoder.text brushCode
decodeBrush
:: forall m flds. ( MonadIO m, STypesI flds )
=> UniqueSupply
-> JSON.Decoder m ( Brush flds )
decodeBrush uniqSupply = do
brushName <- JSON.Decoder.atKey "name" JSON.Decoder.text
brushCode <- JSON.Decoder.atKey "code" JSON.Decoder.text
( mbBrush, _ ) <- lift ( liftIO $ interpretBrush uniqSupply brushCode )
case mbBrush of
Left err -> throwError ( JSON.ParseFailed ( "Failed to interpret brush code:\n" <> ( Text.pack $ show err ) ) )
Right ( SomeBrushFunction ( brushFunction :: BrushFunction brushParams ) ) ->
case eqTys @flds @brushParams of
Just Refl -> pure ( BrushData { brushName, brushCode, brushFunction } )
Nothing ->
throwError
( JSON.ParseFailed $
"Brush has unexpected input record type:\n\
\Expected: " <> Text.pack ( show ( sTypesI @flds ) ) <> "\n\
\ Actual: " <> Text.pack ( show ( sTypesI @brushParams ) )
)
encodeStroke :: Monad f => JSON.Encoder f Stroke
encodeStroke = JSON.Encoder.mapLikeObj
\ ( Stroke
{ strokeName
, strokeVisible
, strokeSpline = strokeSpline :: StrokeSpline clo ( Super.Rec pointFields )
, strokeBrush = strokeBrush :: Brush brushFields
}
) ->
let
closed :: Bool
closed = case ssplineType @clo of
SClosed -> True
SOpen -> False
in
JSON.Encoder.atKey' "name" JSON.Encoder.text strokeName
. JSON.Encoder.atKey' "visible" JSON.Encoder.bool strokeVisible
. JSON.Encoder.atKey' "closed" JSON.Encoder.bool closed
. JSON.Encoder.atKey' "brushFields" encodeFieldTypes ( someSTypes @brushFields )
. JSON.Encoder.atKey' "pointFields" encodeFieldTypes ( someSTypes @pointFields )
. JSON.Encoder.atKey' "usedFields" encodeFieldTypes ( someSTypes @( brushFields `SuperRecord.Intersect` pointFields ) )
. JSON.Encoder.atKey' "brush" encodeBrush strokeBrush
. JSON.Encoder.atKey' "spline" ( encodeSpline encodePointData ) strokeSpline
decodeStroke :: forall m. MonadIO m => UniqueSupply -> JSON.Decoder m Stroke
decodeStroke uniqueSupply = do
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
@ -370,16 +776,188 @@ 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' "content" encodeDocumentContent documentContent
JSON.Encoder.atKey' "name" JSON.Encoder.text displayName
. 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

201
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
p0, p1, s :: Point2D Double
t :: Double
p0 = coords sp0
p1 = coords sp1
( t, s ) = closestPointToSegment @( Vector2D Double ) ( invert offset • c ) 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
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
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 ) )
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 ) = closestPointOnSegment @( Vector2D Double ) ( invert offset • c ) ( Segment p0 p1 )
sqDist :: Double
sqDist = quadrance @( Vector2D Double ) c ( offset • s )
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
sqDist :: 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
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 )

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -5,13 +5,16 @@
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE 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 )
Cairo.save
Cairo.translate ( 0.5 + 0.5 * fromIntegral viewportWidth ) ( 0.5 + 0.5 * fromIntegral viewportHeight )
Cairo.scale zoomFactor zoomFactor
Cairo.translate ( -cx ) ( -cy )
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,139 +208,210 @@ 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 } )
: strokes content
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
for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols mbHoverContext params mode debug zoomFactor )
renderSelectionRect
= ( strokes content, True )
Cairo.restore
pure ()
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
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 } )
| 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 ) }
| otherwise
= pure ()
-- 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
mbUpdatedDoc :: Maybe Document
mbUpdatedDoc
| noModifiedStrokes
= let
newDoc :: Document
newDoc =
set ( field' @"documentContent" . field' @"strokes" )
( modifiedStrokes )
doc
in Just newDoc
| otherwise
= Nothing -- TODO: update the original document in this case too (by undoing the modifications)
renderStroke
:: Colours -> Maybe HoverContext -> Mode -> Bool -> Double
-> ( Stroke, Maybe ( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed ), Seq FitPoint ) )
-> Compose Renders Cairo.Render ()
renderStroke cols@( Colours { brush } ) mbHoverContext mode debug zoom
( Stroke
{ strokeSpline = strokeSpline :: StrokeSpline clo ( Super.Rec pointFields )
, strokeVisible
, strokeBrush = BrushData { brushFunction = ( AdaptableFunction brushFn ) :: BrushFunction brushFields }
}
, mbOutlineData )
| strokeVisible
, ( _ :: Proxy# usedFields ) <- proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields )
, let
-- Get the adaptable brush shape (function),
-- specialising it to the type we are using.
toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields
brushShapeFn :: Super.Rec usedFields -> SplinePts Closed
( toUsedParams, brushShapeFn ) = brushFn @pointFields @usedFields
= renderStrokeSpline cols mode mbHoverContext zoom
( when ( mode == BrushMode ) . renderBrushShape ( cols { path = brush } ) mbHoverContext ( 1.5 * zoom ) ( brushShapeFn . toUsedParams ) )
strokeSpline
*> for_ mbOutlineData \outlineData ->
Compose blank { renderStrokes = drawOutline cols debug zoom outlineData }
| otherwise
= pure ()
-- | Render a sequence of stroke points.
--
-- 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
( ( 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 )
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
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 )

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

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

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

@ -1,11 +1,20 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.UI.Coordinates
( toViewportCoordinates, closestPoint )
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' } )

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

File diff suppressed because it is too large Load diff

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

@ -10,7 +10,8 @@ module Math.Module
( Module(..), lerp
, 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 )