framework for brush differentiation

MetaBrush.cabal

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

src/app/MetaBrush/Action.hs

@@ -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  #-}
 
 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(..)

src/app/MetaBrush/Action.hs-boot

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

src/app/MetaBrush/Application.hs

@@ -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
+import Math.Linear
-  ( Point2D(..) )
+  ( 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 :: Point2D Double -> Double -> Double -> Double -> PointData ( Record Asset.Brushes.EllipseBrushFields )
-          mkPoint pt a b phi = PointData pt Normal
+          mkPoint pt a b phi = PointData pt Normal ( MkR $ ℝ3 a b phi )
-            ( Rec.insert @"a" (I a) $ Rec.insert @"b" (I b) $ Rec.insert @"phi" (I phi) $ Rec.empty )
-
 
   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

src/app/MetaBrush/Asset/CloseTabButton.hs

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

src/app/MetaBrush/Asset/Colours.hs

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

src/app/MetaBrush/Asset/Cursor.hs

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

src/app/MetaBrush/Asset/InfoBar.hs

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

src/app/MetaBrush/Asset/Logo.hs

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

src/app/MetaBrush/Asset/TickBox.hs

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

src/app/MetaBrush/Asset/Tools.hs

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

src/app/MetaBrush/Asset/WindowIcons.hs

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

src/app/MetaBrush/Context.hs

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

src/app/MetaBrush/Document/Selection.hs

@@ -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 )
+  ( Module, lerp, squaredNorm, closestPointOnSegment )
-import Math.Vector2D
+import Math.Linear
-  ( Point2D(..), Vector2D(..), Segment(..) )
+  ( 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
@@ -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

src/app/MetaBrush/Document/Update.hs

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

src/app/MetaBrush/Event.hs

@@ -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(..)

src/app/MetaBrush/GTK/Util.hs

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

src/app/MetaBrush/Render/Document.hs

@@ -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
+import Math.Linear
-  ( Point2D(..), Vector2D(..) )
+  ( 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,25 +281,19 @@ strokeRenderData fitParams
              { defaultParams = brush_defaults
              , withParams    = brushFn
              } <- fn
+          -> -- 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
-            -- Use the handy 'intersect' function to do a computation
+                    let embedUsedParams r = inject r brush_defaults
-            -- 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 )
+                      computeStrokeOutline @( T ( Record usedFields) ) @clo
                         fitParams ( toUsedParams . brushParams ) ( brushFn . embedUsedParams ) spline
                     pure $
                       StrokeWithOutlineRenderData
@@ -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
@@ -471,8 +440,8 @@ drawPoint ( Colours {..} ) mbHover zoom PathPoint pt
   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.lineTo  0.5 (-hsqrt3)
+  Cairo.lineTo  0.5 -hsqrt3
   Cairo.closePath
 
   Cairo.setLineWidth 1.0

src/app/MetaBrush/Render/Rulers.hs

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

src/app/MetaBrush/Time.hs

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

src/app/MetaBrush/UI/Coordinates.hs

@@ -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(..)

src/app/MetaBrush/UI/FileBar.hs

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

src/app/MetaBrush/UI/InfoBar.hs

@@ -1,10 +1,4 @@
-{-# LANGUAGE BlockArguments     #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE NamedFieldPuns     #-}
-{-# LANGUAGE NegativeLiterals   #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards    #-}
-{-# LANGUAGE TypeApplications   #-}
 
 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 )

src/app/MetaBrush/UI/Menu.hs

@@ -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    #-}
 
 module MetaBrush.UI.Menu where
 

src/app/MetaBrush/UI/Panels.hs

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

src/app/MetaBrush/UI/ToolBar.hs

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

src/app/MetaBrush/UI/Viewport.hs

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

src/convert/Main.hs

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

src/convert/MetaBrush/MetaFont/Convert.hs

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

src/metabrushes/MetaBrush/Asset/Brushes.hs

@@ -1,15 +1,11 @@
-{-# LANGUAGE BangPatterns        #-}
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE GADTs               #-}
-{-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PolyKinds           #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications    #-}
-{-# LANGUAGE TypeOperators       #-}
 
 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
+κ :: Double
-c = 0.5519150244935105707435627227925
+κ = 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  1  κ) (p  κ  1) (NextPoint (p  0  1)) ()
-      , Bezier3To (p (-c)   1)  (p (-1)   c ) (NextPoint (p (-1)   0 )) ()
+      , Bezier3To (p -κ  1) (p -1  κ) (NextPoint (p -1  0)) ()
-      , Bezier3To (p (-1) (-c)) (p (-c) (-1)) (NextPoint (p   0  (-1))) ()
+      , 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 :: Record CircleBrushFields
-    deflts = Rec.insert @"r" (I 1) Rec.empty
+    deflts = MkR ( ℝ1 1 )
-    shape :: Rec CircleBrushFields -> SplinePts 'Closed
+    shape :: Record CircleBrushFields -> SplinePts 'Closed
-    shape params =
+    shape ( MkR ( ℝ1 r ) ) =
-      let !(I !r) = Rec.lookup @"r" params
+      circleSpline ( \ x y -> Point2D (r * x) (r * y) )
-      in 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 :: Record EllipseBrushFields
-    deflts = Rec.insert @"a"   (I 1)
+    deflts = MkR ( ℝ3 1 1 0 )
-           $ Rec.insert @"b"   (I 1)
+    shape :: Record EllipseBrushFields -> SplinePts 'Closed
-           $ Rec.insert @"phi" (I 0)
+    shape ( MkR ( ℝ3 a b phi ) ) =
-           $ Rec.empty
+      circleSpline ( \ x y -> Point2D (a * x * cos phi - b * y * sin phi)
-    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) )
+
+--------------------------------------------------------------------------------
+-- 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

src/metabrushes/MetaBrush/Brush.hs

@@ -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(..)
+  ( Brush(..), SomeBrush(..), BrushFunction
-  , BrushFunction
+  , PointFields, provePointFields, duplicates
-  , SomeFieldSType(..), SomeBrushFields(..)
-  , reflectBrushFieldsNoDups
   )
   where
 
 -- base
-import Control.Arrow
+import Data.Kind
-  ( second )
+  ( Type, Constraint )
-import Data.Proxy
+import Data.List
-  ( Proxy(..) )
+  ( nub )
+import Data.Typeable
+  ( Typeable )
 import GHC.Exts
-  ( Proxy#, Any )
+  ( Proxy#, proxy# )
-import Unsafe.Coerce
+import GHC.TypeLits
-  ( unsafeCoerce )
+  ( 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
+import MetaBrush.Serialisable
-  , WithParams(..)
+import Math.Linear
-  , Dict(..)
-  , proveRecordDicts
-  )
-import qualified MetaBrush.Records as Rec
-  ( map )
 
 --------------------------------------------------------------------------------
 
 -- | 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 )
+    .  ( KnownSymbols brushFields
-    =>
+       , Representable ( ℝ ( Length brushFields) )
-      { brushName     :: !Text
+       , 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
 
---------------------------------------------------------------------------------
+type PointFields :: [ Symbol ] -> Constraint
--- Instance dictionary passing machinery.
+class ( KnownSymbols pointFields, Typeable pointFields
-
+      , Serialisable   ( Record pointFields )
--- | Existential type over an allowed record field type used in brushes, such as Double and Point2D Double.
+      , Show           ( Record pointFields )
-data SomeFieldSType where
+      , NFData         ( Record pointFields )
-  SomeFieldSType
+      , Interpolatable ( Record pointFields )
-    :: ( STypeI a, Show a, NFData a, Interpolatable a, Serialisable a )
+      , Representable  ( ℝ ( Length pointFields ) )
-    => 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
       )
-    => 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
+-- | Assumes the input has no duplicates (doesn't check.)
-  show ( SomeBrushFields @kvs ) = show ( Proxy @kvs )
+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.
+duplicates :: [ Text ] -> [ Text ]
---
+duplicates = nub . duplicatesAcc [] []
--- Assumes the input list has no duplicate field names,
+  where
--- but they don't have to be sorted.
+    duplicatesAcc :: [ Text ] -> [ Text ] -> [ Text ] -> [ Text ]
-reflectBrushFieldsNoDups :: [ ( Text, SomeFieldSType ) ] -> SomeBrushFields
+    duplicatesAcc _    dups [] = dups
-reflectBrushFieldsNoDups elts =
+    duplicatesAcc seen dups ( k : kvs )
-  let
+      | k `elem` seen
-    mkSomeSType :: SomeFieldSType -> SomeSType
+      = duplicatesAcc seen ( k : dups ) kvs
-    mkSomeSType (SomeFieldSType @a) = SomeSType @a
+      | otherwise
-    mkField :: SomeFieldSType -> FieldSType Any
+      = duplicatesAcc ( k : seen ) dups kvs
-    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

src/metabrushes/MetaBrush/DSL/Interpolation.hs

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

src/metabrushes/MetaBrush/DSL/Types.hs

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

src/metabrushes/MetaBrush/Document.hs

@@ -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  #-}
 
 {-# 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 )
+  ( Brush, PointFields )
-import MetaBrush.Serialisable
-  ( Serialisable(..) )
-import MetaBrush.DSL.Types
-  ( STypesI )
-import MetaBrush.DSL.Interpolation
-  ( Interpolatable(..) )
 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
+    :: forall clo pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
-       , pointParams ~ Rec pointFields
+    .  ( KnownSplineType clo
-       , STypesI pointFields, STypesI brushFields
+       , pointParams ~ Record pointFields
-       , Show pointParams, NFData pointParams
+       , PointFields pointFields, Typeable pointFields
-       , AllFields Interpolatable pointFields
-       , Serialisable pointParams
        )
     =>
       { 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
+        , pointParams ~ Record pointFields
-        , AllFields Interpolatable pointFields
+        , PointFields pointFields
-        , pointParams ~ Rec pointFields, STypesI pointFields
-        , Serialisable pointParams
         )
      => 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
+        , pointParams ~ Record pointFields
-        , AllFields Interpolatable pointFields
+        , PointFields pointFields
-        , pointParams ~ Rec pointFields, STypesI pointFields
-        , Serialisable pointParams
         )
      => 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

src/metabrushes/MetaBrush/Document/Draw.hs

@@ -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         #-}
 
 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
+import Math.Linear
-  ( Point2D(..), Vector2D(..) )
+  ( 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,12 +229,9 @@ withAnchorBrushData
   :: forall r
   .  DrawAnchor
   -> Document
-  -> ( forall pointParams pointFields brushFields
+  -> ( forall pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] )
-     . ( pointParams ~ Rec pointFields
+     . ( pointParams ~ Record pointFields
-       , STypesI pointFields, STypesI brushFields
+       , PointFields pointFields
-       , Show pointParams, NFData pointParams
-       , Serialisable pointParams
-       , AllFields Interpolatable pointFields
        )
      => Maybe ( Brush brushFields )
      -> pointParams
@@ -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 )

src/metabrushes/MetaBrush/Document/History.hs

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

src/metabrushes/MetaBrush/Document/Serialise.hs

@@ -1,19 +1,5 @@
-{-# LANGUAGE BlockArguments       #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# 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 #-}
 
 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(..)
+  ( Brush(..), SomeBrush(..), provePointFields, duplicates )
-  , SomeFieldSType(..), SomeBrushFields(..)
-  , reflectBrushFieldsNoDups
-  )
 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
+    , brushParams ~ Record flds
-    , Serialisable ( Rec 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
+    , brushParams ~ Record flds
-    , Serialisable ( Rec 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
+decodeFields :: Monad m => JSON.Decoder m [ Text ]
-encodeSomeSType = JSON.Encoder.mapLikeObj \ ( SomeSType @ty ) ->
+decodeFields = do
-  if
+  fields <- JSON.Decoder.list JSON.Decoder.text
-    | Just Refl <- eqT @ty @Double
+  case duplicates fields of
-    -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "double"
+    []    -> pure fields
-    | 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 )
     [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,36 +251,36 @@ encodeStroke = JSON.Encoder.mapLikeObj
         SOpen   -> False
       mbEncodeBrush :: JSON.MapLikeObj JSON.WS Json -> JSON.MapLikeObj JSON.WS Json
       mbEncodeBrush = case strokeBrush of
-        Nothing ->
+        Nothing    -> id
-          id
+        Just brush -> JSON.Encoder.atKey' "brush" encodeBrush brush
-        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
+  strokeUnique  <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply )
   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
+  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 ( Rec pointFields ) ) decodePointData )
+      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 ( Rec pointFields ) ) decodePointData )
+      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 '[] ) }

src/metabrushes/MetaBrush/Document/SubdivideStroke.hs

@@ -1,12 +1,4 @@
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE GADTs               #-}
-{-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards     #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections       #-}
-{-# LANGUAGE TypeApplications    #-}
 
 module MetaBrush.Document.SubdivideStroke
   ( subdivide )
@@ -57,15 +49,15 @@ import Math.Bezier.Stroke
   ( CachedStroke(..), invalidateCache )
 import Math.Module
   ( lerp, quadrance, closestPointOnSegment )
-import Math.Vector2D
+import Math.Linear
-  ( Point2D(..), Vector2D(..), Segment(..) )
+  ( Point2D(..), Vector2D(..), Segment(..), T(..) )
 import MetaBrush.Document
   ( Document(..), Stroke(..), StrokeHierarchy(..), StrokeSpline
   , PointData(..), DiffPointData(..)
   , coords, _strokeSpline
   )
-import MetaBrush.DSL.Interpolation
+import MetaBrush.Records
-  ( Interpolatable(Diff) )
+  ( 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 )

src/metabrushes/MetaBrush/Records.hs

@@ -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       #-}
 
-{-# OPTIONS_GHC -Wno-orphans #-}
+module MetaBrush.Records where
-
-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
 
 -- base
-import Prelude
+import Data.Functor
-  hiding ( lookup, map, mapM, zipWith )
+  ( (<&>) )
-import Data.Coerce
-  ( coerce )
-import Data.Functor.Const
-  ( Const(..) )
 import Data.Kind
   ( Type, Constraint )
 import Data.List
-  ( intersperse )
+  ( findIndex, intersperse )
-import Data.Monoid
-  ( Endo(..) )
-import Data.Proxy
-  ( Proxy(..) )
 import Data.Typeable
-  ( Typeable, TypeRep, typeRep )
+  ( Typeable, eqT )
-import GHC.TypeLits
+import Data.Type.Equality
-  ( Symbol, KnownSymbol, symbolVal'
+  ( (:~:)(Refl) )
-  , TypeError, ErrorMessage(..)
-  )
 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
+-- MetaBrush
-import Data.HashMap.Strict
+import Math.Linear
-  ( HashMap )
+import Math.Module
-import qualified Data.HashMap.Strict as HashMap
 
 --------------------------------------------------------------------------------
 
-type Record :: (Type -> Type) -> [(Symbol, Type)] -> Type
+-- | A convenient constraint synonym for types that support interpolation.
-newtype Record f kvs = MkR { recordKeyVals :: HashMap Text (f Any) }
+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
+-- | A function from a given record type, with provided default values
-       .  KnownSymbol k
+-- that can be overridden.
-       => f v
+type WithParams :: [ Symbol ] -> Type -> Type
-       -> Record f kvs
+data WithParams params a =
-       -> Record f ( '(k,v) ': kvs )
+  WithParams
-insert v (MkR r) = MkR $ HashMap.insert k v' r
+    { defaultParams :: Record params
-  where
+    , withParams    :: Record params -> a
-    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
+-- | A record of 'Double' values.
-type Lookup k kvs = LookupIn kvs k kvs
+type Record :: [ k ] -> Type
+newtype Record ks = MkR { recordKeyVals :: ℝ ( Length ks ) }
 
-type LookupIn :: [(Symbol, Type)] -> Symbol -> [(Symbol, Type)] -> Type
+deriving newtype
-type family LookupIn orig k kvs where
+  instance Eq ( ℝ ( Length ks ) )
-  LookupIn _    k ( '(k, v) ': _ ) = v
+        => Eq ( Record ks )
-  LookupIn orig k ( _ ': kvs )     = LookupIn orig k kvs
+deriving newtype
-  LookupIn orig k _ = TypeError
+  instance Ord ( ℝ ( Length ks ) )
-    (    'Text "Key '" :<>: ShowType k :<>: 'Text "' is not present in row:"
+        => Ord ( Record ks )
-    :$$: 'Text "  - " :<>: ShowType orig )
+deriving newtype
+  instance NFData ( ℝ ( Length ks ) )
+        => NFData ( Record ks )
 
-type Rec :: [(Symbol, Type)] -> Type
+-- | Show a record, using the given type-level field names.
-type Rec kvs = Record I kvs
+instance ( KnownSymbols ks, Representable ( ℝ ( Length ks ) ) )
-
+       => Show ( Record ks ) where
-type I :: Type -> Type
+  showsPrec p ( MkR r )
-newtype I a = I { unI :: a }
+    = showParen ( p >= 11 )
-  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 "}"
-
-data WithParams params a =
-  WithParams
-    { defaultParams :: Rec params
-    , withParams    :: Rec 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
-
-instance ( AllFields Semigroup kvs
-         , AllFields Monoid    kvs
-         , AllFields Group     kvs )
-      => Group     (Record I kvs) where
-  invert = cmap @Group ( \ (I g) -> I (invert g) )
-
-instance AllFields NFData kvs
-      => NFData ( Record I kvs ) where
-  rnf (MkR r) = HashMap.foldlWithKey' go () r
       where
-      dicts :: HashMap Text (Dict NFData Any)
+        fields :: [ ShowS ]
-      MkR dicts = recordDicts @NFData @kvs
+        fields =
-      go :: () -> Text -> I Any -> ()
+          zip [ 1.. ] ( knownSymbols @ks ) <&> \ ( W# i, fld ) ->
-      go !_ k (I a) =
+            let v = index r ( Fin i )
-        case dicts HashMap.! k of
+            in showString ( Text.unpack fld ) . showString " = " . showsPrec 0 v
-          Dict -> rnf a
 
-data MyIntersection r1 g r2 c where
+deriving via ( T ( ℝ ( Length ks ) ) )
-  MyIntersection
+  instance Semigroup ( T ( ℝ ( Length ks ) ) )
-    :: forall i r1 g r2 c
+        => Semigroup ( T ( Record ks ) )
-    .  ( AllFields c i )
+deriving via ( T ( ℝ ( Length ks ) ) )
-    => { myProject :: forall f. Record f r1 -> Record (f :*: g) i
+  instance Monoid    ( T ( ℝ ( Length ks ) ) )
-       , myInject  :: Record g i -> Record g r2
+        => Monoid    ( T ( Record ks ) )
-       }
+deriving via ( T ( ℝ ( Length ks ) ) )
-    -> MyIntersection r1 g r2 c
+  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
+instance ( Act       ( T ( ℝ ( Length ks ) ) ) ( ℝ ( Length ks ) )
-  :: forall c r1 g r2
+         , Semigroup ( T ( ℝ ( Length ks ) ) ) )
-  .  ( AllFields c r1 )
+        => Act ( T ( Record ks ) ) ( Record ks ) where
-  => Record g r2
+  T ( MkR g ) • MkR a = MkR ( T g • a )
-  -> MyIntersection r1 g r2 c
+instance ( Torsor ( T ( ℝ ( Length ks ) ) ) ( ℝ ( Length ks ) )
-myIntersect (MkR r2) =
+         , Group  ( T ( ℝ ( Length ks ) ) ) )
-  proveRecordDicts @c @Any intersectionDict
+        => Torsor ( T ( Record ks ) ) ( Record ks ) where
-    ( MyIntersection { myProject, myInject } )
+  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
+    go :: Word -> [ k ] -> [ k ] -> [ ( k, Word, Word ) ]
-    myProject (MkR r1) = MkR (HashMap.intersectionWith (:*:) r1 r2)
+    go _ [] _
-    myInject :: Record g Any -> Record g r2
+      = []
-    myInject (MkR i) = MkR (HashMap.union i r2)
+    go i ( k : ks ) r
-    intersectionDict :: Record (Dict c) Any
+      | Just j <- findIndex ( k == ) r
-    intersectionDict =
+      = ( k, i, fromIntegral j + 1 ) : go ( i + 1 ) ks r
-      case recordDicts @c @r1 of
+      | otherwise
-        MkR d -> MkR (HashMap.intersection d r2)
+      = go ( i + 1 ) ks r
 
-proveRecordDicts :: forall c r x. Record (Dict c) r -> (AllFields c r => x) -> x
+type Intersect :: [ k ] -> [ k ] -> [ k ]
-proveRecordDicts = withDict @(AllFields c r)
+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 ) ]
+type DoIntersection :: k -> [ k ] -> [ k ] -> Bool -> [ k ]
-describeRecord = collapse $ cmapWithKey @Typeable describeField (recordDicts @Typeable @kvs)
+type family DoIntersection k ks r mb_j where
-  where
+  DoIntersection _ ks r False = Intersect ks r
-    describeField :: forall a. Text -> Dict Typeable a -> K ( Text, TypeRep ) a
+  DoIntersection k ks r True  = k ': Intersect ks r
-    describeField k Dict = K ( k, typeRep ( Proxy :: Proxy a ) )
 
-------------------------------------------------------------
+type Elem :: k -> [ k ] -> Bool
--- Record combinators.
+type family Elem k ks where
-
+  Elem _ '[]         = False
-map :: ( forall x. f x -> g x )
+  Elem k ( k ': _  ) = True
-    -> Record f kvs -> Record g kvs
+  Elem k ( _ ': ks ) = Elem k ks
-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

src/metabrushes/MetaBrush/Serialisable.hs

@@ -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 #-}
 
 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', keyValueTupleFoldable, list, mapLikeObj, scientific, text, either )
-  , atKey', json, keyValueTupleFoldable, list, mapLikeObj, scientific, text, either
-  )
-import Waargonaut.Types.Json
-  ( Json )
 
 -- meta-brushes
 import Math.Bezier.Spline
@@ -91,13 +79,11 @@ import Math.Bezier.Spline
   )
 import Math.Bezier.Stroke
   ( CachedStroke(..) )
-import MetaBrush.Records
+import Math.Linear
-  ( Record, Rec, AllFields
+  ( Point2D(..), Vector2D(..), ℝ(..)
-  , I(..), K(..)
+  , Fin(..), Representable(tabulate, index)
-  , collapse, cmapWithKey, cpureMWithKey
   )
-import Math.Vector2D
+import MetaBrush.Records
-  ( Point2D(..), Vector2D(..) )
 import MetaBrush.Unique
   ( Unique )
 
@@ -122,23 +108,19 @@ instance Serialisable a => Serialisable ( Vector2D a ) where
       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 ( KnownSymbols ks, Representable ( ℝ ( Length ks ) ) ) => Serialisable ( Record ks ) where
-instance Serialisable a => Serialisable (I a) where
+  encoder = contramap encodeFields ( JSON.Encoder.keyValueTupleFoldable ( encoder @Double ) )
-  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 )
     where
-      encodeFields :: Record I kvs -> [ ( Text, Json ) ]
+      encodeFields :: Record ks -> [ ( Text, Double ) ]
-      encodeFields = collapse . cmapWithKey @Serialisable keyVal
+      encodeFields ( MkR r ) =
-      keyVal :: Serialisable x => Text -> I x -> K (Text, Json) x
+        zip [1..] ( knownSymbols @ks ) <&> \ ( W# i, fld ) ->
-      keyVal k (I x) = K ( k, JSON.Encoder.runPureEncoder encoder x )
+          ( fld, index r ( Fin i ) )
 
-  decoder :: forall m. Monad m => JSON.Decoder m ( Rec kvs )
+  decoder = fmap decodeFields $ for ( knownSymbols @ks ) \ k -> JSON.Decoder.atKey k ( decoder @Double )
-  decoder = cpureMWithKey @Serialisable ( \ k -> JSON.Decoder.atKey k decoder )
+    where
+      decodeFields :: [ Double ] -> Record ks
+      decodeFields coords = MkR $ tabulate \ ( Fin i# ) ->
+        coords !! ( fromIntegral ( W# i# ) - 1 )
 
 --------------------------------------------------------------------------------
 

src/metabrushes/MetaBrush/Unique.hs

@@ -1,13 +1,4 @@
-{-# LANGUAGE BangPatterns               #-}
-{-# LANGUAGE BlockArguments             #-}
-{-# LANGUAGE DerivingStrategies         #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE NamedFieldPuns             #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications           #-}
-{-# LANGUAGE UndecidableInstances       #-}
 
 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 )

src/metabrushes/MetaBrush/Util.hs

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

src/splines/Math/Bezier/Cubic.hs

@@ -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
+import Math.Linear
-  ( Point2D(..), Vector2D(..) )
+  ( 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

src/splines/Math/Bezier/Cubic/Fit.hs

@@ -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(..) )
 
 --------------------------------------------------------------------------------
@@ -249,7 +240,7 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr =
         -- Convert from Hermite form to Bézier form.
         cp1, cp2 :: Point2D Double
         cp1 = ( (  s1 / 3 ) *^ tp ) • p
-        cp2 = ( ( (-s2) / 3 ) *^ tr ) • r
+        cp2 = ( ( -s2 / 3 ) *^ tr ) • r
 
         bez :: Cubic.Bezier ( Point2D Double )
         bez = Cubic.Bezier p cp1 cp2 r

src/splines/Math/Bezier/Envelope.hs

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

src/splines/Math/Bezier/Quadratic.hs

@@ -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  #-}
 
 module Math.Bezier.Quadratic
   ( Bezier(..)
@@ -68,8 +56,8 @@ import Math.Module
   )
 import Math.Roots
   ( realRoots )
-import Math.Vector2D
+import Math.Linear
-  ( Point2D(..), Vector2D(..) )
+  ( 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

src/splines/Math/Bezier/Spline.hs

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

src/splines/Math/Bezier/Stroke.hs

@@ -1,27 +1,20 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE BlockArguments      #-}
+
-{-# LANGUAGE DataKinds           #-}
+{-# OPTIONS_GHC -Wno-type-defaults #-}
-{-# 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        #-}
 
 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
+import Math.Linear
-  ( Point2D(..), Vector2D(..) )
+import Math.Linear.Dual
 
 --------------------------------------------------------------------------------
 
@@ -209,9 +202,9 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
         endPt = openCurveEnd lastCurve
         startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: Vector2D Double
         startTgtFwd =       snd ( firstOutlineFwd 0 )
-        startTgtBwd = (-1) *^ snd ( firstOutlineBwd 1 )
+        startTgtBwd = -1 *^ snd ( firstOutlineBwd 1 )
         endTgtFwd   =       snd (  lastOutlineFwd 1 )
-        endTgtBwd   = (-1) *^ snd (  lastOutlineBwd 0 )
+        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
@@ -271,9 +264,9 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
           Empty          -> endTangent spt0 spt0                      lastCurve
           _ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve
         startTgtFwd =       snd ( firstOutlineFwd 0 )
-        startTgtBwd = (-1) *^ snd ( firstOutlineBwd 1 )
+        startTgtBwd = -1 *^ snd ( firstOutlineBwd 1 )
         endTgtFwd   =       snd (  lastOutlineFwd 1 )
-        endTgtBwd   = (-1) *^ snd (  lastOutlineBwd 0 )
+        endTgtBwd   = -1 *^ snd (  lastOutlineBwd 0 )
         fwdStartCap, bwdStartCap :: SplinePts Open
         TwoSided fwdStartCap bwdStartCap
           = fmap fst . snd . runWriter
@@ -328,8 +321,8 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart =
               next_tgt    =   endTangent spt0 ptData curve
               tgtFwd      =       snd ( fwd 0 )
               next_tgtFwd =       snd ( fwd 1 )
-              tgtBwd      = (-1) *^ snd ( bwd 1 )
+              tgtBwd      = -1 *^ snd ( bwd 1 )
-              next_tgtBwd = (-1) *^ snd ( bwd 0 )
+              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 )
@@ -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

src/splines/Math/Epsilon.hs

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

src/splines/Math/Linear.hs

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

src/splines/Math/Linear/Dual.hs

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

src/splines/Math/Linear/Solve.hs

@@ -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(..) )
 
 --------------------------------------------------------------------------------

src/splines/Math/Module.hs

@@ -1,9 +1,4 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE FlexibleInstances      #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE ScopedTypeVariables    #-}
-{-# LANGUAGE TypeApplications       #-}
-{-# LANGUAGE UndecidableInstances   #-}
 
 module Math.Module
   ( Module(..), lerp
@@ -38,8 +33,7 @@ import Data.Group
 -- MetaBrush
 import Math.Epsilon
   ( epsilon )
-import Math.Vector2D
+import Math.Linear
-  ( Vector2D(..), Segment(..) )
 
 --------------------------------------------------------------------------------
 
@@ -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 )

src/splines/Math/Orientation.hs

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

src/splines/Math/Roots.hs

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

src/splines/Math/Vector2D.hs

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