mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 14:53:37 +00:00
Implement programmable brush framework
This commit is contained in:
parent
a5ba7dcd33
commit
393ef6f06e
|
@ -27,7 +27,7 @@ common common
|
|||
|
||||
build-depends:
|
||||
base
|
||||
>= 4.13 && < 4.16
|
||||
>= 4.13 && < 4.17
|
||||
, acts
|
||||
^>= 0.3.1.0
|
||||
, containers
|
||||
|
@ -77,6 +77,7 @@ library
|
|||
Math.Bezier.Cubic
|
||||
, Math.Bezier.Cubic.Fit
|
||||
, Math.Bezier.Quadratic
|
||||
, Math.Bezier.Spline
|
||||
, Math.Bezier.Stroke
|
||||
, Math.Epsilon
|
||||
, Math.Linear.Solve
|
||||
|
@ -85,12 +86,14 @@ library
|
|||
, Math.Vector2D
|
||||
|
||||
build-depends:
|
||||
groups-generic
|
||||
bifunctors
|
||||
^>= 5.5.4
|
||||
, groups-generic
|
||||
^>= 0.1.0.0
|
||||
, hmatrix
|
||||
^>= 0.20.0.0
|
||||
, monad-par
|
||||
^>= 0.3.5
|
||||
, parallel
|
||||
^>= 3.2.2.0
|
||||
, prim-instances
|
||||
^>= 0.2
|
||||
, vector
|
||||
|
@ -128,6 +131,14 @@ executable MetaBrush
|
|||
, MetaBrush.Document.SubdivideStroke
|
||||
, MetaBrush.Document.Update
|
||||
, MetaBrush.Event
|
||||
, MetaBrush.MetaParameter.AST
|
||||
, MetaBrush.MetaParameter.Driver
|
||||
, MetaBrush.MetaParameter.Eval
|
||||
, MetaBrush.MetaParameter.Interpolation
|
||||
, MetaBrush.MetaParameter.Parse
|
||||
, MetaBrush.MetaParameter.PrimOp
|
||||
, MetaBrush.MetaParameter.Rename
|
||||
, MetaBrush.MetaParameter.TypeCheck
|
||||
, MetaBrush.Render.Document
|
||||
, MetaBrush.Render.Rulers
|
||||
, MetaBrush.Time
|
||||
|
@ -153,11 +164,17 @@ executable MetaBrush
|
|||
, atomic-file-ops
|
||||
^>= 0.3.0.0
|
||||
, bytestring
|
||||
^>= 0.10.10.1
|
||||
^>= 0.10.10.0
|
||||
, directory
|
||||
>= 1.3.4.0 && < 1.4
|
||||
, dlist
|
||||
^>= 1.0
|
||||
, Earley
|
||||
^>= 0.13.0.1
|
||||
, filepath
|
||||
^>= 1.4.2.1
|
||||
, ghc-typelits-knownnat
|
||||
^>= 0.7.3
|
||||
, gi-gdk
|
||||
>= 3.0.22 && < 3.1
|
||||
, gi-gio
|
||||
|
@ -173,16 +190,22 @@ executable MetaBrush
|
|||
, gi-cairo-connector
|
||||
^>= 0.0.1
|
||||
, haskell-gi-base
|
||||
^>= 0.24
|
||||
^>= 0.24.3
|
||||
, lens
|
||||
^>= 4.19.2
|
||||
, mtl
|
||||
^>= 2.2.2
|
||||
, scientific
|
||||
^>= 0.3.6.2
|
||||
, stm
|
||||
^>= 2.5.0.0
|
||||
, superrecord
|
||||
^>= 0.5.1.0
|
||||
, tardis
|
||||
^>= 0.4.1.0
|
||||
, text
|
||||
^>= 1.2.3.1 && < 1.2.5
|
||||
>= 1.2.3.1 && < 1.2.5
|
||||
, tree-view
|
||||
^>= 0.5
|
||||
, waargonaut
|
||||
^>= 0.8.0.1
|
||||
|
|
158
app/Main.hs
158
app/Main.hs
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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 )
|
||||
)
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
@ -1,12 +1,26 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
|
||||
|
||||
module MetaBrush.Document.Serialise
|
||||
( documentToJSON, documentFromJSON
|
||||
( Serialisable(..)
|
||||
, documentToJSON, documentFromJSON
|
||||
, saveDocument, loadDocument
|
||||
)
|
||||
where
|
||||
|
@ -24,6 +38,24 @@ import Data.Functor.Contravariant
|
|||
( contramap )
|
||||
import Data.Functor.Identity
|
||||
( Identity(..) )
|
||||
import Data.Kind
|
||||
( Type )
|
||||
import Data.List
|
||||
( sortBy )
|
||||
import Data.Ord
|
||||
( comparing )
|
||||
import Data.Proxy
|
||||
( Proxy(Proxy) )
|
||||
import Data.Type.Equality
|
||||
( (:~:)(Refl) )
|
||||
import Data.Typeable
|
||||
( Typeable, eqT )
|
||||
import GHC.Exts
|
||||
( Proxy#, proxy# )
|
||||
import GHC.TypeLits
|
||||
( symbolVal', KnownSymbol, SomeSymbol(..), someSymbolVal, sameSymbol )
|
||||
import GHC.TypeNats
|
||||
( KnownNat )
|
||||
import Unsafe.Coerce
|
||||
( unsafeCoerce ) -- Tony Morris special
|
||||
|
||||
|
@ -51,6 +83,10 @@ import Data.Sequence
|
|||
import qualified Data.Sequence as Seq
|
||||
( fromList )
|
||||
|
||||
-- deepseq
|
||||
import Control.DeepSeq
|
||||
( NFData(..) )
|
||||
|
||||
-- directory
|
||||
import System.Directory
|
||||
( canonicalizePath, createDirectoryIfMissing, doesFileExist )
|
||||
|
@ -63,10 +99,18 @@ import System.FilePath
|
|||
import Data.Generics.Product.Typed
|
||||
( HasType(typed) )
|
||||
|
||||
-- groups
|
||||
import Data.Group
|
||||
( Group )
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( view )
|
||||
|
||||
-- mtl
|
||||
import Control.Monad.Except
|
||||
( MonadError(throwError) )
|
||||
|
||||
-- scientific
|
||||
import qualified Data.Scientific as Scientific
|
||||
( fromFloatDigits, toRealFloat )
|
||||
|
@ -75,13 +119,29 @@ import qualified Data.Scientific as Scientific
|
|||
import qualified Control.Concurrent.STM as STM
|
||||
( atomically )
|
||||
|
||||
-- superrecord
|
||||
import qualified SuperRecord as Super
|
||||
( Rec )
|
||||
import qualified SuperRecord
|
||||
( Has, RecTy, (:=), FldProxy(..)
|
||||
, RecSize, RecApply(..), RecVecIdxPos, UnsafeRecBuild(..)
|
||||
, TraversalCHelper, RemoveAccessTo, Intersect
|
||||
, reflectRec
|
||||
)
|
||||
import SuperRecord
|
||||
( ConstC, Tuple22C )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
import qualified Data.Text as Text
|
||||
( pack, unpack, unwords )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.IO.Class
|
||||
( MonadIO(liftIO) )
|
||||
import Control.Monad.Trans.Reader
|
||||
( runReaderT )
|
||||
import Control.Monad.Trans.Class
|
||||
( MonadTrans(lift) )
|
||||
|
||||
|
@ -91,14 +151,14 @@ import qualified Waargonaut.Attoparsec as JSON.Decoder
|
|||
import qualified Waargonaut.Decode as JSON
|
||||
( Decoder )
|
||||
import qualified Waargonaut.Decode.Error as JSON
|
||||
( DecodeError )
|
||||
( DecodeError(ParseFailed) )
|
||||
import qualified Waargonaut.Decode as JSON.Decoder
|
||||
( atKey, bool, list, oneOf, scientific, text )
|
||||
( atKey, atKeyOptional, bool, list, objectAsKeyValues, scientific, text )
|
||||
import qualified Waargonaut.Encode as JSON
|
||||
( Encoder, Encoder' )
|
||||
( Encoder )
|
||||
import qualified Waargonaut.Encode as JSON.Encoder
|
||||
( runEncoder
|
||||
, atKey', bool, list, mapLikeObj, scientific, text
|
||||
( runEncoder, runPureEncoder
|
||||
, atKey', bool, json, keyValueTupleFoldable, list, mapLikeObj, scientific, text, either
|
||||
)
|
||||
import qualified Waargonaut.Encode.Builder as JSON.Builder
|
||||
( waargonautBuilder, bsBuilder )
|
||||
|
@ -112,20 +172,40 @@ import qualified Waargonaut.Prettier as JSON
|
|||
( prettyJson )
|
||||
import qualified Waargonaut.Prettier as TonyMorris
|
||||
( Natural )
|
||||
import Waargonaut.Types.Json
|
||||
( Json )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Bezier.Stroke
|
||||
( StrokePoint(..) )
|
||||
import Math.Vector2D
|
||||
( Point2D(..), Vector2D(..) )
|
||||
import MetaBrush.Document
|
||||
( Document(..), DocumentContent(..)
|
||||
, Guide(..)
|
||||
, Stroke(..)
|
||||
, PointData(..)
|
||||
, BrushPointData(..)
|
||||
, FocusState(..)
|
||||
import qualified Math.Bezier.Cubic as Cubic
|
||||
( Bezier )
|
||||
import qualified Math.Bezier.Quadratic as Quadratic
|
||||
( Bezier )
|
||||
import Math.Bezier.Spline
|
||||
( Spline(..), SplinePts, SplineType(..), SSplineType(..), SplineTypeI(..)
|
||||
, Curves(..), Curve(..), NextPoint(..)
|
||||
)
|
||||
import Math.Bezier.Stroke
|
||||
( CachedStroke(..) )
|
||||
import Math.Module
|
||||
( Module )
|
||||
import Math.Vector2D
|
||||
( Point2D(..), Vector2D(..), Segment )
|
||||
import MetaBrush.Document
|
||||
( Document(..), DocumentContent(..), Guide(..)
|
||||
, Stroke(..), StrokeSpline
|
||||
, PointData(..), Brush(..) , FocusState(..)
|
||||
)
|
||||
import MetaBrush.MetaParameter.AST
|
||||
( SType(..), STypeI(..), STypes(..), STypesI(..)
|
||||
, SomeSType(..), someSTypes
|
||||
, Adapted, AdaptableFunction(..), BrushFunction
|
||||
, MapFields, UniqueField, UseFieldsInBrush
|
||||
, eqTy, eqTys
|
||||
)
|
||||
import MetaBrush.MetaParameter.Driver
|
||||
( SomeBrushFunction(..), interpretBrush )
|
||||
import MetaBrush.MetaParameter.Interpolation
|
||||
( Interpolatable(..), MapDiff, HasDiff', HasTorsor )
|
||||
import MetaBrush.Unique
|
||||
( Unique, UniqueSupply, freshUnique )
|
||||
|
||||
|
@ -176,31 +256,53 @@ loadDocument uniqueSupply fp = do
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
encodeDouble :: Applicative f => JSON.Encoder f Double
|
||||
encodeDouble = contramap Scientific.fromFloatDigits JSON.Encoder.scientific
|
||||
class Serialisable a where
|
||||
encoder :: Monad f => JSON.Encoder f a
|
||||
decoder :: Monad m => JSON.Decoder m a
|
||||
|
||||
decodeDouble :: Monad m => JSON.Decoder m Double
|
||||
decodeDouble = fmap Scientific.toRealFloat JSON.Decoder.scientific
|
||||
instance Serialisable Double where
|
||||
encoder = contramap Scientific.fromFloatDigits JSON.Encoder.scientific
|
||||
decoder = fmap Scientific.toRealFloat JSON.Decoder.scientific
|
||||
|
||||
instance Serialisable a => Serialisable ( Point2D a ) where
|
||||
encoder = JSON.Encoder.mapLikeObj \ ( Point2D x y ) ->
|
||||
JSON.Encoder.atKey' "x" encoder x
|
||||
. JSON.Encoder.atKey' "y" encoder y
|
||||
decoder = Point2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
|
||||
|
||||
instance Serialisable a => Serialisable ( Vector2D a ) where
|
||||
encoder = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) ->
|
||||
JSON.Encoder.atKey' "x" encoder x
|
||||
. JSON.Encoder.atKey' "y" encoder y
|
||||
decoder = Vector2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
|
||||
|
||||
encodePoint2D :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Point2D a )
|
||||
encodePoint2D enc = JSON.Encoder.mapLikeObj \ ( Point2D x y ) ->
|
||||
JSON.Encoder.atKey' "x" enc x . JSON.Encoder.atKey' "y" enc y
|
||||
instance ( SuperRecord.RecApply flds flds ( ConstC Serialisable )
|
||||
, SuperRecord.UnsafeRecBuild flds flds ( ConstC Serialisable )
|
||||
, KnownNat ( SuperRecord.RecSize flds )
|
||||
)
|
||||
=> Serialisable ( Super.Rec flds ) where
|
||||
encoder :: forall f. Monad f => JSON.Encoder f ( Super.Rec flds )
|
||||
encoder = contramap ( SuperRecord.reflectRec @( ConstC Serialisable ) keyVal ) ( JSON.Encoder.keyValueTupleFoldable JSON.Encoder.json )
|
||||
where
|
||||
keyVal :: forall k v. ( KnownSymbol k, Serialisable v ) => SuperRecord.FldProxy k -> v -> ( Text, Json )
|
||||
keyVal _ v = let k = symbolVal' ( proxy# :: Proxy# k ) in ( Text.pack k, JSON.Encoder.runPureEncoder ( encoder @v ) v )
|
||||
|
||||
decodePoint2D :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Point2D a )
|
||||
decodePoint2D dec = Point2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" dec
|
||||
|
||||
|
||||
|
||||
encodeVector2D :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Vector2D a )
|
||||
encodeVector2D enc = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) ->
|
||||
JSON.Encoder.atKey' "x" enc x
|
||||
. JSON.Encoder.atKey' "y" enc y
|
||||
|
||||
decodeVector2D :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Vector2D a )
|
||||
decodeVector2D dec = Vector2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" dec
|
||||
decoder :: forall m. Monad m => JSON.Decoder m ( Super.Rec flds )
|
||||
decoder = SuperRecord.unsafeRecBuild @flds @flds @( ConstC Serialisable ) decodeAndWrite
|
||||
where
|
||||
decodeAndWrite
|
||||
:: forall k v
|
||||
. ( KnownSymbol k, Serialisable v )
|
||||
=> SuperRecord.FldProxy k -> Proxy# v
|
||||
-> JSON.Decoder m v
|
||||
decodeAndWrite _ _ = do
|
||||
let
|
||||
k :: Text
|
||||
k = Text.pack ( symbolVal' ( proxy# :: Proxy# k ) )
|
||||
val <- JSON.Decoder.atKey k ( decoder @v @m )
|
||||
pure val
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{-
|
||||
encodeMat22 :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Mat22 a )
|
||||
|
@ -238,30 +340,115 @@ decodeAABB = do
|
|||
-}
|
||||
|
||||
|
||||
encodeStrokePoint :: Applicative f => JSON.Encoder' d -> JSON.Encoder f ( StrokePoint d )
|
||||
encodeStrokePoint enc = JSON.Encoder.mapLikeObj \case
|
||||
PathPoint { coords, pointData } ->
|
||||
JSON.Encoder.atKey' "coords" ( encodePoint2D encodeDouble ) coords
|
||||
. JSON.Encoder.atKey' "data" enc pointData
|
||||
. JSON.Encoder.atKey' "type" JSON.Encoder.text "path"
|
||||
ControlPoint { coords, pointData } ->
|
||||
JSON.Encoder.atKey' "coords" ( encodePoint2D encodeDouble ) coords
|
||||
. JSON.Encoder.atKey' "data" enc pointData
|
||||
. JSON.Encoder.atKey' "type" JSON.Encoder.text "control"
|
||||
encodeCurve
|
||||
:: forall clo crvData ptData f
|
||||
. ( SplineTypeI clo, Applicative f )
|
||||
=> JSON.Encoder Identity ptData
|
||||
-> JSON.Encoder f ( Curve clo crvData ptData )
|
||||
encodeCurve encodePtData = case ssplineType @clo of
|
||||
SOpen -> JSON.Encoder.mapLikeObj \case
|
||||
LineTo ( NextPoint p1 ) _ ->
|
||||
JSON.Encoder.atKey' "p1" encodePtData p1
|
||||
Bezier2To p1 ( NextPoint p2 ) _ ->
|
||||
JSON.Encoder.atKey' "p1" encodePtData p1
|
||||
. JSON.Encoder.atKey' "p2" encodePtData p2
|
||||
Bezier3To p1 p2 ( NextPoint p3 ) _ ->
|
||||
JSON.Encoder.atKey' "p1" encodePtData p1
|
||||
. JSON.Encoder.atKey' "p2" encodePtData p2
|
||||
. JSON.Encoder.atKey' "p3" encodePtData p3
|
||||
SClosed -> JSON.Encoder.mapLikeObj \case
|
||||
LineTo BackToStart _ -> id
|
||||
Bezier2To p1 BackToStart _ ->
|
||||
JSON.Encoder.atKey' "p1" encodePtData p1
|
||||
Bezier3To p1 p2 BackToStart _ ->
|
||||
JSON.Encoder.atKey' "p1" encodePtData p1
|
||||
. JSON.Encoder.atKey' "p2" encodePtData p2
|
||||
|
||||
decodeStrokePointTypeIsPath :: Monad m => JSON.Decoder m Bool
|
||||
decodeStrokePointTypeIsPath = JSON.Decoder.oneOf JSON.Decoder.text "StrokePoint Type"
|
||||
[ ( "path", True ), ( "control", False ) ]
|
||||
decodeCurve
|
||||
:: forall clo ptData m
|
||||
. ( SplineTypeI clo, Monad m )
|
||||
=> JSON.Decoder m ptData
|
||||
-> JSON.Decoder m ( Curve clo CachedStroke ptData )
|
||||
decodeCurve decodePtData = case ssplineType @clo of
|
||||
SOpen -> do
|
||||
p1 <- JSON.Decoder.atKey "p1" decodePtData
|
||||
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
|
||||
case mb_p2 of
|
||||
Nothing ->
|
||||
pure ( LineTo ( NextPoint p1 ) ( CachedStroke Nothing ) )
|
||||
Just p2 -> do
|
||||
mb_p3 <- JSON.Decoder.atKeyOptional "p3" decodePtData
|
||||
case mb_p3 of
|
||||
Nothing -> pure ( Bezier2To p1 ( NextPoint p2 ) ( CachedStroke Nothing ) )
|
||||
Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) ( CachedStroke Nothing ) )
|
||||
SClosed -> do
|
||||
mb_p1 <- JSON.Decoder.atKeyOptional "p1" decodePtData
|
||||
case mb_p1 of
|
||||
Nothing ->
|
||||
pure ( LineTo BackToStart ( CachedStroke Nothing ) )
|
||||
Just p1 -> do
|
||||
mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData
|
||||
case mb_p2 of
|
||||
Nothing -> pure ( Bezier2To p1 BackToStart ( CachedStroke Nothing ) )
|
||||
Just p2 -> pure ( Bezier3To p1 p2 BackToStart ( CachedStroke Nothing ) )
|
||||
|
||||
decodeStrokePoint :: Monad m => JSON.Decoder m d -> JSON.Decoder m ( StrokePoint d )
|
||||
decodeStrokePoint dec = do
|
||||
coords <- JSON.Decoder.atKey "coords" ( decodePoint2D decodeDouble )
|
||||
pointData <- JSON.Decoder.atKey "data" dec
|
||||
isPathPoint <- JSON.Decoder.atKey "type" decodeStrokePointTypeIsPath
|
||||
if isPathPoint
|
||||
then pure ( PathPoint { coords, pointData } )
|
||||
else pure ( ControlPoint { coords, pointData } )
|
||||
|
||||
|
||||
encodeCurves
|
||||
:: forall clo crvData ptData f
|
||||
. ( SplineTypeI clo, Applicative f )
|
||||
=> JSON.Encoder Identity ptData
|
||||
-> JSON.Encoder f ( Curves clo crvData ptData )
|
||||
encodeCurves encodePtData = case ssplineType @clo of
|
||||
SOpen -> contramap ( openCurves ) ( encodeSequence $ encodeCurve @Open encodePtData )
|
||||
SClosed -> contramap ( \case { NoCurves -> Left (); ClosedCurves prevs lst -> Right ( prevs, lst ) } ) ( JSON.Encoder.either encodeL encodeR )
|
||||
where
|
||||
encodeL :: JSON.Encoder f ()
|
||||
encodeL = contramap ( const "NoCurves" ) JSON.Encoder.text
|
||||
encodeR :: JSON.Encoder f ( Seq ( Curve Open crvData ptData ), Curve Closed crvData ptData )
|
||||
encodeR = JSON.Encoder.mapLikeObj \ ( openCurves, closedCurve ) ->
|
||||
JSON.Encoder.atKey' "prevOpenCurves" ( encodeSequence $ encodeCurve @Open encodePtData ) openCurves
|
||||
. JSON.Encoder.atKey' "lastClosedCurve" ( encodeCurve @Closed encodePtData ) closedCurve
|
||||
|
||||
decodeCurves
|
||||
:: forall clo ptData m
|
||||
. ( SplineTypeI clo, Monad m )
|
||||
=> JSON.Decoder m ptData
|
||||
-> JSON.Decoder m ( Curves clo CachedStroke ptData )
|
||||
decodeCurves decodePtData = case ssplineType @clo of
|
||||
SOpen -> OpenCurves <$> decodeSequence ( decodeCurve @Open decodePtData )
|
||||
SClosed -> do
|
||||
mbNoCurves <- JSON.Decoder.atKeyOptional "NoCurves" ( JSON.Decoder.text )
|
||||
case mbNoCurves of
|
||||
Just _ -> pure NoCurves
|
||||
Nothing -> do
|
||||
prevCurves <- JSON.Decoder.atKey "prevOpenCurves" ( decodeSequence $ decodeCurve @Open decodePtData )
|
||||
lastCurve <- JSON.Decoder.atKey "lastClosedCurve" ( decodeCurve @Closed decodePtData )
|
||||
pure ( ClosedCurves prevCurves lastCurve )
|
||||
|
||||
|
||||
|
||||
encodeSpline
|
||||
:: forall clo crvData ptData f
|
||||
. ( SplineTypeI clo, Applicative f )
|
||||
=> JSON.Encoder Identity ptData
|
||||
-> JSON.Encoder f ( Spline clo crvData ptData )
|
||||
encodeSpline encodePtData = JSON.Encoder.mapLikeObj \ ( Spline { splineStart, splineCurves } ) ->
|
||||
JSON.Encoder.atKey' "splineStart" encodePtData splineStart
|
||||
. JSON.Encoder.atKey' "splineCurves" ( encodeCurves @clo encodePtData ) splineCurves
|
||||
|
||||
decodeSpline
|
||||
:: forall clo ptData m
|
||||
. ( SplineTypeI clo, Monad m )
|
||||
=> JSON.Decoder m ptData
|
||||
-> JSON.Decoder m ( Spline clo CachedStroke ptData )
|
||||
decodeSpline decodePtData = do
|
||||
splineStart <- JSON.Decoder.atKey "splineStart" decodePtData
|
||||
splineCurves <- JSON.Decoder.atKey "splineCurves" ( decodeCurves @clo decodePtData )
|
||||
pure ( Spline { splineStart, splineCurves } )
|
||||
|
||||
|
||||
{-
|
||||
encodeFocusState :: Applicative f => JSON.Encoder f FocusState
|
||||
encodeFocusState = contramap focusText JSON.Encoder.text
|
||||
where
|
||||
|
@ -287,7 +474,7 @@ decodeBrushPointData :: Monad m => JSON.Decoder m BrushPointData
|
|||
decodeBrushPointData = do
|
||||
brushPointState <- JSON.Decoder.atKey "focus" decodeFocusState
|
||||
pure ( BrushPointData { brushPointState } )
|
||||
|
||||
-}
|
||||
|
||||
|
||||
encodeSequence :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Seq a )
|
||||
|
@ -306,50 +493,269 @@ decodeUniqueMap dec = Map.fromList . map ( view typed &&& id ) <$> JSON.Decoder.
|
|||
|
||||
|
||||
|
||||
encodePointData :: Applicative f => JSON.Encoder f PointData
|
||||
encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointState, brushShape } ) ->
|
||||
JSON.Encoder.atKey' "focus" encodeFocusState pointState
|
||||
. JSON.Encoder.atKey' "brush" ( encodeSequence ( encodeStrokePoint encodeBrushPointData ) ) brushShape
|
||||
encodePointData
|
||||
:: forall f flds brushParams
|
||||
. ( Applicative f
|
||||
, brushParams ~ Super.Rec flds
|
||||
, Serialisable ( Super.Rec flds )
|
||||
)
|
||||
=> JSON.Encoder f ( PointData brushParams )
|
||||
encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointCoords, brushParams } ) ->
|
||||
JSON.Encoder.atKey' "coords" ( encoder @( Point2D Double ) ) pointCoords
|
||||
. JSON.Encoder.atKey' "brushParams" ( encoder @( Super.Rec flds ) ) brushParams
|
||||
|
||||
decodePointData :: Monad m => JSON.Decoder m PointData
|
||||
decodePointData
|
||||
:: forall m flds brushParams
|
||||
. ( Monad m
|
||||
, brushParams ~ Super.Rec flds
|
||||
, Serialisable ( Super.Rec flds )
|
||||
)
|
||||
=> JSON.Decoder m ( PointData brushParams )
|
||||
decodePointData = do
|
||||
pointState <- JSON.Decoder.atKey "focus" decodeFocusState
|
||||
brushShape <- JSON.Decoder.atKey "brush" ( decodeSequence ( decodeStrokePoint decodeBrushPointData ) )
|
||||
pure ( PointData { pointState, brushShape } )
|
||||
pointCoords <- JSON.Decoder.atKey "coords" ( decoder @( Point2D Double ) )
|
||||
let
|
||||
pointState :: FocusState
|
||||
pointState = Normal
|
||||
brushParams <- JSON.Decoder.atKey "brushParams" ( decoder @( Super.Rec flds ) )
|
||||
pure ( PointData { pointCoords, pointState, brushParams } )
|
||||
|
||||
|
||||
|
||||
encodeStroke :: Applicative f => JSON.Encoder f Stroke
|
||||
encodeStroke = JSON.Encoder.mapLikeObj \ ( Stroke { strokeName, strokeVisible, strokePoints } ) ->
|
||||
JSON.Encoder.atKey' "name" JSON.Encoder.text strokeName
|
||||
. JSON.Encoder.atKey' "visible" JSON.Encoder.bool strokeVisible
|
||||
. JSON.Encoder.atKey' "points" ( encodeSequence ( encodeStrokePoint encodePointData ) ) strokePoints
|
||||
encodeSomeSType :: Applicative f => JSON.Encoder f SomeSType
|
||||
encodeSomeSType = JSON.Encoder.mapLikeObj \ ( SomeSType ( _ :: Proxy# ty ) ) ->
|
||||
case sTypeI @ty of
|
||||
sFunTy@SFunTy | ( _ :: SType ( a -> b ) ) <- sFunTy
|
||||
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "fun"
|
||||
. JSON.Encoder.atKey' "arg" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) )
|
||||
. JSON.Encoder.atKey' "res" encodeSomeSType ( SomeSType ( proxy# :: Proxy# b ) )
|
||||
STyBool
|
||||
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bool"
|
||||
STyDouble
|
||||
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "double"
|
||||
sTyPoint@STyPoint | ( _ :: SType ( Point2D a ) ) <- sTyPoint
|
||||
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "point"
|
||||
. JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) )
|
||||
sTyLine@STyLine | ( _ :: SType ( Segment a ) ) <- sTyLine
|
||||
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "line"
|
||||
. JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) )
|
||||
sTyBez2@STyBez2 | ( _ :: SType ( Quadratic.Bezier a ) ) <- sTyBez2
|
||||
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bez2"
|
||||
. JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) )
|
||||
sTyBez3@STyBez3 | ( _ :: SType ( Cubic.Bezier a ) ) <- sTyBez3
|
||||
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bez3"
|
||||
. JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) )
|
||||
sTySpline@STySpline | ( _ :: SType ( SplinePts clo ) ) <- sTySpline
|
||||
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "spline"
|
||||
. JSON.Encoder.atKey' "closed" JSON.Encoder.bool ( case ssplineType @clo of { SOpen -> False; SClosed -> True } )
|
||||
sTyRecord@STyWithFn | ( _ :: SType ( AdaptableFunction kvs res ) ) <- sTyRecord
|
||||
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "adaptableFun"
|
||||
. JSON.Encoder.atKey' "fields" encodeFieldTypes ( someSTypes @kvs )
|
||||
. JSON.Encoder.atKey' "res" encodeSomeSType ( SomeSType ( proxy# :: Proxy# res ) )
|
||||
{-
|
||||
decodeSomeSType :: Monad m => JSON.Decoder m SomeSType
|
||||
decodeSomeSType = do
|
||||
tag <- JSON.Decoder.atKey "tag" JSON.Decoder.text
|
||||
case tag of
|
||||
"fun" -> do
|
||||
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "arg" decodeSomeSType
|
||||
( SomeSType ( _ :: Proxy# b ) ) <- JSON.Decoder.atKey "res" decodeSomeSType
|
||||
pure ( SomeSType ( proxy# :: Proxy# ( a -> b ) ) )
|
||||
"bool" -> pure ( SomeSType ( proxy# :: Proxy# Bool ) )
|
||||
"double" -> pure ( SomeSType ( proxy# :: Proxy# Double ) )
|
||||
"point" -> do
|
||||
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
|
||||
pure ( SomeSType ( proxy# :: Proxy# ( Point2D a ) ) )
|
||||
"line" -> do
|
||||
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
|
||||
pure ( SomeSType ( proxy# :: Proxy# ( Segment a ) ) )
|
||||
"bez2" -> do
|
||||
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
|
||||
pure ( SomeSType ( proxy# :: Proxy# ( Quadratic.Bezier a ) ) )
|
||||
"bez3" -> do
|
||||
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType
|
||||
pure ( SomeSType ( proxy# :: Proxy# ( Cubic.Bezier a ) ) )
|
||||
"spline" -> do
|
||||
closed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool
|
||||
case closed of
|
||||
True -> pure ( SomeSType ( proxy# :: Proxy# ( SplinePts Closed ) ) )
|
||||
False -> pure ( SomeSType ( proxy# :: Proxy# ( SplinePts Open ) ) )
|
||||
"adaptableFun" -> do
|
||||
( SomeBrushFields ( _ :: Proxy# kvs ) ) <- JSON.Decoder.atKey "fields" decodeFieldTypes
|
||||
( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "res" decodeSomeSType
|
||||
pure ( SomeSType ( proxy# :: Proxy# ( AdaptableFunction kvs a ) ) )
|
||||
-}
|
||||
decodeSomeFieldSType :: Monad m => JSON.Decoder m SomeFieldSType
|
||||
decodeSomeFieldSType = do
|
||||
tag <- JSON.Decoder.atKey "tag" JSON.Decoder.text
|
||||
case tag of
|
||||
"double" -> pure ( SomeFieldSType ( proxy# :: Proxy# Double ) )
|
||||
"point" -> do
|
||||
( SomeFieldSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeFieldSType
|
||||
case eqT @a @Double of
|
||||
Just Refl -> pure ( SomeFieldSType ( proxy# :: Proxy# ( Point2D Double ) ) )
|
||||
Nothing -> throwError ( JSON.ParseFailed "Point2D: non-Double coordinate type" )
|
||||
_ -> throwError ( JSON.ParseFailed $ "Unsupported record field type with tag " <> tag )
|
||||
|
||||
decodeStroke :: MonadIO m => UniqueSupply -> JSON.Decoder m Stroke
|
||||
|
||||
encodeFieldTypes :: Monad f => JSON.Encoder f ( [ ( Text, SomeSType ) ] )
|
||||
encodeFieldTypes = JSON.Encoder.keyValueTupleFoldable encodeSomeSType
|
||||
|
||||
decodeFieldTypes :: Monad m => JSON.Decoder m SomeBrushFields
|
||||
decodeFieldTypes = do
|
||||
fields <- JSON.Decoder.objectAsKeyValues JSON.Decoder.text decodeSomeFieldSType
|
||||
let
|
||||
sortedFields :: [ ( Text, SomeFieldSType ) ]
|
||||
sortedFields = sortBy ( comparing fst ) fields
|
||||
duplicates :: [ Text ]
|
||||
duplicates = duplicatesAcc [] [] sortedFields
|
||||
duplicatesAcc :: [ Text ] -> [ Text ] -> [ ( Text, SomeFieldSType ) ] -> [ Text ]
|
||||
duplicatesAcc _ dups [] = dups
|
||||
duplicatesAcc seen dups ( ( k, _ ) : kvs )
|
||||
| k `elem` seen
|
||||
= duplicatesAcc seen ( k : dups ) kvs
|
||||
| otherwise
|
||||
= duplicatesAcc ( k : seen ) dups kvs
|
||||
case duplicates of
|
||||
[] -> pure ( mkBrushFields sortedFields )
|
||||
[dup] -> throwError ( JSON.ParseFailed $ "Duplicate field name " <> dup <> " in brush record type" )
|
||||
dups -> throwError ( JSON.ParseFailed $ "Duplicate field names in brush record type:\n" <> Text.unwords dups )
|
||||
|
||||
where
|
||||
|
||||
mkBrushFields :: [ ( Text, SomeFieldSType ) ] -> SomeBrushFields
|
||||
mkBrushFields = fromSomeBrushFieldsList . mkBrushFieldsList
|
||||
|
||||
mkBrushFieldsList :: [ ( Text, SomeFieldSType ) ] -> SomeBrushFieldsList
|
||||
mkBrushFieldsList [] = SomeBrushFieldsList NilFields
|
||||
mkBrushFieldsList ( ( k, SomeFieldSType ( _ :: Proxy# v ) ) : kvs )
|
||||
| SomeBrushFieldsList ( kvs_list :: BrushFieldsList kvs ) <- mkBrushFieldsList kvs
|
||||
, SomeSymbol ( _ :: Proxy k ) <- someSymbolVal ( Text.unpack k )
|
||||
-- deduce RecSize ( MapDiff kvs ) ~ RecSize kvs
|
||||
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize ( MapDiff kvs ) :~: SuperRecord.RecSize kvs )
|
||||
-- compute indexing into record list (with SuperRecord, the index is the number of fields remaining)
|
||||
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k ( ( k SuperRecord.:= v ) : kvs ) :~: SuperRecord.RecSize kvs )
|
||||
= SomeBrushFieldsList ( ConsFields ( proxy# :: Proxy# k ) ( proxy# :: Proxy# v ) kvs_list )
|
||||
|
||||
fromSomeBrushFieldsList :: SomeBrushFieldsList -> SomeBrushFields
|
||||
fromSomeBrushFieldsList ( SomeBrushFieldsList ( kvs :: BrushFieldsList kvs ) ) = case go @kvs kvs of
|
||||
SomeClassyBrushFieldsList ( _ :: Proxy# kvs ) ( _ :: Proxy# kvs ) ->
|
||||
SomeBrushFields ( proxy# :: Proxy# kvs )
|
||||
where
|
||||
go :: forall ( rts :: [ Type ] ) ( lts :: [ Type ] )
|
||||
. ( STypesI rts, KnownNat ( SuperRecord.RecSize rts ), KnownNat ( SuperRecord.RecSize ( MapDiff rts ) ) )
|
||||
=> BrushFieldsList lts -> SomeClassyBrushFieldsList rts lts
|
||||
go NilFields =
|
||||
SomeClassyBrushFieldsList ( proxy# :: Proxy# rts ) ( proxy# :: Proxy# '[] )
|
||||
go ( ConsFields ( _ :: Proxy# k ) ( _ :: Proxy# a ) kvs' )
|
||||
| ( SomeClassyBrushFieldsList _ ( _ :: Proxy# lts' ) ) <- go @rts kvs'
|
||||
-- Assert some facts that result from the field names being distinct:
|
||||
-- - current field name does not re-occur later on
|
||||
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k lts' :~: lts' )
|
||||
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k ( MapDiff lts' ) :~: MapDiff lts' )
|
||||
-- - looking up the type associated with the current field name returns the current type
|
||||
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k rts :~: Just a )
|
||||
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k ( MapDiff rts ) :~: Just ( Diff a ) )
|
||||
-- - MapDiff preserves length
|
||||
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize ( MapDiff lts' ) :~: SuperRecord.RecSize lts' )
|
||||
-- - compute the index (which is the number of fields remaining, i.e. the indexing starts counting from 0 from the right)
|
||||
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k rts :~: SuperRecord.RecSize lts' )
|
||||
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k ( MapDiff rts ) :~: SuperRecord.RecSize lts' )
|
||||
= SomeClassyBrushFieldsList ( proxy# :: Proxy# rts ) ( proxy# :: Proxy# ( ( k SuperRecord.:= a ) ': lts' ) )
|
||||
|
||||
|
||||
|
||||
encodeBrush :: Applicative f => JSON.Encoder f ( Brush brushParams )
|
||||
encodeBrush = JSON.Encoder.mapLikeObj \ ( BrushData { brushName, brushCode } ) ->
|
||||
JSON.Encoder.atKey' "name" JSON.Encoder.text brushName
|
||||
. JSON.Encoder.atKey' "code" JSON.Encoder.text brushCode
|
||||
|
||||
decodeBrush
|
||||
:: forall m flds. ( MonadIO m, STypesI flds )
|
||||
=> UniqueSupply
|
||||
-> JSON.Decoder m ( Brush flds )
|
||||
decodeBrush uniqSupply = do
|
||||
brushName <- JSON.Decoder.atKey "name" JSON.Decoder.text
|
||||
brushCode <- JSON.Decoder.atKey "code" JSON.Decoder.text
|
||||
( mbBrush, _ ) <- lift ( liftIO $ interpretBrush uniqSupply brushCode )
|
||||
case mbBrush of
|
||||
Left err -> throwError ( JSON.ParseFailed ( "Failed to interpret brush code:\n" <> ( Text.pack $ show err ) ) )
|
||||
Right ( SomeBrushFunction ( brushFunction :: BrushFunction brushParams ) ) ->
|
||||
case eqTys @flds @brushParams of
|
||||
Just Refl -> pure ( BrushData { brushName, brushCode, brushFunction } )
|
||||
Nothing ->
|
||||
throwError
|
||||
( JSON.ParseFailed $
|
||||
"Brush has unexpected input record type:\n\
|
||||
\Expected: " <> Text.pack ( show ( sTypesI @flds ) ) <> "\n\
|
||||
\ Actual: " <> Text.pack ( show ( sTypesI @brushParams ) )
|
||||
)
|
||||
|
||||
|
||||
|
||||
encodeStroke :: Monad f => JSON.Encoder f Stroke
|
||||
encodeStroke = JSON.Encoder.mapLikeObj
|
||||
\ ( Stroke
|
||||
{ strokeName
|
||||
, strokeVisible
|
||||
, strokeSpline = strokeSpline :: StrokeSpline clo ( Super.Rec pointFields )
|
||||
, strokeBrush = strokeBrush :: Brush brushFields
|
||||
}
|
||||
) ->
|
||||
let
|
||||
closed :: Bool
|
||||
closed = case ssplineType @clo of
|
||||
SClosed -> True
|
||||
SOpen -> False
|
||||
in
|
||||
JSON.Encoder.atKey' "name" JSON.Encoder.text strokeName
|
||||
. JSON.Encoder.atKey' "visible" JSON.Encoder.bool strokeVisible
|
||||
. JSON.Encoder.atKey' "closed" JSON.Encoder.bool closed
|
||||
. JSON.Encoder.atKey' "brushFields" encodeFieldTypes ( someSTypes @brushFields )
|
||||
. JSON.Encoder.atKey' "pointFields" encodeFieldTypes ( someSTypes @pointFields )
|
||||
. JSON.Encoder.atKey' "usedFields" encodeFieldTypes ( someSTypes @( brushFields `SuperRecord.Intersect` pointFields ) )
|
||||
. JSON.Encoder.atKey' "brush" encodeBrush strokeBrush
|
||||
. JSON.Encoder.atKey' "spline" ( encodeSpline encodePointData ) strokeSpline
|
||||
|
||||
|
||||
|
||||
decodeStroke :: forall m. MonadIO m => UniqueSupply -> JSON.Decoder m Stroke
|
||||
decodeStroke uniqueSupply = do
|
||||
strokeName <- JSON.Decoder.atKey "name" JSON.Decoder.text
|
||||
strokeVisible <- JSON.Decoder.atKey "visible" JSON.Decoder.bool
|
||||
strokeUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
|
||||
strokePoints <- JSON.Decoder.atKey "points" ( decodeSequence ( decodeStrokePoint decodePointData ) )
|
||||
pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokePoints } )
|
||||
|
||||
|
||||
strokeUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
|
||||
strokeClosed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool
|
||||
SomeBrushFields ( _ :: Proxy# brushFields ) <- JSON.Decoder.atKey "brushFields" decodeFieldTypes
|
||||
SomeBrushFields ( _ :: Proxy# pointFields ) <- JSON.Decoder.atKey "pointFields" decodeFieldTypes
|
||||
SomeBrushFields ( _ :: Proxy# usedFields ) <- JSON.Decoder.atKey "usedFields" decodeFieldTypes
|
||||
strokeBrush <- JSON.Decoder.atKey "brush" ( decodeBrush @m @brushFields uniqueSupply )
|
||||
case proveAdapted @brushFields @pointFields @usedFields of
|
||||
Nothing -> throwError ( JSON.ParseFailed "Stroke: 'usedFields' is not equal to 'brushFields `Intersect` pointFields'" )
|
||||
Just Dict ->
|
||||
case strokeClosed of
|
||||
True -> do
|
||||
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Super.Rec pointFields ) ) decodePointData )
|
||||
pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush } )
|
||||
False -> do
|
||||
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open @( PointData ( Super.Rec pointFields ) ) decodePointData )
|
||||
pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush } )
|
||||
|
||||
encodeGuide :: Applicative f => JSON.Encoder f Guide
|
||||
encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal, guideFocus } ) ->
|
||||
JSON.Encoder.atKey' "point" ( encodePoint2D encodeDouble ) guidePoint
|
||||
. JSON.Encoder.atKey' "normal" ( encodeVector2D encodeDouble ) guideNormal
|
||||
. JSON.Encoder.atKey' "focus" encodeFocusState guideFocus
|
||||
encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) ->
|
||||
JSON.Encoder.atKey' "point" ( encoder @( Point2D Double ) ) guidePoint
|
||||
. JSON.Encoder.atKey' "normal" ( encoder @( Vector2D Double ) ) guideNormal
|
||||
|
||||
decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m Guide
|
||||
decodeGuide uniqueSupply = do
|
||||
guidePoint <- JSON.Decoder.atKey "point" ( decodePoint2D decodeDouble )
|
||||
guideNormal <- JSON.Decoder.atKey "normal" ( decodeVector2D decodeDouble )
|
||||
guideFocus <- JSON.Decoder.atKey "focus" decodeFocusState
|
||||
guideUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
|
||||
guidePoint <- JSON.Decoder.atKey "point" ( decoder @( Point2D Double ) )
|
||||
guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( Vector2D Double ) )
|
||||
let
|
||||
guideFocus :: FocusState
|
||||
guideFocus = Normal
|
||||
guideUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
|
||||
pure ( Guide { guidePoint, guideNormal, guideFocus, guideUnique } )
|
||||
|
||||
|
||||
|
||||
encodeDocumentContent :: Applicative f => JSON.Encoder f DocumentContent
|
||||
encodeDocumentContent = JSON.Encoder.mapLikeObj \ ( Content { guides, strokes } ) ->
|
||||
JSON.Encoder.atKey' "guides" ( encodeUniqueMap encodeGuide ) guides
|
||||
|
@ -370,16 +776,188 @@ decodeDocumentContent uniqueSupply = do
|
|||
|
||||
encodeDocument :: Applicative f => JSON.Encoder f Document
|
||||
encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, documentContent } ) ->
|
||||
JSON.Encoder.atKey' "name" JSON.Encoder.text displayName
|
||||
. JSON.Encoder.atKey' "center" ( encodePoint2D encodeDouble ) viewportCenter
|
||||
. JSON.Encoder.atKey' "zoom" encodeDouble zoomFactor
|
||||
. JSON.Encoder.atKey' "content" encodeDocumentContent documentContent
|
||||
JSON.Encoder.atKey' "name" JSON.Encoder.text displayName
|
||||
. JSON.Encoder.atKey' "center" ( encoder @( Point2D Double ) ) viewportCenter
|
||||
. JSON.Encoder.atKey' "zoom" ( encoder @Double ) zoomFactor
|
||||
. JSON.Encoder.atKey' "content" encodeDocumentContent documentContent
|
||||
|
||||
decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document
|
||||
decodeDocument uniqueSupply mbFilePath = do
|
||||
displayName <- JSON.Decoder.atKey "name" JSON.Decoder.text
|
||||
viewportCenter <- JSON.Decoder.atKey "center" ( decodePoint2D decodeDouble )
|
||||
zoomFactor <- JSON.Decoder.atKey "zoom" decodeDouble
|
||||
documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply )
|
||||
viewportCenter <- JSON.Decoder.atKey "center" ( decoder @( Point2D Double ) )
|
||||
zoomFactor <- JSON.Decoder.atKey "zoom" ( decoder @Double )
|
||||
documentUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
|
||||
documentContent <- JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply )
|
||||
pure ( Document { displayName, mbFilePath, viewportCenter, zoomFactor, documentUnique, documentContent } )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Various auxiliary types.
|
||||
|
||||
-- | Existential type over an allowed record field type used in brushes, such as Double and Point2D Double.
|
||||
data SomeFieldSType where
|
||||
SomeFieldSType
|
||||
:: ( STypeI a, Show a, NFData a, Serialisable a, Interpolatable a, Typeable a )
|
||||
=> Proxy# a -> SomeFieldSType
|
||||
|
||||
-- | Existential type for allowed fields of a brush record.
|
||||
data SomeBrushFields where
|
||||
SomeBrushFields
|
||||
:: forall kvs rec
|
||||
. ( STypesI kvs
|
||||
, rec ~ Super.Rec kvs
|
||||
, Show rec, NFData rec
|
||||
, Interpolatable rec
|
||||
, Serialisable rec
|
||||
)
|
||||
=> Proxy# kvs -> SomeBrushFields
|
||||
|
||||
instance Show SomeBrushFields where
|
||||
show ( SomeBrushFields ( _ :: Proxy# kvs ) ) = show ( sTypesI @kvs )
|
||||
|
||||
-- | Auxiliary datatype used to create a proof that record fields have the required instances.
|
||||
data BrushFieldsList kvs where
|
||||
NilFields :: BrushFieldsList '[]
|
||||
ConsFields
|
||||
::
|
||||
( KnownSymbol k
|
||||
, Show a, NFData a, Serialisable a
|
||||
, Interpolatable a
|
||||
, STypesI kvs
|
||||
, KnownNat ( SuperRecord.RecSize kvs )
|
||||
, SuperRecord.Has ( k SuperRecord.:= a ': kvs ) k a
|
||||
)
|
||||
=> Proxy# k -> Proxy# a -> BrushFieldsList kvs -> BrushFieldsList ( k SuperRecord.:= a ': kvs )
|
||||
|
||||
-- | Existential type used in the process of proving that record fields have the required instances.
|
||||
data SomeBrushFieldsList where
|
||||
SomeBrushFieldsList
|
||||
:: ( STypesI kvs
|
||||
, KnownNat ( SuperRecord.RecSize kvs )
|
||||
, KnownNat ( SuperRecord.RecSize ( MapDiff kvs ) )
|
||||
)
|
||||
=> BrushFieldsList kvs -> SomeBrushFieldsList
|
||||
|
||||
-- | Type used to backtrack instance resolution in the SuperRecord library,
|
||||
-- to witness the required typeclass instances by induction on the record fields.
|
||||
data SomeClassyBrushFieldsList rts lts where
|
||||
SomeClassyBrushFieldsList
|
||||
:: forall rts lts drts dlts
|
||||
. ( drts ~ MapDiff rts
|
||||
, dlts ~ MapDiff lts
|
||||
, KnownNat ( SuperRecord.RecSize rts )
|
||||
, KnownNat ( SuperRecord.RecSize drts )
|
||||
, SuperRecord.UnsafeRecBuild rts lts ( ConstC Serialisable )
|
||||
, SuperRecord.UnsafeRecBuild drts dlts ( ConstC ( Module Double ) )
|
||||
, SuperRecord.UnsafeRecBuild drts dlts ( ConstC Monoid )
|
||||
, SuperRecord.RecApply rts lts ( ConstC Show )
|
||||
, SuperRecord.RecApply rts lts ( ConstC NFData )
|
||||
, SuperRecord.RecApply rts lts ( ConstC Serialisable )
|
||||
, SuperRecord.RecApply drts dlts ( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has drts ) )
|
||||
, SuperRecord.RecApply drts dlts ( Tuple22C ( ConstC Semigroup ) ( SuperRecord.Has drts ) )
|
||||
, SuperRecord.RecApply drts dlts ( Tuple22C ( ConstC Group ) ( SuperRecord.Has drts ) )
|
||||
, SuperRecord.RecApply drts dlts ( HasDiff' rts )
|
||||
, SuperRecord.TraversalCHelper dlts rts drts ( HasTorsor rts )
|
||||
)
|
||||
=> Proxy# rts -> Proxy# lts -> SomeClassyBrushFieldsList rts lts
|
||||
|
||||
proveAdapted
|
||||
:: forall brushFields givenFields usedFields
|
||||
. ( STypesI brushFields, STypesI givenFields, STypesI usedFields )
|
||||
=> Maybe ( Dict ( Adapted brushFields givenFields usedFields ) )
|
||||
proveAdapted
|
||||
| Just Dict <- proveUnsafeRecBuild @usedFields
|
||||
, Just Dict <- proveRecApply @brushFields ( size @usedFields )
|
||||
, Refl <- ( unsafeCoerce Refl :: usedFields :~: ( brushFields `SuperRecord.Intersect` givenFields ) )
|
||||
= Just Dict
|
||||
| otherwise
|
||||
= Nothing
|
||||
where
|
||||
-- Provide evidence that each field of "used" appears in "given".
|
||||
proveUnsafeRecBuild
|
||||
:: forall lts_used
|
||||
. ( STypesI lts_used )
|
||||
=> Maybe ( Dict ( SuperRecord.UnsafeRecBuild usedFields lts_used ( SuperRecord.Has givenFields ) ) )
|
||||
proveUnsafeRecBuild = case sTypesI @lts_used of
|
||||
STyNil -> Just Dict
|
||||
sTyCons@STyCons
|
||||
| ( _ :: STypes ( k SuperRecord.:= v ': tail_lts_used ) ) <- sTyCons
|
||||
, SomeIndex ( _ :: Proxy# i ) <- lookupIndex @k @v @givenFields
|
||||
, Just Dict <- proveUnsafeRecBuild @tail_lts_used
|
||||
-> Just Dict
|
||||
| otherwise
|
||||
-> Nothing
|
||||
|
||||
-- Provide evidence whether each field of "brush" appears in "used" or not.
|
||||
-- Additionally checks that "used" is a subset of "brush".
|
||||
proveRecApply
|
||||
:: forall lts_brush
|
||||
. ( STypesI lts_brush )
|
||||
=> Int
|
||||
-> Maybe ( Dict ( SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField lts_brush ) ( UseFieldsInBrush usedFields ) ) )
|
||||
proveRecApply nbUnseen = case sTypesI @lts_brush of
|
||||
STyNil -> if nbUnseen < 1 then Just Dict else Nothing
|
||||
sTyCons@STyCons
|
||||
| ( _ :: STypes ( k SuperRecord.:= v ': tail_lts_brush ) ) <- sTyCons
|
||||
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize ( MapFields UniqueField brushFields ) :~: SuperRecord.RecSize brushFields )
|
||||
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k ( MapFields UniqueField brushFields ) :~: SuperRecord.RecSize tail_lts_brush )
|
||||
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k ( MapFields UniqueField brushFields ) :~: Just ( UniqueField v ) )
|
||||
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k ( MapFields UniqueField tail_lts_brush ) :~: MapFields UniqueField tail_lts_brush )
|
||||
-> case lookupIndex @k @v @usedFields of
|
||||
SomeIndex ( _ :: Proxy# i ) ->
|
||||
case proveRecApply @tail_lts_brush ( nbUnseen - 1 ) of
|
||||
Just Dict -> Just Dict
|
||||
Nothing -> Nothing
|
||||
NoIndex ->
|
||||
case proveRecApply @tail_lts_brush nbUnseen of
|
||||
Just Dict -> Just Dict
|
||||
Nothing -> Nothing
|
||||
|
||||
data LookupResult k v kvs where
|
||||
NoIndex
|
||||
:: forall k v kvs
|
||||
. ( SuperRecord.RecTy k kvs ~ Nothing )
|
||||
=> LookupResult k v kvs
|
||||
SomeIndex
|
||||
:: forall k v kvs i
|
||||
. ( SuperRecord.RecTy k kvs ~ Just v
|
||||
, SuperRecord.RecVecIdxPos k kvs ~ i
|
||||
, KnownNat i
|
||||
)
|
||||
=> Proxy# i -> LookupResult k v kvs
|
||||
|
||||
lookupIndex
|
||||
:: forall k v kvs
|
||||
. ( STypesI kvs, KnownSymbol k, STypeI v )
|
||||
=> LookupResult k v kvs
|
||||
lookupIndex = case sTypesI @kvs of
|
||||
STyNil -> NoIndex
|
||||
sTyCons@STyCons
|
||||
| ( _ :: STypes ( ( l SuperRecord.:= w ) ': tail_kvs ) ) <- sTyCons
|
||||
-> case sameSymbol ( Proxy :: Proxy k ) ( Proxy :: Proxy l ) of
|
||||
Just Refl
|
||||
| Just Refl <- eqTy @v @w
|
||||
, ( index_proxy :: Proxy# i ) <- ( proxy# :: Proxy# ( SuperRecord.RecSize tail_kvs ) )
|
||||
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k kvs :~: i )
|
||||
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k kvs :~: Just v )
|
||||
-> SomeIndex index_proxy
|
||||
_ -> case lookupIndex @k @v @tail_kvs of
|
||||
NoIndex
|
||||
| Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k kvs :~: Nothing )
|
||||
-> NoIndex
|
||||
SomeIndex ( px_j :: Proxy# j )
|
||||
| Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k kvs :~: Just v )
|
||||
, Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k kvs :~: j )
|
||||
-> SomeIndex px_j
|
||||
|
||||
size :: forall kvs. STypesI kvs => Int
|
||||
size = case sTypesI @kvs of
|
||||
STyNil -> 0
|
||||
sTyCons@STyCons
|
||||
| ( _ :: STypes ( head_kvs ': tail_kvs ) ) <- sTyCons
|
||||
-> 1 + size @tail_kvs
|
||||
|
||||
data Dict c where
|
||||
Dict :: c => Dict c
|
||||
|
||||
type family FromJust ( x :: Maybe a ) where
|
||||
FromJust ( Just a ) = a
|
15
src/app/MetaBrush/Document/Serialise.hs-boot
Normal file
15
src/app/MetaBrush/Document/Serialise.hs-boot
Normal 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
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -109,7 +109,7 @@ handleMouseButtonRelease elts vars eventOrigin mouseReleaseEvent = do
|
|||
|
||||
adjustMousePosition :: Viewport -> ActionOrigin -> Point2D Double -> IO ( Point2D Double )
|
||||
adjustMousePosition _ ViewportOrigin pt = pure pt
|
||||
adjustMousePosition ( Viewport { .. } ) ( RulerOrigin ruler ) ( Point2D x y ) =
|
||||
adjustMousePosition ( Viewport {..} ) ( RulerOrigin ruler ) ( Point2D x y ) =
|
||||
case ruler of
|
||||
RulerCorner -> do
|
||||
dx <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth rulerCornerDrawingArea
|
||||
|
|
625
src/app/MetaBrush/MetaParameter/AST.hs
Normal file
625
src/app/MetaBrush/MetaParameter/AST.hs
Normal file
|
@ -0,0 +1,625 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE EmptyCase #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE QuantifiedConstraints #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilyDependencies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
|
||||
|
||||
module MetaBrush.MetaParameter.AST
|
||||
( Span(..), Located(.., Location)
|
||||
, Term(..), Pat(..), Decl(..)
|
||||
, toTreeArgsTerm, toTreeTerm, toTreePat, toTreeDecl
|
||||
, termSpan
|
||||
, TypedTerm(..), TypedPat(..)
|
||||
, SType(..), STypeI(..), SomeSType(..)
|
||||
, STypes(..), STypesI(..), someSTypes
|
||||
, eqSTy, eqTy, eqSTys, eqTys
|
||||
, Pass(..), Name, UniqueName(..), Loc
|
||||
, Ext_With(..), X_With(..)
|
||||
, MapFields, IsUniqueTerm, IsUniqueTerm2, UseFieldsInBrush
|
||||
, UniqueField(..), GetUniqueField, UniqueTerm, GetUniqueTerm
|
||||
, Adapted, AdaptableFunction(..), BrushFunction
|
||||
, X_Ext(..)
|
||||
, Expr, EPat, RnExpr, RnPat
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Functor.Compose
|
||||
( Compose(..) )
|
||||
import Data.Functor.Identity
|
||||
( Identity(..) )
|
||||
import Data.Kind
|
||||
( Type, Constraint )
|
||||
import Data.Proxy
|
||||
( Proxy(..) )
|
||||
import Data.Type.Equality
|
||||
( (:~:)(Refl) )
|
||||
import GHC.Exts
|
||||
( Proxy#, proxy# )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
import GHC.TypeLits
|
||||
( Symbol, KnownSymbol, symbolVal', sameSymbol )
|
||||
import GHC.TypeNats
|
||||
( KnownNat )
|
||||
|
||||
-- containers
|
||||
import Data.Tree
|
||||
( Tree(Node) )
|
||||
|
||||
-- deepseq
|
||||
import Control.DeepSeq
|
||||
( NFData(..) )
|
||||
|
||||
-- superrecord
|
||||
import qualified SuperRecord as Super
|
||||
( Rec )
|
||||
import qualified SuperRecord
|
||||
( (:=), RecApply, UnsafeRecBuild, Has, TraversalC
|
||||
, Intersect, Lookup, RecTy, RecSize, reflectRec
|
||||
)
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
import qualified Data.Text as Text
|
||||
( pack )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Vector2D
|
||||
( Point2D(..), Segment(..) )
|
||||
import qualified Math.Bezier.Cubic as Cubic
|
||||
( Bezier(..) )
|
||||
import qualified Math.Bezier.Quadratic as Quadratic
|
||||
( Bezier(..) )
|
||||
import Math.Bezier.Spline
|
||||
( Spline(..), SplinePts, SplineType(..)
|
||||
, SSplineType(..), SplineTypeI(ssplineType), KnownSplineType(bifoldSpline)
|
||||
, Curve(..), NextPoint(..)
|
||||
)
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
---------------------
|
||||
-- Source locations.
|
||||
|
||||
data Span = Span
|
||||
{ startRow :: !Int
|
||||
, startCol :: !Int
|
||||
, endRow :: !Int
|
||||
, endCol :: !Int
|
||||
} deriving stock ( Eq, Ord )
|
||||
instance Show Span where
|
||||
show ( Span sr sc er ec ) =
|
||||
"l" <> show sr <> "c" <> show sc <> " -- " <> "l" <> show er <> "c" <> show ec
|
||||
instance Semigroup Span where
|
||||
Span 0 0 0 0 <> s = s
|
||||
s <> Span 0 0 0 0 = s
|
||||
Span sr1 sc1 er1 ec1 <> Span sr2 sc2 er2 ec2
|
||||
= case ( compare ( sr1, sc1 ) ( sr2, sc2 ), compare ( er1, ec1 ) ( er2, ec2 ) ) of
|
||||
( LT, LT ) -> Span sr1 sc1 er2 ec2
|
||||
( LT, _ ) -> Span sr1 sc1 er1 ec1
|
||||
( _ , LT ) -> Span sr2 sc2 er2 ec2
|
||||
_ -> Span sr2 sc2 er1 ec1
|
||||
instance Monoid Span where
|
||||
mempty = Span 0 0 0 0
|
||||
|
||||
data Located a =
|
||||
Located
|
||||
{ location :: !Span
|
||||
, located :: !a
|
||||
}
|
||||
deriving stock Show
|
||||
|
||||
{-# COMPLETE Location #-}
|
||||
pattern Location :: Span -> Located ()
|
||||
pattern Location loc = Located loc ()
|
||||
|
||||
----------
|
||||
-- Types.
|
||||
|
||||
data SType ( ty :: Type ) where
|
||||
SFunTy :: ( STypeI a, STypeI b ) => SType ( a -> b )
|
||||
STyBool :: SType Bool
|
||||
STyDouble :: SType Double
|
||||
STyPoint :: STypeI a => SType ( Point2D a )
|
||||
STyLine :: STypeI a => SType ( Segment a )
|
||||
STyBez2 :: STypeI a => SType ( Quadratic.Bezier a )
|
||||
STyBez3 :: STypeI a => SType ( Cubic.Bezier a )
|
||||
STySpline :: KnownSplineType clo => SType ( SplinePts clo )
|
||||
STyWithFn :: ( STypesI kvs, STypeI a ) => SType ( AdaptableFunction kvs a )
|
||||
-- reminder: update eqSTy when adding new constructors
|
||||
|
||||
deriving stock instance Show ( SType ty )
|
||||
|
||||
class STypeI ty where
|
||||
sTypeI :: SType ty
|
||||
instance ( STypeI a, STypeI b ) => STypeI ( a -> b ) where
|
||||
sTypeI = SFunTy
|
||||
instance STypeI Bool where
|
||||
sTypeI = STyBool
|
||||
instance STypeI Double where
|
||||
sTypeI = STyDouble
|
||||
instance STypeI a => STypeI ( Point2D a ) where
|
||||
sTypeI = STyPoint
|
||||
instance STypeI a => STypeI ( Segment a ) where
|
||||
sTypeI = STyLine
|
||||
instance STypeI a => STypeI ( Quadratic.Bezier a ) where
|
||||
sTypeI = STyBez2
|
||||
instance STypeI a => STypeI ( Cubic.Bezier a ) where
|
||||
sTypeI = STyBez3
|
||||
instance KnownSplineType clo => STypeI ( SplinePts clo ) where
|
||||
sTypeI = STySpline
|
||||
instance ( STypesI kvs, STypeI a ) => STypeI ( AdaptableFunction kvs a ) where
|
||||
sTypeI = STyWithFn
|
||||
|
||||
data STypes ( kvs :: [ Type ] ) where
|
||||
STyNil :: STypes '[]
|
||||
STyCons :: ( kv ~ ( k SuperRecord.:= v ), KnownSymbol k, STypeI v, STypesI kvs ) => STypes ( kv ': kvs )
|
||||
deriving stock instance Show ( STypes kvs )
|
||||
|
||||
class KnownNat ( SuperRecord.RecSize kvs ) => STypesI kvs where
|
||||
sTypesI :: STypes kvs
|
||||
|
||||
instance STypesI '[] where
|
||||
sTypesI = STyNil
|
||||
-- Warning: this instance is somewhat overly general as it doesn't check that the names are ordered.
|
||||
instance ( kv ~ ( k SuperRecord.:= v ), KnownSymbol k, STypeI v, STypesI kvs ) => STypesI ( kv ': kvs ) where
|
||||
sTypesI = STyCons
|
||||
|
||||
data SomeSType where
|
||||
SomeSType :: STypeI a => Proxy# a -> SomeSType
|
||||
|
||||
instance Show SomeSType where
|
||||
show ( SomeSType ( _ :: Proxy# a ) ) = show ( sTypeI @a )
|
||||
|
||||
eqSTy :: SType a -> SType b -> Maybe ( a :~: b )
|
||||
eqSTy sTy_a@SFunTy sTy_b@SFunTy
|
||||
| ( _ :: SType ( a1 -> b1 ) ) <- sTy_a
|
||||
, ( _ :: SType ( a2 -> b2 ) ) <- sTy_b
|
||||
, Just Refl <- eqTy @a1 @a2
|
||||
, Just Refl <- eqTy @b1 @b2
|
||||
= Just Refl
|
||||
eqSTy STyBool STyBool = Just Refl
|
||||
eqSTy STyDouble STyDouble = Just Refl
|
||||
eqSTy sTy_a@STyPoint sTy_b@STyPoint
|
||||
| ( _ :: SType ( Point2D l ) ) <- sTy_a
|
||||
, ( _ :: SType ( Point2D r ) ) <- sTy_b
|
||||
, Just Refl <- eqTy @l @r
|
||||
= Just Refl
|
||||
eqSTy sTy_a@STyLine sTy_b@STyLine
|
||||
| ( _ :: SType ( Segment l ) ) <- sTy_a
|
||||
, ( _ :: SType ( Segment r ) ) <- sTy_b
|
||||
, Just Refl <- eqTy @l @r
|
||||
= Just Refl
|
||||
eqSTy sTy_a@STyBez2 sTy_b@STyBez2
|
||||
| ( _ :: SType ( Quadratic.Bezier l ) ) <- sTy_a
|
||||
, ( _ :: SType ( Quadratic.Bezier r ) ) <- sTy_b
|
||||
, Just Refl <- eqTy @l @r
|
||||
= Just Refl
|
||||
eqSTy sTy_a@STyBez3 sTy_b@STyBez3
|
||||
| ( _ :: SType ( Cubic.Bezier l ) ) <- sTy_a
|
||||
, ( _ :: SType ( Cubic.Bezier r ) ) <- sTy_b
|
||||
, Just Refl <- eqTy @l @r
|
||||
= Just Refl
|
||||
eqSTy sTy_a@STySpline sTy_b@STySpline
|
||||
| ( _ :: SType ( SplinePts clo1 ) ) <- sTy_a
|
||||
, ( _ :: SType ( SplinePts clo2 ) ) <- sTy_b
|
||||
= case ( ssplineType @clo1, ssplineType @clo2 ) of
|
||||
( SOpen , SOpen ) -> Just Refl
|
||||
( SClosed, SClosed ) -> Just Refl
|
||||
_ -> Nothing
|
||||
eqSTy sTy_a@STyWithFn sTy_b@STyWithFn
|
||||
| ( _ :: SType ( AdaptableFunction kvs a ) ) <- sTy_a
|
||||
, ( _ :: SType ( AdaptableFunction lvs b ) ) <- sTy_b
|
||||
, Just Refl <- eqTys @kvs @lvs
|
||||
, Just Refl <- eqTy @a @b
|
||||
= Just Refl
|
||||
eqSTy _ _ = Nothing
|
||||
|
||||
eqTy :: forall a b. ( STypeI a, STypeI b ) => Maybe ( a :~: b )
|
||||
eqTy = eqSTy ( sTypeI @a ) ( sTypeI @b )
|
||||
|
||||
eqSTys :: STypes as -> STypes bs -> Maybe ( as :~: bs )
|
||||
eqSTys STyNil STyNil = Just Refl
|
||||
eqSTys sTyCons1@STyCons sTyCons2@STyCons
|
||||
| ( _ :: STypes ( ( l1 SuperRecord.:= v1 ) ': as' ) ) <- sTyCons1
|
||||
, ( _ :: STypes ( ( l2 SuperRecord.:= v2 ) ': bs' ) ) <- sTyCons2
|
||||
, Just Refl <- sameSymbol ( Proxy :: Proxy l1 ) ( Proxy :: Proxy l2 )
|
||||
, Just Refl <- eqTy @v1 @v2
|
||||
, Just Refl <- eqTys @as' @bs'
|
||||
= Just Refl
|
||||
eqSTys _ _ = Nothing
|
||||
|
||||
eqTys :: forall as bs. ( STypesI as, STypesI bs ) => Maybe ( as :~: bs )
|
||||
eqTys = eqSTys ( sTypesI @as ) ( sTypesI @bs )
|
||||
|
||||
someSTypes :: forall kvs. STypesI kvs => [ ( Text, SomeSType ) ]
|
||||
someSTypes = go ( sTypesI @kvs )
|
||||
where
|
||||
go :: forall lvs. STypes lvs -> [ ( Text, SomeSType ) ]
|
||||
go STyNil = []
|
||||
go sTyCons@STyCons
|
||||
| ( _ :: STypes ( ( l SuperRecord.:= v ) ': lvs' ) ) <- sTyCons
|
||||
= ( Text.pack $ symbolVal' ( proxy# :: Proxy# l ), SomeSType ( proxy# :: Proxy# v ) )
|
||||
: go ( sTypesI @lvs' )
|
||||
|
||||
------------------------------------------------
|
||||
-- AST. --
|
||||
----------
|
||||
|
||||
data Pass = P | Rn | Tc
|
||||
deriving stock Show
|
||||
|
||||
type family K ( p :: Pass ) :: Type where
|
||||
K P = ()
|
||||
K Rn = ()
|
||||
K Tc = Type
|
||||
|
||||
type family Ks ( p :: Pass ) :: Type where
|
||||
Ks P = ()
|
||||
Ks Rn = ()
|
||||
Ks Tc = [Type]
|
||||
|
||||
type family T ( p :: Pass ) ( t :: Type ) :: K p where
|
||||
T P _ = '()
|
||||
T Rn _ = '()
|
||||
T Tc a = a
|
||||
|
||||
type family Ts ( p :: Pass ) ( as :: [ Type ] ) :: Ks p where
|
||||
Ts P _ = '()
|
||||
Ts Rn _ = '()
|
||||
Ts Tc '[] = '[]
|
||||
Ts Tc ( a ': as ) = T Tc a ': Ts Tc as
|
||||
|
||||
type family R ( p :: Pass ) ( kvs :: [ Type ] ) :: Ks p where
|
||||
R P _ = '()
|
||||
R Rn _ = '()
|
||||
R Tc kvs = kvs
|
||||
|
||||
type family C ( p :: Pass ) ( ct :: Constraint ) :: Constraint where
|
||||
C P _ = ()
|
||||
C Rn _ = ()
|
||||
C Tc ct = ct
|
||||
|
||||
-- C p ct: constraint for which evidence is generated at Tc stage
|
||||
-- ct: constraint for which evidence is provided from the start
|
||||
|
||||
infixl 9 :$
|
||||
data Term ( p :: Pass ) ( kind :: K p ) where
|
||||
(:$) :: C p ( STypeI a )
|
||||
=> Term p ( T p ( a -> b ) )
|
||||
-> Term p ( T p a )
|
||||
-> Term p ( T p b )
|
||||
Var :: { varName :: !( Loc p ( Name p ) ) }
|
||||
-> Term p ( T p a )
|
||||
Let :: { let_loc :: ![ Loc p () ]
|
||||
, let_decls :: ![ Decl p ]
|
||||
, let_body :: !( Term p ( T p a ) )
|
||||
}
|
||||
-> Term p ( T p a )
|
||||
With :: forall ( p :: Pass ) ( kvs :: [ Type ] ) ( a :: Type )
|
||||
. C p ( STypeI a )
|
||||
=> ![ Loc p () ]
|
||||
-> !( X_With p ( R p kvs ) )
|
||||
-> ![ Term p ( T p Bool ) ]
|
||||
-> !( Term p ( T p a ) )
|
||||
-> Term p ( T p ( AdaptableFunction kvs a ) )
|
||||
Lit :: ( Show a, STypeI a )
|
||||
=> !( Loc p ( Maybe Text ) )
|
||||
-> !a
|
||||
-> Term p ( T p a )
|
||||
Op :: STypeI a
|
||||
=> ![ Loc p () ] -> !Text -> a -> Term p ( T p a )
|
||||
Point :: ( C p ( STypeI a ), pt ~ Term p ( T p ( Point2D a ) ) )
|
||||
=> ![ Loc p () ]
|
||||
-> !( Term p ( T p a ) ) -> !( Term p ( T p a ) )
|
||||
-> Term p ( T p ( Point2D a ) )
|
||||
Line :: ( C p ( STypeI a ), pt ~ Term p ( T p a ) )
|
||||
=> ![ Loc p () ]
|
||||
-> !pt -> !pt
|
||||
-> Term p ( T p ( Segment a ) )
|
||||
Bez2 :: ( C p ( STypeI a ), pt ~ Term p ( T p a ) )
|
||||
=> ![ Loc p () ]
|
||||
-> !pt -> !pt -> !pt
|
||||
-> Term p ( T p ( Quadratic.Bezier a ) )
|
||||
Bez3 :: ( C p ( STypeI a ), pt ~ Term p ( T p a ) )
|
||||
=> ![ Loc p () ]
|
||||
-> !pt -> !pt -> !pt -> !pt
|
||||
-> Term p ( T p ( Cubic.Bezier a ) )
|
||||
PolyBez
|
||||
:: ( KnownSplineType clo, C p ( STypeI a ) )
|
||||
=> ![ Loc p () ]
|
||||
-> Spline clo [ Loc p () ] ( Term p ( T p a ) )
|
||||
-> Term p ( T p ( Spline clo () a ) )
|
||||
CExt :: !( X_Ext p ( T p a ) ) -> Term p ( T p a )
|
||||
|
||||
data Decl ( p :: Pass ) where
|
||||
Decl :: C p ( STypeI a )
|
||||
=> !( Loc p () )
|
||||
-> !( Pat p ( T p a ) ) -> !( Term p ( T p a ) )
|
||||
-> Decl p
|
||||
|
||||
data Pat ( p :: Pass ) ( kind :: K p ) where
|
||||
PName :: { patName :: !( Loc p ( Name p ) ) }
|
||||
-> Pat p ( T p a )
|
||||
PPoint :: ![ Loc p () ]
|
||||
-> !( Pat p ( T p a ) )
|
||||
-> !( Pat p ( T p a ) )
|
||||
-> Pat p ( T p ( Point2D a ) )
|
||||
PWild :: { wildName :: !( Loc p Text ) }
|
||||
-> Pat p ( T p a )
|
||||
AsPat :: { atSymbol :: !( Loc p () )
|
||||
, asPatName :: !( Loc p ( Name p ) )
|
||||
, asPat :: !( Pat p ( T p a ) )
|
||||
}
|
||||
-> Pat p ( T p a )
|
||||
|
||||
type Expr = Term P '()
|
||||
type EPat = Pat P '()
|
||||
|
||||
type RnExpr = Term Rn '()
|
||||
type RnPat = Pat Rn '()
|
||||
|
||||
data TypedTerm where
|
||||
TypedTerm :: STypeI a => Term Tc a -> TypedTerm
|
||||
|
||||
data TypedPat where
|
||||
TypedPat :: STypeI a => Pat Tc a -> TypedPat
|
||||
|
||||
---------------------
|
||||
-- Extension fields
|
||||
|
||||
data UniqueName
|
||||
= UniqueName
|
||||
{ occName :: !Text
|
||||
, nameUnique :: !Unique
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
|
||||
type family Name ( p :: Pass ) :: Type
|
||||
type instance Name P = Text
|
||||
type instance Name Rn = UniqueName
|
||||
type instance Name Tc = UniqueName
|
||||
|
||||
type family Loc ( p :: Pass ) ( a :: Type ) :: Type
|
||||
type instance Loc p a = Located a
|
||||
|
||||
class Ext_With ( p :: Pass ) ( kvs :: Ks p ) where
|
||||
data family X_With p kvs :: Type
|
||||
toTreeWith :: forall ( lvs :: Ks p ). Ext_With p lvs => X_With p kvs -> [ Tree String ]
|
||||
|
||||
instance Ext_With P kvs where
|
||||
newtype X_With P _ = P_With [ Decl P ]
|
||||
toTreeWith ( P_With decls ) = map toTreeDecl decls
|
||||
|
||||
instance Ext_With Rn kvs where
|
||||
newtype X_With Rn _ = Rn_With [ Decl Rn ]
|
||||
toTreeWith ( Rn_With decls ) = map toTreeDecl decls
|
||||
|
||||
|
||||
instance Ext_With Tc kvs where
|
||||
data X_With Tc kvs where
|
||||
Tc_With
|
||||
:: ( ts ~ MapFields UniqueTerm kvs
|
||||
, fs ~ MapFields UniqueField kvs
|
||||
, SuperRecord.RecApply ts ts IsUniqueTerm
|
||||
, SuperRecord.TraversalC IsUniqueTerm2 ts fs
|
||||
)
|
||||
=> Super.Rec ts -> X_With Tc kvs
|
||||
toTreeWith ( Tc_With decls ) =
|
||||
SuperRecord.reflectRec @IsUniqueTerm
|
||||
( \ _ ( Compose ( UniqueField { uniqueField = a } ) ) -> toTreeTerm @Tc a )
|
||||
decls
|
||||
|
||||
data UniqueField a =
|
||||
UniqueField { uniqueFieldName :: !UniqueName, uniqueField :: !a }
|
||||
|
||||
type UniqueTerm = Compose UniqueField ( Term Tc )
|
||||
|
||||
type family MapFields ( f :: Type -> Type ) ( kvs :: [ Type ] ) = ( r :: [ Type ] ) | r -> kvs where
|
||||
MapFields _ '[] = '[]
|
||||
MapFields f ( ( k SuperRecord.:= v ) ': kvs ) = ( k SuperRecord.:= f v ) ': MapFields f kvs
|
||||
|
||||
|
||||
type family GetUniqueField ( uniqueField :: Type ) :: Type where
|
||||
GetUniqueField ( UniqueField a ) = a
|
||||
type family GetUniqueTerm ( uniqueTerm :: Type ) :: Type where
|
||||
GetUniqueTerm ( Compose UniqueField ( Term Tc ) a ) = a
|
||||
|
||||
class ( STypeI ( GetUniqueTerm t )
|
||||
, t ~ UniqueTerm ( GetUniqueTerm t )
|
||||
)
|
||||
=> IsUniqueTerm ( k :: Symbol ) t
|
||||
where
|
||||
instance ( STypeI ( GetUniqueTerm t )
|
||||
, t ~ UniqueTerm ( GetUniqueTerm t )
|
||||
)
|
||||
=> IsUniqueTerm ( k :: Symbol ) t
|
||||
where
|
||||
|
||||
class ( IsUniqueTerm k t
|
||||
, a ~ UniqueField ( GetUniqueField a )
|
||||
, GetUniqueTerm t ~ GetUniqueField a
|
||||
)
|
||||
=> IsUniqueTerm2 k t a
|
||||
where
|
||||
instance ( IsUniqueTerm k t
|
||||
, a ~ UniqueField ( GetUniqueField a )
|
||||
, GetUniqueTerm t ~ GetUniqueField a
|
||||
)
|
||||
=> IsUniqueTerm2 k t a
|
||||
where
|
||||
|
||||
class ( STypeI ( GetUniqueField t )
|
||||
, t ~ UniqueField ( GetUniqueField t )
|
||||
, SuperRecord.Lookup kvs k ( GetUniqueField t )
|
||||
( SuperRecord.RecTy k kvs )
|
||||
)
|
||||
=> UseFieldsInBrush ( kvs :: [ Type ] ) ( k :: Symbol ) t
|
||||
instance ( STypeI ( GetUniqueField t )
|
||||
, t ~ UniqueField ( GetUniqueField t )
|
||||
, SuperRecord.Lookup kvs k ( GetUniqueField t )
|
||||
( SuperRecord.RecTy k kvs )
|
||||
)
|
||||
=> UseFieldsInBrush ( kvs :: [ Type ] ) ( k :: Symbol ) t
|
||||
|
||||
class ( usedFields ~ ( brushFields `SuperRecord.Intersect` givenFields )
|
||||
, SuperRecord.UnsafeRecBuild usedFields usedFields ( SuperRecord.Has givenFields )
|
||||
, SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField brushFields )
|
||||
( UseFieldsInBrush usedFields )
|
||||
)
|
||||
=> Adapted brushFields givenFields usedFields | givenFields brushFields -> usedFields
|
||||
instance ( usedFields ~ ( brushFields `SuperRecord.Intersect` givenFields )
|
||||
, SuperRecord.UnsafeRecBuild usedFields usedFields ( SuperRecord.Has givenFields )
|
||||
, SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField brushFields )
|
||||
( UseFieldsInBrush usedFields )
|
||||
)
|
||||
=> Adapted brushFields givenFields usedFields
|
||||
|
||||
type BrushFunction brushFields = AdaptableFunction brushFields ( SplinePts Closed )
|
||||
newtype AdaptableFunction brushFields a
|
||||
= AdaptableFunction
|
||||
( forall givenFields usedFields
|
||||
. Adapted brushFields givenFields usedFields
|
||||
=> ( Super.Rec givenFields -> Super.Rec usedFields
|
||||
, Super.Rec usedFields -> a
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
class Ext ( p :: Pass ) ( a :: K p ) where
|
||||
data family X_Ext ( p :: Pass ) a :: Type
|
||||
toTreeArgsExt :: [ Tree String ] -> X_Ext p a -> Tree String
|
||||
|
||||
instance Ext P a where
|
||||
data instance X_Ext P a
|
||||
toTreeArgsExt _ x = case x of {}
|
||||
|
||||
instance Ext Rn a where
|
||||
data instance X_Ext Rn a
|
||||
toTreeArgsExt _ x = case x of {}
|
||||
|
||||
instance Ext Tc a where
|
||||
newtype instance X_Ext Tc a = Val a
|
||||
deriving stock ( Generic, Show )
|
||||
deriving newtype NFData
|
||||
toTreeArgsExt as ( Val _ ) = Node "Value..." as
|
||||
|
||||
|
||||
------------------------------------------------
|
||||
-- Printing AST. --
|
||||
-------------------
|
||||
|
||||
termSpan :: Term p a -> Span
|
||||
termSpan ( f :$ a ) = termSpan f <> termSpan a
|
||||
termSpan ( Var ( Located l _ ) ) = l
|
||||
termSpan ( Let locs _ body ) = foldMap ( \ ( Located l _ ) -> l ) locs <> termSpan body
|
||||
termSpan ( With locs _ _ body ) = foldMap ( \ ( Located l _ ) -> l ) locs <> termSpan body
|
||||
termSpan ( Lit ( Located l _ ) _ ) = l
|
||||
termSpan ( Op locs _ _ ) = foldMap ( \ ( Located l _ ) -> l ) locs
|
||||
termSpan ( Point locs x y ) = foldMap ( \ ( Located l _ ) -> l ) locs <> termSpan x <> termSpan y
|
||||
termSpan ( Line locs _ _ ) = foldMap ( \ ( Located l _ ) -> l ) locs
|
||||
termSpan ( Bez2 locs _ _ _ ) = foldMap ( \ ( Located l _ ) -> l ) locs
|
||||
termSpan ( Bez3 locs _ _ _ _ ) = foldMap ( \ ( Located l _ ) -> l ) locs
|
||||
termSpan ( PolyBez locs _ ) = foldMap ( \ ( Located l _ ) -> l ) locs
|
||||
termSpan ( CExt _ ) = mempty
|
||||
|
||||
|
||||
toTreeTerm
|
||||
:: forall ( p :: Pass ) ( a :: K p )
|
||||
. ( Show ( Name p ), forall x. Ext p x, forall kvs. Ext_With p kvs )
|
||||
=> Term p a
|
||||
-> Tree String
|
||||
toTreeTerm = toTreeArgsTerm @p @a []
|
||||
|
||||
toTreeArgsTerm
|
||||
:: forall ( p :: Pass ) ( a :: K p )
|
||||
. ( Show ( Name p ), forall x. Ext p x, forall (kvs :: Ks p). Ext_With p kvs )
|
||||
=> [ Tree String ]
|
||||
-> Term p a
|
||||
-> Tree String
|
||||
toTreeArgsTerm as ( f :$ a ) = toTreeArgsTerm ( toTreeTerm a : as ) f
|
||||
toTreeArgsTerm as ( Op _ nm _ ) = Node ( "Op " <> show nm ) as
|
||||
toTreeArgsTerm as ( Var nm ) = Node ( "Var " <> show nm ) as
|
||||
toTreeArgsTerm as ( Lit loc a ) =
|
||||
case loc of
|
||||
Located l Nothing -> Node ( "Lit " <> show ( Located l a ) ) as
|
||||
Located l ( Just nm ) -> Node ( "Lit " <> show ( Located l nm ) ) as
|
||||
toTreeArgsTerm as ( Point _ p1 p2 ) = Node "(,)" ( toTreeTerm p1 : toTreeTerm p2 : as )
|
||||
toTreeArgsTerm as ( Line _ p0 p1 ) = Node "Line" ( toTreeTerm p0 : toTreeTerm p1 : as )
|
||||
toTreeArgsTerm as ( Bez2 _ p0 p1 p2 ) = Node "Bez2" ( toTreeTerm p0 : toTreeTerm p1 : toTreeTerm p2 : as )
|
||||
toTreeArgsTerm as ( Bez3 _ p0 p1 p2 p3 ) = Node "Bez3" ( toTreeTerm p0 : toTreeTerm p1 : toTreeTerm p2 : toTreeTerm p3 : as )
|
||||
toTreeArgsTerm as ( PolyBez _ spline ) = Node "Spline"
|
||||
( ( runIdentity
|
||||
$ ( bifoldSpline @_ @Identity @[ Tree String ] @_ )
|
||||
( const ( toTreeCurve @p ) )
|
||||
( Identity . (:[]) . toTreeTerm )
|
||||
spline
|
||||
)
|
||||
<> as
|
||||
)
|
||||
toTreeArgsTerm as ( Let _ ds a ) =
|
||||
Node "Let"
|
||||
( Node "Decls" ( map ( toTreeDecl @p ) ds )
|
||||
: Node "In" [ toTreeTerm a ]
|
||||
: as
|
||||
)
|
||||
toTreeArgsTerm as ( With _ args conds body ) =
|
||||
Node "With"
|
||||
( Node "Params" ( toTreeWith @p args )
|
||||
: Node "Conds" ( map toTreeTerm conds )
|
||||
: Node "Define" [ toTreeTerm body ]
|
||||
: as
|
||||
)
|
||||
toTreeArgsTerm as ( CExt ext ) = toTreeArgsExt as ext
|
||||
|
||||
toTreeDecl
|
||||
:: forall ( p :: Pass )
|
||||
. ( Show ( Name p ), forall x. Ext p x, forall (kvs :: Ks p). Ext_With p kvs )
|
||||
=> Decl p
|
||||
-> Tree String
|
||||
toTreeDecl ( Decl _ lhs rhs ) = Node "(=)" [ toTreePat lhs, toTreeTerm rhs ]
|
||||
|
||||
toTreePat :: Show ( Name p ) => Pat p a -> Tree String
|
||||
toTreePat ( PName nm ) = Node ( show nm ) [ ]
|
||||
toTreePat ( PPoint _ pl pr ) = Node "(_,_)" [ toTreePat pl, toTreePat pr ]
|
||||
toTreePat ( PWild nm ) = Node ( show nm ) [ ]
|
||||
toTreePat ( AsPat _ nm pat ) = Node "(@)" [ Node ( show nm ) [], toTreePat pat ]
|
||||
|
||||
toTreeCurve
|
||||
:: forall ( p :: Pass ) ( clo :: SplineType ) ( crvData :: Type ) ( a :: K p )
|
||||
. ( SplineTypeI clo, Show ( Name p ), forall x. Ext p x, forall (kvs :: Ks p). Ext_With p kvs )
|
||||
=> Curve clo crvData ( Term p a )
|
||||
-> Identity [ Tree String ]
|
||||
toTreeCurve curve = Identity . (:[]) $ case ssplineType @clo of
|
||||
SOpen -> case curve of
|
||||
( LineTo ( NextPoint p1 ) _ ) -> Node "LineTo" [ toTreeTerm p1 ]
|
||||
( Bezier2To p1 ( NextPoint p2 ) _ ) -> Node "Bezier2To" [ toTreeTerm p1, toTreeTerm p2 ]
|
||||
( Bezier3To p1 p2 ( NextPoint p3 ) _ ) -> Node "Bezier3To" [ toTreeTerm p1, toTreeTerm p2, toTreeTerm p3 ]
|
||||
SClosed -> case curve of
|
||||
( LineTo BackToStart _ ) -> Node "LineTo" [ Node "cycle" [] ]
|
||||
( Bezier2To p1 BackToStart _ ) -> Node "Bezier2To" [ toTreeTerm p1, Node "cycle" [] ]
|
||||
( Bezier3To p1 p2 BackToStart _ ) -> Node "Bezier3To" [ toTreeTerm p1, toTreeTerm p2, Node "cycle" [] ]
|
116
src/app/MetaBrush/MetaParameter/Driver.hs
Normal file
116
src/app/MetaBrush/MetaParameter/Driver.hs
Normal file
|
@ -0,0 +1,116 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
module MetaBrush.MetaParameter.Driver where
|
||||
|
||||
-- base
|
||||
import GHC.Exts
|
||||
( Proxy#, proxy# )
|
||||
|
||||
-- dlist
|
||||
import qualified Data.DList as DList
|
||||
( toList )
|
||||
|
||||
-- Earley
|
||||
import qualified Text.Earley as Earley
|
||||
( Report(..), fullParses, parser )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.Trans.Except
|
||||
( runExceptT )
|
||||
import Control.Monad.Trans.Reader
|
||||
( runReaderT )
|
||||
import Control.Monad.Trans.RWS.CPS
|
||||
( runRWST )
|
||||
import Control.Monad.Trans.State.Strict
|
||||
( evalState )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Bezier.Spline
|
||||
( SplinePts, SSplineType(SClosed), SplineTypeI(ssplineType) )
|
||||
import MetaBrush.MetaParameter.AST
|
||||
( Located
|
||||
, Term, TypedTerm(..)
|
||||
, SType(..), STypeI(sTypeI)
|
||||
, SomeSType(..), STypesI
|
||||
, Pass(Tc)
|
||||
, AdaptableFunction(..), BrushFunction
|
||||
)
|
||||
import MetaBrush.MetaParameter.Eval
|
||||
( EvalState(..), eval )
|
||||
import MetaBrush.MetaParameter.Parse
|
||||
( grammar, Token, tokenize )
|
||||
import MetaBrush.MetaParameter.Rename
|
||||
( rename, RnM, RnMessage, RnError, emptyRnState )
|
||||
import MetaBrush.MetaParameter.TypeCheck
|
||||
( typeCheck, TcM, TcMessage, TcError, emptyTcState )
|
||||
import MetaBrush.Unique
|
||||
( UniqueSupply, MonadUnique(freshUnique) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data DriverError
|
||||
= ParseError !( Earley.Report Text [ Located Token ] )
|
||||
| RenameError !RnError
|
||||
| TypeCheckError !TcError
|
||||
| NonBrushType !SomeSType
|
||||
deriving stock Show
|
||||
|
||||
data DriverMessage
|
||||
= RenameMessage !RnMessage
|
||||
| TypeCheckMessage !TcMessage
|
||||
|
||||
data SomeBrushFunction where
|
||||
SomeBrushFunction
|
||||
:: forall brushParams
|
||||
. ( STypesI brushParams )
|
||||
=> BrushFunction brushParams
|
||||
-> SomeBrushFunction
|
||||
|
||||
interpretBrush
|
||||
:: UniqueSupply
|
||||
-> Text
|
||||
-> IO
|
||||
( Either DriverError SomeBrushFunction
|
||||
, [ DriverMessage ]
|
||||
)
|
||||
interpretBrush uniqSupply sourceText = case Earley.fullParses ( Earley.parser grammar ) $ tokenize sourceText of
|
||||
( [], parserReport ) -> pure ( Left ( ParseError parserReport ), [] )
|
||||
( parsedExpr : _, _ ) -> do
|
||||
( renamedExpr, _, rnMessages ) <- runRWST ( rename @RnM parsedExpr ) uniqSupply emptyRnState
|
||||
( tcResult , _, tcMessages ) <- runRWST ( runExceptT $ typeCheck @TcM renamedExpr ) uniqSupply emptyTcState
|
||||
let
|
||||
messages :: [ DriverMessage ]
|
||||
messages = DList.toList ( fmap RenameMessage rnMessages <> fmap TypeCheckMessage tcMessages )
|
||||
case tcResult of
|
||||
Left err -> pure ( Left ( TypeCheckError err ), messages )
|
||||
-- Type checking succeeded: check that the type of the given program
|
||||
-- is indeed a function that takes in a record of parameters and returns
|
||||
-- a closed brush shape.
|
||||
Right ( TypedTerm ( term :: Term Tc v ) )
|
||||
| sTyWithFn@STyWithFn <- sTypeI @v
|
||||
, ( _ :: SType ( AdaptableFunction kvs b ) ) <- sTyWithFn
|
||||
, sTySpline@STySpline <- sTypeI @b
|
||||
, ( _ :: SType ( SplinePts clo ) ) <- sTySpline
|
||||
, SClosed <- ssplineType @clo
|
||||
-> do
|
||||
uniq <- ( `runReaderT` uniqSupply ) freshUnique
|
||||
let
|
||||
initEvalState :: EvalState
|
||||
initEvalState =
|
||||
EvalState { evalHeap = mempty, nextUnique = uniq }
|
||||
val :: BrushFunction kvs
|
||||
val = ( `evalState` initEvalState ) $ eval term
|
||||
pure ( Right ( SomeBrushFunction @kvs val ), messages )
|
||||
| otherwise
|
||||
-> pure ( Left ( NonBrushType ( SomeSType ( proxy# :: Proxy# v ) ) ), messages )
|
234
src/app/MetaBrush/MetaParameter/Eval.hs
Normal file
234
src/app/MetaBrush/MetaParameter/Eval.hs
Normal file
|
@ -0,0 +1,234 @@
|
|||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MagicHash #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module MetaBrush.MetaParameter.Eval
|
||||
( EvalState(..), eval )
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
import Data.Functor.Compose
|
||||
( Compose(..) )
|
||||
import Data.Type.Equality
|
||||
( (:~:)(Refl) )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
|
||||
-- containers
|
||||
import Data.Map
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
( insert, lookup, union, fromList )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
( field' )
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( assign, modifying, use )
|
||||
|
||||
-- mtl
|
||||
import Control.Monad.State
|
||||
( get )
|
||||
|
||||
-- superrecord
|
||||
import qualified SuperRecord as Super
|
||||
( Rec )
|
||||
import qualified SuperRecord
|
||||
( RecApply(..), Lookup(..), Has, UnsafeRecBuild, traverseC, project )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
import qualified Data.Text as Text
|
||||
( pack )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.Trans.State.Strict
|
||||
( State, evalState )
|
||||
|
||||
-- MetaBrush
|
||||
import qualified Math.Bezier.Cubic as Cubic
|
||||
( Bezier(..) )
|
||||
import qualified Math.Bezier.Quadratic as Quadratic
|
||||
( Bezier(..) )
|
||||
import Math.Bezier.Spline
|
||||
( KnownSplineType(bitraverseSpline), bitraverseCurve )
|
||||
import Math.Vector2D
|
||||
( Point2D(..), Segment(..) )
|
||||
import MetaBrush.MetaParameter.AST
|
||||
( Term(..), Pat(..), Decl(..)
|
||||
, TypedTerm(..), STypeI(..), SType(..)
|
||||
, Pass(Tc), X_Ext(..), X_With(..)
|
||||
, Span(..), Located(..)
|
||||
, MapFields, AdaptableFunction(..)
|
||||
, UniqueField(..), UniqueTerm, IsUniqueTerm2, UseFieldsInBrush
|
||||
, eqTy
|
||||
)
|
||||
import MetaBrush.MetaParameter.Rename
|
||||
( UniqueName(..) )
|
||||
import MetaBrush.Unique
|
||||
( Unique )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data EvalState
|
||||
= EvalState
|
||||
{ evalHeap :: !( Map Unique TypedTerm )
|
||||
, nextUnique :: !Unique
|
||||
}
|
||||
deriving stock Generic
|
||||
|
||||
eval :: forall a. STypeI a => Term Tc a -> State EvalState a
|
||||
eval ( f :$ a ) = eval f <*> eval a
|
||||
eval ( Lit _ x ) = pure x
|
||||
eval ( Op _ _ f ) = pure f
|
||||
eval ( Point _ x y ) = Point2D <$> eval x <*> eval y
|
||||
eval ( Line _ p q ) = Segment <$> eval p <*> eval q
|
||||
eval ( Bez2 _ p q r ) = Quadratic.Bezier <$> eval p <*> eval q <*> eval r
|
||||
eval ( Bez3 _ p q r s ) = Cubic.Bezier <$> eval p <*> eval q <*> eval r <*> eval s
|
||||
eval ( PolyBez _ spline ) =
|
||||
bitraverseSpline
|
||||
( const $ bitraverseCurve ( const $ pure () ) ( const eval ) )
|
||||
eval
|
||||
spline
|
||||
eval ( Let _ decls a ) = declare decls *> eval a
|
||||
eval ( With _ ( Tc_With ( withDeclsRecord :: Super.Rec ( MapFields UniqueTerm brushFields ) ) ) _ ( body :: Term Tc r ) ) = do
|
||||
defaultParamsRecord <-
|
||||
SuperRecord.traverseC @IsUniqueTerm2 @( State EvalState ) @( MapFields UniqueTerm brushFields ) @( MapFields UniqueField brushFields )
|
||||
( \ _ ( Compose ( UniqueField uniq term ) ) -> UniqueField uniq <$> eval term )
|
||||
withDeclsRecord
|
||||
EvalState { evalHeap, nextUnique } <- get
|
||||
let
|
||||
toBrushParameters
|
||||
:: forall givenFields usedFields
|
||||
. ( SuperRecord.UnsafeRecBuild usedFields usedFields
|
||||
( SuperRecord.Has givenFields )
|
||||
)
|
||||
=> Super.Rec givenFields -> Super.Rec usedFields
|
||||
toBrushParameters = SuperRecord.project
|
||||
brushFunction
|
||||
:: forall usedFields
|
||||
. ( SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField brushFields )
|
||||
( UseFieldsInBrush usedFields )
|
||||
)
|
||||
=> Super.Rec usedFields -> r
|
||||
brushFunction usedParamsRecord =
|
||||
let
|
||||
updatedHeap :: Map Unique TypedTerm
|
||||
updatedHeap = bindRecordValues @brushFields @usedFields defaultParamsRecord usedParamsRecord evalHeap
|
||||
in
|
||||
( `evalState` ( EvalState { evalHeap = updatedHeap, nextUnique } ) ) $ eval body
|
||||
pure ( AdaptableFunction ( toBrushParameters, brushFunction ) )
|
||||
eval ( Var var@( Located _ ( UniqueName _ varUniq ) ) ) = do
|
||||
vars <- use ( field' @"evalHeap" )
|
||||
case Map.lookup varUniq vars of
|
||||
Nothing -> error ( "eval: out of scope variable " <> show var )
|
||||
Just ( TypedTerm ( r :: Term Tc b ) )
|
||||
| Just Refl <- eqTy @a @b
|
||||
-> do
|
||||
res <- eval r
|
||||
modifying ( field' @"evalHeap" )
|
||||
( Map.insert varUniq ( TypedTerm $ CExt @Tc @a ( Val res ) ) )
|
||||
pure res
|
||||
| otherwise
|
||||
-> error
|
||||
( "eval: unexpected type of variable read from environment.\n\
|
||||
\Expected: " <> show ( sTypeI @a ) <> "\n\
|
||||
\ Actual: " <> show ( sTypeI @b )
|
||||
)
|
||||
eval ( CExt ( Val v ) ) = pure v
|
||||
|
||||
declare :: [ Decl Tc ] -> State EvalState ()
|
||||
declare [] = pure ()
|
||||
declare ( Decl _ pat t : next ) = go pat t *> declare next
|
||||
where
|
||||
go :: forall a. STypeI a => Pat Tc a -> Term Tc a -> State EvalState ( Maybe UniqueName )
|
||||
go ( PName ( Located _ patUniqName@( UniqueName _ patUniq ) ) ) r = do
|
||||
modifying ( field' @"evalHeap" )
|
||||
( Map.insert patUniq $ TypedTerm r )
|
||||
pure ( Just patUniqName )
|
||||
go ( PPoint _ lpat rpat ) r = do
|
||||
case sTypeI @a of
|
||||
sTyPoint@STyPoint
|
||||
| ( _ :: SType ( Point2D x ) ) <- sTyPoint
|
||||
-> do
|
||||
nextUnique <- use ( field' @"nextUnique" )
|
||||
let
|
||||
uniq1, uniq2, uniq3, nextUnique' :: Unique
|
||||
uniq1 = nextUnique
|
||||
uniq2 = succ uniq1
|
||||
uniq3 = succ uniq2
|
||||
nextUnique' = succ uniq3
|
||||
assign ( field' @"nextUnique" ) nextUnique'
|
||||
let
|
||||
pairText :: Text
|
||||
pairText = "$pair%" <> Text.pack ( show uniq1 )
|
||||
pairName, fstName, sndName :: UniqueName
|
||||
pairName = UniqueName pairText uniq1
|
||||
fstName = UniqueName ( pairText <> "$fst" ) uniq2
|
||||
sndName = UniqueName ( pairText <> "$snd" ) uniq3
|
||||
var_l, var_r :: Term Tc x
|
||||
var_l = Var ( Located noSpan fstName )
|
||||
var_r = Var ( Located noSpan sndName )
|
||||
modifying ( field' @"evalHeap" )
|
||||
( Map.union
|
||||
$ Map.fromList
|
||||
[ ( uniq1, TypedTerm $ Point [] var_l var_r )
|
||||
, ( uniq2, TypedTerm $ ( Op @( a -> x ) [] "fst" ( \ ~( Point2D x _ ) -> x ) ) :$ r )
|
||||
, ( uniq3, TypedTerm $ ( Op @( a -> x ) [] "snd" ( \ ~( Point2D _ y ) -> y ) ) :$ r )
|
||||
]
|
||||
)
|
||||
go lpat var_l
|
||||
go rpat var_r
|
||||
pure ( Just pairName )
|
||||
go ( AsPat _ ( Located _ asUniqName@( UniqueName _ asUniq ) ) patt ) r = do
|
||||
mbNm <- go patt r
|
||||
for_ mbNm \ nm ->
|
||||
modifying ( field' @"evalHeap" )
|
||||
( Map.insert asUniq ( TypedTerm $ Var @Tc @a ( Located noSpan nm ) ) )
|
||||
pure ( Just asUniqName )
|
||||
go ( PWild _ ) _ = pure Nothing
|
||||
|
||||
bindRecordValues
|
||||
:: forall brushFields usedFields defaultFields
|
||||
. ( defaultFields ~ MapFields UniqueField brushFields
|
||||
, SuperRecord.RecApply defaultFields defaultFields ( UseFieldsInBrush usedFields )
|
||||
)
|
||||
=> Super.Rec defaultFields
|
||||
-> Super.Rec usedFields
|
||||
-> Map Unique TypedTerm
|
||||
-> Map Unique TypedTerm
|
||||
bindRecordValues defaultValues usedValues heap = do
|
||||
SuperRecord.recApply @defaultFields @defaultFields @( UseFieldsInBrush usedFields )
|
||||
( \ k ( UniqueField ( UniqueName _ uniq ) ( defaultVal :: a ) ) prevState ->
|
||||
let
|
||||
val :: a
|
||||
val = SuperRecord.lookupWithDefault k defaultVal usedValues
|
||||
updatedHeap :: Map Unique TypedTerm
|
||||
updatedHeap = Map.insert uniq ( TypedTerm $ CExt @Tc @a ( Val val ) ) prevState
|
||||
in updatedHeap
|
||||
)
|
||||
defaultValues
|
||||
heap
|
||||
|
||||
noSpan :: Span
|
||||
noSpan = Span 0 0 0 0
|
141
src/app/MetaBrush/MetaParameter/Interpolation.hs
Normal file
141
src/app/MetaBrush/MetaParameter/Interpolation.hs
Normal file
|
@ -0,0 +1,141 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilyDependencies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module MetaBrush.MetaParameter.Interpolation
|
||||
( Interpolatable(..), MapDiff, HasDiff', HasTorsor )
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Functor.Identity
|
||||
( Identity(..) )
|
||||
import Data.Kind
|
||||
( Type )
|
||||
import Data.Monoid
|
||||
( Sum )
|
||||
import GHC.TypeLits
|
||||
( Symbol )
|
||||
|
||||
-- acts
|
||||
import Data.Act
|
||||
( Act(..), Torsor(..) )
|
||||
|
||||
-- groups
|
||||
import Data.Group
|
||||
( Group(..) )
|
||||
|
||||
-- superrecord
|
||||
import qualified SuperRecord as Super
|
||||
( Rec )
|
||||
import qualified SuperRecord
|
||||
( (:=), Has, RecTy, RecApply(..), UnsafeRecBuild(..), TraversalC, traverseC
|
||||
, get, set, modify
|
||||
)
|
||||
import SuperRecord
|
||||
( ConstC, Tuple22C )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Module
|
||||
( Module(..) )
|
||||
import Math.Vector2D
|
||||
( Point2D, Vector2D )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
class ( Module Double ( Diff a ), Torsor ( Diff a ) a ) => Interpolatable a where
|
||||
type Diff a = ( d :: Type ) | d -> a
|
||||
|
||||
instance ( a ~ Double ) => Interpolatable ( Point2D a ) where
|
||||
type Diff ( Point2D a ) = Vector2D a
|
||||
|
||||
instance Interpolatable Double where
|
||||
type Diff Double = Sum Double
|
||||
|
||||
instance ( dvs ~ MapDiff kvs
|
||||
, SuperRecord.UnsafeRecBuild dvs dvs ( ConstC Monoid )
|
||||
, SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has dvs ) )
|
||||
, SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC Semigroup ) ( SuperRecord.Has dvs ) )
|
||||
, SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC Group ) ( SuperRecord.Has dvs ) )
|
||||
, SuperRecord.RecApply dvs dvs ( HasDiff' kvs )
|
||||
, SuperRecord.TraversalC ( HasTorsor kvs ) kvs dvs
|
||||
, Module Double ( Super.Rec ( MapDiff kvs ) )
|
||||
)
|
||||
=> Interpolatable ( Super.Rec kvs )
|
||||
where
|
||||
type Diff ( Super.Rec kvs ) = Super.Rec ( MapDiff kvs )
|
||||
|
||||
type family MapDiff ( kvs :: [ Type ] ) = ( lvs :: [ Type ] ) | lvs -> kvs where
|
||||
MapDiff '[] = '[]
|
||||
MapDiff ( k SuperRecord.:= v ': kvs ) = ( k SuperRecord.:= Diff v ': MapDiff kvs )
|
||||
|
||||
|
||||
|
||||
|
||||
instance ( Monoid ( Super.Rec kvs )
|
||||
, SuperRecord.RecApply kvs kvs
|
||||
( Tuple22C ( ConstC Group ) ( SuperRecord.Has kvs ) )
|
||||
)
|
||||
=> Group ( Super.Rec kvs )
|
||||
where
|
||||
invert r = SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC Group ) ( SuperRecord.Has kvs ) )
|
||||
( \ lbl v res -> SuperRecord.set lbl ( invert v ) res ) r r
|
||||
instance ( SuperRecord.RecApply kvs kvs
|
||||
( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) )
|
||||
, SuperRecord.UnsafeRecBuild kvs kvs ( ConstC ( Module Double ) )
|
||||
)
|
||||
=> Module Double ( Super.Rec kvs )
|
||||
where
|
||||
origin = runIdentity $ SuperRecord.unsafeRecBuild @kvs @kvs @( ConstC ( Module Double ) ) ( \ _ _ -> Identity origin )
|
||||
r1 ^+^ r2 =
|
||||
SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) )
|
||||
( \ lbl v1 res -> SuperRecord.modify lbl ( v1 ^+^ ) res ) r1 r2
|
||||
r1 ^-^ r2 =
|
||||
SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) )
|
||||
( \ lbl v1 res -> SuperRecord.modify lbl ( v1 ^-^ ) res ) r1 r2
|
||||
k *^ r =
|
||||
SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) )
|
||||
( \ lbl v1 res -> SuperRecord.set lbl ( k *^ v1 ) res ) r r
|
||||
|
||||
class ( SuperRecord.Has kvs k t, Interpolatable t, d ~ Diff t, Just t ~ SuperRecord.RecTy k kvs )
|
||||
=> HasDiff ( kvs :: [ Type ] ) ( t :: Type ) ( k :: Symbol ) ( d :: Type )
|
||||
instance ( SuperRecord.Has kvs k t, Interpolatable t, d ~ Diff t, Just t ~ SuperRecord.RecTy k kvs )
|
||||
=> HasDiff kvs t k d
|
||||
|
||||
type family FromJust ( a :: Maybe k ) :: k where
|
||||
FromJust ( Just a ) = a
|
||||
|
||||
class HasDiff kvs ( FromJust ( SuperRecord.RecTy k kvs ) ) k d => HasDiff' kvs k d
|
||||
instance HasDiff kvs ( FromJust ( SuperRecord.RecTy k kvs ) ) k d => HasDiff' kvs k d
|
||||
|
||||
instance ( dvs ~ MapDiff kvs
|
||||
, SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC Semigroup ) ( SuperRecord.Has dvs ) )
|
||||
, SuperRecord.RecApply dvs dvs ( HasDiff' kvs )
|
||||
)
|
||||
=> Act ( Super.Rec dvs ) ( Super.Rec kvs )
|
||||
where
|
||||
ds • as = SuperRecord.recApply @dvs @dvs @( HasDiff' kvs )
|
||||
( \ lbl d1 res -> SuperRecord.modify lbl ( d1 • ) res ) ds as
|
||||
|
||||
|
||||
class ( d ~ Diff t, Torsor d t, SuperRecord.Has kvs k t ) => HasTorsor ( kvs :: [Type] ) ( k :: Symbol ) t d where
|
||||
instance ( d ~ Diff t, Torsor d t, SuperRecord.Has kvs k t ) => HasTorsor kvs k t d where
|
||||
|
||||
instance ( dvs ~ MapDiff kvs
|
||||
, SuperRecord.TraversalC ( HasTorsor kvs ) kvs dvs
|
||||
, Act ( Super.Rec dvs ) ( Super.Rec kvs )
|
||||
, Group ( Super.Rec dvs )
|
||||
)
|
||||
=> Torsor ( Super.Rec dvs ) ( Super.Rec kvs ) where
|
||||
as <-- bs =
|
||||
runIdentity $ SuperRecord.traverseC @( HasTorsor kvs ) @Identity @kvs @dvs
|
||||
( \ lbl a -> Identity ( a <-- SuperRecord.get lbl bs ) )
|
||||
as
|
828
src/app/MetaBrush/MetaParameter/Parse.hs
Normal file
828
src/app/MetaBrush/MetaParameter/Parse.hs
Normal file
|
@ -0,0 +1,828 @@
|
|||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
|
||||
|
||||
module MetaBrush.MetaParameter.Parse where
|
||||
|
||||
-- base
|
||||
import Control.Applicative
|
||||
( Alternative
|
||||
( (<|>), some, many )
|
||||
, optional
|
||||
)
|
||||
import Control.Category
|
||||
( (>>>) )
|
||||
import Control.Monad
|
||||
( void )
|
||||
import qualified Data.Char as Char
|
||||
( isAlpha, isAlphaNum, isDigit, isSpace, isSymbol, isPunctuation, toLower )
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
|
||||
-- containers
|
||||
import Data.Set
|
||||
( Set )
|
||||
import qualified Data.Set as Set
|
||||
( member, fromList )
|
||||
import qualified Data.Sequence as Seq
|
||||
( fromList )
|
||||
|
||||
-- Earley
|
||||
import qualified Text.Earley as Earley
|
||||
import Text.Earley
|
||||
( (<?>) )
|
||||
import qualified Text.Earley.Mixfix as Earley
|
||||
|
||||
-- text
|
||||
import Data.Text.Internal
|
||||
( Text(..) )
|
||||
import qualified Data.Text as Text
|
||||
( all, break, cons, foldl'
|
||||
, length, map, null
|
||||
, singleton, span
|
||||
, uncons, unpack
|
||||
)
|
||||
import qualified Data.Text.Read as Text.Read
|
||||
( double )
|
||||
|
||||
-- tree-view
|
||||
import Data.Tree.View
|
||||
( drawTree )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Bezier.Spline
|
||||
( SplineType(..), SSplineType(..), SplineTypeI(ssplineType)
|
||||
, Spline(..), Curves(..), Curve(..), NextPoint(..)
|
||||
)
|
||||
import MetaBrush.MetaParameter.AST
|
||||
( Span(..), Located(..)
|
||||
, Expr, EPat
|
||||
, Term(..), Pat(..), Decl(..)
|
||||
, X_With(..)
|
||||
, toTreeTerm
|
||||
)
|
||||
import MetaBrush.MetaParameter.PrimOp
|
||||
( Orientation(..), kappa
|
||||
, rotate_around_by, rotate_by
|
||||
, scale_around_by, scale_by
|
||||
, shear_from_by, shear_by
|
||||
, translate_by
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Parsing using the language grammar.
|
||||
|
||||
parse :: Text -> ( [ ( Expr, Int ) ], Earley.Report Text [ Located Token ] )
|
||||
parse = Earley.allParses ( Earley.parser grammar ) . tokenize
|
||||
|
||||
showParses :: Text -> IO ()
|
||||
showParses x = do
|
||||
let
|
||||
( parses, report ) = parse x
|
||||
putStrLn "Report:\n"
|
||||
print report
|
||||
putStrLn "\n\n"
|
||||
putStrLn "Parses:\n"
|
||||
for_ parses \ ( expr, _ ) -> do
|
||||
let
|
||||
tree = toTreeTerm expr
|
||||
drawTree tree
|
||||
|
||||
examples :: [ Located Token ] -> Int -> IO ()
|
||||
examples inputToks n =
|
||||
for_ ( Earley.exactly n ( Earley.generator grammar inputToks ) ) \ ( expr, toks ) -> do
|
||||
for_ toks ( located >>> showToken >>> ( <> " " ) >>> putStr )
|
||||
putStrLn ""
|
||||
drawTree ( toTreeTerm expr )
|
||||
putStrLn "\n\n"
|
||||
|
||||
someToks :: [ Located Token ]
|
||||
someToks = map ( Located mempty )
|
||||
[ TokAlphabetic "x"
|
||||
, TokAlphabetic "let"
|
||||
, TokAlphabetic "in"
|
||||
, TokSpecial '['
|
||||
, TokSpecial ']'
|
||||
, TokSpecial '('
|
||||
, TokSpecial ')'
|
||||
, TokSymbolic "="
|
||||
, TokSymbolic "--"
|
||||
, TokSymbolic "->"
|
||||
, TokSymbolic "."
|
||||
]
|
||||
|
||||
test1 :: Text
|
||||
test1 =
|
||||
" let\n\
|
||||
\ q = rotate p around c CW by theta + 3 * theta2\n\
|
||||
\ r = scale ( translate q by t ) by (7,11)\n\
|
||||
\ in rotate q around p CW by phi"
|
||||
|
||||
test2 :: Text
|
||||
test2 =
|
||||
" let\n\
|
||||
\ p = (3,3)\n\
|
||||
\ q = (1,1)\n\
|
||||
\ in\n\
|
||||
\ rotate p\n\
|
||||
\ around q\n\
|
||||
\ CCW by\n\
|
||||
\ let\n\
|
||||
\ q = pi / 2 \n\
|
||||
\ in q"
|
||||
|
||||
test3 :: Text
|
||||
test3 =
|
||||
" let\n\
|
||||
\ p = (1,1)\n\
|
||||
\ in\n\
|
||||
\ [ p -- c1 -- c2 -> q\n\
|
||||
\ -- c3 -- c4 -> r\n\
|
||||
\ -> s -> .\n\
|
||||
\ ]"
|
||||
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Language grammar.
|
||||
|
||||
grammar :: forall r. Earley.Grammar r ( Earley.Prod r Text ( Located Token ) Expr )
|
||||
grammar = mdo
|
||||
|
||||
pair <- Earley.rule $
|
||||
do
|
||||
lp <- special '('
|
||||
l <- expr
|
||||
anyWhitespace
|
||||
comma <- special ','
|
||||
r <- expr
|
||||
anyWhitespace
|
||||
rp <- special ')'
|
||||
pure $
|
||||
Point
|
||||
[ Location ( location lp )
|
||||
, Location ( location comma )
|
||||
, Location ( location rp ) ]
|
||||
l r
|
||||
<?> "pair"
|
||||
atom <- Earley.rule
|
||||
( identifier
|
||||
<|> pair
|
||||
<|> ( special '(' *> expr <* anyWhitespace <* special ')' )
|
||||
<|> spline
|
||||
)
|
||||
app <- Earley.rule ( atom <|> (:$) <$> app <*> ( anyWhitespace *> atom ) )
|
||||
|
||||
pairPattern <- Earley.rule
|
||||
( do
|
||||
openLoc <- special '('
|
||||
anyWhitespace
|
||||
l <- anyPattern
|
||||
anyWhitespace
|
||||
commaLoc <- special ','
|
||||
anyWhitespace
|
||||
r <- anyPattern
|
||||
anyWhitespace
|
||||
closeLoc <- special ')'
|
||||
pure $ PPoint
|
||||
[ Location ( location openLoc )
|
||||
, Location ( location commaLoc )
|
||||
, Location ( location closeLoc )
|
||||
]
|
||||
l r
|
||||
<?> "pair"
|
||||
)
|
||||
|
||||
basicPattern <- Earley.rule
|
||||
( wildcard
|
||||
<|> ( PName <$> alphabeticName
|
||||
<?> "pattern name"
|
||||
)
|
||||
<|> pairPattern
|
||||
)
|
||||
|
||||
asPattern <- Earley.rule
|
||||
( do
|
||||
n <- alphabeticName <?> "pattern name"
|
||||
asLoc <- symbol "@"
|
||||
pat <- anyPattern
|
||||
pure $
|
||||
AsPat ( Location ( location asLoc ) ) n pat
|
||||
<?> "as pattern"
|
||||
)
|
||||
|
||||
anyPattern <- Earley.rule ( ( basicPattern <|> asPattern ) <?> "pattern" )
|
||||
|
||||
declaration <-
|
||||
Earley.rule
|
||||
( do
|
||||
p <- anyPattern
|
||||
anyWhitespace
|
||||
eqLoc <- symbol "="
|
||||
e <- expr
|
||||
pure ( Location ( location eqLoc ), p, e )
|
||||
<?> "declaration"
|
||||
)
|
||||
|
||||
moreDeclarations <- Earley.rule
|
||||
( do
|
||||
separator
|
||||
decl <- declaration
|
||||
more <- moreDeclarations
|
||||
pure $ ( \ ( l, p, e ) -> Decl l p e : more ) decl
|
||||
<|> pure []
|
||||
)
|
||||
|
||||
declarations <-
|
||||
Earley.rule
|
||||
( do
|
||||
decl <- declaration
|
||||
more <- moreDeclarations
|
||||
pure $ ( \ ( l, p, e ) -> Decl l p e : more ) decl
|
||||
<|> pure []
|
||||
)
|
||||
|
||||
let_statement <-
|
||||
Earley.rule
|
||||
( do
|
||||
loc_let <- tokAlpha "let"
|
||||
anyWhitespace
|
||||
decls <- declarations <?> "declarations"
|
||||
anyWhitespace
|
||||
loc_in <- tokAlpha "in"
|
||||
e <- expr
|
||||
pure $
|
||||
Let
|
||||
[ Location ( location loc_let )
|
||||
, Location ( location loc_in ) ]
|
||||
decls
|
||||
e
|
||||
<?> "let statement"
|
||||
)
|
||||
|
||||
moreProperties <- Earley.rule
|
||||
( do
|
||||
separator
|
||||
prop <- expr
|
||||
more <- moreProperties
|
||||
pure ( prop : more )
|
||||
<|> pure []
|
||||
)
|
||||
|
||||
properties <-
|
||||
Earley.rule
|
||||
( do
|
||||
prop <- expr
|
||||
more <- moreProperties
|
||||
pure ( prop : more )
|
||||
<|> pure []
|
||||
)
|
||||
|
||||
with_statement <-
|
||||
Earley.rule
|
||||
( do
|
||||
loc_with <- tokAlpha "with"
|
||||
anyWhitespace
|
||||
decls <- declarations <?> "parameter default definitions"
|
||||
mbProps <- optional do
|
||||
anyWhitespace
|
||||
loc_sats <- tokAlpha "satisfying"
|
||||
props <- properties <?> "parameter range properties"
|
||||
pure ( loc_sats, props )
|
||||
anyWhitespace
|
||||
loc_def <- tokAlpha "define"
|
||||
e <- expr
|
||||
pure $
|
||||
let
|
||||
( locs, props ) = case mbProps of
|
||||
Nothing ->
|
||||
( [ Location ( location loc_with )
|
||||
, Location ( location loc_def ) ]
|
||||
, []
|
||||
)
|
||||
Just ( loc_sats, sat_props ) ->
|
||||
( [ Location ( location loc_with )
|
||||
, Location ( location loc_sats )
|
||||
, Location ( location loc_def ) ]
|
||||
, sat_props
|
||||
)
|
||||
in
|
||||
With locs ( P_With decls ) props e
|
||||
<?> "with statement"
|
||||
)
|
||||
|
||||
spline <-
|
||||
Earley.rule
|
||||
( do
|
||||
start <- special '['
|
||||
p0 <- expr <?> "first point of spline"
|
||||
openCurves <- many $ curveTo @Open expr <?> "open curve to"
|
||||
mbClosed <- optional $ curveTo @Closed expr <?> "closed curve"
|
||||
anyWhitespace
|
||||
end <- special ']'
|
||||
pure $
|
||||
( \ opens -> \ case
|
||||
Nothing ->
|
||||
PolyBez
|
||||
[ Location ( location start ), Location ( location end ) ]
|
||||
( Spline p0 ( OpenCurves opens ) )
|
||||
Just closed ->
|
||||
PolyBez
|
||||
[ Location ( location start ), Location ( location end ) ]
|
||||
( Spline p0 ( ClosedCurves opens closed ) )
|
||||
) ( Seq.fromList openCurves ) mbClosed
|
||||
<?> "spline" )
|
||||
|
||||
simpleExpr <- Earley.rule do
|
||||
anyWhitespace
|
||||
res <- app <|> let_statement
|
||||
pure res
|
||||
expr <- Earley.mixfixExpressionSeparate mixfixTable simpleExpr
|
||||
|
||||
pure ( with_statement <|> expr )
|
||||
|
||||
-- | Reserved alphabetic identifiers.
|
||||
reserved :: Set Text
|
||||
reserved
|
||||
= Set.fromList
|
||||
[ "let", "in"
|
||||
, "with", "set", "satisfying"
|
||||
, "around", "by", "rotate", "scale", "shear", "translate", "transform"
|
||||
, "cw", "ccw"
|
||||
, "pi", "tau", "kappa"
|
||||
]
|
||||
{-
|
||||
[ "=", "_", "@", "--", "->" ]
|
||||
-}
|
||||
|
||||
dots :: Earley.Prod r Text ( Located Token ) ( Located Token )
|
||||
dots = Earley.satisfy ( located >>> \case { TokSymbolic s | Text.all ( == '.' ) s -> True; _ -> False } )
|
||||
|
||||
locatedToken :: Token -> Earley.Prod r Text ( Located Token ) ( Located Token )
|
||||
locatedToken t = Earley.satisfy ( located >>> ( == t ) )
|
||||
|
||||
tokAlpha, ws_tokAlpha :: Text -> Earley.Prod r Text ( Located Token ) ( Located Token )
|
||||
tokAlpha t = Earley.satisfy
|
||||
( located >>> \case { TokAlphabetic a | Text.map Char.toLower a == t -> True; _ -> False } )
|
||||
<?> t
|
||||
ws_tokAlpha t = anyWhitespace *> tokAlpha t
|
||||
|
||||
tokSymbol, ws_tokSymbol :: Text -> Earley.Prod r Text ( Located Token ) ( Located Token )
|
||||
tokSymbol t = locatedToken ( TokSymbolic t ) <?> t
|
||||
ws_tokSymbol t = anyWhitespace *> tokSymbol t
|
||||
|
||||
tokOrientation :: Earley.Prod r Text ( Located Token ) ( Located Token )
|
||||
tokOrientation = anyWhitespace *> ( tokAlpha "ccw" <|> tokAlpha "cw" )
|
||||
|
||||
orientation :: Token -> Orientation
|
||||
orientation ( TokAlphabetic ori )
|
||||
| Text.map Char.toLower ori == "ccw"
|
||||
= CCW
|
||||
| Text.map Char.toLower ori == "cw"
|
||||
= CW
|
||||
orientation tok = error ( "orientation: unexpected token " <> show tok )
|
||||
|
||||
curveTo
|
||||
:: forall clo r
|
||||
. SplineTypeI clo
|
||||
=> Earley.Prod r Text ( Located Token ) Expr
|
||||
-> Earley.Prod r Text ( Located Token ) ( Curve clo [ Located () ] Expr )
|
||||
curveTo expr = do
|
||||
anyWhitespace
|
||||
cps <- optional do
|
||||
locTo1 <- symbol "--"
|
||||
cp1 <- expr
|
||||
anyWhitespace
|
||||
mb_cp2 <- optional do
|
||||
locTo2 <- symbol "--"
|
||||
cp2 <- expr
|
||||
anyWhitespace
|
||||
pure ( locTo2, cp2 )
|
||||
pure ( ( locTo1, cp1), mb_cp2 )
|
||||
locTo3 <- symbol "->"
|
||||
mkCurve <- case ssplineType @clo of
|
||||
SClosed ->
|
||||
let
|
||||
mkCurve
|
||||
:: Located Token
|
||||
-> Maybe ( ( Located Token, Expr ), Maybe ( Located Token, Expr ) )
|
||||
-> Span
|
||||
-> Curve Closed [ Located () ] Expr
|
||||
mkCurve ( Located dotsLoc _ ) mbCps loc3 = case mbCps of
|
||||
Nothing ->
|
||||
LineTo BackToStart [ Location loc3, Location dotsLoc ]
|
||||
Just ( ( Located loc1 _, cp1 ), Nothing ) ->
|
||||
Bezier2To cp1 BackToStart [ Location loc1, Location loc3, Location dotsLoc ]
|
||||
Just ( ( Located loc1 _, cp1 ), Just ( Located loc2 _, cp2 ) ) ->
|
||||
Bezier3To cp1 cp2 BackToStart [ Location loc1, Location loc2, Location loc3, Location dotsLoc ]
|
||||
in do
|
||||
anyWhitespace
|
||||
locatedDots <- dots
|
||||
pure ( mkCurve locatedDots )
|
||||
SOpen ->
|
||||
let
|
||||
mkCurve
|
||||
:: Expr
|
||||
-> Maybe ( ( Located Token, Expr ), Maybe ( Located Token, Expr ) )
|
||||
-> Span
|
||||
-> Curve Open [ Located () ] Expr
|
||||
mkCurve p mbCps loc3 = case mbCps of
|
||||
Nothing ->
|
||||
LineTo ( NextPoint p ) [ Location loc3 ]
|
||||
Just ( ( Located loc1 _, cp1 ), Nothing ) ->
|
||||
Bezier2To cp1 ( NextPoint p ) [ Location loc1, Location loc3 ]
|
||||
Just ( ( Located loc1 _, cp1 ), Just ( Located loc2 _, cp2 ) ) ->
|
||||
Bezier3To cp1 cp2 ( NextPoint p ) [ Location loc1, Location loc2, Location loc3 ]
|
||||
in do
|
||||
p <- expr
|
||||
pure ( mkCurve p )
|
||||
pure ( mkCurve cps ( location locTo3 ) )
|
||||
|
||||
mixfixTable
|
||||
:: [ [
|
||||
( Earley.Holey ( Earley.Prod r Text ( Located Token ) ( Located Token ) )
|
||||
, Earley.Associativity
|
||||
, Earley.Holey ( Located Token ) -> [ Expr ] -> Expr
|
||||
)
|
||||
] ]
|
||||
mixfixTable
|
||||
= [ [ ( [ Just $ ws_tokAlpha "rotate", Nothing, Just $ ws_tokAlpha "around", Nothing, Just tokOrientation, Just $ ws_tokAlpha "by", Nothing ]
|
||||
, Earley.NonAssoc
|
||||
, \ [ Just ( Located lr _ ), _, Just ( Located la _ ), _, Just ( Located lo ori_tok ), Just ( Located lb _ ), _ ] [ p, c, theta ] ->
|
||||
let
|
||||
ori :: Orientation
|
||||
ori = orientation ori_tok
|
||||
opName :: Text
|
||||
opName = case ori of { CW -> "rotate_around_cwby_"; CCW -> "rotate_around_ccwby_" }
|
||||
in
|
||||
Op [ Location lr, Location la, Location lo, Location lb ]
|
||||
opName ( rotate_around_by ori )
|
||||
:$ p :$ c :$ theta
|
||||
)
|
||||
, ( [ Just $ ws_tokAlpha "scale", Nothing, Just $ ws_tokAlpha "around", Nothing, Just $ ws_tokAlpha "by", Nothing ]
|
||||
, Earley.NonAssoc
|
||||
, \ [ Just ( Located ls _ ), _, Just ( Located la _ ), _, Just ( Located lb _ ), _ ] [ p, c, r ] ->
|
||||
Op [ Location ls, Location la, Location lb ]
|
||||
"scale_around_by_" scale_around_by
|
||||
:$ p :$ c :$ r
|
||||
)
|
||||
, ( [ Just $ ws_tokAlpha "shear", Nothing, Just $ ws_tokAlpha "from", Nothing, Just $ ws_tokAlpha "by", Nothing ]
|
||||
, Earley.NonAssoc
|
||||
, \ [ Just ( Located ls _ ), _, Just ( Located lf _ ), _, Just ( Located lb _ ), _ ] [ p, c, v ] ->
|
||||
Op [ Location ls, Location lf, Location lb ]
|
||||
"shear_from_by_" shear_from_by
|
||||
:$ p :$ c :$ v
|
||||
)
|
||||
]
|
||||
, [ ( [ Just $ ws_tokAlpha "rotate", Nothing, Just tokOrientation, Just $ ws_tokAlpha "by", Nothing ]
|
||||
, Earley.NonAssoc
|
||||
, \ [ Just ( Located lr _ ), _, Just ( Located lo ori_tok ), Just ( Located lb _), _ ] [ p, theta ] ->
|
||||
let
|
||||
ori :: Orientation
|
||||
ori = orientation ori_tok
|
||||
opName :: Text
|
||||
opName = case ori of { CW -> "rotate_around_cw_"; CCW -> "rotate_around_ccw_" }
|
||||
in
|
||||
Op [ Location lr, Location lo, Location lb ]
|
||||
opName ( rotate_by ori )
|
||||
:$ p :$ theta
|
||||
)
|
||||
, ( [ Just $ ws_tokAlpha "scale", Nothing, Just $ ws_tokAlpha "by", Nothing ]
|
||||
, Earley.NonAssoc
|
||||
, \ [ Just ( Located ls _ ), _, Just ( Located lb _ ), _ ] [ p, r ] ->
|
||||
Op [ Location ls, Location lb ]
|
||||
"scale_by_" scale_by
|
||||
:$ p :$ r
|
||||
)
|
||||
, ( [ Just $ ws_tokAlpha "shear", Nothing, Just $ ws_tokAlpha "along", Nothing, Just $ ws_tokAlpha "by", Nothing ]
|
||||
, Earley.NonAssoc
|
||||
, \ [ Just ( Located ls _ ), _, Just ( Located lb _ ), _ ] [ p, v ] ->
|
||||
Op [ Location ls, Location lb ]
|
||||
"shear_along_by_" shear_by
|
||||
:$ p :$ v
|
||||
)
|
||||
, ( [ Just $ ws_tokAlpha "translate", Nothing, Just $ ws_tokAlpha "by", Nothing ]
|
||||
, Earley.NonAssoc
|
||||
, \ [ Just ( Located lt _ ), _, Just ( Located lb _ ), _ ] [ p, t ] ->
|
||||
Op [ Location lt, Location lb ]
|
||||
"translate_by_" translate_by
|
||||
:$ p :$ t
|
||||
)
|
||||
]
|
||||
, [ ( [ Nothing, Just $ ws_tokSymbol "||", Nothing ]
|
||||
, Earley.RightAssoc
|
||||
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
|
||||
Op [ Location l ]
|
||||
"(||)" (||)
|
||||
:$ a :$ b
|
||||
)
|
||||
]
|
||||
, [ ( [ Nothing, Just $ ws_tokSymbol "&&", Nothing ]
|
||||
, Earley.RightAssoc
|
||||
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
|
||||
Op [ Location l ]
|
||||
"(&&)" (&&)
|
||||
:$ a :$ b
|
||||
)
|
||||
]
|
||||
, [ ( [ Nothing, Just $ ws_tokSymbol "<", Nothing ]
|
||||
, Earley.NonAssoc
|
||||
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
|
||||
Op [ Location l ]
|
||||
"(<)" ( (<) @Double )
|
||||
:$ a :$ b
|
||||
)
|
||||
, ( [ Nothing, Just $ ws_tokSymbol "<=", Nothing ]
|
||||
, Earley.NonAssoc
|
||||
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
|
||||
Op [ Location l ]
|
||||
"(<=)" ( (<=) @Double )
|
||||
:$ a :$ b
|
||||
)
|
||||
, ( [ Nothing, Just $ ws_tokSymbol ">", Nothing ]
|
||||
, Earley.NonAssoc
|
||||
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
|
||||
Op [ Location l ]
|
||||
"(>)" ( (>) @Double )
|
||||
:$ a :$ b
|
||||
)
|
||||
, ( [ Nothing, Just $ ws_tokSymbol ">=", Nothing ]
|
||||
, Earley.NonAssoc
|
||||
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
|
||||
Op [ Location l ]
|
||||
"(>=)" ( (>=) @Double )
|
||||
:$ a :$ b
|
||||
)
|
||||
, ( [ Nothing, Just $ ws_tokSymbol "==", Nothing ]
|
||||
, Earley.NonAssoc
|
||||
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
|
||||
Op [ Location l ]
|
||||
"(==)" ( (==) @Double )
|
||||
:$ a :$ b
|
||||
)
|
||||
]
|
||||
, [ ( [ Nothing, Just $ ws_tokSymbol "+", Nothing ]
|
||||
, Earley.LeftAssoc
|
||||
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
|
||||
Op [ Location l ]
|
||||
"(+)" ( (+) @Double )
|
||||
:$ a :$ b
|
||||
)
|
||||
, ( [ Nothing, Just $ ws_tokSymbol "-", Nothing ]
|
||||
, Earley.LeftAssoc
|
||||
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
|
||||
Op [ Location l ]
|
||||
"(-)" ( (-) @Double )
|
||||
:$ a :$ b
|
||||
)
|
||||
, ( [ Just $ ws_tokSymbol "-", Nothing ]
|
||||
, Earley.RightAssoc
|
||||
, \ [ Just ( Located l _ ), _ ] [ a ] ->
|
||||
Op [ Location l ]
|
||||
"negate" ( negate @Double )
|
||||
:$ a
|
||||
)
|
||||
]
|
||||
, [ ( [ Nothing, Just $ ws_tokSymbol "*", Nothing ]
|
||||
, Earley.LeftAssoc
|
||||
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
|
||||
Op [ Location l ]
|
||||
"(*)" ( (*) @Double )
|
||||
:$ a :$ b
|
||||
)
|
||||
, ( [ Nothing, Just $ ws_tokSymbol "/", Nothing ]
|
||||
, Earley.LeftAssoc
|
||||
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
|
||||
Op [ Location l ]
|
||||
"(/)" ( (/) @Double )
|
||||
:$ a :$ b
|
||||
)
|
||||
]
|
||||
, [ ( [ Nothing, Just $ ws_tokSymbol "^", Nothing ]
|
||||
, Earley.RightAssoc
|
||||
, \ [ _, Just ( Located l _ ), _ ] [ a, b ] ->
|
||||
Op [ Location l ]
|
||||
"(^)" ( (**) @Double )
|
||||
:$ a :$ b
|
||||
)
|
||||
]
|
||||
]
|
||||
|
||||
numericLiteral :: Located Token -> Maybe Expr
|
||||
numericLiteral ( Located l ( TokNumeric x ) ) = Just $ Lit @Double ( Located l Nothing ) x
|
||||
numericLiteral _ = Nothing
|
||||
|
||||
number :: Earley.Prod r Text ( Located Token ) Expr
|
||||
number = Earley.terminal numericLiteral
|
||||
<?> "number"
|
||||
|
||||
identifier :: Earley.Prod r Text ( Located Token ) Expr
|
||||
identifier =
|
||||
number
|
||||
<|> ( \ ( Located l _ ) -> Lit @Double ( Located l ( Just "pi" ) ) pi ) <$> tokAlpha "pi"
|
||||
<|> ( \ ( Located l _ ) -> Lit @Double ( Located l ( Just "tau" ) ) ( 2 * pi ) ) <$> tokAlpha "tau"
|
||||
<|> ( \ ( Located l _ ) -> Lit @Double ( Located l ( Just "kappa" ) ) kappa ) <$> tokAlpha "kappa"
|
||||
<|> ( ( \ n -> Var n ) <$> alphabeticName
|
||||
<?> "identifier"
|
||||
)
|
||||
|
||||
|
||||
|
||||
whitespace, anyWhitespace :: Earley.Prod r Text ( Located Token ) ()
|
||||
whitespace = Earley.terminal $ located >>> \case { TokWhitespace _ -> Just (); _ -> Nothing }
|
||||
anyWhitespace = void $ many whitespace
|
||||
|
||||
significantWhitespace :: Earley.Prod r Text ( Located Token ) ()
|
||||
significantWhitespace = Earley.terminal ( located >>> \case { TokWhitespace True -> Just (); _ -> Nothing } )
|
||||
<?> "newline"
|
||||
|
||||
separator :: Earley.Prod r Text ( Located Token ) ()
|
||||
separator =
|
||||
( void ( some significantWhitespace )
|
||||
<|> ( void ( anyWhitespace *> special ';' <* anyWhitespace ) )
|
||||
)
|
||||
<?> "separator"
|
||||
|
||||
alphabeticName :: Earley.Prod r Text ( Located Token ) ( Located Text )
|
||||
alphabeticName =
|
||||
Earley.terminal \case
|
||||
Located l ( TokAlphabetic x )
|
||||
| not ( x `Set.member` reserved )
|
||||
-> Just ( Located l x )
|
||||
_ -> Nothing
|
||||
|
||||
special :: Char -> Earley.Prod r Text ( Located Token ) ( Located Token )
|
||||
special c = locatedToken ( TokSpecial c ) <?> Text.singleton c
|
||||
|
||||
symbol :: Text -> Earley.Prod r Text ( Located Token ) ( Located Token )
|
||||
symbol s = locatedToken ( TokSymbolic s ) <?> s
|
||||
|
||||
wildcard :: Earley.Prod r Text ( Located Token ) EPat
|
||||
wildcard = Earley.terminal
|
||||
\case
|
||||
Located l ( TokWildcard x ) -> Just ( PWild ( Located l x ) )
|
||||
_ -> Nothing
|
||||
<?> "wildcard pattern"
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Tokenizer.
|
||||
|
||||
isSpecial :: Char -> Bool
|
||||
isSpecial c = Set.member c ( Set.fromList "(){}[],;`\"" )
|
||||
|
||||
data Token
|
||||
= TokWhitespace Bool
|
||||
| TokSpecial Char
|
||||
| TokAlphabetic Text
|
||||
| TokNumeric Double
|
||||
| TokWildcard Text
|
||||
| TokSymbolic Text
|
||||
| OtherTok Text
|
||||
deriving stock ( Show, Eq, Ord )
|
||||
|
||||
showToken :: Token -> String
|
||||
showToken ( TokWhitespace False ) = " "
|
||||
showToken ( TokWhitespace True ) = "\n"
|
||||
showToken ( TokSpecial s ) = [s]
|
||||
showToken ( TokAlphabetic a ) = Text.unpack a
|
||||
showToken ( TokNumeric x ) = show x
|
||||
showToken ( TokWildcard w ) = Text.unpack w
|
||||
showToken ( TokSymbolic s ) = Text.unpack s
|
||||
showToken ( OtherTok t ) = Text.unpack t
|
||||
|
||||
tokenize :: Text -> [ Located Token ]
|
||||
tokenize = go 1 1
|
||||
where
|
||||
go :: Int -> Int -> Text -> [ Located Token ]
|
||||
go sr sc t = case Text.uncons t of
|
||||
Nothing -> []
|
||||
Just ( x, xs )
|
||||
-- White space.
|
||||
| Char.isSpace x
|
||||
, let
|
||||
( ys, rest ) = Text.span Char.isSpace xs
|
||||
( er1, er2, ec ) =
|
||||
Text.foldl'
|
||||
( \ (r1,r2,c) -> \ case
|
||||
'\n' -> (r1+1,r2,1)
|
||||
'\r' -> (r1,r2+1,1)
|
||||
'\t' -> (r1,r2,c+2)
|
||||
'\f' -> (r1,r2,c)
|
||||
'\v' -> (r1,r2,c)
|
||||
_ -> (r1,r2,c+1)
|
||||
)
|
||||
(sr,sr,sc)
|
||||
( x `Text.cons` ys )
|
||||
er = max er1 er2
|
||||
-> if er > sr
|
||||
then Located ( Span sr sc er ec ) ( TokWhitespace True ) : go er ec rest
|
||||
else Located ( Span sr sc er ec ) ( TokWhitespace False ) : go er ec rest
|
||||
-- Special characters.
|
||||
| isSpecial x
|
||||
-> Located ( Span sr sc sr ( sc + 1 ) ) ( TokSpecial x )
|
||||
: go sr ( sc + 1 ) xs
|
||||
-- Alphabetic identifier.
|
||||
| Char.isAlpha x
|
||||
, let
|
||||
( ys, rest ) = Text.span ( \case { '\'' -> True; '_' -> True; y | Char.isAlphaNum y -> True; _ -> False } ) xs
|
||||
tok = x `Text.cons` ys
|
||||
l = Text.length tok
|
||||
-> Located ( Span sr sc sr ( sc + l ) ) ( TokAlphabetic tok )
|
||||
: go sr ( sc + l ) rest
|
||||
-- Numeric identifier.
|
||||
| Just ( locTok@Located { location = Span { endRow, endCol } }, rest ) <- tokenizeNumeric sr sc t
|
||||
-> locTok
|
||||
: go endRow endCol rest
|
||||
-- Wildcard.
|
||||
| '_' <- x
|
||||
, let
|
||||
( ys, rest ) = Text.span ( \case { '_' -> True; y | Char.isAlphaNum y -> True; _ -> False } ) xs
|
||||
tok :: Text
|
||||
tok = x `Text.cons` ys
|
||||
l = Text.length tok
|
||||
-> Located ( Span sr sc sr ( sc + l ) ) ( TokWildcard tok )
|
||||
: go sr ( sc + l ) rest
|
||||
-- Symbolic identifier.
|
||||
| Char.isSymbol x || Char.isPunctuation x
|
||||
, let
|
||||
( ys, rest ) = Text.break ( \ c -> isSpecial c || Char.isSpace c || Char.isAlphaNum c ) xs
|
||||
tok = x `Text.cons` ys
|
||||
l = Text.length tok
|
||||
-> Located ( Span sr sc sr ( sc + l ) ) ( TokSymbolic tok )
|
||||
: go sr ( sc + l ) rest
|
||||
-- Fallback.
|
||||
| let
|
||||
( ys, rest ) = Text.break ( \ c -> isSpecial c || Char.isSpace c ) xs
|
||||
tok = x `Text.cons` ys
|
||||
l = Text.length tok
|
||||
-> Located ( Span sr sc sr ( sc + l ) ) ( OtherTok tok )
|
||||
: go sr ( sc + l ) rest
|
||||
|
||||
-- Tokenize a numeric literal (without any leading sign).
|
||||
tokenizeNumeric :: Int -> Int -> Text -> Maybe ( Located Token, Text )
|
||||
tokenizeNumeric sr sc t = case Text.span Char.isDigit t of
|
||||
-- Integer part of the mantissa.
|
||||
( integ, rest )
|
||||
| not ( Text.null integ )
|
||||
-> case Text.uncons rest of
|
||||
Just ( c, rest' )
|
||||
-- Fraction.
|
||||
| c == '.'
|
||||
->
|
||||
-- Fractional part of the mantissa.
|
||||
let ( frac, rest'' ) = Text.span Char.isDigit rest'
|
||||
in case Text.uncons rest'' of
|
||||
Just ( c', rest''' )
|
||||
-- Fraction followed by exponent.
|
||||
| c' == 'e' || c' == 'E'
|
||||
, Just ( expo, rest'''' ) <- spanExponent rest'''
|
||||
, Right ( r, leftover ) <- Text.Read.double ( integ <> "." <> frac <> "e" <> expo )
|
||||
, Text.null leftover
|
||||
, let
|
||||
l = Text.length integ + 1 + Text.length frac + 1 + Text.length expo
|
||||
-> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest'''' )
|
||||
-- Simple fraction (no exponent).
|
||||
_ | Right ( r, leftover ) <- Text.Read.double ( integ <> "." <> frac )
|
||||
, Text.null leftover
|
||||
, let
|
||||
l = Text.length integ + 1 + Text.length frac
|
||||
-> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest'' )
|
||||
_ -> Nothing
|
||||
-- Positive integer followed by exponent.
|
||||
| c == 'e' || c == 'E'
|
||||
, Just ( expo, rest'' ) <- spanExponent rest'
|
||||
, Right ( r, leftover ) <- Text.Read.double ( integ <> "e" <> expo )
|
||||
, Text.null leftover
|
||||
, let
|
||||
l = Text.length integ + 1 + Text.length expo
|
||||
-> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest'' )
|
||||
-- Simple positive integer (no fractional part or exponent).
|
||||
_ | Right ( r, leftover ) <- Text.Read.double integ
|
||||
, Text.null leftover
|
||||
, let
|
||||
l = Text.length integ
|
||||
-> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest )
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
|
||||
spanExponent :: Text -> Maybe ( Text, Text )
|
||||
spanExponent t = case Text.uncons t of
|
||||
Just ( x, xs )
|
||||
| x == '+' || x == '-' || Char.isDigit x
|
||||
, let
|
||||
( ds, rest ) = Text.span Char.isDigit xs
|
||||
-> Just ( Text.cons x ds, rest )
|
||||
_ -> Nothing
|
42
src/app/MetaBrush/MetaParameter/PrimOp.hs
Normal file
42
src/app/MetaBrush/MetaParameter/PrimOp.hs
Normal file
|
@ -0,0 +1,42 @@
|
|||
{-# LANGUAGE DerivingStrategies #-}
|
||||
|
||||
module MetaBrush.MetaParameter.PrimOp where
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Vector2D
|
||||
( Point2D(..) )
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Operations supported by the DSL.
|
||||
|
||||
data Orientation = CCW | CW
|
||||
deriving stock Show
|
||||
|
||||
kappa :: Double
|
||||
kappa = 0.5519150244935105707435627227925
|
||||
-- root of (Sqrt[2] (4 + 3 κ) - 16) (2 - 3 κ)^2 - 8 (1 - 3 κ) Sqrt[8 - 24 κ + 12 κ^2 + 8 κ^3 + 3 κ^4]
|
||||
|
||||
rotate_around_by :: Orientation -> Point2D Double -> Point2D Double -> Double -> Point2D Double
|
||||
rotate_around_by ori ( Point2D px py ) ( Point2D cx cy ) theta =
|
||||
translate_by ( rotate_by ori ( Point2D ( px - cx ) ( py - cy ) ) theta ) ( Point2D cx cy )
|
||||
rotate_by :: Orientation -> Point2D Double -> Double -> Point2D Double
|
||||
rotate_by CCW ( Point2D px py ) theta = Point2D ( c * px - s * py ) ( c * py + s * px )
|
||||
where
|
||||
c, s :: Double
|
||||
c = cos theta
|
||||
s = sin theta
|
||||
rotate_by CW p theta = rotate_by CCW p ( -theta )
|
||||
|
||||
scale_around_by :: Point2D Double -> Point2D Double -> Point2D Double -> Point2D Double
|
||||
scale_around_by ( Point2D px py ) ( Point2D cx cy ) ( Point2D rx ry ) = Point2D ( rx * ( px - cx ) + cx ) ( ry * ( py - cy ) + cy )
|
||||
scale_by :: Point2D Double -> Point2D Double -> Point2D Double
|
||||
scale_by ( Point2D px py ) ( Point2D rx ry ) = Point2D ( rx * px ) ( ry * py )
|
||||
|
||||
shear_from_by :: Point2D Double -> Point2D Double -> Point2D Double -> Point2D Double
|
||||
shear_from_by ( Point2D px py ) ( Point2D cx cy ) v =
|
||||
translate_by ( shear_by ( Point2D ( px - cx ) ( py - cy ) ) v ) ( Point2D cx cy )
|
||||
shear_by :: Point2D Double -> Point2D Double -> Point2D Double
|
||||
shear_by ( Point2D px py ) ( Point2D vx vy ) = undefined
|
||||
|
||||
translate_by :: Point2D Double -> Point2D Double -> Point2D Double
|
||||
translate_by ( Point2D px py ) ( Point2D tx ty ) = Point2D ( px + tx ) ( py + ty )
|
240
src/app/MetaBrush/MetaParameter/Rename.hs
Normal file
240
src/app/MetaBrush/MetaParameter/Rename.hs
Normal file
|
@ -0,0 +1,240 @@
|
|||
{-# LANGUAGE BlockArguments #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE EmptyCase #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module MetaBrush.MetaParameter.Rename
|
||||
( rename, MonadRn, RnM
|
||||
, RnMessage, RnError
|
||||
, RnState, emptyRnState
|
||||
, Env(..), UniqueName(..)
|
||||
)
|
||||
where
|
||||
|
||||
-- base
|
||||
import Data.Foldable
|
||||
( for_ )
|
||||
import GHC.Generics
|
||||
( Generic )
|
||||
|
||||
-- containers
|
||||
import Data.Map.Strict
|
||||
( Map )
|
||||
import qualified Data.Map.Strict as Map
|
||||
( lookup )
|
||||
|
||||
-- dlist
|
||||
import Data.DList
|
||||
( DList )
|
||||
import qualified Data.DList as DList
|
||||
( singleton )
|
||||
|
||||
-- generic-lens
|
||||
import Data.Generics.Product.Fields
|
||||
( field' )
|
||||
|
||||
-- lens
|
||||
import Control.Lens
|
||||
( assign, at, modifying, use )
|
||||
|
||||
-- mtl
|
||||
import Control.Monad.State
|
||||
( MonadState(..) )
|
||||
import Control.Monad.Writer
|
||||
( MonadWriter(..) )
|
||||
|
||||
-- text
|
||||
import Data.Text
|
||||
( Text )
|
||||
|
||||
-- transformers
|
||||
import Control.Monad.Trans.RWS.CPS
|
||||
( RWST )
|
||||
|
||||
-- MetaBrush
|
||||
import Math.Bezier.Spline
|
||||
( KnownSplineType(bitraverseSpline), bitraverseCurve )
|
||||
import MetaBrush.MetaParameter.AST
|
||||
( Located(..)
|
||||
, Pass(P,Rn), Name, UniqueName(..), X_With(..)
|
||||
, Term(..), Decl(..), Pat(..)
|
||||
)
|
||||
import MetaBrush.MetaParameter.Parse
|
||||
( ) -- AST type family instances for parsing pass
|
||||
import MetaBrush.Unique
|
||||
( UniqueSupply, MonadUnique(freshUnique)
|
||||
, Unique
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Renaming pass.
|
||||
|
||||
rename :: MonadRn m => Term P '() -> m ( Term Rn '() )
|
||||
rename ( f :$ a ) = (:$) <$> locally ( rename f ) <*> locally ( rename a )
|
||||
rename ( Var locv@( Located l v ) ) = do
|
||||
mbRes <- use ( field' @"localEnv" . field' @"rnLocalVars" . at v )
|
||||
case mbRes of
|
||||
Nothing -> do
|
||||
rnError ( OutOfScope locv )
|
||||
uniq' <- freshUnique
|
||||
pure $ Var ( Located l ( UniqueName v uniq' ) )
|
||||
Just uniq ->
|
||||
pure $ Var ( Located l ( UniqueName v uniq ) )
|
||||
rename ( Lit l a ) = pure ( Lit l a )
|
||||
rename ( Op locs nm op ) = pure ( Op locs nm op )
|
||||
rename ( Point locs a b ) = Point locs <$> locally ( rename a ) <*> locally ( rename b )
|
||||
rename ( Line locs p1 p2 ) = Line locs <$> locally ( rename p1 ) <*> locally ( rename p2 )
|
||||
rename ( Bez2 locs p1 p2 p3 ) = Bez2 locs <$> locally ( rename p1 ) <*> locally ( rename p2 ) <*> locally ( rename p3 )
|
||||
rename ( Bez3 locs p1 p2 p3 p4 ) = Bez3 locs <$> locally ( rename p1 ) <*> locally ( rename p2 ) <*> locally ( rename p3 ) <*> locally ( rename p4 )
|
||||
rename ( PolyBez locs spline ) = PolyBez locs <$>
|
||||
bitraverseSpline
|
||||
( const $ bitraverseCurve pure ( const $ locally . rename ) )
|
||||
( locally . rename )
|
||||
spline
|
||||
rename ( Let locs decls body ) = do
|
||||
decls' <- renameDecls decls
|
||||
body' <- rename body
|
||||
pure ( Let locs decls' body' )
|
||||
rename ( With locs ( P_With decls ) conds body ) = do
|
||||
decls' <- renameDecls decls
|
||||
conds' <- traverse ( locally . rename ) conds
|
||||
body' <- rename body
|
||||
pure ( With locs ( Rn_With decls' ) conds' body' )
|
||||
|
||||
renameDecls :: forall m. MonadRn m => [ Decl P ] -> m [ Decl Rn ]
|
||||
renameDecls decls = do
|
||||
outerLocalVars <- use ( field' @"localEnv" . field' @"rnLocalVars" )
|
||||
assign ( field' @"localEnv" . field' @"rnLocalVars" ) mempty
|
||||
decls' <- go outerLocalVars decls
|
||||
pure decls'
|
||||
|
||||
where
|
||||
|
||||
go :: Map Text Unique -> [ Decl P ] -> m [ Decl Rn ]
|
||||
go outerLocalVars ( Decl loc lhs rhs : next ) = do
|
||||
-- Collect all the declarations from the left-hand sides.
|
||||
lhs' <- renameLhs outerLocalVars lhs
|
||||
next' <- go outerLocalVars next
|
||||
-- Now rename each right-hand side with the full LHS info.
|
||||
rhs' <- locally ( rename rhs )
|
||||
pure $ Decl loc lhs' rhs' : next'
|
||||
go outerLocalVars [] = do
|
||||
-- Finished handling all the left-hand sides:
|
||||
-- add all the declared names to the existing (outer) names,
|
||||
-- shadowing the outer names if necessary.
|
||||
modifying ( field' @"localEnv" . field' @"rnLocalVars" ) ( <> outerLocalVars )
|
||||
pure []
|
||||
|
||||
renameLhs :: Map Text Unique -> Pat P '() -> m ( Pat Rn '() )
|
||||
renameLhs outerLocalVars ( PName locPat@( Located l nm ) ) = do
|
||||
mbUniq <- use ( field' @"localEnv" . field' @"rnLocalVars" . at nm )
|
||||
case mbUniq of
|
||||
Just uniq -> do
|
||||
rnError ( DuplicateDecl uniq locPat )
|
||||
uniq' <- freshUnique
|
||||
pure $ PName ( Located l ( UniqueName nm uniq' ) )
|
||||
Nothing -> do
|
||||
let
|
||||
mbPrevUniq :: Maybe Unique
|
||||
mbPrevUniq = Map.lookup nm outerLocalVars
|
||||
uniq <- freshUnique
|
||||
for_ mbPrevUniq \ prevUniq -> do
|
||||
rnWarning ( NameShadowing prevUniq ( Located l ( UniqueName nm uniq ) ) )
|
||||
assign ( field' @"localEnv" . field' @"rnLocalVars" . at nm ) ( Just uniq )
|
||||
assign ( field' @"globalEnv" . field' @"rnGlobalVars" . at uniq ) ( Just locPat )
|
||||
pure $ PName ( Located l ( UniqueName nm uniq ) )
|
||||
renameLhs outerLocalVars ( PPoint l p1 p2 ) = PPoint l <$> renameLhs outerLocalVars p1 <*> renameLhs outerLocalVars p2
|
||||
renameLhs _ ( PWild wild ) = pure ( PWild wild )
|
||||
renameLhs outerLocalVars ( AsPat atLoc locName pat ) = do
|
||||
name' <- renameLhs outerLocalVars ( PName locName )
|
||||
case name' of
|
||||
PName locName' -> do
|
||||
pat' <- renameLhs outerLocalVars pat
|
||||
pure $ AsPat atLoc locName' pat'
|
||||
_ -> error "renameLHS: internal error"
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Renamer-specific data and instances.
|
||||
|
||||
data RnLocalEnv
|
||||
= RnLocalEnv
|
||||
{ rnLocalVars :: !( Map Text Unique ) }
|
||||
deriving stock ( Show, Generic )
|
||||
|
||||
data RnGlobalEnv
|
||||
= RnGlobalEnv
|
||||
{ rnGlobalVars :: !( Map Unique ( Located Text ) ) }
|
||||
deriving stock ( Show, Generic )
|
||||
|
||||
data Env global local
|
||||
= Env
|
||||
{ globalEnv :: !global
|
||||
, localEnv :: !local
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
|
||||
type RnState = Env RnGlobalEnv RnLocalEnv
|
||||
|
||||
emptyRnState :: RnState
|
||||
emptyRnState = Env ( RnGlobalEnv mempty ) ( RnLocalEnv mempty )
|
||||
|
||||
locally :: MonadState ( Env global local ) m => m a -> m a
|
||||
locally action = do
|
||||
Env { localEnv } <- get
|
||||
res <- action
|
||||
assign ( field' @"localEnv" ) localEnv
|
||||
pure res
|
||||
|
||||
data RnMessage
|
||||
= RnWarningMessage
|
||||
{ rnWarningMessage :: !RnWarning
|
||||
, rnMessageState :: !RnState
|
||||
}
|
||||
| RnErrorMessage
|
||||
{ rnErrorMessage :: !RnError
|
||||
, rnMessageState :: !RnState
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
|
||||
data RnError
|
||||
= OutOfScope !( Located Text )
|
||||
| DuplicateDecl
|
||||
{ prevDecl :: !Unique
|
||||
, dupDecl :: !( Located Text )
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
|
||||
data RnWarning
|
||||
= NameShadowing
|
||||
{ shadowedUnique :: !Unique
|
||||
, shadowingName :: !( Located UniqueName )
|
||||
}
|
||||
deriving stock ( Show, Generic )
|
||||
|
||||
rnError
|
||||
:: ( MonadState RnState m , MonadWriter ( DList RnMessage ) m )
|
||||
=> RnError -> m ()
|
||||
rnError err = do
|
||||
st <- get
|
||||
tell ( DList.singleton $ RnErrorMessage err st )
|
||||
|
||||
rnWarning
|
||||
:: ( MonadState RnState m , MonadWriter ( DList RnMessage ) m )
|
||||
=> RnWarning -> m ()
|
||||
rnWarning warn = do
|
||||
st <- get
|
||||
tell ( DList.singleton $ RnWarningMessage warn st )
|
||||
|
||||
type RnM = RWST UniqueSupply ( DList RnMessage ) RnState IO
|
||||
type MonadRn m = ( MonadUnique m, MonadState RnState m, MonadWriter ( DList RnMessage ) m )
|
||||
|
||||
type instance Name Rn = UniqueName
|
446
src/app/MetaBrush/MetaParameter/TypeCheck.hs
Normal file
446
src/app/MetaBrush/MetaParameter/TypeCheck.hs
Normal 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 )
|
||||
-}
|
|
@ -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 )
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
@ -16,9 +16,9 @@ data Tool
|
|||
instance Show Tool
|
||||
|
||||
data Mode
|
||||
= Path
|
||||
| Brush
|
||||
| Meta
|
||||
= PathMode
|
||||
| BrushMode
|
||||
| MetaMode
|
||||
|
||||
instance Show Mode
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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.
|
||||
--
|
||||
|
|
|
@ -147,7 +147,7 @@ ddist ( Bezier {..} ) c = [ a3, a2, a1, a0 ]
|
|||
closestPoint
|
||||
:: forall v r p. ( Torsor v p, Inner r v, RealFloat r, Prim r )
|
||||
=> Bezier p -> p -> ArgMin r ( r, p )
|
||||
closestPoint pts@( Bezier {..} ) c = pickClosest ( 0 :| 1 : roots )
|
||||
closestPoint pts c = pickClosest ( 0 :| 1 : roots )
|
||||
where
|
||||
roots :: [ r ]
|
||||
roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots 2000 $ ddist @v pts c )
|
||||
|
|
523
src/lib/Math/Bezier/Spline.hs
Normal file
523
src/lib/Math/Bezier/Spline.hs
Normal 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
|
@ -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
|
|
@ -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 )
|
||||
|
|
Loading…
Reference in a new issue