Implement programmable brush framework

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

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

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

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

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 )

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

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 }

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

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

File diff suppressed because it is too large Load diff

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

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

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

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 )

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

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" [] ]

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 )

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

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

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

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 )

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

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

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 )

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 )

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

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

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

View file

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

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

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 )

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.
--

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 )

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

File diff suppressed because it is too large Load diff

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

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 )