diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 25fc228..d7df970 100644 --- a/MetaBrush.cabal +++ b/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 diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 5c68a96..910da96 100644 --- a/src/app/MetaBrush/Action.hs +++ b/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 #-} +{-# LANGUAGE OverloadedStrings #-} module MetaBrush.Action where @@ -104,7 +89,7 @@ import Math.Bezier.Stroke ( CachedStroke(..), invalidateCache ) import Math.Module ( Module((*^)), quadrance ) -import Math.Vector2D +import Math.Linear ( Point2D(..), Vector2D(..) ) import MetaBrush.Context ( UIElements(..), Variables(..) diff --git a/src/app/MetaBrush/Action.hs-boot b/src/app/MetaBrush/Action.hs-boot index a2a823b..80fbf04 100644 --- a/src/app/MetaBrush/Action.hs-boot +++ b/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 ) diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs index ad98e68..1646236 100644 --- a/src/app/MetaBrush/Application.hs +++ b/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 - ( Point2D(..) ) +import Math.Linear + ( Point2D(..), ℝ(..) ) import MetaBrush.Action ( ActionOrigin(..) ) import qualified MetaBrush.Asset.Brushes as Asset.Brushes @@ -113,9 +105,6 @@ import MetaBrush.Document.Update import MetaBrush.Event ( handleEvents ) import MetaBrush.Records - ( Rec, I(..) ) -import qualified MetaBrush.Records as Rec - ( empty, insert ) import MetaBrush.Render.Document ( blankRender, getDocumentRender ) import MetaBrush.Render.Rulers @@ -184,10 +173,8 @@ runApplication application = do ) ] where - mkPoint :: Point2D Double -> Double -> Double -> Double -> PointData ( Rec Asset.Brushes.EllipseBrushFields ) - mkPoint pt a b phi = PointData pt Normal - ( Rec.insert @"a" (I a) $ Rec.insert @"b" (I b) $ Rec.insert @"phi" (I phi) $ Rec.empty ) - + mkPoint :: Point2D Double -> Double -> Double -> Double -> PointData ( Record Asset.Brushes.EllipseBrushFields ) + mkPoint pt a b phi = PointData pt Normal ( MkR $ ℝ3 a b phi ) recomputeStrokesTVar <- STM.newTVarIO @Bool False documentRenderTVar <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () ) @@ -225,7 +212,7 @@ runApplication application = do display <- GTK.rootGetDisplay window dataPath <- Directory.canonicalizePath =<< Cabal.getDataDir - themePath <- ( Directory.canonicalizePath =<< Cabal.getDataFileName "theme.css" ) + themePath <- Directory.canonicalizePath =<< Cabal.getDataFileName "theme.css" cssProvider <- GTK.cssProviderNew GTK.cssProviderLoadFromPath cssProvider themePath GTK.styleContextAddProviderForDisplay display cssProvider 1000 diff --git a/src/app/MetaBrush/Asset/CloseTabButton.hs b/src/app/MetaBrush/Asset/CloseTabButton.hs index c267cbe..c05912d 100644 --- a/src/app/MetaBrush/Asset/CloseTabButton.hs +++ b/src/app/MetaBrush/Asset/CloseTabButton.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE RecordWildCards #-} - module MetaBrush.Asset.CloseTabButton ( drawCloseTabButton ) where diff --git a/src/app/MetaBrush/Asset/Colours.hs b/src/app/MetaBrush/Asset/Colours.hs index b200b41..ad5e189 100644 --- a/src/app/MetaBrush/Asset/Colours.hs +++ b/src/app/MetaBrush/Asset/Colours.hs @@ -1,9 +1,4 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} diff --git a/src/app/MetaBrush/Asset/Cursor.hs b/src/app/MetaBrush/Asset/Cursor.hs index d4c3ce3..001bb56 100644 --- a/src/app/MetaBrush/Asset/Cursor.hs +++ b/src/app/MetaBrush/Asset/Cursor.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} - module MetaBrush.Asset.Cursor ( drawCursor, drawCursorIcon ) where diff --git a/src/app/MetaBrush/Asset/InfoBar.hs b/src/app/MetaBrush/Asset/InfoBar.hs index 45c92b1..ae271f5 100644 --- a/src/app/MetaBrush/Asset/InfoBar.hs +++ b/src/app/MetaBrush/Asset/InfoBar.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NegativeLiterals #-} - module MetaBrush.Asset.InfoBar ( drawMagnifier, drawTopLeftCornerRect ) where diff --git a/src/app/MetaBrush/Asset/Logo.hs b/src/app/MetaBrush/Asset/Logo.hs index 5cfebb7..060bf13 100644 --- a/src/app/MetaBrush/Asset/Logo.hs +++ b/src/app/MetaBrush/Asset/Logo.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} - module MetaBrush.Asset.Logo ( drawLogo ) where diff --git a/src/app/MetaBrush/Asset/TickBox.hs b/src/app/MetaBrush/Asset/TickBox.hs index ccbce0e..78ed329 100644 --- a/src/app/MetaBrush/Asset/TickBox.hs +++ b/src/app/MetaBrush/Asset/TickBox.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NegativeLiterals #-} - module MetaBrush.Asset.TickBox ( drawBox, drawTickedBox ) where diff --git a/src/app/MetaBrush/Asset/Tools.hs b/src/app/MetaBrush/Asset/Tools.hs index 7efe8e5..b6a9465 100644 --- a/src/app/MetaBrush/Asset/Tools.hs +++ b/src/app/MetaBrush/Asset/Tools.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} - module MetaBrush.Asset.Tools ( drawBrush, drawBug, drawMeta, drawPath, drawPen ) where diff --git a/src/app/MetaBrush/Asset/WindowIcons.hs b/src/app/MetaBrush/Asset/WindowIcons.hs index f5d46b8..9634180 100644 --- a/src/app/MetaBrush/Asset/WindowIcons.hs +++ b/src/app/MetaBrush/Asset/WindowIcons.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} - module MetaBrush.Asset.WindowIcons ( drawMinimise, drawRestoreDown, drawMaximise, drawClose ) where diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Context.hs index b602985..e4de54b 100644 --- a/src/app/MetaBrush/Context.hs +++ b/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 ) diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 636043b..7cb9ee5 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/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 ) -import Math.Vector2D - ( Point2D(..), Vector2D(..), Segment(..) ) + ( Module, lerp, squaredNorm, closestPointOnSegment ) +import Math.Linear + ( Point2D(..), Vector2D(..), Segment(..), T(..) ) import {-# SOURCE #-} MetaBrush.Context ( Modifier(..) ) import MetaBrush.Document @@ -122,8 +107,6 @@ import MetaBrush.Document ) import {-# SOURCE #-} MetaBrush.Document.Update ( DocChange(..) ) -import MetaBrush.DSL.Interpolation - ( Interpolatable(Diff) ) import MetaBrush.Unique ( Unique ) import MetaBrush.Util @@ -723,7 +706,7 @@ dragUpdate p0 p PointDrag _ doc = do changeText = "Translate " <> Text.intercalate " and " ( catMaybes [ ppMv, cpMv ] ) <> " across " <> Text.pack ( show $ length strokesAffected ) <> " strokes" - -> Just ( HistoryChange { newDocument, changeText } ) + -> Just ( HistoryChange { newDocument, changeText } ) dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmentParameter } ) alternateMode doc = let ( newDocument, mbStrokeName ) = @@ -753,7 +736,7 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen where updateSpline :: forall clo pointParams - . ( KnownSplineType clo, Interpolatable pointParams ) + . ( KnownSplineType clo, Module Double ( T pointParams ), Torsor ( T pointParams ) pointParams ) => StrokeSpline clo pointParams -> State ( Maybe Text ) ( StrokeSpline clo pointParams ) updateSpline @@ -785,16 +768,16 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen LineTo ( NextPoint sp1 ) dat -> do let bez2 :: Quadratic.Bezier ( PointData pointParams ) - bez2 = Quadratic.Bezier sp0 ( lerp @( DiffPointData ( Diff pointParams ) ) dragSegmentParameter sp0 sp1 ) sp1 + bez2 = Quadratic.Bezier sp0 ( lerp @( DiffPointData ( T pointParams ) ) dragSegmentParameter sp0 sp1 ) sp1 if alternateMode then quadraticDragCurve dat bez2 - else cubicDragCurve dat ( Cubic.fromQuadratic @( DiffPointData ( Diff pointParams ) ) bez2 ) + else cubicDragCurve dat ( Cubic.fromQuadratic @( DiffPointData ( T pointParams ) ) bez2 ) Bezier2To sp1 ( NextPoint sp2 ) dat -> do let bez2 :: Quadratic.Bezier ( PointData pointParams ) bez2 = Quadratic.Bezier sp0 sp1 sp2 if alternateMode - then cubicDragCurve dat $ Cubic.fromQuadratic @( DiffPointData ( Diff pointParams ) ) bez2 + then cubicDragCurve dat $ Cubic.fromQuadratic @( DiffPointData ( T pointParams ) ) bez2 else quadraticDragCurve dat ( Quadratic.Bezier sp0 sp1 sp2 ) Bezier3To sp1 sp2 ( NextPoint sp3 ) dat -> do let @@ -804,7 +787,7 @@ dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmen then quadraticDragCurve dat ( Quadratic.Bezier sp0 - ( Cubic.bezier @( DiffPointData ( Diff pointParams ) ) bez3 dragSegmentParameter ) + ( Cubic.bezier @( DiffPointData ( T pointParams ) ) bez3 dragSegmentParameter ) sp3 ) else cubicDragCurve dat bez3 diff --git a/src/app/MetaBrush/Document/Update.hs b/src/app/MetaBrush/Document/Update.hs index 71c48e1..0490b9b 100644 --- a/src/app/MetaBrush/Document/Update.hs +++ b/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 diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index 421343a..eece440 100644 --- a/src/app/MetaBrush/Event.hs +++ b/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(..) diff --git a/src/app/MetaBrush/GTK/Util.hs b/src/app/MetaBrush/GTK/Util.hs index 952ec28..42bed51 100644 --- a/src/app/MetaBrush/GTK/Util.hs +++ b/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 diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 9273439..fffea85 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/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 - ( Point2D(..), Vector2D(..) ) +import Math.Linear + ( Point2D(..), Vector2D(..), T(..) ) import MetaBrush.Asset.Colours ( Colours, ColourRecord(..) ) import MetaBrush.Brush @@ -116,15 +99,7 @@ import MetaBrush.Document.Serialise ( ) -- 'Serialisable' instances import MetaBrush.Document.Update ( DocChange(..) ) -import MetaBrush.DSL.Interpolation - ( Interpolatable, DRec ) import MetaBrush.Records - ( Record, Rec, WithParams(..) - , I(..), (:*:)(..) - , MyIntersection (..), myIntersect - ) -import qualified MetaBrush.Records as Rec - ( map ) import MetaBrush.UI.ToolBar ( Mode(..) ) import MetaBrush.Unique @@ -205,9 +180,9 @@ getDocumentRender , Just finalPoint <- mbFinalPoint , let previewStroke :: Stroke - previewStroke = withAnchorBrushData anchor doc \ mbBrush ( pointData :: Rec pointFields ) -> + previewStroke = withAnchorBrushData anchor doc \ mbBrush ( pointData :: Record pointFields ) -> let - previewSpline :: Spline Open ( CachedStroke RealWorld ) ( PointData ( Rec pointFields ) ) + previewSpline :: Spline Open ( CachedStroke RealWorld ) ( PointData ( Record pointFields ) ) previewSpline = catMaybesSpline ( invalidateCache undefined ) ( PointData p0 Normal pointData ) ( do @@ -295,7 +270,7 @@ instance NFData StrokeRenderData where strokeRenderData :: FitParameters -> Stroke -> Maybe ( ST RealWorld StrokeRenderData ) strokeRenderData fitParams ( Stroke - { strokeSpline = spline :: StrokeSpline clo ( Rec pointFields ) + { strokeSpline = spline :: StrokeSpline clo ( Record pointFields ) , strokeBrush = ( strokeBrush :: Maybe ( Brush brushFields ) ) , .. } @@ -306,32 +281,26 @@ strokeRenderData fitParams { defaultParams = brush_defaults , withParams = brushFn } <- fn - -> do - -- Use the handy 'intersect' function to do a computation - -- using only the relevant fields (which are the intersection - -- of the parameters along the stroke and the brush parameters). - -- - -- See also MetaBrush.DSL.Eval.eval for how we interpret brush code - -- to obtain a brush function. - case myIntersect @Interpolatable @pointFields brush_defaults of - MyIntersection - { myProject = project :: forall f. Record f pointFields -> Record (f :*: I) usedFields - , myInject } -> do - let - toUsedParams :: Rec pointFields -> Rec usedFields - toUsedParams given = Rec.map ( \ (x :*: _) -> x ) $ project @I given - embedUsedParams :: Rec usedFields -> Rec brushFields - embedUsedParams = myInject - -- Compute the outline using the brush function. - ( outline, fitPts ) <- - computeStrokeOutline @( DRec usedFields ) @clo @( Rec usedFields ) - fitParams ( toUsedParams . brushParams ) ( brushFn . embedUsedParams ) spline - pure $ - StrokeWithOutlineRenderData - { strokeDataSpline = spline - , strokeOutlineData = ( outline, fitPts ) - , strokeBrushFunction = brushFn . embedUsedParams . toUsedParams - } + -> -- This is the key place where we need to perform impedance matching + -- between the collection of parameters supplied along a strong and + -- the collection of parameters expected by the brush. + case intersect @pointFields @brushFields of + Intersection + { inject + , project = toUsedParams :: Record pointFields -> Record usedFields } + -> do + let embedUsedParams r = inject r brush_defaults + + -- Compute the outline using the brush function. + ( outline, fitPts ) <- + computeStrokeOutline @( T ( Record usedFields) ) @clo + fitParams ( toUsedParams . brushParams ) ( brushFn . embedUsedParams ) spline + pure $ + StrokeWithOutlineRenderData + { strokeDataSpline = spline + , strokeOutlineData = ( outline, fitPts ) + , strokeBrushFunction = brushFn . embedUsedParams . toUsedParams + } _ -> pure $ StrokeRenderData { strokeDataSpline = spline } @@ -443,7 +412,7 @@ renderBrushShape cols mbHoverContext zoom brushFn pt = brushPts :: SplinePts Closed brushPts = brushFn ( brushParams pt ) mbHoverContext' :: Maybe HoverContext - mbHoverContext' = Vector2D (-x) (-y) • mbHoverContext + mbHoverContext' = Vector2D -x -y • mbHoverContext in toAll do Cairo.save @@ -467,12 +436,12 @@ drawPoint ( Colours {..} ) mbHover zoom PathPoint pt Cairo.translate x y Cairo.scale ( 3 / zoom ) ( 3 / zoom ) - Cairo.moveTo 1 0 - Cairo.lineTo 0.5 hsqrt3 - Cairo.lineTo -0.5 hsqrt3 - Cairo.lineTo -1 0 - Cairo.lineTo -0.5 (-hsqrt3) - Cairo.lineTo 0.5 (-hsqrt3) + Cairo.moveTo 1 0 + Cairo.lineTo 0.5 hsqrt3 + Cairo.lineTo -0.5 hsqrt3 + Cairo.lineTo -1 0 + Cairo.lineTo -0.5 -hsqrt3 + Cairo.lineTo 0.5 -hsqrt3 Cairo.closePath Cairo.setLineWidth 1.0 diff --git a/src/app/MetaBrush/Render/Rulers.hs b/src/app/MetaBrush/Render/Rulers.hs index e0137f7..7a1bb3e 100644 --- a/src/app/MetaBrush/Render/Rulers.hs +++ b/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 diff --git a/src/app/MetaBrush/Time.hs b/src/app/MetaBrush/Time.hs index 0467953..149fe7e 100644 --- a/src/app/MetaBrush/Time.hs +++ b/src/app/MetaBrush/Time.hs @@ -57,8 +57,8 @@ pprSeconds ( h_name, m_name, s_name ) ( Seconds secs ) = pm <> absolute where pm :: String pm - | secs <= (-1) = "-" - | otherwise = "" + | secs <= -1 = "-" + | otherwise = "" h, r, m, s :: Int64 (h,r) = round ( abs secs ) `divMod` 3600 (m,s) = r `divMod` 60 diff --git a/src/app/MetaBrush/UI/Coordinates.hs b/src/app/MetaBrush/UI/Coordinates.hs index dff1e92..9400b45 100644 --- a/src/app/MetaBrush/UI/Coordinates.hs +++ b/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(..) diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs index e8b9f44..100a79b 100644 --- a/src/app/MetaBrush/UI/FileBar.hs +++ b/src/app/MetaBrush/UI/FileBar.hs @@ -1,10 +1,4 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} module MetaBrush.UI.FileBar ( FileBar(..), FileBarTab(..) diff --git a/src/app/MetaBrush/UI/InfoBar.hs b/src/app/MetaBrush/UI/InfoBar.hs index 37b503b..8bf14bf 100644 --- a/src/app/MetaBrush/UI/InfoBar.hs +++ b/src/app/MetaBrush/UI/InfoBar.hs @@ -1,10 +1,4 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} module MetaBrush.UI.InfoBar ( InfoBar(..), createInfoBar, updateInfoBar ) @@ -41,7 +35,7 @@ import qualified Data.Text as Text ( pack ) -- MetaBrush -import Math.Vector2D +import Math.Linear ( Point2D(..) ) import MetaBrush.Asset.Colours ( Colours ) diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index fe30e34..fe75f99 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/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 #-} +{-# LANGUAGE OverloadedStrings #-} module MetaBrush.UI.Menu where diff --git a/src/app/MetaBrush/UI/Panels.hs b/src/app/MetaBrush/UI/Panels.hs index c791c3b..111546a 100644 --- a/src/app/MetaBrush/UI/Panels.hs +++ b/src/app/MetaBrush/UI/Panels.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} module MetaBrush.UI.Panels diff --git a/src/app/MetaBrush/UI/ToolBar.hs b/src/app/MetaBrush/UI/ToolBar.hs index d469d04..0a60fbb 100644 --- a/src/app/MetaBrush/UI/ToolBar.hs +++ b/src/app/MetaBrush/UI/ToolBar.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} module MetaBrush.UI.ToolBar ( Tool(..), Mode(..) diff --git a/src/app/MetaBrush/UI/Viewport.hs b/src/app/MetaBrush/UI/Viewport.hs index 5ed587b..89e3072 100644 --- a/src/app/MetaBrush/UI/Viewport.hs +++ b/src/app/MetaBrush/UI/Viewport.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} module MetaBrush.UI.Viewport ( Viewport(..), ViewportEventControllers(..) diff --git a/src/convert/Main.hs b/src/convert/Main.hs index c76e417..70ad82d 100644 --- a/src/convert/Main.hs +++ b/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 diff --git a/src/convert/MetaBrush/MetaFont/Convert.hs b/src/convert/MetaBrush/MetaFont/Convert.hs index 06c0662..4092263 100644 --- a/src/convert/MetaBrush/MetaFont/Convert.hs +++ b/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 diff --git a/src/metabrushes/MetaBrush/Asset/Brushes.hs b/src/metabrushes/MetaBrush/Asset/Brushes.hs index 10ef341..95980ac 100644 --- a/src/metabrushes/MetaBrush/Asset/Brushes.hs +++ b/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 #-} +{-# LANGUAGE OverloadedStrings #-} module MetaBrush.Asset.Brushes where +-- base +import Data.Coerce + ( coerce ) + -- containers import qualified Data.Sequence as Seq ( fromList ) @@ -26,16 +22,19 @@ import qualified Data.HashMap.Strict as HashMap -- MetaBrush import Math.Bezier.Spline -import Math.Vector2D +import Math.Linear + ( Point2D(..), ℝ(..), T(..) ) +import Math.Linear.Dual + ( D, type (~>)(..), Var(var), konst ) +import Math.Module + ( Module((^+^), (*^)) ) import MetaBrush.Brush ( Brush(..), SomeBrush(..) ) import MetaBrush.Records - ( Rec, WithParams(..), I(..) ) -import qualified MetaBrush.Records as Rec -------------------------------------------------------------------------------- -type CircleBrushFields = '[ '("r", Double) ] +type CircleBrushFields = '[ "r" ] lookupBrush :: Text -> Maybe SomeBrush lookupBrush nm = HashMap.lookup nm brushes @@ -51,8 +50,8 @@ brushes = HashMap.fromList -- | Root of @(Sqrt[2] (4 + 3 κ) - 16) (2 - 3 κ)^2 - 8 (1 - 3 κ) Sqrt[8 - 24 κ + 12 κ^2 + 8 κ^3 + 3 κ^4]@. -- -- Used to approximate circles and ellipses with Bézier curves. -c :: Double -c = 0.5519150244935105707435627227925 +κ :: Double +κ = 0.5519150244935105707435627227925 circleSpline :: (Double -> Double -> ptData) -> Spline 'Closed () ptData circleSpline p = @@ -60,38 +59,71 @@ circleSpline p = , splineCurves = ClosedCurves crvs lastCrv } where crvs = Seq.fromList - [ Bezier3To (p 1 c) (p c 1 ) (NextPoint (p 0 1 )) () - , Bezier3To (p (-c) 1) (p (-1) c ) (NextPoint (p (-1) 0 )) () - , Bezier3To (p (-1) (-c)) (p (-c) (-1)) (NextPoint (p 0 (-1))) () + [ Bezier3To (p 1 κ) (p κ 1) (NextPoint (p 0 1)) () + , Bezier3To (p -κ 1) (p -1 κ) (NextPoint (p -1 0)) () + , Bezier3To (p -1 -κ) (p -κ -1) (NextPoint (p 0 -1)) () ] lastCrv = - Bezier3To (p c (-1)) (p 1 (-c)) BackToStart () + Bezier3To (p κ -1) (p 1 -κ) BackToStart () circle :: Brush CircleBrushFields circle = BrushData "circle" (WithParams deflts shape) where - deflts :: Rec CircleBrushFields - deflts = Rec.insert @"r" (I 1) Rec.empty - shape :: Rec CircleBrushFields -> SplinePts 'Closed - shape params = - let !(I !r) = Rec.lookup @"r" params - in circleSpline ( \ x y -> Point2D (r * x) (r * y) ) + deflts :: Record CircleBrushFields + deflts = MkR ( ℝ1 1 ) + shape :: Record CircleBrushFields -> SplinePts 'Closed + shape ( MkR ( ℝ1 r ) ) = + circleSpline ( \ x y -> Point2D (r * x) (r * y) ) -type EllipseBrushFields = '[ '("a", Double), '("b", Double), '("phi", Double) ] +type EllipseBrushFields = '[ "a", "b", "phi" ] ellipse :: Brush EllipseBrushFields ellipse = BrushData "ellipse" (WithParams deflts shape) where - deflts :: Rec EllipseBrushFields - deflts = Rec.insert @"a" (I 1) - $ Rec.insert @"b" (I 1) - $ Rec.insert @"phi" (I 0) - $ Rec.empty - shape :: Rec EllipseBrushFields -> SplinePts 'Closed - shape params = - let - !(I !a ) = Rec.lookup @"a" params - !(I !b ) = Rec.lookup @"b" params - !(I !phi) = Rec.lookup @"phi" params - in circleSpline ( \ x y -> Point2D (a * x * cos phi - b * y * sin phi) - (b * y * cos phi + a * x * sin phi) ) + deflts :: Record EllipseBrushFields + deflts = MkR ( ℝ3 1 1 0 ) + shape :: Record EllipseBrushFields -> SplinePts 'Closed + shape ( MkR ( ℝ3 a b phi ) ) = + circleSpline ( \ x y -> Point2D (a * x * cos phi - b * y * sin phi) + (b * y * cos phi + a * x * sin phi) ) + +-------------------------------------------------------------------------------- +-- Differentiable brushes. + +circleSpline2 :: ( Double -> Double -> D ( ℝ 3 ) ptData ) -> D ( ℝ 3 ) ( Spline 'Closed () ptData ) +circleSpline2 p = sequenceA $ + Spline { splineStart = p 1 0 + , splineCurves = ClosedCurves crvs lastCrv } + where + crvs = Seq.fromList + [ Bezier3To (p 1 κ) (p κ 1) (NextPoint (p 0 1)) () + , Bezier3To (p -κ 1) (p -1 κ) (NextPoint (p -1 0)) () + , Bezier3To (p -1 -κ) (p -κ -1) (NextPoint (p 0 -1)) () + ] + lastCrv = + Bezier3To (p κ -1) (p 1 -κ) BackToStart () + +ellipseBrush :: ℝ 3 ~> Spline 'Closed () ( ℝ 2 ) +ellipseBrush = + D \ params -> + let a, b, phi :: D ( ℝ 3 ) Double + a = runD ( var @1 ) params + b = runD ( var @2 ) params + phi = runD ( var @3 ) params + mkPt :: Double -> Double -> D ( ℝ 3 ) ( ℝ 2 ) + mkPt ( konst -> x ) ( konst -> y ) + = fmap coerce + $ ( x * a * cos phi - y * b * sin phi ) *^ e_x + ^+^ ( y * b * cos phi + x * a * sin phi ) *^ e_y + in circleSpline2 mkPt + where + e_x, e_y :: D ( ℝ 3 ) ( T ( ℝ 2 ) ) + e_x = pure $ T $ ℝ2 1 0 + e_y = pure $ T $ ℝ2 0 1 + +--ellipseArc :: ℝ 2 ~> ℝ 2 +--ellipseArc = brushStroke ( linear myPath ) ( uncurryD $ fmap bezier3 myBrush ) + +--testing :: Double -> Double -> (# Double, T ( ℝ 2 ) #) +--testing :: Double -> Double -> (# Double, T (ℝ 2) #) +--testing t s = envelopeEquation ellipseArc t s diff --git a/src/metabrushes/MetaBrush/Brush.hs b/src/metabrushes/MetaBrush/Brush.hs index 21f258d..5959d3c 100644 --- a/src/metabrushes/MetaBrush/Brush.hs +++ b/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(..) - , BrushFunction - , SomeFieldSType(..), SomeBrushFields(..) - , reflectBrushFieldsNoDups + ( Brush(..), SomeBrush(..), BrushFunction + , PointFields, provePointFields, duplicates ) where -- base -import Control.Arrow - ( second ) -import Data.Proxy - ( Proxy(..) ) +import Data.Kind + ( Type, Constraint ) +import Data.List + ( nub ) +import Data.Typeable + ( Typeable ) import GHC.Exts - ( Proxy#, Any ) -import Unsafe.Coerce - ( unsafeCoerce ) + ( Proxy#, proxy# ) +import GHC.TypeLits + ( Symbol, someSymbolVal + , SomeSymbol(..) + ) -- deepseq import Control.DeepSeq @@ -45,49 +34,34 @@ import Data.Text import qualified Data.Text as Text ( unpack ) --- unordered-containers -import qualified Data.HashMap.Strict as HashMap - ( fromList ) - -- MetaBrush import Math.Bezier.Spline ( SplineType(Closed), SplinePts) -import MetaBrush.Serialisable - ( Serialisable ) -import MetaBrush.DSL.Types - ( STypeI, STypesI - , SomeSType(..), proveSomeSTypes - ) -import MetaBrush.DSL.Interpolation - ( Interpolatable(..) ) import MetaBrush.Records - ( Record(MkR), Rec, AllFields - , WithParams(..) - , Dict(..) - , proveRecordDicts - ) -import qualified MetaBrush.Records as Rec - ( map ) +import MetaBrush.Serialisable +import Math.Linear -------------------------------------------------------------------------------- -- | A brush function: a function from a record of parameters to a closed spline. +type BrushFunction :: [ Symbol ] -> Type type BrushFunction brushFields = WithParams brushFields (SplinePts Closed) +type Brush :: [ Symbol ] -> Type data Brush brushFields where BrushData :: forall brushFields - . ( STypesI brushFields ) - => - { brushName :: !Text - , brushFunction :: BrushFunction brushFields - } + . ( KnownSymbols brushFields + , Representable ( ℝ ( Length brushFields) ) + , Typeable brushFields ) + => { brushName :: !Text + , brushFunction :: BrushFunction brushFields + } -> Brush brushFields data SomeBrush where SomeBrush - :: STypesI brushFields - => { someBrush :: !( Brush brushFields ) } + :: { someBrush :: !( Brush brushFields ) } -> SomeBrush instance Show ( Brush brushFields ) where @@ -107,62 +81,52 @@ instance Hashable ( Brush brushFields ) where hashWithSalt salt ( BrushData { brushName } ) = hashWithSalt salt brushName --------------------------------------------------------------------------------- --- Instance dictionary passing machinery. - --- | Existential type over an allowed record field type used in brushes, such as Double and Point2D Double. -data SomeFieldSType where - SomeFieldSType - :: ( STypeI a, Show a, NFData a, Interpolatable a, Serialisable a ) - => SomeFieldSType - -data FieldSType a where - FieldSType - :: ( STypeI a, Show a, NFData a, Interpolatable a, Serialisable a ) - => FieldSType a - --- | Existential type for allowed fields of a brush record. -data SomeBrushFields where - SomeBrushFields - :: forall kvs rec - . ( STypesI kvs - , rec ~ Rec kvs - , Show rec, NFData rec - , Serialisable rec - , AllFields Interpolatable kvs +type PointFields :: [ Symbol ] -> Constraint +class ( KnownSymbols pointFields, Typeable pointFields + , Serialisable ( Record pointFields ) + , Show ( Record pointFields ) + , NFData ( Record pointFields ) + , Interpolatable ( Record pointFields ) + , Representable ( ℝ ( Length pointFields ) ) ) - => SomeBrushFields + => PointFields pointFields where { } +instance ( KnownSymbols pointFields, Typeable pointFields + , Serialisable ( Record pointFields ) + , Show ( Record pointFields ) + , NFData ( Record pointFields ) + , Interpolatable ( Record pointFields ) + , Representable ( ℝ ( Length pointFields ) ) + ) + => PointFields pointFields where { } -instance Show SomeBrushFields where - show ( SomeBrushFields @kvs ) = show ( Proxy @kvs ) +-- | Assumes the input has no duplicates (doesn't check.) +provePointFields :: [ Text ] -> ( forall pointFields. PointFields pointFields => Proxy# pointFields -> r ) -> r +provePointFields fieldNames k = + case fieldNames of + [] + -> k ( proxy# @'[] ) + [ f1 ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + -> k ( proxy# @'[ f1 ] ) + [ f1, f2 ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 ) + -> k ( proxy# @'[ f1, f2 ] ) + [ f1, f2, f3 ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 ) + , SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 ) + -> k ( proxy# @'[ f1, f2, f3 ] ) + _ -> error $ "I haven't defined ℝ " ++ show ( length fieldNames ) +{-# INLINE provePointFields #-} --- | Reflects a list of brush fields to the type level. --- --- Assumes the input list has no duplicate field names, --- but they don't have to be sorted. -reflectBrushFieldsNoDups :: [ ( Text, SomeFieldSType ) ] -> SomeBrushFields -reflectBrushFieldsNoDups elts = - let - mkSomeSType :: SomeFieldSType -> SomeSType - mkSomeSType (SomeFieldSType @a) = SomeSType @a - mkField :: SomeFieldSType -> FieldSType Any - mkField (SomeFieldSType @a) = unsafeCoerce $ FieldSType @a - in - proveSomeSTypes (map (second mkSomeSType) elts) \ ( _ :: Proxy# kvs ) -> - let - dictsRec :: Record FieldSType kvs - dictsRec = MkR (HashMap.fromList $ map (second mkField) elts) - showDicts :: Record (Dict Show) kvs - showDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @Show @a ) dictsRec - nfDataDicts :: Record (Dict NFData) kvs - nfDataDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @NFData @a ) dictsRec - serialisableDicts :: Record (Dict Serialisable) kvs - serialisableDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @Serialisable @a ) dictsRec - interpolatableDicts :: Record (Dict Interpolatable) kvs - interpolatableDicts = Rec.map ( \ ( ( FieldSType @a ) ) -> Dict @Interpolatable @a ) dictsRec - in - proveRecordDicts @Show showDicts $ - proveRecordDicts @NFData nfDataDicts $ - proveRecordDicts @Serialisable serialisableDicts $ - proveRecordDicts @Interpolatable interpolatableDicts $ - SomeBrushFields @kvs +duplicates :: [ Text ] -> [ Text ] +duplicates = nub . duplicatesAcc [] [] + where + duplicatesAcc :: [ Text ] -> [ Text ] -> [ Text ] -> [ Text ] + duplicatesAcc _ dups [] = dups + duplicatesAcc seen dups ( k : kvs ) + | k `elem` seen + = duplicatesAcc seen ( k : dups ) kvs + | otherwise + = duplicatesAcc ( k : seen ) dups kvs diff --git a/src/metabrushes/MetaBrush/DSL/Interpolation.hs b/src/metabrushes/MetaBrush/DSL/Interpolation.hs deleted file mode 100644 index 70956dd..0000000 --- a/src/metabrushes/MetaBrush/DSL/Interpolation.hs +++ /dev/null @@ -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 diff --git a/src/metabrushes/MetaBrush/DSL/Types.hs b/src/metabrushes/MetaBrush/DSL/Types.hs deleted file mode 100644 index 98deb6b..0000000 --- a/src/metabrushes/MetaBrush/DSL/Types.hs +++ /dev/null @@ -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 ) diff --git a/src/metabrushes/MetaBrush/Document.hs b/src/metabrushes/MetaBrush/Document.hs index bd66bf8..dd41264 100644 --- a/src/metabrushes/MetaBrush/Document.hs +++ b/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 #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -45,8 +25,12 @@ import Data.Functor.Identity ( Identity(..) ) import Data.Semigroup ( Arg(..), Min(..), ArgMin ) +import Data.Typeable + ( Typeable ) import GHC.Generics ( Generic, Generic1 ) +import GHC.TypeLits + ( Symbol ) -- acts import Data.Act @@ -103,18 +87,11 @@ import Math.Module , Inner((^.^)) , squaredNorm, quadrance ) -import Math.Vector2D +import Math.Linear ( Point2D(..), Vector2D(..) ) import MetaBrush.Brush - ( Brush ) -import MetaBrush.Serialisable - ( Serialisable(..) ) -import MetaBrush.DSL.Types - ( STypesI ) -import MetaBrush.DSL.Interpolation - ( Interpolatable(..) ) + ( Brush, PointFields ) import MetaBrush.Records - ( Rec, AllFields ) import MetaBrush.Unique ( UniqueSupply, Unique, freshUnique ) @@ -189,12 +166,10 @@ type StrokeSpline clo brushParams = data Stroke where Stroke - :: ( KnownSplineType clo - , pointParams ~ Rec pointFields - , STypesI pointFields, STypesI brushFields - , Show pointParams, NFData pointParams - , AllFields Interpolatable pointFields - , Serialisable pointParams + :: forall clo pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] ) + . ( KnownSplineType clo + , pointParams ~ Record pointFields + , PointFields pointFields, Typeable pointFields ) => { strokeName :: !Text @@ -216,12 +191,10 @@ instance NFData Stroke where _strokeSpline :: forall f . Functor f - => ( forall clo pointParams pointFields + => ( forall clo pointParams ( pointFields :: [ Symbol ] ) . ( KnownSplineType clo - , Show pointParams, NFData pointParams - , AllFields Interpolatable pointFields - , pointParams ~ Rec pointFields, STypesI pointFields - , Serialisable pointParams + , pointParams ~ Record pointFields + , PointFields pointFields ) => StrokeSpline clo pointParams -> f ( StrokeSpline clo pointParams ) @@ -231,12 +204,10 @@ _strokeSpline f ( Stroke { strokeSpline = oldStrokeSpline, .. } ) = ( \ newSpline -> Stroke { strokeSpline = newSpline, .. } ) <$> f oldStrokeSpline overStrokeSpline - :: ( forall clo pointParams pointFields + :: ( forall clo pointParams ( pointFields :: [ Symbol ] ) . ( KnownSplineType clo - , Show pointParams, NFData pointParams - , AllFields Interpolatable pointFields - , pointParams ~ Rec pointFields, STypesI pointFields - , Serialisable pointParams + , pointParams ~ Record pointFields + , PointFields pointFields ) => StrokeSpline clo pointParams -> StrokeSpline clo pointParams @@ -373,7 +344,7 @@ instance Module Double diffBrushParams => Monoid ( DiffPointData diffBrushParams mempty = DiffPointData mempty origin mempty instance Module Double diffBrushParams => Group ( DiffPointData diffBrushParams ) where invert ( DiffPointData v1 p1 s1 ) = - DiffPointData ( invert v1 ) ( (-1) *^ p1 ) ( invert s1 ) + DiffPointData ( invert v1 ) ( -1 *^ p1 ) ( invert s1 ) instance ( Module Double diffBrushParams, Act diffBrushParams brushParams ) => Act ( DiffPointData diffBrushParams ) ( PointData brushParams ) where diff --git a/src/metabrushes/MetaBrush/Document/Draw.hs b/src/metabrushes/MetaBrush/Document/Draw.hs index 363f9f4..5feb8aa 100644 --- a/src/metabrushes/MetaBrush/Document/Draw.hs +++ b/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 #-} +{-# LANGUAGE OverloadedStrings #-} module MetaBrush.Document.Draw ( DrawAnchor(..), anchorsAreComplementary @@ -25,6 +14,8 @@ import Data.Functor ( ($>) ) import Data.Semigroup ( First(..) ) +import GHC.TypeLits + ( Symbol ) -- acts import Data.Act @@ -34,10 +25,6 @@ import Data.Act import Data.Sequence ( Seq(..) ) --- deepseq -import Control.DeepSeq - ( NFData ) - -- generic-lens import Data.Generics.Product.Fields ( field, field' ) @@ -70,12 +57,12 @@ import Math.Bezier.Spline ) import Math.Module ( squaredNorm ) -import Math.Vector2D - ( Point2D(..), Vector2D(..) ) +import Math.Linear + ( Point2D(..), Vector2D(..), ℝ(..) ) import MetaBrush.Assert ( assert ) import MetaBrush.Brush - ( Brush(..) ) + ( Brush(..), PointFields ) import MetaBrush.Document ( Document(..), DocumentContent(..) , Stroke(..), StrokeHierarchy(..), StrokeSpline @@ -83,16 +70,7 @@ import MetaBrush.Document , _selection, _strokeSpline , coords, overStrokeSpline ) -import MetaBrush.Serialisable - ( Serialisable ) -import MetaBrush.DSL.Types - ( STypesI ) -import MetaBrush.DSL.Interpolation - ( Interpolatable ) import MetaBrush.Records - ( Rec, AllFields ) -import qualified MetaBrush.Records as Rec - ( empty ) import MetaBrush.Unique ( Unique, UniqueSupply, freshUnique, uniqueText ) @@ -132,9 +110,9 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = ( newDoc, Nothing ) -> do uniq <- runReaderT freshUnique uniqueSupply let - newSpline :: StrokeSpline Open ( Rec '[] ) + newSpline :: StrokeSpline Open ( Record ( '[] :: [ Symbol ] ) ) newSpline = - Spline { splineStart = PointData c Normal Rec.empty + Spline { splineStart = PointData c Normal ( MkR ℝ0 ) , splineCurves = OpenCurves Empty } newStroke :: Stroke @@ -144,7 +122,7 @@ getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = , strokeVisible = True , strokeUnique = uniq , strokeSpline = newSpline - , strokeBrush = Nothing :: Maybe ( Brush '[] ) + , strokeBrush = Nothing :: Maybe ( Brush ( '[] :: [ Symbol ] ) ) } newDoc' :: Document newDoc' @@ -251,14 +229,11 @@ withAnchorBrushData :: forall r . DrawAnchor -> Document - -> ( forall pointParams pointFields brushFields - . ( pointParams ~ Rec pointFields - , STypesI pointFields, STypesI brushFields - , Show pointParams, NFData pointParams - , Serialisable pointParams - , AllFields Interpolatable pointFields + -> ( forall pointParams ( pointFields :: [ Symbol ] ) ( brushFields :: [ Symbol ] ) + . ( pointParams ~ Record pointFields + , PointFields pointFields ) - => Maybe (Brush brushFields) + => Maybe ( Brush brushFields ) -> pointParams -> r ) @@ -283,4 +258,4 @@ withAnchorBrushData anchor ( Document { documentContent = Content { strokes } } AnchorAtStart {} -> f strokeBrush ( brushParams ( splineStart strokeSpline ) ) AnchorAtEnd {} -> f strokeBrush ( brushParams ( splineEnd strokeSpline ) ) splineAnchor _ - = f (Nothing :: Maybe (Brush '[])) Rec.empty + = f @_ @'[] @'[] Nothing ( MkR ℝ0 ) diff --git a/src/metabrushes/MetaBrush/Document/History.hs b/src/metabrushes/MetaBrush/Document/History.hs index 7042c48..078e5f4 100644 --- a/src/metabrushes/MetaBrush/Document/History.hs +++ b/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 diff --git a/src/metabrushes/MetaBrush/Document/Serialise.hs b/src/metabrushes/MetaBrush/Document/Serialise.hs index d45add2..7420c36 100644 --- a/src/metabrushes/MetaBrush/Document/Serialise.hs +++ b/src/metabrushes/MetaBrush/Document/Serialise.hs @@ -1,19 +1,5 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} module MetaBrush.Document.Serialise ( documentToJSON, documentFromJSON @@ -28,12 +14,12 @@ import qualified Data.Bifunctor as Bifunctor ( first ) import Data.Functor.Identity ( Identity(..) ) -import Data.Typeable - ( eqT ) -import Data.Type.Equality - ( (:~:)(Refl) ) import Data.Version ( Version(versionBranch) ) +import GHC.Exts + ( Proxy# ) +import GHC.TypeLits + ( Symbol ) import Unsafe.Coerce ( unsafeCoerce ) -- Tony Morris special @@ -89,12 +75,12 @@ import qualified Waargonaut.Decode as JSON import qualified Waargonaut.Decode.Error as JSON ( DecodeError(ParseFailed) ) import qualified Waargonaut.Decode as JSON.Decoder - ( atKey, atKeyOptional, bool, objectAsKeyValues, text ) + ( atKey, atKeyOptional, bool, text, list ) import qualified Waargonaut.Encode as JSON ( Encoder ) import qualified Waargonaut.Encode as JSON.Encoder ( runEncoder - , atKey', bool, int, keyValueTupleFoldable, list, mapLikeObj, text + , atKey', bool, int, list, mapLikeObj, text ) import qualified Waargonaut.Encode.Builder as JSON.Builder ( waargonautBuilder, bsBuilder ) @@ -118,22 +104,17 @@ import qualified Waargonaut.Types.Whitespace as JSON -- metabrushes import Math.Bezier.Spline ( SplineType(..), SSplineType(..), SplineTypeI(..) ) -import Math.Vector2D +import Math.Linear ( Point2D(..), Vector2D(..)) import MetaBrush.Asset.Brushes ( lookupBrush ) import MetaBrush.Brush - ( Brush(..), SomeBrush(..) - , SomeFieldSType(..), SomeBrushFields(..) - , reflectBrushFieldsNoDups - ) + ( Brush(..), SomeBrush(..), provePointFields, duplicates ) import MetaBrush.Document ( Document(..), DocumentContent(..), Guide(..) , Stroke(..), StrokeHierarchy(..), StrokeSpline , PointData(..), FocusState(..) ) -import MetaBrush.DSL.Types - ( SomeSType(..), someSTypes ) import MetaBrush.Serialisable ( Serialisable(..) , encodeSequence, decodeSequence @@ -141,7 +122,7 @@ import MetaBrush.Serialisable , encodeSpline, decodeSpline ) import MetaBrush.Records - ( Rec ) + ( Record, knownSymbols ) import MetaBrush.Unique ( UniqueSupply, freshUnique ) @@ -203,21 +184,21 @@ loadDocument uniqueSupply fp = do -------------------------------------------------------------------------------- encodePointData - :: forall f flds brushParams + :: forall f ( flds :: [ Symbol ] ) brushParams . ( Applicative f - , brushParams ~ Rec flds - , Serialisable ( Rec flds ) + , brushParams ~ Record flds + , Serialisable ( Record flds ) ) => JSON.Encoder f ( PointData brushParams ) encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointCoords, brushParams } ) -> JSON.Encoder.atKey' "coords" ( encoder @( Point2D Double ) ) pointCoords - . JSON.Encoder.atKey' "brushParams" ( encoder @( Rec flds ) ) brushParams + . JSON.Encoder.atKey' "brushParams" ( encoder @( Record flds ) ) brushParams decodePointData - :: forall m flds brushParams + :: forall m ( flds :: [ Symbol ] ) brushParams . ( Monad m - , brushParams ~ Rec flds - , Serialisable ( Rec flds ) + , brushParams ~ Record flds + , Serialisable ( Record flds ) ) => JSON.Decoder m ( PointData brushParams ) decodePointData = do @@ -225,50 +206,22 @@ decodePointData = do let pointState :: FocusState pointState = Normal - brushParams <- JSON.Decoder.atKey "brushParams" ( decoder @( Rec flds ) ) + brushParams <- JSON.Decoder.atKey "brushParams" ( decoder @( Record flds ) ) pure ( PointData { pointCoords, pointState, brushParams } ) +encodeFields :: Monad f => JSON.Encoder f [ Text ] +encodeFields = JSON.Encoder.list JSON.Encoder.text -encodeSomeSType :: Applicative f => JSON.Encoder f SomeSType -encodeSomeSType = JSON.Encoder.mapLikeObj \ ( SomeSType @ty ) -> - if - | Just Refl <- eqT @ty @Double - -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "double" - | otherwise - -> error "SLD TODO" --( JSON.ParseFailed $ "Unsupported record field type (not double)" ) - -decodeSomeFieldSType :: Monad m => JSON.Decoder m SomeFieldSType -decodeSomeFieldSType = do - tag <- JSON.Decoder.atKey "tag" JSON.Decoder.text - case tag of - "double" -> pure ( SomeFieldSType @Double ) - _ -> throwError ( JSON.ParseFailed $ "Unsupported record field type with tag " <> tag ) - - -encodeFieldTypes :: Monad f => JSON.Encoder f [ ( Text, SomeSType ) ] -encodeFieldTypes = JSON.Encoder.keyValueTupleFoldable encodeSomeSType - -decodeFieldTypes :: Monad m => JSON.Decoder m SomeBrushFields -decodeFieldTypes = do - fields <- JSON.Decoder.objectAsKeyValues JSON.Decoder.text decodeSomeFieldSType - let - duplicates :: [ Text ] - duplicates = duplicatesAcc [] [] fields - duplicatesAcc :: [ Text ] -> [ Text ] -> [ ( Text, whatever ) ] -> [ Text ] - duplicatesAcc _ dups [] = dups - duplicatesAcc seen dups ( ( k, _ ) : kvs ) - | k `elem` seen - = duplicatesAcc seen ( k : dups ) kvs - | otherwise - = duplicatesAcc ( k : seen ) dups kvs - case duplicates of - [] -> pure ( reflectBrushFieldsNoDups fields ) +decodeFields :: Monad m => JSON.Decoder m [ Text ] +decodeFields = do + fields <- JSON.Decoder.list JSON.Decoder.text + case duplicates fields of + [] -> pure fields [dup] -> throwError ( JSON.ParseFailed $ "Duplicate field name " <> dup <> " in brush record type" ) dups -> throwError ( JSON.ParseFailed $ "Duplicate field names in brush record type:\n" <> Text.unwords dups ) - encodeBrush :: Applicative f => JSON.Encoder f (Brush brushFields) encodeBrush = JSON.Encoder.mapLikeObj \ ( BrushData { brushName } ) -> @@ -287,7 +240,7 @@ encodeStroke = JSON.Encoder.mapLikeObj \ ( Stroke { strokeName , strokeVisible - , strokeSpline = strokeSpline :: StrokeSpline clo ( Rec pointFields ) + , strokeSpline = strokeSpline :: StrokeSpline clo ( Record pointFields ) , strokeBrush } ) -> @@ -298,41 +251,41 @@ encodeStroke = JSON.Encoder.mapLikeObj SOpen -> False mbEncodeBrush :: JSON.MapLikeObj JSON.WS Json -> JSON.MapLikeObj JSON.WS Json mbEncodeBrush = case strokeBrush of - Nothing -> - id - Just brush -> - JSON.Encoder.atKey' "brush" encodeBrush brush + Nothing -> id + Just brush -> JSON.Encoder.atKey' "brush" encodeBrush brush in JSON.Encoder.atKey' "name" JSON.Encoder.text strokeName . JSON.Encoder.atKey' "visible" JSON.Encoder.bool strokeVisible . JSON.Encoder.atKey' "closed" JSON.Encoder.bool closed - . JSON.Encoder.atKey' "pointFields" encodeFieldTypes ( someSTypes @pointFields ) + . JSON.Encoder.atKey' "pointFields" encodeFields ( knownSymbols @pointFields ) . mbEncodeBrush . JSON.Encoder.atKey' "spline" ( encodeSpline encodePointData ) strokeSpline decodeStroke :: MonadIO m => UniqueSupply -> JSON.Decoder m Stroke decodeStroke uniqueSupply = do - strokeName <- JSON.Decoder.atKey "name" JSON.Decoder.text - strokeVisible <- JSON.Decoder.atKey "visible" JSON.Decoder.bool strokeUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply ) - strokeClosed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool - SomeBrushFields @pointFields <- JSON.Decoder.atKey "pointFields" decodeFieldTypes - mbSomeBrush <- JSON.Decoder.atKeyOptional "brush" decodeBrush - if strokeClosed - then do - strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Rec pointFields ) ) decodePointData ) - pure $ case mbSomeBrush of - Nothing -> - Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( Brush '[] ) } - Just (SomeBrush brush) -> - Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush } - else do - strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open @( PointData ( Rec pointFields ) ) decodePointData ) - pure $ case mbSomeBrush of - Nothing -> - Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( Brush '[] ) } - Just (SomeBrush brush) -> - Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush } + strokeName <- JSON.Decoder.atKey "name" JSON.Decoder.text + strokeVisible <- JSON.Decoder.atKey "visible" JSON.Decoder.bool + strokeClosed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool + mbSomeBrush <- JSON.Decoder.atKeyOptional "brush" decodeBrush + pointFields <- JSON.Decoder.atKey "pointFields" decodeFields + -- decodeFields ensured there were no duplicate field names. + provePointFields pointFields \ ( _ :: Proxy# pointFields ) -> + if strokeClosed + then do + strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Record pointFields ) ) decodePointData ) + pure $ case mbSomeBrush of + Nothing -> + Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( Brush '[] ) } + Just (SomeBrush brush) -> + Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush } + else do + strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open @( PointData ( Record pointFields ) ) decodePointData ) + pure $ case mbSomeBrush of + Nothing -> + Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Nothing :: Maybe ( Brush '[] ) } + Just (SomeBrush brush) -> + Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush = Just brush } encodeStrokeHierarchy :: Monad f => JSON.Encoder f StrokeHierarchy diff --git a/src/metabrushes/MetaBrush/Document/SubdivideStroke.hs b/src/metabrushes/MetaBrush/Document/SubdivideStroke.hs index 09549cd..c4db874 100644 --- a/src/metabrushes/MetaBrush/Document/SubdivideStroke.hs +++ b/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 #-} +{-# LANGUAGE OverloadedStrings #-} module MetaBrush.Document.SubdivideStroke ( subdivide ) @@ -57,15 +49,15 @@ import Math.Bezier.Stroke ( CachedStroke(..), invalidateCache ) import Math.Module ( lerp, quadrance, closestPointOnSegment ) -import Math.Vector2D - ( Point2D(..), Vector2D(..), Segment(..) ) +import Math.Linear + ( Point2D(..), Vector2D(..), Segment(..), T(..) ) import MetaBrush.Document ( Document(..), Stroke(..), StrokeHierarchy(..), StrokeSpline , PointData(..), DiffPointData(..) , coords, _strokeSpline ) -import MetaBrush.DSL.Interpolation - ( Interpolatable(Diff) ) +import MetaBrush.Records + ( Interpolatable ) -------------------------------------------------------------------------------- @@ -128,7 +120,7 @@ subdivide c doc@( Document { zoomFactor } ) = then let subdiv :: PointData brushParams - subdiv = lerp @( DiffPointData ( Diff brushParams ) ) t sp0 sp1 + subdiv = lerp @( DiffPointData ( T brushParams ) ) t sp0 sp1 in do put ( Just txt ) pure ( LineTo ( NextPoint subdiv ) ( invalidateCache dat ) :<| LineTo ( NextPoint sp1 ) ( invalidateCache dat ) :<| Empty ) @@ -143,7 +135,7 @@ subdivide c doc@( Document { zoomFactor } ) = Min ( Arg sqDist ( t, _ ) ) = Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier {..} ) ( invert offset • c ) in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 - then case Quadratic.subdivide @( DiffPointData ( Diff brushParams ) ) ( Quadratic.Bezier sp0 sp1 sp2 ) t of + then case Quadratic.subdivide @( DiffPointData ( T brushParams ) ) ( Quadratic.Bezier sp0 sp1 sp2 ) t of ( Quadratic.Bezier _ q1 subdiv, Quadratic.Bezier _ r1 _ ) -> do let bez_start, bez_end :: Curve Open ( CachedStroke RealWorld ) ( PointData brushParams ) @@ -162,7 +154,7 @@ subdivide c doc@( Document { zoomFactor } ) = Min ( Arg sqDist ( t, _ ) ) = Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier {..} ) ( invert offset • c ) in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 - then case Cubic.subdivide @( DiffPointData ( Diff brushParams ) ) ( Cubic.Bezier sp0 sp1 sp2 sp3 ) t of + then case Cubic.subdivide @( DiffPointData ( T brushParams ) ) ( Cubic.Bezier sp0 sp1 sp2 sp3 ) t of ( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) -> do let bez_start, bez_end :: Curve Open ( CachedStroke RealWorld ) ( PointData brushParams ) diff --git a/src/metabrushes/MetaBrush/Records.hs b/src/metabrushes/MetaBrush/Records.hs index 0165ec6..1a197c1 100644 --- a/src/metabrushes/MetaBrush/Records.hs +++ b/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 #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE PolyKinds #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -module MetaBrush.Records - ( Record(..), Rec, AllFields(..) - - , empty, insert, lookup, Lookup - - , map, mapM - , mapMWithKey - , zipWith - , cpure, cmap, czipWith - , cpureM, cpureMWithKey - , cmapWithKey - , collapse, foldRec - , proveRecordDicts - , describeRecord - , MyIntersection(..), myIntersect - - , WithParams(..) - - -- * Functors - , I(..), K(..), (:*:)(..), Dict(..) - ) - where +module MetaBrush.Records where -- base -import Prelude - hiding ( lookup, map, mapM, zipWith ) -import Data.Coerce - ( coerce ) -import Data.Functor.Const - ( Const(..) ) +import Data.Functor + ( (<&>) ) import Data.Kind ( Type, Constraint ) import Data.List - ( intersperse ) -import Data.Monoid - ( Endo(..) ) -import Data.Proxy - ( Proxy(..) ) + ( findIndex, intersperse ) import Data.Typeable - ( Typeable, TypeRep, typeRep ) -import GHC.TypeLits - ( Symbol, KnownSymbol, symbolVal' - , TypeError, ErrorMessage(..) - ) + ( Typeable, eqT ) +import Data.Type.Equality + ( (:~:)(Refl) ) import GHC.Exts - ( Any, proxy#, withDict ) + ( Word(W#), Proxy#, proxy# ) import GHC.Show ( showCommaSpace ) +import GHC.TypeLits + ( Symbol, KnownSymbol, symbolVal' + , SomeSymbol(..), someSymbolVal + ) +import GHC.TypeNats + ( Nat, type (+) ) import Unsafe.Coerce ( unsafeCoerce ) +-- acts +import Data.Act + ( Act(..), Torsor(..) ) + -- deepseq import Control.DeepSeq ( NFData(..) ) @@ -87,249 +45,217 @@ import Data.Text import qualified Data.Text as Text ( pack, unpack ) --- unordered-containers -import Data.HashMap.Strict - ( HashMap ) -import qualified Data.HashMap.Strict as HashMap +-- MetaBrush +import Math.Linear +import Math.Module -------------------------------------------------------------------------------- -type Record :: (Type -> Type) -> [(Symbol, Type)] -> Type -newtype Record f kvs = MkR { recordKeyVals :: HashMap Text (f Any) } +-- | A convenient constraint synonym for types that support interpolation. +type Interpolatable :: Type -> Constraint +class ( Torsor ( T r ) r, Module Double ( T r ) ) => Interpolatable r +instance ( Torsor ( T r ) r, Module Double ( T r ) ) => Interpolatable r -empty :: Record f '[] -empty = MkR HashMap.empty - -insert :: forall k v kvs f - . KnownSymbol k - => f v - -> Record f kvs - -> Record f ( '(k,v) ': kvs ) -insert v (MkR r) = MkR $ HashMap.insert k v' r - where - k :: Text - k = Text.pack $ symbolVal' @k proxy# - v' :: f Any - v' = unsafeCoerce v - -lookup :: forall k kvs f - . KnownSymbol k - => Record f kvs -> f (Lookup k kvs) -lookup ( MkR r ) = unsafeCoerce ( r HashMap.! k ) - where - k :: Text - k = Text.pack $ symbolVal' @k proxy# - -type Lookup :: Symbol -> [(Symbol, Type)] -> Type -type Lookup k kvs = LookupIn kvs k kvs - -type LookupIn :: [(Symbol, Type)] -> Symbol -> [(Symbol, Type)] -> Type -type family LookupIn orig k kvs where - LookupIn _ k ( '(k, v) ': _ ) = v - LookupIn orig k ( _ ': kvs ) = LookupIn orig k kvs - LookupIn orig k _ = TypeError - ( 'Text "Key '" :<>: ShowType k :<>: 'Text "' is not present in row:" - :$$: 'Text " - " :<>: ShowType orig ) - -type Rec :: [(Symbol, Type)] -> Type -type Rec kvs = Record I kvs - -type I :: Type -> Type -newtype I a = I { unI :: a } - deriving newtype ( Semigroup, Monoid, Group, NFData ) - -type K :: Type -> Type -> Type -newtype K a b = K { unK :: a } - deriving newtype ( Semigroup, Monoid, Group, NFData ) - -type (:*:) :: (Type -> Type) -> (Type -> Type) -> Type -> Type -data (f :*: g) a = f a :*: g a - -type Dict :: (Type -> Constraint) -> Type -> Type -data Dict c a where - Dict :: c a => Dict c a - -type AllFields :: (Type -> Constraint) -> [(Symbol, Type)] -> Constraint -class AllFields c kvs where - recordDicts :: Record (Dict c) kvs - -instance AllFields c '[] where - recordDicts = MkR HashMap.empty - -instance ( c v, KnownSymbol k, AllFields c kvs ) => AllFields c ( '(k, v) ': kvs ) where - recordDicts = case recordDicts @c @kvs of - MkR kvs -> MkR $ HashMap.insert k dict kvs - where - k :: Text - k = Text.pack $ symbolVal' @k proxy# - dict :: Dict c Any - dict = unsafeCoerce ( Dict :: Dict c v ) - -instance AllFields Show kvs => Show (Record I kvs) where - showsPrec d = aux . collapse . cmapWithKey @Show showField - where - showField :: Show x => Text -> I x -> K ShowS x - showField k (I x) = K $ showString (Text.unpack k) . showString " = " . showsPrec 0 x - - aux :: [ShowS] -> ShowS - aux fields = showParen (d >= 11) - $ showString "{" - . foldr (.) id (intersperse showCommaSpace fields) - . showString "}" +-------------------------------------------------------------------------------- +-- | A function from a given record type, with provided default values +-- that can be overridden. +type WithParams :: [ Symbol ] -> Type -> Type data WithParams params a = WithParams - { defaultParams :: Rec params - , withParams :: Rec params -> a + { defaultParams :: Record params + , withParams :: Record params -> a } -instance AllFields Semigroup kvs - => Semigroup (Record I kvs) where - (<>) = czipWith @Semigroup (<>) +-------------------------------------------------------------------------------- -instance ( AllFields Semigroup kvs - , AllFields Monoid kvs ) - => Monoid (Record I kvs) where - mempty = cpure @Monoid mempty +-- | A record of 'Double' values. +type Record :: [ k ] -> Type +newtype Record ks = MkR { recordKeyVals :: ℝ ( Length ks ) } -instance ( AllFields Semigroup kvs - , AllFields Monoid kvs - , AllFields Group kvs ) - => Group (Record I kvs) where - invert = cmap @Group ( \ (I g) -> I (invert g) ) +deriving newtype + instance Eq ( ℝ ( Length ks ) ) + => Eq ( Record ks ) +deriving newtype + instance Ord ( ℝ ( Length ks ) ) + => Ord ( Record ks ) +deriving newtype + instance NFData ( ℝ ( Length ks ) ) + => NFData ( Record ks ) -instance AllFields NFData kvs - => NFData ( Record I kvs ) where - rnf (MkR r) = HashMap.foldlWithKey' go () r - where - dicts :: HashMap Text (Dict NFData Any) - MkR dicts = recordDicts @NFData @kvs - go :: () -> Text -> I Any -> () - go !_ k (I a) = - case dicts HashMap.! k of - Dict -> rnf a +-- | Show a record, using the given type-level field names. +instance ( KnownSymbols ks, Representable ( ℝ ( Length ks ) ) ) + => Show ( Record ks ) where + showsPrec p ( MkR r ) + = showParen ( p >= 11 ) + $ showString "{" + . foldr (.) id ( intersperse showCommaSpace fields ) + . showString "}" + where + fields :: [ ShowS ] + fields = + zip [ 1.. ] ( knownSymbols @ks ) <&> \ ( W# i, fld ) -> + let v = index r ( Fin i ) + in showString ( Text.unpack fld ) . showString " = " . showsPrec 0 v -data MyIntersection r1 g r2 c where - MyIntersection - :: forall i r1 g r2 c - . ( AllFields c i ) - => { myProject :: forall f. Record f r1 -> Record (f :*: g) i - , myInject :: Record g i -> Record g r2 - } - -> MyIntersection r1 g r2 c +deriving via ( T ( ℝ ( Length ks ) ) ) + instance Semigroup ( T ( ℝ ( Length ks ) ) ) + => Semigroup ( T ( Record ks ) ) +deriving via ( T ( ℝ ( Length ks ) ) ) + instance Monoid ( T ( ℝ ( Length ks ) ) ) + => Monoid ( T ( Record ks ) ) +deriving via ( T ( ℝ ( Length ks ) ) ) + instance Group ( T ( ℝ ( Length ks ) ) ) + => Group ( T ( Record ks ) ) +deriving via ( T ( ℝ ( Length ks ) ) ) + instance Module Double ( T ( ℝ ( Length ks ) ) ) + => Module Double ( T ( Record ks ) ) -myIntersect - :: forall c r1 g r2 - . ( AllFields c r1 ) - => Record g r2 - -> MyIntersection r1 g r2 c -myIntersect (MkR r2) = - proveRecordDicts @c @Any intersectionDict - ( MyIntersection { myProject, myInject } ) +instance ( Act ( T ( ℝ ( Length ks ) ) ) ( ℝ ( Length ks ) ) + , Semigroup ( T ( ℝ ( Length ks ) ) ) ) + => Act ( T ( Record ks ) ) ( Record ks ) where + T ( MkR g ) • MkR a = MkR ( T g • a ) +instance ( Torsor ( T ( ℝ ( Length ks ) ) ) ( ℝ ( Length ks ) ) + , Group ( T ( ℝ ( Length ks ) ) ) ) + => Torsor ( T ( Record ks ) ) ( Record ks ) where + MkR g --> MkR a = T $ MkR $ unT $ g --> a + +-------------------------------------------------------------------------------- + +type Length :: [ k ] -> Nat +type family Length xs where + Length '[] = 0 + Length ( _ : xs ) = 1 + Length xs + +type KnownSymbols :: [ Symbol ] -> Constraint +class KnownSymbols ks where + knownSymbols :: [ Text ] +instance KnownSymbols '[] where + knownSymbols = [] + {-# INLINE knownSymbols #-} +instance ( KnownSymbol k, KnownSymbols ks ) => KnownSymbols ( k ': ks ) where + knownSymbols = Text.pack ( symbolVal' @k proxy# ) : knownSymbols @ks + {-# INLINE knownSymbols #-} + +-------------------------------------------------------------------------------- +-- Intersection of two records. + +{-# INLINE intersect #-} +intersect :: forall r1 r2 l1 l2 + . ( Typeable r1, Typeable r2 + , KnownSymbols r1, KnownSymbols r2 + , l1 ~ Length r1, l2 ~ Length r2 + , Representable ( ℝ l1 ), Representable ( ℝ l2 ) + , Interpolatable ( Record r1 ) + ) + => Intersection r1 r2 +intersect + -- Shortcut when the two rows are equal. + | Just Refl <- eqT @r1 @r2 + , Refl <- ( unsafeCoerce Refl :: r1 :~: Intersect r1 r2 ) + = Intersection { project = id, inject = const } + | otherwise + = doIntersection @r1 @r2 \ ( _ :: Proxy# r1r2 ) r1_idxs r2_idxs -> + let + project :: Record r1 -> Record r1r2 + project = \ ( MkR r1 ) -> MkR $ projection ( (!) r1_idxs ) r1 + + inject :: Record r1r2 -> Record r2 -> Record r2 + inject = \ ( MkR r1r2 ) ( MkR r2 ) -> MkR $ injection ( find eqFin r2_idxs ) r1r2 r2 + in Intersection { project, inject } + +data Intersection r1 r2 where + Intersection + :: forall r1r2 r1 r2 + . ( KnownSymbols r1r2, Representable ( ℝ ( Length r1r2 ) ) + , Interpolatable ( Record r1r2 ) ) + => { project :: Record r1 -> Record r1r2 + , inject :: Record r1r2 -> Record r2 -> Record r2 + } -> Intersection r1 r2 + +{-# INLINE doIntersection #-} +doIntersection + :: forall r1 r2 l1 l2 kont + . ( KnownSymbols r1, KnownSymbols r2 + , l1 ~ Length r1, l2 ~ Length r2 + , Representable ( ℝ l1 ), Representable ( ℝ l2 ) + ) + => ( forall r1r2 l12. + ( r1r2 ~ Intersect r1 r2, l12 ~ Length r1r2 + , Representable ( ℝ l12 ), Interpolatable ( ℝ l12 ) + , KnownSymbols r1r2, Representable ( ℝ ( Length r1r2 ) ) + ) + => Proxy# r1r2 -> Vec l12 ( Fin l1 ) -> Vec l12 ( Fin l2 ) -> kont ) + -> kont +doIntersection k = + case knownSymbols @r1 `intersectLists` knownSymbols @r2 of + + [ ] + | ( _ :: Proxy# r1r2 ) <- proxy# @'[ ] + , Refl <- ( unsafeCoerce Refl :: r1r2 :~: Intersect r1 r2 ) + -> k @'[] proxy# + VZ + VZ + + [ ( f1, W# r1_i1, W# r2_i1 ) ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1 ] + , Refl <- ( unsafeCoerce Refl :: r1r2 :~: Intersect r1 r2 ) + -> k @r1r2 proxy# + ( VS ( Fin r1_i1 ) VZ ) + ( VS ( Fin r2_i1 ) VZ ) + + [ ( f1, W# r1_i1, W# r2_i1 ) + , ( f2, W# r1_i2, W# r2_i2 ) ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 ) + , ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1, f2 ] + , Refl <- ( unsafeCoerce Refl :: r1r2 :~: Intersect r1 r2 ) + -> k @r1r2 proxy# + ( VS ( Fin r1_i1 ) $ VS ( Fin r1_i2 ) VZ ) + ( VS ( Fin r2_i1 ) $ VS ( Fin r2_i2 ) VZ ) + + [ ( f1, W# r1_i1, W# r2_i1 ) + , ( f2, W# r1_i2, W# r2_i2 ) + , ( f3, W# r1_i3, W# r2_i3 ) ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 ) + , SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 ) + , ( _ :: Proxy# r1r2 ) <- proxy# @'[ f1, f2, f3 ] + , Refl <- ( unsafeCoerce Refl :: r1r2 :~: Intersect r1 r2 ) + -> k @r1r2 proxy# + ( VS ( Fin r1_i1 ) $ VS ( Fin r1_i2 ) $ VS ( Fin r1_i3 ) VZ ) + ( VS ( Fin r2_i1 ) $ VS ( Fin r2_i2 ) $ VS ( Fin r2_i3 ) VZ ) + + other -> error $ "Intersection not defined in dimension " ++ show ( length other ) + +------ +-- Functions for intersection. + +intersectLists :: forall k. Eq k => [ k ] -> [ k ] -> [ ( k, Word, Word ) ] +intersectLists = go 1 where - myProject :: Record f r1 -> Record (f :*: g) Any - myProject (MkR r1) = MkR (HashMap.intersectionWith (:*:) r1 r2) - myInject :: Record g Any -> Record g r2 - myInject (MkR i) = MkR (HashMap.union i r2) - intersectionDict :: Record (Dict c) Any - intersectionDict = - case recordDicts @c @r1 of - MkR d -> MkR (HashMap.intersection d r2) + go :: Word -> [ k ] -> [ k ] -> [ ( k, Word, Word ) ] + go _ [] _ + = [] + go i ( k : ks ) r + | Just j <- findIndex ( k == ) r + = ( k, i, fromIntegral j + 1 ) : go ( i + 1 ) ks r + | otherwise + = go ( i + 1 ) ks r -proveRecordDicts :: forall c r x. Record (Dict c) r -> (AllFields c r => x) -> x -proveRecordDicts = withDict @(AllFields c r) +type Intersect :: [ k ] -> [ k ] -> [ k ] +type family Intersect r1 r2 where + Intersect '[] _ = '[] + Intersect ( k ': ks ) r = DoIntersection k ks r ( Elem k r ) -describeRecord :: forall kvs. AllFields Typeable kvs => [ ( Text, TypeRep ) ] -describeRecord = collapse $ cmapWithKey @Typeable describeField (recordDicts @Typeable @kvs) - where - describeField :: forall a. Text -> Dict Typeable a -> K ( Text, TypeRep ) a - describeField k Dict = K ( k, typeRep ( Proxy :: Proxy a ) ) +type DoIntersection :: k -> [ k ] -> [ k ] -> Bool -> [ k ] +type family DoIntersection k ks r mb_j where + DoIntersection _ ks r False = Intersect ks r + DoIntersection k ks r True = k ': Intersect ks r ------------------------------------------------------------- --- Record combinators. - -map :: ( forall x. f x -> g x ) - -> Record f kvs -> Record g kvs -map f (MkR r) = MkR $ fmap f r - -mapM :: Applicative m - => ( forall x. f x -> m ( g x ) ) - -> Record f kvs -> m (Record g kvs) -mapM f (MkR r) = - MkR <$> traverse f r - -mapMWithKey :: forall m kvs f g - . Applicative m - => ( forall x. Text -> f x -> m ( g x ) ) - -> Record f kvs -> m (Record g kvs) -mapMWithKey f (MkR r) = - MkR <$> HashMap.traverseWithKey f r - -cpure :: forall c kvs f - . AllFields c kvs - => ( forall x. c x => f x ) - -> Record f kvs -cpure f = - MkR $ fmap (\ Dict -> f) (recordKeyVals $ recordDicts @c @kvs) - -cmap :: forall c kvs f g - . AllFields c kvs - => ( forall x. c x => f x -> g x ) - -> Record f kvs - -> Record g kvs -cmap f (MkR r) = - MkR $ HashMap.intersectionWith (\ Dict x -> f x) (recordKeyVals $ recordDicts @c @kvs) r - -zipWith :: forall kvs f g h - . ( forall x. f x -> g x -> h x ) - -> Record f kvs - -> Record g kvs - -> Record h kvs -zipWith f (MkR r1) (MkR r2) = - MkR $ HashMap.intersectionWith (\ x y -> f x y) r1 r2 - -czipWith :: forall c kvs f g h - . AllFields c kvs - => ( forall x. c x => f x -> g x -> h x ) - -> Record f kvs - -> Record g kvs - -> Record h kvs -czipWith f (MkR r1) (MkR r2) = - MkR $ HashMap.intersectionWith (\ Dict (x :*: y) -> f x y) (recordKeyVals $ recordDicts @c @kvs) pairs - where - pairs :: HashMap Text ((f :*: g) Any) - pairs = HashMap.intersectionWith (\ x y -> x :*: y) r1 r2 - -cpureM :: forall c m kvs f - . ( Applicative m, AllFields c kvs) - => ( forall x. c x => m (f x) ) - -> m ( Record f kvs ) -cpureM f = mapM (\Dict -> f) (recordDicts @c @kvs) - -cpureMWithKey :: forall c m kvs f - . ( Applicative m, AllFields c kvs) - => ( forall x. c x => Text-> m (f x) ) - -> m ( Record f kvs ) -cpureMWithKey f = mapMWithKey (\k Dict -> f k) (recordDicts @c @kvs) - -cmapWithKey :: forall c kvs f g - . AllFields c kvs - => (forall x. c x => Text -> f x -> g x) - -> Record f kvs - -> Record g kvs -cmapWithKey f = zipWithKey ( \ k Dict x -> f k x ) (recordDicts @c @kvs) - -zipWithKey :: forall r f g h - . ( forall x. Text -> f x -> g x -> h x ) - -> Record f r -> Record g r -> Record h r -zipWithKey f (MkR a) (MkR b) = MkR $ - HashMap.intersectionWithKey f a b - -foldRec :: forall y f r. ( forall x . f x -> y -> y ) -> Record f r -> y -> y -foldRec f r = coerce $ mapM g r - where - g :: ( forall x. f x -> Const (Endo y) (I x) ) - g x = coerce (f x) - -collapse :: Record (K a) r -> [a] -collapse (MkR a) = coerce $ HashMap.elems a +type Elem :: k -> [ k ] -> Bool +type family Elem k ks where + Elem _ '[] = False + Elem k ( k ': _ ) = True + Elem k ( _ ': ks ) = Elem k ks diff --git a/src/metabrushes/MetaBrush/Serialisable.hs b/src/metabrushes/MetaBrush/Serialisable.hs index 0e3a20e..90fd5a9 100644 --- a/src/metabrushes/MetaBrush/Serialisable.hs +++ b/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 #-} +{-# LANGUAGE OverloadedStrings #-} module MetaBrush.Serialisable ( Serialisable(..) @@ -31,12 +17,18 @@ import Control.Monad.ST ( RealWorld, stToIO ) import Data.Foldable ( toList ) +import Data.Functor + ( (<&>) ) import Data.Functor.Contravariant ( contramap ) import Data.Functor.Identity ( Identity(..) ) import Data.STRef ( newSTRef ) +import Data.Traversable + ( for ) +import GHC.Exts + ( Word(W#) ) -- containers import Data.Map.Strict @@ -78,11 +70,7 @@ import qualified Waargonaut.Decode as JSON.Decoder import qualified Waargonaut.Encode as JSON ( Encoder ) import qualified Waargonaut.Encode as JSON.Encoder - ( runPureEncoder - , atKey', json, keyValueTupleFoldable, list, mapLikeObj, scientific, text, either - ) -import Waargonaut.Types.Json - ( Json ) + ( atKey', keyValueTupleFoldable, list, mapLikeObj, scientific, text, either ) -- meta-brushes import Math.Bezier.Spline @@ -91,13 +79,11 @@ import Math.Bezier.Spline ) import Math.Bezier.Stroke ( CachedStroke(..) ) -import MetaBrush.Records - ( Record, Rec, AllFields - , I(..), K(..) - , collapse, cmapWithKey, cpureMWithKey +import Math.Linear + ( Point2D(..), Vector2D(..), ℝ(..) + , Fin(..), Representable(tabulate, index) ) -import Math.Vector2D - ( Point2D(..), Vector2D(..) ) +import MetaBrush.Records import MetaBrush.Unique ( Unique ) @@ -121,24 +107,20 @@ instance Serialisable a => Serialisable ( Vector2D a ) where encoder = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) -> JSON.Encoder.atKey' "x" encoder x . JSON.Encoder.atKey' "y" encoder y - decoder = Vector2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder - -instance Serialisable a => Serialisable (I a) where - encoder = contramap unI encoder - decoder = fmap I decoder - -instance ( AllFields Serialisable kvs ) - => Serialisable ( Record I kvs ) where - encoder :: forall f. Monad f => JSON.Encoder f ( Rec kvs ) - encoder = contramap encodeFields ( JSON.Encoder.keyValueTupleFoldable JSON.Encoder.json ) + decoder = Vector2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder +instance ( KnownSymbols ks, Representable ( ℝ ( Length ks ) ) ) => Serialisable ( Record ks ) where + encoder = contramap encodeFields ( JSON.Encoder.keyValueTupleFoldable ( encoder @Double ) ) where - encodeFields :: Record I kvs -> [ ( Text, Json ) ] - encodeFields = collapse . cmapWithKey @Serialisable keyVal - keyVal :: Serialisable x => Text -> I x -> K (Text, Json) x - keyVal k (I x) = K ( k, JSON.Encoder.runPureEncoder encoder x ) + encodeFields :: Record ks -> [ ( Text, Double ) ] + encodeFields ( MkR r ) = + zip [1..] ( knownSymbols @ks ) <&> \ ( W# i, fld ) -> + ( fld, index r ( Fin i ) ) - decoder :: forall m. Monad m => JSON.Decoder m ( Rec kvs ) - decoder = cpureMWithKey @Serialisable ( \ k -> JSON.Decoder.atKey k decoder ) + decoder = fmap decodeFields $ for ( knownSymbols @ks ) \ k -> JSON.Decoder.atKey k ( decoder @Double ) + where + decodeFields :: [ Double ] -> Record ks + decodeFields coords = MkR $ tabulate \ ( Fin i# ) -> + coords !! ( fromIntegral ( W# i# ) - 1 ) -------------------------------------------------------------------------------- diff --git a/src/metabrushes/MetaBrush/Unique.hs b/src/metabrushes/MetaBrush/Unique.hs index 2fab38f..3651b0f 100644 --- a/src/metabrushes/MetaBrush/Unique.hs +++ b/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 #-} +{-# LANGUAGE OverloadedStrings #-} module MetaBrush.Unique ( MonadUnique(freshUnique) @@ -79,7 +70,7 @@ newtype Unique = Unique { unique :: Int64 } deriving newtype ( Eq, Ord, Enum, Storable, NFData ) unsafeUnique :: Word32 -> Unique -unsafeUnique i = Unique ( - fromIntegral i - 1 ) +unsafeUnique i = Unique ( -(fromIntegral i) - 1 ) uniqueText :: Unique -> Text uniqueText ( Unique i ) diff --git a/src/metabrushes/MetaBrush/Util.hs b/src/metabrushes/MetaBrush/Util.hs index d143dd7..55e9e22 100644 --- a/src/metabrushes/MetaBrush/Util.hs +++ b/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(..) diff --git a/src/splines/Math/Bezier/Cubic.hs b/src/splines/Math/Bezier/Cubic.hs index 52fb2f1..05ebe73 100644 --- a/src/splines/Math/Bezier/Cubic.hs +++ b/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 - ( Point2D(..), Vector2D(..) ) +import Math.Linear + ( Point2D(..), Vector2D(..), T(..) ) -------------------------------------------------------------------------------- @@ -91,13 +77,15 @@ data Bezier p via Generically1 Bezier deriving anyclass ( NFData, NFData1 ) +deriving via Ap Bezier p + instance {-# OVERLAPPING #-} Act v p => Act v ( Bezier p ) +deriving via Ap Bezier ( T b ) + instance Module r ( T b ) => Module r ( T ( Bezier b ) ) + instance Show p => Show (Bezier p) where show (Bezier p1 p2 p3 p4) = show p1 ++ "--" ++ show p2 ++ "--" ++ show p3 ++ "->" ++ show p4 -deriving via Ap Bezier p - instance {-# OVERLAPPING #-} Act v p => Act v ( Bezier p ) - -- | Degree raising: convert a quadratic Bézier curve to a cubic Bézier curve. fromQuadratic :: forall v r p. ( Torsor v p, Module r v, Fractional r ) => Quadratic.Bezier p -> Bezier p fromQuadratic ( Quadratic.Bezier { p0 = q0, p1 = q1, p2 = q2 } ) = Bezier {..} @@ -114,7 +102,7 @@ bezier ( Bezier {..} ) t = ( Quadratic.bezier @v ( Quadratic.Bezier p0 p1 p2 ) t ) ( Quadratic.bezier @v ( Quadratic.Bezier p1 p2 p3 ) t ) --- | Derivative of cubic Bézier curve. +-- | Derivative of a cubic Bézier curve. bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v bezier' ( Bezier {..} ) = ( 3 *^ ) @@ -149,7 +137,7 @@ squaredCurvature bez t -- | Signed curvature of a planar cubic Bézier curve. signedCurvature :: forall r. Floating r => Bezier ( Point2D r ) -> r -> r -signedCurvature bez t = ( g' `cross` g'' ) / norm g' +signedCurvature bez t = ( g' `cross` g'' ) / norm g' ^ ( 3 :: Int ) where g', g'' :: Vector2D r g' = bezier' @( Vector2D r ) bez t @@ -235,7 +223,7 @@ drag ( Bezier {..} ) t q = Bezier { p0, p1 = p1', p2 = p2', p3 } -- | Compute parameter values for the self-intersection of a planar cubic Bézier curve, if such exist. -- --- The parameter values might lie outside the interval [0,1], +-- The parameter values might lie outside the interval [0,1], -- indicating a self-intersection of the extended curve. -- -- Formula taken from: diff --git a/src/splines/Math/Bezier/Cubic/Fit.hs b/src/splines/Math/Bezier/Cubic/Fit.hs index 3ee2424..08cc3a5 100644 --- a/src/splines/Math/Bezier/Cubic/Fit.hs +++ b/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(..) ) -------------------------------------------------------------------------------- @@ -180,7 +171,7 @@ fitSpline ( FitParameters {..} ) = go 0 -- -- Proceeds by fitting a cubic Bézier curve \( B(t) \), \( 0 \leqslant t \leqslant 1 \), -- with given endpoints and tangents, which minimises the sum of squares functional --- +-- -- \[ \sum_{i=1}^n \Big \| B(t_i) - q_i \Big \|^2. \] -- -- The values of the parameters \( \left ( t_i \right )_{i=1}^n \) are recursively estimated, @@ -219,7 +210,7 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr = f1 t = h2 t *^ tr f2 t = h0 t *^ ( MkVector2D p ) f3 t = h3 t *^ ( MkVector2D r ) - + loop :: forall s. Unboxed.MVector s Double -> Int -> ST s ( Cubic.Bezier ( Point2D Double ), ArgMax Double Double ) loop ts count = do let @@ -248,8 +239,8 @@ fitPiece dist_tol t_tol maxIters p tp qs r tr = let -- Convert from Hermite form to Bézier form. cp1, cp2 :: Point2D Double - cp1 = ( ( s1 / 3 ) *^ tp ) • p - cp2 = ( ( (-s2) / 3 ) *^ tr ) • r + cp1 = ( ( s1 / 3 ) *^ tp ) • p + cp2 = ( ( -s2 / 3 ) *^ tr ) • r bez :: Cubic.Bezier ( Point2D Double ) bez = Cubic.Bezier p cp1 cp2 r diff --git a/src/splines/Math/Bezier/Envelope.hs b/src/splines/Math/Bezier/Envelope.hs index 3801d7d..1137fa8 100644 --- a/src/splines/Math/Bezier/Envelope.hs +++ b/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 ) @@ -515,7 +508,7 @@ envelope31 path ( Segment b10 b11 ) ( Segment b20 b21 ) ( Segment b30 b31 ) - ) t0 = [ - a1 / a0 ] + ) t0 = [ -a1 / a0 ] where @@ -553,7 +546,7 @@ envelope21 path ( Segment b00 b01 ) ( Segment b10 b11 ) ( Segment b20 b21 ) - ) t0 = [ - a1 / a0 ] + ) t0 = [ -a1 / a0 ] where @@ -590,7 +583,7 @@ envelope11 ( Segment p0 p1 ) ( Segment ( Segment b00 b01 ) ( Segment b10 b11 ) - ) t0 = [ - a1 / a0 ] + ) t0 = [ -a1 / a0 ] where diff --git a/src/splines/Math/Bezier/Quadratic.hs b/src/splines/Math/Bezier/Quadratic.hs index 8bbbba8..dfe1680 100644 --- a/src/splines/Math/Bezier/Quadratic.hs +++ b/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 #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module Math.Bezier.Quadratic ( Bezier(..) @@ -68,8 +56,8 @@ import Math.Module ) import Math.Roots ( realRoots ) -import Math.Vector2D - ( Point2D(..), Vector2D(..) ) +import Math.Linear + ( Point2D(..), Vector2D(..), T(..) ) -------------------------------------------------------------------------------- @@ -86,18 +74,20 @@ data Bezier p via Generically1 Bezier deriving anyclass ( NFData, NFData1 ) +deriving via Ap Bezier p + instance {-# OVERLAPPING #-} Act v p => Act v ( Bezier p ) +deriving via Ap Bezier ( T b ) + instance Module r ( T b ) => Module r ( T ( Bezier b ) ) + instance Show p => Show (Bezier p) where show (Bezier p1 p2 p3) = show p1 ++ "--" ++ show p2 ++ "->" ++ show p3 -deriving via Ap Bezier p - instance {-# OVERLAPPING #-} Act v p => Act v ( Bezier p ) - -- | Quadratic Bézier curve. bezier :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> p bezier ( Bezier {..} ) t = lerp @v t ( lerp @v t p0 p1 ) ( lerp @v t p1 p2 ) --- | Derivative of quadratic Bézier curve. +-- | Derivative of a quadratic Bézier curve. bezier' :: forall v r p. ( Torsor v p, Module r v ) => Bezier p -> r -> v bezier' ( Bezier {..} ) t = 2 *^ lerp @v t ( p0 --> p1 ) ( p1 --> p2 ) @@ -126,7 +116,7 @@ squaredCurvature bez t -- | Signed curvature of a planar quadratic Bézier curve. signedCurvature :: forall r. Floating r => Bezier ( Point2D r ) -> r -> r -signedCurvature bez t = ( g' `cross` g'' ) / norm g' +signedCurvature bez t = ( g' `cross` g'' ) / norm g' ^ ( 3 :: Int ) where g', g'' :: Vector2D r g' = bezier' @( Vector2D r ) bez t diff --git a/src/splines/Math/Bezier/Spline.hs b/src/splines/Math/Bezier/Spline.hs index 1a2a8f6..eca3096 100644 --- a/src/splines/Math/Bezier/Spline.hs +++ b/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 diff --git a/src/splines/Math/Bezier/Stroke.hs b/src/splines/Math/Bezier/Stroke.hs index 2726d36..c68b01d 100644 --- a/src/splines/Math/Bezier/Stroke.hs +++ b/src/splines/Math/Bezier/Stroke.hs @@ -1,27 +1,20 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-type-defaults #-} module Math.Bezier.Stroke ( Offset(..) , CachedStroke(..), discardCache, invalidateCache , computeStrokeOutline, joinWithBrush , withTangent + + -- * Brush stroking + + -- $brushes + , brushStroke, envelopeEquation + , linear, bezier2, bezier3 +-- , uncurryD + ) where @@ -119,8 +112,8 @@ import Math.Orientation ) import Math.Roots ( solveQuadratic ) -import Math.Vector2D - ( Point2D(..), Vector2D(..) ) +import Math.Linear +import Math.Linear.Dual -------------------------------------------------------------------------------- @@ -208,10 +201,10 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart = endPt :: ptData endPt = openCurveEnd lastCurve startTgtFwd, startTgtBwd, endTgtFwd, endTgtBwd :: Vector2D Double - startTgtFwd = snd ( firstOutlineFwd 0 ) - startTgtBwd = (-1) *^ snd ( firstOutlineBwd 1 ) - endTgtFwd = snd ( lastOutlineFwd 1 ) - endTgtBwd = (-1) *^ snd ( lastOutlineBwd 0 ) + startTgtFwd = snd ( firstOutlineFwd 0 ) + startTgtBwd = -1 *^ snd ( firstOutlineBwd 1 ) + endTgtFwd = snd ( lastOutlineFwd 1 ) + endTgtBwd = -1 *^ snd ( lastOutlineBwd 0 ) startBrush, endBrush :: SplinePts Closed startBrush = brushShape spt0 endBrush = brushShape endPt @@ -223,11 +216,11 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart = Empty -> endTangent spt0 spt0 lastCurve _ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve startTestTgt, endTestTgt :: Vector2D Double - startTestTgt = Vector2D sty (-stx) + startTestTgt = Vector2D sty -stx where stx, sty :: Double Vector2D stx sty = startTgt - endTestTgt = Vector2D ety (-etx) + endTestTgt = Vector2D ety -etx where etx, ety :: Double Vector2D etx ety = endTgt @@ -270,10 +263,10 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart = endTgt = case prevCurves of Empty -> endTangent spt0 spt0 lastCurve _ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve - startTgtFwd = snd ( firstOutlineFwd 0 ) - startTgtBwd = (-1) *^ snd ( firstOutlineBwd 1 ) - endTgtFwd = snd ( lastOutlineFwd 1 ) - endTgtBwd = (-1) *^ snd ( lastOutlineBwd 0 ) + startTgtFwd = snd ( firstOutlineFwd 0 ) + startTgtBwd = -1 *^ snd ( firstOutlineBwd 1 ) + endTgtFwd = snd ( lastOutlineFwd 1 ) + endTgtBwd = -1 *^ snd ( lastOutlineBwd 0 ) fwdStartCap, bwdStartCap :: SplinePts Open TwoSided fwdStartCap bwdStartCap = fmap fst . snd . runWriter @@ -326,10 +319,10 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart = tgt, next_tgt, tgtFwd, next_tgtFwd, tgtBwd, next_tgtBwd :: Vector2D Double tgt = startTangent spt0 ptData curve next_tgt = endTangent spt0 ptData curve - tgtFwd = snd ( fwd 0 ) - next_tgtFwd = snd ( fwd 1 ) - tgtBwd = (-1) *^ snd ( bwd 1 ) - next_tgtBwd = (-1) *^ snd ( bwd 0 ) + tgtFwd = snd ( fwd 0 ) + next_tgtFwd = snd ( fwd 1 ) + tgtBwd = -1 *^ snd ( bwd 1 ) + next_tgtBwd = -1 *^ snd ( bwd 0 ) lift $ tellBrushJoin ( prevTgt, prev_tgtFwd, tgtBwd ) ptData ( tgt, tgtFwd, prev_tgtBwd ) lift $ updateCurveData ( curveData curve ) fwd bwd put ( next_tgt, next_tgtFwd, next_tgtBwd ) @@ -385,14 +378,14 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart = ( fwdCond, bwdCond ) | prevTgt `cross` tgt < 0 && prevTgt ^.^ tgt < 0 = ( isJust $ between ori prevTgtFwd tgtFwd testTgt1 - , isJust $ between ori prevTgtBwd tgtBwd ( (-1) *^ testTgt1 ) + , isJust $ between ori prevTgtBwd tgtBwd ( -1 *^ testTgt1 ) ) | otherwise = ( not . isJust $ between ori prevTgtFwd tgtFwd testTgt2 - , not . isJust $ between ori prevTgtBwd tgtBwd ( (-1) *^ testTgt2 ) + , not . isJust $ between ori prevTgtBwd tgtBwd ( -1 *^ testTgt2 ) ) testTgt1, testTgt2 :: Vector2D Double - testTgt1 = Vector2D (-ty) tx + testTgt1 = Vector2D -ty tx where tx, ty :: Double Vector2D tx ty = tgt ^-^ prevTgt @@ -400,7 +393,7 @@ computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart = | prevTgt ^.^ tgt < 0 = testTgt1 | otherwise - = (-1) *^ ( tgt ^+^ prevTgt ) + = -1 *^ ( tgt ^+^ prevTgt ) fwdJoin, bwdJoin :: SplinePts Open fwdJoin | tgtFwd `strictlyParallel` prevTgtFwd @@ -504,14 +497,14 @@ outlineFunctions ptParams brushFn sp0 crv = | otherwise = offTgt u bwd t - = ( off s --offset ( withTangent ( (-1) *^ bwd' s ) ( brush s ) ) • f s + = ( off s --offset ( withTangent ( -1 *^ bwd' s ) ( brush s ) ) • f s , bwd' s ) where s :: Double s = 1 - t off :: Double -> Point2D Double - off u = offset ( withTangent ( (-1) *^ f' u ) ( brush u ) ) • f u + off u = offset ( withTangent ( -1 *^ f' u ) ( brush u ) ) • f u offTgt :: Double -> Vector2D Double offTgt u | u < 0.5 @@ -521,7 +514,7 @@ outlineFunctions ptParams brushFn sp0 crv = bwd' :: Double -> Vector2D Double bwd' u | squaredNorm ( offTgt u ) < epsilon - = (-1) *^ f' u + = -1 *^ f' u | otherwise = offTgt u in ( fwd, bwd ) @@ -648,7 +641,7 @@ splitFirstPiece t ( Spline { splineStart = sp0, splineCurves = OpenCurves curves $ LineTo { curveEnd = NextPoint p , curveData = () } } , Spline - { splineStart = p + { splineStart = p , splineCurves = OpenCurves . Seq.singleton $ LineTo { curveEnd = NextPoint p1, curveData = () } } @@ -804,3 +797,94 @@ withTangent tgt_wanted spline@( Spline { splineStart } ) , offsetParameter = Just t , offset = MkVector2D $ Cubic.bezier @( Vector2D Double ) bez t } + +-------------------------------------------------------------------------------- + +-- $brushes +-- +-- You can compute the envelope equation for a brush stroke by using +-- the functions 'linear', 'bezier2' and 'bezier3' in conjunction with +-- the 'brushStroke' function, e.g. +-- +-- > brushStroke ( bezier2 path ) ( uncurryD $ fmap bezier3 brush ) + +-- | Linear interpolation, as a differentiable function. +linear :: forall b. ( Module Double ( T b ), Torsor ( T b ) b ) + => Segment b -> ℝ 1 ~> b +linear ( Segment a b ) = D \ ( ℝ1 t ) -> + D1 ( lerp @( T b ) t a b ) + ( a --> b ) + origin + +-- | A quadratic Bézier curve, as a differentiable function. +bezier2 :: forall b. ( Module Double ( T b ), Torsor ( T b ) b ) + => Quadratic.Bezier b -> ℝ 1 ~> b +bezier2 bez = D \ ( ℝ1 t ) -> + D1 ( Quadratic.bezier @( T b ) bez t ) + ( Quadratic.bezier' bez t ) + ( Quadratic.bezier'' bez ) + +-- | A cubic Bézier curve, as a differentiable function. +bezier3 :: forall b. ( Module Double ( T b ), Torsor ( T b ) b ) + => Cubic.Bezier b -> ℝ 1 ~> b +bezier3 bez = D \ ( ℝ1 t ) -> + D1 ( Cubic.bezier @( T b ) bez t ) + ( Cubic.bezier' bez t ) + ( Cubic.bezier'' bez t ) + +-- | A brush stroke, as described by the equation +-- +-- \[ c(t,s) = p(t) + b(t,s) \] +-- +-- where: +-- +-- - \( p(t) \) is the path that the brush follows, and +-- - \( b(t,s) \) is the brush shape, as it varies along the path. +brushStroke :: ℝ 1 ~> ℝ 2 -- ^ stroke path \( p(t) \) + -> ℝ 2 ~> ℝ 2 -- ^ brush \( b(t,s) \) + -> ℝ 2 ~> ℝ 2 +brushStroke ( D f_p ) ( D f_b ) = D \ ( ℝ2 t0 s0 ) -> + let !( D1 p dpdt d2pdt2 ) + = f_p ( ℝ1 t0 ) + !( D2 b dbdt dbds d2bdt2 d2bdtds d2bds2 ) + = f_b ( ℝ2 t0 s0 ) + in + D2 ( unT $ T p ^+^ T b ) + -- c = p + b + + ( dpdt ^+^ dbdt ) dbds + -- ∂c/∂t = dp/dt + ∂b/∂t + -- ∂c/∂s = ∂b/∂s + + ( d2pdt2 ^+^ d2bdt2 ) d2bdtds d2bds2 + -- ∂²c/∂t² = d²p/dt² + ∂²b/∂t² + -- ∂²c/∂t∂s = ∂²b/∂t∂s + -- ∂²c/∂s² = ∂²b/∂s² + +-- | The envelope equation +-- +-- \[ E = \frac{\partial c}{\partial t} \times \frac{\partial c}{\partial s} = 0, ] +-- +-- as well as the vector +-- +-- \[ \frac{\partial E}{\partial s} \frac{\mathrm{d} c}{\mathrm{d} t} \] +-- +-- whose roots correspond to cusps in the envelope. +envelopeEquation :: ℝ 2 ~> ℝ 2 -> Double -> Double -> (# Double, T ( ℝ 2 ) #) +envelopeEquation ( D c ) t s = + case c ( ℝ2 t s ) of + D2 _ dcdt dcds d2cdt2 d2cdtds d2cds2 -> + let dEdt = d2cdt2 `cross2` dcds + dcdt `cross2` d2cdtds + dEds = d2cdtds `cross2` dcds + dcdt `cross2` d2cds2 + in (# dcdt `cross2` dcds, dEds *^ dcdt ^-^ dEdt *^ dcds #) + -- Computation of total derivative dc/dt: + -- + -- dc/dt = ∂c/∂t + ∂c/∂s ∂s/∂t + -- ∂s/∂t = - ( ∂E / ∂t ) / ( ∂E / ∂s ) + -- + -- ( ∂E / ∂s ) dc/dt = ( ∂E / ∂s ) ∂c/∂t - ( ∂E / ∂t ) ∂c/∂s. + +-- | Cross-product of two 2D vectors. +cross2 :: T ( ℝ 2 ) -> T ( ℝ 2 ) -> Double +cross2 ( T ( ℝ2 x1 y1 ) ) ( T ( ℝ2 x2 y2 ) ) + = x1 * y2 - x2 * y1 diff --git a/src/splines/Math/Epsilon.hs b/src/splines/Math/Epsilon.hs index 918725c..51413fc 100644 --- a/src/splines/Math/Epsilon.hs +++ b/src/splines/Math/Epsilon.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ScopedTypeVariables #-} - module Math.Epsilon ( epsilon, nearZero ) where diff --git a/src/splines/Math/Linear.hs b/src/splines/Math/Linear.hs new file mode 100644 index 0000000..dc4bf82 --- /dev/null +++ b/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## diff --git a/src/splines/Math/Linear/Dual.hs b/src/splines/Math/Linear/Dual.hs new file mode 100644 index 0000000..902eeb4 --- /dev/null +++ b/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 ) diff --git a/src/splines/Math/Linear/Solve.hs b/src/splines/Math/Linear/Solve.hs index be2f123..cfd2e96 100644 --- a/src/splines/Math/Linear/Solve.hs +++ b/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(..) ) -------------------------------------------------------------------------------- diff --git a/src/splines/Math/Module.hs b/src/splines/Math/Module.hs index e412e6e..05a4a14 100644 --- a/src/splines/Math/Module.hs +++ b/src/splines/Math/Module.hs @@ -1,9 +1,4 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module Math.Module ( Module(..), lerp @@ -38,8 +33,7 @@ import Data.Group -- MetaBrush import Math.Epsilon ( epsilon ) -import Math.Vector2D - ( Vector2D(..), Segment(..) ) +import Math.Linear -------------------------------------------------------------------------------- @@ -58,7 +52,7 @@ class Num r => Module r m | m -> r where (*^) = flip (^*) (^*) = flip (*^) - m ^-^ n = m ^+^ (-1) *^ n + m ^-^ n = m ^+^ -1 *^ n instance ( Applicative f, Module r m ) => Module r ( Ap f m ) where origin = pure origin @@ -145,6 +139,29 @@ instance Num a => Inner a ( Vector2D a ) where ( Vector2D x1 y1 ) ^.^ ( Vector2D x2 y2 ) = x1 * x2 + y1 * y2 +instance Module Double ( T ( ℝ 0 ) ) where + origin = T ℝ0 + _ ^+^ _ = T ℝ0 + _ ^-^ _ = T ℝ0 + _ *^ _ = T ℝ0 + +deriving via Sum Double instance Module Double ( T Double ) +deriving via Sum Double instance Module Double ( T ( ℝ 1 ) ) + +instance Module Double ( T ( ℝ 2 ) ) where + origin = mempty + (^+^) = (<>) + T ( ℝ2 x1 y1 ) ^-^ T ( ℝ2 x2 y2 ) = + T ( ℝ2 ( x1 - x2 ) ( y1 - y2 ) ) + k *^ ( T ( ℝ2 a b ) ) = T ( ℝ2 ( k * a ) ( k * b ) ) + +instance Module Double ( T ( ℝ 3 ) ) where + origin = mempty + (^+^) = (<>) + T ( ℝ3 x1 y1 z1 ) ^-^ T ( ℝ3 x2 y2 z2 ) = + T ( ℝ3 ( x1 - x2 ) ( y1 - y2 ) ( z1 - z2 ) ) + k *^ ( T ( ℝ3 a b c ) ) = T ( ℝ3 ( k * a ) ( k * b ) ( k * c ) ) + -- | Cross-product of two 2D vectors. cross :: Num a => Vector2D a -> Vector2D a -> a cross ( Vector2D x1 y1 ) ( Vector2D x2 y2 ) @@ -181,7 +198,7 @@ convexCombination v0 v1 u let t :: r t = c0 / c10 - guard ( t > - epsilon && t < 1 + epsilon ) + guard ( t > -epsilon && t < 1 + epsilon ) guard ( epsilon < u ^.^ ( lerp @( Vector2D r ) t v0 v1 ) ) Just $ min 1 ( max 0 t ) diff --git a/src/splines/Math/Orientation.hs b/src/splines/Math/Orientation.hs index 031a8b7..035575d 100644 --- a/src/splines/Math/Orientation.hs +++ b/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 diff --git a/src/splines/Math/Roots.hs b/src/splines/Math/Roots.hs index c32453f..102b174 100644 --- a/src/splines/Math/Roots.hs +++ b/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 @@ -61,7 +52,7 @@ solveQuadratic a0 a1 a2 then [ 0, 0.5, 1 ] -- convention else [] | nearZero ( a0 * a0 * a2 / ( a1 * a1 ) ) - = [ - a0 / a1 ] + = [ -a0 / a1 ] | disc < 0 = [] -- non-real solutions | otherwise @@ -69,11 +60,11 @@ solveQuadratic a0 a1 a2 r :: a r = if a1 >= 0 - then 2 * a0 / ( - a1 - sqrt disc ) - else 0.5 * ( - a1 + sqrt disc ) / a2 + then 2 * a0 / ( -a1 - sqrt disc ) + else 0.5 * ( -a1 + sqrt disc ) / a2 in [ r, -r - a1 / a2 ] where - disc :: a + disc :: a disc = a1 * a1 - 4 * a0 * a2 -- | Find real roots of a polynomial with real coefficients. diff --git a/src/splines/Math/Vector2D.hs b/src/splines/Math/Vector2D.hs deleted file mode 100644 index 4a2c3e1..0000000 --- a/src/splines/Math/Vector2D.hs +++ /dev/null @@ -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