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

framework for brush differentiation

Browse source
This commit is contained in:
sheaf 2023-01-08 17:16:14 +01:00
parent 4e5c848883
commit 5bd4e7f4cf
56 changed files with 1319 additions and 1458 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

43
MetaBrush.cabal
View file

@ -50,6 +50,44 @@ common common
, transformers
^>= 0.5.6.2
default-extensions:
BangPatterns
BlockArguments
ConstraintKinds
DataKinds
DeriveAnyClass
DeriveTraversable
DeriveGeneric
DerivingVia
DuplicateRecordFields
FlexibleContexts
FlexibleInstances
FunctionalDependencies
GADTs
GeneralisedNewtypeDeriving
ImplicitParams
InstanceSigs
LambdaCase
LexicalNegation
MagicHash
MultiWayIf
NamedFieldPuns
PatternSynonyms
QuantifiedConstraints
RankNTypes
RecordWildCards
RecursiveDo
ScopedTypeVariables
StandaloneDeriving
StandaloneKindSignatures
TupleSections
TypeApplications
TypeFamilies
TypeOperators
UnboxedTuples
UndecidableInstances
ViewPatterns
ghc-options:
-O1
-fexpose-all-unfoldings
@ -132,11 +170,12 @@ library splines
, Math.Bezier.Spline
, Math.Bezier.Stroke
, Math.Epsilon
, Math.Linear
, Math.Linear.Dual
, Math.Linear.Solve
, Math.Module
, Math.Orientation
, Math.Roots
, Math.Vector2D
build-depends:
bifunctors
@ -170,8 +209,6 @@ library metabrushes
, MetaBrush.Document.History
, MetaBrush.Document.Serialise
, MetaBrush.Document.SubdivideStroke
, MetaBrush.DSL.Interpolation
, MetaBrush.DSL.Types
, MetaBrush.Records
, MetaBrush.Serialisable
, MetaBrush.Unique

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

@ -1,19 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module MetaBrush.Action where
@ -104,7 +89,7 @@ import Math.Bezier.Stroke
( CachedStroke(..), invalidateCache )
import Math.Module
( Module((*^)), quadrance )
import Math.Vector2D
import Math.Linear
( Point2D(..), Vector2D(..) )
import MetaBrush.Context
( UIElements(..), Variables(..)

4
src/app/MetaBrush/Action.hs-boot
View file

@ -1,5 +1,3 @@
{-# LANGUAGE MonoLocalBinds #-}
module MetaBrush.Action where
-- base
@ -18,7 +16,7 @@ import Data.Text
( Text )
-- MetaBrush
import Math.Vector2D
import Math.Linear
( Point2D, Vector2D )
import {-# SOURCE #-} MetaBrush.Context
( UIElements, Variables )

23
src/app/MetaBrush/Application.hs
View file

@ -1,13 +1,5 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Application
( runApplication )
@ -86,8 +78,8 @@ import Math.Bezier.Spline
( Spline(..), Curves(..), Curve(..), NextPoint(..) )
import Math.Bezier.Stroke
( invalidateCache )
import Math.Vector2D
( Point2D(..) )
import Math.Linear
( Point2D(..), ℝ(..) )
import MetaBrush.Action
( ActionOrigin(..) )
import qualified MetaBrush.Asset.Brushes as Asset.Brushes
@ -113,9 +105,6 @@ import MetaBrush.Document.Update
import MetaBrush.Event
( handleEvents )
import MetaBrush.Records
( Rec, I(..) )
import qualified MetaBrush.Records as Rec
( empty, insert )
import MetaBrush.Render.Document
( blankRender, getDocumentRender )
import MetaBrush.Render.Rulers
@ -184,10 +173,8 @@ runApplication application = do
)
]
where
mkPoint :: Point2D Double -> Double -> Double -> Double -> PointData ( Rec Asset.Brushes.EllipseBrushFields )
mkPoint pt a b phi = PointData pt Normal
( Rec.insert @"a" (I a) $ Rec.insert @"b" (I b) $ Rec.insert @"phi" (I phi) $ Rec.empty )
mkPoint :: Point2D Double -> Double -> Double -> Double -> PointData ( Record Asset.Brushes.EllipseBrushFields )
mkPoint pt a b phi = PointData pt Normal ( MkR $ ℝ3 a b phi )
recomputeStrokesTVar <- STM.newTVarIO @Bool False
documentRenderTVar <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () )
@ -225,7 +212,7 @@ runApplication application = do
display <- GTK.rootGetDisplay window
dataPath <- Directory.canonicalizePath =<< Cabal.getDataDir
themePath <- ( Directory.canonicalizePath =<< Cabal.getDataFileName "theme.css" )
themePath <- Directory.canonicalizePath =<< Cabal.getDataFileName "theme.css"
cssProvider <- GTK.cssProviderNew
GTK.cssProviderLoadFromPath cssProvider themePath
GTK.styleContextAddProviderForDisplay display cssProvider 1000

4
src/app/MetaBrush/Asset/CloseTabButton.hs
View file

@ -1,7 +1,3 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE RecordWildCards #-}
module MetaBrush.Asset.CloseTabButton
( drawCloseTabButton )
where

7
src/app/MetaBrush/Asset/Colours.hs
View file

@ -1,9 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}

2
src/app/MetaBrush/Asset/Cursor.hs
View file

@ -1,5 +1,3 @@
{-# LANGUAGE NamedFieldPuns #-}
module MetaBrush.Asset.Cursor
( drawCursor, drawCursorIcon )
where

3
src/app/MetaBrush/Asset/InfoBar.hs
View file

@ -1,6 +1,3 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NegativeLiterals #-}
module MetaBrush.Asset.InfoBar
( drawMagnifier, drawTopLeftCornerRect )
where

2
src/app/MetaBrush/Asset/Logo.hs
View file

@ -1,5 +1,3 @@
{-# LANGUAGE NamedFieldPuns #-}
module MetaBrush.Asset.Logo
( drawLogo )
where

3
src/app/MetaBrush/Asset/TickBox.hs
View file

@ -1,6 +1,3 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NegativeLiterals #-}
module MetaBrush.Asset.TickBox
( drawBox, drawTickedBox )
where

3
src/app/MetaBrush/Asset/Tools.hs
View file

@ -1,6 +1,3 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
module MetaBrush.Asset.Tools
( drawBrush, drawBug, drawMeta, drawPath, drawPen )
where

2
src/app/MetaBrush/Asset/WindowIcons.hs
View file

@ -1,5 +1,3 @@
{-# LANGUAGE NamedFieldPuns #-}
module MetaBrush.Asset.WindowIcons
( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
where

5
src/app/MetaBrush/Context.hs
View file

@ -1,6 +1,3 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
module MetaBrush.Context
( UIElements(..), Variables(..)
, LR(..), Modifier(..), modifierKey
@ -44,7 +41,7 @@ import Data.HashMap.Strict
-- MetaBrush
import Math.Bezier.Cubic.Fit
( FitParameters )
import Math.Vector2D
import Math.Linear
( Point2D )
import {-# SOURCE #-} MetaBrush.Action
( ActionName )

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

@ -1,19 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module MetaBrush.Document.Selection
( SelectionMode(..), selectionMode
@ -108,9 +93,9 @@ import Math.Bezier.Spline
import Math.Bezier.Stroke
( CachedStroke(..), invalidateCache )
import Math.Module
( lerp, squaredNorm, closestPointOnSegment )
import Math.Vector2D
( Point2D(..), Vector2D(..), Segment(..) )
( Module, lerp, squaredNorm, closestPointOnSegment )
import Math.Linear
( Point2D(..), Vector2D(..), Segment(..), T(..) )
import {-# SOURCE #-} MetaBrush.Context
( Modifier(..) )
import MetaBrush.Document
@ -122,8 +107,6 @@ import MetaBrush.Document
)
import {-# SOURCE #-} MetaBrush.Document.Update
( DocChange(..) )
import MetaBrush.DSL.Interpolation
( Interpolatable(Diff) )
import MetaBrush.Unique
( Unique )
import MetaBrush.Util
@ -723,7 +706,7 @@ dragUpdate p0 p PointDrag _ doc = do
changeText =
"Translate " <> Text.intercalate " and " ( catMaybes [ ppMv, cpMv ] )
<> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes"
-> Just ( HistoryChange { newDocument, changeText } )
-> Just ( HistoryChange { newDocument, changeText } )
dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmentParameter } ) alternateMode doc =
let
( newDocument, mbStrokeName ) =
@ -753,7 +736,7 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen
where
updateSpline
:: forall clo pointParams
. ( KnownSplineType clo, Interpolatable pointParams )
. ( KnownSplineType clo, Module Double ( T pointParams ), Torsor ( T pointParams ) pointParams )
=> StrokeSpline clo pointParams
-> State ( Maybe Text ) ( StrokeSpline clo pointParams )
updateSpline
@ -785,16 +768,16 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen
LineTo ( NextPoint sp1 ) dat -> do
let
bez2 :: Quadratic.Bezier ( PointData pointParams )
bez2 = Quadratic.Bezier sp0 ( lerp @( DiffPointData ( Diff pointParams ) ) dragSegmentParameter sp0 sp1 ) sp1
bez2 = Quadratic.Bezier sp0 ( lerp @( DiffPointData ( T pointParams ) ) dragSegmentParameter sp0 sp1 ) sp1
if alternateMode
then quadraticDragCurve dat bez2
else cubicDragCurve dat ( Cubic.fromQuadratic @( DiffPointData ( Diff pointParams ) ) bez2 )
else cubicDragCurve dat ( Cubic.fromQuadratic @( DiffPointData ( T pointParams ) ) bez2 )
Bezier2To sp1 ( NextPoint sp2 ) dat -> do
let
bez2 :: Quadratic.Bezier ( PointData pointParams )
bez2 = Quadratic.Bezier sp0 sp1 sp2
if alternateMode
then cubicDragCurve dat $ Cubic.fromQuadratic @( DiffPointData ( Diff pointParams ) ) bez2
then cubicDragCurve dat $ Cubic.fromQuadratic @( DiffPointData ( T pointParams ) ) bez2
else quadraticDragCurve dat ( Quadratic.Bezier sp0 sp1 sp2 )
Bezier3To sp1 sp2 ( NextPoint sp3 ) dat -> do
let
@ -804,7 +787,7 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen
then quadraticDragCurve dat
( Quadratic.Bezier
sp0
( Cubic.bezier @( DiffPointData ( Diff pointParams ) ) bez3 dragSegmentParameter )
( Cubic.bezier @( DiffPointData ( T pointParams ) ) bez3 dragSegmentParameter )
sp3
)
else cubicDragCurve dat bez3

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

@ -1,11 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Document.Update
( activeDocument, withActiveDocument

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

@ -1,9 +1,3 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Event
( handleEvents )
where
@ -29,7 +23,7 @@ import qualified Control.Concurrent.STM.TVar as STM
( readTVarIO )
-- MetaBrush
import Math.Vector2D
import Math.Linear
( Point2D(..), Vector2D(..) )
import MetaBrush.Action
( HandleAction(..)

8
src/app/MetaBrush/GTK/Util.hs
View file

@ -1,11 +1,3 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.GTK.Util
( withRGBA, showRGBA
, widgetAddClasses, widgetAddClass

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

@ -1,22 +1,5 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module MetaBrush.Render.Document
( getDocumentRender, blankRender )
@ -87,8 +70,8 @@ import Math.Bezier.Stroke
( CachedStroke(..), invalidateCache
, computeStrokeOutline
)
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import Math.Linear
( Point2D(..), Vector2D(..), T(..) )
import MetaBrush.Asset.Colours
( Colours, ColourRecord(..) )
import MetaBrush.Brush
@ -116,15 +99,7 @@ import MetaBrush.Document.Serialise
( ) -- 'Serialisable' instances
import MetaBrush.Document.Update
( DocChange(..) )
import MetaBrush.DSL.Interpolation
( Interpolatable, DRec )
import MetaBrush.Records
( Record, Rec, WithParams(..)
, I(..), (:*:)(..)
, MyIntersection (..), myIntersect
)
import qualified MetaBrush.Records as Rec
( map )
import MetaBrush.UI.ToolBar
( Mode(..) )
import MetaBrush.Unique
@ -205,9 +180,9 @@ getDocumentRender
, Just finalPoint <- mbFinalPoint
, let
previewStroke :: Stroke
previewStroke = withAnchorBrushData anchor doc \ mbBrush ( pointData :: Rec pointFields ) ->
previewStroke = withAnchorBrushData anchor doc \ mbBrush ( pointData :: Record pointFields ) ->
let
previewSpline :: Spline Open ( CachedStroke RealWorld ) ( PointData ( Rec pointFields ) )
previewSpline :: Spline Open ( CachedStroke RealWorld ) ( PointData ( Record pointFields ) )
previewSpline = catMaybesSpline ( invalidateCache undefined )
( PointData p0 Normal pointData )
( do
@ -295,7 +270,7 @@ instance NFData StrokeRenderData where
strokeRenderData :: FitParameters -> Stroke -> Maybe ( ST RealWorld StrokeRenderData )
strokeRenderData fitParams
( Stroke
{ strokeSpline = spline :: StrokeSpline clo ( Rec pointFields )
{ strokeSpline = spline :: StrokeSpline clo ( Record pointFields )
, strokeBrush = ( strokeBrush :: Maybe ( Brush brushFields ) )
, ..
}
@ -306,32 +281,26 @@ strokeRenderData fitParams
{ defaultParams = brush_defaults
, withParams = brushFn
} <- fn
-> do
-- Use the handy 'intersect' function to do a computation
-- using only the relevant fields (which are the intersection
-- of the parameters along the stroke and the brush parameters).
--
-- See also MetaBrush.DSL.Eval.eval for how we interpret brush code
-- to obtain a brush function.
case myIntersect @Interpolatable @pointFields brush_defaults of
MyIntersection
{ myProject = project :: forall f. Record f pointFields -> Record (f :*: I) usedFields
, myInject } -> do
let
toUsedParams :: Rec pointFields -> Rec usedFields
toUsedParams given = Rec.map ( \ (x :*: _) -> x ) $ project @I given
embedUsedParams :: Rec usedFields -> Rec brushFields
embedUsedParams = myInject
-- Compute the outline using the brush function.
( outline, fitPts ) <-
computeStrokeOutline @( DRec usedFields ) @clo @( Rec usedFields )
fitParams ( toUsedParams . brushParams ) ( brushFn . embedUsedParams ) spline
pure $
StrokeWithOutlineRenderData
{ strokeDataSpline = spline
, strokeOutlineData = ( outline, fitPts )
, strokeBrushFunction = brushFn . embedUsedParams . toUsedParams
}
-> -- This is the key place where we need to perform impedance matching
-- between the collection of parameters supplied along a strong and
-- the collection of parameters expected by the brush.
case intersect @pointFields @brushFields of
Intersection
{ inject
, project = toUsedParams :: Record pointFields -> Record usedFields }
-> do
let embedUsedParams r = inject r brush_defaults
-- Compute the outline using the brush function.
( outline, fitPts ) <-
computeStrokeOutline @( T ( Record usedFields) ) @clo
fitParams ( toUsedParams . brushParams ) ( brushFn . embedUsedParams ) spline
pure $
StrokeWithOutlineRenderData
{ strokeDataSpline = spline
, strokeOutlineData = ( outline, fitPts )
, strokeBrushFunction = brushFn . embedUsedParams . toUsedParams
}
_ -> pure $
StrokeRenderData
{ strokeDataSpline = spline }
@ -443,7 +412,7 @@ renderBrushShape cols mbHoverContext zoom brushFn pt =
brushPts :: SplinePts Closed
brushPts = brushFn ( brushParams pt )
mbHoverContext' :: Maybe HoverContext
mbHoverContext' = Vector2D (-x) (-y) • mbHoverContext
mbHoverContext' = Vector2D -x -y • mbHoverContext
in
toAll do
Cairo.save
@ -467,12 +436,12 @@ drawPoint ( Colours {..} ) mbHover zoom PathPoint pt
Cairo.translate x y
Cairo.scale ( 3 / zoom ) ( 3 / zoom )
Cairo.moveTo 1 0
Cairo.lineTo 0.5 hsqrt3
Cairo.lineTo -0.5 hsqrt3
Cairo.lineTo -1 0
Cairo.lineTo -0.5 (-hsqrt3)
Cairo.lineTo 0.5 (-hsqrt3)
Cairo.moveTo 1 0
Cairo.lineTo 0.5 hsqrt3
Cairo.lineTo -0.5 hsqrt3
Cairo.lineTo -1 0
Cairo.lineTo -0.5 -hsqrt3
Cairo.lineTo 0.5 -hsqrt3
Cairo.closePath
Cairo.setLineWidth 1.0

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

@ -1,12 +1,3 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Render.Rulers
( renderRuler )
where
@ -51,7 +42,7 @@ import Control.Lens
( set, over )
-- MetaBrush
import Math.Vector2D
import Math.Linear
( Point2D(..), Vector2D(..) )
import MetaBrush.Action
( ActionOrigin(..) )
@ -255,7 +246,7 @@ renderRuler
Cairo.translate tickPosition top
Cairo.scale ( 1 / zoomFactor ) ( 1 / zoomFactor )
Cairo.moveTo 0 0
Cairo.lineTo 0 (-tickSize)
Cairo.lineTo 0 -tickSize
Cairo.stroke
when tickHasLabel do
Cairo.translate 2 -8.5

4
src/app/MetaBrush/Time.hs
View file

@ -57,8 +57,8 @@ pprSeconds ( h_name, m_name, s_name ) ( Seconds secs ) = pm <> absolute
where
pm :: String
pm
| secs <= (-1) = "-"
| otherwise = ""
| secs <= -1 = "-"
| otherwise = ""
h, r, m, s :: Int64
(h,r) = round ( abs secs ) `divMod` 3600
(m,s) = r `divMod` 60

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

@ -1,11 +1,3 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.UI.Coordinates
( toViewportCoordinates, closestPoint )
where
@ -37,7 +29,7 @@ import Math.Bezier.Spline
)
import Math.Module
( (*^), squaredNorm, closestPointOnSegment )
import Math.Vector2D
import Math.Linear
( Point2D(..), Vector2D(..), Segment(..) )
import MetaBrush.Document
( Stroke(..), PointData(..)

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

@ -1,10 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
module MetaBrush.UI.FileBar
( FileBar(..), FileBarTab(..)

10
src/app/MetaBrush/UI/InfoBar.hs
View file

@ -1,10 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
module MetaBrush.UI.InfoBar
( InfoBar(..), createInfoBar, updateInfoBar )
@ -41,7 +35,7 @@ import qualified Data.Text as Text
( pack )
-- MetaBrush
import Math.Vector2D
import Math.Linear
( Point2D(..) )
import MetaBrush.Asset.Colours
( Colours )

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

@ -1,14 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
module MetaBrush.UI.Menu where

1
src/app/MetaBrush/UI/Panels.hs
View file

@ -1,4 +1,3 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
module MetaBrush.UI.Panels

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

@ -1,8 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
module MetaBrush.UI.ToolBar
( Tool(..), Mode(..)

5
src/app/MetaBrush/UI/Viewport.hs
View file

@ -1,7 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module MetaBrush.UI.Viewport
( Viewport(..), ViewportEventControllers(..)

6
src/convert/Main.hs
View file

@ -1,6 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Main where
@ -41,7 +39,7 @@ import Math.Bezier.Spline
( Spline, SplineType(..) )
import Math.Bezier.Stroke
( CachedStroke(..) )
import Math.Vector2D
import Math.Linear
( Point2D(..) )
-- metabrushes
@ -113,7 +111,7 @@ test = trailToSpline @Diagrams.Line
mk_ellipse a phi =
Rec.insert @"a" (I $ 0.5 * a) $ Rec.insert @"b" (I 0.05) $ Rec.insert @"phi" (I phi) $ Rec.empty
up = arriving $ Linear.V2 0 (-1)
up = arriving $ Linear.V2 0 -1
main :: IO ()
main = case test of

15
src/convert/MetaBrush/MetaFont/Convert.hs
View file

@ -1,16 +1,3 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UnboxedTuples #-}
module MetaBrush.MetaFont.Convert
( MetaFontError(..)
, SomeSpline(..)
@ -78,7 +65,7 @@ import Math.Bezier.Stroke
( CachedStroke(..) )
import Math.Module
( lerp )
import Math.Vector2D
import Math.Linear
( Point2D(..), Vector2D(..) )
-- metabrushes

110
src/metabrushes/MetaBrush/Asset/Brushes.hs
View file

@ -1,15 +1,11 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
module MetaBrush.Asset.Brushes where
-- base
import Data.Coerce
( coerce )
-- containers
import qualified Data.Sequence as Seq
( fromList )
@ -26,16 +22,19 @@ import qualified Data.HashMap.Strict as HashMap
-- MetaBrush
import Math.Bezier.Spline
import Math.Vector2D
import Math.Linear
( Point2D(..), ℝ(..), T(..) )
import Math.Linear.Dual
( D, type (~>)(..), Var(var), konst )
import Math.Module
( Module((^+^), (*^)) )
import MetaBrush.Brush
( Brush(..), SomeBrush(..) )
import MetaBrush.Records
( Rec, WithParams(..), I(..) )
import qualified MetaBrush.Records as Rec
--------------------------------------------------------------------------------
type CircleBrushFields = '[ '("r", Double) ]
type CircleBrushFields = '[ "r" ]
lookupBrush :: Text -> Maybe SomeBrush
lookupBrush nm = HashMap.lookup nm brushes
@ -51,8 +50,8 @@ brushes = HashMap.fromList
-- | Root of @(Sqrt[2] (4 + 3 κ) - 16) (2 - 3 κ)^2 - 8 (1 - 3 κ) Sqrt[8 - 24 κ + 12 κ^2 + 8 κ^3 + 3 κ^4]@.
--
-- Used to approximate circles and ellipses with Bézier curves.
c :: Double
c = 0.5519150244935105707435627227925
κ :: Double
κ = 0.5519150244935105707435627227925
circleSpline :: (Double -> Double -> ptData) -> Spline 'Closed () ptData
circleSpline p =
@ -60,38 +59,71 @@ circleSpline p =
, splineCurves = ClosedCurves crvs lastCrv }
where
crvs = Seq.fromList
[ Bezier3To (p 1 c) (p c 1 ) (NextPoint (p 0 1 )) ()
, Bezier3To (p (-c) 1) (p (-1) c ) (NextPoint (p (-1) 0 )) ()
, Bezier3To (p (-1) (-c)) (p (-c) (-1)) (NextPoint (p 0 (-1))) ()
[ Bezier3To (p 1 κ) (p κ 1) (NextPoint (p 0 1)) ()
, Bezier3To (p -κ 1) (p -1 κ) (NextPoint (p -1 0)) ()
, Bezier3To (p -1 -κ) (p -κ -1) (NextPoint (p 0 -1)) ()
]
lastCrv =
Bezier3To (p c (-1)) (p 1 (-c)) BackToStart ()
Bezier3To (p κ -1) (p 1 -κ) BackToStart ()
circle :: Brush CircleBrushFields
circle = BrushData "circle" (WithParams deflts shape)
where
deflts :: Rec CircleBrushFields
deflts = Rec.insert @"r" (I 1) Rec.empty
shape :: Rec CircleBrushFields -> SplinePts 'Closed
shape params =
let !(I !r) = Rec.lookup @"r" params
in circleSpline ( \ x y -> Point2D (r * x) (r * y) )
deflts :: Record CircleBrushFields
deflts = MkR ( ℝ1 1 )
shape :: Record CircleBrushFields -> SplinePts 'Closed
shape ( MkR ( ℝ1 r ) ) =
circleSpline ( \ x y -> Point2D (r * x) (r * y) )
type EllipseBrushFields = '[ '("a", Double), '("b", Double), '("phi", Double) ]
type EllipseBrushFields = '[ "a", "b", "phi" ]
ellipse :: Brush EllipseBrushFields
ellipse = BrushData "ellipse" (WithParams deflts shape)
where
deflts :: Rec EllipseBrushFields
deflts = Rec.insert @"a" (I 1)
$ Rec.insert @"b" (I 1)
$ Rec.insert @"phi" (I 0)
$ Rec.empty
shape :: Rec EllipseBrushFields -> SplinePts 'Closed
shape params =
let
!(I !a ) = Rec.lookup @"a" params
!(I !b ) = Rec.lookup @"b" params
!(I !phi) = Rec.lookup @"phi" params
in circleSpline ( \ x y -> Point2D (a * x * cos phi - b * y * sin phi)
(b * y * cos phi + a * x * sin phi) )
deflts :: Record EllipseBrushFields
deflts = MkR ( ℝ3 1 1 0 )
shape :: Record EllipseBrushFields -> SplinePts 'Closed
shape ( MkR ( ℝ3 a b phi ) ) =
circleSpline ( \ x y -> Point2D (a * x * cos phi - b * y * sin phi)
(b * y * cos phi + a * x * sin phi) )
--------------------------------------------------------------------------------
-- Differentiable brushes.
circleSpline2 :: ( Double -> Double -> D ( ℝ 3 ) ptData ) -> D ( ℝ 3 ) ( Spline 'Closed () ptData )
circleSpline2 p = sequenceA $
Spline { splineStart = p 1 0
, splineCurves = ClosedCurves crvs lastCrv }
where
crvs = Seq.fromList
[ Bezier3To (p 1 κ) (p κ 1) (NextPoint (p 0 1)) ()
, Bezier3To (p -κ 1) (p -1 κ) (NextPoint (p -1 0)) ()
, Bezier3To (p -1 -κ) (p -κ -1) (NextPoint (p 0 -1)) ()
]
lastCrv =
Bezier3To (p κ -1) (p 1 -κ) BackToStart ()
ellipseBrush :: ℝ 3 ~> Spline 'Closed () ( ℝ 2 )
ellipseBrush =
D \ params ->
let a, b, phi :: D ( ℝ 3 ) Double
a = runD ( var @1 ) params
b = runD ( var @2 ) params
phi = runD ( var @3 ) params
mkPt :: Double -> Double -> D ( ℝ 3 ) ( ℝ 2 )
mkPt ( konst -> x ) ( konst -> y )
= fmap coerce
$ ( x * a * cos phi - y * b * sin phi ) *^ e_x
^+^ ( y * b * cos phi + x * a * sin phi ) *^ e_y
in circleSpline2 mkPt
where
e_x, e_y :: D ( ℝ 3 ) ( T ( ℝ 2 ) )
e_x = pure $ T $ ℝ2 1 0
e_y = pure $ T $ ℝ2 0 1
--ellipseArc :: ℝ 2 ~> ℝ 2
--ellipseArc = brushStroke ( linear myPath ) ( uncurryD $ fmap bezier3 myBrush )
--testing :: Double -> Double -> (# Double, T ( ℝ 2 ) #)
--testing :: Double -> Double -> (# Double, T (ℝ 2) #)
--testing t s = envelopeEquation ellipseArc t s

176
src/metabrushes/MetaBrush/Brush.hs
View file

@ -1,35 +1,24 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints#-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module MetaBrush.Brush
( Brush(..), SomeBrush(..)
, BrushFunction
, SomeFieldSType(..), SomeBrushFields(..)
, reflectBrushFieldsNoDups
( Brush(..), SomeBrush(..), BrushFunction
, PointFields, provePointFields, duplicates
)
where
-- base
import Control.Arrow
( second )
import Data.Proxy
( Proxy(..) )
import Data.Kind
( Type, Constraint )
import Data.List
( nub )
import Data.Typeable
( Typeable )
import GHC.Exts
( Proxy#, Any )
import Unsafe.Coerce
( unsafeCoerce )
( Proxy#, proxy# )
import GHC.TypeLits
( Symbol, someSymbolVal
, SomeSymbol(..)
)
-- deepseq
import Control.DeepSeq
@ -45,49 +34,34 @@ import Data.Text
import qualified Data.Text as Text
( unpack )
-- unordered-containers
import qualified Data.HashMap.Strict as HashMap
( fromList )
-- MetaBrush
import Math.Bezier.Spline
( SplineType(Closed), SplinePts)
import MetaBrush.Serialisable
( Serialisable )
import MetaBrush.DSL.Types
( STypeI, STypesI
, SomeSType(..), proveSomeSTypes
)
import MetaBrush.DSL.Interpolation
( Interpolatable(..) )
import MetaBrush.Records
( Record(MkR), Rec, AllFields
, WithParams(..)
, Dict(..)
, proveRecordDicts
)
import qualified MetaBrush.Records as Rec
( map )
import MetaBrush.Serialisable
import Math.Linear
--------------------------------------------------------------------------------
-- | A brush function: a function from a record of parameters to a closed spline.
type BrushFunction :: [ Symbol ] -> Type
type BrushFunction brushFields = WithParams brushFields (SplinePts Closed)
type Brush :: [ Symbol ] -> Type
data Brush brushFields where
BrushData
:: forall brushFields
. ( STypesI brushFields )
=>
{ brushName :: !Text
, brushFunction :: BrushFunction brushFields
}
. ( KnownSymbols brushFields
, Representable ( ℝ ( Length brushFields) )
, Typeable brushFields )
=> { brushName :: !Text
, brushFunction :: BrushFunction brushFields
}
-> Brush brushFields
data SomeBrush where
SomeBrush
:: STypesI brushFields
=> { someBrush :: !( Brush brushFields ) }
:: { someBrush :: !( Brush brushFields ) }
-> SomeBrush
instance Show ( Brush brushFields ) where
@ -107,62 +81,52 @@ instance Hashable ( Brush brushFields ) where
hashWithSalt salt ( BrushData { brushName } ) =
hashWithSalt salt brushName
--------------------------------------------------------------------------------
-- Instance dictionary passing machinery.
-- | 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, Interpolatable a, Serialisable a )
=> SomeFieldSType
data FieldSType a where
FieldSType
:: ( STypeI a, Show a, NFData a, Interpolatable a, Serialisable a )
=> FieldSType a
-- | Existential type for allowed fields of a brush record.
data SomeBrushFields where
SomeBrushFields
:: forall kvs rec
. ( STypesI kvs
, rec ~ Rec kvs
, Show rec, NFData rec
, Serialisable rec
, AllFields Interpolatable kvs
type PointFields :: [ Symbol ] -> Constraint
class ( KnownSymbols pointFields, Typeable pointFields
, Serialisable ( Record pointFields )
, Show ( Record pointFields )
, NFData ( Record pointFields )
, Interpolatable ( Record pointFields )
, Representable ( ℝ ( Length pointFields ) )
)
=> SomeBrushFields
=> PointFields pointFields where { }
instance ( KnownSymbols pointFields, Typeable pointFields
, Serialisable ( Record pointFields )
, Show ( Record pointFields )
, NFData ( Record pointFields )
, Interpolatable ( Record pointFields )
, Representable ( ℝ ( Length pointFields ) )
)
=> PointFields pointFields where { }
instance Show SomeBrushFields where
show ( SomeBrushFields @kvs ) = show ( Proxy @kvs )
-- | Assumes the input has no duplicates (doesn't check.)
provePointFields :: [ Text ] -> ( forall pointFields. PointFields pointFields => Proxy# pointFields -> r ) -> r
provePointFields fieldNames k =
case fieldNames of
[]
-> k ( proxy# @'[] )
[ f1 ]
| SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 )
-> k ( proxy# @'[ f1 ] )
[ f1, f2 ]
| SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 )
, SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 )
-> k ( proxy# @'[ f1, f2 ] )
[ f1, f2, f3 ]
| SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 )
, SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 )
, SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 )
-> k ( proxy# @'[ f1, f2, f3 ] )
_ -> error $ "I haven't defined ℝ " ++ show ( length fieldNames )
{-# INLINE provePointFields #-}
-- | Reflects a list of brush fields to the type level.
--
-- Assumes the input list has no duplicate field names,
-- but they don't have to be sorted.
reflectBrushFieldsNoDups :: [ ( Text, SomeFieldSType ) ] -> SomeBrushFields
reflectBrushFieldsNoDups elts =
let
mkSomeSType :: SomeFieldSType -> SomeSType
mkSomeSType (SomeFieldSType @a) = SomeSType @a
mkField :: SomeFieldSType -> FieldSType Any
mkField (SomeFieldSType @a) = unsafeCoerce $ FieldSType @a
in
proveSomeSTypes (map (second mkSomeSType) elts) \ ( _ :: Proxy# kvs ) ->
let
dictsRec :: Record FieldSType kvs
dictsRec = MkR (HashMap.fromList $ map (second mkField) elts)
showDicts :: Record (Dict Show) kvs
showDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @Show @a ) dictsRec
nfDataDicts :: Record (Dict NFData) kvs
nfDataDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @NFData @a ) dictsRec
serialisableDicts :: Record (Dict Serialisable) kvs
serialisableDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @Serialisable @a ) dictsRec
interpolatableDicts :: Record (Dict Interpolatable) kvs
interpolatableDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @Interpolatable @a ) dictsRec
in
proveRecordDicts @Show showDicts $
proveRecordDicts @NFData nfDataDicts $
proveRecordDicts @Serialisable serialisableDicts $
proveRecordDicts @Interpolatable interpolatableDicts $
SomeBrushFields @kvs
duplicates :: [ Text ] -> [ Text ]
duplicates = nub . duplicatesAcc [] []
where
duplicatesAcc :: [ Text ] -> [ Text ] -> [ Text ] -> [ Text ]
duplicatesAcc _ dups [] = dups
duplicatesAcc seen dups ( k : kvs )
| k `elem` seen
= duplicatesAcc seen ( k : dups ) kvs
| otherwise
= duplicatesAcc ( k : seen ) dups kvs

101
src/metabrushes/MetaBrush/DSL/Interpolation.hs
View file

@ -1,101 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module MetaBrush.DSL.Interpolation
( Interpolatable(..)
, D(..), DRec
)
where
-- base
import Data.Kind
( Type )
import Data.Monoid
( Sum )
import GHC.TypeLits
( Symbol )
-- acts
import Data.Act
( Act(..), Torsor(..) )
-- groups
import Data.Group
( Group(..) )
-- MetaBrush
import Math.Module
( Module(..) )
import Math.Vector2D
( Point2D, Vector2D )
import MetaBrush.Records
( Record, AllFields, I(..) )
import qualified MetaBrush.Records as Rec
( cpure, cmap, czipWith )
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
-- Linear/affine action for records.
type DRec :: [ ( Symbol, Type ) ] -> Type
type DRec = Record D
newtype D a = D { getDiff :: Diff a }
deriving newtype instance Semigroup (Diff a) => Semigroup (D a)
deriving newtype instance Monoid (Diff a) => Monoid (D a)
deriving newtype instance Group (Diff a) => Group (D a)
instance Interpolatable a => Act (D a) (I a) where
act (D d) (I a) = I (act d a)
instance Interpolatable a => Torsor (D a) (I a) where
I a --> I b = D (a --> b)
instance Interpolatable a => Module Double (D a) where
origin = D origin
D a ^+^ D b = D (a ^+^ b)
d *^ D a = D (d *^ a)
instance AllFields Interpolatable kvs
=> Semigroup (Record D kvs) where
(<>) = Rec.czipWith @Interpolatable (<>)
instance AllFields Interpolatable kvs
=> Monoid (Record D kvs) where
mempty = Rec.cpure @Interpolatable mempty
instance AllFields Interpolatable kvs
=> Group (Record D kvs) where
invert = Rec.cmap @Interpolatable invert
instance AllFields Interpolatable kvs
=> Act (Record D kvs) (Record I kvs) where
act = Rec.czipWith @Interpolatable act
instance AllFields Interpolatable kvs
=> Torsor (Record D kvs) (Record I kvs) where
(-->) = Rec.czipWith @Interpolatable (-->)
instance AllFields Interpolatable kvs
=> Module Double (Record D kvs) where
origin = Rec.cpure @Interpolatable origin
(^+^) = Rec.czipWith @Interpolatable (^+^)
d *^ r = Rec.cmap @Interpolatable (d *^) r
instance AllFields Interpolatable kvs
=> Interpolatable (Record I kvs) where
type Diff (Record I kvs) = Record D kvs

129
src/metabrushes/MetaBrush/DSL/Types.hs
View file

@ -1,129 +0,0 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module MetaBrush.DSL.Types
( STypeI, STypesI
, SomeSType(..)
, eqTys
, someSTypes, proveSomeSTypes
) where
-- base
import Data.Kind
( Constraint, Type )
import Data.List
( intercalate )
import Data.Proxy
( Proxy(..) )
import Data.Typeable
( Typeable, eqT )
import Data.Type.Equality
( (:~:)(Refl) )
import GHC.Exts
( Proxy#, proxy# )
import GHC.TypeLits
( Symbol, KnownSymbol, SomeSymbol(..)
, symbolVal', sameSymbol, someSymbolVal )
-- text
import Data.Text
( Text )
import qualified Data.Text as Text
( pack, unpack )
-- MetaBrush
import MetaBrush.DSL.Interpolation
( Interpolatable )
--------------------------------------------------------------------------------
-- Types.
class ( Typeable ty, Interpolatable ty ) => STypeI ty where
instance ( Typeable ty, Interpolatable ty ) => STypeI ty where
type STypes :: [ (Symbol, Type) ] -> Type
data STypes kvs where
STyNil :: STypes '[]
STyCons :: ( kv ~ '( k, v ), KnownSymbol k, STypeI v, STypesI kvs ) => STypes ( kv ': kvs )
instance Show ( STypes kvs ) where
show sTypes = "'[" <> intercalate "," ( showSTypes sTypes ) <> "]"
showSTypes :: STypes kvs -> [ String ]
showSTypes STyNil = []
showSTypes sTyCons@STyCons
| ( _ :: STypes ( '( k, v ) ': tail_kvs ) ) <- sTyCons
= ( symbolVal' ( proxy# :: Proxy# k ) <> " := " <> show( Proxy @v ) ) : showSTypes ( sTypesI @tail_kvs )
type STypesI :: [ (Symbol, Type) ] -> Constraint
class STypesI kvs where
sTypesI :: STypes kvs
instance STypesI '[] where
sTypesI = STyNil
-- Warning: this instance is somewhat overly general as it doesn't check for lack of duplicates
instance ( kv ~ '( k, v ), KnownSymbol k, STypeI v, STypesI kvs ) => STypesI ( kv ': kvs ) where
sTypesI = STyCons
eqSTys :: STypes as -> STypes bs -> Maybe ( as :~: bs )
eqSTys STyNil STyNil = Just Refl
eqSTys sTyCons1@STyCons sTyCons2@STyCons
| ( _ :: STypes ( '( l1, v1 ) ': as' ) ) <- sTyCons1
, ( _ :: STypes ( '( l2, v2 ) ': bs' ) ) <- sTyCons2
, Just Refl <- sameSymbol ( Proxy :: Proxy l1 ) ( Proxy :: Proxy l2 )
, Just Refl <- eqT @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 )
data SomeSType where
SomeSType :: forall a. STypeI a => SomeSType
instance Show SomeSType where
show ( SomeSType @a ) = show ( Proxy @a )
instance Eq SomeSType where
( SomeSType @a ) == ( SomeSType @b ) =
case eqT @a @b of
Just _ -> True
_ -> False
data SomeSTypes where
SomeSTypes :: forall kvs. STypesI kvs => SomeSTypes
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, v ) ': lvs' ) ) <- sTyCons
, let
l :: Text
l = Text.pack $ symbolVal' ( proxy# :: Proxy# l )
= ( l, SomeSType @v )
: go ( sTypesI @lvs' )
proveSomeSTypes :: [ ( Text, SomeSType ) ] -> ( forall kvs. STypesI kvs => Proxy# kvs -> r ) -> r
proveSomeSTypes rs f = case go rs of { SomeSTypes @kvs -> f @kvs proxy# }
where
go :: [ ( Text, SomeSType ) ] -> SomeSTypes
go [] = SomeSTypes @'[]
go ( ( s, SomeSType @v ) :rest )
= case go rest of
SomeSTypes @kvs
| SomeSymbol ( _ :: Proxy k ) <- someSymbolVal ( Text.unpack s )
-> SomeSTypes @( '( k, v ) ': kvs )

65
src/metabrushes/MetaBrush/Document.hs
View file

@ -1,24 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# 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 #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -45,8 +25,12 @@ import Data.Functor.Identity
( Identity(..) )
import Data.Semigroup
( Arg(..), Min(..), ArgMin )
import Data.Typeable
( Typeable )
import GHC.Generics
( Generic, Generic1 )
import GHC.TypeLits
( Symbol )
-- acts
import Data.Act
@ -103,18 +87,11 @@ import Math.Module
, Inner((^.^))
, squaredNorm, quadrance
)
import Math.Vector2D
import Math.Linear
( Point2D(..), Vector2D(..) )
import MetaBrush.Brush
( Brush )
import MetaBrush.Serialisable
( Serialisable(..) )
import MetaBrush.DSL.Types
( STypesI )
import MetaBrush.DSL.Interpolation
( Interpolatable(..) )
( Brush, PointFields )
import MetaBrush.Records
( Rec, AllFields )
import MetaBrush.Unique
( UniqueSupply, Unique, freshUnique )
@ -189,12 +166,10 @@ type StrokeSpline clo brushParams =
data Stroke where
Stroke
:: ( KnownSplineType clo
, pointParams ~ Rec pointFields
, STypesI pointFields, STypesI brushFields
, Show pointParams, NFData pointParams
, AllFields Interpolatable pointFields
, Serialisable pointParams
:: forall clo pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
. ( KnownSplineType clo
, pointParams ~ Record pointFields
, PointFields pointFields, Typeable pointFields
)
=>
{ strokeName :: !Text
@ -216,12 +191,10 @@ instance NFData Stroke where
_strokeSpline
:: forall f
. Functor f
=> ( forall clo pointParams pointFields
=> ( forall clo pointParams ( pointFields :: [ Symbol ] )
. ( KnownSplineType clo
, Show pointParams, NFData pointParams
, AllFields Interpolatable pointFields
, pointParams ~ Rec pointFields, STypesI pointFields
, Serialisable pointParams
, pointParams ~ Record pointFields
, PointFields pointFields
)
=> StrokeSpline clo pointParams
-> f ( StrokeSpline clo pointParams )
@ -231,12 +204,10 @@ _strokeSpline f ( Stroke { strokeSpline = oldStrokeSpline, .. } )
= ( \ newSpline -> Stroke { strokeSpline = newSpline, .. } ) <$> f oldStrokeSpline
overStrokeSpline
:: ( forall clo pointParams pointFields
:: ( forall clo pointParams ( pointFields :: [ Symbol ] )
. ( KnownSplineType clo
, Show pointParams, NFData pointParams
, AllFields Interpolatable pointFields
, pointParams ~ Rec pointFields, STypesI pointFields
, Serialisable pointParams
, pointParams ~ Record pointFields
, PointFields pointFields
)
=> StrokeSpline clo pointParams
-> StrokeSpline clo pointParams
@ -373,7 +344,7 @@ instance Module Double diffBrushParams => Monoid ( DiffPointData diffBrushParams
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 )
DiffPointData ( invert v1 ) ( -1 *^ p1 ) ( invert s1 )
instance ( Module Double diffBrushParams, Act diffBrushParams brushParams )
=> Act ( DiffPointData diffBrushParams ) ( PointData brushParams ) where

53
src/metabrushes/MetaBrush/Document/Draw.hs
View file

@ -1,15 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
module MetaBrush.Document.Draw
( DrawAnchor(..), anchorsAreComplementary
@ -25,6 +14,8 @@ import Data.Functor
( ($>) )
import Data.Semigroup
( First(..) )
import GHC.TypeLits
( Symbol )
-- acts
import Data.Act
@ -34,10 +25,6 @@ import Data.Act
import Data.Sequence
( Seq(..) )
-- deepseq
import Control.DeepSeq
( NFData )
-- generic-lens
import Data.Generics.Product.Fields
( field, field' )
@ -70,12 +57,12 @@ import Math.Bezier.Spline
)
import Math.Module
( squaredNorm )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import Math.Linear
( Point2D(..), Vector2D(..), ℝ(..) )
import MetaBrush.Assert
( assert )
import MetaBrush.Brush
( Brush(..) )
( Brush(..), PointFields )
import MetaBrush.Document
( Document(..), DocumentContent(..)
, Stroke(..), StrokeHierarchy(..), StrokeSpline
@ -83,16 +70,7 @@ import MetaBrush.Document
, _selection, _strokeSpline
, coords, overStrokeSpline
)
import MetaBrush.Serialisable
( Serialisable )
import MetaBrush.DSL.Types
( STypesI )
import MetaBrush.DSL.Interpolation
( Interpolatable )
import MetaBrush.Records
( Rec, AllFields )
import qualified MetaBrush.Records as Rec
( empty )
import MetaBrush.Unique
( Unique, UniqueSupply, freshUnique, uniqueText )
@ -132,9 +110,9 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
( newDoc, Nothing ) -> do
uniq <- runReaderT freshUnique uniqueSupply
let
newSpline :: StrokeSpline Open ( Rec '[] )
newSpline :: StrokeSpline Open ( Record ( '[] :: [ Symbol ] ) )
newSpline =
Spline { splineStart = PointData c Normal Rec.empty
Spline { splineStart = PointData c Normal ( MkR ℝ0 )
, splineCurves = OpenCurves Empty
}
newStroke :: Stroke
@ -144,7 +122,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) =
, strokeVisible = True
, strokeUnique = uniq
, strokeSpline = newSpline
, strokeBrush = Nothing :: Maybe ( Brush '[] )
, strokeBrush = Nothing :: Maybe ( Brush ( '[] :: [ Symbol ] ) )
}
newDoc' :: Document
newDoc'
@ -251,14 +229,11 @@ withAnchorBrushData
:: forall r
. DrawAnchor
-> Document
-> ( forall pointParams pointFields brushFields
. ( pointParams ~ Rec pointFields
, STypesI pointFields, STypesI brushFields
, Show pointParams, NFData pointParams
, Serialisable pointParams
, AllFields Interpolatable pointFields
-> ( forall pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
. ( pointParams ~ Record pointFields
, PointFields pointFields
)
=> Maybe (Brush brushFields)
=> Maybe ( Brush brushFields )
-> pointParams
-> r
)
@ -283,4 +258,4 @@ withAnchorBrushData anchor ( Document { documentContent = Content { strokes } }
AnchorAtStart {} -> f strokeBrush ( brushParams ( splineStart strokeSpline ) )
AnchorAtEnd {} -> f strokeBrush ( brushParams ( splineEnd strokeSpline ) )
splineAnchor _
= f (Nothing :: Maybe (Brush '[])) Rec.empty
= f @_ @'[] @'[] Nothing ( MkR ℝ0 )

10
src/metabrushes/MetaBrush/Document/History.hs
View file

@ -1,13 +1,3 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Document.History
( DocumentHistory(..)
, back, fwd, newHistory, newFutureStep

151
src/metabrushes/MetaBrush/Document/Serialise.hs
View file

@ -1,19 +1,5 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedStrings #-}
module MetaBrush.Document.Serialise
( documentToJSON, documentFromJSON
@ -28,12 +14,12 @@ import qualified Data.Bifunctor as Bifunctor
( first )
import Data.Functor.Identity
( Identity(..) )
import Data.Typeable
( eqT )
import Data.Type.Equality
( (:~:)(Refl) )
import Data.Version
( Version(versionBranch) )
import GHC.Exts
( Proxy# )
import GHC.TypeLits
( Symbol )
import Unsafe.Coerce
( unsafeCoerce ) -- Tony Morris special
@ -89,12 +75,12 @@ import qualified Waargonaut.Decode as JSON
import qualified Waargonaut.Decode.Error as JSON
( DecodeError(ParseFailed) )
import qualified Waargonaut.Decode as JSON.Decoder
( atKey, atKeyOptional, bool, objectAsKeyValues, text )
( atKey, atKeyOptional, bool, text, list )
import qualified Waargonaut.Encode as JSON
( Encoder )
import qualified Waargonaut.Encode as JSON.Encoder
( runEncoder
, atKey', bool, int, keyValueTupleFoldable, list, mapLikeObj, text
, atKey', bool, int, list, mapLikeObj, text
)
import qualified Waargonaut.Encode.Builder as JSON.Builder
( waargonautBuilder, bsBuilder )
@ -118,22 +104,17 @@ import qualified Waargonaut.Types.Whitespace as JSON
-- metabrushes
import Math.Bezier.Spline
( SplineType(..), SSplineType(..), SplineTypeI(..) )
import Math.Vector2D
import Math.Linear
( Point2D(..), Vector2D(..))
import MetaBrush.Asset.Brushes
( lookupBrush )
import MetaBrush.Brush
( Brush(..), SomeBrush(..)
, SomeFieldSType(..), SomeBrushFields(..)
, reflectBrushFieldsNoDups
)
( Brush(..), SomeBrush(..), provePointFields, duplicates )
import MetaBrush.Document
( Document(..), DocumentContent(..), Guide(..)
, Stroke(..), StrokeHierarchy(..), StrokeSpline
, PointData(..), FocusState(..)
)
import MetaBrush.DSL.Types
( SomeSType(..), someSTypes )
import MetaBrush.Serialisable
( Serialisable(..)
, encodeSequence, decodeSequence
@ -141,7 +122,7 @@ import MetaBrush.Serialisable
, encodeSpline, decodeSpline
)
import MetaBrush.Records
( Rec )
( Record, knownSymbols )
import MetaBrush.Unique
( UniqueSupply, freshUnique )
@ -203,21 +184,21 @@ loadDocument uniqueSupply fp = do
--------------------------------------------------------------------------------
encodePointData
:: forall f flds brushParams
:: forall f ( flds :: [ Symbol ] ) brushParams
. ( Applicative f
, brushParams ~ Rec flds
, Serialisable ( Rec flds )
, brushParams ~ Record flds
, Serialisable ( Record 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 @( Rec flds ) ) brushParams
. JSON.Encoder.atKey' "brushParams" ( encoder @( Record flds ) ) brushParams
decodePointData
:: forall m flds brushParams
:: forall m ( flds :: [ Symbol ] ) brushParams
. ( Monad m
, brushParams ~ Rec flds
, Serialisable ( Rec flds )
, brushParams ~ Record flds
, Serialisable ( Record flds )
)
=> JSON.Decoder m ( PointData brushParams )
decodePointData = do
@ -225,50 +206,22 @@ decodePointData = do
let
pointState :: FocusState
pointState = Normal
brushParams <- JSON.Decoder.atKey "brushParams" ( decoder @( Rec flds ) )
brushParams <- JSON.Decoder.atKey "brushParams" ( decoder @( Record flds ) )
pure ( PointData { pointCoords, pointState, brushParams } )
encodeFields :: Monad f => JSON.Encoder f [ Text ]
encodeFields = JSON.Encoder.list JSON.Encoder.text
encodeSomeSType :: Applicative f => JSON.Encoder f SomeSType
encodeSomeSType = JSON.Encoder.mapLikeObj \ ( SomeSType @ty ) ->
if
| Just Refl <- eqT @ty @Double
-> JSON.Encoder.atKey' "tag" JSON.Encoder.text "double"
| otherwise
-> error "SLD TODO" --( JSON.ParseFailed $ "Unsupported record field type (not double)" )
decodeSomeFieldSType :: Monad m => JSON.Decoder m SomeFieldSType
decodeSomeFieldSType = do
tag <- JSON.Decoder.atKey "tag" JSON.Decoder.text
case tag of
"double" -> pure ( SomeFieldSType @Double )
_ -> throwError ( JSON.ParseFailed $ "Unsupported record field type with tag " <> tag )
encodeFieldTypes :: Monad f => JSON.Encoder f [ ( Text, SomeSType ) ]
encodeFieldTypes = JSON.Encoder.keyValueTupleFoldable encodeSomeSType
decodeFieldTypes :: Monad m => JSON.Decoder m SomeBrushFields
decodeFieldTypes = do
fields <- JSON.Decoder.objectAsKeyValues JSON.Decoder.text decodeSomeFieldSType
let
duplicates :: [ Text ]
duplicates = duplicatesAcc [] [] fields
duplicatesAcc :: [ Text ] -> [ Text ] -> [ ( Text, whatever ) ] -> [ 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 ( reflectBrushFieldsNoDups fields )
decodeFields :: Monad m => JSON.Decoder m [ Text ]
decodeFields = do
fields <- JSON.Decoder.list JSON.Decoder.text
case duplicates fields of
[] -> pure fields
[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 )
encodeBrush :: Applicative f => JSON.Encoder f (Brush brushFields)
encodeBrush = JSON.Encoder.mapLikeObj
\ ( BrushData { brushName } ) ->
@ -287,7 +240,7 @@ encodeStroke = JSON.Encoder.mapLikeObj
\ ( Stroke
{ strokeName
, strokeVisible
, strokeSpline = strokeSpline :: StrokeSpline clo ( Rec pointFields )
, strokeSpline = strokeSpline :: StrokeSpline clo ( Record pointFields )
, strokeBrush
}
) ->
@ -298,41 +251,41 @@ encodeStroke = JSON.Encoder.mapLikeObj
SOpen -> False
mbEncodeBrush :: JSON.MapLikeObj JSON.WS Json -> JSON.MapLikeObj JSON.WS Json
mbEncodeBrush = case strokeBrush of
Nothing ->
id
Just brush ->
JSON.Encoder.atKey' "brush" encodeBrush brush
Nothing -> id
Just brush -> JSON.Encoder.atKey' "brush" encodeBrush brush
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' "pointFields" encodeFieldTypes ( someSTypes @pointFields )
. JSON.Encoder.atKey' "pointFields" encodeFields ( knownSymbols @pointFields )
. mbEncodeBrush
. JSON.Encoder.atKey' "spline" ( encodeSpline encodePointData ) strokeSpline
decodeStroke :: 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 $ runReaderT freshUnique uniqueSupply )
strokeClosed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool
SomeBrushFields @pointFields <- JSON.Decoder.atKey "pointFields" decodeFieldTypes
mbSomeBrush <- JSON.Decoder.atKeyOptional "brush" decodeBrush
if strokeClosed
then do
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Rec pointFields ) ) decodePointData )
pure $ case mbSomeBrush of
Nothing ->
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( Brush '[] ) }
Just (SomeBrush brush) ->
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush }
else do
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open @( PointData ( Rec pointFields ) ) decodePointData )
pure $ case mbSomeBrush of
Nothing ->
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( Brush '[] ) }
Just (SomeBrush brush) ->
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush }
strokeName <- JSON.Decoder.atKey "name" JSON.Decoder.text
strokeVisible <- JSON.Decoder.atKey "visible" JSON.Decoder.bool
strokeClosed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool
mbSomeBrush <- JSON.Decoder.atKeyOptional "brush" decodeBrush
pointFields <- JSON.Decoder.atKey "pointFields" decodeFields
-- decodeFields ensured there were no duplicate field names.
provePointFields pointFields \ ( _ :: Proxy# pointFields ) ->
if strokeClosed
then do
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Record pointFields ) ) decodePointData )
pure $ case mbSomeBrush of
Nothing ->
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( Brush '[] ) }
Just (SomeBrush brush) ->
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush }
else do
strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open @( PointData ( Record pointFields ) ) decodePointData )
pure $ case mbSomeBrush of
Nothing ->
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( Brush '[] ) }
Just (SomeBrush brush) ->
Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush }
encodeStrokeHierarchy :: Monad f => JSON.Encoder f StrokeHierarchy

24
src/metabrushes/MetaBrush/Document/SubdivideStroke.hs
View file

@ -1,12 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
module MetaBrush.Document.SubdivideStroke
( subdivide )
@ -57,15 +49,15 @@ import Math.Bezier.Stroke
( CachedStroke(..), invalidateCache )
import Math.Module
( lerp, quadrance, closestPointOnSegment )
import Math.Vector2D
( Point2D(..), Vector2D(..), Segment(..) )
import Math.Linear
( Point2D(..), Vector2D(..), Segment(..), T(..) )
import MetaBrush.Document
( Document(..), Stroke(..), StrokeHierarchy(..), StrokeSpline
, PointData(..), DiffPointData(..)
, coords, _strokeSpline
)
import MetaBrush.DSL.Interpolation
( Interpolatable(Diff) )
import MetaBrush.Records
( Interpolatable )
--------------------------------------------------------------------------------
@ -128,7 +120,7 @@ subdivide c doc@( Document { zoomFactor } ) =
then
let
subdiv :: PointData brushParams
subdiv = lerp @( DiffPointData ( Diff brushParams ) ) t sp0 sp1
subdiv = lerp @( DiffPointData ( T brushParams ) ) t sp0 sp1
in do
put ( Just txt )
pure ( LineTo ( NextPoint subdiv ) ( invalidateCache dat ) :<| LineTo ( NextPoint sp1 ) ( invalidateCache dat ) :<| Empty )
@ -143,7 +135,7 @@ subdivide c doc@( Document { zoomFactor } ) =
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
then case Quadratic.subdivide @( DiffPointData ( T brushParams ) ) ( Quadratic.Bezier sp0 sp1 sp2 ) t of
( Quadratic.Bezier _ q1 subdiv, Quadratic.Bezier _ r1 _ ) -> do
let
bez_start, bez_end :: Curve Open ( CachedStroke RealWorld ) ( PointData brushParams )
@ -162,7 +154,7 @@ subdivide c doc@( Document { zoomFactor } ) =
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
then case Cubic.subdivide @( DiffPointData ( T brushParams ) ) ( Cubic.Bezier sp0 sp1 sp2 sp3 ) t of
( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) -> do
let
bez_start, bez_end :: Curve Open ( CachedStroke RealWorld ) ( PointData brushParams )

506
src/metabrushes/MetaBrush/Records.hs
View file

@ -1,78 +1,36 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module MetaBrush.Records
( Record(..), Rec, AllFields(..)
, empty, insert, lookup, Lookup
, map, mapM
, mapMWithKey
, zipWith
, cpure, cmap, czipWith
, cpureM, cpureMWithKey
, cmapWithKey
, collapse, foldRec
, proveRecordDicts
, describeRecord
, MyIntersection(..), myIntersect
, WithParams(..)
-- * Functors
, I(..), K(..), (:*:)(..), Dict(..)
)
where
module MetaBrush.Records where
-- base
import Prelude
hiding ( lookup, map, mapM, zipWith )
import Data.Coerce
( coerce )
import Data.Functor.Const
( Const(..) )
import Data.Functor
( (<&>) )
import Data.Kind
( Type, Constraint )
import Data.List
( intersperse )
import Data.Monoid
( Endo(..) )
import Data.Proxy
( Proxy(..) )
( findIndex, intersperse )
import Data.Typeable
( Typeable, TypeRep, typeRep )
import GHC.TypeLits
( Symbol, KnownSymbol, symbolVal'
, TypeError, ErrorMessage(..)
)
( Typeable, eqT )
import Data.Type.Equality
( (:~:)(Refl) )
import GHC.Exts
( Any, proxy#, withDict )
( Word(W#), Proxy#, proxy# )
import GHC.Show
( showCommaSpace )
import GHC.TypeLits
( Symbol, KnownSymbol, symbolVal'
, SomeSymbol(..), someSymbolVal
)
import GHC.TypeNats
( Nat, type (+) )
import Unsafe.Coerce
( unsafeCoerce )
-- acts
import Data.Act
( Act(..), Torsor(..) )
-- deepseq
import Control.DeepSeq
( NFData(..) )
@ -87,249 +45,217 @@ import Data.Text
import qualified Data.Text as Text
( pack, unpack )
-- unordered-containers
import Data.HashMap.Strict
( HashMap )
import qualified Data.HashMap.Strict as HashMap
-- MetaBrush
import Math.Linear
import Math.Module
--------------------------------------------------------------------------------
type Record :: (Type -> Type) -> [(Symbol, Type)] -> Type
newtype Record f kvs = MkR { recordKeyVals :: HashMap Text (f Any) }
-- | A convenient constraint synonym for types that support interpolation.
type Interpolatable :: Type -> Constraint
class ( Torsor ( T r ) r, Module Double ( T r ) ) => Interpolatable r
instance ( Torsor ( T r ) r, Module Double ( T r ) ) => Interpolatable r
empty :: Record f '[]
empty = MkR HashMap.empty
insert :: forall k v kvs f
. KnownSymbol k
=> f v
-> Record f kvs
-> Record f ( '(k,v) ': kvs )
insert v (MkR r) = MkR $ HashMap.insert k v' r
where
k :: Text
k = Text.pack $ symbolVal' @k proxy#
v' :: f Any
v' = unsafeCoerce v
lookup :: forall k kvs f
. KnownSymbol k
=> Record f kvs -> f (Lookup k kvs)
lookup ( MkR r ) = unsafeCoerce ( r HashMap.! k )
where
k :: Text
k = Text.pack $ symbolVal' @k proxy#
type Lookup :: Symbol -> [(Symbol, Type)] -> Type
type Lookup k kvs = LookupIn kvs k kvs
type LookupIn :: [(Symbol, Type)] -> Symbol -> [(Symbol, Type)] -> Type
type family LookupIn orig k kvs where
LookupIn _ k ( '(k, v) ': _ ) = v
LookupIn orig k ( _ ': kvs ) = LookupIn orig k kvs
LookupIn orig k _ = TypeError
( 'Text "Key '" :<>: ShowType k :<>: 'Text "' is not present in row:"
:$$: 'Text " - " :<>: ShowType orig )
type Rec :: [(Symbol, Type)] -> Type
type Rec kvs = Record I kvs
type I :: Type -> Type
newtype I a = I { unI :: a }
deriving newtype ( Semigroup, Monoid, Group, NFData )
type K :: Type -> Type -> Type
newtype K a b = K { unK :: a }
deriving newtype ( Semigroup, Monoid, Group, NFData )
type (:*:) :: (Type -> Type) -> (Type -> Type) -> Type -> Type
data (f :*: g) a = f a :*: g a
type Dict :: (Type -> Constraint) -> Type -> Type
data Dict c a where
Dict :: c a => Dict c a
type AllFields :: (Type -> Constraint) -> [(Symbol, Type)] -> Constraint
class AllFields c kvs where
recordDicts :: Record (Dict c) kvs
instance AllFields c '[] where
recordDicts = MkR HashMap.empty
instance ( c v, KnownSymbol k, AllFields c kvs ) => AllFields c ( '(k, v) ': kvs ) where
recordDicts = case recordDicts @c @kvs of
MkR kvs -> MkR $ HashMap.insert k dict kvs
where
k :: Text
k = Text.pack $ symbolVal' @k proxy#
dict :: Dict c Any
dict = unsafeCoerce ( Dict :: Dict c v )
instance AllFields Show kvs => Show (Record I kvs) where
showsPrec d = aux . collapse . cmapWithKey @Show showField
where
showField :: Show x => Text -> I x -> K ShowS x
showField k (I x) = K $ showString (Text.unpack k) . showString " = " . showsPrec 0 x
aux :: [ShowS] -> ShowS
aux fields = showParen (d >= 11)
$ showString "{"
. foldr (.) id (intersperse showCommaSpace fields)
. showString "}"
--------------------------------------------------------------------------------
-- | A function from a given record type, with provided default values
-- that can be overridden.
type WithParams :: [ Symbol ] -> Type -> Type
data WithParams params a =
WithParams
{ defaultParams :: Rec params
, withParams :: Rec params -> a
{ defaultParams :: Record params
, withParams :: Record params -> a
}
instance AllFields Semigroup kvs
=> Semigroup (Record I kvs) where
(<>) = czipWith @Semigroup (<>)
--------------------------------------------------------------------------------
instance ( AllFields Semigroup kvs
, AllFields Monoid kvs )
=> Monoid (Record I kvs) where
mempty = cpure @Monoid mempty
-- | A record of 'Double' values.
type Record :: [ k ] -> Type
newtype Record ks = MkR { recordKeyVals :: ℝ ( Length ks ) }
instance ( AllFields Semigroup kvs
, AllFields Monoid kvs
, AllFields Group kvs )
=> Group (Record I kvs) where
invert = cmap @Group ( \ (I g) -> I (invert g) )
deriving newtype
instance Eq ( ℝ ( Length ks ) )
=> Eq ( Record ks )
deriving newtype
instance Ord ( ℝ ( Length ks ) )
=> Ord ( Record ks )
deriving newtype
instance NFData ( ℝ ( Length ks ) )
=> NFData ( Record ks )
instance AllFields NFData kvs
=> NFData ( Record I kvs ) where
rnf (MkR r) = HashMap.foldlWithKey' go () r
where
dicts :: HashMap Text (Dict NFData Any)
MkR dicts = recordDicts @NFData @kvs
go :: () -> Text -> I Any -> ()
go !_ k (I a) =
case dicts HashMap.! k of
Dict -> rnf a
-- | Show a record, using the given type-level field names.
instance ( KnownSymbols ks, Representable ( ℝ ( Length ks ) ) )
=> Show ( Record ks ) where
showsPrec p ( MkR r )
= showParen ( p >= 11 )
$ showString "{"
. foldr (.) id ( intersperse showCommaSpace fields )
. showString "}"
where
fields :: [ ShowS ]
fields =
zip [ 1.. ] ( knownSymbols @ks ) <&> \ ( W# i, fld ) ->
let v = index r ( Fin i )
in showString ( Text.unpack fld ) . showString " = " . showsPrec 0 v
data MyIntersection r1 g r2 c where
MyIntersection
:: forall i r1 g r2 c
. ( AllFields c i )
=> { myProject :: forall f. Record f r1 -> Record (f :*: g) i
, myInject :: Record g i -> Record g r2
}
-> MyIntersection r1 g r2 c
deriving via ( T ( ℝ ( Length ks ) ) )
instance Semigroup ( T ( ℝ ( Length ks ) ) )
=> Semigroup ( T ( Record ks ) )
deriving via ( T ( ℝ ( Length ks ) ) )
instance Monoid ( T ( ℝ ( Length ks ) ) )
=> Monoid ( T ( Record ks ) )
deriving via ( T ( ℝ ( Length ks ) ) )
instance Group ( T ( ℝ ( Length ks ) ) )
=> Group ( T ( Record ks ) )
deriving via ( T ( ℝ ( Length ks ) ) )
instance Module Double ( T ( ℝ ( Length ks ) ) )
=> Module Double ( T ( Record ks ) )
myIntersect
:: forall c r1 g r2
. ( AllFields c r1 )
=> Record g r2
-> MyIntersection r1 g r2 c
myIntersect (MkR r2) =
proveRecordDicts @c @Any intersectionDict
( MyIntersection { myProject, myInject } )
instance ( Act ( T ( ℝ ( Length ks ) ) ) ( ℝ ( Length ks ) )
, Semigroup ( T ( ℝ ( Length ks ) ) ) )
=> Act ( T ( Record ks ) ) ( Record ks ) where
T ( MkR g ) • MkR a = MkR ( T g • a )
instance ( Torsor ( T ( ℝ ( Length ks ) ) ) ( ℝ ( Length ks ) )
, Group ( T ( ℝ ( Length ks ) ) ) )
=> Torsor ( T ( Record ks ) ) ( Record ks ) where
MkR g --> MkR a = T $ MkR $ unT $ g --> a
--------------------------------------------------------------------------------
type Length :: [ k ] -> Nat
type family Length xs where
Length '[] = 0
Length ( _ : xs ) = 1 + Length xs
type KnownSymbols :: [ Symbol ] -> Constraint
class KnownSymbols ks where
knownSymbols :: [ Text ]
instance KnownSymbols '[] where
knownSymbols = []
{-# INLINE knownSymbols #-}
instance ( KnownSymbol k, KnownSymbols ks ) => KnownSymbols ( k ': ks ) where
knownSymbols = Text.pack ( symbolVal' @k proxy# ) : knownSymbols @ks
{-# INLINE knownSymbols #-}
--------------------------------------------------------------------------------
-- Intersection of two records.
{-# INLINE intersect #-}
intersect :: forall r1 r2 l1 l2
. ( Typeable r1, Typeable r2
, KnownSymbols r1, KnownSymbols r2
, l1 ~ Length r1, l2 ~ Length r2
, Representable ( ℝ l1 ), Representable ( ℝ l2 )
, Interpolatable ( Record r1 )
)
=> Intersection r1 r2
intersect
-- Shortcut when the two rows are equal.
| Just Refl <- eqT @r1 @r2
, Refl <- ( unsafeCoerce Refl :: r1 :~: Intersect r1 r2 )
= Intersection { project = id, inject = const }
| otherwise
= doIntersection @r1 @r2 \ ( _ :: Proxy# r1r2 ) r1_idxs r2_idxs ->
let
project :: Record r1 -> Record r1r2
project = \ ( MkR r1 ) -> MkR $ projection ( (!) r1_idxs ) r1
inject :: Record r1r2 -> Record r2 -> Record r2
inject = \ ( MkR r1r2 ) ( MkR r2 ) -> MkR $ injection ( find eqFin r2_idxs ) r1r2 r2
in Intersection { project, inject }
data Intersection r1 r2 where
Intersection
:: forall r1r2 r1 r2
. ( KnownSymbols r1r2, Representable ( ℝ ( Length r1r2 ) )
, Interpolatable ( Record r1r2 ) )
=> { project :: Record r1 -> Record r1r2
, inject :: Record r1r2 -> Record r2 -> Record r2
} -> Intersection r1 r2
{-# INLINE doIntersection #-}
doIntersection
:: forall r1 r2 l1 l2 kont
. ( KnownSymbols r1, KnownSymbols r2
, l1 ~ Length r1, l2 ~ Length r2
, Representable ( ℝ l1 ), Representable ( ℝ l2 )
)
=> ( forall r1r2 l12.
( r1r2 ~ Intersect r1 r2, l12 ~ Length r1r2
, Representable ( ℝ l12 ), Interpolatable ( ℝ l12 )
, KnownSymbols r1r2, Representable ( ℝ ( Length r1r2 ) )
)
=> Proxy# r1r2 -> Vec l12 ( Fin l1 ) -> Vec l12 ( Fin l2 ) -> kont )
-> kont
doIntersection k =
case knownSymbols @r1 `intersectLists` knownSymbols @r2 of
[ ]
| ( _ :: Proxy# r1r2 ) <- proxy# @'[ ]
, Refl <- ( unsafeCoerce Refl :: r1r2 :~: Intersect r1 r2 )
-> k @'[] proxy#
VZ
VZ
[ ( f1, W# r1_i1, W# r2_i1 ) ]
| SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 )
, ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1 ]
, Refl <- ( unsafeCoerce Refl :: r1r2 :~: Intersect r1 r2 )
-> k @r1r2 proxy#
( VS ( Fin r1_i1 ) VZ )
( VS ( Fin r2_i1 ) VZ )
[ ( f1, W# r1_i1, W# r2_i1 )
, ( f2, W# r1_i2, W# r2_i2 ) ]
| SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 )
, SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 )
, ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1, f2 ]
, Refl <- ( unsafeCoerce Refl :: r1r2 :~: Intersect r1 r2 )
-> k @r1r2 proxy#
( VS ( Fin r1_i1 ) $ VS ( Fin r1_i2 ) VZ )
( VS ( Fin r2_i1 ) $ VS ( Fin r2_i2 ) VZ )
[ ( f1, W# r1_i1, W# r2_i1 )
, ( f2, W# r1_i2, W# r2_i2 )
, ( f3, W# r1_i3, W# r2_i3 ) ]
| SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 )
, SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 )
, SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 )
, ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1, f2, f3 ]
, Refl <- ( unsafeCoerce Refl :: r1r2 :~: Intersect r1 r2 )
-> k @r1r2 proxy#
( VS ( Fin r1_i1 ) $ VS ( Fin r1_i2 ) $ VS ( Fin r1_i3 ) VZ )
( VS ( Fin r2_i1 ) $ VS ( Fin r2_i2 ) $ VS ( Fin r2_i3 ) VZ )
other -> error $ "Intersection not defined in dimension " ++ show ( length other )
------
-- Functions for intersection.
intersectLists :: forall k. Eq k => [ k ] -> [ k ] -> [ ( k, Word, Word ) ]
intersectLists = go 1
where
myProject :: Record f r1 -> Record (f :*: g) Any
myProject (MkR r1) = MkR (HashMap.intersectionWith (:*:) r1 r2)
myInject :: Record g Any -> Record g r2
myInject (MkR i) = MkR (HashMap.union i r2)
intersectionDict :: Record (Dict c) Any
intersectionDict =
case recordDicts @c @r1 of
MkR d -> MkR (HashMap.intersection d r2)
go :: Word -> [ k ] -> [ k ] -> [ ( k, Word, Word ) ]
go _ [] _
= []
go i ( k : ks ) r
| Just j <- findIndex ( k == ) r
= ( k, i, fromIntegral j + 1 ) : go ( i + 1 ) ks r
| otherwise
= go ( i + 1 ) ks r
proveRecordDicts :: forall c r x. Record (Dict c) r -> (AllFields c r => x) -> x
proveRecordDicts = withDict @(AllFields c r)
type Intersect :: [ k ] -> [ k ] -> [ k ]
type family Intersect r1 r2 where
Intersect '[] _ = '[]
Intersect ( k ': ks ) r = DoIntersection k ks r ( Elem k r )
describeRecord :: forall kvs. AllFields Typeable kvs => [ ( Text, TypeRep ) ]
describeRecord = collapse $ cmapWithKey @Typeable describeField (recordDicts @Typeable @kvs)
where
describeField :: forall a. Text -> Dict Typeable a -> K ( Text, TypeRep ) a
describeField k Dict = K ( k, typeRep ( Proxy :: Proxy a ) )
type DoIntersection :: k -> [ k ] -> [ k ] -> Bool -> [ k ]
type family DoIntersection k ks r mb_j where
DoIntersection _ ks r False = Intersect ks r
DoIntersection k ks r True = k ': Intersect ks r
------------------------------------------------------------
-- Record combinators.
map :: ( forall x. f x -> g x )
-> Record f kvs -> Record g kvs
map f (MkR r) = MkR $ fmap f r
mapM :: Applicative m
=> ( forall x. f x -> m ( g x ) )
-> Record f kvs -> m (Record g kvs)
mapM f (MkR r) =
MkR <$> traverse f r
mapMWithKey :: forall m kvs f g
. Applicative m
=> ( forall x. Text -> f x -> m ( g x ) )
-> Record f kvs -> m (Record g kvs)
mapMWithKey f (MkR r) =
MkR <$> HashMap.traverseWithKey f r
cpure :: forall c kvs f
. AllFields c kvs
=> ( forall x. c x => f x )
-> Record f kvs
cpure f =
MkR $ fmap (\ Dict -> f) (recordKeyVals $ recordDicts @c @kvs)
cmap :: forall c kvs f g
. AllFields c kvs
=> ( forall x. c x => f x -> g x )
-> Record f kvs
-> Record g kvs
cmap f (MkR r) =
MkR $ HashMap.intersectionWith (\ Dict x -> f x) (recordKeyVals $ recordDicts @c @kvs) r
zipWith :: forall kvs f g h
. ( forall x. f x -> g x -> h x )
-> Record f kvs
-> Record g kvs
-> Record h kvs
zipWith f (MkR r1) (MkR r2) =
MkR $ HashMap.intersectionWith (\ x y -> f x y) r1 r2
czipWith :: forall c kvs f g h
. AllFields c kvs
=> ( forall x. c x => f x -> g x -> h x )
-> Record f kvs
-> Record g kvs
-> Record h kvs
czipWith f (MkR r1) (MkR r2) =
MkR $ HashMap.intersectionWith (\ Dict (x :*: y) -> f x y) (recordKeyVals $ recordDicts @c @kvs) pairs
where
pairs :: HashMap Text ((f :*: g) Any)
pairs = HashMap.intersectionWith (\ x y -> x :*: y) r1 r2
cpureM :: forall c m kvs f
. ( Applicative m, AllFields c kvs)
=> ( forall x. c x => m (f x) )
-> m ( Record f kvs )
cpureM f = mapM (\Dict -> f) (recordDicts @c @kvs)
cpureMWithKey :: forall c m kvs f
. ( Applicative m, AllFields c kvs)
=> ( forall x. c x => Text-> m (f x) )
-> m ( Record f kvs )
cpureMWithKey f = mapMWithKey (\k Dict -> f k) (recordDicts @c @kvs)
cmapWithKey :: forall c kvs f g
. AllFields c kvs
=> (forall x. c x => Text -> f x -> g x)
-> Record f kvs
-> Record g kvs
cmapWithKey f = zipWithKey ( \ k Dict x -> f k x ) (recordDicts @c @kvs)
zipWithKey :: forall r f g h
. ( forall x. Text -> f x -> g x -> h x )
-> Record f r -> Record g r -> Record h r
zipWithKey f (MkR a) (MkR b) = MkR $
HashMap.intersectionWithKey f a b
foldRec :: forall y f r. ( forall x . f x -> y -> y ) -> Record f r -> y -> y
foldRec f r = coerce $ mapM g r
where
g :: ( forall x. f x -> Const (Endo y) (I x) )
g x = coerce (f x)
collapse :: Record (K a) r -> [a]
collapse (MkR a) = coerce $ HashMap.elems a
type Elem :: k -> [ k ] -> Bool
type family Elem k ks where
Elem _ '[] = False
Elem k ( k ': _ ) = True
Elem k ( _ ': ks ) = Elem k ks

66
src/metabrushes/MetaBrush/Serialisable.hs
View file

@ -1,18 +1,4 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module MetaBrush.Serialisable
( Serialisable(..)
@ -31,12 +17,18 @@ import Control.Monad.ST
( RealWorld, stToIO )
import Data.Foldable
( toList )
import Data.Functor
( (<&>) )
import Data.Functor.Contravariant
( contramap )
import Data.Functor.Identity
( Identity(..) )
import Data.STRef
( newSTRef )
import Data.Traversable
( for )
import GHC.Exts
( Word(W#) )
-- containers
import Data.Map.Strict
@ -78,11 +70,7 @@ import qualified Waargonaut.Decode as JSON.Decoder
import qualified Waargonaut.Encode as JSON
( Encoder )
import qualified Waargonaut.Encode as JSON.Encoder
( runPureEncoder
, atKey', json, keyValueTupleFoldable, list, mapLikeObj, scientific, text, either
)
import Waargonaut.Types.Json
( Json )
( atKey', keyValueTupleFoldable, list, mapLikeObj, scientific, text, either )
-- meta-brushes
import Math.Bezier.Spline
@ -91,13 +79,11 @@ import Math.Bezier.Spline
)
import Math.Bezier.Stroke
( CachedStroke(..) )
import MetaBrush.Records
( Record, Rec, AllFields
, I(..), K(..)
, collapse, cmapWithKey, cpureMWithKey
import Math.Linear
( Point2D(..), Vector2D(..), ℝ(..)
, Fin(..), Representable(tabulate, index)
)
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import MetaBrush.Records
import MetaBrush.Unique
( Unique )
@ -121,24 +107,20 @@ 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
instance Serialisable a => Serialisable (I a) where
encoder = contramap unI encoder
decoder = fmap I decoder
instance ( AllFields Serialisable kvs )
=> Serialisable ( Record I kvs ) where
encoder :: forall f. Monad f => JSON.Encoder f ( Rec kvs )
encoder = contramap encodeFields ( JSON.Encoder.keyValueTupleFoldable JSON.Encoder.json )
decoder = Vector2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder
instance ( KnownSymbols ks, Representable ( ℝ ( Length ks ) ) ) => Serialisable ( Record ks ) where
encoder = contramap encodeFields ( JSON.Encoder.keyValueTupleFoldable ( encoder @Double ) )
where
encodeFields :: Record I kvs -> [ ( Text, Json ) ]
encodeFields = collapse . cmapWithKey @Serialisable keyVal
keyVal :: Serialisable x => Text -> I x -> K (Text, Json) x
keyVal k (I x) = K ( k, JSON.Encoder.runPureEncoder encoder x )
encodeFields :: Record ks -> [ ( Text, Double ) ]
encodeFields ( MkR r ) =
zip [1..] ( knownSymbols @ks ) <&> \ ( W# i, fld ) ->
( fld, index r ( Fin i ) )
decoder :: forall m. Monad m => JSON.Decoder m ( Rec kvs )
decoder = cpureMWithKey @Serialisable ( \ k -> JSON.Decoder.atKey k decoder )
decoder = fmap decodeFields $ for ( knownSymbols @ks ) \ k -> JSON.Decoder.atKey k ( decoder @Double )
where
decodeFields :: [ Double ] -> Record ks
decodeFields coords = MkR $ tabulate \ ( Fin i# ) ->
coords !! ( fromIntegral ( W# i# ) - 1 )
--------------------------------------------------------------------------------

13
src/metabrushes/MetaBrush/Unique.hs
View file

@ -1,13 +1,4 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module MetaBrush.Unique
( MonadUnique(freshUnique)
@ -79,7 +70,7 @@ newtype Unique = Unique { unique :: Int64 }
deriving newtype ( Eq, Ord, Enum, Storable, NFData )
unsafeUnique :: Word32 -> Unique
unsafeUnique i = Unique ( - fromIntegral i - 1 )
unsafeUnique i = Unique ( -(fromIntegral i) - 1 )
uniqueText :: Unique -> Text
uniqueText ( Unique i )

8
src/metabrushes/MetaBrush/Util.hs
View file

@ -1,11 +1,3 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module MetaBrush.Util
( traverseMaybe
, Exists(..)

32
src/splines/Math/Bezier/Cubic.hs
View file

@ -1,18 +1,4 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Math.Bezier.Cubic
( Bezier(..)
@ -73,8 +59,8 @@ import Math.Module
)
import Math.Roots
( realRoots, solveQuadratic )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import Math.Linear
( Point2D(..), Vector2D(..), T(..) )
--------------------------------------------------------------------------------
@ -91,13 +77,15 @@ data Bezier p
via Generically1 Bezier
deriving anyclass ( NFData, NFData1 )
deriving via Ap Bezier p
instance {-# OVERLAPPING #-} Act v p => Act v ( Bezier p )
deriving via Ap Bezier ( T b )
instance Module r ( T b ) => Module r ( T ( Bezier b ) )
instance Show p => Show (Bezier p) where
show (Bezier p1 p2 p3 p4) =
show p1 ++ "--" ++ show p2 ++ "--" ++ show p3 ++ "->" ++ show p4
deriving via Ap Bezier p
instance {-# OVERLAPPING #-} Act v p => Act v ( Bezier p )
-- | Degree raising: convert a quadratic Bézier curve to a cubic Bézier curve.
fromQuadratic :: forall v r p. ( Torsor v p, Module r v, Fractional r ) => Quadratic.Bezier p -> Bezier p
fromQuadratic ( Quadratic.Bezier { p0 = q0, p1 = q1, p2 = q2 } ) = Bezier {..}
@ -114,7 +102,7 @@ bezier ( Bezier {..} ) t =
( Quadratic.bezier @v ( Quadratic.Bezier p0 p1 p2 ) t )
( Quadratic.bezier @v ( Quadratic.Bezier p1 p2 p3 ) t )
-- | Derivative of cubic Bézier curve.
-- | Derivative of a cubic Bézier curve.
bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v
bezier' ( Bezier {..} )
= ( 3 *^ )
@ -149,7 +137,7 @@ squaredCurvature bez t
-- | Signed curvature of a planar cubic Bézier curve.
signedCurvature :: forall r. Floating r => Bezier ( Point2D r ) -> r -> r
signedCurvature bez t = ( g' `cross` g'' ) / norm g'
signedCurvature bez t = ( g' `cross` g'' ) / norm g' ^ ( 3 :: Int )
where
g', g'' :: Vector2D r
g' = bezier' @( Vector2D r ) bez t
@ -235,7 +223,7 @@ drag ( Bezier {..} ) t q = Bezier { p0, p1 = p1', p2 = p2', p3 }
-- | Compute parameter values for the self-intersection of a planar cubic Bézier curve, if such exist.
--
-- The parameter values might lie outside the interval [0,1],
-- The parameter values might lie outside the interval [0,1],
-- indicating a self-intersection of the extended curve.
--
-- Formula taken from:

19
src/splines/Math/Bezier/Cubic/Fit.hs
View file

@ -1,12 +1,3 @@
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Math.Bezier.Cubic.Fit
( FitParameters(..), FitPoint(..)
, fitSpline, fitPiece
@ -86,7 +77,7 @@ import Math.Module
)
import Math.Roots
( laguerre ) --, eval, derivative )
import Math.Vector2D
import Math.Linear
( Mat22(..), Point2D(..), Vector2D(..) )
--------------------------------------------------------------------------------
@ -180,7 +171,7 @@ fitSpline ( FitParameters {..} ) = go 0
--
-- Proceeds by fitting a cubic Bézier curve \( B(t) \), \( 0 \leqslant t \leqslant 1 \),
-- with given endpoints and tangents, which minimises the sum of squares functional
--
--
-- \[ \sum_{i=1}^n \Big \| B(t_i) - q_i \Big \|^2. \]
--
-- The values of the parameters \( \left ( t_i \right )_{i=1}^n \) are recursively estimated,
@ -219,7 +210,7 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr =
f1 t = h2 t *^ tr
f2 t = h0 t *^ ( MkVector2D p )
f3 t = h3 t *^ ( MkVector2D r )
loop :: forall s. Unboxed.MVector s Double -> Int -> ST s ( Cubic.Bezier ( Point2D Double ), ArgMax Double Double )
loop ts count = do
let
@ -248,8 +239,8 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr =
let
-- Convert from Hermite form to Bézier form.
cp1, cp2 :: Point2D Double
cp1 = ( ( s1 / 3 ) *^ tp ) • p
cp2 = ( ( (-s2) / 3 ) *^ tr ) • r
cp1 = ( ( s1 / 3 ) *^ tp ) • p
cp2 = ( ( -s2 / 3 ) *^ tr ) • r
bez :: Cubic.Bezier ( Point2D Double )
bez = Cubic.Bezier p cp1 cp2 r

17
src/splines/Math/Bezier/Envelope.hs
View file

@ -1,10 +1,3 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Math.Bezier.Envelope where
-- acts
@ -28,7 +21,7 @@ import qualified Math.Bezier.Quadratic as Quadratic
( Bezier(..), bezier, bezier' )
import Math.Module
( Module((^+^),(*^)), lerp, cross )
import Math.Vector2D
import Math.Linear
( Point2D(..), Vector2D(..), Segment(..) )
--------------------------------------------------------------------------------
@ -61,7 +54,7 @@ validRoot r
{-
:seti -XNegativeLiterals -XFlexibleInstances -XRebindableSyntax
:m Math.Vector2D Math.Bezier.Envelope
:m Math.Linear Math.Bezier.Envelope
import qualified Math.Bezier.Cubic as Cubic
import Prelude hiding ( fromInteger )
import AlgebraicPrelude ( fromInteger )
@ -515,7 +508,7 @@ envelope31 path
( Segment b10 b11 )
( Segment b20 b21 )
( Segment b30 b31 )
) t0 = [ - a1 / a0 ]
) t0 = [ -a1 / a0 ]
where
@ -553,7 +546,7 @@ envelope21 path
( Segment b00 b01 )
( Segment b10 b11 )
( Segment b20 b21 )
) t0 = [ - a1 / a0 ]
) t0 = [ -a1 / a0 ]
where
@ -590,7 +583,7 @@ envelope11 ( Segment p0 p1 )
( Segment
( Segment b00 b01 )
( Segment b10 b11 )
) t0 = [ - a1 / a0 ]
) t0 = [ -a1 / a0 ]
where

30
src/splines/Math/Bezier/Quadratic.hs
View file

@ -1,16 +1,4 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Math.Bezier.Quadratic
( Bezier(..)
@ -68,8 +56,8 @@ import Math.Module
)
import Math.Roots
( realRoots )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import Math.Linear
( Point2D(..), Vector2D(..), T(..) )
--------------------------------------------------------------------------------
@ -86,18 +74,20 @@ data Bezier p
via Generically1 Bezier
deriving anyclass ( NFData, NFData1 )
deriving via Ap Bezier p
instance {-# OVERLAPPING #-} Act v p => Act v ( Bezier p )
deriving via Ap Bezier ( T b )
instance Module r ( T b ) => Module r ( T ( Bezier b ) )
instance Show p => Show (Bezier p) where
show (Bezier p1 p2 p3) =
show p1 ++ "--" ++ show p2 ++ "->" ++ show p3
deriving via Ap Bezier p
instance {-# OVERLAPPING #-} Act v p => Act v ( Bezier p )
-- | Quadratic Bézier curve.
bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p
bezier ( Bezier {..} ) t = lerp @v t ( lerp @v t p0 p1 ) ( lerp @v t p1 p2 )
-- | Derivative of quadratic Bézier curve.
-- | Derivative of a quadratic Bézier curve.
bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v
bezier' ( Bezier {..} ) t = 2 *^ lerp @v t ( p0 --> p1 ) ( p1 --> p2 )
@ -126,7 +116,7 @@ squaredCurvature bez t
-- | Signed curvature of a planar quadratic Bézier curve.
signedCurvature :: forall r. Floating r => Bezier ( Point2D r ) -> r -> r
signedCurvature bez t = ( g' `cross` g'' ) / norm g'
signedCurvature bez t = ( g' `cross` g'' ) / norm g' ^ ( 3 :: Int )
where
g', g'' :: Vector2D r
g' = bezier' @( Vector2D r ) bez t

31
src/splines/Math/Bezier/Spline.hs
View file

@ -1,26 +1,3 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Math.Bezier.Spline where
-- base
@ -43,7 +20,7 @@ import Data.Monoid
import Data.Semigroup
( First(..) )
import GHC.Generics
( Generic, Generic1 )
( Generic, Generic1, Generically1(..) )
-- bifunctors
import qualified Data.Bifunctor.Tannen as Biff
@ -74,7 +51,7 @@ import Control.Monad.Trans.State.Strict
-- MetaBrush
import qualified Math.Bezier.Cubic as Cubic
( Bezier(..) )
import Math.Vector2D
import Math.Linear
( Point2D )
--------------------------------------------------------------------------------
@ -110,9 +87,13 @@ 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 )
deriving Applicative
via ( Generically1 ( NextPoint Open ) )
data instance NextPoint Closed ptData = BackToStart
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
deriving anyclass ( NFData, NFData1 )
deriving Applicative
via ( Generically1 ( NextPoint Closed ) )
fromNextPoint :: forall clo ptData. SplineTypeI clo => ptData -> NextPoint clo ptData -> ptData
fromNextPoint pt nxt

166
src/splines/Math/Bezier/Stroke.hs
View file

@ -1,27 +1,20 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}
module Math.Bezier.Stroke
( Offset(..)
, CachedStroke(..), discardCache, invalidateCache
, computeStrokeOutline, joinWithBrush
, withTangent
-- * Brush stroking
-- $brushes
, brushStroke, envelopeEquation
, linear, bezier2, bezier3
-- , uncurryD
)
where
@ -119,8 +112,8 @@ import Math.Orientation
)
import Math.Roots
( solveQuadratic )
import Math.Vector2D
( Point2D(..), Vector2D(..) )
import Math.Linear
import Math.Linear.Dual
--------------------------------------------------------------------------------
@ -208,10 +201,10 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
endPt :: ptData
endPt = openCurveEnd lastCurve
startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: Vector2D Double
startTgtFwd = snd ( firstOutlineFwd 0 )
startTgtBwd = (-1) *^ snd ( firstOutlineBwd 1 )
endTgtFwd = snd ( lastOutlineFwd 1 )
endTgtBwd = (-1) *^ snd ( lastOutlineBwd 0 )
startTgtFwd = snd ( firstOutlineFwd 0 )
startTgtBwd = -1 *^ snd ( firstOutlineBwd 1 )
endTgtFwd = snd ( lastOutlineFwd 1 )
endTgtBwd = -1 *^ snd ( lastOutlineBwd 0 )
startBrush, endBrush :: SplinePts Closed
startBrush = brushShape spt0
endBrush = brushShape endPt
@ -223,11 +216,11 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
Empty -> endTangent spt0 spt0 lastCurve
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
startTestTgt, endTestTgt :: Vector2D Double
startTestTgt = Vector2D sty (-stx)
startTestTgt = Vector2D sty -stx
where
stx, sty :: Double
Vector2D stx sty = startTgt
endTestTgt = Vector2D ety (-etx)
endTestTgt = Vector2D ety -etx
where
etx, ety :: Double
Vector2D etx ety = endTgt
@ -270,10 +263,10 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
endTgt = case prevCurves of
Empty -> endTangent spt0 spt0 lastCurve
_ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
startTgtFwd = snd ( firstOutlineFwd 0 )
startTgtBwd = (-1) *^ snd ( firstOutlineBwd 1 )
endTgtFwd = snd ( lastOutlineFwd 1 )
endTgtBwd = (-1) *^ snd ( lastOutlineBwd 0 )
startTgtFwd = snd ( firstOutlineFwd 0 )
startTgtBwd = -1 *^ snd ( firstOutlineBwd 1 )
endTgtFwd = snd ( lastOutlineFwd 1 )
endTgtBwd = -1 *^ snd ( lastOutlineBwd 0 )
fwdStartCap, bwdStartCap :: SplinePts Open
TwoSided fwdStartCap bwdStartCap
= fmap fst . snd . runWriter
@ -326,10 +319,10 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
tgt, next_tgt, tgtFwd, next_tgtFwd, tgtBwd, next_tgtBwd :: Vector2D Double
tgt = startTangent spt0 ptData curve
next_tgt = endTangent spt0 ptData curve
tgtFwd = snd ( fwd 0 )
next_tgtFwd = snd ( fwd 1 )
tgtBwd = (-1) *^ snd ( bwd 1 )
next_tgtBwd = (-1) *^ snd ( bwd 0 )
tgtFwd = snd ( fwd 0 )
next_tgtFwd = snd ( fwd 1 )
tgtBwd = -1 *^ snd ( bwd 1 )
next_tgtBwd = -1 *^ snd ( bwd 0 )
lift $ tellBrushJoin ( prevTgt, prev_tgtFwd, tgtBwd ) ptData ( tgt, tgtFwd, prev_tgtBwd )
lift $ updateCurveData ( curveData curve ) fwd bwd
put ( next_tgt, next_tgtFwd, next_tgtBwd )
@ -385,14 +378,14 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
( fwdCond, bwdCond )
| prevTgt `cross` tgt < 0 && prevTgt ^.^ tgt < 0
= ( isJust $ between ori prevTgtFwd tgtFwd testTgt1
, isJust $ between ori prevTgtBwd tgtBwd ( (-1) *^ testTgt1 )
, isJust $ between ori prevTgtBwd tgtBwd ( -1 *^ testTgt1 )
)
| otherwise
= ( not . isJust $ between ori prevTgtFwd tgtFwd testTgt2
, not . isJust $ between ori prevTgtBwd tgtBwd ( (-1) *^ testTgt2 )
, not . isJust $ between ori prevTgtBwd tgtBwd ( -1 *^ testTgt2 )
)
testTgt1, testTgt2 :: Vector2D Double
testTgt1 = Vector2D (-ty) tx
testTgt1 = Vector2D -ty tx
where
tx, ty :: Double
Vector2D tx ty = tgt ^-^ prevTgt
@ -400,7 +393,7 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
| prevTgt ^.^ tgt < 0
= testTgt1
| otherwise
= (-1) *^ ( tgt ^+^ prevTgt )
= -1 *^ ( tgt ^+^ prevTgt )
fwdJoin, bwdJoin :: SplinePts Open
fwdJoin
| tgtFwd `strictlyParallel` prevTgtFwd
@ -504,14 +497,14 @@ outlineFunctions ptParams brushFn sp0 crv =
| otherwise
= offTgt u
bwd t
= ( off s --offset ( withTangent ( (-1) *^ bwd' s ) ( brush s ) ) • f s
= ( off s --offset ( withTangent ( -1 *^ bwd' s ) ( brush s ) ) • f s
, bwd' s
)
where
s :: Double
s = 1 - t
off :: Double -> Point2D Double
off u = offset ( withTangent ( (-1) *^ f' u ) ( brush u ) ) • f u
off u = offset ( withTangent ( -1 *^ f' u ) ( brush u ) ) • f u
offTgt :: Double -> Vector2D Double
offTgt u
| u < 0.5
@ -521,7 +514,7 @@ outlineFunctions ptParams brushFn sp0 crv =
bwd' :: Double -> Vector2D Double
bwd' u
| squaredNorm ( offTgt u ) < epsilon
= (-1) *^ f' u
= -1 *^ f' u
| otherwise
= offTgt u
in ( fwd, bwd )
@ -648,7 +641,7 @@ splitFirstPiece t ( Spline { splineStart = sp0, splineCurves = OpenCurves curves
$ LineTo { curveEnd = NextPoint p , curveData = () }
}
, Spline
{ splineStart = p
{ splineStart = p
, splineCurves = OpenCurves . Seq.singleton
$ LineTo { curveEnd = NextPoint p1, curveData = () }
}
@ -804,3 +797,94 @@ withTangent tgt_wanted spline@( Spline { splineStart } )
, offsetParameter = Just t
, offset = MkVector2D $ Cubic.bezier @( Vector2D Double ) bez t
}
--------------------------------------------------------------------------------
-- $brushes
--
-- You can compute the envelope equation for a brush stroke by using
-- the functions 'linear', 'bezier2' and 'bezier3' in conjunction with
-- the 'brushStroke' function, e.g.
--
-- > brushStroke ( bezier2 path ) ( uncurryD $ fmap bezier3 brush )
-- | Linear interpolation, as a differentiable function.
linear :: forall b. ( Module Double ( T b ), Torsor ( T b ) b )
=> Segment b -> ℝ 1 ~> b
linear ( Segment a b ) = D \ ( ℝ1 t ) ->
D1 ( lerp @( T b ) t a b )
( a --> b )
origin
-- | A quadratic Bézier curve, as a differentiable function.
bezier2 :: forall b. ( Module Double ( T b ), Torsor ( T b ) b )
=> Quadratic.Bezier b -> ℝ 1 ~> b
bezier2 bez = D \ ( ℝ1 t ) ->
D1 ( Quadratic.bezier @( T b ) bez t )
( Quadratic.bezier' bez t )
( Quadratic.bezier'' bez )
-- | A cubic Bézier curve, as a differentiable function.
bezier3 :: forall b. ( Module Double ( T b ), Torsor ( T b ) b )
=> Cubic.Bezier b -> ℝ 1 ~> b
bezier3 bez = D \ ( ℝ1 t ) ->
D1 ( Cubic.bezier @( T b ) bez t )
( Cubic.bezier' bez t )
( Cubic.bezier'' bez t )
-- | A brush stroke, as described by the equation
--
-- \[ c(t,s) = p(t) + b(t,s) \]
--
-- where:
--
-- - \( p(t) \) is the path that the brush follows, and
-- - \( b(t,s) \) is the brush shape, as it varies along the path.
brushStroke :: ℝ 1 ~> ℝ 2 -- ^ stroke path \( p(t) \)
-> ℝ 2 ~> ℝ 2 -- ^ brush \( b(t,s) \)
-> ℝ 2 ~> ℝ 2
brushStroke ( D f_p ) ( D f_b ) = D \ ( ℝ2 t0 s0 ) ->
let !( D1 p dpdt d2pdt2 )
= f_p ( ℝ1 t0 )
!( D2 b dbdt dbds d2bdt2 d2bdtds d2bds2 )
= f_b ( ℝ2 t0 s0 )
in
D2 ( unT $ T p ^+^ T b )
-- c = p + b
( dpdt ^+^ dbdt ) dbds
-- ∂c/∂t = dp/dt + ∂b/∂t
-- ∂c/∂s = ∂b/∂s
( d2pdt2 ^+^ d2bdt2 ) d2bdtds d2bds2
-- ∂²c/∂t² = d²p/dt² + ∂²b/∂t²
-- ∂²c/∂t∂s = ∂²b/∂t∂s
-- ∂²c/∂s² = ∂²b/∂s²
-- | The envelope equation
--
-- \[ E = \frac{\partial c}{\partial t} \times \frac{\partial c}{\partial s} = 0, ]
--
-- as well as the vector
--
-- \[ \frac{\partial E}{\partial s} \frac{\mathrm{d} c}{\mathrm{d} t} \]
--
-- whose roots correspond to cusps in the envelope.
envelopeEquation :: ℝ 2 ~> ℝ 2 -> Double -> Double -> (# Double, T ( ℝ 2 ) #)
envelopeEquation ( D c ) t s =
case c ( ℝ2 t s ) of
D2 _ dcdt dcds d2cdt2 d2cdtds d2cds2 ->
let dEdt = d2cdt2 `cross2` dcds + dcdt `cross2` d2cdtds
dEds = d2cdtds `cross2` dcds + dcdt `cross2` d2cds2
in (# dcdt `cross2` dcds, dEds *^ dcdt ^-^ dEdt *^ dcds #)
-- Computation of total derivative dc/dt:
--
-- dc/dt = ∂c/∂t + ∂c/∂s ∂s/∂t
-- ∂s/∂t = - ( ∂E / ∂t ) / ( ∂E / ∂s )
--
-- ( ∂E / ∂s ) dc/dt = ( ∂E / ∂s ) ∂c/∂t - ( ∂E / ∂t ) ∂c/∂s.
-- | Cross-product of two 2D vectors.
cross2 :: T ( ℝ 2 ) -> T ( ℝ 2 ) -> Double
cross2 ( T ( ℝ2 x1 y1 ) ) ( T ( ℝ2 x2 y2 ) )
= x1 * y2 - x2 * y1

2
src/splines/Math/Epsilon.hs
View file

@ -1,5 +1,3 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Math.Epsilon
( epsilon, nearZero )
where

271
src/splines/Math/Linear.hs Normal file
View file

@ -0,0 +1,271 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UnliftedNewtypes #-}
module Math.Linear
( -- * Points and vectors
Point2D(..), Vector2D(.., Vector2D), Segment(..), Mat22(..)
-- * Points and vectors (second version)
, ℝ(..), T(.., V2, V3)
, Fin(..), eqFin, MFin(..)
, Dim, Representable(..), injection, projection
, Vec(..), (!), find
) where
-- base
import Data.Kind
( Type, Constraint )
import Data.Monoid
( Sum(..) )
import GHC.Exts
( TYPE, RuntimeRep(..)
, Word#, plusWord#, minusWord#, isTrue#, eqWord#
)
import GHC.Generics
( Generic, Generic1, Generically(..), Generically1(..) )
import GHC.TypeNats
( Nat, type (+) )
-- acts
import Data.Act
( Act((•)), Torsor((-->)) )
-- deepseq
import Control.DeepSeq
( NFData, NFData1 )
-- groups
import Data.Group
( Group(..) )
-- groups-generic
import Data.Group.Generics
( )
--------------------------------------------------------------------------------
data Point2D a = Point2D !a !a
deriving stock ( Eq, Generic, Generic1, Functor, Foldable, Traversable )
deriving ( Act ( Vector2D a ), Torsor ( Vector2D a ) )
via Vector2D a
deriving Applicative
via Generically1 Point2D
deriving anyclass ( NFData, NFData1 )
instance Show a => Show (Point2D a) where
showsPrec i (Point2D a b) = showsPrec i (a,b)
newtype Vector2D a = MkVector2D { tip :: Point2D a }
deriving stock ( Generic, Generic1, Foldable, Traversable )
deriving newtype ( Eq, Functor, Applicative, NFData, NFData1 )
deriving ( Semigroup, Monoid, Group )
via Generically ( Point2D ( Sum a ) )
-- | One-off datatype used for the 'Show' instance of Vector2D.
data V a = V a a
deriving stock Show
instance Show a => Show (Vector2D a) where
showsPrec i (Vector2D x y) = showsPrec i (V x y)
{-# COMPLETE Vector2D #-}
pattern Vector2D :: a -> a -> Vector2D a
pattern Vector2D x y = MkVector2D ( Point2D x y )
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 ( Generic, Generic1, Functor, Foldable, Traversable )
deriving ( Semigroup, Monoid, Group )
via Generically ( Segment p )
deriving Applicative
via Generically1 Segment
deriving anyclass ( NFData, NFData1 )
instance Show p => Show (Segment p) where
show (Segment s e) = show s ++ " -> " ++ show e
--------------------------------------------------------------------------------
-- | Euclidean space \( \mathbb{R}^n \).
type ℝ :: Nat -> Type
data family ℝ n
data instance ℝ 0 = ℝ0
deriving stock ( Show, Eq, Ord, Generic )
deriving anyclass NFData
newtype instance ℝ 1 = ℝ1 Double
deriving stock ( Generic )
deriving newtype ( Show, Eq, Ord, NFData )
data instance ℝ 2 = ℝ2 {-# UNPACK #-} !Double {-# UNPACK #-} !Double
deriving stock Generic
deriving anyclass NFData
deriving stock ( Show, Eq, Ord )
data instance ℝ 3 = ℝ3 {-# UNPACK #-} !Double {-# UNPACK #-} !Double {-# UNPACK #-} !Double
deriving stock Generic
deriving anyclass NFData
deriving stock ( Show, Eq, Ord )
-- | Tangent space to Euclidean space.
type T :: Type -> Type
newtype T e = T { unT :: e }
deriving stock ( Eq, Functor )
deriving newtype ( Show, NFData ) -- newtype Show instance for debugging...
instance Applicative T where
pure = T
T f <*> T a = T ( f a )
instance Semigroup ( T ( ℝ 0 ) ) where { _ <> _ = T ℝ0 }
instance Monoid ( T ( ℝ 0 ) ) where { mempty = T ℝ0 }
instance Group ( T ( ℝ 0 ) ) where { invert _ = T ℝ0 }
deriving via Sum Double instance Semigroup ( T ( ℝ 1 ) )
deriving via Sum Double instance Monoid ( T ( ℝ 1 ) )
deriving via Sum Double instance Group ( T ( ℝ 1 ) )
{-# COMPLETE V2 #-}
pattern V2 :: Double -> Double -> T ( ℝ 2 )
pattern V2 x y = T ( ℝ2 x y )
--instance Show (T (ℝ 2)) where
-- showsPrec i (T (ℝ2 x y)) = showsPrec i (V x y)
{-# COMPLETE V3 #-}
pattern V3 :: Double -> Double -> Double -> T ( ℝ 3 )
pattern V3 x y z = T ( ℝ3 x y z )
instance Semigroup ( T ( ℝ 2 ) ) where
T ( ℝ2 x1 y1 ) <> T ( ℝ2 x2 y2 ) =
T ( ℝ2 ( x1 + x2 ) ( y1 + y2 ) )
instance Monoid ( T ( ℝ 2 ) ) where
mempty = T ( ℝ2 0 0 )
instance Group ( T ( ℝ 2 ) ) where
invert ( T ( ℝ2 x y ) ) = T ( ℝ2 ( negate x ) ( negate y ) )
instance Semigroup ( T ( ℝ 3 ) ) where
T ( ℝ3 x1 y1 z1 ) <> T ( ℝ3 x2 y2 z2 ) =
T ( ℝ3 ( x1 + x2 ) ( y1 + y2 ) ( z1 + z2 ) )
instance Monoid ( T ( ℝ 3 ) ) where
mempty = T ( ℝ3 0 0 0 )
instance Group ( T ( ℝ 3 ) ) where
invert ( T ( ℝ3 x y z ) ) = T ( ℝ3 ( negate x ) ( negate y ) ( negate z ) )
instance Act ( T ( ℝ 0 ) ) ( ℝ 0 ) where
_ • _ = ℝ0
instance Torsor ( T ( ℝ 0 ) ) ( ℝ 0 ) where
_ --> _ = T ℝ0
instance Act ( T ( ℝ 1 ) ) ( ℝ 1 ) where
T ( ℝ1 t ) • ℝ1 a = ℝ1 ( a + t )
instance Torsor ( T ( ℝ 1 ) ) ( ℝ 1 ) where
ℝ1 a --> ℝ1 b = T ( ℝ1 ( b - a ) )
instance Act ( T ( ℝ 2 ) ) ( ℝ 2 ) where
T ( ℝ2 u v ) • ℝ2 x y = ℝ2 ( x + u ) ( y + v )
instance Torsor ( T ( ℝ 2 ) ) ( ℝ 2 ) where
ℝ2 a1 b1 --> ℝ2 a2 b2 = T ( ℝ2 ( a2 - a1 ) ( b2 - b1 ) )
instance Act ( T ( ℝ 3 ) ) ( ℝ 3 ) where
T ( ℝ3 u v w ) • ℝ3 x y z = ℝ3 ( x + u ) ( y + v ) ( z + w)
instance Torsor ( T ( ℝ 3 ) ) ( ℝ 3 ) where
ℝ3 a1 b1 c1 --> ℝ3 a2 b2 c2 = T ( ℝ3 ( a2 - a1 ) ( b2 - b1 ) ( c2 - c1 ) )
--------------------------------------------------------------------------------
-- | 1, ..., n
type Fin :: Nat -> TYPE WordRep
newtype Fin n = Fin Word#
{-# INLINE eqFin #-}
eqFin :: Fin n -> Fin n -> Bool
eqFin ( Fin i ) ( Fin j ) = isTrue# ( i `eqWord#` j )
-- | 0, ..., n
type MFin :: Nat -> TYPE WordRep
newtype MFin n = MFin Word#
type Dim :: k -> Nat
type family Dim v
type instance Dim ( ℝ n ) = n
type Representable :: Type -> Constraint
class Representable v where
tabulate :: ( Fin ( Dim v ) -> Double ) -> v
index :: v -> Fin ( Dim v ) -> Double
instance Representable ( ℝ 0 ) where
{-# INLINE tabulate #-}
tabulate _ = ℝ0
{-# INLINE index #-}
index _ _ = 0
instance Representable ( ℝ 1 ) where
{-# INLINE tabulate #-}
tabulate f = ℝ1 ( f ( Fin 1## ) )
{-# INLINE index #-}
index ( ℝ1 x ) _ = x
instance Representable ( ℝ 2 ) where
{-# INLINE tabulate #-}
tabulate f = ℝ2 ( f ( Fin 1## ) ) ( f ( Fin 2## ) )
{-# INLINE index #-}
index ( ℝ2 x y ) = \ case
Fin 1## -> x
_ -> y
instance Representable ( ℝ 3 ) where
{-# INLINE tabulate #-}
tabulate f = ℝ3 ( f ( Fin 1## ) ) ( f ( Fin 2## ) ) ( f ( Fin 3## ) )
{-# INLINE index #-}
index ( ℝ3 x y z ) = \ case
Fin 1## -> x
Fin 2## -> y
_ -> z
{-# INLINE projection #-}
projection :: ( Representable u, Representable v )
=> ( Fin ( Dim v ) -> Fin ( Dim u ) )
-> u -> v
projection f = \ u ->
tabulate \ i -> index u ( f i )
{-# INLINE injection #-}
injection :: ( Representable u, Representable v )
=> ( Fin ( Dim v ) -> MFin ( Dim u ) )
-> u -> v -> v
injection f = \ u v ->
tabulate \ i -> case f i of
MFin 0## -> index v i
MFin j -> index u ( Fin j )
type Vec :: Nat -> TYPE WordRep -> Type
data Vec n a where
VZ :: Vec 0 a
VS :: a -> Vec n a -> Vec ( 1 + n ) a
infixl 9 !
(!) :: forall l a. Vec l a -> Fin l -> a
VS a _ ! Fin 1## = a
VS _ a ! Fin i = a ! Fin ( i `minusWord#` 1## )
_ ! _ = error "impossible: Fin 0 is uninhabited"
find :: forall l a. ( a -> a -> Bool ) -> Vec l a -> a -> MFin l
find eq v b = MFin ( go 1## v )
where
go :: Word# -> Vec n a -> Word#
go j ( VS a as )
| a `eq` b
= j
| otherwise
= go ( j `plusWord#` 1## ) as
go _ VZ = 0##

271
src/splines/Math/Linear/Dual.hs Normal file
View file

@ -0,0 +1,271 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
module Math.Linear.Dual where
-- base
import Control.Applicative
( liftA2 )
import Data.Kind
( Type, Constraint )
import GHC.Generics
( Generic, Generic1, Generically1(..) )
import GHC.TypeNats
( Nat )
-- MetaBrush
import Math.Module
import Math.Linear
--------------------------------------------------------------------------------
-- | Differentiable mappings between spaces.
infixr 0 ~>
type (~>) :: Type -> Type -> Type
newtype a ~> b = D { runD :: a -> D a b }
deriving stock instance Functor ( D a ) => Functor ( (~>) a )
-- | @D ( ℝ n ) v@ is \( \mathbb{R}[x_1, \ldots, x_n]/(x_1, \ldots, x_n)^3 \otimes_\mathbb{R} v \)
type D :: Type -> Type -> Type
data family D u v
newtype instance D ( ℝ 0 ) v = D0 { v :: v }
deriving stock ( Show, Eq, Functor, Generic, Generic1 )
deriving newtype ( Num, Fractional, Floating )
deriving Applicative
via Generically1 ( D ( ℝ 0 ) )
data instance D ( ℝ 1 ) v = D1 { v :: !v, dx :: !( T v ), ddx :: !( T v ) }
deriving stock ( Show, Eq, Functor, Generic, Generic1 )
deriving Applicative
via Generically1 ( D ( ℝ 1 ) )
data instance D ( ℝ 2 ) v = D2 { v :: !v, dx, dy :: !( T v ), ddx, dxdy, ddy :: !( T v ) }
deriving stock ( Show, Eq, Functor, Generic, Generic1 )
deriving Applicative
via Generically1 ( D ( ℝ 2 ) )
data instance D ( ℝ 3 ) v = D3 { v :: !v, dx, dy, dz :: !( T v ), ddx, dxdy, ddy, dxdz, dydz, ddz :: !( T v ) }
deriving stock ( Show, Eq, Functor, Generic, Generic1 )
deriving Applicative
via Generically1 ( D ( ℝ 3 ) )
instance Num ( D ( ℝ 1 ) Double ) where
(+) = liftA2 (+)
(-) = liftA2 (-)
negate = fmap negate
fromInteger = konst . fromInteger
abs = error "no"
signum = error "no"
D1 v1 ( T dx1 ) ( T ddx1 )
* D1 v2 ( T dx2 ) ( T ddx2 )
= D1 ( v1 * v2 )
( T $ dx1 * v2 + v1 * dx2 )
( T $ dx1 * dx2 + v1 * ddx2 + ddx1 * v2 )
instance Num ( D ( ℝ 2 ) Double ) where
(+) = liftA2 (+)
(-) = liftA2 (-)
negate = fmap negate
fromInteger = konst . fromInteger
abs = error "no"
signum = error "no"
D2 v1 ( T dx1 ) ( T dy1 ) ( T ddx1 ) ( T dxdy1 ) ( T ddy1 )
* D2 v2 ( T dx2 ) ( T dy2 ) ( T ddx2 ) ( T dxdy2 ) ( T ddy2 )
= D2 ( v1 * v2 )
( T $ dx1 * v2 + v1 * dx2 )
( T $ dy1 * v2 + v1 * dy2 )
( T $ dx1 * dx2 + v1 * ddx2 + ddx1 * v2 )
( T $ dy1 * dx2 + dx1 * dy2 + v1 * dxdy2 + dxdy1 * v2 )
( T $ dy1 * dy2 + v1 * ddy2 + ddy1 * v2 )
instance Num ( D ( ℝ 3 ) Double ) where
(+) = liftA2 (+)
(-) = liftA2 (-)
negate = fmap negate
fromInteger = konst . fromInteger
abs = error "no"
signum = error "no"
D3 v1 ( T dx1 ) ( T dy1 ) ( T dz1 ) ( T ddx1 ) ( T dxdy1 ) ( T ddy1 ) ( T dxdz1 ) ( T dydz1 ) ( T ddz1 )
* D3 v2 ( T dx2 ) ( T dy2 ) ( T dz2 ) ( T ddx2 ) ( T dxdy2 ) ( T ddy2 ) ( T dxdz2 ) ( T dydz2 ) ( T ddz2 )
= D3 ( v1 * v2 )
( T $ dx1 * v2 + v1 * dx2 )
( T $ dy1 * v2 + v1 * dy2 )
( T $ dz1 * v2 + v1 * dz2 )
( T $ dx1 * dx2 + ddx2 * v1 + ddx1 * v2 )
( T $ dy1 * dx2 + dx1 * dy2 + v1 * dxdy2 + dxdy1 * v2 )
( T $ dy1 * dy2 + v1 * ddy2 + ddy1 * v2 )
( T $ dz1 * dx2 + dx1 * dz2 + v1 * dxdz2 + dxdz1 * v2 )
( T $ dz1 * dy2 + dy1 * dz2 + v1 * dydz2 + dydz1 * v2 )
( T $ dz1 * dz2 + v1 * ddz2 + ddz1 * v2)
instance Module Double v => Module ( D ( ℝ 0 ) Double ) ( D ( ℝ 0 ) v ) where
(^+^) = liftA2 (^+^)
(^-^) = liftA2 (^-^)
origin = pure origin
(*^) = liftA2 (*^)
instance Module Double v => Module ( D ( ℝ 1 ) Double ) ( D ( ℝ 1 ) v ) where
(^+^) = liftA2 (^+^)
(^-^) = liftA2 (^-^)
origin = pure origin
(*^) = liftA2 (*^)
instance Module Double v => Module ( D ( ℝ 2 ) Double ) ( D ( ℝ 2 ) v ) where
(^+^) = liftA2 (^+^)
(^-^) = liftA2 (^-^)
origin = pure origin
(*^) = liftA2 (*^)
instance Module Double v => Module ( D ( ℝ 3 ) Double ) ( D ( ℝ 3 ) v ) where
(^+^) = liftA2 (^+^)
(^-^) = liftA2 (^-^)
origin = pure origin
(*^) = liftA2 (*^)
instance Fractional ( D ( ℝ 1 ) Double ) where
(/) = error "I haven't yet defined (/) for D ( ℝ 1 )"
fromRational = konst . fromRational
instance Floating ( D ( ℝ 1 ) Double ) where
pi = konst pi
sin ( D1 v ( T dx ) ( T ddx ) )
= let !s = sin v
!c = cos v
in D1 s ( T $ c * dx ) ( T $ 2 * c * ddx - s * dx * dx )
cos ( D1 v ( T dx ) ( T ddx ) )
= let !s = sin v
!c = cos v
in D1 c ( T $ -s * dx ) ( T $ -2 * s * ddx - c * dx * dx )
instance Fractional ( D ( ℝ 2 ) Double ) where
(/) = error "I haven't yet defined (/) for D ( ℝ 2 )"
fromRational = konst . fromRational
instance Floating ( D ( ℝ 2 ) Double ) where
pi = konst pi
sin ( D2 v ( T dx ) ( T dy ) ( T ddx ) ( T dxdy ) ( T ddy ) )
= let !s = sin v
!c = cos v
in D2 s
( T $ c * dx ) ( T $ c * dy )
( T $ 2 * c * ddx - s * dx * dx )
( T $ 2 * c * dxdy - 2 * s * dx * dy )
( T $ 2 * c * ddy - s * dy * dy )
cos ( D2 v ( T dx ) ( T dy ) ( T ddx ) ( T dxdy ) ( T ddy ) )
= let !s = sin v
!c = cos v
in D2 c
( T $ -s * dx ) ( T $ -s * dy )
( T $ -2 * s * ddx - c * dx * dx )
( T $ -2 * s * dxdy - 2 * c * dx * dy )
( T $ -2 * s * ddy - c * dy * dy )
instance Fractional ( D ( ℝ 3 ) Double ) where
(/) = error "I haven't yet defined (/) for D ( ℝ 3 )"
fromRational = konst . fromRational
instance Floating ( D ( ℝ 3 ) Double ) where
pi = konst pi
sin ( D3 v ( T dx ) ( T dy ) ( T dz ) ( T ddx ) ( T dxdy ) ( T ddy ) ( T dxdz ) ( T dydz ) ( T ddz ) )
= let !s = sin v
!c = cos v
in D3 s
( T $ c * dx ) ( T $ c * dy ) ( T $ c * dz )
( T $ 2 * c * ddx - s * dx * dx )
( T $ 2 * c * dxdy - 2 * s * dx * dy )
( T $ 2 * c * ddy - s * dy * dy )
( T $ 2 * c * dxdz - 2 * s * dx * dz )
( T $ 2 * c * dydz - 2 * s * dy * dz )
( T $ 2 * c * ddz - s * dz * dz )
cos ( D3 v ( T dx ) ( T dy ) ( T dz ) ( T ddx ) ( T dxdy ) ( T ddy ) ( T dxdz ) ( T dydz ) ( T ddz ) )
= let !s = sin v
!c = cos v
in D3 c
( T $ -s * dx ) ( T $ -s * dy ) ( T $ -s * dz )
( T $ -2 * s * ddx - c * dx * dx )
( T $ -2 * s * dxdy - 2 * c * dx * dy )
( T $ -2 * s * ddy - c * dy * dy )
( T $ -2 * s * dxdz - 2 * c * dx * dz )
( T $ -2 * s * dydz - 2 * c * dy * dz )
( T $ -2 * s * ddz - c * dz * dz )
--------------------------------------------------------------------------------
uncurryD :: ( ℝ 1 ~> ℝ 1 ~> b ) -> ( ℝ 2 ~> b )
uncurryD ( D b ) = D \ ( ℝ2 t0 s0 ) ->
let !(D1 ( D b_t0 ) ( T ( D dbdt_t0 ) ) ( T ( D d2bdt2_t0 ) ) ) = b ( ℝ1 t0 )
!(D1 b_t0s0 dbds_t0s0 d2bds2_t0s0 ) = b_t0 ( ℝ1 s0 )
!(D1 dbdt_t0s0 d2bdtds_t0s0 _ ) = dbdt_t0 ( ℝ1 s0 )
!(D1 d2bdt2_t0s0 _ _ ) = d2bdt2_t0 ( ℝ1 s0 )
in D2 b_t0s0 ( T dbdt_t0s0 ) dbds_t0s0 ( T d2bdt2_t0s0 ) d2bdtds_t0s0 d2bds2_t0s0
--------------------------------------------------------------------------------
chainRule :: ( Chain v, Module Double ( T w ) )
=> ( ( ℝ 1 ) ~> v )
-> ( v ~> w )
-> ( ( ℝ 1 ) ~> w )
chainRule ( D f ) ( D g ) =
D \ x ->
case f x of
df@( D1 { v = f_x } ) ->
chain df ( g f_x )
type Chain :: Type -> Constraint
class Chain v where
chain :: ( Module Double ( T w ) )
=> D ( ℝ 1 ) v -> D v w -> D ( ℝ 1 ) w
konst :: Module Double ( T w ) => w -> D v w
instance Chain ( ℝ 0 ) where
chain _ ( D0 v ) = D1 v origin origin
konst k = D0 k
instance Chain ( ℝ 1 ) where
chain ( D1 _ ( T ( ℝ1 x' ) ) ( T ( ℝ1 x'' ) ) ) ( D1 v g_x g_xx )
= D1 v
( x' *^ g_x )
( x'' *^ g_x ^+^ ( x' * x' ) *^ g_xx )
konst k = D1 k origin origin
instance Chain ( ℝ 2 ) where
chain ( D1 _ ( T ( ℝ2 x' y' ) ) ( T ( ℝ2 x'' y'' ) ) ) ( D2 v g_x g_y g_xx g_xy g_yy )
= D1 v
( x' *^ g_x ^+^ y' *^ g_y )
( x'' *^ g_x ^+^ y'' *^ g_y
^+^ ( x' * x' ) *^ g_xx ^+^ ( y' * y' ) *^ g_yy
^+^ 2 *^ ( ( x' * y' ) *^ g_xy ) )
konst k = D2 k origin origin origin origin origin
instance Chain ( ℝ 3 ) where
chain ( D1 _ ( T ( ℝ3 x' y' z' ) ) ( T ( ℝ3 x'' y'' z'' ) ) )
( D3 v g_x g_y g_z g_xx g_xy g_yy g_xz g_yz g_zz )
= D1 v
( x' *^ g_x ^+^ y' *^ g_y ^+^ z' *^ g_z )
( x'' *^ g_x ^+^ y'' *^ g_y ^+^ z'' *^ g_z
^+^ ( x' * x' ) *^ g_xx ^+^ ( y' * y' ) *^ g_yy ^+^ ( z' * z' ) *^ g_zz
^+^ 2 *^ ( ( x' * y' ) *^ g_xy ) ^+^ ( x' * z' ) *^ g_xz ^+^ ( y' * z' ) *^ g_yz )
konst k = D3 k origin origin origin origin origin origin origin origin origin
--------------------------------------------------------------------------------
type Var :: Nat -> Type -> Constraint
class Var n v where
var :: v ~> Double
instance Var 1 ( ℝ 1 ) where
var = D \ ( ℝ1 x ) -> D1 x ( T 1 ) ( T 0 )
instance Var 1 ( ℝ 2 ) where
var = D \ ( ℝ2 x _ ) -> D2 x ( T 1 ) ( T 0 ) ( T 0 ) ( T 0 ) ( T 0 )
instance Var 2 ( ℝ 2 ) where
var = D \ ( ℝ2 _ y ) -> D2 y ( T 0 ) ( T 1 ) ( T 0 ) ( T 0 ) ( T 0 )
instance Var 1 ( ℝ 3 ) where
var = D \ ( ℝ3 x _ _ ) -> D3 x ( T 1 ) ( T 0 ) ( T 0 ) ( T 0 ) ( T 0 ) ( T 0 ) ( T 0 ) ( T 0 ) ( T 0 )
instance Var 2 ( ℝ 3 ) where
var = D \ ( ℝ3 _ y _ ) -> D3 y ( T 0 ) ( T 1 ) ( T 0 ) ( T 0 ) ( T 0 ) ( T 0 ) ( T 0 ) ( T 0 ) ( T 0 )
instance Var 3 ( ℝ 3 ) where
var = D \ ( ℝ3 _ _ z ) -> D3 z ( T 0 ) ( T 0 ) ( T 1 ) ( T 0 ) ( T 0 ) ( T 0 ) ( T 0 ) ( T 0 ) ( T 0 )

4
src/splines/Math/Linear/Solve.hs
View file

@ -1,5 +1,3 @@
{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Math.Linear.Solve
@ -17,7 +15,7 @@ import qualified Eigen.Solver.LA as Eigen
( Decomposition(..), solve )
-- MetaBrush
import Math.Vector2D
import Math.Linear
( Vector2D(..), Mat22(..) )
--------------------------------------------------------------------------------

37
src/splines/Math/Module.hs
View file

@ -1,9 +1,4 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Math.Module
( Module(..), lerp
@ -38,8 +33,7 @@ import Data.Group
-- MetaBrush
import Math.Epsilon
( epsilon )
import Math.Vector2D
( Vector2D(..), Segment(..) )
import Math.Linear
--------------------------------------------------------------------------------
@ -58,7 +52,7 @@ class Num r => Module r m | m -> r where
(*^) = flip (^*)
(^*) = flip (*^)
m ^-^ n = m ^+^ (-1) *^ n
m ^-^ n = m ^+^ -1 *^ n
instance ( Applicative f, Module r m ) => Module r ( Ap f m ) where
origin = pure origin
@ -145,6 +139,29 @@ instance Num a => Inner a ( Vector2D a ) where
( Vector2D x1 y1 ) ^.^ ( Vector2D x2 y2 )
= x1 * x2 + y1 * y2
instance Module Double ( T ( ℝ 0 ) ) where
origin = T ℝ0
_ ^+^ _ = T ℝ0
_ ^-^ _ = T ℝ0
_ *^ _ = T ℝ0
deriving via Sum Double instance Module Double ( T Double )
deriving via Sum Double instance Module Double ( T ( ℝ 1 ) )
instance Module Double ( T ( ℝ 2 ) ) where
origin = mempty
(^+^) = (<>)
T ( ℝ2 x1 y1 ) ^-^ T ( ℝ2 x2 y2 ) =
T ( ℝ2 ( x1 - x2 ) ( y1 - y2 ) )
k *^ ( T ( ℝ2 a b ) ) = T ( ℝ2 ( k * a ) ( k * b ) )
instance Module Double ( T ( ℝ 3 ) ) where
origin = mempty
(^+^) = (<>)
T ( ℝ3 x1 y1 z1 ) ^-^ T ( ℝ3 x2 y2 z2 ) =
T ( ℝ3 ( x1 - x2 ) ( y1 - y2 ) ( z1 - z2 ) )
k *^ ( T ( ℝ3 a b c ) ) = T ( ℝ3 ( k * a ) ( k * b ) ( k * c ) )
-- | Cross-product of two 2D vectors.
cross :: Num a => Vector2D a -> Vector2D a -> a
cross ( Vector2D x1 y1 ) ( Vector2D x2 y2 )
@ -181,7 +198,7 @@ convexCombination v0 v1 u
let
t :: r
t = c0 / c10
guard ( t > - epsilon && t < 1 + epsilon )
guard ( t > -epsilon && t < 1 + epsilon )
guard ( epsilon < u ^.^ ( lerp @( Vector2D r ) t v0 v1 ) )
Just $ min 1 ( max 0 t )

12
src/splines/Math/Orientation.hs
View file

@ -1,10 +1,4 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Math.Orientation
( Orientation(..), reverseOrientation
@ -43,7 +37,7 @@ import Math.Bezier.Spline
, SplineType(..), KnownSplineType(..), SSplineType(..)
, ssplineType
)
import Math.Vector2D
import Math.Linear
( Point2D, Vector2D(..) )
--------------------------------------------------------------------------------
@ -127,7 +121,7 @@ splineTangents spline@( Spline { splineStart = sp0, splineCurves = curves } )
-- Returns the proportion of the angle the vector is in between, or @Nothing@ if the query vector
-- is not in between.
--
-- >>> between CCW ( Vector2D 1 0 ) ( Vector2D (-1) 1 ) ( Vector2D 1 1 )
-- >>> between CCW ( Vector2D 1 0 ) ( Vector2D -1 1 ) ( Vector2D 1 1 )
-- Just 0.3333333333333333
between
:: forall r
@ -135,7 +129,7 @@ between
=> Orientation
-> Vector2D r -- ^ start vector
-> Vector2D r -- ^ end vector
-> Vector2D r -- ^ query vector: is in between the start and end vectors w.r.t. the provided orientation?
-> Vector2D r -- ^ query vector: is it in between the start and end vectors w.r.t. the provided orientation?
-> Maybe r
between CCW ( Vector2D x1 y1 ) ( Vector2D x2 y2 ) ( Vector2D a b ) =
let

17
src/splines/Math/Roots.hs
View file

@ -1,12 +1,3 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedWildCards #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Math.Roots where
-- base
@ -61,7 +52,7 @@ solveQuadratic a0 a1 a2
then [ 0, 0.5, 1 ] -- convention
else []
| nearZero ( a0 * a0 * a2 / ( a1 * a1 ) )
= [ - a0 / a1 ]
= [ -a0 / a1 ]
| disc < 0
= [] -- non-real solutions
| otherwise
@ -69,11 +60,11 @@ solveQuadratic a0 a1 a2
r :: a
r =
if a1 >= 0
then 2 * a0 / ( - a1 - sqrt disc )
else 0.5 * ( - a1 + sqrt disc ) / a2
then 2 * a0 / ( -a1 - sqrt disc )
else 0.5 * ( -a1 + sqrt disc ) / a2
in [ r, -r - a1 / a2 ]
where
disc :: a
disc :: a
disc = a1 * a1 - 4 * a0 * a2
-- | Find real roots of a polynomial with real coefficients.

93
src/splines/Math/Vector2D.hs
View file

@ -1,93 +0,0 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Math.Vector2D
( Point2D(..), Vector2D(.., Vector2D), Mat22(..)
, Segment(..)
)
where
-- base
import Data.Monoid
( Sum(..) )
import GHC.Generics
( Generic, Generic1
, Generically(..), Generically1(..)
)
-- acts
import Data.Act
( Act, Torsor )
-- deepseq
import Control.DeepSeq
( NFData, NFData1 )
-- groups
import Data.Group
( Group(..) )
-- groups-generic
import Data.Group.Generics
( )
--------------------------------------------------------------------------------
data Point2D a = Point2D !a !a
deriving stock ( Eq, Generic, Generic1, Functor, Foldable, Traversable )
deriving ( Act ( Vector2D a ), Torsor ( Vector2D a ) )
via Vector2D a
deriving Applicative
via Generically1 Point2D
deriving anyclass ( NFData, NFData1 )
instance Show a => Show (Point2D a) where
showsPrec i (Point2D a b) = showsPrec i (a,b)
newtype Vector2D a = MkVector2D { tip :: Point2D a }
deriving stock ( Generic, Generic1, Foldable, Traversable )
deriving newtype ( Eq, Functor, Applicative, NFData, NFData1 )
deriving ( Semigroup, Monoid, Group )
via Generically ( Point2D ( Sum a ) )
data V a = V a a
deriving stock Show
instance Show a => Show (Vector2D a) where
showsPrec i (Vector2D x y) = showsPrec i (V x y)
{-# COMPLETE Vector2D #-}
pattern Vector2D :: a -> a -> Vector2D a
pattern Vector2D x y = MkVector2D ( Point2D x y )
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 ( Generic, Generic1, Functor, Foldable, Traversable )
deriving ( Semigroup, Monoid, Group )
via Generically ( Segment p )
deriving Applicative
via Generically1 Segment
deriving anyclass ( NFData, NFData1 )
instance Show p => Show (Segment p) where
show (Segment s e) = show s ++ " -> " ++ show e