diff --git a/MetaBrush.cabal b/MetaBrush.cabal index c00e335..25c17dd 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -27,7 +27,7 @@ common common build-depends: base - >= 4.13 && < 4.16 + >= 4.13 && < 4.17 , acts ^>= 0.3.1.0 , containers @@ -77,6 +77,7 @@ library Math.Bezier.Cubic , Math.Bezier.Cubic.Fit , Math.Bezier.Quadratic + , Math.Bezier.Spline , Math.Bezier.Stroke , Math.Epsilon , Math.Linear.Solve @@ -85,12 +86,14 @@ library , Math.Vector2D build-depends: - groups-generic + bifunctors + ^>= 5.5.4 + , groups-generic ^>= 0.1.0.0 , hmatrix ^>= 0.20.0.0 - , monad-par - ^>= 0.3.5 + , parallel + ^>= 3.2.2.0 , prim-instances ^>= 0.2 , vector @@ -128,6 +131,14 @@ executable MetaBrush , MetaBrush.Document.SubdivideStroke , MetaBrush.Document.Update , MetaBrush.Event + , MetaBrush.MetaParameter.AST + , MetaBrush.MetaParameter.Driver + , MetaBrush.MetaParameter.Eval + , MetaBrush.MetaParameter.Interpolation + , MetaBrush.MetaParameter.Parse + , MetaBrush.MetaParameter.PrimOp + , MetaBrush.MetaParameter.Rename + , MetaBrush.MetaParameter.TypeCheck , MetaBrush.Render.Document , MetaBrush.Render.Rulers , MetaBrush.Time @@ -153,11 +164,17 @@ executable MetaBrush , atomic-file-ops ^>= 0.3.0.0 , bytestring - ^>= 0.10.10.1 + ^>= 0.10.10.0 , directory >= 1.3.4.0 && < 1.4 + , dlist + ^>= 1.0 + , Earley + ^>= 0.13.0.1 , filepath ^>= 1.4.2.1 + , ghc-typelits-knownnat + ^>= 0.7.3 , gi-gdk >= 3.0.22 && < 3.1 , gi-gio @@ -173,16 +190,22 @@ executable MetaBrush , gi-cairo-connector ^>= 0.0.1 , haskell-gi-base - ^>= 0.24 + ^>= 0.24.3 , lens ^>= 4.19.2 + , mtl + ^>= 2.2.2 , scientific ^>= 0.3.6.2 , stm ^>= 2.5.0.0 + , superrecord + ^>= 0.5.1.0 , tardis ^>= 0.4.1.0 , text - ^>= 1.2.3.1 && < 1.2.5 + >= 1.2.3.1 && < 1.2.5 + , tree-view + ^>= 0.5 , waargonaut ^>= 0.8.0.1 diff --git a/app/Main.hs b/app/Main.hs index 24526f3..f2935f1 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,11 +2,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module Main ( main ) @@ -30,9 +32,7 @@ import GHC.Conc import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map - ( empty ) -import Data.Sequence - ( Seq(..) ) + ( adjust, empty ) import qualified Data.Sequence as Seq ( fromList ) import Data.Set @@ -48,6 +48,10 @@ import qualified System.Directory as Directory import Data.Generics.Product.Fields ( field' ) +-- gi-cairo-render +import qualified GI.Cairo.Render as Cairo + ( Render ) + -- gi-cairo-connector import qualified GI.Cairo.Render.Connector as Cairo ( renderWithContext ) @@ -60,13 +64,19 @@ import qualified GI.Gtk as GTK -- lens import Control.Lens - ( (.~) ) + ( (.~), set ) -- stm import qualified Control.Concurrent.STM as STM ( atomically ) import qualified Control.Concurrent.STM.TVar as STM - ( newTVarIO, readTVar ) + ( modifyTVar', newTVarIO, readTVar ) + +-- superrecord +import qualified SuperRecord as Super + ( Rec ) +import qualified SuperRecord + ( (:=)(..), (&), rnil ) -- text import qualified Data.Text as Text @@ -75,14 +85,16 @@ import qualified Data.Text as Text -- MetaBrush import Math.Bezier.Cubic.Fit ( FitParameters(..) ) +import Math.Bezier.Spline + ( Spline(..), Curves(..), Curve(..), NextPoint(..) ) import Math.Bezier.Stroke - ( StrokePoint(..) ) + ( CachedStroke(..) ) import Math.Vector2D ( Point2D(..) ) import MetaBrush.Action ( ActionOrigin(..) ) -import MetaBrush.Asset.Brushes - ( ellipse, rect ) +import qualified MetaBrush.Asset.Brushes as Asset.Brushes + ( circle ) import MetaBrush.Asset.Colours ( getColours ) import MetaBrush.Asset.Logo @@ -95,7 +107,7 @@ import MetaBrush.Context import MetaBrush.Document ( Document(..), emptyDocument , Stroke(..), FocusState(..) - , PointData(..), BrushPointData(..) + , PointData(..) ) import MetaBrush.Document.History ( DocumentHistory(..), newHistory ) @@ -131,56 +143,6 @@ import qualified Paths_MetaBrush as Cabal -------------------------------------------------------------------------------- -testDocuments :: Map Unique DocumentHistory -testDocuments = fmap newHistory $ uniqueMapFromList - [ emptyDocument "Closed" ( unsafeUnique 0 ) - & ( field' @"documentContent" . field' @"strokes" ) .~ - [ Stroke - { strokeName = "Ellipse" - , strokeVisible = True - , strokeUnique = unsafeUnique 10 - , strokePoints = ellipse 150 100 ( PointData Normal ( rect 30 6 $ BrushPointData Normal ) ) - } - ] - , emptyDocument "Line" ( unsafeUnique 1 ) - & ( field' @"documentContent" . field' @"strokes" ) .~ - [ Stroke - { strokeName = "Line" - , strokeVisible = True - , strokeUnique = unsafeUnique 11 - , strokePoints = linePts - } - ] - , emptyDocument "Short line" ( unsafeUnique 2 ) - & ( field' @"documentContent" . field' @"strokes" ) .~ - [ Stroke - { strokeName = "ShortLine" - , strokeVisible = True - , strokeUnique = unsafeUnique 12 - , strokePoints = linePts2 - } - ] - ] - where - linePts :: Seq ( StrokePoint PointData ) - linePts = Seq.fromList - [ PathPoint ( Point2D 0 -100 ) ( PointData Normal ( ellipse 30 8 $ BrushPointData Normal ) ) - , ControlPoint ( Point2D 0 -30 ) ( PointData Normal ( ellipse 25 6 $ BrushPointData Normal ) ) - , ControlPoint ( Point2D 0 30 ) ( PointData Normal ( ellipse 15 6 $ BrushPointData Normal ) ) - , PathPoint ( Point2D 0 100 ) ( PointData Normal ( ellipse 15 6 $ BrushPointData Normal ) ) - , ControlPoint ( Point2D 0 150 ) ( PointData Normal ( ellipse 15 6 $ BrushPointData Normal ) ) - , ControlPoint ( Point2D 0 200 ) ( PointData Normal ( ellipse 15 6 $ BrushPointData Normal ) ) - , PathPoint ( Point2D 0 250 ) ( PointData Normal ( ellipse 10 1 $ BrushPointData Normal ) ) - ] - linePts2 :: Seq ( StrokePoint PointData ) - linePts2 = Seq.fromList - [ PathPoint ( Point2D 0 -100 ) ( PointData Normal ( ellipse 20 8 $ BrushPointData Normal ) ) - --, ControlPoint ( Point2D 0 0 ) ( PointData Normal ( ellipse 140 8 $ BrushPointData Normal ) ) - , PathPoint ( Point2D 0 100 ) ( PointData Normal ( ellipse 20 8 $ BrushPointData Normal ) ) - ] - --------------------------------------------------------------------------------- - main :: IO () main = do @@ -199,14 +161,43 @@ main = do --------------------------------------------------------- -- Initialise state - uniqueSupply <- newUniqueSupply + uniqueSupply <- newUniqueSupply + + circleBrush <- Asset.Brushes.circle uniqueSupply + + let + testDocuments :: Map Unique DocumentHistory + testDocuments = fmap newHistory $ uniqueMapFromList + [ emptyDocument "Test" ( unsafeUnique 0 ) + & ( field' @"documentContent" . field' @"strokes" ) .~ + [ Stroke + { strokeName = "Stroke 1" + , strokeVisible = True + , strokeUnique = unsafeUnique 10 + , strokeBrush = circleBrush + , strokeSpline = + Spline + { splineStart = mkPoint ( Point2D 10 -20 ) 2 + , splineCurves = OpenCurves $ Seq.fromList + [ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 5 ), curveData = CachedStroke Nothing } + , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = CachedStroke Nothing } + , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 2 ), curveData = CachedStroke Nothing } + ] + } + } + ] + ] + where + mkPoint :: Point2D Double -> Double -> PointData ( Super.Rec '[ "r" SuperRecord.:= Double ] ) + mkPoint pt r = PointData pt Normal ( #r SuperRecord.:= r SuperRecord.& SuperRecord.rnil ) + activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty toolTVar <- STM.newTVarIO @Tool Selection - modeTVar <- STM.newTVarIO @Mode Path + modeTVar <- STM.newTVarIO @Mode PathMode debugTVar <- STM.newTVarIO @Bool False partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing fileBarTabsTVar <- STM.newTVarIO @( Map Unique ( GTK.Box, GTK.RadioButton ) ) Map.empty @@ -323,7 +314,7 @@ main = do --------------------------------------------------------- -- Main viewport - viewport@( Viewport { .. } ) <- createViewport viewportGrid + viewport@( Viewport {..} ) <- createViewport viewportGrid ----------------- -- Viewport rendering @@ -332,7 +323,7 @@ main = do -- Get the relevant document information viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea - mbRender <- STM.atomically $ withActiveDocument variables \ doc@( Document {..} ) -> do + mbDocAndRender <- STM.atomically $ withActiveDocument variables \ doc -> do modifiers <- STM.readTVar modifiersTVar mbMousePos <- STM.readTVar mousePosTVar mbHoldAction <- STM.readTVar mouseHoldTVar @@ -341,18 +332,33 @@ main = do debug <- STM.readTVar debugTVar showGuides <- STM.readTVar showGuidesTVar fitParameters <- STM.readTVar fitParametersTVar - pure do - renderDocument - colours fitParameters mode debug ( viewportWidth, viewportHeight ) - modifiers mbMousePos mbHoldAction mbPartialPath - doc - renderRuler - colours ( viewportWidth, viewportHeight ) ViewportOrigin ( viewportWidth, viewportHeight ) - mbMousePos mbHoldAction showGuides - doc - case mbRender of - Just render -> Cairo.renderWithContext render ctx - Nothing -> Cairo.renderWithContext ( blankRender colours ) ctx + + let + mbUpdatedDoc :: Maybe Document + renderDoc, renderAction :: Cairo.Render () + ( mbUpdatedDoc, renderDoc ) = + renderDocument + colours fitParameters mode debug ( viewportWidth, viewportHeight ) + modifiers mbMousePos mbHoldAction mbPartialPath + doc + renderAction = do + renderDoc + renderRuler + colours ( viewportWidth, viewportHeight ) ViewportOrigin ( viewportWidth, viewportHeight ) + mbMousePos mbHoldAction showGuides + doc + pure + ( mbUpdatedDoc, renderAction ) + + case mbDocAndRender of + Just ( mbNewDoc, render ) -> do + Cairo.renderWithContext render ctx + for_ mbNewDoc \ newDoc -> STM.atomically do + mbCurrDocUnique <- STM.readTVar activeDocumentTVar + for_ mbCurrDocUnique \ currDocUnique -> do + STM.modifyTVar' openDocumentsTVar ( Map.adjust ( set ( field' @"present" ) newDoc ) currDocUnique ) + Nothing -> + Cairo.renderWithContext ( blankRender colours ) ctx pure True @@ -365,7 +371,7 @@ main = do viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea width <- GTK.widgetGetAllocatedWidth rulerDrawingArea height <- GTK.widgetGetAllocatedHeight rulerDrawingArea - mbRender <- STM.atomically $ withActiveDocument variables \ doc@( Document {..} ) -> do + mbRender <- STM.atomically $ withActiveDocument variables \ doc -> do mbMousePos <- STM.readTVar mousePosTVar mbHoldAction <- STM.readTVar mouseHoldTVar showGuides <- STM.readTVar showGuidesTVar diff --git a/cabal.project b/cabal.project index 25f67a7..cdf15cc 100644 --- a/cabal.project +++ b/cabal.project @@ -4,7 +4,8 @@ constraints: acts -finitary allow-newer: - waargonaut:* + waargonaut:* + -- fixes gi-cairo-render to work with haskell-gi >= 0.24 source-repository-package @@ -30,8 +31,18 @@ source-repository-package location: https://github.com/sheaf/waargonaut tag: dc835fb86d2592fa2e55753fa4eb7c59d6124699 --- haskell-gi: add fix for GValue +-- instances for CPS Writer / CPS RWST source-repository-package type: git - location: https://github.com/haskell-gi/haskell-gi - tag: 6fe7fc271095b5b6115b142f72995ebc11840afb + location: https://github.com/haskell/mtl + tag: a9023c764a08beedbb1b8ca20bc39103f26529c5 + +-- patch to superrecord with API improvements +source-repository-package + type: git + location: https://github.com/sheaf/superrecord + tag: 4cecac06afaa3fb60e67cdb273e36eed3f04335d + +constraints: + -- fix for Haskell GI GValue bug + haskell-gi >= 0.24.5 diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index a1755ca..fbf2232 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} @@ -23,7 +22,7 @@ import Data.Foldable import Data.Int ( Int32 ) import Data.Maybe - ( catMaybes, listToMaybe ) + ( listToMaybe ) import Data.Traversable ( for ) import Data.Word @@ -40,10 +39,6 @@ import Data.Act -- containers import qualified Data.Map as Map ( insert, lookup ) -import Data.Sequence - ( Seq(..) ) -import qualified Data.Sequence as Seq - ( fromList ) import qualified Data.Set as Set ( delete, insert ) @@ -84,8 +79,12 @@ import qualified Data.Text as Text ( intercalate, pack ) -- MetaBrush +import Math.Bezier.Spline + ( Spline(..), SplineType(Open) + , catMaybesSpline + ) import Math.Bezier.Stroke - ( StrokePoint(..) ) + ( CachedStroke(..) ) import Math.Module ( Module((*^)) ) import Math.Vector2D @@ -96,11 +95,11 @@ import MetaBrush.Context , HoldAction(..), GuideAction(..), PartialPath(..) ) import MetaBrush.Document - ( Document(..), DocumentContent(..), PointData(..), FocusState(..) ) + ( Document(..), DocumentContent(..), PointData(..), FocusState(..) + , Guide(..), selectedGuide, addGuide + ) import MetaBrush.Document.Draw ( addToAnchor, getOrCreateDrawAnchor, anchorsAreComplementary ) -import MetaBrush.Document - ( Guide(..), selectedGuide, addGuide ) import MetaBrush.Document.History ( DocumentHistory(..), newHistory , back, fwd @@ -132,7 +131,7 @@ import {-# SOURCE #-} MetaBrush.UI.FileBar import MetaBrush.UI.Menu ( MenuItem(..), Menu(..), ViewMenu(..) ) import MetaBrush.UI.ToolBar - ( Tool(..) ) + ( Tool(..), Mode(..) ) import MetaBrush.UI.Viewport ( Viewport(..), Ruler(..) ) import MetaBrush.Unique @@ -243,7 +242,6 @@ instance HandleAction OpenFolder where newDocHist = newHistory doc newFileTab False uiElts vars ( Just newDocHist ) tabLoc updateHistoryState uiElts ( Just newDocHist ) - pure () --------------- -- Save file -- @@ -253,12 +251,12 @@ data Save = Save deriving stock Show instance HandleAction Save where - handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ = + handleAction uiElts vars _ = save uiElts vars True save :: UIElements -> Variables -> Bool -> IO () save uiElts vars keepOpen = do - mbDoc <- fmap present <$> ( STM.atomically $ activeDocument vars ) + mbDoc <- fmap present <$> STM.atomically ( activeDocument vars ) for_ mbDoc \case doc@( Document { mbFilePath, documentContent } ) | Nothing <- mbFilePath @@ -285,7 +283,7 @@ instance HandleAction SaveAs where saveAs :: UIElements -> Variables -> Bool -> IO () saveAs uiElts vars keepOpen = do mbSavePath <- askForSavePath uiElts - for_ mbSavePath \ savePath -> do + for_ mbSavePath \ savePath -> modifyingCurrentDocument uiElts vars \ doc -> do let modif :: DocumentUpdate @@ -332,7 +330,7 @@ pattern CancelClose = 3 instance HandleAction Close where handleAction - uiElts@( UIElements { viewport = Viewport {..}, .. } ) + uiElts@( UIElements {..} ) vars@( Variables {..} ) close = do mbDoc <- case close of @@ -391,7 +389,7 @@ data SwitchTo = SwitchTo Unique instance HandleAction SwitchTo where handleAction - uiElts@( UIElements { viewport = Viewport {..}, .. } ) + uiElts vars@( Variables {..} ) ( SwitchTo newUnique ) = do uiUpdateAction <- STM.atomically do @@ -424,17 +422,17 @@ data Undo = Undo deriving stock Show instance HandleAction Undo where - handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ = updateHistory back uiElts vars + handleAction uiElts vars _ = updateHistory back uiElts vars data Redo = Redo deriving stock Show instance HandleAction Redo where - handleAction uiElts@( UIElements {..} ) vars@( Variables {..} ) _ = updateHistory fwd uiElts vars + handleAction uiElts vars _ = updateHistory fwd uiElts vars updateHistory :: ( DocumentHistory -> DocumentHistory ) -> UIElements -> Variables -> IO () -updateHistory f uiElts@( UIElements {..} ) vars@( Variables {..} ) = do +updateHistory f uiElts vars@( Variables {..} ) = do uiUpdateAction <- STM.atomically do mbUnique <- STM.readTVar activeDocumentTVar case mbUnique of @@ -514,13 +512,14 @@ instance HandleAction Delete where tool <- STM.readTVarIO toolTVar mode <- STM.readTVarIO modeTVar case tool of - -- Delete selected points on pressing 'Delete'. + -- Delete selected points on pressing 'Delete' in path mode. Selection + | PathMode <- mode -> modifyingCurrentDocument uiElts vars \ doc -> do let newDocument :: Document updateInfo :: UpdateInfo - ( newDocument, updateInfo ) = deleteSelected mode doc + ( newDocument, updateInfo ) = deleteSelected doc case updateInfo of UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected } | null strokesAffected @@ -677,105 +676,109 @@ instance HandleAction MouseClick where pos :: Point2D Double pos = toViewport mouseClickCoords STM.writeTVar mousePosTVar ( Just pos ) - case actionOrigin of + mode <- STM.readTVar modeTVar + case mode of + BrushMode -> pure Don'tModifyDoc -- TODO: brush parameter modification UI + _ -> + case actionOrigin of - ViewportOrigin -> case ty of + ViewportOrigin -> case ty of - SingleClick -> do - modifiers <- STM.readTVar modifiersTVar - tool <- STM.readTVar toolTVar - mode <- STM.readTVar modeTVar - case tool of - -- Selection mode mouse hold: - -- - -- - If holding shift or alt, mouse hold initiates a rectangular selection. - -- - If not holding shift or alt: - -- - if mouse click selected an object, initiate a drag move, - -- - otherwise, initiate a rectangular selection. - Selection -> - case selectionMode modifiers of - -- Drag move: not holding shift or alt, click has selected something. - New - | Just ( dragMove, newDoc ) <- dragMoveSelect mode pos doc - -> do - STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove ) - case dragMove of - ClickedOnSelected -> + SingleClick -> do + modifiers <- STM.readTVar modifiersTVar + tool <- STM.readTVar toolTVar + + case tool of + -- Selection mode mouse hold: + -- + -- - If holding shift or alt, mouse hold initiates a rectangular selection. + -- - If not holding shift or alt: + -- - if mouse click selected an object, initiate a drag move, + -- - otherwise, initiate a rectangular selection. + Selection -> + case selectionMode modifiers of + -- Drag move: not holding shift or alt, click has selected something. + New + | Just ( dragMove, newDoc ) <- dragMoveSelect pos doc + -> do + STM.writeTVar mouseHoldTVar ( Just $ DragMoveHold pos dragMove ) + case dragMove of + ClickedOnSelected -> + pure Don'tModifyDoc + ClickedOnUnselected -> + pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc ) + ClickedOnCurve {} -> + pure Don'tModifyDoc + -- Rectangular selection. + _ -> do + STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos ) pure Don'tModifyDoc - ClickedOnUnselected -> - pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc ) - ClickedOnCurve {} -> - pure Don'tModifyDoc - -- Rectangular selection. - _ -> do - STM.writeTVar mouseHoldTVar ( Just $ SelectionHold pos ) - pure Don'tModifyDoc - -- Pen tool: start or continue a drawing operation. - Pen -> do - mbPartialPath <- STM.readTVar partialPathTVar - STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos ) - case mbPartialPath of - -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke). - Nothing -> do - ( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <- - getOrCreateDrawAnchor uniqueSupply pos doc - STM.writeTVar partialPathTVar - ( Just $ PartialPath - { partialStartPos = anchorPt - , partialControlPoint = Nothing - , partialPathAnchor = drawAnchor - , firstPoint = True - } - ) - case mbExistingAnchorName of - Nothing -> - let - changeText :: Text - changeText = "Begin new stroke" - in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) - Just _ -> + -- Pen tool: start or continue a drawing operation. + Pen -> do + mbPartialPath <- STM.readTVar partialPathTVar + STM.writeTVar mouseHoldTVar ( Just $ DrawHold pos ) + case mbPartialPath of + -- No path started yet: find anchor for drawing (existing stroke endpoint, or new stroke). + Nothing -> do + ( newDocument, drawAnchor, anchorPt, mbExistingAnchorName ) <- + getOrCreateDrawAnchor uniqueSupply pos doc + STM.writeTVar partialPathTVar + ( Just $ PartialPath + { partialStartPos = anchorPt + , partialControlPoint = Nothing + , partialPathAnchor = drawAnchor + , firstPoint = True + } + ) + case mbExistingAnchorName of + Nothing -> + let + changeText :: Text + changeText = "Begin new stroke" + in pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) + Just _ -> + pure Don'tModifyDoc + -- Path already started: indicate that we are continuing a path. + Just pp -> do + STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } ) pure Don'tModifyDoc - -- Path already started: indicate that we are continuing a path. - Just pp -> do - STM.writeTVar partialPathTVar ( Just $ pp { firstPoint = False } ) - pure Don'tModifyDoc - - DoubleClick -> do - tool <- STM.readTVar toolTVar - mode <- STM.readTVar modeTVar - modifs <- STM.readTVar modifiersTVar - case tool of - Selection - | null modifs - -> do - STM.writeTVar mouseHoldTVar Nothing - case subdivide mode pos doc of - Nothing -> - pure Don'tModifyDoc - Just ( newDocument, loc ) -> do - let - changeText :: Text - changeText = "Subdivide " <> loc - pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange { .. } ) - -- Ignore double click event otherwise. - _ -> pure Don'tModifyDoc + DoubleClick -> do + tool <- STM.readTVar toolTVar + modifs <- STM.readTVar modifiersTVar + case tool of + Selection + | PathMode <- mode + , null modifs + -> do + STM.writeTVar mouseHoldTVar Nothing + case subdivide pos doc of + Nothing -> + pure Don'tModifyDoc + Just ( newDocument, loc ) -> do + let + changeText :: Text + changeText = "Subdivide " <> loc + pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) + + -- Ignore double click event otherwise. + _ -> pure Don'tModifyDoc - RulerOrigin ruler -> do - showGuides <- STM.readTVar showGuidesTVar - when showGuides do - let - mbGuide :: Maybe Guide - mbGuide = selectedGuide pos doc - guideAction :: GuideAction - guideAction - | Just guide <- mbGuide - = MoveGuide ( guideUnique guide ) - | otherwise - = CreateGuide ruler - STM.writeTVar mouseHoldTVar ( Just $ GuideAction { holdStartPos = pos, guideAction } ) - pure Don'tModifyDoc + RulerOrigin ruler -> do + showGuides <- STM.readTVar showGuidesTVar + when showGuides do + let + mbGuide :: Maybe Guide + mbGuide = selectedGuide pos doc + guideAction :: GuideAction + guideAction + | Just guide <- mbGuide + = MoveGuide ( guideUnique guide ) + | otherwise + = CreateGuide ruler + STM.writeTVar mouseHoldTVar ( Just $ GuideAction { holdStartPos = pos, guideAction } ) + pure Don'tModifyDoc -- Right mouse button: end partial path. 3 -> do @@ -869,111 +872,112 @@ instance HandleAction MouseRelease where _ -> do tool <- STM.readTVar toolTVar mode <- STM.readTVar modeTVar - case tool of + case mode of + BrushMode -> pure Don'tModifyDoc -- TODO: brush parameter modification UI + _ -> + case tool of - Selection -> do - let - selMode :: SelectionMode - selMode = selectionMode modifiers - case mbHoldPos of - Just hold - | DragMoveHold { holdStartPos = pos0, dragAction } <- hold - , pos0 /= pos - -> let - alternateMode :: Bool - alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers - in case dragUpdate mode pos0 pos dragAction alternateMode doc of - Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd ) - Nothing -> pure Don'tModifyDoc - | SelectionHold pos0 <- hold - , pos0 /= pos - -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle mode selMode pos0 pos doc ) - _ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt mode selMode pos doc ) - - Pen -> do - mbPartialPath <- STM.readTVar partialPathTVar - case mbPartialPath of - -- Normal pen mode mouse click should have created an anchor. - -- If no anchor exists, then just ignore the mouse release event. - Nothing -> pure Don'tModifyDoc - -- Mouse click release possibilities: - -- - -- - click was on complementary draw stroke draw anchor to close the path, - -- - release at same point as click: finish current segment, - -- - release at different point as click: finish current segment, adding a control point. - Just - ( PartialPath - { partialStartPos = p1 - , partialControlPoint = mbCp2 - , partialPathAnchor = anchor - , firstPoint - } - ) -> do + Selection -> do let - pathPoint :: Point2D Double - mbControlPoint :: Maybe ( Point2D Double ) - partialControlPoint :: Maybe ( Point2D Double ) - ( pathPoint, mbControlPoint, partialControlPoint ) - | Just ( DrawHold holdPos ) <- mbHoldPos - = ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos ) - | otherwise - = ( pos, Nothing, Nothing ) - ( _, otherAnchor, otherAnchorPt, _ ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc - if not firstPoint && anchorsAreComplementary anchor otherAnchor - -- Close path. - then do - STM.writeTVar partialPathTVar Nothing - let - newSegment :: Seq ( StrokePoint PointData ) - newSegment - = Seq.fromList - $ catMaybes - [ Just ( PathPoint p1 ( PointData Normal Empty ) ) - , do - cp <- mbCp2 - guard ( cp /= p1 ) - pure $ ControlPoint cp ( PointData Normal Empty ) - , do - cp <- mbControlPoint - guard ( cp /= otherAnchorPt ) - pure $ ControlPoint cp ( PointData Normal Empty ) - , Just ( PathPoint otherAnchorPt ( PointData Normal Empty ) ) - ] - newDocument :: Document - newDocument = addToAnchor anchor newSegment doc - changeText :: Text - changeText = "Close stroke" - pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) - else - if firstPoint - -- Continue current partial path. - then do - STM.writeTVar partialPathTVar ( Just $ PartialPath p1 partialControlPoint anchor False ) - pure Don'tModifyDoc - -- Finish current partial path. - else do - STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False ) + selMode :: SelectionMode + selMode = selectionMode modifiers + case mbHoldPos of + Just hold + | DragMoveHold { holdStartPos = pos0, dragAction } <- hold + , pos0 /= pos + -> let + alternateMode :: Bool + alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers + in case dragUpdate pos0 pos dragAction alternateMode doc of + Just upd -> pure $ UpdateDoc ( UpdateDocumentTo upd ) + Nothing -> pure Don'tModifyDoc + | SelectionHold pos0 <- hold + , pos0 /= pos + -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectRectangle selMode pos0 pos doc ) + _ -> pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ selectAt selMode pos doc ) + + Pen -> do + mbPartialPath <- STM.readTVar partialPathTVar + case mbPartialPath of + -- Normal pen mode mouse click should have created an anchor. + -- If no anchor exists, then just ignore the mouse release event. + Nothing -> pure Don'tModifyDoc + -- Mouse click release possibilities: + -- + -- - click was on complementary draw stroke draw anchor to close the path, + -- - release at same point as click: finish current segment, + -- - release at different point as click: finish current segment, adding a control point. + Just + ( PartialPath + { partialStartPos = p1 + , partialControlPoint = mbCp2 + , partialPathAnchor = anchor + , firstPoint + } + ) -> do let - newSegment :: Seq ( StrokePoint PointData ) - newSegment - = Seq.fromList - $ catMaybes - [ Just ( PathPoint p1 ( PointData Normal Empty ) ) - , do - cp <- mbCp2 - guard ( cp /= p1 ) - pure $ ControlPoint cp ( PointData Normal Empty ) - , do - cp <- mbControlPoint - guard ( cp /= pathPoint ) - pure $ ControlPoint cp ( PointData Normal Empty ) - , Just ( PathPoint pathPoint ( PointData Normal Empty ) ) - ] - newDocument :: Document - newDocument = addToAnchor anchor newSegment doc - changeText :: Text - changeText = "Continue stroke" - pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) + pathPoint :: Point2D Double + mbControlPoint :: Maybe ( Point2D Double ) + partialControlPoint :: Maybe ( Point2D Double ) + ( pathPoint, mbControlPoint, partialControlPoint ) + | Just ( DrawHold holdPos ) <- mbHoldPos + = ( holdPos, Just $ ( pos --> holdPos :: Vector2D Double ) • holdPos, Just pos ) + | otherwise + = ( pos, Nothing, Nothing ) + ( _, otherAnchor, otherAnchorPt, _ ) <- getOrCreateDrawAnchor uniqueSupply pathPoint doc + if not firstPoint && anchorsAreComplementary anchor otherAnchor + -- Close path. + then do + STM.writeTVar partialPathTVar Nothing + let + newSegment :: Spline Open CachedStroke ( PointData () ) + newSegment = catMaybesSpline ( CachedStroke Nothing ) + ( PointData p1 Normal () ) + ( do + cp <- mbCp2 + guard ( cp /= p1 ) + pure ( PointData cp Normal () ) + ) + ( do + cp <- mbControlPoint + guard ( cp /= otherAnchorPt ) + pure ( PointData cp Normal () ) + ) + ( PointData otherAnchorPt Normal () ) + newDocument :: Document + newDocument = addToAnchor anchor newSegment doc + changeText :: Text + changeText = "Close stroke" + pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) + else + if firstPoint + -- Continue current partial path. + then do + STM.writeTVar partialPathTVar ( Just $ PartialPath p1 partialControlPoint anchor False ) + pure Don'tModifyDoc + -- Finish current partial path. + else do + STM.writeTVar partialPathTVar ( Just $ PartialPath pathPoint partialControlPoint anchor False ) + let + newSegment :: Spline Open CachedStroke ( PointData () ) + newSegment = catMaybesSpline ( CachedStroke Nothing ) + ( PointData p1 Normal () ) + ( do + cp <- mbCp2 + guard ( cp /= p1 ) + pure ( PointData cp Normal () ) + ) + ( do + cp <- mbControlPoint + guard ( cp /= pathPoint ) + pure ( PointData cp Normal () ) + ) + ( PointData pathPoint Normal () ) + newDocument :: Document + newDocument = addToAnchor anchor newSegment doc + changeText :: Text + changeText = "Continue stroke" + pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) -- Other mouse buttons: ignored (for the moment at least). _ -> pure () @@ -987,7 +991,7 @@ data Scroll = Scroll ( Point2D Double ) ( Vector2D Double ) instance HandleAction Scroll where handleAction - uiElts@( UIElements { viewport = Viewport {..}, .. } ) + uiElts@( UIElements { viewport = Viewport {..} } ) vars@( Variables {..} ) ( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do @@ -1051,12 +1055,12 @@ data KeyboardPress = KeyboardPress Word32 instance HandleAction KeyboardPress where handleAction - uiElts@( UIElements { viewport = Viewport {..}, .. } ) + uiElts@( UIElements { viewport = Viewport {..} } ) vars@( Variables {..} ) ( KeyboardPress keyCode ) = do - for_ ( modifierKey keyCode ) \ modifier -> - STM.atomically $ STM.modifyTVar' modifiersTVar ( Set.insert modifier ) + for_ ( modifierKey keyCode ) + ( STM.atomically . STM.modifyTVar' modifiersTVar . Set.insert ) case keyCode of @@ -1096,5 +1100,5 @@ data KeyboardRelease = KeyboardRelease Word32 instance HandleAction KeyboardRelease where handleAction _ ( Variables { modifiersTVar } ) ( KeyboardRelease keyCode ) = - for_ ( modifierKey keyCode ) \ modifier -> do - STM.atomically $ STM.modifyTVar' modifiersTVar ( Set.delete modifier ) + for_ ( modifierKey keyCode ) + ( STM.atomically . STM.modifyTVar' modifiersTVar . Set.delete ) diff --git a/src/app/MetaBrush/Asset/Brushes.hs b/src/app/MetaBrush/Asset/Brushes.hs index 4a3e83c..8110acd 100644 --- a/src/app/MetaBrush/Asset/Brushes.hs +++ b/src/app/MetaBrush/Asset/Brushes.hs @@ -1,70 +1,108 @@ -{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -module MetaBrush.Asset.Brushes - ( ellipse, blob, rect ) - where +module MetaBrush.Asset.Brushes where --- containers -import Data.Sequence - ( Seq(..) ) -import qualified Data.Sequence as Seq - ( fromList ) +-- base +import Data.Kind + ( Type ) +import Data.Type.Equality + ( (:~:)(Refl) ) + +-- superrecord +import qualified SuperRecord + ( (:=) ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + ( unpack ) -- MetaBrush -import Math.Bezier.Stroke - ( StrokePoint(..) ) -import Math.Vector2D - ( Point2D(..) ) +import MetaBrush.Document + ( Brush(..) ) +import MetaBrush.MetaParameter.AST + ( BrushFunction, STypesI(sTypesI), eqTys ) +import MetaBrush.MetaParameter.Driver + ( SomeBrushFunction(..), interpretBrush ) +import MetaBrush.Unique + ( UniqueSupply ) -------------------------------------------------------------------------------- -ellipse :: forall d. Double -> Double -> d -> Seq ( StrokePoint d ) -ellipse w h d = Seq.fromList - [ pp ( Point2D 0 1 ) - , cp ( Point2D a 1 ) - , cp ( Point2D 1 a ) - , pp ( Point2D 1 0 ) - , cp ( Point2D 1 (-a) ) - , cp ( Point2D a (-1) ) - , pp ( Point2D 0 (-1) ) - , cp ( Point2D (-a) (-1) ) - , cp ( Point2D (-1) (-a) ) - , pp ( Point2D (-1) 0 ) - , cp ( Point2D (-1) a ) - , cp ( Point2D (-a) 1 ) - , pp ( Point2D 0 1 ) - ] +circle + :: forall circleBrushFields + . ( circleBrushFields ~ '[ "r" SuperRecord.:= Double ] ) + => UniqueSupply -> IO ( Brush circleBrushFields ) +circle uniqueSupply = mkBrush @circleBrushFields uniqueSupply name code where - a :: Double - a = 0.551915024494 - pp, cp :: Point2D Double -> StrokePoint d - pp ( Point2D x y ) = PathPoint ( Point2D ( w * x ) ( h * y ) ) d - cp ( Point2D x y ) = ControlPoint ( Point2D ( w * x ) ( h * y ) ) d + name, code :: Text + name = "Circle" + code = + "with\n\ + \ r = 1\n\ + \satisfying\n\ + \ r > 0\n\ + \define\n\ + \ let c = kappa in\n\ + \ [ (r,0) -- ( r , r*c) -- ( r*c, r ) -> ( 0, r)\n\ + \ -- (-r*c, r ) -- (-r , r*c) -> (-r, 0)\n\ + \ -- (-r ,-r*c) -- (-r*c,-r ) -> ( 0,-r)\n\ + \ -- ( r*c,-r ) -- ( r ,-r*c) -> . ]" -blob :: forall d. Double -> Double -> d -> Seq ( StrokePoint d ) -blob w h d = Seq.fromList - [ pp ( Point2D 1 0 ) - , cp ( Point2D 1 -1 ) - , cp ( Point2D -1 -1 ) - , pp ( Point2D -1 0 ) - , cp ( Point2D -1 1 ) - , cp ( Point2D 1 1 ) - , pp ( Point2D 1 0 ) - ] +rounded + :: forall roundedBrushFields + . ( roundedBrushFields ~ '[ ] ) -- TODO + => UniqueSupply -> IO ( Brush roundedBrushFields ) +rounded uniqueSupply = mkBrush @roundedBrushFields uniqueSupply name code where - pp, cp :: Point2D Double -> StrokePoint d - pp ( Point2D x y ) = PathPoint ( Point2D ( w * x ) ( h * y ) ) d - cp ( Point2D x y ) = ControlPoint ( Point2D ( w * x ) ( h * y ) ) d + name, code :: Text + name = "Rounded quadrilateral" + code = + "with\n\ + \ tr = (1,-2)\n\ + \ rt = (2,-1)\n\ + \ br = (1,2)\n\ + \ rb = (2,1)\n\ + \ bl = (-1,2)\n\ + \ lb = (-2,1)\n\ + \ tl = (-1,-2)\n\ + \ lt = (-2,-1)\n\ + \define\n\ + \ let c = kappa in\n\ + \ [ tr -- lerp c tr ( project rt onto [ tl -> tr ] ) -- lerp c rt ( project tr onto [ rb -> rt ] ) -> rt\n\ + \ -> rb\n\ + \ -- lerp c rb ( project br onto [ rt -> rb ] ) -- lerp c br ( project rb onto [ bl -> br ] ) -> br\n\ + \ -> bl\n\ + \ -- lerp c bl ( project lb onto [ br -> bl ] ) -- lerp c lb ( project bl onto [ lt -> lb ] ) -> lb\n\ + \ -> lt\n\ + \ -- lerp c lt ( project tl onto [ lb -> lt ] ) -- lerp c tl ( project lt onto [ tr -> tl ] ) -> tl\n\ + \ -> .]" -rect :: forall d. Double -> Double -> d -> Seq ( StrokePoint d ) -rect w h d = Seq.fromList - [ pp ( Point2D 1 1 ) - , pp ( Point2D 1 -1 ) - , pp ( Point2D -1 -1 ) - , pp ( Point2D -1 1 ) - , pp ( Point2D 1 1 ) - ] - where - pp :: Point2D Double -> StrokePoint d - pp ( Point2D x y ) = PathPoint ( Point2D ( w * x ) ( h * y ) ) d +-------------------------------------------------------------------------------- + +mkBrush + :: forall ( givenBrushFields :: [ Type ] ) + . STypesI givenBrushFields + => UniqueSupply -> Text -> Text + -> IO ( Brush givenBrushFields ) +mkBrush uniqSupply brushName brushCode = do + ( mbBrush, _ ) <- interpretBrush uniqSupply brushCode + case mbBrush of + Left err -> error ( "Could not interpret '" <> Text.unpack brushName <> "' brush:\n" <> show err ) + Right ( SomeBrushFunction ( brushFunction :: BrushFunction inferredBrushFields ) ) -> + case eqTys @givenBrushFields @inferredBrushFields of + Just Refl -> pure ( BrushData { brushName, brushCode, brushFunction } ) + Nothing -> + error + ( "Incorrect record type for '" <> Text.unpack brushName <> "' brush:\n\ + \Expected: " <> show ( sTypesI @givenBrushFields ) <> "\n\ + \ Actual: " <> show ( sTypesI @inferredBrushFields ) + ) diff --git a/src/app/MetaBrush/Document.hs b/src/app/MetaBrush/Document.hs index eae6384..187c4f0 100644 --- a/src/app/MetaBrush/Document.hs +++ b/src/app/MetaBrush/Document.hs @@ -1,82 +1,118 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module MetaBrush.Document ( AABB(..), mkAABB , Document(..), DocumentContent(..) , emptyDocument - , Stroke(..) - , PointData(..), BrushPointData(..) + , Stroke(..), StrokeSpline, _strokeSpline, overStrokeSpline + , PointData(..), BrushPointData(..), DiffPointData(..) + , Brush(..), emptyBrush , FocusState(..), Hoverable(..), HoverContext(..) - , _selection, _brush , Guide(..) + , _selection, _coords, coords , addGuide, selectedGuide ) where -- base +import Data.Coerce + ( coerce ) +import Data.Functor.Identity + ( Identity(..) ) +import Data.Kind + ( Type ) import Data.Semigroup ( Arg(..), Min(..), ArgMin ) import GHC.Generics - ( Generic ) + ( Generic, Generic1 ) -- acts import Data.Act - ( Act - ( (•) ) - , Torsor - ( (-->) ) - ) + ( Act(..), Torsor(..) ) -- containers import Data.Map.Strict ( Map ) import qualified Data.Map.Strict as Map - ( insert ) -import qualified Data.Map.Strict as Map - ( empty ) -import Data.Sequence - ( Seq ) + ( empty, insert ) -- deepseq import Control.DeepSeq - ( NFData ) + ( NFData(..), NFData1, deepseq ) -- generic-lens import Data.Generics.Product.Fields ( field' ) -import Data.Generics.Product.Typed - ( HasType(typed) ) + +-- groups +import Data.Group + ( Group(..) ) -- lens import Control.Lens - ( Lens' ) + ( Lens' + , set, view, over + ) -- stm import Control.Concurrent.STM ( STM ) +-- superrecord +import qualified SuperRecord as Super + ( Rec ) +import qualified SuperRecord + ( Intersect, rnil ) + -- text import Data.Text ( Text ) +import qualified Data.Text as Text + ( unpack ) + +-- transformers +import Control.Monad.Trans.Reader + ( ReaderT, runReaderT ) -- MetaBrush +import Math.Bezier.Spline + ( Spline(..), KnownSplineType, Curves(..) ) import Math.Bezier.Stroke - ( StrokePoint(..) ) + ( CachedStroke ) import Math.Module - ( Inner((^.^)), squaredNorm, quadrance ) + ( Module + ( origin, (^+^), (^-^), (*^) ) + , Inner((^.^)) + , squaredNorm, quadrance + ) import Math.Vector2D ( Point2D(..), Vector2D(..) ) +import {-# SOURCE #-} MetaBrush.Document.Serialise + ( Serialisable(..) ) +import MetaBrush.MetaParameter.AST + ( STypesI, Adapted, AdaptableFunction(..), BrushFunction ) +import MetaBrush.MetaParameter.Interpolation + ( Interpolatable(..) ) -- + orphan instances import MetaBrush.UI.Viewport ( Ruler(..) ) import MetaBrush.Unique @@ -113,7 +149,7 @@ data Document deriving stock ( Show, Generic ) deriving anyclass NFData --- | Main content of document (data which we keept track of throughout history). +-- | Main content of document (data which we kept track of throughout history). data DocumentContent = Content { unsavedChanges :: !Bool @@ -124,20 +160,90 @@ data DocumentContent deriving stock ( Show, Generic ) deriving anyclass NFData -data Stroke - = Stroke - { strokeName :: Text - , strokeVisible :: !Bool - , strokeUnique :: Unique - , strokePoints :: !( Seq ( StrokePoint PointData ) ) - } - deriving stock ( Show, Generic ) - deriving anyclass NFData +type StrokeSpline ty brushParams = Spline ty CachedStroke ( PointData brushParams ) -data PointData +data Stroke where + Stroke + :: ( KnownSplineType clo + , pointParams ~ Super.Rec pointFields, STypesI pointFields + , brushParams ~ Super.Rec brushFields, STypesI brushFields + , usedParams ~ Super.Rec usedFields , STypesI usedFields + , usedFields ~ ( brushFields `SuperRecord.Intersect` pointFields ) + , Show brushParams, NFData brushParams + , Show pointParams, NFData pointParams + , Interpolatable pointParams + , Interpolatable usedParams + , Serialisable pointParams + , Adapted brushFields pointFields usedFields + ) + => + { strokeName :: Text + , strokeVisible :: !Bool + , strokeUnique :: Unique + , strokeBrush :: Brush brushFields + , strokeSpline :: !( StrokeSpline clo pointParams ) + } + -> Stroke +deriving stock instance Show Stroke +instance NFData Stroke where + rnf ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline } ) + = deepseq strokeSpline + . deepseq strokeUnique + . deepseq strokeVisible + $ rnf strokeName + +_strokeSpline + :: forall f + . Functor f + => ( forall clo pointParams pointFields + . ( KnownSplineType clo + , Show pointParams, NFData pointParams + , pointParams ~ Super.Rec pointFields, STypesI pointFields + , Interpolatable pointParams + , Serialisable pointParams + ) + => StrokeSpline clo pointParams + -> f ( StrokeSpline clo pointParams ) + ) + -> Stroke -> f Stroke +_strokeSpline f ( Stroke { strokeSpline = oldStrokeSpline, .. } ) + = ( \ newSpline -> Stroke { strokeSpline = newSpline, .. } ) <$> f oldStrokeSpline + +overStrokeSpline + :: ( forall clo pointParams pointFields + . ( KnownSplineType clo + , Show pointParams, NFData pointParams + , pointParams ~ Super.Rec pointFields, STypesI pointFields + , Interpolatable pointParams + , Serialisable pointParams + ) + => StrokeSpline clo pointParams + -> StrokeSpline clo pointParams + ) + -> Stroke -> Stroke +overStrokeSpline f = coerce ( _strokeSpline @Identity ( coerce . f ) ) + + +data Brush ( brushFields :: [ Type ] ) + = BrushData + { brushName :: !Text + , brushCode :: !Text + , brushFunction :: !( BrushFunction brushFields ) + } + +instance Show ( Brush brushFields ) where + show ( BrushData { brushName } ) = Text.unpack brushName + +-- Brush parameters using open records. +emptyBrush :: Brush '[] +emptyBrush = BrushData "Empty brush" "" + ( AdaptableFunction ( const SuperRecord.rnil, const $ Spline ( Point2D 0 0 ) NoCurves ) ) + +data PointData params = PointData - { pointState :: FocusState - , brushShape :: Seq ( StrokePoint BrushPointData ) + { pointCoords :: !( Point2D Double ) + , pointState :: FocusState + , brushParams :: !params } deriving stock ( Show, Generic ) deriving anyclass NFData @@ -164,12 +270,6 @@ instance Semigroup FocusState where instance Monoid FocusState where mempty = Normal -_selection :: HasType FocusState pt => Lens' ( StrokePoint pt ) FocusState -_selection = field' @"pointData" . typed @FocusState - -_brush :: Lens' ( StrokePoint PointData ) ( Seq ( StrokePoint BrushPointData ) ) -_brush = field' @"pointData" . field' @"brushShape" - emptyDocument :: Text -> Unique -> Document emptyDocument docName unique = Document @@ -218,6 +318,74 @@ instance Hoverable ( Point2D Double ) where | otherwise = Normal +class HasSelection pt where + _selection :: Lens' pt FocusState +instance HasSelection ( PointData brushParams ) where + _selection = field' @"pointState" +instance HasSelection BrushPointData where + _selection = field' @"brushPointState" + +_coords :: Lens' ( PointData brushParams ) ( Point2D Double ) +_coords = field' @"pointCoords" + +coords :: PointData brushParams -> Point2D Double +coords = view _coords + +data FocusDifference + = DifferentFocus + | SameFocus + deriving stock ( Show, Generic ) + deriving anyclass NFData + +instance Semigroup FocusDifference where + SameFocus <> SameFocus = SameFocus + _ <> _ = DifferentFocus + +instance Monoid FocusDifference where + mempty = SameFocus + +instance Group FocusDifference where + invert = id + +data DiffPointData diffBrushParams + = DiffPointData + { diffVector :: !( Vector2D Double ) + , diffParams :: !diffBrushParams + , diffState :: !FocusDifference + } + deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable ) + deriving anyclass ( NFData, NFData1 ) + +instance Module Double diffBrushParams => Semigroup ( DiffPointData diffBrushParams ) where + DiffPointData v1 p1 s1 <> DiffPointData v2 p2 s2 = + DiffPointData ( v1 <> v2 ) ( p1 ^+^ p2 ) ( s1 <> s2 ) +instance Module Double diffBrushParams => Monoid ( DiffPointData diffBrushParams ) where + mempty = DiffPointData mempty origin mempty +instance Module Double diffBrushParams => Group ( DiffPointData diffBrushParams ) where + invert ( DiffPointData v1 p1 s1 ) = + DiffPointData ( invert v1 ) ( (-1) *^ p1 ) ( invert s1 ) + +instance ( Module Double diffBrushParams, Act diffBrushParams brushParams ) + => Act ( DiffPointData diffBrushParams ) ( PointData brushParams ) where + (•) ( DiffPointData { diffVector = dp, diffParams = db, diffState = focusDiff } ) + = over _coords ( dp • ) + . over ( field' @"brushParams" ) ( db • ) + . ( case focusDiff of { SameFocus -> id; DifferentFocus -> set ( field' @"pointState" ) Normal } ) +instance ( Module Double diffBrushParams, Torsor diffBrushParams brushParams ) + => Torsor ( DiffPointData diffBrushParams ) ( PointData brushParams ) where + ( PointData { pointCoords = p1, brushParams = b1, pointState = s1 } ) <-- ( PointData { pointCoords = p2, brushParams = b2, pointState = s2 } ) = + DiffPointData + { diffVector = p1 <-- p2 + , diffParams = b1 <-- b2 + , diffState = if s1 == s2 then SameFocus else DifferentFocus + } +instance Module Double brushParams => Module Double ( DiffPointData brushParams ) where + origin = mempty + (^+^) = (<>) + x ^-^ y = x <> invert y + d *^ DiffPointData v1 p1 s1 = DiffPointData ( d *^ v1 ) ( d *^ p1 ) s1 + + -------------------------------------------------------------------------------- -- Guides. @@ -250,14 +418,14 @@ selectGuide_maybe c zoom guide@( Guide { guidePoint = p, guideNormal = n } ) -- | Add new guide after a mouse drag from a ruler area. addGuide :: UniqueSupply -> Ruler -> Point2D Double -> Document -> STM Document -addGuide uniqueSupply ruler p = ( field' @"documentContent" . field' @"guides" ) insertNewGuides +addGuide uniqueSupply ruler p doc = ( `runReaderT` uniqueSupply ) $ ( field' @"documentContent" . field' @"guides" ) insertNewGuides doc where - insertNewGuides :: Map Unique Guide -> STM ( Map Unique Guide ) + insertNewGuides :: Map Unique Guide -> ReaderT UniqueSupply STM ( Map Unique Guide ) insertNewGuides gs = case ruler of RulerCorner -> do - uniq1 <- freshUnique uniqueSupply - uniq2 <- freshUnique uniqueSupply + uniq1 <- freshUnique + uniq2 <- freshUnique let guide1, guide2 :: Guide guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideFocus = Normal, guideUnique = uniq1 } @@ -265,14 +433,14 @@ addGuide uniqueSupply ruler p = ( field' @"documentContent" . field' @"guides" ) pure ( Map.insert uniq2 guide2 . Map.insert uniq1 guide1 $ gs ) TopRuler -> do - uniq1 <- freshUnique uniqueSupply + uniq1 <- freshUnique let guide1 :: Guide guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideFocus = Normal, guideUnique = uniq1 } pure ( Map.insert uniq1 guide1 gs ) LeftRuler -> do - uniq2 <- freshUnique uniqueSupply + uniq2 <- freshUnique let guide2 :: Guide guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideFocus = Normal, guideUnique = uniq2 } diff --git a/src/app/MetaBrush/Document/Draw.hs b/src/app/MetaBrush/Document/Draw.hs index b72433e..debfcb9 100644 --- a/src/app/MetaBrush/Document/Draw.hs +++ b/src/app/MetaBrush/Document/Draw.hs @@ -1,8 +1,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module MetaBrush.Document.Draw @@ -22,12 +24,10 @@ import Data.Act -- containers import Data.Sequence ( Seq(..) ) -import qualified Data.Sequence as Seq - ( singleton, reverse, take, drop, length ) -- generic-lens import Data.Generics.Product.Fields - ( field' ) + ( field, field' ) -- lens import Control.Lens @@ -37,6 +37,12 @@ import Control.Lens import Control.Concurrent.STM ( STM ) +-- superrecord +import qualified SuperRecord as Super + ( Rec ) +import qualified SuperRecord + ( rnil ) + -- text import Data.Text ( Text ) @@ -44,17 +50,27 @@ import Data.Text -- transformers import Control.Monad.Trans.State.Strict ( State, runState, get, put ) +import Control.Monad.Trans.Reader + ( runReaderT ) -- MetaBrush -import Math.Bezier.Stroke - ( StrokePoint(..) ) +import Math.Bezier.Spline + ( Spline(..), Curves(..) + , SplineType(..), SSplineType(..) + , SplineTypeI(ssplineType) + , reverseSpline, splineEnd + , openCurveEnd + ) import Math.Module ( squaredNorm ) import Math.Vector2D ( Point2D(..), Vector2D(..) ) import MetaBrush.Document - ( Document(..), Stroke(..), FocusState(..), PointData(..) - , _selection + ( Document(..), Stroke(..), StrokeSpline + , FocusState(..), PointData(..) + , emptyBrush + , _selection, _strokeSpline + , coords, overStrokeSpline ) import MetaBrush.Unique ( Unique, UniqueSupply, freshUnique, uniqueText ) @@ -81,75 +97,115 @@ getOrCreateDrawAnchor -> Point2D Double -> Document -> STM ( Document, DrawAnchor, Point2D Double, Maybe Text ) -getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = - case ( `runState` Nothing ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc of +getOrCreateDrawAnchor uniqueSupply c doc@( Document { zoomFactor } ) = + case + ( `runState` Nothing ) + $ ( field' @"documentContent" . field' @"strokes" . traverse ) + updateStroke doc + of -- Anchor found: use it. - ( newDoc, Just ( ( anchor, anchorPt ), anchorName ) ) -> do - pure ( newDoc, anchor, anchorPt, Just anchorName ) + ( newDoc, Just ( ( anchor, anchorPt ), anchorName ) ) -> + pure ( newDoc, anchor, anchorPt, Just anchorName ) -- No anchor found: start a new stroke (on a new stroke layer). ( newDoc, Nothing ) -> do - uniq <- freshUnique uniqueSupply + uniq <- runReaderT freshUnique uniqueSupply let + newSpline :: StrokeSpline Open ( Super.Rec '[] ) + newSpline = + Spline { splineStart = PointData c Normal ( SuperRecord.rnil ) + , splineCurves = OpenCurves Empty + } + newStroke :: Stroke + newStroke = + Stroke + { strokeName = "Stroke " <> uniqueText uniq + , strokeVisible = True + , strokeUnique = uniq + , strokeSpline = newSpline + , strokeBrush = emptyBrush + } newDoc' :: Document newDoc' = over ( field' @"documentContent" . field' @"strokes" ) - ( Stroke - { strokeName = "Stroke " <> uniqueText uniq - , strokeVisible = True - , strokeUnique = uniq - , strokePoints = Seq.singleton $ PathPoint c ( PointData Normal Empty ) - } - : ) + ( newStroke : ) newDoc pure ( newDoc', AnchorAtEnd uniq, c, Nothing ) where -- Deselect all points, and try to find a valid anchor for drawing -- (a path start/end point at mouse click point). updateStroke :: Stroke -> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) Stroke - updateStroke stroke@( Stroke { strokeName, strokeVisible, strokePoints, strokeUnique } ) = do + updateStroke stroke@( Stroke { strokeName, strokeVisible, strokeUnique } ) = _strokeSpline updateStrokeSpline stroke - mbAnchor <- get - case mbAnchor of - -- If we haven't already found an anchor, - -- and the current point is a valid candidate, - -- then select it as an anchor for the drawing operation. - Nothing - | strokeVisible - , Just anchor <- endpointAnchor strokeUnique strokePoints - -> put ( Just ( anchor, strokeName ) ) - $> set ( field' @"strokePoints" . mapped . _selection ) Normal stroke - -- Otherwise, just deselect. - _ -> pure $ set ( field' @"strokePoints" . mapped . _selection ) Normal stroke - - -- See if we can anchor a drawing operation on a given (visible) stroke. - endpointAnchor :: Unique -> Seq ( StrokePoint PointData ) -> Maybe ( DrawAnchor, Point2D Double ) - endpointAnchor _ ( PathPoint { coords = p0 } :<| ( _ :|> PathPoint { coords = pn } ) ) - | p0 == pn - = Nothing - endpointAnchor uniq (PathPoint { coords = p0 } :<| _ ) - | inPointClickRange p0 - = Just ( AnchorAtStart uniq, p0 ) - endpointAnchor uniq ( _ :|> PathPoint { coords = pn } ) - | inPointClickRange pn - = Just ( AnchorAtEnd uniq, pn ) - endpointAnchor _ _ = Nothing - inPointClickRange :: Point2D Double -> Bool - inPointClickRange p = - squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor ) + where + updateStrokeSpline + :: forall clo brushParams + . SplineTypeI clo + => StrokeSpline clo brushParams + -> State ( Maybe ( ( DrawAnchor, Point2D Double ), Text ) ) ( StrokeSpline clo brushParams ) + updateStrokeSpline spline = do -addToAnchor :: DrawAnchor -> Seq ( StrokePoint PointData ) -> Document -> Document -addToAnchor anchor newPts = over ( field' @"documentContent" . field' @"strokes" . mapped ) addToStroke + mbAnchor <- get + case mbAnchor of + -- If we haven't already found an anchor, + -- and the current point is a valid candidate, + -- then select it as an anchor for the drawing operation. + Nothing + | strokeVisible + , Just anchor <- endpointAnchor strokeUnique spline + -> put ( Just ( anchor, strokeName ) ) + $> set ( mapped . _selection ) Normal spline + -- Otherwise, just deselect. + _ -> pure $ set ( mapped . _selection ) Normal spline + + where + -- See if we can anchor a drawing operation on a given (visible) stroke. + endpointAnchor :: Unique -> StrokeSpline clo brushParams -> Maybe ( DrawAnchor, Point2D Double ) + endpointAnchor uniq ( Spline { splineStart, splineCurves } ) = case ssplineType @clo of + SOpen + | let + p0 :: Point2D Double + p0 = coords splineStart + , inPointClickRange p0 + -> Just ( AnchorAtStart uniq, p0 ) + | OpenCurves ( _ :|> lastCurve ) <- splineCurves + , let + pn :: Point2D Double + pn = coords ( openCurveEnd lastCurve ) + , inPointClickRange pn + -> Just ( AnchorAtEnd uniq, pn ) + _ -> Nothing + inPointClickRange :: Point2D Double -> Bool + inPointClickRange p = + squaredNorm ( c --> p :: Vector2D Double ) < 16 / ( zoomFactor * zoomFactor ) + +addToAnchor :: DrawAnchor -> StrokeSpline Open () -> Document -> Document +addToAnchor anchor newSpline = over ( field' @"documentContent" . field' @"strokes" . mapped ) addToStroke where addToStroke :: Stroke -> Stroke - addToStroke stroke@( Stroke { strokeUnique, strokePoints = pts } ) + addToStroke stroke@( Stroke { strokeUnique } ) | strokeUnique == anchorStrokeUnique anchor - = case anchor of - AnchorAtStart _ -> stroke { strokePoints = Seq.reverse newPts <> Seq.drop 1 pts } - AnchorAtEnd _ -> stroke { strokePoints = dropEnd 1 pts <> newPts } + = + let + updateSpline + :: forall clo brushData + . SplineTypeI clo + => StrokeSpline clo brushData -> StrokeSpline clo brushData + updateSpline prevSpline + | SOpen <- ssplineType @clo + = case anchor of + AnchorAtStart _ -> + let + setBrushData :: PointData () -> PointData brushData + setBrushData = set ( field @"brushParams" ) ( brushParams ( splineStart prevSpline ) ) + in fmap setBrushData ( reverseSpline newSpline ) <> prevSpline + AnchorAtEnd _ -> + let + setBrushData :: PointData () -> PointData brushData + setBrushData = set ( field @"brushParams" ) ( brushParams ( splineEnd prevSpline ) ) + in prevSpline <> fmap setBrushData newSpline + | otherwise + = error "addToAnchor: trying to add to a closed spline" + in + overStrokeSpline updateSpline stroke | otherwise = stroke - dropEnd :: Int -> Seq a -> Seq a - dropEnd i as = Seq.take ( n - i ) as - where - n :: Int - n = Seq.length as diff --git a/src/app/MetaBrush/Document/History.hs b/src/app/MetaBrush/Document/History.hs index 4bb959b..4061c69 100644 --- a/src/app/MetaBrush/Document/History.hs +++ b/src/app/MetaBrush/Document/History.hs @@ -1,13 +1,10 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index 0704b71..3fff17d 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -4,12 +4,12 @@ {-# 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 #-} @@ -25,8 +25,6 @@ module MetaBrush.Document.Selection where -- base -import Control.Category - ( (>>>) ) import Control.Monad ( guard ) import Data.Functor @@ -63,12 +61,6 @@ import Generic.Data -- generic-lens import Data.Generics.Product.Fields ( field' ) -import Data.Generics.Product.Typed - ( HasType ) - --- groups -import Data.Group - ( invert ) -- lens import Control.Lens @@ -78,9 +70,7 @@ import Control.Lens import Control.Monad.Trans.Tardis ( Tardis ) import qualified Control.Monad.Trans.Tardis as Tardis - ( TardisT(..) - , getPast, getFuture, sendPast, sendFuture - ) + ( runTardisT, getPast, getFuture, sendPast, sendFuture ) -- text import Data.Text @@ -91,34 +81,49 @@ import qualified Data.Text as Text -- transformers import Control.Monad.Trans.Class ( lift ) +import Control.Monad.Trans.Maybe + ( MaybeT(..) ) import Control.Monad.Trans.State.Strict - ( StateT(..), State, runState, evalState - , get, put, modify + ( StateT, State + , runState, evalState, evalStateT + , get, put, modify' ) import Control.Monad.Trans.Writer.CPS ( WriterT, runWriterT, tell ) -- MetaBrush import qualified Math.Bezier.Cubic as Cubic - ( Bezier(..), closestPoint, fromQuadratic, drag ) + ( Bezier(..), bezier, closestPoint, fromQuadratic, drag ) import qualified Math.Bezier.Quadratic as Quadratic ( Bezier(..), closestPoint, interpolate ) +import Math.Bezier.Spline + ( Spline(..), SplineType(..), SSplineType(..), NextPoint(..) + , Curve(..), Curves(..), PointType(..) + , splitSplineAt + , SplineTypeI(ssplineType) + , KnownSplineType + ( lastPoint, adjustSplineType, biwitherSpline, ibitraverseSpline, bitraverseSpline ) + , fromNextPoint + ) import Math.Bezier.Stroke - ( StrokePoint(..) ) + ( CachedStroke(..), discardCache ) import Math.Module - ( squaredNorm, closestPointToSegment ) + ( lerp, squaredNorm, closestPointOnSegment ) import Math.Vector2D - ( Point2D(..), Vector2D(..) ) + ( Point2D(..), Vector2D(..), Segment(..) ) import {-# SOURCE #-} MetaBrush.Context ( Modifier(..) ) import MetaBrush.Document ( Document(..), Stroke(..) + , PointData(..), DiffPointData , FocusState(..), _selection + , StrokeSpline, _strokeSpline, overStrokeSpline + , _coords, coords ) import {-# SOURCE #-} MetaBrush.Document.Update ( DocChange(..) ) -import {-# SOURCE #-} MetaBrush.UI.ToolBar - ( Mode(..) ) +import MetaBrush.MetaParameter.Interpolation + ( Interpolatable(Diff) ) import MetaBrush.Unique ( Unique ) @@ -147,49 +152,38 @@ selectionMode = foldMap \case _ -> New -- | Updates the selected objects on a single click selection event. -selectAt :: Mode -> SelectionMode -> Point2D Double -> Document -> Document -selectAt mode selMode c doc@( Document { zoomFactor } ) = +selectAt :: SelectionMode -> Point2D Double -> Document -> Document +selectAt selMode c doc@( Document { zoomFactor } ) = ( `evalState` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc where updateStroke :: Stroke -> State Bool Stroke - updateStroke stroke@( Stroke { strokeVisible } ) - | Brush <- mode - = ( field' @"strokePoints" . traverse ) - ( \ spt -> - ( field' @"pointData" . field' @"brushShape" ) - ( traverse ( updatePoint strokeVisible ( MkVector2D $ coords spt ) ) - >>> fmap matchEndpoints - ) - spt - ) - stroke - | otherwise - = ( field' @"strokePoints" ) - ( traverse ( updatePoint strokeVisible ( Vector2D 0 0 ) ) - >>> fmap matchEndpoints - ) - stroke - updatePoint :: HasType FocusState pt => Bool -> Vector2D Double -> StrokePoint pt -> State Bool ( StrokePoint pt ) - updatePoint isVisible offset pt = do - anotherPointHasAlreadyBeenSelected <- get - if selected && not anotherPointHasAlreadyBeenSelected - then put True $> case selMode of - Subtract -> set _selection Normal pt - _ -> set _selection Selected pt - else pure $ case selMode of - New -> set _selection Normal pt - _ -> pt + updateStroke stroke@( Stroke { strokeVisible } ) = _strokeSpline updateSpline stroke where - selected :: Bool - selected - | not isVisible = False - | otherwise = squaredNorm ( c --> ( offset • coords pt ) :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16 - -- Ensure consistency of selection at endpoints for closed loops. - matchEndpoints :: HasType FocusState pt => Seq ( StrokePoint pt ) -> Seq ( StrokePoint pt ) - matchEndpoints ( p0 :<| ( ps :|> pn ) ) - | coords p0 == coords pn - = p0 :<| ( ps :|> set _selection ( view _selection p0 ) pn ) - matchEndpoints ps = ps + updateSpline + :: forall clo brushParams + . ( KnownSplineType clo ) + => StrokeSpline clo brushParams -> State Bool ( StrokeSpline clo brushParams ) + updateSpline oldSpline = + bitraverseSpline + ( const pure ) + ( updateSplinePoint strokeVisible ) + oldSpline + + updateSplinePoint :: Bool -> PointData brushParams -> State Bool ( PointData brushParams ) + updateSplinePoint isVisible pt = do + anotherPointHasAlreadyBeenSelected <- get + if selected && not anotherPointHasAlreadyBeenSelected + then put True $> case selMode of + Subtract -> set _selection Normal pt + _ -> set _selection Selected pt + else pure $ case selMode of + New -> set _selection Normal pt + _ -> pt + where + selected :: Bool + selected + | not isVisible = False + | otherwise = squaredNorm ( c --> coords pt :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16 -- | Type of a drag move selection: -- @@ -203,7 +197,6 @@ data DragMoveSelect { dragStrokeUnique :: !Unique , dragSegmentIndex :: !Int , dragSegmentParameter :: !Double - , dragBrushCenter :: !( Maybe ( Point2D Double ) ) } deriving stock Show @@ -220,8 +213,8 @@ instance Semigroup DragMoveSelect where -- | Checks whether a mouse click can initiate a drag move event, -- and if so returns an updated document with the selection modified from the start of the drag move. -dragMoveSelect :: Mode -> Point2D Double -> Document -> Maybe ( DragMoveSelect, Document ) -dragMoveSelect mode c doc@( Document { zoomFactor } ) = +dragMoveSelect :: Point2D Double -> Document -> Maybe ( DragMoveSelect, Document ) +dragMoveSelect c doc@( Document { zoomFactor } ) = let res :: WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) Document res = do @@ -235,174 +228,147 @@ dragMoveSelect mode c doc@( Document { zoomFactor } ) = where updateStroke :: Stroke -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) Stroke - updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) - | Brush <- mode - = ( field' @"strokePoints" . traverse ) - ( \ spt -> - ( field' @"pointData" . field' @"brushShape" ) - ( updateStrokePoints strokeVisible strokeUnique ( coords spt ) - >>> fmap matchEndpoints - ) - spt - ) - stroke - | otherwise - = ( field' @"strokePoints" ) - ( updateStrokePoints strokeVisible strokeUnique ( Point2D 0 0 ) - >>> fmap matchEndpoints - ) - stroke - - -- Ensure consistency of selection at endpoints for closed loops. - matchEndpoints :: HasType FocusState pt => Seq ( StrokePoint pt ) -> Seq ( StrokePoint pt ) - matchEndpoints ( p0 :<| ( ps :|> pn ) ) - | coords p0 == coords pn - = p0 :<| ( ps :|> set _selection ( view _selection p0 ) pn ) - matchEndpoints ps = ps - - updateStrokePoints - :: forall pt - . ( Show pt, HasType FocusState pt ) - => Bool - -> Unique - -> Point2D Double - -> Seq ( StrokePoint pt ) - -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) ( Seq ( StrokePoint pt ) ) - updateStrokePoints _ _ _ Empty = pure Empty - updateStrokePoints isVisible uniq offset ( spt :<| spts ) = go 0 spt spts + updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = _strokeSpline updateSpline stroke where - inSelectionRange :: Point2D Double -> Bool - inSelectionRange p - | not isVisible = False - | otherwise = squaredNorm ( c --> ( MkVector2D offset • p ) :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16 - go :: Int -> StrokePoint pt -> Seq ( StrokePoint pt ) - -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) ( Seq ( StrokePoint pt ) ) - go _ sp0 Empty = ( :<| Empty ) <$> updatePoint sp0 - -- Line. - go i sp0 ( sp1 :<| sps ) - | PathPoint {} <- sp1 - = do + updateSpline + :: forall clo brushParams + . KnownSplineType clo + => StrokeSpline clo brushParams + -> WriterT ( Maybe DragMoveSelect ) + ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) + ( StrokeSpline clo brushParams ) + updateSpline oldSpline = + ibitraverseSpline + ( updateSplineCurve ( splineStart oldSpline ) strokeVisible strokeUnique ) + ( updateSplinePoint strokeVisible ) + oldSpline + + updateSplineCurve + :: forall clo' brushParams + . ( SplineTypeI clo', Traversable ( NextPoint clo' ) ) + => PointData brushParams -> Bool -> Unique + -> Int -> PointData brushParams -> Curve clo' CachedStroke ( PointData brushParams ) + -> WriterT ( Maybe DragMoveSelect ) + ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) + ( Curve clo' CachedStroke ( PointData brushParams ) ) + updateSplineCurve start isVisible uniq i sp0 curve = case curve of + line@( LineTo sp1 _ ) -> do + let + mbCurveDrag :: Maybe DragMoveSelect + mbCurveDrag = do let - mbCurveDrag :: Maybe DragMoveSelect - mbCurveDrag = do - let - t :: Double - p :: Point2D Double - ( t, p ) - = closestPointToSegment @( Vector2D Double ) ( invert ( MkVector2D offset ) • c ) ( coords sp0 ) ( coords sp1 ) - guard ( inSelectionRange p ) - pure $ - ClickedOnCurve - { dragStrokeUnique = uniq - , dragSegmentIndex = i - , dragSegmentParameter = t - , dragBrushCenter = case mode of { Brush -> Just offset; _ -> Nothing } - } - tell mbCurveDrag - sp0' <- updatePoint sp0 - ( sp0' :<| ) <$> go ( i + 1 ) sp1 sps - -- Quadratic Bézier curve. - go i sp0 ( sp1 :<| sp2 :<| sps ) - | ControlPoint {} <- sp1 - , PathPoint {} <- sp2 - = do + t :: Double + p :: Point2D Double + ( t, p ) + = closestPointOnSegment @( Vector2D Double ) c ( Segment ( coords sp0 ) ( coords $ fromNextPoint start sp1 ) ) + guard ( inSelectionRange isVisible p ) + pure $ + ClickedOnCurve + { dragStrokeUnique = uniq + , dragSegmentIndex = i + , dragSegmentParameter = t + } + tell mbCurveDrag + sp1' <- traverse ( updateSplinePoint isVisible ) sp1 + pure ( line { curveEnd = sp1' } ) + bez2@( Bezier2To sp1 sp2 _ ) -> do + let + mbCurveDrag :: Maybe DragMoveSelect + mbCurveDrag = do let - mbCurveDrag :: Maybe DragMoveSelect - mbCurveDrag = do - let - bez :: Quadratic.Bezier ( Point2D Double ) - bez = Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) - sq_d :: Double - t :: Double - Min ( Arg sq_d (t, _) ) - = Quadratic.closestPoint @( Vector2D Double ) bez ( invert ( MkVector2D offset ) • c ) - guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 ) - pure $ - ClickedOnCurve - { dragStrokeUnique = uniq - , dragSegmentIndex = i - , dragSegmentParameter = t - , dragBrushCenter = case mode of { Brush -> Just offset; _ -> Nothing } - } - tell mbCurveDrag - sp0' <- updatePoint sp0 - sp1' <- updatePoint sp1 - ( ( sp0' :<| ) . ( sp1' :<| ) ) <$> go ( i + 2 ) sp2 sps - -- Cubic Bézier curve. - go i sp0 ( sp1 :<| sp2 :<| sp3 :<| sps ) - | ControlPoint {} <- sp1 - , ControlPoint {} <- sp2 - , PathPoint {} <- sp3 - = do + bez :: Quadratic.Bezier ( Point2D Double ) + bez = Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords $ fromNextPoint start sp2 ) + sq_d :: Double + t :: Double + Min ( Arg sq_d (t, _) ) + = Quadratic.closestPoint @( Vector2D Double ) bez c + guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 ) + pure $ + ClickedOnCurve + { dragStrokeUnique = uniq + , dragSegmentIndex = i + , dragSegmentParameter = t + } + tell mbCurveDrag + sp1' <- updateSplinePoint isVisible sp1 + sp2' <- traverse ( updateSplinePoint isVisible ) sp2 + pure ( bez2 { controlPoint = sp1', curveEnd = sp2' } ) + bez3@( Bezier3To sp1 sp2 sp3 _ ) -> do + let + mbCurveDrag :: Maybe DragMoveSelect + mbCurveDrag = do let - mbCurveDrag :: Maybe DragMoveSelect - mbCurveDrag = do - let - bez :: Cubic.Bezier ( Point2D Double ) - bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 ) - sq_d :: Double - t :: Double - Min ( Arg sq_d (t, _) ) - = Cubic.closestPoint @( Vector2D Double ) bez ( invert ( MkVector2D offset ) • c ) - guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 ) - pure $ - ClickedOnCurve - { dragStrokeUnique = uniq - , dragSegmentIndex = i - , dragSegmentParameter = t - , dragBrushCenter = case mode of { Brush -> Just offset; _ -> Nothing } - } - tell mbCurveDrag - sp0' <- updatePoint sp0 - sp1' <- updatePoint sp1 - sp2' <- updatePoint sp2 - ( ( sp0' :<| ) . ( sp1' :<| ) . ( sp2' :<| ) ) <$> go ( i + 3 ) sp3 sps - go _ sp0 sps = error ( "dragMoveSelect: unrecognised stroke type\n" <> show ( sp0 :<| sps ) ) - updatePoint - :: StrokePoint pt - -> WriterT ( Maybe DragMoveSelect ) ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) ( StrokePoint pt ) - updatePoint pt - | inSelectionRange ( coords pt ) - = do - mbPreviousSelect <- lift $ Tardis.getPast - case mbPreviousSelect of - -- Already clicked on a point: don't select further points. - Just dragSelect - | ClickedOnSelected <- dragSelect - -> pure pt - | ClickedOnUnselected <- dragSelect - -> pure pt - -- First click on a point: record this. - _ -> do - let - mbDrag :: Maybe DragMoveSelect - mbDrag = case view _selection pt of - Selected -> Just ClickedOnSelected - _ -> Just ClickedOnUnselected - lift $ Tardis.sendFuture mbDrag - tell mbDrag - -- Select this point (whether it was previously selected or not). - pure ( set _selection Selected pt ) - | otherwise - = do - mbDragClick <- lift $ Tardis.getFuture - let - -- needs to be lazy - newPointState :: FocusState - newPointState = case mbDragClick of - -- User clicked on a selected point or a curve segment: preserve selection. - Just dragMove - | ClickedOnSelected <- dragMove - -> view _selection pt - | ClickedOnCurve {} <- dragMove - -> view _selection pt - -- User clicked on an unselected point, or not on a point at all: discard selection. - _ -> Normal - pure ( set _selection newPointState pt ) + bez :: Cubic.Bezier ( Point2D Double ) + bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords $ fromNextPoint start sp3 ) + sq_d :: Double + t :: Double + Min ( Arg sq_d (t, _) ) + = Cubic.closestPoint @( Vector2D Double ) bez c + guard ( t > 0 && t < 1 && sq_d * zoomFactor ^ ( 2 :: Int ) < 16 ) + pure $ + ClickedOnCurve + { dragStrokeUnique = uniq + , dragSegmentIndex = i + , dragSegmentParameter = t + } + tell mbCurveDrag + sp1' <- updateSplinePoint isVisible sp1 + sp2' <- updateSplinePoint isVisible sp2 + sp3' <- traverse ( updateSplinePoint isVisible ) sp3 + pure ( bez3 { controlPoint1 = sp1', controlPoint2 = sp2', curveEnd = sp3' } ) + + inSelectionRange :: Bool -> Point2D Double -> Bool + inSelectionRange isVisible p + | not isVisible = False + | otherwise = squaredNorm ( c --> p :: Vector2D Double ) * zoomFactor ^ ( 2 :: Int ) < 16 + + updateSplinePoint + :: Bool -> PointData brushParams + -> WriterT ( Maybe DragMoveSelect ) + ( Tardis ( Maybe DragMoveSelect ) ( Maybe DragMoveSelect ) ) + ( PointData brushParams ) + updateSplinePoint strokeVisible pt + | inSelectionRange strokeVisible ( coords pt ) + = do + mbPreviousSelect <- lift Tardis.getPast + case mbPreviousSelect of + -- Already clicked on a point: don't select further points. + Just dragSelect + | ClickedOnSelected <- dragSelect + -> pure pt + | ClickedOnUnselected <- dragSelect + -> pure pt + -- First click on a point: record this. + _ -> do + let + mbDrag :: Maybe DragMoveSelect + mbDrag = case view _selection pt of + Selected -> Just ClickedOnSelected + _ -> Just ClickedOnUnselected + lift ( Tardis.sendFuture mbDrag ) + tell mbDrag + -- Select this point (whether it was previously selected or not). + pure ( set _selection Selected pt ) + | otherwise + = do + mbDragClick <- lift Tardis.getFuture + let + -- needs to be lazy + newPointState :: FocusState + newPointState = case mbDragClick of + -- User clicked on a selected point or a curve segment: preserve selection. + Just dragMove + | ClickedOnSelected <- dragMove + -> view _selection pt + | ClickedOnCurve {} <- dragMove + -> view _selection pt + -- User clicked on an unselected point, or not on a point at all: discard selection. + _ -> Normal + pure ( set _selection newPointState pt ) -- | Updates the selected objects on a rectangular selection event. -selectRectangle :: Mode -> SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document -selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 ) +selectRectangle :: SelectionMode -> Point2D Double -> Point2D Double -> Document -> Document +selectRectangle selMode ( Point2D x0 y0 ) ( Point2D x1 y1 ) = over ( field' @"documentContent" . field' @"strokes" . mapped ) updateStroke where @@ -410,21 +376,12 @@ selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 ) ( xMin, xMax ) = if x0 <= x1 then ( x0, x1 ) else ( x1, x0 ) ( yMin, yMax ) = if y0 <= y1 then ( y0, y1 ) else ( y1, y0 ) updateStroke :: Stroke -> Stroke - updateStroke stroke@( Stroke { strokeVisible } ) - | Brush <- mode - = over ( field' @"strokePoints" . mapped ) - ( \ spt -> - over ( field' @"pointData" . field' @"brushShape" . mapped ) - ( updatePoint strokeVisible ( MkVector2D $ coords spt ) ) - spt - ) + updateStroke stroke@( Stroke { strokeVisible } ) = + overStrokeSpline + ( fmap ( updateSplinePoint strokeVisible ) ) stroke - | otherwise - = over ( field' @"strokePoints" . mapped ) - ( updatePoint strokeVisible ( Vector2D 0 0 ) ) - stroke - updatePoint :: HasType FocusState pt => Bool -> Vector2D Double -> StrokePoint pt -> StrokePoint pt - updatePoint isVisible offset pt + updateSplinePoint :: Bool -> PointData brushParams -> PointData brushParams + updateSplinePoint isVisible pt | selected = case selMode of Subtract -> set _selection Normal pt _ -> set _selection Selected pt @@ -433,7 +390,7 @@ selectRectangle mode selMode ( Point2D x0 y0 ) ( Point2D x1 y1 ) _ -> pt where x, y :: Double - Point2D x y = offset • coords pt + Point2D x y = coords pt selected :: Bool selected | not isVisible = False @@ -449,123 +406,237 @@ data UpdateInfo deriving ( Semigroup, Monoid ) via Generically UpdateInfo --- Update the info to record a modification. --- --- Needs to be lazy in the given Boolean, to avoid time paradoxes. -recordPointUpdate :: Monad m => Bool -> Unique -> StrokePoint d -> StateT UpdateInfo m () -recordPointUpdate doUpdate uniq ( PathPoint {} ) = modify $ - if doUpdate - then - ( over ( field' @"pathPointsAffected" ) (<>1) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - else id -recordPointUpdate doUpdate uniq ( ControlPoint {} ) = modify $ - if doUpdate - then - ( over ( field' @"controlPointsAffected" ) (<>1) - . over ( field' @"strokesAffected" ) ( Set.insert uniq ) - ) - else id - -- | Translate all selected points by the given vector. -- --- Returns the updated doucment, together with info about how many points were translated. -translateSelection :: Mode -> Vector2D Double -> Document -> ( Document, UpdateInfo ) -translateSelection mode t doc = - ( `runState` mempty ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc - +-- Returns the updated document, together with info about how many points were translated. +translateSelection :: Vector2D Double -> Document -> ( Document, UpdateInfo ) +translateSelection t doc = + ( `runState` mempty ) . ( `evalStateT` False ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc where - updateStroke :: Stroke -> State UpdateInfo Stroke - updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) - | not strokeVisible - = pure stroke - | Brush <- mode - = ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" . traverse ) - ( updateStrokePoint strokeUnique ) - stroke - | otherwise - = ( field' @"strokePoints" . traverse ) - ( updateStrokePoint strokeUnique ) - stroke + updateStroke :: Stroke -> StateT Bool ( State UpdateInfo ) Stroke + updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = _strokeSpline updateSpline stroke + where + updateSpline + :: forall clo brushParams + . KnownSplineType clo + => StrokeSpline clo brushParams + -> StateT Bool ( State UpdateInfo ) ( StrokeSpline clo brushParams ) + updateSpline oldSpline + | not strokeVisible + = pure oldSpline + | otherwise + = bitraverseSpline + ( const $ updateSplineCurve ( splineStart oldSpline ) ) + ( updatePoint PathPoint ) + oldSpline + where + updateSplineCurve + :: forall clo' + . SplineTypeI clo' + => PointData brushParams + -> Curve clo' CachedStroke ( PointData brushParams ) + -> StateT Bool ( State UpdateInfo ) ( Curve clo' CachedStroke ( PointData brushParams ) ) + updateSplineCurve start crv = do + prevMod <- get + case crv of + LineTo p1 dat -> do + p1' <- traverse ( updatePoint PathPoint ) p1 + pure $ LineTo p1' dat' + where + dat' :: CachedStroke + dat' + | prevMod || ( view _selection ( fromNextPoint start p1 ) == Selected ) + = discardCache dat + | otherwise + = dat + Bezier2To p1 p2 dat -> do + p1' <- updatePoint ControlPoint p1 + p2' <- traverse ( updatePoint PathPoint ) p2 + pure $ Bezier2To p1' p2' dat' + where + dat' :: CachedStroke + dat' + | prevMod || any ( \ pt -> view _selection pt == Selected ) [ p1, fromNextPoint start p2 ] + = discardCache dat + | otherwise + = dat + Bezier3To p1 p2 p3 dat -> do + p1' <- updatePoint ControlPoint p1 + p2' <- updatePoint ControlPoint p2 + p3' <- traverse ( updatePoint PathPoint ) p3 + pure $ Bezier3To p1' p2' p3' dat' + where + dat' :: CachedStroke + dat' + | prevMod || any ( \ pt -> view _selection pt == Selected ) [ p1, p2, fromNextPoint start p3 ] + = discardCache dat + | otherwise + = dat - updateStrokePoint :: HasType FocusState pt => Unique -> StrokePoint pt -> State UpdateInfo ( StrokePoint pt ) - updateStrokePoint uniq pt - | Selected <- view _selection pt - = recordPointUpdate True uniq pt - $> pt { coords = t • coords pt } - | otherwise - = pure pt + updatePoint :: PointType -> PointData brushParams -> StateT Bool ( State UpdateInfo ) ( PointData brushParams ) + updatePoint PathPoint pt + | Selected <- view _selection pt + = do + lift . modify' $ + ( over ( field' @"pathPointsAffected" ) (<>1) + . over ( field' @"strokesAffected" ) ( Set.insert strokeUnique ) + ) + put True $> over _coords ( t • ) pt + | otherwise + = put False $> pt + updatePoint ControlPoint pt + | Selected <- view _selection pt + = do + lift . modify' $ + ( over ( field' @"controlPointsAffected" ) (<>1) + . over ( field' @"strokesAffected" ) ( Set.insert strokeUnique ) + ) + pure $ over _coords ( t • ) pt + | otherwise + = pure pt -- | Delete the selected points. -- -- Returns the updated document, together with info about how many points were deleted. -deleteSelected :: Mode -> Document -> ( Document, UpdateInfo ) -deleteSelected mode doc = deletionResult +deleteSelected :: Document -> ( Document, UpdateInfo ) +deleteSelected doc = deletionResult where deletionResult :: ( Document, UpdateInfo ) deletionResult - = fst . runIdentity . ( `Tardis.runTardisT` ( False, False ) ) . ( `runStateT` mempty ) - $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc + = ( `runState` mempty ) + $ ( field' @"documentContent" . field' @"strokes" ) + ( fmap catMaybes . traverse updateStroke ) + doc - updateStroke :: Stroke -> StateT UpdateInfo ( Tardis Bool Bool ) Stroke - updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) - | not strokeVisible - = pure stroke - | Brush <- mode - = ( field' @"strokePoints" . traverse . field' @"pointData" . field' @"brushShape" ) - ( updateStrokePoints strokeUnique ) - stroke - | otherwise - = ( field' @"strokePoints" ) - ( updateStrokePoints strokeUnique ) - stroke - - updateStrokePoints - :: forall pt - . HasType FocusState pt - => Unique -> Seq ( StrokePoint pt ) - -> StateT UpdateInfo ( Tardis Bool Bool ) ( Seq ( StrokePoint pt ) ) - updateStrokePoints _ Empty = pure Empty - updateStrokePoints uniq ( p :<| ps ) = case p of - PathPoint {} - | Selected <- selectionState - -> do - lift ( Tardis.sendPast True ) - lift ( Tardis.sendFuture True ) - recordPointUpdate True uniq p - updateStrokePoints uniq ps - | otherwise - -> do - lift ( Tardis.sendPast False ) - lift ( Tardis.sendFuture False ) - ( p :<| ) <$> updateStrokePoints uniq ps - _ -> do - prevPathPointDeleted <- lift Tardis.getPast - nextPathPointDeleted <- lift Tardis.getFuture - rest <- updateStrokePoints uniq ps - let - -- Control point must be deleted: - -- - if it is selected, - -- - if the previous path point was deleted, - -- - if the next path point is going to be deleted. - -- - -- Need to be lazy in "nextPathPointDeleted" to avoid looping. - needsDeletion :: Bool - needsDeletion - = selectionState == Selected - || prevPathPointDeleted - || nextPathPointDeleted - recordPointUpdate needsDeletion uniq p - pure $ if needsDeletion then rest else ( p :<| rest ) + updateStroke :: Stroke -> State UpdateInfo ( Maybe Stroke ) + updateStroke stroke@( Stroke { strokeVisible, strokeUnique } ) = runMaybeT $ _strokeSpline updateSpline stroke where - selectionState :: FocusState - selectionState = view _selection p + updateSpline + :: forall clo brushParams + . KnownSplineType clo + => StrokeSpline clo brushParams + -> MaybeT ( State UpdateInfo ) ( StrokeSpline clo brushParams ) + updateSpline oldSpline + | not strokeVisible + = pure oldSpline + | otherwise + = MaybeT + $ biwitherSpline + ( updateSplineCurve strokeUnique ) + ( updateSplinePoint strokeUnique ) + oldSpline + where + + noDat :: CachedStroke + noDat = CachedStroke Nothing + + updateSplinePoint + :: Unique + -> PointData brushParams + -> State UpdateInfo + ( Maybe ( PointData brushParams ) ) + updateSplinePoint uniq pt + | Selected <- view _selection pt + = do + modify' + ( over ( field' @"pathPointsAffected" ) ( <> 1 ) + . over ( field' @"strokesAffected" ) ( Set.insert uniq ) + ) + pure Nothing + | otherwise + = do + pure ( Just pt ) + + updateSplineCurve + :: forall clo'. SplineTypeI clo' + => Unique + -> Maybe ( PointData brushParams ) + -> Curve clo' CachedStroke ( PointData brushParams ) + -> State UpdateInfo + ( Maybe ( Curve clo' CachedStroke ( PointData brushParams ) ) ) + updateSplineCurve uniq mbPrevPt crv = + case crv of + LineTo p1 _ -> + case ssplineType @clo' of + SOpen + | NextPoint pt <- p1 + , Selected <- view _selection pt + -> do + modify' + ( over ( field' @"pathPointsAffected" ) ( <> 1 ) + . over ( field' @"strokesAffected" ) ( Set.insert uniq ) + ) + pure Nothing + _ -> + case mbPrevPt of + Nothing -> pure ( Just $ LineTo p1 noDat ) -- no need to update "strokesAffected" + Just _ -> pure ( Just crv ) + Bezier2To cp1 p2 _ -> + case ssplineType @clo' of + SOpen + | NextPoint pt <- p2 + , Selected <- view _selection pt + -> do + modify' + ( over ( field' @"pathPointsAffected" ) ( <> 1 ) + . over ( field' @"controlPointsAffected" ) ( <> 1 ) + . over ( field' @"strokesAffected" ) ( Set.insert uniq ) + ) + pure Nothing + _ -> + case mbPrevPt of + Just _ | Normal <- view _selection cp1 + -> pure ( Just crv ) + _ -> do + modify' + ( over ( field' @"controlPointsAffected" ) ( <> 1 ) + . over ( field' @"strokesAffected" ) ( Set.insert uniq ) + ) + pure ( Just $ LineTo p2 noDat ) + Bezier3To cp1 cp2 p3 _ -> + case ssplineType @clo' of + SOpen + | NextPoint pt <- p3 + , Selected <- view _selection pt + -> do + modify' + ( over ( field' @"pathPointsAffected" ) ( <> 1 ) + . over ( field' @"controlPointsAffected" ) ( <> 2 ) + . over ( field' @"strokesAffected" ) ( Set.insert uniq ) + ) + pure Nothing + _ -> + case mbPrevPt of + Just _ + | Normal <- view _selection cp1 + , Normal <- view _selection cp2 + -> pure ( Just crv ) + | Normal <- view _selection cp1 + -> do + modify' + ( over ( field' @"controlPointsAffected" ) ( <> 1 ) + . over ( field' @"strokesAffected" ) ( Set.insert uniq ) + ) + pure ( Just $ Bezier2To cp1 p3 noDat ) + | Normal <- view _selection cp2 + -> do + modify' + ( over ( field' @"controlPointsAffected" ) ( <> 1 ) + . over ( field' @"strokesAffected" ) ( Set.insert uniq ) + ) + pure ( Just $ Bezier2To cp2 p3 noDat ) + _ -> do + modify' + ( over ( field' @"controlPointsAffected" ) ( <> 2 ) + . over ( field' @"strokesAffected" ) ( Set.insert uniq ) + ) + pure ( Just $ LineTo p3 noDat ) + -- | Perform a drag move action on a document. -dragUpdate :: Mode -> Point2D Double -> Point2D Double -> DragMoveSelect -> Bool -> Document -> Maybe DocChange -dragUpdate mode p0 p PointDrag _ doc = case updateInfo of +dragUpdate :: Point2D Double -> Point2D Double -> DragMoveSelect -> Bool -> Document -> Maybe DocChange +dragUpdate p0 p PointDrag _ doc = case updateInfo of UpdateInfo { pathPointsAffected, controlPointsAffected, strokesAffected } | null strokesAffected -> Nothing @@ -589,8 +660,8 @@ dragUpdate mode p0 p PointDrag _ doc = case updateInfo of where newDocument :: Document updateInfo :: UpdateInfo - ( newDocument, updateInfo ) = translateSelection mode ( p0 --> p ) doc -dragUpdate mode _ p ( ClickedOnCurve {..} ) alternateMode doc + ( newDocument, updateInfo ) = translateSelection ( p0 --> p ) doc +dragUpdate _ p ( ClickedOnCurve { dragStrokeUnique, dragSegmentIndex, dragSegmentParameter } ) alternateMode doc | Just name <- mbStrokeName , let changeText :: Text @@ -602,124 +673,93 @@ dragUpdate mode _ p ( ClickedOnCurve {..} ) alternateMode doc newDocument :: Document mbStrokeName :: Maybe Text ( newDocument, mbStrokeName ) - = ( `runState` Nothing ) - $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc + = ( `runState` Nothing ) $ ( field' @"documentContent" . field' @"strokes" . traverse ) updateStroke doc updateStroke :: Stroke -> State ( Maybe Text ) Stroke updateStroke stroke@( Stroke { strokeUnique, strokeName } ) | strokeUnique /= dragStrokeUnique = pure stroke - | Brush <- mode - = ( field' @"strokePoints" . traverse ) - ( \ spt -> - if dragBrushCenter /= Just ( coords spt ) - then -- only update the correct brush path - pure spt - else - ( field' @"pointData" . field' @"brushShape" ) - ( updateStrokePoints strokeName ( MkVector2D $ coords spt ) ) - spt - ) - stroke | otherwise - = ( field' @"strokePoints" ) - ( updateStrokePoints strokeName ( Vector2D 0 0 ) ) - stroke - updateStrokePoints - :: forall pt. Show pt - => Text -> Vector2D Double - -> Seq ( StrokePoint pt ) -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) ) - updateStrokePoints _ _ Empty = pure Empty - updateStrokePoints name offset ( spt :<| spts ) = go 0 spt spts + = _strokeSpline updateSpline stroke where - p_eff :: Point2D Double - p_eff = invert offset • p - go :: Int -> StrokePoint pt -> Seq ( StrokePoint pt ) -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) ) - go _ sp0 Empty = pure ( sp0 :<| Empty ) - -- Line. - go i sp0 ( sp1 :<| sps ) - | PathPoint {} <- sp1 - = case compare i dragSegmentIndex of - GT -> pure ( sp0 :<| sp1 :<| sps ) - LT -> ( sp0 :<| ) <$> go ( i + 1 ) sp1 sps - EQ -> do + updateSpline + :: forall clo pointParams + . ( KnownSplineType clo, Interpolatable pointParams ) + => StrokeSpline clo pointParams + -> State ( Maybe Text ) ( StrokeSpline clo pointParams ) + updateSpline + = fmap ( adjustSplineType @clo ) + . updateSplineCurves strokeName + . adjustSplineType @Open + + where + + updateSplineCurves + :: Text + -> StrokeSpline Open pointParams + -> State ( Maybe Text ) ( StrokeSpline Open pointParams) + updateSplineCurves name spline = case splitSplineAt dragSegmentIndex spline of + ( _ , Spline { splineCurves = OpenCurves Empty } ) -> pure spline + ( bef, Spline { splineStart, splineCurves = OpenCurves ( curve :<| next ) } ) -> do put ( Just name ) - if alternateMode - then - let - p1 :: Point2D Double - Quadratic.Bezier { p1 } = - Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp1 ) dragSegmentParameter p_eff - cp :: StrokePoint pt - cp = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate - in pure ( sp0 :<| cp :<| sp1 :<| sps ) - else - let - bez :: Cubic.Bezier ( Point2D Double ) - bez = Cubic.Bezier ( coords sp0 ) ( coords sp0 ) ( coords sp1 ) ( coords sp1 ) - p1, p2 :: Point2D Double - Cubic.Bezier { p1, p2 } = - Cubic.drag @( Vector2D Double ) bez dragSegmentParameter p_eff - cp1, cp2 :: StrokePoint pt - cp1 = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate - cp2 = ControlPoint { coords = p2, pointData = pointData sp1 } -- TODO: interpolate - in pure ( sp0 :<| cp1 :<| cp2 :<| sp1 :<| sps ) - -- Quadratic Bézier curve. - go i sp0 ( sp1 :<| sp2 :<| sps ) - | ControlPoint {} <- sp1 - , PathPoint {} <- sp2 - = case compare i dragSegmentIndex of - GT -> pure ( sp0 :<| sp1 :<| sp2 :<| sps ) - LT -> ( ( sp0 :<| ) . ( sp1 :<| ) ) <$> go ( i + 2 ) sp2 sps - EQ -> do - put ( Just name ) - if not alternateMode -- switch alternate mode for quadratic Bézier case... - then - let - p1 :: Point2D Double - Quadratic.Bezier { p1 } = - Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp2 ) dragSegmentParameter p_eff - cp :: StrokePoint pt - cp = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate - in pure ( sp0 :<| cp :<| sp2 :<| sps ) - else - let - bez :: Cubic.Bezier ( Point2D Double ) - bez = Cubic.fromQuadratic @( Vector2D Double ) ( Quadratic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ) - p1, p2 :: Point2D Double - Cubic.Bezier { p1, p2 } = - Cubic.drag @( Vector2D Double ) bez dragSegmentParameter p_eff - cp1, cp2 :: StrokePoint pt - cp1 = sp1 { coords = p1 } -- TODO: interpolate - cp2 = sp1 { coords = p2 } -- TODO: interpolate - in pure ( sp0 :<| cp1 :<| cp2 :<| sp2 :<| sps ) - -- Cubic Bézier curve. - go i sp0 ( sp1 :<| sp2 :<| sp3 :<| sps ) - | ControlPoint {} <- sp1 - , ControlPoint {} <- sp2 - , PathPoint {} <- sp3 - = case compare i dragSegmentIndex of - GT -> pure ( sp0 :<| sp1 :<| sp2 :<| sp3 :<| sps ) - LT -> ( ( sp0 :<| ) . ( sp1 :<| ) . ( sp2 :<| ) ) <$> go ( i + 3 ) sp3 sps - EQ -> do - put ( Just name ) - if alternateMode - then - let - p1 :: Point2D Double - Quadratic.Bezier { p1 } = - Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp3 ) dragSegmentParameter p_eff - cp :: StrokePoint pt - cp = ControlPoint { coords = p1, pointData = pointData sp0 } -- TODO: interpolate - in pure ( sp0 :<| cp :<| sp3 :<| sps ) - else - let - bez :: Cubic.Bezier ( Point2D Double ) - bez = Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 ) - p1, p2 :: Point2D Double - Cubic.Bezier { p1, p2 } = - Cubic.drag @( Vector2D Double ) bez dragSegmentParameter p_eff - cp1, cp2 :: StrokePoint pt - cp1 = sp1 { coords = p1 } -- TODO: interpolate - cp2 = sp2 { coords = p2 } -- TODO: interpolate - in pure ( sp0 :<| cp1 :<| cp2 :<| sp3 :<| sps ) - go _ sp0 sps = error ( "dragUpdate: unrecognised stroke type\n" <> show ( sp0 :<| sps ) ) + pure ( bef <> Spline { splineStart, splineCurves = OpenCurves $ updateCurve ( lastPoint bef ) curve :<| next } ) + + where + updateCurve + :: PointData pointParams + -> Curve Open CachedStroke ( PointData pointParams ) + -> Curve Open CachedStroke ( PointData pointParams ) + updateCurve sp0 curve = case curve of + LineTo ( NextPoint sp1 ) dat -> do + let + bez2 :: Quadratic.Bezier ( PointData pointParams ) + bez2 = Quadratic.Bezier sp0 ( lerp @( DiffPointData ( Diff pointParams ) ) dragSegmentParameter sp0 sp1 ) sp1 + if alternateMode + then quadraticDragCurve dat bez2 + else cubicDragCurve dat ( Cubic.fromQuadratic @( DiffPointData ( Diff 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 + else quadraticDragCurve dat ( Quadratic.Bezier sp0 sp1 sp2 ) + Bezier3To sp1 sp2 ( NextPoint sp3 ) dat -> do + let + bez3 :: Cubic.Bezier ( PointData pointParams ) + bez3 = Cubic.Bezier sp0 sp1 sp2 sp3 + if alternateMode + then quadraticDragCurve dat + ( Quadratic.Bezier + sp0 + ( Cubic.bezier @( DiffPointData ( Diff pointParams ) ) bez3 dragSegmentParameter ) + sp3 + ) + else cubicDragCurve dat bez3 + where + quadraticDragCurve + :: CachedStroke + -> Quadratic.Bezier ( PointData pointParams ) + -> Curve Open CachedStroke ( PointData pointParams ) + quadraticDragCurve dat ( Quadratic.Bezier { Quadratic.p1 = sp1, Quadratic.p2 = sp2 } ) = + let + cp :: Point2D Double + Quadratic.Bezier { Quadratic.p1 = cp } = + Quadratic.interpolate @( Vector2D Double ) ( coords sp0 ) ( coords sp2 ) dragSegmentParameter p + dat' :: CachedStroke + dat' = discardCache dat + in Bezier2To ( set _coords cp sp1 ) ( NextPoint sp2 ) dat' + cubicDragCurve + :: CachedStroke + -> Cubic.Bezier ( PointData pointParams ) + -> Curve Open CachedStroke ( PointData pointParams ) + cubicDragCurve dat ( Cubic.Bezier { Cubic.p1 = sp1, Cubic.p2 = sp2, Cubic.p3 = sp3 } ) = + let + cp1, cp2 :: Point2D Double + Cubic.Bezier { Cubic.p1 = cp1, Cubic.p2 = cp2 } = + Cubic.drag @( Vector2D Double ) + ( Cubic.Bezier ( coords sp0 ) ( coords sp1 ) ( coords sp2 ) ( coords sp3 ) ) + dragSegmentParameter + p + dat' :: CachedStroke + dat' = discardCache dat + in Bezier3To ( set _coords cp1 sp1 ) ( set _coords cp2 sp2 ) ( NextPoint sp3 ) dat' diff --git a/src/app/MetaBrush/Document/Serialise.hs b/src/app/MetaBrush/Document/Serialise.hs index d87ab8c..b982ebe 100644 --- a/src/app/MetaBrush/Document/Serialise.hs +++ b/src/app/MetaBrush/Document/Serialise.hs @@ -1,12 +1,26 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} module MetaBrush.Document.Serialise - ( documentToJSON, documentFromJSON + ( Serialisable(..) + , documentToJSON, documentFromJSON , saveDocument, loadDocument ) where @@ -24,6 +38,24 @@ import Data.Functor.Contravariant ( contramap ) import Data.Functor.Identity ( Identity(..) ) +import Data.Kind + ( Type ) +import Data.List + ( sortBy ) +import Data.Ord + ( comparing ) +import Data.Proxy + ( Proxy(Proxy) ) +import Data.Type.Equality + ( (:~:)(Refl) ) +import Data.Typeable + ( Typeable, eqT ) +import GHC.Exts + ( Proxy#, proxy# ) +import GHC.TypeLits + ( symbolVal', KnownSymbol, SomeSymbol(..), someSymbolVal, sameSymbol ) +import GHC.TypeNats + ( KnownNat ) import Unsafe.Coerce ( unsafeCoerce ) -- Tony Morris special @@ -51,6 +83,10 @@ import Data.Sequence import qualified Data.Sequence as Seq ( fromList ) +-- deepseq +import Control.DeepSeq + ( NFData(..) ) + -- directory import System.Directory ( canonicalizePath, createDirectoryIfMissing, doesFileExist ) @@ -63,10 +99,18 @@ import System.FilePath import Data.Generics.Product.Typed ( HasType(typed) ) +-- groups +import Data.Group + ( Group ) + -- lens import Control.Lens ( view ) +-- mtl +import Control.Monad.Except + ( MonadError(throwError) ) + -- scientific import qualified Data.Scientific as Scientific ( fromFloatDigits, toRealFloat ) @@ -75,13 +119,29 @@ import qualified Data.Scientific as Scientific import qualified Control.Concurrent.STM as STM ( atomically ) +-- superrecord +import qualified SuperRecord as Super + ( Rec ) +import qualified SuperRecord + ( Has, RecTy, (:=), FldProxy(..) + , RecSize, RecApply(..), RecVecIdxPos, UnsafeRecBuild(..) + , TraversalCHelper, RemoveAccessTo, Intersect + , reflectRec + ) +import SuperRecord + ( ConstC, Tuple22C ) + -- text import Data.Text ( Text ) +import qualified Data.Text as Text + ( pack, unpack, unwords ) -- transformers import Control.Monad.IO.Class ( MonadIO(liftIO) ) +import Control.Monad.Trans.Reader + ( runReaderT ) import Control.Monad.Trans.Class ( MonadTrans(lift) ) @@ -91,14 +151,14 @@ import qualified Waargonaut.Attoparsec as JSON.Decoder import qualified Waargonaut.Decode as JSON ( Decoder ) import qualified Waargonaut.Decode.Error as JSON - ( DecodeError ) + ( DecodeError(ParseFailed) ) import qualified Waargonaut.Decode as JSON.Decoder - ( atKey, bool, list, oneOf, scientific, text ) + ( atKey, atKeyOptional, bool, list, objectAsKeyValues, scientific, text ) import qualified Waargonaut.Encode as JSON - ( Encoder, Encoder' ) + ( Encoder ) import qualified Waargonaut.Encode as JSON.Encoder - ( runEncoder - , atKey', bool, list, mapLikeObj, scientific, text + ( runEncoder, runPureEncoder + , atKey', bool, json, keyValueTupleFoldable, list, mapLikeObj, scientific, text, either ) import qualified Waargonaut.Encode.Builder as JSON.Builder ( waargonautBuilder, bsBuilder ) @@ -112,20 +172,40 @@ import qualified Waargonaut.Prettier as JSON ( prettyJson ) import qualified Waargonaut.Prettier as TonyMorris ( Natural ) +import Waargonaut.Types.Json + ( Json ) -- MetaBrush -import Math.Bezier.Stroke - ( StrokePoint(..) ) -import Math.Vector2D - ( Point2D(..), Vector2D(..) ) -import MetaBrush.Document - ( Document(..), DocumentContent(..) - , Guide(..) - , Stroke(..) - , PointData(..) - , BrushPointData(..) - , FocusState(..) +import qualified Math.Bezier.Cubic as Cubic + ( Bezier ) +import qualified Math.Bezier.Quadratic as Quadratic + ( Bezier ) +import Math.Bezier.Spline + ( Spline(..), SplinePts, SplineType(..), SSplineType(..), SplineTypeI(..) + , Curves(..), Curve(..), NextPoint(..) ) +import Math.Bezier.Stroke + ( CachedStroke(..) ) +import Math.Module + ( Module ) +import Math.Vector2D + ( Point2D(..), Vector2D(..), Segment ) +import MetaBrush.Document + ( Document(..), DocumentContent(..), Guide(..) + , Stroke(..), StrokeSpline + , PointData(..), Brush(..) , FocusState(..) + ) +import MetaBrush.MetaParameter.AST + ( SType(..), STypeI(..), STypes(..), STypesI(..) + , SomeSType(..), someSTypes + , Adapted, AdaptableFunction(..), BrushFunction + , MapFields, UniqueField, UseFieldsInBrush + , eqTy, eqTys + ) +import MetaBrush.MetaParameter.Driver + ( SomeBrushFunction(..), interpretBrush ) +import MetaBrush.MetaParameter.Interpolation + ( Interpolatable(..), MapDiff, HasDiff', HasTorsor ) import MetaBrush.Unique ( Unique, UniqueSupply, freshUnique ) @@ -176,31 +256,53 @@ loadDocument uniqueSupply fp = do -------------------------------------------------------------------------------- -encodeDouble :: Applicative f => JSON.Encoder f Double -encodeDouble = contramap Scientific.fromFloatDigits JSON.Encoder.scientific +class Serialisable a where + encoder :: Monad f => JSON.Encoder f a + decoder :: Monad m => JSON.Decoder m a -decodeDouble :: Monad m => JSON.Decoder m Double -decodeDouble = fmap Scientific.toRealFloat JSON.Decoder.scientific +instance Serialisable Double where + encoder = contramap Scientific.fromFloatDigits JSON.Encoder.scientific + decoder = fmap Scientific.toRealFloat JSON.Decoder.scientific +instance Serialisable a => Serialisable ( Point2D a ) where + encoder = JSON.Encoder.mapLikeObj \ ( Point2D x y ) -> + JSON.Encoder.atKey' "x" encoder x + . JSON.Encoder.atKey' "y" encoder y + decoder = Point2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder +instance Serialisable a => Serialisable ( Vector2D a ) where + encoder = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) -> + JSON.Encoder.atKey' "x" encoder x + . JSON.Encoder.atKey' "y" encoder y + decoder = Vector2D <$> JSON.Decoder.atKey "x" decoder <*> JSON.Decoder.atKey "y" decoder -encodePoint2D :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Point2D a ) -encodePoint2D enc = JSON.Encoder.mapLikeObj \ ( Point2D x y ) -> - JSON.Encoder.atKey' "x" enc x . JSON.Encoder.atKey' "y" enc y +instance ( SuperRecord.RecApply flds flds ( ConstC Serialisable ) + , SuperRecord.UnsafeRecBuild flds flds ( ConstC Serialisable ) + , KnownNat ( SuperRecord.RecSize flds ) + ) + => Serialisable ( Super.Rec flds ) where + encoder :: forall f. Monad f => JSON.Encoder f ( Super.Rec flds ) + encoder = contramap ( SuperRecord.reflectRec @( ConstC Serialisable ) keyVal ) ( JSON.Encoder.keyValueTupleFoldable JSON.Encoder.json ) + where + keyVal :: forall k v. ( KnownSymbol k, Serialisable v ) => SuperRecord.FldProxy k -> v -> ( Text, Json ) + keyVal _ v = let k = symbolVal' ( proxy# :: Proxy# k ) in ( Text.pack k, JSON.Encoder.runPureEncoder ( encoder @v ) v ) -decodePoint2D :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Point2D a ) -decodePoint2D dec = Point2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" dec - - - -encodeVector2D :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Vector2D a ) -encodeVector2D enc = JSON.Encoder.mapLikeObj \ ( Vector2D x y ) -> - JSON.Encoder.atKey' "x" enc x - . JSON.Encoder.atKey' "y" enc y - -decodeVector2D :: Monad m => JSON.Decoder m a -> JSON.Decoder m ( Vector2D a ) -decodeVector2D dec = Vector2D <$> JSON.Decoder.atKey "x" dec <*> JSON.Decoder.atKey "y" dec + decoder :: forall m. Monad m => JSON.Decoder m ( Super.Rec flds ) + decoder = SuperRecord.unsafeRecBuild @flds @flds @( ConstC Serialisable ) decodeAndWrite + where + decodeAndWrite + :: forall k v + . ( KnownSymbol k, Serialisable v ) + => SuperRecord.FldProxy k -> Proxy# v + -> JSON.Decoder m v + decodeAndWrite _ _ = do + let + k :: Text + k = Text.pack ( symbolVal' ( proxy# :: Proxy# k ) ) + val <- JSON.Decoder.atKey k ( decoder @v @m ) + pure val +-------------------------------------------------------------------------------- {- encodeMat22 :: Applicative f => JSON.Encoder' a -> JSON.Encoder f ( Mat22 a ) @@ -238,30 +340,115 @@ decodeAABB = do -} -encodeStrokePoint :: Applicative f => JSON.Encoder' d -> JSON.Encoder f ( StrokePoint d ) -encodeStrokePoint enc = JSON.Encoder.mapLikeObj \case - PathPoint { coords, pointData } -> - JSON.Encoder.atKey' "coords" ( encodePoint2D encodeDouble ) coords - . JSON.Encoder.atKey' "data" enc pointData - . JSON.Encoder.atKey' "type" JSON.Encoder.text "path" - ControlPoint { coords, pointData } -> - JSON.Encoder.atKey' "coords" ( encodePoint2D encodeDouble ) coords - . JSON.Encoder.atKey' "data" enc pointData - . JSON.Encoder.atKey' "type" JSON.Encoder.text "control" +encodeCurve + :: forall clo crvData ptData f + . ( SplineTypeI clo, Applicative f ) + => JSON.Encoder Identity ptData + -> JSON.Encoder f ( Curve clo crvData ptData ) +encodeCurve encodePtData = case ssplineType @clo of + SOpen -> JSON.Encoder.mapLikeObj \case + LineTo ( NextPoint p1 ) _ -> + JSON.Encoder.atKey' "p1" encodePtData p1 + Bezier2To p1 ( NextPoint p2 ) _ -> + JSON.Encoder.atKey' "p1" encodePtData p1 + . JSON.Encoder.atKey' "p2" encodePtData p2 + Bezier3To p1 p2 ( NextPoint p3 ) _ -> + JSON.Encoder.atKey' "p1" encodePtData p1 + . JSON.Encoder.atKey' "p2" encodePtData p2 + . JSON.Encoder.atKey' "p3" encodePtData p3 + SClosed -> JSON.Encoder.mapLikeObj \case + LineTo BackToStart _ -> id + Bezier2To p1 BackToStart _ -> + JSON.Encoder.atKey' "p1" encodePtData p1 + Bezier3To p1 p2 BackToStart _ -> + JSON.Encoder.atKey' "p1" encodePtData p1 + . JSON.Encoder.atKey' "p2" encodePtData p2 -decodeStrokePointTypeIsPath :: Monad m => JSON.Decoder m Bool -decodeStrokePointTypeIsPath = JSON.Decoder.oneOf JSON.Decoder.text "StrokePoint Type" - [ ( "path", True ), ( "control", False ) ] +decodeCurve + :: forall clo ptData m + . ( SplineTypeI clo, Monad m ) + => JSON.Decoder m ptData + -> JSON.Decoder m ( Curve clo CachedStroke ptData ) +decodeCurve decodePtData = case ssplineType @clo of + SOpen -> do + p1 <- JSON.Decoder.atKey "p1" decodePtData + mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData + case mb_p2 of + Nothing -> + pure ( LineTo ( NextPoint p1 ) ( CachedStroke Nothing ) ) + Just p2 -> do + mb_p3 <- JSON.Decoder.atKeyOptional "p3" decodePtData + case mb_p3 of + Nothing -> pure ( Bezier2To p1 ( NextPoint p2 ) ( CachedStroke Nothing ) ) + Just p3 -> pure ( Bezier3To p1 p2 ( NextPoint p3 ) ( CachedStroke Nothing ) ) + SClosed -> do + mb_p1 <- JSON.Decoder.atKeyOptional "p1" decodePtData + case mb_p1 of + Nothing -> + pure ( LineTo BackToStart ( CachedStroke Nothing ) ) + Just p1 -> do + mb_p2 <- JSON.Decoder.atKeyOptional "p2" decodePtData + case mb_p2 of + Nothing -> pure ( Bezier2To p1 BackToStart ( CachedStroke Nothing ) ) + Just p2 -> pure ( Bezier3To p1 p2 BackToStart ( CachedStroke Nothing ) ) -decodeStrokePoint :: Monad m => JSON.Decoder m d -> JSON.Decoder m ( StrokePoint d ) -decodeStrokePoint dec = do - coords <- JSON.Decoder.atKey "coords" ( decodePoint2D decodeDouble ) - pointData <- JSON.Decoder.atKey "data" dec - isPathPoint <- JSON.Decoder.atKey "type" decodeStrokePointTypeIsPath - if isPathPoint - then pure ( PathPoint { coords, pointData } ) - else pure ( ControlPoint { coords, pointData } ) + +encodeCurves + :: forall clo crvData ptData f + . ( SplineTypeI clo, Applicative f ) + => JSON.Encoder Identity ptData + -> JSON.Encoder f ( Curves clo crvData ptData ) +encodeCurves encodePtData = case ssplineType @clo of + SOpen -> contramap ( openCurves ) ( encodeSequence $ encodeCurve @Open encodePtData ) + SClosed -> contramap ( \case { NoCurves -> Left (); ClosedCurves prevs lst -> Right ( prevs, lst ) } ) ( JSON.Encoder.either encodeL encodeR ) + where + encodeL :: JSON.Encoder f () + encodeL = contramap ( const "NoCurves" ) JSON.Encoder.text + encodeR :: JSON.Encoder f ( Seq ( Curve Open crvData ptData ), Curve Closed crvData ptData ) + encodeR = JSON.Encoder.mapLikeObj \ ( openCurves, closedCurve ) -> + JSON.Encoder.atKey' "prevOpenCurves" ( encodeSequence $ encodeCurve @Open encodePtData ) openCurves + . JSON.Encoder.atKey' "lastClosedCurve" ( encodeCurve @Closed encodePtData ) closedCurve + +decodeCurves + :: forall clo ptData m + . ( SplineTypeI clo, Monad m ) + => JSON.Decoder m ptData + -> JSON.Decoder m ( Curves clo CachedStroke ptData ) +decodeCurves decodePtData = case ssplineType @clo of + SOpen -> OpenCurves <$> decodeSequence ( decodeCurve @Open decodePtData ) + SClosed -> do + mbNoCurves <- JSON.Decoder.atKeyOptional "NoCurves" ( JSON.Decoder.text ) + case mbNoCurves of + Just _ -> pure NoCurves + Nothing -> do + prevCurves <- JSON.Decoder.atKey "prevOpenCurves" ( decodeSequence $ decodeCurve @Open decodePtData ) + lastCurve <- JSON.Decoder.atKey "lastClosedCurve" ( decodeCurve @Closed decodePtData ) + pure ( ClosedCurves prevCurves lastCurve ) + + + +encodeSpline + :: forall clo crvData ptData f + . ( SplineTypeI clo, Applicative f ) + => JSON.Encoder Identity ptData + -> JSON.Encoder f ( Spline clo crvData ptData ) +encodeSpline encodePtData = JSON.Encoder.mapLikeObj \ ( Spline { splineStart, splineCurves } ) -> + JSON.Encoder.atKey' "splineStart" encodePtData splineStart + . JSON.Encoder.atKey' "splineCurves" ( encodeCurves @clo encodePtData ) splineCurves + +decodeSpline + :: forall clo ptData m + . ( SplineTypeI clo, Monad m ) + => JSON.Decoder m ptData + -> JSON.Decoder m ( Spline clo CachedStroke ptData ) +decodeSpline decodePtData = do + splineStart <- JSON.Decoder.atKey "splineStart" decodePtData + splineCurves <- JSON.Decoder.atKey "splineCurves" ( decodeCurves @clo decodePtData ) + pure ( Spline { splineStart, splineCurves } ) + + +{- encodeFocusState :: Applicative f => JSON.Encoder f FocusState encodeFocusState = contramap focusText JSON.Encoder.text where @@ -287,7 +474,7 @@ decodeBrushPointData :: Monad m => JSON.Decoder m BrushPointData decodeBrushPointData = do brushPointState <- JSON.Decoder.atKey "focus" decodeFocusState pure ( BrushPointData { brushPointState } ) - +-} encodeSequence :: Applicative f => JSON.Encoder f a -> JSON.Encoder f ( Seq a ) @@ -306,50 +493,269 @@ decodeUniqueMap dec = Map.fromList . map ( view typed &&& id ) <$> JSON.Decoder. -encodePointData :: Applicative f => JSON.Encoder f PointData -encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointState, brushShape } ) -> - JSON.Encoder.atKey' "focus" encodeFocusState pointState - . JSON.Encoder.atKey' "brush" ( encodeSequence ( encodeStrokePoint encodeBrushPointData ) ) brushShape +encodePointData + :: forall f flds brushParams + . ( Applicative f + , brushParams ~ Super.Rec flds + , Serialisable ( Super.Rec flds ) + ) + => JSON.Encoder f ( PointData brushParams ) +encodePointData = JSON.Encoder.mapLikeObj \ ( PointData { pointCoords, brushParams } ) -> + JSON.Encoder.atKey' "coords" ( encoder @( Point2D Double ) ) pointCoords + . JSON.Encoder.atKey' "brushParams" ( encoder @( Super.Rec flds ) ) brushParams -decodePointData :: Monad m => JSON.Decoder m PointData +decodePointData + :: forall m flds brushParams + . ( Monad m + , brushParams ~ Super.Rec flds + , Serialisable ( Super.Rec flds ) + ) + => JSON.Decoder m ( PointData brushParams ) decodePointData = do - pointState <- JSON.Decoder.atKey "focus" decodeFocusState - brushShape <- JSON.Decoder.atKey "brush" ( decodeSequence ( decodeStrokePoint decodeBrushPointData ) ) - pure ( PointData { pointState, brushShape } ) + pointCoords <- JSON.Decoder.atKey "coords" ( decoder @( Point2D Double ) ) + let + pointState :: FocusState + pointState = Normal + brushParams <- JSON.Decoder.atKey "brushParams" ( decoder @( Super.Rec flds ) ) + pure ( PointData { pointCoords, pointState, brushParams } ) -encodeStroke :: Applicative f => JSON.Encoder f Stroke -encodeStroke = JSON.Encoder.mapLikeObj \ ( Stroke { strokeName, strokeVisible, strokePoints } ) -> - JSON.Encoder.atKey' "name" JSON.Encoder.text strokeName - . JSON.Encoder.atKey' "visible" JSON.Encoder.bool strokeVisible - . JSON.Encoder.atKey' "points" ( encodeSequence ( encodeStrokePoint encodePointData ) ) strokePoints +encodeSomeSType :: Applicative f => JSON.Encoder f SomeSType +encodeSomeSType = JSON.Encoder.mapLikeObj \ ( SomeSType ( _ :: Proxy# ty ) ) -> + case sTypeI @ty of + sFunTy@SFunTy | ( _ :: SType ( a -> b ) ) <- sFunTy + -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "fun" + . JSON.Encoder.atKey' "arg" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) ) + . JSON.Encoder.atKey' "res" encodeSomeSType ( SomeSType ( proxy# :: Proxy# b ) ) + STyBool + -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bool" + STyDouble + -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "double" + sTyPoint@STyPoint | ( _ :: SType ( Point2D a ) ) <- sTyPoint + -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "point" + . JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) ) + sTyLine@STyLine | ( _ :: SType ( Segment a ) ) <- sTyLine + -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "line" + . JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) ) + sTyBez2@STyBez2 | ( _ :: SType ( Quadratic.Bezier a ) ) <- sTyBez2 + -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bez2" + . JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) ) + sTyBez3@STyBez3 | ( _ :: SType ( Cubic.Bezier a ) ) <- sTyBez3 + -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "bez3" + . JSON.Encoder.atKey' "coords" encodeSomeSType ( SomeSType ( proxy# :: Proxy# a ) ) + sTySpline@STySpline | ( _ :: SType ( SplinePts clo ) ) <- sTySpline + -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "spline" + . JSON.Encoder.atKey' "closed" JSON.Encoder.bool ( case ssplineType @clo of { SOpen -> False; SClosed -> True } ) + sTyRecord@STyWithFn | ( _ :: SType ( AdaptableFunction kvs res ) ) <- sTyRecord + -> JSON.Encoder.atKey' "tag" JSON.Encoder.text "adaptableFun" + . JSON.Encoder.atKey' "fields" encodeFieldTypes ( someSTypes @kvs ) + . JSON.Encoder.atKey' "res" encodeSomeSType ( SomeSType ( proxy# :: Proxy# res ) ) +{- +decodeSomeSType :: Monad m => JSON.Decoder m SomeSType +decodeSomeSType = do + tag <- JSON.Decoder.atKey "tag" JSON.Decoder.text + case tag of + "fun" -> do + ( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "arg" decodeSomeSType + ( SomeSType ( _ :: Proxy# b ) ) <- JSON.Decoder.atKey "res" decodeSomeSType + pure ( SomeSType ( proxy# :: Proxy# ( a -> b ) ) ) + "bool" -> pure ( SomeSType ( proxy# :: Proxy# Bool ) ) + "double" -> pure ( SomeSType ( proxy# :: Proxy# Double ) ) + "point" -> do + ( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType + pure ( SomeSType ( proxy# :: Proxy# ( Point2D a ) ) ) + "line" -> do + ( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType + pure ( SomeSType ( proxy# :: Proxy# ( Segment a ) ) ) + "bez2" -> do + ( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType + pure ( SomeSType ( proxy# :: Proxy# ( Quadratic.Bezier a ) ) ) + "bez3" -> do + ( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeSType + pure ( SomeSType ( proxy# :: Proxy# ( Cubic.Bezier a ) ) ) + "spline" -> do + closed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool + case closed of + True -> pure ( SomeSType ( proxy# :: Proxy# ( SplinePts Closed ) ) ) + False -> pure ( SomeSType ( proxy# :: Proxy# ( SplinePts Open ) ) ) + "adaptableFun" -> do + ( SomeBrushFields ( _ :: Proxy# kvs ) ) <- JSON.Decoder.atKey "fields" decodeFieldTypes + ( SomeSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "res" decodeSomeSType + pure ( SomeSType ( proxy# :: Proxy# ( AdaptableFunction kvs a ) ) ) +-} +decodeSomeFieldSType :: Monad m => JSON.Decoder m SomeFieldSType +decodeSomeFieldSType = do + tag <- JSON.Decoder.atKey "tag" JSON.Decoder.text + case tag of + "double" -> pure ( SomeFieldSType ( proxy# :: Proxy# Double ) ) + "point" -> do + ( SomeFieldSType ( _ :: Proxy# a ) ) <- JSON.Decoder.atKey "coords" decodeSomeFieldSType + case eqT @a @Double of + Just Refl -> pure ( SomeFieldSType ( proxy# :: Proxy# ( Point2D Double ) ) ) + Nothing -> throwError ( JSON.ParseFailed "Point2D: non-Double coordinate type" ) + _ -> throwError ( JSON.ParseFailed $ "Unsupported record field type with tag " <> tag ) -decodeStroke :: MonadIO m => UniqueSupply -> JSON.Decoder m Stroke + +encodeFieldTypes :: Monad f => JSON.Encoder f ( [ ( Text, SomeSType ) ] ) +encodeFieldTypes = JSON.Encoder.keyValueTupleFoldable encodeSomeSType + +decodeFieldTypes :: Monad m => JSON.Decoder m SomeBrushFields +decodeFieldTypes = do + fields <- JSON.Decoder.objectAsKeyValues JSON.Decoder.text decodeSomeFieldSType + let + sortedFields :: [ ( Text, SomeFieldSType ) ] + sortedFields = sortBy ( comparing fst ) fields + duplicates :: [ Text ] + duplicates = duplicatesAcc [] [] sortedFields + duplicatesAcc :: [ Text ] -> [ Text ] -> [ ( Text, SomeFieldSType ) ] -> [ Text ] + duplicatesAcc _ dups [] = dups + duplicatesAcc seen dups ( ( k, _ ) : kvs ) + | k `elem` seen + = duplicatesAcc seen ( k : dups ) kvs + | otherwise + = duplicatesAcc ( k : seen ) dups kvs + case duplicates of + [] -> pure ( mkBrushFields sortedFields ) + [dup] -> throwError ( JSON.ParseFailed $ "Duplicate field name " <> dup <> " in brush record type" ) + dups -> throwError ( JSON.ParseFailed $ "Duplicate field names in brush record type:\n" <> Text.unwords dups ) + + where + + mkBrushFields :: [ ( Text, SomeFieldSType ) ] -> SomeBrushFields + mkBrushFields = fromSomeBrushFieldsList . mkBrushFieldsList + + mkBrushFieldsList :: [ ( Text, SomeFieldSType ) ] -> SomeBrushFieldsList + mkBrushFieldsList [] = SomeBrushFieldsList NilFields + mkBrushFieldsList ( ( k, SomeFieldSType ( _ :: Proxy# v ) ) : kvs ) + | SomeBrushFieldsList ( kvs_list :: BrushFieldsList kvs ) <- mkBrushFieldsList kvs + , SomeSymbol ( _ :: Proxy k ) <- someSymbolVal ( Text.unpack k ) + -- deduce RecSize ( MapDiff kvs ) ~ RecSize kvs + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize ( MapDiff kvs ) :~: SuperRecord.RecSize kvs ) + -- compute indexing into record list (with SuperRecord, the index is the number of fields remaining) + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k ( ( k SuperRecord.:= v ) : kvs ) :~: SuperRecord.RecSize kvs ) + = SomeBrushFieldsList ( ConsFields ( proxy# :: Proxy# k ) ( proxy# :: Proxy# v ) kvs_list ) + + fromSomeBrushFieldsList :: SomeBrushFieldsList -> SomeBrushFields + fromSomeBrushFieldsList ( SomeBrushFieldsList ( kvs :: BrushFieldsList kvs ) ) = case go @kvs kvs of + SomeClassyBrushFieldsList ( _ :: Proxy# kvs ) ( _ :: Proxy# kvs ) -> + SomeBrushFields ( proxy# :: Proxy# kvs ) + where + go :: forall ( rts :: [ Type ] ) ( lts :: [ Type ] ) + . ( STypesI rts, KnownNat ( SuperRecord.RecSize rts ), KnownNat ( SuperRecord.RecSize ( MapDiff rts ) ) ) + => BrushFieldsList lts -> SomeClassyBrushFieldsList rts lts + go NilFields = + SomeClassyBrushFieldsList ( proxy# :: Proxy# rts ) ( proxy# :: Proxy# '[] ) + go ( ConsFields ( _ :: Proxy# k ) ( _ :: Proxy# a ) kvs' ) + | ( SomeClassyBrushFieldsList _ ( _ :: Proxy# lts' ) ) <- go @rts kvs' + -- Assert some facts that result from the field names being distinct: + -- - current field name does not re-occur later on + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k lts' :~: lts' ) + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k ( MapDiff lts' ) :~: MapDiff lts' ) + -- - looking up the type associated with the current field name returns the current type + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k rts :~: Just a ) + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k ( MapDiff rts ) :~: Just ( Diff a ) ) + -- - MapDiff preserves length + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize ( MapDiff lts' ) :~: SuperRecord.RecSize lts' ) + -- - compute the index (which is the number of fields remaining, i.e. the indexing starts counting from 0 from the right) + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k rts :~: SuperRecord.RecSize lts' ) + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k ( MapDiff rts ) :~: SuperRecord.RecSize lts' ) + = SomeClassyBrushFieldsList ( proxy# :: Proxy# rts ) ( proxy# :: Proxy# ( ( k SuperRecord.:= a ) ': lts' ) ) + + + +encodeBrush :: Applicative f => JSON.Encoder f ( Brush brushParams ) +encodeBrush = JSON.Encoder.mapLikeObj \ ( BrushData { brushName, brushCode } ) -> + JSON.Encoder.atKey' "name" JSON.Encoder.text brushName + . JSON.Encoder.atKey' "code" JSON.Encoder.text brushCode + +decodeBrush + :: forall m flds. ( MonadIO m, STypesI flds ) + => UniqueSupply + -> JSON.Decoder m ( Brush flds ) +decodeBrush uniqSupply = do + brushName <- JSON.Decoder.atKey "name" JSON.Decoder.text + brushCode <- JSON.Decoder.atKey "code" JSON.Decoder.text + ( mbBrush, _ ) <- lift ( liftIO $ interpretBrush uniqSupply brushCode ) + case mbBrush of + Left err -> throwError ( JSON.ParseFailed ( "Failed to interpret brush code:\n" <> ( Text.pack $ show err ) ) ) + Right ( SomeBrushFunction ( brushFunction :: BrushFunction brushParams ) ) -> + case eqTys @flds @brushParams of + Just Refl -> pure ( BrushData { brushName, brushCode, brushFunction } ) + Nothing -> + throwError + ( JSON.ParseFailed $ + "Brush has unexpected input record type:\n\ + \Expected: " <> Text.pack ( show ( sTypesI @flds ) ) <> "\n\ + \ Actual: " <> Text.pack ( show ( sTypesI @brushParams ) ) + ) + + + +encodeStroke :: Monad f => JSON.Encoder f Stroke +encodeStroke = JSON.Encoder.mapLikeObj + \ ( Stroke + { strokeName + , strokeVisible + , strokeSpline = strokeSpline :: StrokeSpline clo ( Super.Rec pointFields ) + , strokeBrush = strokeBrush :: Brush brushFields + } + ) -> + let + closed :: Bool + closed = case ssplineType @clo of + SClosed -> True + SOpen -> False + in + JSON.Encoder.atKey' "name" JSON.Encoder.text strokeName + . JSON.Encoder.atKey' "visible" JSON.Encoder.bool strokeVisible + . JSON.Encoder.atKey' "closed" JSON.Encoder.bool closed + . JSON.Encoder.atKey' "brushFields" encodeFieldTypes ( someSTypes @brushFields ) + . JSON.Encoder.atKey' "pointFields" encodeFieldTypes ( someSTypes @pointFields ) + . JSON.Encoder.atKey' "usedFields" encodeFieldTypes ( someSTypes @( brushFields `SuperRecord.Intersect` pointFields ) ) + . JSON.Encoder.atKey' "brush" encodeBrush strokeBrush + . JSON.Encoder.atKey' "spline" ( encodeSpline encodePointData ) strokeSpline + + + +decodeStroke :: forall m. MonadIO m => UniqueSupply -> JSON.Decoder m Stroke decodeStroke uniqueSupply = do strokeName <- JSON.Decoder.atKey "name" JSON.Decoder.text strokeVisible <- JSON.Decoder.atKey "visible" JSON.Decoder.bool - strokeUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply ) - strokePoints <- JSON.Decoder.atKey "points" ( decodeSequence ( decodeStrokePoint decodePointData ) ) - pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokePoints } ) - - + strokeUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply ) + strokeClosed <- JSON.Decoder.atKey "closed" JSON.Decoder.bool + SomeBrushFields ( _ :: Proxy# brushFields ) <- JSON.Decoder.atKey "brushFields" decodeFieldTypes + SomeBrushFields ( _ :: Proxy# pointFields ) <- JSON.Decoder.atKey "pointFields" decodeFieldTypes + SomeBrushFields ( _ :: Proxy# usedFields ) <- JSON.Decoder.atKey "usedFields" decodeFieldTypes + strokeBrush <- JSON.Decoder.atKey "brush" ( decodeBrush @m @brushFields uniqueSupply ) + case proveAdapted @brushFields @pointFields @usedFields of + Nothing -> throwError ( JSON.ParseFailed "Stroke: 'usedFields' is not equal to 'brushFields `Intersect` pointFields'" ) + Just Dict -> + case strokeClosed of + True -> do + strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Closed @( PointData ( Super.Rec pointFields ) ) decodePointData ) + pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush } ) + False -> do + strokeSpline <- JSON.Decoder.atKey "spline" ( decodeSpline @Open @( PointData ( Super.Rec pointFields ) ) decodePointData ) + pure ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline, strokeBrush } ) encodeGuide :: Applicative f => JSON.Encoder f Guide -encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal, guideFocus } ) -> - JSON.Encoder.atKey' "point" ( encodePoint2D encodeDouble ) guidePoint - . JSON.Encoder.atKey' "normal" ( encodeVector2D encodeDouble ) guideNormal - . JSON.Encoder.atKey' "focus" encodeFocusState guideFocus +encodeGuide = JSON.Encoder.mapLikeObj \ ( Guide { guidePoint, guideNormal } ) -> + JSON.Encoder.atKey' "point" ( encoder @( Point2D Double ) ) guidePoint + . JSON.Encoder.atKey' "normal" ( encoder @( Vector2D Double ) ) guideNormal decodeGuide :: MonadIO m => UniqueSupply -> JSON.Decoder m Guide decodeGuide uniqueSupply = do - guidePoint <- JSON.Decoder.atKey "point" ( decodePoint2D decodeDouble ) - guideNormal <- JSON.Decoder.atKey "normal" ( decodeVector2D decodeDouble ) - guideFocus <- JSON.Decoder.atKey "focus" decodeFocusState - guideUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply ) + guidePoint <- JSON.Decoder.atKey "point" ( decoder @( Point2D Double ) ) + guideNormal <- JSON.Decoder.atKey "normal" ( decoder @( Vector2D Double ) ) + let + guideFocus :: FocusState + guideFocus = Normal + guideUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply ) pure ( Guide { guidePoint, guideNormal, guideFocus, guideUnique } ) + encodeDocumentContent :: Applicative f => JSON.Encoder f DocumentContent encodeDocumentContent = JSON.Encoder.mapLikeObj \ ( Content { guides, strokes } ) -> JSON.Encoder.atKey' "guides" ( encodeUniqueMap encodeGuide ) guides @@ -370,16 +776,188 @@ decodeDocumentContent uniqueSupply = do encodeDocument :: Applicative f => JSON.Encoder f Document encodeDocument = JSON.Encoder.mapLikeObj \ ( Document { displayName, viewportCenter, zoomFactor, documentContent } ) -> - JSON.Encoder.atKey' "name" JSON.Encoder.text displayName - . JSON.Encoder.atKey' "center" ( encodePoint2D encodeDouble ) viewportCenter - . JSON.Encoder.atKey' "zoom" encodeDouble zoomFactor - . JSON.Encoder.atKey' "content" encodeDocumentContent documentContent + JSON.Encoder.atKey' "name" JSON.Encoder.text displayName + . JSON.Encoder.atKey' "center" ( encoder @( Point2D Double ) ) viewportCenter + . JSON.Encoder.atKey' "zoom" ( encoder @Double ) zoomFactor + . JSON.Encoder.atKey' "content" encodeDocumentContent documentContent decodeDocument :: MonadIO m => UniqueSupply -> Maybe FilePath -> JSON.Decoder m Document decodeDocument uniqueSupply mbFilePath = do displayName <- JSON.Decoder.atKey "name" JSON.Decoder.text - viewportCenter <- JSON.Decoder.atKey "center" ( decodePoint2D decodeDouble ) - zoomFactor <- JSON.Decoder.atKey "zoom" decodeDouble - documentUnique <- lift ( liftIO . STM.atomically $ freshUnique uniqueSupply ) + viewportCenter <- JSON.Decoder.atKey "center" ( decoder @( Point2D Double ) ) + zoomFactor <- JSON.Decoder.atKey "zoom" ( decoder @Double ) + documentUnique <- lift ( liftIO . STM.atomically $ runReaderT freshUnique uniqueSupply ) documentContent <- JSON.Decoder.atKey "content" ( decodeDocumentContent uniqueSupply ) pure ( Document { displayName, mbFilePath, viewportCenter, zoomFactor, documentUnique, documentContent } ) + +-------------------------------------------------------------------------------- +-- Various auxiliary types. + +-- | Existential type over an allowed record field type used in brushes, such as Double and Point2D Double. +data SomeFieldSType where + SomeFieldSType + :: ( STypeI a, Show a, NFData a, Serialisable a, Interpolatable a, Typeable a ) + => Proxy# a -> SomeFieldSType + +-- | Existential type for allowed fields of a brush record. +data SomeBrushFields where + SomeBrushFields + :: forall kvs rec + . ( STypesI kvs + , rec ~ Super.Rec kvs + , Show rec, NFData rec + , Interpolatable rec + , Serialisable rec + ) + => Proxy# kvs -> SomeBrushFields + +instance Show SomeBrushFields where + show ( SomeBrushFields ( _ :: Proxy# kvs ) ) = show ( sTypesI @kvs ) + +-- | Auxiliary datatype used to create a proof that record fields have the required instances. +data BrushFieldsList kvs where + NilFields :: BrushFieldsList '[] + ConsFields + :: + ( KnownSymbol k + , Show a, NFData a, Serialisable a + , Interpolatable a + , STypesI kvs + , KnownNat ( SuperRecord.RecSize kvs ) + , SuperRecord.Has ( k SuperRecord.:= a ': kvs ) k a + ) + => Proxy# k -> Proxy# a -> BrushFieldsList kvs -> BrushFieldsList ( k SuperRecord.:= a ': kvs ) + +-- | Existential type used in the process of proving that record fields have the required instances. +data SomeBrushFieldsList where + SomeBrushFieldsList + :: ( STypesI kvs + , KnownNat ( SuperRecord.RecSize kvs ) + , KnownNat ( SuperRecord.RecSize ( MapDiff kvs ) ) + ) + => BrushFieldsList kvs -> SomeBrushFieldsList + +-- | Type used to backtrack instance resolution in the SuperRecord library, +-- to witness the required typeclass instances by induction on the record fields. +data SomeClassyBrushFieldsList rts lts where + SomeClassyBrushFieldsList + :: forall rts lts drts dlts + . ( drts ~ MapDiff rts + , dlts ~ MapDiff lts + , KnownNat ( SuperRecord.RecSize rts ) + , KnownNat ( SuperRecord.RecSize drts ) + , SuperRecord.UnsafeRecBuild rts lts ( ConstC Serialisable ) + , SuperRecord.UnsafeRecBuild drts dlts ( ConstC ( Module Double ) ) + , SuperRecord.UnsafeRecBuild drts dlts ( ConstC Monoid ) + , SuperRecord.RecApply rts lts ( ConstC Show ) + , SuperRecord.RecApply rts lts ( ConstC NFData ) + , SuperRecord.RecApply rts lts ( ConstC Serialisable ) + , SuperRecord.RecApply drts dlts ( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has drts ) ) + , SuperRecord.RecApply drts dlts ( Tuple22C ( ConstC Semigroup ) ( SuperRecord.Has drts ) ) + , SuperRecord.RecApply drts dlts ( Tuple22C ( ConstC Group ) ( SuperRecord.Has drts ) ) + , SuperRecord.RecApply drts dlts ( HasDiff' rts ) + , SuperRecord.TraversalCHelper dlts rts drts ( HasTorsor rts ) + ) + => Proxy# rts -> Proxy# lts -> SomeClassyBrushFieldsList rts lts + +proveAdapted + :: forall brushFields givenFields usedFields + . ( STypesI brushFields, STypesI givenFields, STypesI usedFields ) + => Maybe ( Dict ( Adapted brushFields givenFields usedFields ) ) +proveAdapted + | Just Dict <- proveUnsafeRecBuild @usedFields + , Just Dict <- proveRecApply @brushFields ( size @usedFields ) + , Refl <- ( unsafeCoerce Refl :: usedFields :~: ( brushFields `SuperRecord.Intersect` givenFields ) ) + = Just Dict + | otherwise + = Nothing + where + -- Provide evidence that each field of "used" appears in "given". + proveUnsafeRecBuild + :: forall lts_used + . ( STypesI lts_used ) + => Maybe ( Dict ( SuperRecord.UnsafeRecBuild usedFields lts_used ( SuperRecord.Has givenFields ) ) ) + proveUnsafeRecBuild = case sTypesI @lts_used of + STyNil -> Just Dict + sTyCons@STyCons + | ( _ :: STypes ( k SuperRecord.:= v ': tail_lts_used ) ) <- sTyCons + , SomeIndex ( _ :: Proxy# i ) <- lookupIndex @k @v @givenFields + , Just Dict <- proveUnsafeRecBuild @tail_lts_used + -> Just Dict + | otherwise + -> Nothing + + -- Provide evidence whether each field of "brush" appears in "used" or not. + -- Additionally checks that "used" is a subset of "brush". + proveRecApply + :: forall lts_brush + . ( STypesI lts_brush ) + => Int + -> Maybe ( Dict ( SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField lts_brush ) ( UseFieldsInBrush usedFields ) ) ) + proveRecApply nbUnseen = case sTypesI @lts_brush of + STyNil -> if nbUnseen < 1 then Just Dict else Nothing + sTyCons@STyCons + | ( _ :: STypes ( k SuperRecord.:= v ': tail_lts_brush ) ) <- sTyCons + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize ( MapFields UniqueField brushFields ) :~: SuperRecord.RecSize brushFields ) + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k ( MapFields UniqueField brushFields ) :~: SuperRecord.RecSize tail_lts_brush ) + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k ( MapFields UniqueField brushFields ) :~: Just ( UniqueField v ) ) + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RemoveAccessTo k ( MapFields UniqueField tail_lts_brush ) :~: MapFields UniqueField tail_lts_brush ) + -> case lookupIndex @k @v @usedFields of + SomeIndex ( _ :: Proxy# i ) -> + case proveRecApply @tail_lts_brush ( nbUnseen - 1 ) of + Just Dict -> Just Dict + Nothing -> Nothing + NoIndex -> + case proveRecApply @tail_lts_brush nbUnseen of + Just Dict -> Just Dict + Nothing -> Nothing + +data LookupResult k v kvs where + NoIndex + :: forall k v kvs + . ( SuperRecord.RecTy k kvs ~ Nothing ) + => LookupResult k v kvs + SomeIndex + :: forall k v kvs i + . ( SuperRecord.RecTy k kvs ~ Just v + , SuperRecord.RecVecIdxPos k kvs ~ i + , KnownNat i + ) + => Proxy# i -> LookupResult k v kvs + +lookupIndex + :: forall k v kvs + . ( STypesI kvs, KnownSymbol k, STypeI v ) + => LookupResult k v kvs +lookupIndex = case sTypesI @kvs of + STyNil -> NoIndex + sTyCons@STyCons + | ( _ :: STypes ( ( l SuperRecord.:= w ) ': tail_kvs ) ) <- sTyCons + -> case sameSymbol ( Proxy :: Proxy k ) ( Proxy :: Proxy l ) of + Just Refl + | Just Refl <- eqTy @v @w + , ( index_proxy :: Proxy# i ) <- ( proxy# :: Proxy# ( SuperRecord.RecSize tail_kvs ) ) + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k kvs :~: i ) + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k kvs :~: Just v ) + -> SomeIndex index_proxy + _ -> case lookupIndex @k @v @tail_kvs of + NoIndex + | Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k kvs :~: Nothing ) + -> NoIndex + SomeIndex ( px_j :: Proxy# j ) + | Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy k kvs :~: Just v ) + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos k kvs :~: j ) + -> SomeIndex px_j + +size :: forall kvs. STypesI kvs => Int +size = case sTypesI @kvs of + STyNil -> 0 + sTyCons@STyCons + | ( _ :: STypes ( head_kvs ': tail_kvs ) ) <- sTyCons + -> 1 + size @tail_kvs + +data Dict c where + Dict :: c => Dict c + +type family FromJust ( x :: Maybe a ) where + FromJust ( Just a ) = a \ No newline at end of file diff --git a/src/app/MetaBrush/Document/Serialise.hs-boot b/src/app/MetaBrush/Document/Serialise.hs-boot new file mode 100644 index 0000000..971f759 --- /dev/null +++ b/src/app/MetaBrush/Document/Serialise.hs-boot @@ -0,0 +1,15 @@ +module MetaBrush.Document.Serialise + ( Serialisable(..) ) + where + +-- waargonaut +import qualified Waargonaut.Decode as JSON + ( Decoder ) +import qualified Waargonaut.Encode as JSON + ( Encoder ) + +-------------------------------------------------------------------------------- + +class Serialisable a where + encoder :: Monad f => JSON.Encoder f a + decoder :: Monad m => JSON.Decoder m a diff --git a/src/app/MetaBrush/Document/SubdivideStroke.hs b/src/app/MetaBrush/Document/SubdivideStroke.hs index 557c684..d09c73b 100644 --- a/src/app/MetaBrush/Document/SubdivideStroke.hs +++ b/src/app/MetaBrush/Document/SubdivideStroke.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -11,6 +13,8 @@ module MetaBrush.Document.SubdivideStroke where -- base +import Data.Functor + ( ($>) ) import Data.Semigroup ( Min(..), Arg(..) ) @@ -21,6 +25,8 @@ import Data.Act -- containers import Data.Sequence ( Seq(..) ) +import qualified Data.Sequence as Seq + ( singleton ) -- generic-lens import Data.Generics.Product.Fields @@ -43,22 +49,29 @@ import qualified Math.Bezier.Cubic as Cubic ( Bezier(..), closestPoint, subdivide ) import qualified Math.Bezier.Quadratic as Quadratic ( Bezier(..), closestPoint, subdivide ) +import Math.Bezier.Spline + ( Spline(..), SplineType(..), Curve(..), Curves(..), NextPoint(..) + , KnownSplineType(bifoldSpline, adjustSplineType) + ) import Math.Bezier.Stroke - ( StrokePoint(..) ) + ( CachedStroke, discardCache ) import Math.Module - ( quadrance, closestPointToSegment ) + ( lerp, quadrance, closestPointOnSegment ) import Math.Vector2D - ( Point2D(..), Vector2D(..) ) + ( Point2D(..), Vector2D(..), Segment(..) ) import MetaBrush.Document - ( Document(..), Stroke(..) ) -import MetaBrush.UI.ToolBar - ( Mode(..) ) + ( Document(..), Stroke(..), StrokeSpline + , PointData(..), DiffPointData(..) + , coords, _strokeSpline + ) +import MetaBrush.MetaParameter.Interpolation + ( Interpolatable(Diff) ) -------------------------------------------------------------------------------- -- | Subdivide a path at the given center, provided a path indeed lies there. -subdivide :: Mode -> Point2D Double -> Document -> Maybe ( Document, Text ) -subdivide mode c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc +subdivide :: Point2D Double -> Document -> Maybe ( Document, Text ) +subdivide c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdivLoc where updatedDoc :: Document mbSubdivLoc :: Maybe Text @@ -69,95 +82,87 @@ subdivide mode c doc@( Document { zoomFactor } ) = ( updatedDoc , ) <$> mbSubdiv doc updateStroke :: Stroke -> State ( Maybe Text ) Stroke - updateStroke stroke@( Stroke { strokeVisible, strokeName } ) - | Brush <- mode - = ( field' @"strokePoints" . traverse ) - ( \ spt -> - ( field' @"pointData" . field' @"brushShape" ) - ( subdivideStroke strokeVisible ( "brush shape of stroke " <> strokeName ) ( MkVector2D $ coords spt ) ) - spt - ) - stroke - | otherwise - = ( field' @"strokePoints" ) - ( subdivideStroke strokeVisible ( "stroke " <> strokeName ) ( Vector2D 0 0 ) ) - stroke + updateStroke stroke@( Stroke { strokeVisible, strokeName } ) = _strokeSpline updateSpline stroke - subdivideStroke - :: forall pt - . Show pt - => Bool - -> Text - -> Vector2D Double - -> Seq ( StrokePoint pt ) - -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) ) - subdivideStroke False _ _ pts = pure pts - subdivideStroke True _ _ Empty = pure Empty - subdivideStroke True txt offset ( spt :<| spts ) = go spt spts where - go :: StrokePoint pt -> Seq ( StrokePoint pt ) -> State ( Maybe Text ) ( Seq ( StrokePoint pt ) ) - go sp0 Empty = pure ( sp0 :<| Empty ) - -- Line. - go sp0 ( sp1 :<| sps ) - | PathPoint {} <- sp1 - , let - p0, p1, s :: Point2D Double - t :: Double - p0 = coords sp0 - p1 = coords sp1 - ( t, s ) = closestPointToSegment @( Vector2D Double ) ( invert offset • c ) p0 p1 - sqDist :: Double - sqDist = quadrance @( Vector2D Double ) c ( offset • s ) - = if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 - then do - put ( Just txt ) - -- TODO: interpolate brush instead of using these arbitrary intermediate points - pure ( sp0 :<| sp0 { coords = s } :<| sp1 :<| sps ) - else ( sp0 :<| ) <$> go sp1 sps - -- Quadratic Bézier curve. - go sp0 ( sp1 :<| sp2 :<| sps ) - | ControlPoint {} <- sp1 - , PathPoint {} <- sp2 - , let - p0, p1, p2, s :: Point2D Double - p0 = coords sp0 - p1 = coords sp1 - p2 = coords sp2 - bez :: Quadratic.Bezier ( Point2D Double ) - bez = Quadratic.Bezier {..} - sqDist :: Double - Min ( Arg sqDist ( t, s ) ) - = Quadratic.closestPoint @( Vector2D Double ) bez ( invert offset • c ) - = if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 - then case Quadratic.subdivide @( Vector2D Double ) bez t of - ( Quadratic.Bezier _ q1 _, Quadratic.Bezier _ r1 _ ) -> do - put ( Just txt ) - -- TODO: interpolate brush instead of using these arbitrary intermediate points - pure ( sp0 :<| sp1 { coords = q1 } :<| sp2 { coords = s } :<| sp1 { coords = r1 } :<| sp2 :<| sps ) - else ( ( sp0 :<| ) . ( sp1 :<| ) ) <$> go sp2 sps - -- Cubic Bézier curve. - go sp0 ( sp1 :<| sp2 :<| sp3 :<| sps ) - | ControlPoint {} <- sp1 - , ControlPoint {} <- sp2 - , PathPoint {} <- sp3 - , let - p0, p1, p2, p3, s :: Point2D Double - p0 = coords sp0 - p1 = coords sp1 - p2 = coords sp2 - p3 = coords sp3 - bez :: Cubic.Bezier ( Point2D Double ) - bez = Cubic.Bezier {..} - Min ( Arg sqDist ( t, s ) ) - = Cubic.closestPoint @( Vector2D Double ) bez ( invert offset • c ) - = if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 - then case Cubic.subdivide @( Vector2D Double ) bez t of - ( Cubic.Bezier _ q1 q2 _, Cubic.Bezier _ r1 r2 _ ) -> do - put ( Just txt ) - -- TODO: interpolate brush instead of using these arbitrary intermediate points - pure - ( sp0 :<| sp1 { coords = q1 } :<| sp1 { coords = q2 } :<| sp3 { coords = s } - :<| sp2 { coords = r1 } :<| sp2 { coords = r2 } :<| sp3 :<| sps - ) - else ( ( sp0 :<| ) . ( sp1 :<| ) . ( sp2 :<| ) ) <$> go sp3 sps - go sp0 sps = error ( "subdivideStroke: unrecognised stroke type\n" <> show ( sp0 :<| sps ) ) + updateSpline + :: forall clo brushParams + . ( KnownSplineType clo, Interpolatable brushParams ) + => StrokeSpline clo brushParams -> State ( Maybe Text ) ( StrokeSpline clo brushParams ) + updateSpline spline@( Spline { splineStart } ) + | not strokeVisible + = pure spline + | otherwise + = fmap ( \ curves -> adjustSplineType @clo $ Spline { splineStart, splineCurves = OpenCurves curves } ) + $ bifoldSpline + ( updateCurve ( "stroke " <> strokeName ) ( Vector2D 0 0 ) ) + ( const $ pure Empty ) + ( adjustSplineType @Open spline ) + + where + updateCurve + :: Text + -> Vector2D Double + -> PointData brushParams + -> Curve Open CachedStroke ( PointData brushParams ) + -> State ( Maybe Text ) + ( Seq ( Curve Open CachedStroke ( PointData brushParams ) ) ) + updateCurve txt offset sp0 curve = case curve of + line@( LineTo ( NextPoint sp1 ) dat ) -> + let + p0, p1, s :: Point2D Double + t :: Double + p0 = coords sp0 + p1 = coords sp1 + ( t, s ) = closestPointOnSegment @( Vector2D Double ) ( invert offset • c ) ( Segment p0 p1 ) + sqDist :: Double + sqDist = quadrance @( Vector2D Double ) c ( offset • s ) + in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 + then + let + subdiv :: PointData brushParams + subdiv = lerp @( DiffPointData ( Diff brushParams ) ) t sp0 sp1 + dat' :: CachedStroke + dat' = discardCache dat + in put ( Just txt ) $> ( LineTo ( NextPoint subdiv ) dat' :<| LineTo ( NextPoint sp1 ) dat' :<| Empty ) + else pure $ Seq.singleton line + bez2@( Bezier2To sp1 ( NextPoint sp2 ) dat ) -> + let + p0, p1, p2 :: Point2D Double + p0 = coords sp0 + p1 = coords sp1 + p2 = coords sp2 + sqDist :: Double + Min ( Arg sqDist ( t, _ ) ) + = Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier {..} ) ( invert offset • c ) + in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 + then case Quadratic.subdivide @( DiffPointData ( Diff brushParams ) ) ( Quadratic.Bezier sp0 sp1 sp2 ) t of + ( Quadratic.Bezier _ q1 subdiv, Quadratic.Bezier _ r1 _ ) -> + let + dat' :: CachedStroke + dat' = discardCache dat + bez_start, bez_end :: Curve Open CachedStroke ( PointData brushParams ) + bez_start = Bezier2To q1 ( NextPoint subdiv ) dat' + bez_end = Bezier2To r1 ( NextPoint sp2 ) dat' + in put ( Just txt ) $> ( bez_start :<| bez_end :<| Empty ) + else pure $ Seq.singleton bez2 + bez3@( Bezier3To sp1 sp2 ( NextPoint sp3 ) dat ) -> + let + p0, p1, p2, p3 :: Point2D Double + p0 = coords sp0 + p1 = coords sp1 + p2 = coords sp2 + p3 = coords sp3 + Min ( Arg sqDist ( t, _ ) ) + = Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier {..} ) ( invert offset • c ) + in if t > 0 && t < 1 && sqDist * zoomFactor ^ ( 2 :: Int ) < 16 + then case Cubic.subdivide @( DiffPointData ( Diff brushParams ) ) ( Cubic.Bezier sp0 sp1 sp2 sp3 ) t of + ( Cubic.Bezier _ q1 q2 subdiv, Cubic.Bezier _ r1 r2 _ ) -> + let + dat' :: CachedStroke + dat' = discardCache dat + bez_start, bez_end :: Curve Open CachedStroke ( PointData brushParams ) + bez_start = Bezier3To q1 q2 ( NextPoint subdiv ) dat' + bez_end = Bezier3To r1 r2 ( NextPoint sp2 ) dat' + in put ( Just txt ) $> ( bez_start :<| bez_end :<| Empty ) + else pure $ Seq.singleton bez3 diff --git a/src/app/MetaBrush/Document/Update.hs b/src/app/MetaBrush/Document/Update.hs index d9c4e94..27c3979 100644 --- a/src/app/MetaBrush/Document/Update.hs +++ b/src/app/MetaBrush/Document/Update.hs @@ -145,7 +145,7 @@ instance DocumentModification DocModification where -- -- Does nothing if no document is currently active. modifyingCurrentDocument :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO () -modifyingCurrentDocument uiElts@( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) f = do +modifyingCurrentDocument uiElts@( UIElements { .. } ) vars@( Variables {..} ) f = do mbAction <- STM.atomically . runMaybeT $ do unique <- MaybeT ( STM.readTVar activeDocumentTVar ) oldDoc <- MaybeT ( fmap present . Map.lookup unique <$> STM.readTVar openDocumentsTVar ) diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index f9a244a..0b8e797 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -109,7 +109,7 @@ handleMouseButtonRelease elts vars eventOrigin mouseReleaseEvent = do adjustMousePosition :: Viewport -> ActionOrigin -> Point2D Double -> IO ( Point2D Double ) adjustMousePosition _ ViewportOrigin pt = pure pt -adjustMousePosition ( Viewport { .. } ) ( RulerOrigin ruler ) ( Point2D x y ) = +adjustMousePosition ( Viewport {..} ) ( RulerOrigin ruler ) ( Point2D x y ) = case ruler of RulerCorner -> do dx <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth rulerCornerDrawingArea diff --git a/src/app/MetaBrush/MetaParameter/AST.hs b/src/app/MetaBrush/MetaParameter/AST.hs new file mode 100644 index 0000000..0c4d34b --- /dev/null +++ b/src/app/MetaBrush/MetaParameter/AST.hs @@ -0,0 +1,625 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + +module MetaBrush.MetaParameter.AST + ( Span(..), Located(.., Location) + , Term(..), Pat(..), Decl(..) + , toTreeArgsTerm, toTreeTerm, toTreePat, toTreeDecl + , termSpan + , TypedTerm(..), TypedPat(..) + , SType(..), STypeI(..), SomeSType(..) + , STypes(..), STypesI(..), someSTypes + , eqSTy, eqTy, eqSTys, eqTys + , Pass(..), Name, UniqueName(..), Loc + , Ext_With(..), X_With(..) + , MapFields, IsUniqueTerm, IsUniqueTerm2, UseFieldsInBrush + , UniqueField(..), GetUniqueField, UniqueTerm, GetUniqueTerm + , Adapted, AdaptableFunction(..), BrushFunction + , X_Ext(..) + , Expr, EPat, RnExpr, RnPat + ) + where + +-- base +import Data.Functor.Compose + ( Compose(..) ) +import Data.Functor.Identity + ( Identity(..) ) +import Data.Kind + ( Type, Constraint ) +import Data.Proxy + ( Proxy(..) ) +import Data.Type.Equality + ( (:~:)(Refl) ) +import GHC.Exts + ( Proxy#, proxy# ) +import GHC.Generics + ( Generic ) +import GHC.TypeLits + ( Symbol, KnownSymbol, symbolVal', sameSymbol ) +import GHC.TypeNats + ( KnownNat ) + +-- containers +import Data.Tree + ( Tree(Node) ) + +-- deepseq +import Control.DeepSeq + ( NFData(..) ) + +-- superrecord +import qualified SuperRecord as Super + ( Rec ) +import qualified SuperRecord + ( (:=), RecApply, UnsafeRecBuild, Has, TraversalC + , Intersect, Lookup, RecTy, RecSize, reflectRec + ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + ( pack ) + +-- MetaBrush +import Math.Vector2D + ( Point2D(..), Segment(..) ) +import qualified Math.Bezier.Cubic as Cubic + ( Bezier(..) ) +import qualified Math.Bezier.Quadratic as Quadratic + ( Bezier(..) ) +import Math.Bezier.Spline + ( Spline(..), SplinePts, SplineType(..) + , SSplineType(..), SplineTypeI(ssplineType), KnownSplineType(bifoldSpline) + , Curve(..), NextPoint(..) + ) +import MetaBrush.Unique + ( Unique ) + +-------------------------------------------------------------------------------- + +--------------------- +-- Source locations. + +data Span = Span + { startRow :: !Int + , startCol :: !Int + , endRow :: !Int + , endCol :: !Int + } deriving stock ( Eq, Ord ) +instance Show Span where + show ( Span sr sc er ec ) = + "l" <> show sr <> "c" <> show sc <> " -- " <> "l" <> show er <> "c" <> show ec +instance Semigroup Span where + Span 0 0 0 0 <> s = s + s <> Span 0 0 0 0 = s + Span sr1 sc1 er1 ec1 <> Span sr2 sc2 er2 ec2 + = case ( compare ( sr1, sc1 ) ( sr2, sc2 ), compare ( er1, ec1 ) ( er2, ec2 ) ) of + ( LT, LT ) -> Span sr1 sc1 er2 ec2 + ( LT, _ ) -> Span sr1 sc1 er1 ec1 + ( _ , LT ) -> Span sr2 sc2 er2 ec2 + _ -> Span sr2 sc2 er1 ec1 +instance Monoid Span where + mempty = Span 0 0 0 0 + +data Located a = + Located + { location :: !Span + , located :: !a + } + deriving stock Show + +{-# COMPLETE Location #-} +pattern Location :: Span -> Located () +pattern Location loc = Located loc () + +---------- +-- Types. + +data SType ( ty :: Type ) where + SFunTy :: ( STypeI a, STypeI b ) => SType ( a -> b ) + STyBool :: SType Bool + STyDouble :: SType Double + STyPoint :: STypeI a => SType ( Point2D a ) + STyLine :: STypeI a => SType ( Segment a ) + STyBez2 :: STypeI a => SType ( Quadratic.Bezier a ) + STyBez3 :: STypeI a => SType ( Cubic.Bezier a ) + STySpline :: KnownSplineType clo => SType ( SplinePts clo ) + STyWithFn :: ( STypesI kvs, STypeI a ) => SType ( AdaptableFunction kvs a ) + -- reminder: update eqSTy when adding new constructors + +deriving stock instance Show ( SType ty ) + +class STypeI ty where + sTypeI :: SType ty +instance ( STypeI a, STypeI b ) => STypeI ( a -> b ) where + sTypeI = SFunTy +instance STypeI Bool where + sTypeI = STyBool +instance STypeI Double where + sTypeI = STyDouble +instance STypeI a => STypeI ( Point2D a ) where + sTypeI = STyPoint +instance STypeI a => STypeI ( Segment a ) where + sTypeI = STyLine +instance STypeI a => STypeI ( Quadratic.Bezier a ) where + sTypeI = STyBez2 +instance STypeI a => STypeI ( Cubic.Bezier a ) where + sTypeI = STyBez3 +instance KnownSplineType clo => STypeI ( SplinePts clo ) where + sTypeI = STySpline +instance ( STypesI kvs, STypeI a ) => STypeI ( AdaptableFunction kvs a ) where + sTypeI = STyWithFn + +data STypes ( kvs :: [ Type ] ) where + STyNil :: STypes '[] + STyCons :: ( kv ~ ( k SuperRecord.:= v ), KnownSymbol k, STypeI v, STypesI kvs ) => STypes ( kv ': kvs ) +deriving stock instance Show ( STypes kvs ) + +class KnownNat ( SuperRecord.RecSize kvs ) => STypesI kvs where + sTypesI :: STypes kvs + +instance STypesI '[] where + sTypesI = STyNil +-- Warning: this instance is somewhat overly general as it doesn't check that the names are ordered. +instance ( kv ~ ( k SuperRecord.:= v ), KnownSymbol k, STypeI v, STypesI kvs ) => STypesI ( kv ': kvs ) where + sTypesI = STyCons + +data SomeSType where + SomeSType :: STypeI a => Proxy# a -> SomeSType + +instance Show SomeSType where + show ( SomeSType ( _ :: Proxy# a ) ) = show ( sTypeI @a ) + +eqSTy :: SType a -> SType b -> Maybe ( a :~: b ) +eqSTy sTy_a@SFunTy sTy_b@SFunTy + | ( _ :: SType ( a1 -> b1 ) ) <- sTy_a + , ( _ :: SType ( a2 -> b2 ) ) <- sTy_b + , Just Refl <- eqTy @a1 @a2 + , Just Refl <- eqTy @b1 @b2 + = Just Refl +eqSTy STyBool STyBool = Just Refl +eqSTy STyDouble STyDouble = Just Refl +eqSTy sTy_a@STyPoint sTy_b@STyPoint + | ( _ :: SType ( Point2D l ) ) <- sTy_a + , ( _ :: SType ( Point2D r ) ) <- sTy_b + , Just Refl <- eqTy @l @r + = Just Refl +eqSTy sTy_a@STyLine sTy_b@STyLine + | ( _ :: SType ( Segment l ) ) <- sTy_a + , ( _ :: SType ( Segment r ) ) <- sTy_b + , Just Refl <- eqTy @l @r + = Just Refl +eqSTy sTy_a@STyBez2 sTy_b@STyBez2 + | ( _ :: SType ( Quadratic.Bezier l ) ) <- sTy_a + , ( _ :: SType ( Quadratic.Bezier r ) ) <- sTy_b + , Just Refl <- eqTy @l @r + = Just Refl +eqSTy sTy_a@STyBez3 sTy_b@STyBez3 + | ( _ :: SType ( Cubic.Bezier l ) ) <- sTy_a + , ( _ :: SType ( Cubic.Bezier r ) ) <- sTy_b + , Just Refl <- eqTy @l @r + = Just Refl +eqSTy sTy_a@STySpline sTy_b@STySpline + | ( _ :: SType ( SplinePts clo1 ) ) <- sTy_a + , ( _ :: SType ( SplinePts clo2 ) ) <- sTy_b + = case ( ssplineType @clo1, ssplineType @clo2 ) of + ( SOpen , SOpen ) -> Just Refl + ( SClosed, SClosed ) -> Just Refl + _ -> Nothing +eqSTy sTy_a@STyWithFn sTy_b@STyWithFn + | ( _ :: SType ( AdaptableFunction kvs a ) ) <- sTy_a + , ( _ :: SType ( AdaptableFunction lvs b ) ) <- sTy_b + , Just Refl <- eqTys @kvs @lvs + , Just Refl <- eqTy @a @b + = Just Refl +eqSTy _ _ = Nothing + +eqTy :: forall a b. ( STypeI a, STypeI b ) => Maybe ( a :~: b ) +eqTy = eqSTy ( sTypeI @a ) ( sTypeI @b ) + +eqSTys :: STypes as -> STypes bs -> Maybe ( as :~: bs ) +eqSTys STyNil STyNil = Just Refl +eqSTys sTyCons1@STyCons sTyCons2@STyCons + | ( _ :: STypes ( ( l1 SuperRecord.:= v1 ) ': as' ) ) <- sTyCons1 + , ( _ :: STypes ( ( l2 SuperRecord.:= v2 ) ': bs' ) ) <- sTyCons2 + , Just Refl <- sameSymbol ( Proxy :: Proxy l1 ) ( Proxy :: Proxy l2 ) + , Just Refl <- eqTy @v1 @v2 + , Just Refl <- eqTys @as' @bs' + = Just Refl +eqSTys _ _ = Nothing + +eqTys :: forall as bs. ( STypesI as, STypesI bs ) => Maybe ( as :~: bs ) +eqTys = eqSTys ( sTypesI @as ) ( sTypesI @bs ) + +someSTypes :: forall kvs. STypesI kvs => [ ( Text, SomeSType ) ] +someSTypes = go ( sTypesI @kvs ) + where + go :: forall lvs. STypes lvs -> [ ( Text, SomeSType ) ] + go STyNil = [] + go sTyCons@STyCons + | ( _ :: STypes ( ( l SuperRecord.:= v ) ': lvs' ) ) <- sTyCons + = ( Text.pack $ symbolVal' ( proxy# :: Proxy# l ), SomeSType ( proxy# :: Proxy# v ) ) + : go ( sTypesI @lvs' ) + +------------------------------------------------ +-- AST. -- +---------- + +data Pass = P | Rn | Tc + deriving stock Show + +type family K ( p :: Pass ) :: Type where + K P = () + K Rn = () + K Tc = Type + +type family Ks ( p :: Pass ) :: Type where + Ks P = () + Ks Rn = () + Ks Tc = [Type] + +type family T ( p :: Pass ) ( t :: Type ) :: K p where + T P _ = '() + T Rn _ = '() + T Tc a = a + +type family Ts ( p :: Pass ) ( as :: [ Type ] ) :: Ks p where + Ts P _ = '() + Ts Rn _ = '() + Ts Tc '[] = '[] + Ts Tc ( a ': as ) = T Tc a ': Ts Tc as + +type family R ( p :: Pass ) ( kvs :: [ Type ] ) :: Ks p where + R P _ = '() + R Rn _ = '() + R Tc kvs = kvs + +type family C ( p :: Pass ) ( ct :: Constraint ) :: Constraint where + C P _ = () + C Rn _ = () + C Tc ct = ct + +-- C p ct: constraint for which evidence is generated at Tc stage +-- ct: constraint for which evidence is provided from the start + +infixl 9 :$ +data Term ( p :: Pass ) ( kind :: K p ) where + (:$) :: C p ( STypeI a ) + => Term p ( T p ( a -> b ) ) + -> Term p ( T p a ) + -> Term p ( T p b ) + Var :: { varName :: !( Loc p ( Name p ) ) } + -> Term p ( T p a ) + Let :: { let_loc :: ![ Loc p () ] + , let_decls :: ![ Decl p ] + , let_body :: !( Term p ( T p a ) ) + } + -> Term p ( T p a ) + With :: forall ( p :: Pass ) ( kvs :: [ Type ] ) ( a :: Type ) + . C p ( STypeI a ) + => ![ Loc p () ] + -> !( X_With p ( R p kvs ) ) + -> ![ Term p ( T p Bool ) ] + -> !( Term p ( T p a ) ) + -> Term p ( T p ( AdaptableFunction kvs a ) ) + Lit :: ( Show a, STypeI a ) + => !( Loc p ( Maybe Text ) ) + -> !a + -> Term p ( T p a ) + Op :: STypeI a + => ![ Loc p () ] -> !Text -> a -> Term p ( T p a ) + Point :: ( C p ( STypeI a ), pt ~ Term p ( T p ( Point2D a ) ) ) + => ![ Loc p () ] + -> !( Term p ( T p a ) ) -> !( Term p ( T p a ) ) + -> Term p ( T p ( Point2D a ) ) + Line :: ( C p ( STypeI a ), pt ~ Term p ( T p a ) ) + => ![ Loc p () ] + -> !pt -> !pt + -> Term p ( T p ( Segment a ) ) + Bez2 :: ( C p ( STypeI a ), pt ~ Term p ( T p a ) ) + => ![ Loc p () ] + -> !pt -> !pt -> !pt + -> Term p ( T p ( Quadratic.Bezier a ) ) + Bez3 :: ( C p ( STypeI a ), pt ~ Term p ( T p a ) ) + => ![ Loc p () ] + -> !pt -> !pt -> !pt -> !pt + -> Term p ( T p ( Cubic.Bezier a ) ) + PolyBez + :: ( KnownSplineType clo, C p ( STypeI a ) ) + => ![ Loc p () ] + -> Spline clo [ Loc p () ] ( Term p ( T p a ) ) + -> Term p ( T p ( Spline clo () a ) ) + CExt :: !( X_Ext p ( T p a ) ) -> Term p ( T p a ) + +data Decl ( p :: Pass ) where + Decl :: C p ( STypeI a ) + => !( Loc p () ) + -> !( Pat p ( T p a ) ) -> !( Term p ( T p a ) ) + -> Decl p + +data Pat ( p :: Pass ) ( kind :: K p ) where + PName :: { patName :: !( Loc p ( Name p ) ) } + -> Pat p ( T p a ) + PPoint :: ![ Loc p () ] + -> !( Pat p ( T p a ) ) + -> !( Pat p ( T p a ) ) + -> Pat p ( T p ( Point2D a ) ) + PWild :: { wildName :: !( Loc p Text ) } + -> Pat p ( T p a ) + AsPat :: { atSymbol :: !( Loc p () ) + , asPatName :: !( Loc p ( Name p ) ) + , asPat :: !( Pat p ( T p a ) ) + } + -> Pat p ( T p a ) + +type Expr = Term P '() +type EPat = Pat P '() + +type RnExpr = Term Rn '() +type RnPat = Pat Rn '() + +data TypedTerm where + TypedTerm :: STypeI a => Term Tc a -> TypedTerm + +data TypedPat where + TypedPat :: STypeI a => Pat Tc a -> TypedPat + +--------------------- +-- Extension fields + +data UniqueName + = UniqueName + { occName :: !Text + , nameUnique :: !Unique + } + deriving stock ( Show, Generic ) + +type family Name ( p :: Pass ) :: Type +type instance Name P = Text +type instance Name Rn = UniqueName +type instance Name Tc = UniqueName + +type family Loc ( p :: Pass ) ( a :: Type ) :: Type +type instance Loc p a = Located a + +class Ext_With ( p :: Pass ) ( kvs :: Ks p ) where + data family X_With p kvs :: Type + toTreeWith :: forall ( lvs :: Ks p ). Ext_With p lvs => X_With p kvs -> [ Tree String ] + +instance Ext_With P kvs where + newtype X_With P _ = P_With [ Decl P ] + toTreeWith ( P_With decls ) = map toTreeDecl decls + +instance Ext_With Rn kvs where + newtype X_With Rn _ = Rn_With [ Decl Rn ] + toTreeWith ( Rn_With decls ) = map toTreeDecl decls + + +instance Ext_With Tc kvs where + data X_With Tc kvs where + Tc_With + :: ( ts ~ MapFields UniqueTerm kvs + , fs ~ MapFields UniqueField kvs + , SuperRecord.RecApply ts ts IsUniqueTerm + , SuperRecord.TraversalC IsUniqueTerm2 ts fs + ) + => Super.Rec ts -> X_With Tc kvs + toTreeWith ( Tc_With decls ) = + SuperRecord.reflectRec @IsUniqueTerm + ( \ _ ( Compose ( UniqueField { uniqueField = a } ) ) -> toTreeTerm @Tc a ) + decls + +data UniqueField a = + UniqueField { uniqueFieldName :: !UniqueName, uniqueField :: !a } + +type UniqueTerm = Compose UniqueField ( Term Tc ) + +type family MapFields ( f :: Type -> Type ) ( kvs :: [ Type ] ) = ( r :: [ Type ] ) | r -> kvs where + MapFields _ '[] = '[] + MapFields f ( ( k SuperRecord.:= v ) ': kvs ) = ( k SuperRecord.:= f v ) ': MapFields f kvs + + +type family GetUniqueField ( uniqueField :: Type ) :: Type where + GetUniqueField ( UniqueField a ) = a +type family GetUniqueTerm ( uniqueTerm :: Type ) :: Type where + GetUniqueTerm ( Compose UniqueField ( Term Tc ) a ) = a + +class ( STypeI ( GetUniqueTerm t ) + , t ~ UniqueTerm ( GetUniqueTerm t ) + ) + => IsUniqueTerm ( k :: Symbol ) t + where +instance ( STypeI ( GetUniqueTerm t ) + , t ~ UniqueTerm ( GetUniqueTerm t ) + ) + => IsUniqueTerm ( k :: Symbol ) t + where + +class ( IsUniqueTerm k t + , a ~ UniqueField ( GetUniqueField a ) + , GetUniqueTerm t ~ GetUniqueField a + ) + => IsUniqueTerm2 k t a + where +instance ( IsUniqueTerm k t + , a ~ UniqueField ( GetUniqueField a ) + , GetUniqueTerm t ~ GetUniqueField a + ) + => IsUniqueTerm2 k t a + where + +class ( STypeI ( GetUniqueField t ) + , t ~ UniqueField ( GetUniqueField t ) + , SuperRecord.Lookup kvs k ( GetUniqueField t ) + ( SuperRecord.RecTy k kvs ) + ) + => UseFieldsInBrush ( kvs :: [ Type ] ) ( k :: Symbol ) t +instance ( STypeI ( GetUniqueField t ) + , t ~ UniqueField ( GetUniqueField t ) + , SuperRecord.Lookup kvs k ( GetUniqueField t ) + ( SuperRecord.RecTy k kvs ) + ) + => UseFieldsInBrush ( kvs :: [ Type ] ) ( k :: Symbol ) t + +class ( usedFields ~ ( brushFields `SuperRecord.Intersect` givenFields ) + , SuperRecord.UnsafeRecBuild usedFields usedFields ( SuperRecord.Has givenFields ) + , SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField brushFields ) + ( UseFieldsInBrush usedFields ) + ) + => Adapted brushFields givenFields usedFields | givenFields brushFields -> usedFields +instance ( usedFields ~ ( brushFields `SuperRecord.Intersect` givenFields ) + , SuperRecord.UnsafeRecBuild usedFields usedFields ( SuperRecord.Has givenFields ) + , SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField brushFields ) + ( UseFieldsInBrush usedFields ) + ) + => Adapted brushFields givenFields usedFields + +type BrushFunction brushFields = AdaptableFunction brushFields ( SplinePts Closed ) +newtype AdaptableFunction brushFields a + = AdaptableFunction + ( forall givenFields usedFields + . Adapted brushFields givenFields usedFields + => ( Super.Rec givenFields -> Super.Rec usedFields + , Super.Rec usedFields -> a + ) + ) + + +class Ext ( p :: Pass ) ( a :: K p ) where + data family X_Ext ( p :: Pass ) a :: Type + toTreeArgsExt :: [ Tree String ] -> X_Ext p a -> Tree String + +instance Ext P a where + data instance X_Ext P a + toTreeArgsExt _ x = case x of {} + +instance Ext Rn a where + data instance X_Ext Rn a + toTreeArgsExt _ x = case x of {} + +instance Ext Tc a where + newtype instance X_Ext Tc a = Val a + deriving stock ( Generic, Show ) + deriving newtype NFData + toTreeArgsExt as ( Val _ ) = Node "Value..." as + + +------------------------------------------------ +-- Printing AST. -- +------------------- + +termSpan :: Term p a -> Span +termSpan ( f :$ a ) = termSpan f <> termSpan a +termSpan ( Var ( Located l _ ) ) = l +termSpan ( Let locs _ body ) = foldMap ( \ ( Located l _ ) -> l ) locs <> termSpan body +termSpan ( With locs _ _ body ) = foldMap ( \ ( Located l _ ) -> l ) locs <> termSpan body +termSpan ( Lit ( Located l _ ) _ ) = l +termSpan ( Op locs _ _ ) = foldMap ( \ ( Located l _ ) -> l ) locs +termSpan ( Point locs x y ) = foldMap ( \ ( Located l _ ) -> l ) locs <> termSpan x <> termSpan y +termSpan ( Line locs _ _ ) = foldMap ( \ ( Located l _ ) -> l ) locs +termSpan ( Bez2 locs _ _ _ ) = foldMap ( \ ( Located l _ ) -> l ) locs +termSpan ( Bez3 locs _ _ _ _ ) = foldMap ( \ ( Located l _ ) -> l ) locs +termSpan ( PolyBez locs _ ) = foldMap ( \ ( Located l _ ) -> l ) locs +termSpan ( CExt _ ) = mempty + + +toTreeTerm + :: forall ( p :: Pass ) ( a :: K p ) + . ( Show ( Name p ), forall x. Ext p x, forall kvs. Ext_With p kvs ) + => Term p a + -> Tree String +toTreeTerm = toTreeArgsTerm @p @a [] + +toTreeArgsTerm + :: forall ( p :: Pass ) ( a :: K p ) + . ( Show ( Name p ), forall x. Ext p x, forall (kvs :: Ks p). Ext_With p kvs ) + => [ Tree String ] + -> Term p a + -> Tree String +toTreeArgsTerm as ( f :$ a ) = toTreeArgsTerm ( toTreeTerm a : as ) f +toTreeArgsTerm as ( Op _ nm _ ) = Node ( "Op " <> show nm ) as +toTreeArgsTerm as ( Var nm ) = Node ( "Var " <> show nm ) as +toTreeArgsTerm as ( Lit loc a ) = + case loc of + Located l Nothing -> Node ( "Lit " <> show ( Located l a ) ) as + Located l ( Just nm ) -> Node ( "Lit " <> show ( Located l nm ) ) as +toTreeArgsTerm as ( Point _ p1 p2 ) = Node "(,)" ( toTreeTerm p1 : toTreeTerm p2 : as ) +toTreeArgsTerm as ( Line _ p0 p1 ) = Node "Line" ( toTreeTerm p0 : toTreeTerm p1 : as ) +toTreeArgsTerm as ( Bez2 _ p0 p1 p2 ) = Node "Bez2" ( toTreeTerm p0 : toTreeTerm p1 : toTreeTerm p2 : as ) +toTreeArgsTerm as ( Bez3 _ p0 p1 p2 p3 ) = Node "Bez3" ( toTreeTerm p0 : toTreeTerm p1 : toTreeTerm p2 : toTreeTerm p3 : as ) +toTreeArgsTerm as ( PolyBez _ spline ) = Node "Spline" + ( ( runIdentity + $ ( bifoldSpline @_ @Identity @[ Tree String ] @_ ) + ( const ( toTreeCurve @p ) ) + ( Identity . (:[]) . toTreeTerm ) + spline + ) + <> as + ) +toTreeArgsTerm as ( Let _ ds a ) = + Node "Let" + ( Node "Decls" ( map ( toTreeDecl @p ) ds ) + : Node "In" [ toTreeTerm a ] + : as + ) +toTreeArgsTerm as ( With _ args conds body ) = + Node "With" + ( Node "Params" ( toTreeWith @p args ) + : Node "Conds" ( map toTreeTerm conds ) + : Node "Define" [ toTreeTerm body ] + : as + ) +toTreeArgsTerm as ( CExt ext ) = toTreeArgsExt as ext + +toTreeDecl + :: forall ( p :: Pass ) + . ( Show ( Name p ), forall x. Ext p x, forall (kvs :: Ks p). Ext_With p kvs ) + => Decl p + -> Tree String +toTreeDecl ( Decl _ lhs rhs ) = Node "(=)" [ toTreePat lhs, toTreeTerm rhs ] + +toTreePat :: Show ( Name p ) => Pat p a -> Tree String +toTreePat ( PName nm ) = Node ( show nm ) [ ] +toTreePat ( PPoint _ pl pr ) = Node "(_,_)" [ toTreePat pl, toTreePat pr ] +toTreePat ( PWild nm ) = Node ( show nm ) [ ] +toTreePat ( AsPat _ nm pat ) = Node "(@)" [ Node ( show nm ) [], toTreePat pat ] + +toTreeCurve + :: forall ( p :: Pass ) ( clo :: SplineType ) ( crvData :: Type ) ( a :: K p ) + . ( SplineTypeI clo, Show ( Name p ), forall x. Ext p x, forall (kvs :: Ks p). Ext_With p kvs ) + => Curve clo crvData ( Term p a ) + -> Identity [ Tree String ] +toTreeCurve curve = Identity . (:[]) $ case ssplineType @clo of + SOpen -> case curve of + ( LineTo ( NextPoint p1 ) _ ) -> Node "LineTo" [ toTreeTerm p1 ] + ( Bezier2To p1 ( NextPoint p2 ) _ ) -> Node "Bezier2To" [ toTreeTerm p1, toTreeTerm p2 ] + ( Bezier3To p1 p2 ( NextPoint p3 ) _ ) -> Node "Bezier3To" [ toTreeTerm p1, toTreeTerm p2, toTreeTerm p3 ] + SClosed -> case curve of + ( LineTo BackToStart _ ) -> Node "LineTo" [ Node "cycle" [] ] + ( Bezier2To p1 BackToStart _ ) -> Node "Bezier2To" [ toTreeTerm p1, Node "cycle" [] ] + ( Bezier3To p1 p2 BackToStart _ ) -> Node "Bezier3To" [ toTreeTerm p1, toTreeTerm p2, Node "cycle" [] ] diff --git a/src/app/MetaBrush/MetaParameter/Driver.hs b/src/app/MetaBrush/MetaParameter/Driver.hs new file mode 100644 index 0000000..f6be7ce --- /dev/null +++ b/src/app/MetaBrush/MetaParameter/Driver.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module MetaBrush.MetaParameter.Driver where + +-- base +import GHC.Exts + ( Proxy#, proxy# ) + +-- dlist +import qualified Data.DList as DList + ( toList ) + +-- Earley +import qualified Text.Earley as Earley + ( Report(..), fullParses, parser ) + +-- text +import Data.Text + ( Text ) + +-- transformers +import Control.Monad.Trans.Except + ( runExceptT ) +import Control.Monad.Trans.Reader + ( runReaderT ) +import Control.Monad.Trans.RWS.CPS + ( runRWST ) +import Control.Monad.Trans.State.Strict + ( evalState ) + +-- MetaBrush +import Math.Bezier.Spline + ( SplinePts, SSplineType(SClosed), SplineTypeI(ssplineType) ) +import MetaBrush.MetaParameter.AST + ( Located + , Term, TypedTerm(..) + , SType(..), STypeI(sTypeI) + , SomeSType(..), STypesI + , Pass(Tc) + , AdaptableFunction(..), BrushFunction + ) +import MetaBrush.MetaParameter.Eval + ( EvalState(..), eval ) +import MetaBrush.MetaParameter.Parse + ( grammar, Token, tokenize ) +import MetaBrush.MetaParameter.Rename + ( rename, RnM, RnMessage, RnError, emptyRnState ) +import MetaBrush.MetaParameter.TypeCheck + ( typeCheck, TcM, TcMessage, TcError, emptyTcState ) +import MetaBrush.Unique + ( UniqueSupply, MonadUnique(freshUnique) ) + +-------------------------------------------------------------------------------- + +data DriverError + = ParseError !( Earley.Report Text [ Located Token ] ) + | RenameError !RnError + | TypeCheckError !TcError + | NonBrushType !SomeSType + deriving stock Show + +data DriverMessage + = RenameMessage !RnMessage + | TypeCheckMessage !TcMessage + +data SomeBrushFunction where + SomeBrushFunction + :: forall brushParams + . ( STypesI brushParams ) + => BrushFunction brushParams + -> SomeBrushFunction + +interpretBrush + :: UniqueSupply + -> Text + -> IO + ( Either DriverError SomeBrushFunction + , [ DriverMessage ] + ) +interpretBrush uniqSupply sourceText = case Earley.fullParses ( Earley.parser grammar ) $ tokenize sourceText of + ( [], parserReport ) -> pure ( Left ( ParseError parserReport ), [] ) + ( parsedExpr : _, _ ) -> do + ( renamedExpr, _, rnMessages ) <- runRWST ( rename @RnM parsedExpr ) uniqSupply emptyRnState + ( tcResult , _, tcMessages ) <- runRWST ( runExceptT $ typeCheck @TcM renamedExpr ) uniqSupply emptyTcState + let + messages :: [ DriverMessage ] + messages = DList.toList ( fmap RenameMessage rnMessages <> fmap TypeCheckMessage tcMessages ) + case tcResult of + Left err -> pure ( Left ( TypeCheckError err ), messages ) + -- Type checking succeeded: check that the type of the given program + -- is indeed a function that takes in a record of parameters and returns + -- a closed brush shape. + Right ( TypedTerm ( term :: Term Tc v ) ) + | sTyWithFn@STyWithFn <- sTypeI @v + , ( _ :: SType ( AdaptableFunction kvs b ) ) <- sTyWithFn + , sTySpline@STySpline <- sTypeI @b + , ( _ :: SType ( SplinePts clo ) ) <- sTySpline + , SClosed <- ssplineType @clo + -> do + uniq <- ( `runReaderT` uniqSupply ) freshUnique + let + initEvalState :: EvalState + initEvalState = + EvalState { evalHeap = mempty, nextUnique = uniq } + val :: BrushFunction kvs + val = ( `evalState` initEvalState ) $ eval term + pure ( Right ( SomeBrushFunction @kvs val ), messages ) + | otherwise + -> pure ( Left ( NonBrushType ( SomeSType ( proxy# :: Proxy# v ) ) ), messages ) diff --git a/src/app/MetaBrush/MetaParameter/Eval.hs b/src/app/MetaBrush/MetaParameter/Eval.hs new file mode 100644 index 0000000..3170b49 --- /dev/null +++ b/src/app/MetaBrush/MetaParameter/Eval.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module MetaBrush.MetaParameter.Eval + ( EvalState(..), eval ) + where + +-- base +import Data.Foldable + ( for_ ) +import Data.Functor.Compose + ( Compose(..) ) +import Data.Type.Equality + ( (:~:)(Refl) ) +import GHC.Generics + ( Generic ) + +-- containers +import Data.Map + ( Map ) +import qualified Data.Map.Strict as Map + ( insert, lookup, union, fromList ) + +-- generic-lens +import Data.Generics.Product.Fields + ( field' ) + +-- lens +import Control.Lens + ( assign, modifying, use ) + +-- mtl +import Control.Monad.State + ( get ) + +-- superrecord +import qualified SuperRecord as Super + ( Rec ) +import qualified SuperRecord + ( RecApply(..), Lookup(..), Has, UnsafeRecBuild, traverseC, project ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + ( pack ) + +-- transformers +import Control.Monad.Trans.State.Strict + ( State, evalState ) + +-- MetaBrush +import qualified Math.Bezier.Cubic as Cubic + ( Bezier(..) ) +import qualified Math.Bezier.Quadratic as Quadratic + ( Bezier(..) ) +import Math.Bezier.Spline + ( KnownSplineType(bitraverseSpline), bitraverseCurve ) +import Math.Vector2D + ( Point2D(..), Segment(..) ) +import MetaBrush.MetaParameter.AST + ( Term(..), Pat(..), Decl(..) + , TypedTerm(..), STypeI(..), SType(..) + , Pass(Tc), X_Ext(..), X_With(..) + , Span(..), Located(..) + , MapFields, AdaptableFunction(..) + , UniqueField(..), UniqueTerm, IsUniqueTerm2, UseFieldsInBrush + , eqTy + ) +import MetaBrush.MetaParameter.Rename + ( UniqueName(..) ) +import MetaBrush.Unique + ( Unique ) + +-------------------------------------------------------------------------------- + +data EvalState + = EvalState + { evalHeap :: !( Map Unique TypedTerm ) + , nextUnique :: !Unique + } + deriving stock Generic + +eval :: forall a. STypeI a => Term Tc a -> State EvalState a +eval ( f :$ a ) = eval f <*> eval a +eval ( Lit _ x ) = pure x +eval ( Op _ _ f ) = pure f +eval ( Point _ x y ) = Point2D <$> eval x <*> eval y +eval ( Line _ p q ) = Segment <$> eval p <*> eval q +eval ( Bez2 _ p q r ) = Quadratic.Bezier <$> eval p <*> eval q <*> eval r +eval ( Bez3 _ p q r s ) = Cubic.Bezier <$> eval p <*> eval q <*> eval r <*> eval s +eval ( PolyBez _ spline ) = + bitraverseSpline + ( const $ bitraverseCurve ( const $ pure () ) ( const eval ) ) + eval + spline +eval ( Let _ decls a ) = declare decls *> eval a +eval ( With _ ( Tc_With ( withDeclsRecord :: Super.Rec ( MapFields UniqueTerm brushFields ) ) ) _ ( body :: Term Tc r ) ) = do + defaultParamsRecord <- + SuperRecord.traverseC @IsUniqueTerm2 @( State EvalState ) @( MapFields UniqueTerm brushFields ) @( MapFields UniqueField brushFields ) + ( \ _ ( Compose ( UniqueField uniq term ) ) -> UniqueField uniq <$> eval term ) + withDeclsRecord + EvalState { evalHeap, nextUnique } <- get + let + toBrushParameters + :: forall givenFields usedFields + . ( SuperRecord.UnsafeRecBuild usedFields usedFields + ( SuperRecord.Has givenFields ) + ) + => Super.Rec givenFields -> Super.Rec usedFields + toBrushParameters = SuperRecord.project + brushFunction + :: forall usedFields + . ( SuperRecord.RecApply ( MapFields UniqueField brushFields ) ( MapFields UniqueField brushFields ) + ( UseFieldsInBrush usedFields ) + ) + => Super.Rec usedFields -> r + brushFunction usedParamsRecord = + let + updatedHeap :: Map Unique TypedTerm + updatedHeap = bindRecordValues @brushFields @usedFields defaultParamsRecord usedParamsRecord evalHeap + in + ( `evalState` ( EvalState { evalHeap = updatedHeap, nextUnique } ) ) $ eval body + pure ( AdaptableFunction ( toBrushParameters, brushFunction ) ) +eval ( Var var@( Located _ ( UniqueName _ varUniq ) ) ) = do + vars <- use ( field' @"evalHeap" ) + case Map.lookup varUniq vars of + Nothing -> error ( "eval: out of scope variable " <> show var ) + Just ( TypedTerm ( r :: Term Tc b ) ) + | Just Refl <- eqTy @a @b + -> do + res <- eval r + modifying ( field' @"evalHeap" ) + ( Map.insert varUniq ( TypedTerm $ CExt @Tc @a ( Val res ) ) ) + pure res + | otherwise + -> error + ( "eval: unexpected type of variable read from environment.\n\ + \Expected: " <> show ( sTypeI @a ) <> "\n\ + \ Actual: " <> show ( sTypeI @b ) + ) +eval ( CExt ( Val v ) ) = pure v + +declare :: [ Decl Tc ] -> State EvalState () +declare [] = pure () +declare ( Decl _ pat t : next ) = go pat t *> declare next + where + go :: forall a. STypeI a => Pat Tc a -> Term Tc a -> State EvalState ( Maybe UniqueName ) + go ( PName ( Located _ patUniqName@( UniqueName _ patUniq ) ) ) r = do + modifying ( field' @"evalHeap" ) + ( Map.insert patUniq $ TypedTerm r ) + pure ( Just patUniqName ) + go ( PPoint _ lpat rpat ) r = do + case sTypeI @a of + sTyPoint@STyPoint + | ( _ :: SType ( Point2D x ) ) <- sTyPoint + -> do + nextUnique <- use ( field' @"nextUnique" ) + let + uniq1, uniq2, uniq3, nextUnique' :: Unique + uniq1 = nextUnique + uniq2 = succ uniq1 + uniq3 = succ uniq2 + nextUnique' = succ uniq3 + assign ( field' @"nextUnique" ) nextUnique' + let + pairText :: Text + pairText = "$pair%" <> Text.pack ( show uniq1 ) + pairName, fstName, sndName :: UniqueName + pairName = UniqueName pairText uniq1 + fstName = UniqueName ( pairText <> "$fst" ) uniq2 + sndName = UniqueName ( pairText <> "$snd" ) uniq3 + var_l, var_r :: Term Tc x + var_l = Var ( Located noSpan fstName ) + var_r = Var ( Located noSpan sndName ) + modifying ( field' @"evalHeap" ) + ( Map.union + $ Map.fromList + [ ( uniq1, TypedTerm $ Point [] var_l var_r ) + , ( uniq2, TypedTerm $ ( Op @( a -> x ) [] "fst" ( \ ~( Point2D x _ ) -> x ) ) :$ r ) + , ( uniq3, TypedTerm $ ( Op @( a -> x ) [] "snd" ( \ ~( Point2D _ y ) -> y ) ) :$ r ) + ] + ) + go lpat var_l + go rpat var_r + pure ( Just pairName ) + go ( AsPat _ ( Located _ asUniqName@( UniqueName _ asUniq ) ) patt ) r = do + mbNm <- go patt r + for_ mbNm \ nm -> + modifying ( field' @"evalHeap" ) + ( Map.insert asUniq ( TypedTerm $ Var @Tc @a ( Located noSpan nm ) ) ) + pure ( Just asUniqName ) + go ( PWild _ ) _ = pure Nothing + +bindRecordValues + :: forall brushFields usedFields defaultFields + . ( defaultFields ~ MapFields UniqueField brushFields + , SuperRecord.RecApply defaultFields defaultFields ( UseFieldsInBrush usedFields ) + ) + => Super.Rec defaultFields + -> Super.Rec usedFields + -> Map Unique TypedTerm + -> Map Unique TypedTerm +bindRecordValues defaultValues usedValues heap = do + SuperRecord.recApply @defaultFields @defaultFields @( UseFieldsInBrush usedFields ) + ( \ k ( UniqueField ( UniqueName _ uniq ) ( defaultVal :: a ) ) prevState -> + let + val :: a + val = SuperRecord.lookupWithDefault k defaultVal usedValues + updatedHeap :: Map Unique TypedTerm + updatedHeap = Map.insert uniq ( TypedTerm $ CExt @Tc @a ( Val val ) ) prevState + in updatedHeap + ) + defaultValues + heap + +noSpan :: Span +noSpan = Span 0 0 0 0 diff --git a/src/app/MetaBrush/MetaParameter/Interpolation.hs b/src/app/MetaBrush/MetaParameter/Interpolation.hs new file mode 100644 index 0000000..c93d756 --- /dev/null +++ b/src/app/MetaBrush/MetaParameter/Interpolation.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module MetaBrush.MetaParameter.Interpolation + ( Interpolatable(..), MapDiff, HasDiff', HasTorsor ) + where + +-- base +import Data.Functor.Identity + ( Identity(..) ) +import Data.Kind + ( Type ) +import Data.Monoid + ( Sum ) +import GHC.TypeLits + ( Symbol ) + +-- acts +import Data.Act + ( Act(..), Torsor(..) ) + +-- groups +import Data.Group + ( Group(..) ) + +-- superrecord +import qualified SuperRecord as Super + ( Rec ) +import qualified SuperRecord + ( (:=), Has, RecTy, RecApply(..), UnsafeRecBuild(..), TraversalC, traverseC + , get, set, modify + ) +import SuperRecord + ( ConstC, Tuple22C ) + +-- MetaBrush +import Math.Module + ( Module(..) ) +import Math.Vector2D + ( Point2D, Vector2D ) + +-------------------------------------------------------------------------------- + +class ( Module Double ( Diff a ), Torsor ( Diff a ) a ) => Interpolatable a where + type Diff a = ( d :: Type ) | d -> a + +instance ( a ~ Double ) => Interpolatable ( Point2D a ) where + type Diff ( Point2D a ) = Vector2D a + +instance Interpolatable Double where + type Diff Double = Sum Double + +instance ( dvs ~ MapDiff kvs + , SuperRecord.UnsafeRecBuild dvs dvs ( ConstC Monoid ) + , SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has dvs ) ) + , SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC Semigroup ) ( SuperRecord.Has dvs ) ) + , SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC Group ) ( SuperRecord.Has dvs ) ) + , SuperRecord.RecApply dvs dvs ( HasDiff' kvs ) + , SuperRecord.TraversalC ( HasTorsor kvs ) kvs dvs + , Module Double ( Super.Rec ( MapDiff kvs ) ) + ) + => Interpolatable ( Super.Rec kvs ) + where + type Diff ( Super.Rec kvs ) = Super.Rec ( MapDiff kvs ) + +type family MapDiff ( kvs :: [ Type ] ) = ( lvs :: [ Type ] ) | lvs -> kvs where + MapDiff '[] = '[] + MapDiff ( k SuperRecord.:= v ': kvs ) = ( k SuperRecord.:= Diff v ': MapDiff kvs ) + + + + +instance ( Monoid ( Super.Rec kvs ) + , SuperRecord.RecApply kvs kvs + ( Tuple22C ( ConstC Group ) ( SuperRecord.Has kvs ) ) + ) + => Group ( Super.Rec kvs ) + where + invert r = SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC Group ) ( SuperRecord.Has kvs ) ) + ( \ lbl v res -> SuperRecord.set lbl ( invert v ) res ) r r +instance ( SuperRecord.RecApply kvs kvs + ( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) ) + , SuperRecord.UnsafeRecBuild kvs kvs ( ConstC ( Module Double ) ) + ) + => Module Double ( Super.Rec kvs ) + where + origin = runIdentity $ SuperRecord.unsafeRecBuild @kvs @kvs @( ConstC ( Module Double ) ) ( \ _ _ -> Identity origin ) + r1 ^+^ r2 = + SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) ) + ( \ lbl v1 res -> SuperRecord.modify lbl ( v1 ^+^ ) res ) r1 r2 + r1 ^-^ r2 = + SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) ) + ( \ lbl v1 res -> SuperRecord.modify lbl ( v1 ^-^ ) res ) r1 r2 + k *^ r = + SuperRecord.recApply @kvs @kvs @( Tuple22C ( ConstC ( Module Double ) ) ( SuperRecord.Has kvs ) ) + ( \ lbl v1 res -> SuperRecord.set lbl ( k *^ v1 ) res ) r r + +class ( SuperRecord.Has kvs k t, Interpolatable t, d ~ Diff t, Just t ~ SuperRecord.RecTy k kvs ) + => HasDiff ( kvs :: [ Type ] ) ( t :: Type ) ( k :: Symbol ) ( d :: Type ) +instance ( SuperRecord.Has kvs k t, Interpolatable t, d ~ Diff t, Just t ~ SuperRecord.RecTy k kvs ) + => HasDiff kvs t k d + +type family FromJust ( a :: Maybe k ) :: k where + FromJust ( Just a ) = a + +class HasDiff kvs ( FromJust ( SuperRecord.RecTy k kvs ) ) k d => HasDiff' kvs k d +instance HasDiff kvs ( FromJust ( SuperRecord.RecTy k kvs ) ) k d => HasDiff' kvs k d + +instance ( dvs ~ MapDiff kvs + , SuperRecord.RecApply dvs dvs ( Tuple22C ( ConstC Semigroup ) ( SuperRecord.Has dvs ) ) + , SuperRecord.RecApply dvs dvs ( HasDiff' kvs ) + ) + => Act ( Super.Rec dvs ) ( Super.Rec kvs ) + where + ds • as = SuperRecord.recApply @dvs @dvs @( HasDiff' kvs ) + ( \ lbl d1 res -> SuperRecord.modify lbl ( d1 • ) res ) ds as + + +class ( d ~ Diff t, Torsor d t, SuperRecord.Has kvs k t ) => HasTorsor ( kvs :: [Type] ) ( k :: Symbol ) t d where +instance ( d ~ Diff t, Torsor d t, SuperRecord.Has kvs k t ) => HasTorsor kvs k t d where + +instance ( dvs ~ MapDiff kvs + , SuperRecord.TraversalC ( HasTorsor kvs ) kvs dvs + , Act ( Super.Rec dvs ) ( Super.Rec kvs ) + , Group ( Super.Rec dvs ) + ) + => Torsor ( Super.Rec dvs ) ( Super.Rec kvs ) where + as <-- bs = + runIdentity $ SuperRecord.traverseC @( HasTorsor kvs ) @Identity @kvs @dvs + ( \ lbl a -> Identity ( a <-- SuperRecord.get lbl bs ) ) + as diff --git a/src/app/MetaBrush/MetaParameter/Parse.hs b/src/app/MetaBrush/MetaParameter/Parse.hs new file mode 100644 index 0000000..944f58c --- /dev/null +++ b/src/app/MetaBrush/MetaParameter/Parse.hs @@ -0,0 +1,828 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + +module MetaBrush.MetaParameter.Parse where + +-- base +import Control.Applicative + ( Alternative + ( (<|>), some, many ) + , optional + ) +import Control.Category + ( (>>>) ) +import Control.Monad + ( void ) +import qualified Data.Char as Char + ( isAlpha, isAlphaNum, isDigit, isSpace, isSymbol, isPunctuation, toLower ) +import Data.Foldable + ( for_ ) + +-- containers +import Data.Set + ( Set ) +import qualified Data.Set as Set + ( member, fromList ) +import qualified Data.Sequence as Seq + ( fromList ) + +-- Earley +import qualified Text.Earley as Earley +import Text.Earley + ( () ) +import qualified Text.Earley.Mixfix as Earley + +-- text +import Data.Text.Internal + ( Text(..) ) +import qualified Data.Text as Text + ( all, break, cons, foldl' + , length, map, null + , singleton, span + , uncons, unpack + ) +import qualified Data.Text.Read as Text.Read + ( double ) + +-- tree-view +import Data.Tree.View + ( drawTree ) + +-- MetaBrush +import Math.Bezier.Spline + ( SplineType(..), SSplineType(..), SplineTypeI(ssplineType) + , Spline(..), Curves(..), Curve(..), NextPoint(..) + ) +import MetaBrush.MetaParameter.AST + ( Span(..), Located(..) + , Expr, EPat + , Term(..), Pat(..), Decl(..) + , X_With(..) + , toTreeTerm + ) +import MetaBrush.MetaParameter.PrimOp + ( Orientation(..), kappa + , rotate_around_by, rotate_by + , scale_around_by, scale_by + , shear_from_by, shear_by + , translate_by + ) + +-------------------------------------------------------------------------------- +-- Parsing using the language grammar. + +parse :: Text -> ( [ ( Expr, Int ) ], Earley.Report Text [ Located Token ] ) +parse = Earley.allParses ( Earley.parser grammar ) . tokenize + +showParses :: Text -> IO () +showParses x = do + let + ( parses, report ) = parse x + putStrLn "Report:\n" + print report + putStrLn "\n\n" + putStrLn "Parses:\n" + for_ parses \ ( expr, _ ) -> do + let + tree = toTreeTerm expr + drawTree tree + +examples :: [ Located Token ] -> Int -> IO () +examples inputToks n = + for_ ( Earley.exactly n ( Earley.generator grammar inputToks ) ) \ ( expr, toks ) -> do + for_ toks ( located >>> showToken >>> ( <> " " ) >>> putStr ) + putStrLn "" + drawTree ( toTreeTerm expr ) + putStrLn "\n\n" + +someToks :: [ Located Token ] +someToks = map ( Located mempty ) + [ TokAlphabetic "x" + , TokAlphabetic "let" + , TokAlphabetic "in" + , TokSpecial '[' + , TokSpecial ']' + , TokSpecial '(' + , TokSpecial ')' + , TokSymbolic "=" + , TokSymbolic "--" + , TokSymbolic "->" + , TokSymbolic "." + ] + +test1 :: Text +test1 = + " let\n\ + \ q = rotate p around c CW by theta + 3 * theta2\n\ + \ r = scale ( translate q by t ) by (7,11)\n\ + \ in rotate q around p CW by phi" + +test2 :: Text +test2 = + " let\n\ + \ p = (3,3)\n\ + \ q = (1,1)\n\ + \ in\n\ + \ rotate p\n\ + \ around q\n\ + \ CCW by\n\ + \ let\n\ + \ q = pi / 2 \n\ + \ in q" + +test3 :: Text +test3 = + " let\n\ + \ p = (1,1)\n\ + \ in\n\ + \ [ p -- c1 -- c2 -> q\n\ + \ -- c3 -- c4 -> r\n\ + \ -> s -> .\n\ + \ ]" + + + +-------------------------------------------------------------------------------- +-- Language grammar. + +grammar :: forall r. Earley.Grammar r ( Earley.Prod r Text ( Located Token ) Expr ) +grammar = mdo + + pair <- Earley.rule $ + do + lp <- special '(' + l <- expr + anyWhitespace + comma <- special ',' + r <- expr + anyWhitespace + rp <- special ')' + pure $ + Point + [ Location ( location lp ) + , Location ( location comma ) + , Location ( location rp ) ] + l r + "pair" + atom <- Earley.rule + ( identifier + <|> pair + <|> ( special '(' *> expr <* anyWhitespace <* special ')' ) + <|> spline + ) + app <- Earley.rule ( atom <|> (:$) <$> app <*> ( anyWhitespace *> atom ) ) + + pairPattern <- Earley.rule + ( do + openLoc <- special '(' + anyWhitespace + l <- anyPattern + anyWhitespace + commaLoc <- special ',' + anyWhitespace + r <- anyPattern + anyWhitespace + closeLoc <- special ')' + pure $ PPoint + [ Location ( location openLoc ) + , Location ( location commaLoc ) + , Location ( location closeLoc ) + ] + l r + "pair" + ) + + basicPattern <- Earley.rule + ( wildcard + <|> ( PName <$> alphabeticName + "pattern name" + ) + <|> pairPattern + ) + + asPattern <- Earley.rule + ( do + n <- alphabeticName "pattern name" + asLoc <- symbol "@" + pat <- anyPattern + pure $ + AsPat ( Location ( location asLoc ) ) n pat + "as pattern" + ) + + anyPattern <- Earley.rule ( ( basicPattern <|> asPattern ) "pattern" ) + + declaration <- + Earley.rule + ( do + p <- anyPattern + anyWhitespace + eqLoc <- symbol "=" + e <- expr + pure ( Location ( location eqLoc ), p, e ) + "declaration" + ) + + moreDeclarations <- Earley.rule + ( do + separator + decl <- declaration + more <- moreDeclarations + pure $ ( \ ( l, p, e ) -> Decl l p e : more ) decl + <|> pure [] + ) + + declarations <- + Earley.rule + ( do + decl <- declaration + more <- moreDeclarations + pure $ ( \ ( l, p, e ) -> Decl l p e : more ) decl + <|> pure [] + ) + + let_statement <- + Earley.rule + ( do + loc_let <- tokAlpha "let" + anyWhitespace + decls <- declarations "declarations" + anyWhitespace + loc_in <- tokAlpha "in" + e <- expr + pure $ + Let + [ Location ( location loc_let ) + , Location ( location loc_in ) ] + decls + e + "let statement" + ) + + moreProperties <- Earley.rule + ( do + separator + prop <- expr + more <- moreProperties + pure ( prop : more ) + <|> pure [] + ) + + properties <- + Earley.rule + ( do + prop <- expr + more <- moreProperties + pure ( prop : more ) + <|> pure [] + ) + + with_statement <- + Earley.rule + ( do + loc_with <- tokAlpha "with" + anyWhitespace + decls <- declarations "parameter default definitions" + mbProps <- optional do + anyWhitespace + loc_sats <- tokAlpha "satisfying" + props <- properties "parameter range properties" + pure ( loc_sats, props ) + anyWhitespace + loc_def <- tokAlpha "define" + e <- expr + pure $ + let + ( locs, props ) = case mbProps of + Nothing -> + ( [ Location ( location loc_with ) + , Location ( location loc_def ) ] + , [] + ) + Just ( loc_sats, sat_props ) -> + ( [ Location ( location loc_with ) + , Location ( location loc_sats ) + , Location ( location loc_def ) ] + , sat_props + ) + in + With locs ( P_With decls ) props e + "with statement" + ) + + spline <- + Earley.rule + ( do + start <- special '[' + p0 <- expr "first point of spline" + openCurves <- many $ curveTo @Open expr "open curve to" + mbClosed <- optional $ curveTo @Closed expr "closed curve" + anyWhitespace + end <- special ']' + pure $ + ( \ opens -> \ case + Nothing -> + PolyBez + [ Location ( location start ), Location ( location end ) ] + ( Spline p0 ( OpenCurves opens ) ) + Just closed -> + PolyBez + [ Location ( location start ), Location ( location end ) ] + ( Spline p0 ( ClosedCurves opens closed ) ) + ) ( Seq.fromList openCurves ) mbClosed + "spline" ) + + simpleExpr <- Earley.rule do + anyWhitespace + res <- app <|> let_statement + pure res + expr <- Earley.mixfixExpressionSeparate mixfixTable simpleExpr + + pure ( with_statement <|> expr ) + +-- | Reserved alphabetic identifiers. +reserved :: Set Text +reserved + = Set.fromList + [ "let", "in" + , "with", "set", "satisfying" + , "around", "by", "rotate", "scale", "shear", "translate", "transform" + , "cw", "ccw" + , "pi", "tau", "kappa" + ] +{- +[ "=", "_", "@", "--", "->" ] +-} + +dots :: Earley.Prod r Text ( Located Token ) ( Located Token ) +dots = Earley.satisfy ( located >>> \case { TokSymbolic s | Text.all ( == '.' ) s -> True; _ -> False } ) + +locatedToken :: Token -> Earley.Prod r Text ( Located Token ) ( Located Token ) +locatedToken t = Earley.satisfy ( located >>> ( == t ) ) + +tokAlpha, ws_tokAlpha :: Text -> Earley.Prod r Text ( Located Token ) ( Located Token ) +tokAlpha t = Earley.satisfy + ( located >>> \case { TokAlphabetic a | Text.map Char.toLower a == t -> True; _ -> False } ) + t +ws_tokAlpha t = anyWhitespace *> tokAlpha t + +tokSymbol, ws_tokSymbol :: Text -> Earley.Prod r Text ( Located Token ) ( Located Token ) +tokSymbol t = locatedToken ( TokSymbolic t ) t +ws_tokSymbol t = anyWhitespace *> tokSymbol t + +tokOrientation :: Earley.Prod r Text ( Located Token ) ( Located Token ) +tokOrientation = anyWhitespace *> ( tokAlpha "ccw" <|> tokAlpha "cw" ) + +orientation :: Token -> Orientation +orientation ( TokAlphabetic ori ) + | Text.map Char.toLower ori == "ccw" + = CCW + | Text.map Char.toLower ori == "cw" + = CW +orientation tok = error ( "orientation: unexpected token " <> show tok ) + +curveTo + :: forall clo r + . SplineTypeI clo + => Earley.Prod r Text ( Located Token ) Expr + -> Earley.Prod r Text ( Located Token ) ( Curve clo [ Located () ] Expr ) +curveTo expr = do + anyWhitespace + cps <- optional do + locTo1 <- symbol "--" + cp1 <- expr + anyWhitespace + mb_cp2 <- optional do + locTo2 <- symbol "--" + cp2 <- expr + anyWhitespace + pure ( locTo2, cp2 ) + pure ( ( locTo1, cp1), mb_cp2 ) + locTo3 <- symbol "->" + mkCurve <- case ssplineType @clo of + SClosed -> + let + mkCurve + :: Located Token + -> Maybe ( ( Located Token, Expr ), Maybe ( Located Token, Expr ) ) + -> Span + -> Curve Closed [ Located () ] Expr + mkCurve ( Located dotsLoc _ ) mbCps loc3 = case mbCps of + Nothing -> + LineTo BackToStart [ Location loc3, Location dotsLoc ] + Just ( ( Located loc1 _, cp1 ), Nothing ) -> + Bezier2To cp1 BackToStart [ Location loc1, Location loc3, Location dotsLoc ] + Just ( ( Located loc1 _, cp1 ), Just ( Located loc2 _, cp2 ) ) -> + Bezier3To cp1 cp2 BackToStart [ Location loc1, Location loc2, Location loc3, Location dotsLoc ] + in do + anyWhitespace + locatedDots <- dots + pure ( mkCurve locatedDots ) + SOpen -> + let + mkCurve + :: Expr + -> Maybe ( ( Located Token, Expr ), Maybe ( Located Token, Expr ) ) + -> Span + -> Curve Open [ Located () ] Expr + mkCurve p mbCps loc3 = case mbCps of + Nothing -> + LineTo ( NextPoint p ) [ Location loc3 ] + Just ( ( Located loc1 _, cp1 ), Nothing ) -> + Bezier2To cp1 ( NextPoint p ) [ Location loc1, Location loc3 ] + Just ( ( Located loc1 _, cp1 ), Just ( Located loc2 _, cp2 ) ) -> + Bezier3To cp1 cp2 ( NextPoint p ) [ Location loc1, Location loc2, Location loc3 ] + in do + p <- expr + pure ( mkCurve p ) + pure ( mkCurve cps ( location locTo3 ) ) + +mixfixTable + :: [ [ + ( Earley.Holey ( Earley.Prod r Text ( Located Token ) ( Located Token ) ) + , Earley.Associativity + , Earley.Holey ( Located Token ) -> [ Expr ] -> Expr + ) + ] ] +mixfixTable + = [ [ ( [ Just $ ws_tokAlpha "rotate", Nothing, Just $ ws_tokAlpha "around", Nothing, Just tokOrientation, Just $ ws_tokAlpha "by", Nothing ] + , Earley.NonAssoc + , \ [ Just ( Located lr _ ), _, Just ( Located la _ ), _, Just ( Located lo ori_tok ), Just ( Located lb _ ), _ ] [ p, c, theta ] -> + let + ori :: Orientation + ori = orientation ori_tok + opName :: Text + opName = case ori of { CW -> "rotate_around_cwby_"; CCW -> "rotate_around_ccwby_" } + in + Op [ Location lr, Location la, Location lo, Location lb ] + opName ( rotate_around_by ori ) + :$ p :$ c :$ theta + ) + , ( [ Just $ ws_tokAlpha "scale", Nothing, Just $ ws_tokAlpha "around", Nothing, Just $ ws_tokAlpha "by", Nothing ] + , Earley.NonAssoc + , \ [ Just ( Located ls _ ), _, Just ( Located la _ ), _, Just ( Located lb _ ), _ ] [ p, c, r ] -> + Op [ Location ls, Location la, Location lb ] + "scale_around_by_" scale_around_by + :$ p :$ c :$ r + ) + , ( [ Just $ ws_tokAlpha "shear", Nothing, Just $ ws_tokAlpha "from", Nothing, Just $ ws_tokAlpha "by", Nothing ] + , Earley.NonAssoc + , \ [ Just ( Located ls _ ), _, Just ( Located lf _ ), _, Just ( Located lb _ ), _ ] [ p, c, v ] -> + Op [ Location ls, Location lf, Location lb ] + "shear_from_by_" shear_from_by + :$ p :$ c :$ v + ) + ] + , [ ( [ Just $ ws_tokAlpha "rotate", Nothing, Just tokOrientation, Just $ ws_tokAlpha "by", Nothing ] + , Earley.NonAssoc + , \ [ Just ( Located lr _ ), _, Just ( Located lo ori_tok ), Just ( Located lb _), _ ] [ p, theta ] -> + let + ori :: Orientation + ori = orientation ori_tok + opName :: Text + opName = case ori of { CW -> "rotate_around_cw_"; CCW -> "rotate_around_ccw_" } + in + Op [ Location lr, Location lo, Location lb ] + opName ( rotate_by ori ) + :$ p :$ theta + ) + , ( [ Just $ ws_tokAlpha "scale", Nothing, Just $ ws_tokAlpha "by", Nothing ] + , Earley.NonAssoc + , \ [ Just ( Located ls _ ), _, Just ( Located lb _ ), _ ] [ p, r ] -> + Op [ Location ls, Location lb ] + "scale_by_" scale_by + :$ p :$ r + ) + , ( [ Just $ ws_tokAlpha "shear", Nothing, Just $ ws_tokAlpha "along", Nothing, Just $ ws_tokAlpha "by", Nothing ] + , Earley.NonAssoc + , \ [ Just ( Located ls _ ), _, Just ( Located lb _ ), _ ] [ p, v ] -> + Op [ Location ls, Location lb ] + "shear_along_by_" shear_by + :$ p :$ v + ) + , ( [ Just $ ws_tokAlpha "translate", Nothing, Just $ ws_tokAlpha "by", Nothing ] + , Earley.NonAssoc + , \ [ Just ( Located lt _ ), _, Just ( Located lb _ ), _ ] [ p, t ] -> + Op [ Location lt, Location lb ] + "translate_by_" translate_by + :$ p :$ t + ) + ] + , [ ( [ Nothing, Just $ ws_tokSymbol "||", Nothing ] + , Earley.RightAssoc + , \ [ _, Just ( Located l _ ), _ ] [ a, b ] -> + Op [ Location l ] + "(||)" (||) + :$ a :$ b + ) + ] + , [ ( [ Nothing, Just $ ws_tokSymbol "&&", Nothing ] + , Earley.RightAssoc + , \ [ _, Just ( Located l _ ), _ ] [ a, b ] -> + Op [ Location l ] + "(&&)" (&&) + :$ a :$ b + ) + ] + , [ ( [ Nothing, Just $ ws_tokSymbol "<", Nothing ] + , Earley.NonAssoc + , \ [ _, Just ( Located l _ ), _ ] [ a, b ] -> + Op [ Location l ] + "(<)" ( (<) @Double ) + :$ a :$ b + ) + , ( [ Nothing, Just $ ws_tokSymbol "<=", Nothing ] + , Earley.NonAssoc + , \ [ _, Just ( Located l _ ), _ ] [ a, b ] -> + Op [ Location l ] + "(<=)" ( (<=) @Double ) + :$ a :$ b + ) + , ( [ Nothing, Just $ ws_tokSymbol ">", Nothing ] + , Earley.NonAssoc + , \ [ _, Just ( Located l _ ), _ ] [ a, b ] -> + Op [ Location l ] + "(>)" ( (>) @Double ) + :$ a :$ b + ) + , ( [ Nothing, Just $ ws_tokSymbol ">=", Nothing ] + , Earley.NonAssoc + , \ [ _, Just ( Located l _ ), _ ] [ a, b ] -> + Op [ Location l ] + "(>=)" ( (>=) @Double ) + :$ a :$ b + ) + , ( [ Nothing, Just $ ws_tokSymbol "==", Nothing ] + , Earley.NonAssoc + , \ [ _, Just ( Located l _ ), _ ] [ a, b ] -> + Op [ Location l ] + "(==)" ( (==) @Double ) + :$ a :$ b + ) + ] + , [ ( [ Nothing, Just $ ws_tokSymbol "+", Nothing ] + , Earley.LeftAssoc + , \ [ _, Just ( Located l _ ), _ ] [ a, b ] -> + Op [ Location l ] + "(+)" ( (+) @Double ) + :$ a :$ b + ) + , ( [ Nothing, Just $ ws_tokSymbol "-", Nothing ] + , Earley.LeftAssoc + , \ [ _, Just ( Located l _ ), _ ] [ a, b ] -> + Op [ Location l ] + "(-)" ( (-) @Double ) + :$ a :$ b + ) + , ( [ Just $ ws_tokSymbol "-", Nothing ] + , Earley.RightAssoc + , \ [ Just ( Located l _ ), _ ] [ a ] -> + Op [ Location l ] + "negate" ( negate @Double ) + :$ a + ) + ] + , [ ( [ Nothing, Just $ ws_tokSymbol "*", Nothing ] + , Earley.LeftAssoc + , \ [ _, Just ( Located l _ ), _ ] [ a, b ] -> + Op [ Location l ] + "(*)" ( (*) @Double ) + :$ a :$ b + ) + , ( [ Nothing, Just $ ws_tokSymbol "/", Nothing ] + , Earley.LeftAssoc + , \ [ _, Just ( Located l _ ), _ ] [ a, b ] -> + Op [ Location l ] + "(/)" ( (/) @Double ) + :$ a :$ b + ) + ] + , [ ( [ Nothing, Just $ ws_tokSymbol "^", Nothing ] + , Earley.RightAssoc + , \ [ _, Just ( Located l _ ), _ ] [ a, b ] -> + Op [ Location l ] + "(^)" ( (**) @Double ) + :$ a :$ b + ) + ] + ] + +numericLiteral :: Located Token -> Maybe Expr +numericLiteral ( Located l ( TokNumeric x ) ) = Just $ Lit @Double ( Located l Nothing ) x +numericLiteral _ = Nothing + +number :: Earley.Prod r Text ( Located Token ) Expr +number = Earley.terminal numericLiteral + "number" + +identifier :: Earley.Prod r Text ( Located Token ) Expr +identifier = + number + <|> ( \ ( Located l _ ) -> Lit @Double ( Located l ( Just "pi" ) ) pi ) <$> tokAlpha "pi" + <|> ( \ ( Located l _ ) -> Lit @Double ( Located l ( Just "tau" ) ) ( 2 * pi ) ) <$> tokAlpha "tau" + <|> ( \ ( Located l _ ) -> Lit @Double ( Located l ( Just "kappa" ) ) kappa ) <$> tokAlpha "kappa" + <|> ( ( \ n -> Var n ) <$> alphabeticName + "identifier" + ) + + + +whitespace, anyWhitespace :: Earley.Prod r Text ( Located Token ) () +whitespace = Earley.terminal $ located >>> \case { TokWhitespace _ -> Just (); _ -> Nothing } +anyWhitespace = void $ many whitespace + +significantWhitespace :: Earley.Prod r Text ( Located Token ) () +significantWhitespace = Earley.terminal ( located >>> \case { TokWhitespace True -> Just (); _ -> Nothing } ) + "newline" + +separator :: Earley.Prod r Text ( Located Token ) () +separator = + ( void ( some significantWhitespace ) + <|> ( void ( anyWhitespace *> special ';' <* anyWhitespace ) ) + ) + "separator" + +alphabeticName :: Earley.Prod r Text ( Located Token ) ( Located Text ) +alphabeticName = + Earley.terminal \case + Located l ( TokAlphabetic x ) + | not ( x `Set.member` reserved ) + -> Just ( Located l x ) + _ -> Nothing + +special :: Char -> Earley.Prod r Text ( Located Token ) ( Located Token ) +special c = locatedToken ( TokSpecial c ) Text.singleton c + +symbol :: Text -> Earley.Prod r Text ( Located Token ) ( Located Token ) +symbol s = locatedToken ( TokSymbolic s ) s + +wildcard :: Earley.Prod r Text ( Located Token ) EPat +wildcard = Earley.terminal + \case + Located l ( TokWildcard x ) -> Just ( PWild ( Located l x ) ) + _ -> Nothing + "wildcard pattern" + +-------------------------------------------------------------------------------- +-- Tokenizer. + +isSpecial :: Char -> Bool +isSpecial c = Set.member c ( Set.fromList "(){}[],;`\"" ) + +data Token + = TokWhitespace Bool + | TokSpecial Char + | TokAlphabetic Text + | TokNumeric Double + | TokWildcard Text + | TokSymbolic Text + | OtherTok Text + deriving stock ( Show, Eq, Ord ) + +showToken :: Token -> String +showToken ( TokWhitespace False ) = " " +showToken ( TokWhitespace True ) = "\n" +showToken ( TokSpecial s ) = [s] +showToken ( TokAlphabetic a ) = Text.unpack a +showToken ( TokNumeric x ) = show x +showToken ( TokWildcard w ) = Text.unpack w +showToken ( TokSymbolic s ) = Text.unpack s +showToken ( OtherTok t ) = Text.unpack t + +tokenize :: Text -> [ Located Token ] +tokenize = go 1 1 + where + go :: Int -> Int -> Text -> [ Located Token ] + go sr sc t = case Text.uncons t of + Nothing -> [] + Just ( x, xs ) + -- White space. + | Char.isSpace x + , let + ( ys, rest ) = Text.span Char.isSpace xs + ( er1, er2, ec ) = + Text.foldl' + ( \ (r1,r2,c) -> \ case + '\n' -> (r1+1,r2,1) + '\r' -> (r1,r2+1,1) + '\t' -> (r1,r2,c+2) + '\f' -> (r1,r2,c) + '\v' -> (r1,r2,c) + _ -> (r1,r2,c+1) + ) + (sr,sr,sc) + ( x `Text.cons` ys ) + er = max er1 er2 + -> if er > sr + then Located ( Span sr sc er ec ) ( TokWhitespace True ) : go er ec rest + else Located ( Span sr sc er ec ) ( TokWhitespace False ) : go er ec rest + -- Special characters. + | isSpecial x + -> Located ( Span sr sc sr ( sc + 1 ) ) ( TokSpecial x ) + : go sr ( sc + 1 ) xs + -- Alphabetic identifier. + | Char.isAlpha x + , let + ( ys, rest ) = Text.span ( \case { '\'' -> True; '_' -> True; y | Char.isAlphaNum y -> True; _ -> False } ) xs + tok = x `Text.cons` ys + l = Text.length tok + -> Located ( Span sr sc sr ( sc + l ) ) ( TokAlphabetic tok ) + : go sr ( sc + l ) rest + -- Numeric identifier. + | Just ( locTok@Located { location = Span { endRow, endCol } }, rest ) <- tokenizeNumeric sr sc t + -> locTok + : go endRow endCol rest + -- Wildcard. + | '_' <- x + , let + ( ys, rest ) = Text.span ( \case { '_' -> True; y | Char.isAlphaNum y -> True; _ -> False } ) xs + tok :: Text + tok = x `Text.cons` ys + l = Text.length tok + -> Located ( Span sr sc sr ( sc + l ) ) ( TokWildcard tok ) + : go sr ( sc + l ) rest + -- Symbolic identifier. + | Char.isSymbol x || Char.isPunctuation x + , let + ( ys, rest ) = Text.break ( \ c -> isSpecial c || Char.isSpace c || Char.isAlphaNum c ) xs + tok = x `Text.cons` ys + l = Text.length tok + -> Located ( Span sr sc sr ( sc + l ) ) ( TokSymbolic tok ) + : go sr ( sc + l ) rest + -- Fallback. + | let + ( ys, rest ) = Text.break ( \ c -> isSpecial c || Char.isSpace c ) xs + tok = x `Text.cons` ys + l = Text.length tok + -> Located ( Span sr sc sr ( sc + l ) ) ( OtherTok tok ) + : go sr ( sc + l ) rest + +-- Tokenize a numeric literal (without any leading sign). +tokenizeNumeric :: Int -> Int -> Text -> Maybe ( Located Token, Text ) +tokenizeNumeric sr sc t = case Text.span Char.isDigit t of + -- Integer part of the mantissa. + ( integ, rest ) + | not ( Text.null integ ) + -> case Text.uncons rest of + Just ( c, rest' ) + -- Fraction. + | c == '.' + -> + -- Fractional part of the mantissa. + let ( frac, rest'' ) = Text.span Char.isDigit rest' + in case Text.uncons rest'' of + Just ( c', rest''' ) + -- Fraction followed by exponent. + | c' == 'e' || c' == 'E' + , Just ( expo, rest'''' ) <- spanExponent rest''' + , Right ( r, leftover ) <- Text.Read.double ( integ <> "." <> frac <> "e" <> expo ) + , Text.null leftover + , let + l = Text.length integ + 1 + Text.length frac + 1 + Text.length expo + -> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest'''' ) + -- Simple fraction (no exponent). + _ | Right ( r, leftover ) <- Text.Read.double ( integ <> "." <> frac ) + , Text.null leftover + , let + l = Text.length integ + 1 + Text.length frac + -> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest'' ) + _ -> Nothing + -- Positive integer followed by exponent. + | c == 'e' || c == 'E' + , Just ( expo, rest'' ) <- spanExponent rest' + , Right ( r, leftover ) <- Text.Read.double ( integ <> "e" <> expo ) + , Text.null leftover + , let + l = Text.length integ + 1 + Text.length expo + -> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest'' ) + -- Simple positive integer (no fractional part or exponent). + _ | Right ( r, leftover ) <- Text.Read.double integ + , Text.null leftover + , let + l = Text.length integ + -> Just ( Located ( Span sr sc sr ( sc + l ) ) ( TokNumeric r ), rest ) + _ -> Nothing + _ -> Nothing + +spanExponent :: Text -> Maybe ( Text, Text ) +spanExponent t = case Text.uncons t of + Just ( x, xs ) + | x == '+' || x == '-' || Char.isDigit x + , let + ( ds, rest ) = Text.span Char.isDigit xs + -> Just ( Text.cons x ds, rest ) + _ -> Nothing diff --git a/src/app/MetaBrush/MetaParameter/PrimOp.hs b/src/app/MetaBrush/MetaParameter/PrimOp.hs new file mode 100644 index 0000000..b045b4d --- /dev/null +++ b/src/app/MetaBrush/MetaParameter/PrimOp.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DerivingStrategies #-} + +module MetaBrush.MetaParameter.PrimOp where + +-- MetaBrush +import Math.Vector2D + ( Point2D(..) ) + +-------------------------------------------------------------------------------- +-- Operations supported by the DSL. + +data Orientation = CCW | CW + deriving stock Show + +kappa :: Double +kappa = 0.5519150244935105707435627227925 +-- root of (Sqrt[2] (4 + 3 κ) - 16) (2 - 3 κ)^2 - 8 (1 - 3 κ) Sqrt[8 - 24 κ + 12 κ^2 + 8 κ^3 + 3 κ^4] + +rotate_around_by :: Orientation -> Point2D Double -> Point2D Double -> Double -> Point2D Double +rotate_around_by ori ( Point2D px py ) ( Point2D cx cy ) theta = + translate_by ( rotate_by ori ( Point2D ( px - cx ) ( py - cy ) ) theta ) ( Point2D cx cy ) +rotate_by :: Orientation -> Point2D Double -> Double -> Point2D Double +rotate_by CCW ( Point2D px py ) theta = Point2D ( c * px - s * py ) ( c * py + s * px ) + where + c, s :: Double + c = cos theta + s = sin theta +rotate_by CW p theta = rotate_by CCW p ( -theta ) + +scale_around_by :: Point2D Double -> Point2D Double -> Point2D Double -> Point2D Double +scale_around_by ( Point2D px py ) ( Point2D cx cy ) ( Point2D rx ry ) = Point2D ( rx * ( px - cx ) + cx ) ( ry * ( py - cy ) + cy ) +scale_by :: Point2D Double -> Point2D Double -> Point2D Double +scale_by ( Point2D px py ) ( Point2D rx ry ) = Point2D ( rx * px ) ( ry * py ) + +shear_from_by :: Point2D Double -> Point2D Double -> Point2D Double -> Point2D Double +shear_from_by ( Point2D px py ) ( Point2D cx cy ) v = + translate_by ( shear_by ( Point2D ( px - cx ) ( py - cy ) ) v ) ( Point2D cx cy ) +shear_by :: Point2D Double -> Point2D Double -> Point2D Double +shear_by ( Point2D px py ) ( Point2D vx vy ) = undefined + +translate_by :: Point2D Double -> Point2D Double -> Point2D Double +translate_by ( Point2D px py ) ( Point2D tx ty ) = Point2D ( px + tx ) ( py + ty ) diff --git a/src/app/MetaBrush/MetaParameter/Rename.hs b/src/app/MetaBrush/MetaParameter/Rename.hs new file mode 100644 index 0000000..4eea648 --- /dev/null +++ b/src/app/MetaBrush/MetaParameter/Rename.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module MetaBrush.MetaParameter.Rename + ( rename, MonadRn, RnM + , RnMessage, RnError + , RnState, emptyRnState + , Env(..), UniqueName(..) + ) + where + +-- base +import Data.Foldable + ( for_ ) +import GHC.Generics + ( Generic ) + +-- containers +import Data.Map.Strict + ( Map ) +import qualified Data.Map.Strict as Map + ( lookup ) + +-- dlist +import Data.DList + ( DList ) +import qualified Data.DList as DList + ( singleton ) + +-- generic-lens +import Data.Generics.Product.Fields + ( field' ) + +-- lens +import Control.Lens + ( assign, at, modifying, use ) + +-- mtl +import Control.Monad.State + ( MonadState(..) ) +import Control.Monad.Writer + ( MonadWriter(..) ) + +-- text +import Data.Text + ( Text ) + +-- transformers +import Control.Monad.Trans.RWS.CPS + ( RWST ) + +-- MetaBrush +import Math.Bezier.Spline + ( KnownSplineType(bitraverseSpline), bitraverseCurve ) +import MetaBrush.MetaParameter.AST + ( Located(..) + , Pass(P,Rn), Name, UniqueName(..), X_With(..) + , Term(..), Decl(..), Pat(..) + ) +import MetaBrush.MetaParameter.Parse + ( ) -- AST type family instances for parsing pass +import MetaBrush.Unique + ( UniqueSupply, MonadUnique(freshUnique) + , Unique + ) + +-------------------------------------------------------------------------------- +-- Renaming pass. + +rename :: MonadRn m => Term P '() -> m ( Term Rn '() ) +rename ( f :$ a ) = (:$) <$> locally ( rename f ) <*> locally ( rename a ) +rename ( Var locv@( Located l v ) ) = do + mbRes <- use ( field' @"localEnv" . field' @"rnLocalVars" . at v ) + case mbRes of + Nothing -> do + rnError ( OutOfScope locv ) + uniq' <- freshUnique + pure $ Var ( Located l ( UniqueName v uniq' ) ) + Just uniq -> + pure $ Var ( Located l ( UniqueName v uniq ) ) +rename ( Lit l a ) = pure ( Lit l a ) +rename ( Op locs nm op ) = pure ( Op locs nm op ) +rename ( Point locs a b ) = Point locs <$> locally ( rename a ) <*> locally ( rename b ) +rename ( Line locs p1 p2 ) = Line locs <$> locally ( rename p1 ) <*> locally ( rename p2 ) +rename ( Bez2 locs p1 p2 p3 ) = Bez2 locs <$> locally ( rename p1 ) <*> locally ( rename p2 ) <*> locally ( rename p3 ) +rename ( Bez3 locs p1 p2 p3 p4 ) = Bez3 locs <$> locally ( rename p1 ) <*> locally ( rename p2 ) <*> locally ( rename p3 ) <*> locally ( rename p4 ) +rename ( PolyBez locs spline ) = PolyBez locs <$> + bitraverseSpline + ( const $ bitraverseCurve pure ( const $ locally . rename ) ) + ( locally . rename ) + spline +rename ( Let locs decls body ) = do + decls' <- renameDecls decls + body' <- rename body + pure ( Let locs decls' body' ) +rename ( With locs ( P_With decls ) conds body ) = do + decls' <- renameDecls decls + conds' <- traverse ( locally . rename ) conds + body' <- rename body + pure ( With locs ( Rn_With decls' ) conds' body' ) + +renameDecls :: forall m. MonadRn m => [ Decl P ] -> m [ Decl Rn ] +renameDecls decls = do + outerLocalVars <- use ( field' @"localEnv" . field' @"rnLocalVars" ) + assign ( field' @"localEnv" . field' @"rnLocalVars" ) mempty + decls' <- go outerLocalVars decls + pure decls' + + where + + go :: Map Text Unique -> [ Decl P ] -> m [ Decl Rn ] + go outerLocalVars ( Decl loc lhs rhs : next ) = do + -- Collect all the declarations from the left-hand sides. + lhs' <- renameLhs outerLocalVars lhs + next' <- go outerLocalVars next + -- Now rename each right-hand side with the full LHS info. + rhs' <- locally ( rename rhs ) + pure $ Decl loc lhs' rhs' : next' + go outerLocalVars [] = do + -- Finished handling all the left-hand sides: + -- add all the declared names to the existing (outer) names, + -- shadowing the outer names if necessary. + modifying ( field' @"localEnv" . field' @"rnLocalVars" ) ( <> outerLocalVars ) + pure [] + + renameLhs :: Map Text Unique -> Pat P '() -> m ( Pat Rn '() ) + renameLhs outerLocalVars ( PName locPat@( Located l nm ) ) = do + mbUniq <- use ( field' @"localEnv" . field' @"rnLocalVars" . at nm ) + case mbUniq of + Just uniq -> do + rnError ( DuplicateDecl uniq locPat ) + uniq' <- freshUnique + pure $ PName ( Located l ( UniqueName nm uniq' ) ) + Nothing -> do + let + mbPrevUniq :: Maybe Unique + mbPrevUniq = Map.lookup nm outerLocalVars + uniq <- freshUnique + for_ mbPrevUniq \ prevUniq -> do + rnWarning ( NameShadowing prevUniq ( Located l ( UniqueName nm uniq ) ) ) + assign ( field' @"localEnv" . field' @"rnLocalVars" . at nm ) ( Just uniq ) + assign ( field' @"globalEnv" . field' @"rnGlobalVars" . at uniq ) ( Just locPat ) + pure $ PName ( Located l ( UniqueName nm uniq ) ) + renameLhs outerLocalVars ( PPoint l p1 p2 ) = PPoint l <$> renameLhs outerLocalVars p1 <*> renameLhs outerLocalVars p2 + renameLhs _ ( PWild wild ) = pure ( PWild wild ) + renameLhs outerLocalVars ( AsPat atLoc locName pat ) = do + name' <- renameLhs outerLocalVars ( PName locName ) + case name' of + PName locName' -> do + pat' <- renameLhs outerLocalVars pat + pure $ AsPat atLoc locName' pat' + _ -> error "renameLHS: internal error" + + +-------------------------------------------------------------------------------- +-- Renamer-specific data and instances. + +data RnLocalEnv + = RnLocalEnv + { rnLocalVars :: !( Map Text Unique ) } + deriving stock ( Show, Generic ) + +data RnGlobalEnv + = RnGlobalEnv + { rnGlobalVars :: !( Map Unique ( Located Text ) ) } + deriving stock ( Show, Generic ) + +data Env global local + = Env + { globalEnv :: !global + , localEnv :: !local + } + deriving stock ( Show, Generic ) + +type RnState = Env RnGlobalEnv RnLocalEnv + +emptyRnState :: RnState +emptyRnState = Env ( RnGlobalEnv mempty ) ( RnLocalEnv mempty ) + +locally :: MonadState ( Env global local ) m => m a -> m a +locally action = do + Env { localEnv } <- get + res <- action + assign ( field' @"localEnv" ) localEnv + pure res + +data RnMessage + = RnWarningMessage + { rnWarningMessage :: !RnWarning + , rnMessageState :: !RnState + } + | RnErrorMessage + { rnErrorMessage :: !RnError + , rnMessageState :: !RnState + } + deriving stock ( Show, Generic ) + +data RnError + = OutOfScope !( Located Text ) + | DuplicateDecl + { prevDecl :: !Unique + , dupDecl :: !( Located Text ) + } + deriving stock ( Show, Generic ) + +data RnWarning + = NameShadowing + { shadowedUnique :: !Unique + , shadowingName :: !( Located UniqueName ) + } + deriving stock ( Show, Generic ) + +rnError + :: ( MonadState RnState m , MonadWriter ( DList RnMessage ) m ) + => RnError -> m () +rnError err = do + st <- get + tell ( DList.singleton $ RnErrorMessage err st ) + +rnWarning + :: ( MonadState RnState m , MonadWriter ( DList RnMessage ) m ) + => RnWarning -> m () +rnWarning warn = do + st <- get + tell ( DList.singleton $ RnWarningMessage warn st ) + +type RnM = RWST UniqueSupply ( DList RnMessage ) RnState IO +type MonadRn m = ( MonadUnique m, MonadState RnState m, MonadWriter ( DList RnMessage ) m ) + +type instance Name Rn = UniqueName diff --git a/src/app/MetaBrush/MetaParameter/TypeCheck.hs b/src/app/MetaBrush/MetaParameter/TypeCheck.hs new file mode 100644 index 0000000..b1ebe4a --- /dev/null +++ b/src/app/MetaBrush/MetaParameter/TypeCheck.hs @@ -0,0 +1,446 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + +module MetaBrush.MetaParameter.TypeCheck + ( typeCheck, MonadTc, TcM + , TcMessage, TcError + , TcState, emptyTcState + ) + where + +import Data.Kind + ( Type ) + +-- base +import Data.Either + ( partitionEithers ) +import Data.Functor.Compose + ( Compose(..) ) +import Data.List + ( sortBy ) +import Data.Ord + ( comparing ) +import Data.Proxy + ( Proxy ) +import Data.Type.Equality + ( (:~:)(Refl) ) +import GHC.Exts + ( Proxy#, proxy# ) +import GHC.Generics + ( Generic ) +import GHC.TypeLits + ( someSymbolVal, SomeSymbol(..) ) +import GHC.TypeNats + ( KnownNat ) +import Unsafe.Coerce + ( unsafeCoerce ) + +-- containers +import Data.Map.Strict + ( Map ) +import Data.Sequence + ( Seq(..) ) + +-- dlist +import Data.DList + ( DList ) + +-- generic-lens +import Data.Generics.Product.Fields + ( field' ) + +-- lens +import Control.Lens + ( assign, at, use ) + +-- mtl +import Control.Monad.Except + ( MonadError(..) ) +import Control.Monad.State + ( MonadState(..) ) +import Control.Monad.Writer + ( MonadWriter(..) ) + +-- superrecord +import qualified SuperRecord as Super + ( Rec ) +import qualified SuperRecord + ( (:=)(..), FldProxy(..), RecSize, RecApply + , RecTy, RemoveAccessTo, RecVecIdxPos + , TraversalCHelper + , unsafeRNil, unsafeRCons + ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + ( unpack ) + +-- transformers +import Control.Monad.Trans.RWS.CPS + ( RWST ) +import Control.Monad.Trans.Except + ( ExceptT ) + +-- MetaBrush +import Math.Bezier.Spline + ( Spline(..), Curve(..), Curves(..) + , SSplineType(..), SplineTypeI(ssplineType) + , bitraverseCurve, KnownSplineType(bitraverseSpline) + , NextPoint(..) + ) +import Math.Vector2D + ( Point2D(..) ) +import MetaBrush.MetaParameter.AST + ( Span(..), Located(..) + , Pass(Rn,Tc) + , Pat(..), Decl(..) + , X_With(..), MapFields + , UniqueTerm, UniqueField(..), IsUniqueTerm, IsUniqueTerm2 + , SType(..), STypeI(sTypeI), SomeSType(..) + , STypes(..), STypesI(..) + , Term(..), TypedTerm(..), eqTy + , termSpan + ) +import MetaBrush.MetaParameter.Rename + ( Env(..), UniqueName(..) ) +import MetaBrush.Unique + ( UniqueSupply, MonadUnique, Unique ) + +-------------------------------------------------------------------------------- + +typeCheckAt + :: forall ( a :: Type ) m + . ( STypeI a, MonadTc m ) + => Text + -> Term Rn '() -> m ( Term Tc a ) +typeCheckAt mismatchMessage term = do + TypedTerm ( x :: Term Tc x ) <- typeCheck term + case eqTy @a @x of + Just Refl -> pure x + Nothing -> + tcError $ + UnexpectedType + mismatchMessage + ( "Expected: ", SomeSType ( proxy# :: Proxy# a ) ) + ( " Actual: ", Located ( termSpan term ) $ SomeSType ( proxy# :: Proxy# x ) ) + +typeCheck :: forall m. MonadTc m => Term Rn '() -> m TypedTerm +typeCheck ( uf :$ ua ) = do + TypedTerm ( f :: Term Tc f ) <- typeCheck uf + case sTypeI @f of + sFunTy@SFunTy | ( _ :: SType ( b -> c ) ) <- sFunTy + -> do + TypedTerm ( a :: Term Tc a ) <- typeCheck ua + case eqTy @a @b of + Just Refl -> pure ( TypedTerm @c ( f :$ a ) ) + Nothing -> tcError $ + UnexpectedType + "Unexpected function argument type" + ( "Expected: ", SomeSType ( proxy# :: Proxy# b ) ) + ( " Actual: ", Located ( termSpan ua ) $ SomeSType ( proxy# :: Proxy# a ) ) + _ -> tcError $ + OverSaturatedFunctionApplication + ( Located ( termSpan uf ) ( SomeSType ( proxy# :: Proxy# f ) ) ) + ( termSpan ua ) +typeCheck ( Var locVar@( Located _ ( UniqueName _ uniq ) ) ) = do + mbType <- use ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq ) + case mbType of + Just ( SomeSType ( _ :: Proxy# a ) ) -> pure ( TypedTerm ( Var locVar :: Term Tc a ) ) + Nothing -> tcError ( OutOfScope locVar ) +typeCheck ( Let loc decls body ) = do + decls' <- typeCheckDecls decls + TypedTerm body' <- typeCheck body + pure ( TypedTerm $ Let loc decls' body' ) +typeCheck ( With locs ( Rn_With decls ) conds body ) = do + decls' <- typeCheckDecls decls + conds' <- traverse ( typeCheckAt @Bool "Expected Boolean condition, but expression has the wrong type." ) conds + TypedTerm body' <- typeCheck body + withDeclsRecord decls' \ ( decls'Record :: Super.Rec ( MapFields UniqueTerm kvs ) ) -> do + case unsafeCoerce Refl :: SuperRecord.RecSize ( MapFields UniqueTerm kvs ) :~: SuperRecord.RecSize kvs of + Refl -> + case treeArgsDict @kvs @kvs of + RecTreeArgsDict -> + TypedTerm $ With locs ( Tc_With decls'Record ) conds' body' +typeCheck ( Lit loc a ) = pure ( TypedTerm $ Lit loc a ) +typeCheck ( Op locs nm op ) = pure ( TypedTerm $ Op locs nm op ) +typeCheck ( Point locs a b ) = do + TypedTerm ( a' :: Term Tc a ) <- typeCheck a + TypedTerm ( b' :: Term Tc b ) <- typeCheck b + case eqTy @a @b of + Just Refl -> pure ( TypedTerm $ Point locs a' b' ) + Nothing -> + tcError $ + MismatchedTypes + "Components of a point with different types." + ( "1st component: ", Located ( termSpan a ) ( SomeSType ( proxy# :: Proxy# a ) ) ) + ( "2nd component: ", Located ( termSpan b ) ( SomeSType ( proxy# :: Proxy# b ) ) ) +typeCheck ( Line {} ) = error "typeCheck: error, unexpected 'line'" +typeCheck ( Bez2 {} ) = error "typeCheck: error, unexpected 'bez2'" +typeCheck ( Bez3 {} ) = error "typeCheck: error, unexpected 'bez3'" +typeCheck ( PolyBez locs spline@( Spline { splineStart, splineCurves } :: Spline clo [ Located () ] ( Term Rn '() ) ) ) = do + TypedTerm ( start' :: Term Tc pt ) <- typeCheck splineStart + case sTypeI @pt of + sTy@STyPoint + | ( _ :: SType ( Point2D a ) ) <- sTy + -> case sTypeI @a of + STyDouble -> let + tcPoint :: Term Rn '() -> m ( Term Tc pt ) + tcPoint = typeCheckAt @pt "Unexpected Bézier spline coordinate type" + in case ssplineType @clo of + SClosed -> do + spline' <- + bitraverseSpline + ( const $ bitraverseCurve pure ( const tcPoint ) ) tcPoint spline + pure ( TypedTerm $ PolyBez locs spline' ) + SOpen -> case splineCurves of + OpenCurves Empty -> + pure ( TypedTerm $ PolyBez locs ( Spline start' ( OpenCurves Empty ) ) ) + OpenCurves ( crv :<| Empty ) -> case crv of + LineTo ( NextPoint p1 ) _ -> do + p1' <- tcPoint p1 + pure ( TypedTerm $ Line locs start' p1' ) + Bezier2To p1 ( NextPoint p2 ) _ -> do + p1' <- tcPoint p1 + p2' <- tcPoint p2 + pure ( TypedTerm $ Bez2 locs start' p1' p2' ) + Bezier3To p1 p2 ( NextPoint p3 ) _ -> do + p1' <- tcPoint p1 + p2' <- tcPoint p2 + p3' <- tcPoint p3 + pure ( TypedTerm $ Bez3 locs start' p1' p2' p3' ) + OpenCurves crvs -> do + crvs' <- traverse ( traverse tcPoint ) crvs + pure ( TypedTerm $ PolyBez locs ( Spline start' ( OpenCurves crvs' ) ) ) + _ -> + tcError $ + UnexpectedType + "Unexpected Bézier spline coordinate type" + ( "Expected: ", SomeSType ( proxy# :: Proxy# Double ) ) + ( " Actual: ", Located ( termSpan splineStart ) $ SomeSType ( proxy# :: Proxy# a ) ) + _ -> tcError $ + UnexpectedType + "Unexpected Bézier spline point type" + ( "Expected: ", SomeSType ( proxy# :: Proxy# ( Point2D Double ) ) ) + ( " Actual: ", Located ( termSpan splineStart ) $ SomeSType ( proxy# :: Proxy# pt ) ) + +typeCheckDecls :: forall m. MonadTc m => [ Decl Rn ] -> m [ Decl Tc ] +typeCheckDecls = go [] + where + go :: [ Decl Tc ] -> [ Decl Rn ] -> m [ Decl Tc ] + go dones [] = pure dones + go dones todos = do + + ( not_oks, oks ) <- + partitionEithers + <$> traverse + ( \ decl -> ( `catchError` ( catchOutOfScope decl ) ) ( fmap Right $ typeCheckDecl decl ) ) + todos + case oks of + [] -> traverse ( throwError . snd ) not_oks + _ -> go ( dones ++ oks ) ( fmap fst not_oks ) + + catchOutOfScope :: Decl Rn -> TcError -> m ( Either ( Decl Rn, TcError ) ( Decl Tc ) ) + catchOutOfScope decl err@( OutOfScope {} ) = pure ( Left ( decl, err ) ) + catchOutOfScope _ err = throwError err + +typeCheckDecl :: MonadTc m => Decl Rn -> m ( Decl Tc ) +typeCheckDecl ( Decl loc lhs rhs ) = do + TypedTerm ( rhs' :: Term Tc a ) <- typeCheck rhs + lhs' <- typeCheckPatAt @a lhs + pure ( Decl loc lhs' rhs' ) + +typeCheckPatAt :: forall ( a :: Type ) m. ( STypeI a, MonadTc m ) => Pat Rn '() -> m ( Pat Tc a ) +typeCheckPatAt ( PName nm@( Located _ ( UniqueName _ uniq ) ) ) = do + assign ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq ) ( Just $ SomeSType ( proxy# :: Proxy# a ) ) + pure ( PName nm ) +typeCheckPatAt ( PPoint locs pat1 pat2 ) = case sTypeI @a of + sTyPair@STyPoint | ( _ :: SType ( Point2D c ) ) <- sTyPair + -> do + pat1' <- typeCheckPatAt @c pat1 + pat2' <- typeCheckPatAt @c pat2 + pure ( PPoint locs pat1' pat2' ) + _ -> tcError $ + UnexpectedPatType + "RHS of let binding does not have the expected type" + ( "Expected type: ", Located ( foldMap location locs ) $ SomeSType ( proxy# :: Proxy# ( Point2D Double ) ) ) + ( " Actual type: ", SomeSType ( proxy# :: Proxy# a ) ) +typeCheckPatAt ( PWild nm ) = pure ( PWild nm ) +typeCheckPatAt ( AsPat symbLoc nm@( Located _ ( UniqueName _ uniq ) ) pat ) = do + pat' <- typeCheckPatAt @a pat + assign ( field' @"globalEnv" . field' @"tcGlobalVarTys" . at uniq ) ( Just $ SomeSType ( proxy# :: Proxy# a ) ) + pure ( AsPat symbLoc nm pat' ) + +withDeclsRecord + :: forall r m + . ( MonadTc m ) + => [ Decl Tc ] + -> ( forall kvs. STypesI kvs => Super.Rec ( MapFields UniqueTerm kvs ) -> r ) + -> m r +withDeclsRecord decls f = do + TypedTermsRecord record <- go ( TypedTermsRecord $ SuperRecord.unsafeRNil lg ) <$> ( revSortDecls decls ) + pure ( f record ) + where + lg :: Int + lg = length decls + -- This list cannot have duplicate names, + -- as these would have been caught by the renamer. + -- Sort in reverse order as we must add elements in decreasing label order. + revSortDecls :: [ Decl Tc ] -> m [ ( Text, ( UniqueName, TypedTerm ) ) ] + revSortDecls = fmap ( sortBy ( flip $ comparing fst ) ) . traverse getDeclName + getDeclName :: Decl Tc -> m ( Text, ( UniqueName, TypedTerm ) ) + getDeclName ( Decl ( Located loc _ ) pat term ) = case pat of + PName ( Located _ uniq@( UniqueName nm _ ) ) -> pure ( nm, ( uniq, TypedTerm term ) ) + AsPat _ ( Located _ uniq@( UniqueName nm _ ) ) _ -> pure ( nm, ( uniq, TypedTerm term ) ) + _ -> tcError $ NoPatternName loc + go :: TypedTermsRecord -> [ ( Text, ( UniqueName, TypedTerm ) ) ] -> TypedTermsRecord + go record [] = record + go ( TypedTermsRecord ( record :: Super.Rec ( MapFields UniqueTerm kvs ) ) ) + ( ( nm, ( uniq, TypedTerm ( t :: Term Tc a ) ) ) : ps ) + = case someSymbolVal ( Text.unpack nm ) of + SomeSymbol ( _ :: Proxy nm ) -> + go + ( TypedTermsRecord @( ( nm SuperRecord.:= a ) ': kvs ) + $ SuperRecord.unsafeRCons @nm @( UniqueTerm a ) @( MapFields UniqueTerm kvs ) + ( SuperRecord.FldProxy @nm SuperRecord.:= Compose ( UniqueField uniq t ) ) + record + ) + ps + +data TypedTermsRecord where + TypedTermsRecord + :: ( STypesI kvs, ts ~ MapFields UniqueTerm kvs, KnownNat ( SuperRecord.RecSize ts ) ) + => Super.Rec ts -> TypedTermsRecord + +data RecTreeArgsDict rts lts where + RecTreeArgsDict + :: forall rts lts trts tlts frts flts + . ( trts ~ MapFields UniqueTerm rts, tlts ~ MapFields UniqueTerm lts + , frts ~ MapFields UniqueField rts, flts ~ MapFields UniqueField lts + , SuperRecord.RecApply trts tlts IsUniqueTerm + , SuperRecord.TraversalCHelper flts trts frts IsUniqueTerm2 + ) + => RecTreeArgsDict rts lts + +treeArgsDict + :: forall rts lts trts tlts frts flts + . ( trts ~ MapFields UniqueTerm rts, tlts ~ MapFields UniqueTerm lts + , frts ~ MapFields UniqueField rts, flts ~ MapFields UniqueField lts + , STypesI lts + , KnownNat ( SuperRecord.RecSize rts ) + ) + => RecTreeArgsDict rts lts +treeArgsDict = case sTypesI @lts of + STyNil + | Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize frts :~: SuperRecord.RecSize rts ) + -> RecTreeArgsDict + sTyCons@STyCons + | ( _ :: STypes ( ( l SuperRecord.:= v ) ': lvs ) ) <- sTyCons + , Refl <- ( unsafeCoerce Refl :: MapFields UniqueTerm lvs :~: SuperRecord.RemoveAccessTo l ( MapFields UniqueTerm lvs ) ) + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecTy l trts :~: Just ( UniqueTerm v ) ) + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecVecIdxPos l trts :~: SuperRecord.RecSize lvs ) + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize trts :~: SuperRecord.RecSize rts ) + , Refl <- ( unsafeCoerce Refl :: SuperRecord.RecSize lvs :~: SuperRecord.RecSize ( MapFields UniqueField lvs ) ) + -> case treeArgsDict @rts @lvs of + RecTreeArgsDict -> RecTreeArgsDict + + +-------------------------------------------------------------------------------- +-- Type-checker-specific data and instances. + +data TcLocalEnv + = TcLocalEnv + deriving stock ( Show, Generic ) + +data TcGlobalEnv + = TcGlobalEnv + { tcGlobalVarTys :: !( Map Unique SomeSType ) + , tyGlovalVars :: !( Map Unique ( Located Text ) ) + } + deriving stock ( Show, Generic ) + +data TcMessage + = TcWarningMessage + { tcWarningMessage :: !TcWarning + , tcMessageState :: !TcState + } + | TcErrorMessage + { tcErrorMessage :: !TcError + , tcMessageState :: !TcState + } + deriving stock ( Show, Generic ) + +data TcError + = MismatchedTypes + { additionalErrorText :: !Text + , expectedLType :: !( Text, Located SomeSType ) + , actualLType :: !( Text, Located SomeSType ) + } + | UnexpectedType + { additionalErrorText :: !Text + , expectedType :: !( Text, SomeSType ) + , actualLType :: !( Text, Located SomeSType ) + } + | UnexpectedPatType + { additionaLErrorText :: !Text + , expectedPatType :: !( Text, Located SomeSType ) + , actualRHSType :: !( Text, SomeSType ) + } + | OverSaturatedFunctionApplication + { functionLType :: !( Located SomeSType ) + , argument :: !Span + } + | NoPatternName + { declarationSpan :: !Span + } + | OutOfScope + { outOfScopeVar :: !( Located UniqueName ) } + deriving stock ( Show, Generic ) + +data TcWarning = TcWarning + deriving stock ( Show, Generic ) + +type TcState = Env TcGlobalEnv TcLocalEnv + +emptyTcState :: TcState +emptyTcState = Env ( TcGlobalEnv mempty mempty ) TcLocalEnv + +type TcM = ExceptT TcError ( RWST UniqueSupply ( DList TcMessage ) TcState IO ) +type MonadTc m = + ( MonadUnique m + , MonadState TcState m + , MonadWriter ( DList TcMessage ) m + , MonadError TcError m + ) + +tcError + :: ( MonadError TcError m ) + => TcError -> m a +tcError err = throwError err + +{- +tcWarning + :: ( MonadState TcState m, MonadWriter ( DList TcMessage ) m ) + => TcWarning -> m () +tcWarning warn = do + st <- get + tell ( DList.singleton $ TcWarningMessage warn st ) +-} diff --git a/src/app/MetaBrush/Render/Document.hs b/src/app/MetaBrush/Render/Document.hs index 2f9f306..6b380ab 100644 --- a/src/app/MetaBrush/Render/Document.hs +++ b/src/app/MetaBrush/Render/Document.hs @@ -5,13 +5,16 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module MetaBrush.Render.Document ( renderDocument, blankRender ) @@ -28,8 +31,8 @@ import Data.Functor.Compose ( Compose(..) ) import Data.Int ( Int32 ) -import Data.Maybe - ( catMaybes ) +import GHC.Exts + ( Proxy#, proxy# ) import GHC.Generics ( Generic, Generic1 ) @@ -44,8 +47,6 @@ import Data.Act -- containers import Data.Sequence ( Seq(..) ) -import qualified Data.Sequence as Seq - ( fromList ) import Data.Set ( Set ) @@ -54,15 +55,21 @@ import Generic.Data ( Generically1(..) ) -- generic-lens -import Data.Generics.Product.Typed - ( HasType ) +import Data.Generics.Product.Fields + ( field' ) -- gi-cairo-render import qualified GI.Cairo.Render as Cairo -- lens import Control.Lens - ( view ) + ( view, set ) + +-- superrecord +import qualified SuperRecord as Super + ( Rec ) +import qualified SuperRecord + ( Intersect, rnil ) -- transformers import Control.Monad.Trans.Class @@ -77,8 +84,15 @@ import Math.Bezier.Cubic.Fit ( FitPoint(..), FitParameters ) import qualified Math.Bezier.Quadratic as Quadratic ( Bezier(..) ) +import Math.Bezier.Spline + ( Spline(..), SplinePts, PointType(..) + , SplineType(..), SplineTypeI, KnownSplineType(bifoldSpline) + , Curve(..) + , fromNextPoint + , catMaybesSpline + ) import Math.Bezier.Stroke - ( StrokePoint(..), stroke ) + ( CachedStroke(..), computeStrokeOutline ) import Math.Vector2D ( Point2D(..), Vector2D(..) ) import MetaBrush.Asset.Colours @@ -90,15 +104,23 @@ import MetaBrush.Context import MetaBrush.Document ( Document(..), DocumentContent(..) , mkAABB - , Stroke(..), FocusState(..) + , Stroke(..), StrokeSpline + , FocusState(..) , HoverContext(..), Hoverable(..) - , PointData(..), BrushPointData(..) + , PointData(..), Brush(..), emptyBrush , _selection + , coords ) import MetaBrush.Document.Selection ( dragUpdate ) +import MetaBrush.Document.Serialise + ( ) -- 'Serialisable' instances import MetaBrush.Document.Update ( DocChange(..) ) +import MetaBrush.MetaParameter.AST + ( AdaptableFunction(..), BrushFunction ) +import MetaBrush.MetaParameter.Interpolation + ( MapDiff ) import MetaBrush.UI.ToolBar ( Mode(..) ) import MetaBrush.Util @@ -127,25 +149,32 @@ toAll action = Compose ( pure action ) -------------------------------------------------------------------------------- blankRender :: Colours -> Cairo.Render () -blankRender ( Colours {..} ) = pure () +blankRender _ = pure () renderDocument :: Colours -> FitParameters -> Mode -> Bool -> ( Int32, Int32 ) -> Set Modifier -> Maybe ( Point2D Double ) -> Maybe HoldAction -> Maybe PartialPath -> Document - -> Cairo.Render () + -> ( Maybe Document, Cairo.Render () ) renderDocument - cols params mode debug ( viewportWidth, viewportHeight ) + cols fitParams mode debug ( viewportWidth, viewportHeight ) modifiers mbMousePos mbHoldEvent mbPartialPath doc@( Document { viewportCenter = Point2D cx cy, zoomFactor, documentContent = content } ) - = do + = ( mbUpdatedDoc, drawingInstructions ) - Cairo.save - Cairo.translate ( 0.5 + 0.5 * fromIntegral viewportWidth ) ( 0.5 + 0.5 * fromIntegral viewportHeight ) - Cairo.scale zoomFactor zoomFactor - Cairo.translate ( -cx ) ( -cy ) + where + + drawingInstructions :: Cairo.Render () + drawingInstructions = do + Cairo.save + Cairo.translate ( 0.5 + 0.5 * fromIntegral viewportWidth ) ( 0.5 + 0.5 * fromIntegral viewportHeight ) + Cairo.scale zoomFactor zoomFactor + Cairo.translate ( -cx ) ( -cy ) + for_ strokesWithOutlineInfo + ( compositeRenders . getCompose . renderStroke cols mbHoverContext mode debug zoomFactor ) + renderSelectionRect + Cairo.restore - let renderSelectionRect :: Cairo.Render () mbHoverContext :: Maybe HoverContext ( renderSelectionRect, mbHoverContext ) @@ -156,16 +185,19 @@ renderDocument = ( pure (), MouseHover <$> mbMousePos ) modifiedStrokes :: [ Stroke ] - modifiedStrokes - | Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent + noModifiedStrokes :: Bool + ( modifiedStrokes, noModifiedStrokes ) + | PathMode <- mode + , Just ( DragMoveHold { holdStartPos = p0, dragAction } ) <- mbHoldEvent , Just p1 <- mbMousePos , p0 /= p1 , let alternateMode :: Bool alternateMode = any ( \case { Alt _ -> True; _ -> False } ) modifiers - , Just docUpdate <- dragUpdate mode p0 p1 dragAction alternateMode doc - = strokes . documentContent $ newDocument docUpdate - | Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath + , Just docUpdate <- dragUpdate p0 p1 dragAction alternateMode doc + = ( strokes . documentContent $ newDocument docUpdate, False ) + | PathMode <- mode + , Just ( PartialPath p0 cp0 _ _ ) <- mbPartialPath , let mbFinalPoint :: Maybe ( Point2D Double ) mbControlPoint :: Maybe ( Point2D Double ) @@ -176,139 +208,210 @@ renderDocument = ( mbMousePos, Nothing ) , Just finalPoint <- mbFinalPoint , let - previewPts :: Seq ( StrokePoint PointData ) - previewPts - = Seq.fromList - $ catMaybes - [ Just ( PathPoint p0 ( PointData Normal Empty ) ) - , do + previewSpline :: Spline Open CachedStroke ( PointData ( Super.Rec '[] ) ) + previewSpline = catMaybesSpline ( CachedStroke Nothing ) + ( PointData p0 Normal SuperRecord.rnil ) + ( do cp <- cp0 guard ( cp /= p0 ) - pure $ ControlPoint cp ( PointData Normal Empty ) - , do + pure ( PointData cp Normal SuperRecord.rnil ) + ) + ( do cp <- mbControlPoint guard ( cp /= finalPoint ) - pure $ ControlPoint cp ( PointData Normal Empty ) - , Just ( PathPoint finalPoint ( PointData Normal Empty ) ) - ] - = ( Stroke { strokePoints = previewPts, strokeVisible = True, strokeUnique = undefined, strokeName = undefined } ) - : strokes content + pure ( PointData cp Normal SuperRecord.rnil ) + ) + ( PointData finalPoint Normal SuperRecord.rnil ) + = ( ( Stroke + { strokeSpline = previewSpline + , strokeVisible = True + , strokeUnique = undefined + , strokeName = undefined + , strokeBrush = emptyBrush + } + ) + : strokes content + , False + ) | otherwise - = strokes content - - for_ modifiedStrokes ( compositeRenders . getCompose . renderStroke cols mbHoverContext params mode debug zoomFactor ) - renderSelectionRect + = ( strokes content, True ) - Cairo.restore - - pure () + strokesWithOutlineInfo :: [ ( Stroke, Maybe ( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed ), Seq FitPoint ) ) ] + strokesWithOutlineInfo = + fmap + ( \ stroke@( + Stroke + { strokeSpline = spline :: StrokeSpline clo ( Super.Rec pointFields ) + , strokeBrush = + strokeBrush@( + BrushData { brushFunction = ( AdaptableFunction brushFn ) :: BrushFunction brushFields } + ) + , .. + } ) -> + if strokeVisible + then + case ( proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields ) ) of + ( _ :: Proxy# usedFields ) -> + let + -- Get the adaptable brush shape (function), + -- specialising it to the type we are using. + toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields + brushShapeFn :: Super.Rec usedFields -> SplinePts Closed + ( toUsedParams, brushShapeFn ) = brushFn @pointFields @usedFields -renderStroke :: Colours -> Maybe HoverContext -> FitParameters -> Mode -> Bool -> Double -> Stroke -> Compose Renders Cairo.Render () -renderStroke cols@( Colours { brush } ) mbHoverContext params mode debug zoom ( Stroke { strokePoints = pts, strokeVisible } ) - | strokeVisible - = renderStrokePoints cols mode mbHoverContext zoom - ( when ( mode == Brush ) . renderBrushShape ( cols { path = brush } ) mbHoverContext ( 1.5 * zoom ) ) - pts - *> Compose blank { renderStrokes = drawStroke cols debug zoom ( stroke params pts ) } - | otherwise - = pure () + -- Compute the outline using the brush function. + newSpline :: Spline clo CachedStroke ( PointData ( Super.Rec pointFields ) ) + outline :: Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed ) + fitPts :: Seq FitPoint + ( newSpline, outline, fitPts ) = + computeStrokeOutline @( Super.Rec ( MapDiff usedFields ) ) @clo @( Super.Rec usedFields ) + fitParams ( toUsedParams . brushParams ) brushShapeFn spline + in ( Stroke { strokeSpline = newSpline, .. } , Just ( outline, fitPts ) ) + else ( stroke , Nothing ) + ) + modifiedStrokes + + mbUpdatedDoc :: Maybe Document + mbUpdatedDoc + | noModifiedStrokes + = let + newDoc :: Document + newDoc = + set ( field' @"documentContent" . field' @"strokes" ) + ( modifiedStrokes ) + doc + in Just newDoc + | otherwise + = Nothing -- TODO: update the original document in this case too (by undoing the modifications) + + +renderStroke + :: Colours -> Maybe HoverContext -> Mode -> Bool -> Double + -> ( Stroke, Maybe ( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed ), Seq FitPoint ) ) + -> Compose Renders Cairo.Render () +renderStroke cols@( Colours { brush } ) mbHoverContext mode debug zoom + ( Stroke + { strokeSpline = strokeSpline :: StrokeSpline clo ( Super.Rec pointFields ) + , strokeVisible + , strokeBrush = BrushData { brushFunction = ( AdaptableFunction brushFn ) :: BrushFunction brushFields } + } + , mbOutlineData ) + | strokeVisible + , ( _ :: Proxy# usedFields ) <- proxy# :: Proxy# ( brushFields `SuperRecord.Intersect` pointFields ) + , let + -- Get the adaptable brush shape (function), + -- specialising it to the type we are using. + toUsedParams :: Super.Rec pointFields -> Super.Rec usedFields + brushShapeFn :: Super.Rec usedFields -> SplinePts Closed + ( toUsedParams, brushShapeFn ) = brushFn @pointFields @usedFields + = renderStrokeSpline cols mode mbHoverContext zoom + ( when ( mode == BrushMode ) . renderBrushShape ( cols { path = brush } ) mbHoverContext ( 1.5 * zoom ) ( brushShapeFn . toUsedParams ) ) + strokeSpline + *> for_ mbOutlineData \outlineData -> + Compose blank { renderStrokes = drawOutline cols debug zoom outlineData } + | otherwise + = pure () -- | Render a sequence of stroke points. -- -- Accepts a sub-function for additional rendering of each stroke point -- (e.g. overlay a brush shape over each stroke point). -renderStrokePoints - :: forall d - . ( Show d, HasType FocusState d ) +renderStrokeSpline + :: forall clo crvData pointData + . ( Show pointData, KnownSplineType clo ) => Colours -> Mode -> Maybe HoverContext -> Double - -> ( StrokePoint d -> Compose Renders Cairo.Render () ) - -> Seq ( StrokePoint d ) + -> ( PointData pointData -> Compose Renders Cairo.Render () ) + -> Spline clo crvData ( PointData pointData ) -> Compose Renders Cairo.Render () -renderStrokePoints _ _ _ _ _ Empty = pure () -renderStrokePoints cols mode mbHover zoom renderSubcontent ( pt0 :<| pts ) = - Compose blank { renderPPts = when ( mode == Path ) $ drawPoint cols mbHover zoom pt0 } - *> renderSubcontent pt0 - *> go pt0 pts - where - go :: StrokePoint d -> Seq ( StrokePoint d ) -> Compose Renders Cairo.Render () - go _ Empty = pure () - go ( ControlPoint {} ) _ = error "renderStrokePoints: path starts with a control point" - -- Line. - go p0 ( p1 :<| ps ) - | PathPoint {} <- p1 - = Compose blank - { renderPPts - = when ( mode == Path ) $ drawPoint cols mbHover zoom p1 - , renderPath - = unless ( mode == Meta ) $ drawLine cols zoom p0 p1 - } - *> renderSubcontent p1 - *> go p1 ps - -- Quadratic Bézier curve. - go p0 ( p1 :<| p2 :<| ps ) - | ControlPoint {} <- p1 - , PathPoint {} <- p2 - = Compose blank - { renderCLines - = when ( mode == Path ) do - drawLine cols zoom p0 p1 - drawLine cols zoom p1 p2 - , renderCPts - = when ( mode == Path ) $ drawPoint cols mbHover zoom p1 - , renderPPts - = when ( mode == Path ) $ drawPoint cols mbHover zoom p2 - , renderPath - = unless ( mode == Meta ) $ drawQuadraticBezier cols zoom ( coords <$> Quadratic.Bezier { p0, p1, p2 } ) - } - *> renderSubcontent p1 - *> renderSubcontent p2 - *> go p2 ps - -- Cubic Bézier curve. - go p0 ( p1 :<| p2 :<| p3 :<| ps ) - | ControlPoint {} <- p1 - , ControlPoint {} <- p2 - , PathPoint {} <- p3 - = Compose blank - { renderCLines - = when ( mode == Path ) do - drawLine cols zoom p0 p1 - drawLine cols zoom p2 p3 - , renderCPts - = when ( mode == Path ) do - drawPoint cols mbHover zoom p1 - drawPoint cols mbHover zoom p2 - , renderPPts - = when ( mode == Path ) $ drawPoint cols mbHover zoom p3 - , renderPath - = unless ( mode == Meta ) $ drawCubicBezier cols zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 } ) - } - *> renderSubcontent p1 - *> renderSubcontent p2 - *> renderSubcontent p3 - *> go p3 ps - go p0 ps = error $ "renderStroke: unrecognised stroke type\n" <> show ( p0 :<| ps ) +renderStrokeSpline cols mode mbHover zoom renderSubcontent spline = + bifoldSpline ( renderSplineCurve ( splineStart spline ) ) renderSplinePoint spline -renderBrushShape :: Colours -> Maybe HoverContext -> Double -> StrokePoint PointData -> Compose Renders Cairo.Render () -renderBrushShape cols mbHoverContext zoom pt = + where + renderSplinePoint :: PointData pointData -> Compose Renders Cairo.Render () + renderSplinePoint sp0 + = Compose blank { renderPPts = when ( mode == PathMode ) $ drawPoint cols mbHover zoom PathPoint sp0 } + *> renderSubcontent sp0 + renderSplineCurve + :: forall clo' + . SplineTypeI clo' + => PointData pointData -> PointData pointData -> Curve clo' crvData ( PointData pointData ) -> Compose Renders Cairo.Render () + renderSplineCurve start p0 ( LineTo np1 _ ) + = Compose blank + { renderPPts = + when ( mode == PathMode ) $ + for_ np1 \ p1 -> + drawPoint cols mbHover zoom PathPoint p1 + , renderPath = + unless ( mode == MetaMode ) $ + drawLine cols zoom PathPoint p0 ( fromNextPoint start np1 ) + } + *> for_ np1 \ p1 -> renderSubcontent p1 + renderSplineCurve start p0 ( Bezier2To p1 np2 _ ) + = Compose blank + { renderCLines + = when ( mode == PathMode ) do + drawLine cols zoom ControlPoint p0 p1 + drawLine cols zoom ControlPoint p1 ( fromNextPoint start np2 ) + , renderCPts + = when ( mode == PathMode ) $ drawPoint cols mbHover zoom ControlPoint p1 + , renderPPts + = when ( mode == PathMode ) $ + for_ np2 \ p2 -> + drawPoint cols mbHover zoom PathPoint p2 + , renderPath + = unless ( mode == MetaMode ) $ drawQuadraticBezier cols zoom ( coords <$> Quadratic.Bezier { p0, p1, p2 = fromNextPoint start np2 } ) + } + *> renderSubcontent p1 + *> for_ np2 \ p2 -> renderSubcontent p2 + renderSplineCurve start p0 ( Bezier3To p1 p2 np3 _ ) + = Compose blank + { renderCLines + = when ( mode == PathMode ) do + drawLine cols zoom ControlPoint p0 p1 + drawLine cols zoom ControlPoint p2 ( fromNextPoint start np3 ) + , renderCPts + = when ( mode == PathMode ) do + drawPoint cols mbHover zoom ControlPoint p1 + drawPoint cols mbHover zoom ControlPoint p2 + , renderPPts + = when ( mode == PathMode ) $ + for_ np3 \ p3 -> + drawPoint cols mbHover zoom PathPoint p3 + , renderPath + = unless ( mode == MetaMode ) $ drawCubicBezier cols zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 = fromNextPoint start np3 } ) + } + *> renderSubcontent p1 + *> renderSubcontent p2 + *> for_ np3 \ p3 -> renderSubcontent p3 + +renderBrushShape + :: Colours -> Maybe HoverContext -> Double + -> ( brushParams -> SplinePts Closed ) + -> PointData brushParams + -> Compose Renders Cairo.Render () +renderBrushShape cols mbHoverContext zoom brushFn pt = let x, y :: Double Point2D x y = coords pt - brushPts :: Seq ( StrokePoint BrushPointData ) - brushPts = brushShape ( pointData pt ) + brushPts :: SplinePts Closed + brushPts = brushFn ( brushParams pt ) mbHoverContext' :: Maybe HoverContext mbHoverContext' = Vector2D (-x) (-y) • mbHoverContext in toAll do Cairo.save Cairo.translate x y - *> renderStrokePoints cols Path mbHoverContext' zoom ( const $ pure () ) brushPts + *> renderStrokeSpline cols PathMode mbHoverContext' zoom ( const $ pure () ) + ( fmap ( \ p -> PointData p Normal () ) brushPts ) *> Compose blank { renderPPts = drawCross cols zoom } *> toAll Cairo.restore -drawPoint :: HasType FocusState d => Colours -> Maybe HoverContext -> Double -> StrokePoint d -> Cairo.Render () -drawPoint ( Colours {..} ) mbHover zoom pt@( PathPoint { coords = Point2D x y } ) +drawPoint :: Colours -> Maybe HoverContext -> Double -> PointType -> PointData brushData -> Cairo.Render () +drawPoint ( Colours {..} ) mbHover zoom PathPoint pt = do let + x, y :: Double + Point2D x y = coords pt hsqrt3 :: Double hsqrt3 = sqrt 0.75 selectionState :: FocusState @@ -340,9 +443,11 @@ drawPoint ( Colours {..} ) mbHover zoom pt@( PathPoint { coords = Point2D x y } Cairo.restore -drawPoint ( Colours {..} ) mbHover zoom pt@( ControlPoint { coords = Point2D x y } ) +drawPoint ( Colours {..} ) mbHover zoom ControlPoint pt = do let + x, y :: Double + Point2D x y = coords pt selectionState :: FocusState selectionState = view _selection pt <> hovered mbHover zoom ( Point2D x y ) @@ -369,8 +474,8 @@ drawPoint ( Colours {..} ) mbHover zoom pt@( ControlPoint { coords = Point2D x y Cairo.restore -drawLine :: Colours -> Double -> StrokePoint d -> StrokePoint d -> Cairo.Render () -drawLine ( Colours { path, controlPoint } ) zoom p1 p2 = do +drawLine :: Colours -> Double -> PointType -> PointData b -> PointData b -> Cairo.Render () +drawLine ( Colours { path, controlPoint } ) zoom pointType p1 p2 = do let x1, y1, x2, y2 :: Double Point2D x1 y1 = coords p1 @@ -380,11 +485,11 @@ drawLine ( Colours { path, controlPoint } ) zoom p1 p2 = do Cairo.moveTo x1 y1 Cairo.lineTo x2 y2 - case ( p1, p2 ) of - ( PathPoint {}, PathPoint {} ) -> do + case pointType of + PathPoint -> do Cairo.setLineWidth ( 5 / zoom ) withRGBA path Cairo.setSourceRGBA - _ -> do + ControlPoint -> do Cairo.setLineWidth ( 3 / zoom ) withRGBA controlPoint Cairo.setSourceRGBA Cairo.stroke @@ -418,16 +523,16 @@ drawCubicBezier ( Colours { path } ) zoom Cairo.restore -drawStroke +drawOutline :: Colours -> Bool -> Double - -> ( Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ), Seq FitPoint ) + -> ( Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed ), Seq FitPoint ) -> Cairo.Render () -drawStroke cols@( Colours {..} ) debug zoom strokeData = do +drawOutline cols@( Colours {..} ) debug zoom strokeData = do Cairo.save withRGBA brushStroke Cairo.setSourceRGBA case strokeData of ( Left outline, fitPts ) -> do - go outline + makeOutline outline case debug of False -> Cairo.fill True -> do @@ -437,8 +542,8 @@ drawStroke cols@( Colours {..} ) debug zoom strokeData = do Cairo.stroke ( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts ( Right ( fwd, bwd ), fitPts ) -> do - go fwd - go bwd + makeOutline fwd + makeOutline bwd case debug of False -> Cairo.fill True -> do @@ -448,36 +553,30 @@ drawStroke cols@( Colours {..} ) debug zoom strokeData = do Cairo.stroke ( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts Cairo.restore - where - go :: Seq ( StrokePoint () ) -> Cairo.Render () - go ( p@( PP ( Point2D x y ) ) :<| ps ) = Cairo.moveTo x y *> go' p ps - go _ = pure () + makeOutline :: SplinePts Closed -> Cairo.Render () + makeOutline spline = bifoldSpline + ( drawCurve ( splineStart spline ) ) + ( \ ( Point2D x y ) -> Cairo.moveTo x y ) + spline - go' :: StrokePoint () -> Seq ( StrokePoint () ) -> Cairo.Render () - go' _ Empty = pure () - -- Line. - go' _ ( p1@( PP ( Point2D x1 y1 ) ) :<| ps ) = - do - Cairo.lineTo x1 y1 - go' p1 ps - -- Quadratic Bézier curve. - go' ( PP ( Point2D x0 y0 ) ) ( CP ( Point2D x1 y1 ) :<| p2@( PP ( Point2D x2 y2 ) ) :<| ps ) = - do - Cairo.curveTo - ( ( 2 * x1 + x0 ) / 3 ) ( ( 2 * y1 + y0 ) / 3 ) - ( ( 2 * x1 + x2 ) / 3 ) ( ( 2 * y1 + y2 ) / 3 ) - x2 y2 - go' p2 ps - -- Cubic Bézier curve. - go' _ ( CP ( Point2D x1 y1 ) :<| CP ( Point2D x2 y2 ) :<| p3@( PP ( Point2D x3 y3 ) ) :<| ps ) = - do - Cairo.curveTo x1 y1 x2 y2 x3 y3 - go' p3 ps - go' p0 ps = error $ "drawStroke: unrecognised stroke type\n" <> show ( p0 :<| ps ) + drawCurve :: forall clo. SplineTypeI clo => Point2D Double -> Point2D Double -> Curve clo () ( Point2D Double ) -> Cairo.Render () + drawCurve start ( Point2D x0 y0 ) crv = case crv of + LineTo mp1 _ -> + let Point2D x1 y1 = fromNextPoint start mp1 + in Cairo.lineTo x1 y1 + Bezier2To ( Point2D x1 y1 ) mp2 _ -> + let Point2D x2 y2 = fromNextPoint start mp2 + in Cairo.curveTo + ( ( 2 * x1 + x0 ) / 3 ) ( ( 2 * y1 + y0 ) / 3 ) + ( ( 2 * x1 + x2 ) / 3 ) ( ( 2 * y1 + y2 ) / 3 ) + x2 y2 + Bezier3To ( Point2D x1 y1 ) ( Point2D x2 y2 ) mp3 _ -> + let Point2D x3 y3 = fromNextPoint start mp3 + in Cairo.curveTo x1 y1 x2 y2 x3 y3 drawFitPoint :: Colours -> Double -> FitPoint -> StateT Double Cairo.Render () -drawFitPoint ( Colours {..} ) zoom ( FitPoint { fitPoint = Point2D x y } ) = do +drawFitPoint _ zoom ( FitPoint { fitPoint = Point2D x y } ) = do hue <- get put ( hue + 0.01 ) @@ -492,7 +591,7 @@ drawFitPoint ( Colours {..} ) zoom ( FitPoint { fitPoint = Point2D x y } ) = do Cairo.fill Cairo.restore -drawFitPoint ( Colours {..} ) zoom ( FitTangent { fitPoint = Point2D x y, fitTangent = Vector2D tx ty } ) = do +drawFitPoint _ zoom ( FitTangent { fitPoint = Point2D x y, fitTangent = Vector2D tx ty } ) = do hue <- get put ( hue + 0.01 ) diff --git a/src/app/MetaBrush/Render/Rulers.hs b/src/app/MetaBrush/Render/Rulers.hs index 1f148ea..c745920 100644 --- a/src/app/MetaBrush/Render/Rulers.hs +++ b/src/app/MetaBrush/Render/Rulers.hs @@ -230,7 +230,7 @@ renderRuler start = truncateWith bigSpacing left setTickRenderContext traverse_ renderTickV $ - [ Tick { .. } + [ Tick {..} | ( i :: Int ) <- [ 0, 1 .. ceiling ( ( right - start ) / smallSpacing ) ] , let ( tickSize, tickHasLabel ) = subdivAt i increasingSubdivs @@ -242,7 +242,7 @@ renderRuler start = truncateWith bigSpacing top setTickRenderContext traverse_ renderTickH $ - [ Tick { .. } + [ Tick {..} | ( i :: Int ) <- [ 0, 1 .. ceiling ( ( bottom - start ) / smallSpacing ) ] , let ( tickSize, tickHasLabel ) = subdivAt i increasingSubdivs @@ -250,7 +250,7 @@ renderRuler ] renderTickV, renderTickH :: Tick -> Cairo.Render () - renderTickV ( Tick { .. } ) = do + renderTickV ( Tick {..} ) = do Cairo.save Cairo.translate tickPosition top Cairo.scale ( 1 / zoomFactor ) ( 1 / zoomFactor ) @@ -262,7 +262,7 @@ renderRuler Cairo.moveTo 0 0 Cairo.showText ( show $ round @_ @Int tickPosition ) Cairo.restore - renderTickH ( Tick { .. } ) = do + renderTickH ( Tick {..} ) = do Cairo.save Cairo.translate left tickPosition Cairo.scale ( 1 / zoomFactor ) ( 1 / zoomFactor ) diff --git a/src/app/MetaBrush/UI/Coordinates.hs b/src/app/MetaBrush/UI/Coordinates.hs index 8a42d8a..dff1e92 100644 --- a/src/app/MetaBrush/UI/Coordinates.hs +++ b/src/app/MetaBrush/UI/Coordinates.hs @@ -1,11 +1,20 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module MetaBrush.UI.Coordinates ( toViewportCoordinates, closestPoint ) where -- base +import Data.Coerce + ( coerce ) +import Data.Functor.Identity + ( Identity(..) ) import Data.Semigroup ( ArgMin, Arg(..), Min(..) ) @@ -17,23 +26,23 @@ import Data.Act ( (-->) ) ) --- containers -import Data.Sequence - ( Seq(..) ) - -- MetaBrush import qualified Math.Bezier.Cubic as Cubic ( Bezier(..), closestPoint ) import qualified Math.Bezier.Quadratic as Quadratic ( Bezier(..), closestPoint ) -import Math.Bezier.Stroke - ( StrokePoint(..) ) +import Math.Bezier.Spline + ( Curve(..), Spline(..), SplineTypeI, KnownSplineType(bifoldSpline) + , fromNextPoint + ) import Math.Module - ( (*^), squaredNorm, closestPointToSegment ) + ( (*^), squaredNorm, closestPointOnSegment ) import Math.Vector2D - ( Point2D(..), Vector2D(..) ) + ( Point2D(..), Vector2D(..), Segment(..) ) import MetaBrush.Document - ( Stroke(..), PointData(..) ) + ( Stroke(..), PointData(..) + , coords + ) -------------------------------------------------------------------------------- @@ -45,29 +54,40 @@ toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCente -- | Find the closest point in a set of strokes. closestPoint :: Point2D Double -> Stroke -> ArgMin Double ( Maybe ( Point2D Double ) ) -closestPoint c ( Stroke { strokePoints = pt0 :<| pts, strokeVisible = True } ) = go pt0 pts +closestPoint c ( Stroke { strokeSpline, strokeVisible = True } ) = + coerce $ + bifoldSpline @_ @Identity + ( closestPointToCurve ( splineStart strokeSpline ) ) + ( res . coords ) + strokeSpline where - res :: Point2D Double -> ArgMin Double ( Maybe ( Point2D Double ) ) - res p = Min $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p ) - go :: StrokePoint PointData -> Seq ( StrokePoint PointData ) -> ArgMin Double ( Maybe ( Point2D Double ) ) - go ( ControlPoint {} ) _ = error "closestPoint: path starts with a control point" - go p0 Empty = res ( coords p0 ) - -- Line. - go ( PathPoint { coords = p0 } ) - ( sp1@( PathPoint { coords = p1 } ) :<| ps ) - = res ( snd $ closestPointToSegment @( Vector2D Double ) c p0 p1 ) - <> go sp1 ps - -- Quadratic Bézier curve. - go ( PathPoint { coords = p0 } ) - ( ControlPoint { coords = p1 } :<| sp2@( PathPoint { coords = p2 } ) :<| ps ) - = fmap ( fmap ( Just . snd ) ) - ( Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier {..} ) c ) - <> go sp2 ps - -- Cubic Bézier curve. - go ( PathPoint { coords = p0 } ) - ( PathPoint { coords = p1 } :<| PathPoint { coords = p2 } :<| sp3@( PathPoint { coords = p3 } ) :<| ps ) - = fmap ( fmap ( Just . snd ) ) - ( Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier {..} ) c ) - <> go sp3 ps - go p0 ps = error $ "closestPoint: unrecognised stroke type\n" <> show ( p0 :<| ps ) -closestPoint _ _ = Min $ Arg ( 1 / 0 ) Nothing + res :: Point2D Double -> Identity ( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) ) + res p = coerce $ Arg ( squaredNorm ( c --> p :: Vector2D Double ) ) ( Just p ) + + closestPointToCurve + :: forall clo crvData brushParams + . SplineTypeI clo + => PointData brushParams + -> PointData brushParams + -> Curve clo crvData ( PointData brushParams ) + -> Identity ( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) ) + closestPointToCurve start p0 ( LineTo p1 _ ) = + res ( snd $ closestPointOnSegment @( Vector2D Double ) c ( Segment (coords p0 ) ( coords $ fromNextPoint start p1 ) ) ) + closestPointToCurve start p0 ( Bezier2To p1 p2 _ ) = coerce $ + fmap ( fmap ( Just . snd ) ) + ( Quadratic.closestPoint @( Vector2D Double ) ( Quadratic.Bezier ( coords p0 ) ( coords p1 ) ( coords $ fromNextPoint start p2 ) ) c ) + closestPointToCurve start p0 ( Bezier3To p1 p2 p3 _ ) = coerce $ + fmap ( fmap ( Just . snd ) ) + ( Cubic.closestPoint @( Vector2D Double ) ( Cubic.Bezier ( coords p0 ) ( coords p1 ) ( coords p2 ) ( coords $ fromNextPoint start p3 ) ) c ) +closestPoint _ _ = coerce $ mempty @( ArgMin BoundedDouble ( Maybe ( Point2D Double ) ) ) + +-- Messing around to emulate a `Monoid` instance for `ArgMin Double ( Maybe ( Point2D Double ) )` +newtype BoundedDouble = BoundedDouble Double + deriving stock Show + deriving newtype ( Eq, Ord ) +instance Bounded BoundedDouble where + minBound = BoundedDouble ( -1 / 0 ) + maxBound = BoundedDouble ( 1 / 0 ) +instance Bounded ( Arg BoundedDouble ( Maybe b ) ) where + minBound = Arg minBound Nothing + maxBound = Arg maxBound Nothing diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs index 890225e..7b88fc8 100644 --- a/src/app/MetaBrush/UI/FileBar.hs +++ b/src/app/MetaBrush/UI/FileBar.hs @@ -44,6 +44,10 @@ import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM.TVar as STM ( writeTVar, readTVar, readTVarIO, modifyTVar' ) +-- transformers +import Control.Monad.Trans.Reader + ( runReaderT ) + -- MetaBrush import MetaBrush.Action ( SwitchTo(..), Close(..), handleAction ) @@ -97,7 +101,7 @@ newFileTab -> IO () newFileTab initialStage - uiElts@( UIElements { fileBar = FileBar {..}, viewport = Viewport {..}, .. } ) + uiElts@( UIElements { fileBar = FileBar {..}, .. } ) vars@( Variables {..} ) mbDocHist newTabLoc @@ -108,7 +112,7 @@ newFileTab Just docHist -> do pure docHist -- Create a new empty document. Nothing -> do - newDocUniq <- STM.atomically $ freshUnique uniqueSupply + newDocUniq <- STM.atomically $ runReaderT freshUnique uniqueSupply pure ( newHistory $ emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq ) let diff --git a/src/app/MetaBrush/UI/ToolBar.hs b/src/app/MetaBrush/UI/ToolBar.hs index 9cc1dd6..e21b118 100644 --- a/src/app/MetaBrush/UI/ToolBar.hs +++ b/src/app/MetaBrush/UI/ToolBar.hs @@ -49,9 +49,9 @@ data Tool deriving stock ( Show, Eq ) data Mode - = Path - | Brush - | Meta + = PathMode + | BrushMode + | MetaMode deriving stock ( Show, Eq ) data ToolBar @@ -82,13 +82,13 @@ createToolBar ( Variables {..} ) colours drawingArea toolBar = do metaTool <- GTK.radioButtonNewFromWidget ( Just pathTool ) _ <- GTK.onButtonClicked pathTool do - STM.atomically $ STM.writeTVar modeTVar Path + STM.atomically $ STM.writeTVar modeTVar PathMode GTK.widgetQueueDraw drawingArea _ <- GTK.onButtonClicked brushTool do - STM.atomically $ STM.writeTVar modeTVar Brush + STM.atomically $ STM.writeTVar modeTVar BrushMode GTK.widgetQueueDraw drawingArea _ <- GTK.onButtonClicked metaTool do - STM.atomically $ STM.writeTVar modeTVar Meta + STM.atomically $ STM.writeTVar modeTVar MetaMode GTK.widgetQueueDraw drawingArea diff --git a/src/app/MetaBrush/UI/ToolBar.hs-boot b/src/app/MetaBrush/UI/ToolBar.hs-boot index b29f6cb..f1317fe 100644 --- a/src/app/MetaBrush/UI/ToolBar.hs-boot +++ b/src/app/MetaBrush/UI/ToolBar.hs-boot @@ -16,9 +16,9 @@ data Tool instance Show Tool data Mode - = Path - | Brush - | Meta + = PathMode + | BrushMode + | MetaMode instance Show Mode diff --git a/src/app/MetaBrush/Unique.hs b/src/app/MetaBrush/Unique.hs index 5c64a86..e946703 100644 --- a/src/app/MetaBrush/Unique.hs +++ b/src/app/MetaBrush/Unique.hs @@ -1,13 +1,18 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} module MetaBrush.Unique - ( Unique, unsafeUnique - , freshUnique, uniqueText + ( MonadUnique(freshUnique) + , Unique, unsafeUnique + , uniqueText , UniqueSupply, newUniqueSupply , uniqueMapFromList ) @@ -41,9 +46,15 @@ import Data.Generics.Product.Typed import Control.Lens ( view ) +-- mtl +import Control.Monad.Reader + ( MonadReader(..) ) + -- stm import Control.Concurrent.STM ( STM ) +import qualified Control.Concurrent.STM as STM + ( atomically ) import qualified Control.Concurrent.STM.TVar as STM ( TVar, newTVarIO, readTVar, writeTVar ) @@ -53,11 +64,19 @@ import Data.Text import qualified Data.Text as Text ( pack ) +-- transformers +import Control.Monad.IO.Class + ( MonadIO(..) ) +import Control.Monad.Trans.Class + ( lift ) +import Control.Monad.Trans.Reader + ( ReaderT ) + -------------------------------------------------------------------------------- newtype Unique = Unique { unique :: Int64 } deriving stock Show - deriving newtype ( Eq, Ord, Storable, NFData ) + deriving newtype ( Eq, Ord, Enum, Storable, NFData ) unsafeUnique :: Word32 -> Unique unsafeUnique i = Unique ( - fromIntegral i - 1 ) @@ -71,14 +90,29 @@ uniqueText ( Unique i ) newtype UniqueSupply = UniqueSupply { uniqueSupplyTVar :: STM.TVar Unique } -freshUnique :: UniqueSupply -> STM Unique -freshUnique ( UniqueSupply { uniqueSupplyTVar } ) = do - uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar - STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) ) - pure uniq +instance Show UniqueSupply where { show _ = "Unique supply" } newUniqueSupply :: IO UniqueSupply newUniqueSupply = UniqueSupply <$> STM.newTVarIO ( Unique 1 ) uniqueMapFromList :: HasType Unique a => [ a ] -> Map Unique a uniqueMapFromList = Map.fromList . map ( view typed &&& id ) + +class Monad m => MonadUnique m where + freshUnique :: m Unique + +instance {-# OVERLAPPABLE #-} ( Monad m, MonadReader r m, HasType UniqueSupply r, MonadIO m ) => MonadUnique m where + freshUnique = do + UniqueSupply { uniqueSupplyTVar } <- view ( typed @UniqueSupply ) <$> ask + liftIO $ STM.atomically do + uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar + STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) ) + pure uniq + +instance MonadUnique ( ReaderT UniqueSupply STM ) where + freshUnique = do + UniqueSupply { uniqueSupplyTVar } <- ask + lift do + uniq@( Unique !i ) <- STM.readTVar uniqueSupplyTVar + STM.writeTVar uniqueSupplyTVar ( Unique ( succ i ) ) + pure uniq diff --git a/src/lib/Math/Bezier/Cubic.hs b/src/lib/Math/Bezier/Cubic.hs index bebec72..9181e7c 100644 --- a/src/lib/Math/Bezier/Cubic.hs +++ b/src/lib/Math/Bezier/Cubic.hs @@ -179,7 +179,7 @@ ddist ( Bezier {..} ) c = [ a5, a4, a3, a2, a1, a0 ] closestPoint :: forall v r p. ( Torsor v p, Inner r v, RealFloat r, Prim r ) => Bezier p -> p -> ArgMin r ( r, p ) -closestPoint pts@( Bezier {..} ) c = pickClosest ( 0 :| 1 : roots ) -- todo: also include the self-intersection point if one exists +closestPoint pts c = pickClosest ( 0 :| 1 : roots ) -- todo: also include the self-intersection point if one exists where roots :: [ r ] roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots 2000 $ ddist @v pts c ) diff --git a/src/lib/Math/Bezier/Cubic/Fit.hs b/src/lib/Math/Bezier/Cubic/Fit.hs index c47a651..8a21d88 100644 --- a/src/lib/Math/Bezier/Cubic/Fit.hs +++ b/src/lib/Math/Bezier/Cubic/Fit.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} @@ -40,12 +41,16 @@ import Data.Act import Data.Sequence ( Seq(..) ) import qualified Data.Sequence as Seq - ( fromList, singleton ) + ( fromList ) -- deepseq import Control.DeepSeq ( NFData ) +-- parallel +import qualified Control.Parallel.Strategies as Parallel.Strategy + ( rdeepseq, parTuple2, using ) + -- primitive import Data.Primitive.PrimArray ( primArrayFromListN, unsafeThawPrimArray ) @@ -67,6 +72,10 @@ import qualified Data.Vector.Unboxed as Unboxed.Vector -- MetaBrush import qualified Math.Bezier.Cubic as Cubic ( Bezier(..), bezier, ddist ) +import Math.Bezier.Spline + ( SplineType(..), SplinePts + , openCubicBezierCurveSpline + ) import Math.Epsilon ( epsilon ) import Math.Linear.Solve @@ -119,7 +128,7 @@ data FitPoint fitSpline :: FitParameters -> ( Double -> ( Point2D Double, Vector2D Double ) ) -- ^ curve \( t \mapsto ( C(t), C'(t) ) \) to fit - -> ( Seq ( Cubic.Bezier ( Point2D Double ) ), Seq FitPoint ) + -> ( SplinePts Open, Seq FitPoint ) fitSpline ( FitParameters {..} ) = go 0 where dt :: Double @@ -127,26 +136,32 @@ fitSpline ( FitParameters {..} ) = go 0 go :: Int -> ( Double -> ( Point2D Double, Vector2D Double ) ) - -> ( Seq ( Cubic.Bezier ( Point2D Double ) ), Seq FitPoint ) - go subdiv curve = + -> ( SplinePts Open, Seq FitPoint ) + go subdiv curveFn = let p, r :: Point2D Double tp, tr :: Vector2D Double qs :: [ Point2D Double ] - (p, tp) = curve 0 - (r, tr) = curve 1 - qs = [ fst $ curve ( dt * fromIntegral j ) | j <- [ 1 .. nbSegments - 1 ] ] + (p, tp) = curveFn 0 + (r, tr) = curveFn 1 + qs = [ fst $ curveFn ( dt * fromIntegral j ) | j <- [ 1 .. nbSegments - 1 ] ] in case fitPiece dist_tol t_tol maxIters p tp qs r tr of ( bez, Max ( Arg max_sq_error t_split ) ) | subdiv >= maxSubdiv || max_sq_error <= dist_tol ^ ( 2 :: Int ) - -> ( Seq.singleton bez, ( FitTangent p tp :<| Seq.fromList ( map FitPoint qs ) ) :|> FitTangent r tr ) + -> ( openCubicBezierCurveSpline () bez, ( FitTangent p tp :<| Seq.fromList ( map FitPoint qs ) ) :|> FitTangent r tr ) | let t_split_eff :: Double t_split_eff = min ( 1 - dt ) $ max dt t_split - -> go ( subdiv + 1 ) ( \ t -> curve $ t * t_split_eff ) - <> go ( subdiv + 1 ) ( \ t -> curve $ t_split_eff + t * ( 1 - t_split_eff ) ) + c1, c2 :: SplinePts Open + ps1, ps2 :: Seq FitPoint + ( ( c1, ps1 ), ( c2, ps2 ) ) + = ( go ( subdiv + 1 ) ( \ t -> curveFn $ t * t_split_eff ) + , go ( subdiv + 1 ) ( \ t -> curveFn $ t_split_eff + t * ( 1 - t_split_eff ) ) + ) `Parallel.Strategy.using` + ( Parallel.Strategy.parTuple2 Parallel.Strategy.rdeepseq Parallel.Strategy.rdeepseq ) + -> ( c1 <> c2, ps1 <> ps2 ) -- | Fits a single cubic Bézier curve to the given data. -- diff --git a/src/lib/Math/Bezier/Quadratic.hs b/src/lib/Math/Bezier/Quadratic.hs index 3a0621a..de37dd9 100644 --- a/src/lib/Math/Bezier/Quadratic.hs +++ b/src/lib/Math/Bezier/Quadratic.hs @@ -147,7 +147,7 @@ ddist ( Bezier {..} ) c = [ a3, a2, a1, a0 ] closestPoint :: forall v r p. ( Torsor v p, Inner r v, RealFloat r, Prim r ) => Bezier p -> p -> ArgMin r ( r, p ) -closestPoint pts@( Bezier {..} ) c = pickClosest ( 0 :| 1 : roots ) +closestPoint pts c = pickClosest ( 0 :| 1 : roots ) where roots :: [ r ] roots = filter ( \ r -> r > 0 && r < 1 ) ( realRoots 2000 $ ddist @v pts c ) diff --git a/src/lib/Math/Bezier/Spline.hs b/src/lib/Math/Bezier/Spline.hs new file mode 100644 index 0000000..cc06673 --- /dev/null +++ b/src/lib/Math/Bezier/Spline.hs @@ -0,0 +1,523 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Math.Bezier.Spline where + +-- base +import Data.Bifoldable + ( Bifoldable(..) ) +import Data.Bifunctor + ( Bifunctor(..) ) +import Data.Bitraversable + ( Bitraversable(..) ) +import Data.Coerce + ( coerce ) +import Data.Functor.Const + ( Const(..) ) +import Data.Functor.Identity + ( Identity(..) ) +import Data.Kind + ( Constraint ) +import Data.Monoid + ( Ap(..) ) +import Data.Semigroup + ( First(..) ) +import GHC.Generics + ( Generic, Generic1 ) + +-- bifunctors +import qualified Data.Bifunctor.Tannen as Biff + ( Tannen(..) ) + +-- containers +import Data.Sequence + ( Seq(..) ) +import qualified Data.Sequence as Seq + ( singleton, drop, splitAt ) + +-- deepseq +import Control.DeepSeq + ( NFData, NFData1 ) + +-- generic-lens +import Data.Generics.Product.Fields + ( field ) +import Data.GenericLens.Internal + ( set ) + +-- transformers +import Control.Monad.Trans.Class + ( lift ) +import Control.Monad.Trans.State.Strict + ( StateT(runStateT), modify' ) + +-- MetaBrush +import qualified Math.Bezier.Cubic as Cubic + ( Bezier(..) ) +import Math.Vector2D + ( Point2D ) + +-------------------------------------------------------------------------------- + +data PointType + = PathPoint + | ControlPoint + deriving stock Show + +data SplineType = Open | Closed + +data SSplineType ( clo :: SplineType ) where + SOpen :: SSplineType Open + SClosed :: SSplineType Closed + +class ( Traversable ( NextPoint clo ) + , forall crvData. Traversable ( Curves clo crvData ) + , Bitraversable ( Curves clo ) + , forall ptData. Show ptData => Show ( NextPoint clo ptData ) + , forall ptData crvData. ( Show ptData, Show crvData ) => Show ( Curves clo crvData ptData ) + , forall ptData. NFData ptData => NFData ( NextPoint clo ptData ) + , forall ptData crvData. ( NFData ptData, NFData crvData ) => NFData ( Curves clo crvData ptData ) + ) + => SplineTypeI ( clo :: SplineType ) where + -- | Singleton for the spline type + ssplineType :: SSplineType clo +instance SplineTypeI Open where + ssplineType = SOpen +instance SplineTypeI Closed where + ssplineType = SClosed + +data family NextPoint ( clo :: SplineType ) ptData +newtype instance NextPoint Open ptData = NextPoint { nextPoint :: ptData } + deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable ) + deriving anyclass ( NFData, NFData1 ) +data instance NextPoint Closed ptData = BackToStart + deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable ) + deriving anyclass ( NFData, NFData1 ) + +fromNextPoint :: forall clo ptData. SplineTypeI clo => ptData -> NextPoint clo ptData -> ptData +fromNextPoint pt nxt + | SOpen <- ssplineType @clo + = case nxt of { NextPoint q -> q } + | otherwise + = pt + +toNextPoint :: forall clo ptData. SplineTypeI clo => ptData -> NextPoint clo ptData +toNextPoint pt = case ssplineType @clo of + SOpen -> NextPoint pt + SClosed -> BackToStart + +data Curve ( clo :: SplineType ) crvData ptData + = LineTo + { curveEnd :: !( NextPoint clo ptData ) + , curveData :: !crvData + } + | Bezier2To + { controlPoint :: !ptData + , curveEnd :: !( NextPoint clo ptData ) + , curveData :: !crvData + } + | Bezier3To + { controlPoint1 :: !ptData + , controlPoint2 :: !ptData + , curveEnd :: !( NextPoint clo ptData ) + , curveData :: !crvData + } + deriving stock ( Generic, Generic1 ) + +deriving stock instance ( Show ptData, Show crvData, Show ( NextPoint clo ptData ) ) => Show ( Curve clo crvData ptData ) +deriving anyclass instance ( NFData ptData, NFData crvData, NFData ( NextPoint clo ptData ) ) => NFData ( Curve clo crvData ptData ) + +deriving stock instance Functor ( NextPoint clo ) => Functor ( Curve clo crvData ) +deriving stock instance Foldable ( NextPoint clo ) => Foldable ( Curve clo crvData ) +deriving stock instance Traversable ( NextPoint clo ) => Traversable ( Curve clo crvData ) + +instance Functor ( NextPoint clo ) => Bifunctor ( Curve clo ) where + bimap f g ( LineTo np d ) = LineTo ( fmap g np ) ( f d ) + bimap f g ( Bezier2To cp np d ) = Bezier2To ( g cp ) ( fmap g np ) ( f d ) + bimap f g ( Bezier3To cp1 cp2 np d ) = Bezier3To ( g cp1 ) ( g cp2 ) ( fmap g np ) ( f d ) +instance Foldable ( NextPoint clo ) => Bifoldable ( Curve clo ) where + bifoldMap f g ( LineTo np d ) = foldMap g np <> f d + bifoldMap f g ( Bezier2To cp np d ) = g cp <> foldMap g np <> f d + bifoldMap f g ( Bezier3To cp1 cp2 np d ) = g cp1 <> g cp2 <> foldMap g np <> f d +instance Traversable ( NextPoint clo ) => Bitraversable ( Curve clo ) where + bitraverse f g ( LineTo np d ) = LineTo <$> traverse g np <*> f d + bitraverse f g ( Bezier2To cp np d ) = Bezier2To <$> g cp <*> traverse g np <*> f d + bitraverse f g ( Bezier3To cp1 cp2 np d ) = Bezier3To <$> g cp1 <*> g cp2 <*> traverse g np <*> f d + +openCurveEnd :: Curve Open crvData ptData -> ptData +openCurveEnd = nextPoint . curveEnd + +openCurveStart :: Curve Open crvData ptData -> ptData +openCurveStart ( LineTo ( NextPoint p ) _ ) = p +openCurveStart ( Bezier2To p _ _ ) = p +openCurveStart ( Bezier3To p _ _ _ ) = p + +data family Curves ( clo :: SplineType ) crvData ptData + +newtype instance Curves Open crvData ptData + = OpenCurves { openCurves :: Seq ( Curve Open crvData ptData ) } + deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable ) + deriving newtype ( Semigroup, Monoid, NFData ) + +deriving via Biff.Tannen Seq ( Curve Open ) + instance Bifunctor ( Curves Open ) +deriving via Biff.Tannen Seq ( Curve Open ) + instance Bifoldable ( Curves Open ) +instance Bitraversable ( Curves Open ) where + bitraverse f g ( OpenCurves { openCurves = curves } ) + = OpenCurves <$> traverse ( bitraverse f g ) curves + +data instance Curves Closed crvData ptData + = NoCurves + | ClosedCurves + { prevOpenCurves :: !( Seq ( Curve Open crvData ptData ) ) + , lastClosedCurve :: !( Curve Closed crvData ptData ) + } + deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable ) + deriving anyclass NFData + +instance Bifunctor ( Curves Closed ) where + bimap _ _ NoCurves = NoCurves + bimap f g ( ClosedCurves p l ) = ClosedCurves ( fmap ( bimap f g ) p ) ( bimap f g l ) +instance Bifoldable ( Curves Closed ) where + bifoldMap _ _ NoCurves = mempty + bifoldMap f g ( ClosedCurves p l ) = foldMap ( bifoldMap f g ) p <> bifoldMap f g l +instance Bitraversable ( Curves Closed ) where + bitraverse _ _ NoCurves = pure NoCurves + bitraverse f g ( ClosedCurves p l ) + = ClosedCurves <$> ( traverse ( bitraverse f g ) p ) <*> bitraverse f g l + + +data Spline ( clo :: SplineType ) crvData ptData + = Spline + { splineStart :: !ptData + , splineCurves :: !( Curves clo crvData ptData ) + } + deriving stock ( Generic, Generic1 ) + +deriving stock instance ( Show ptData, Show ( Curves clo crvData ptData ) ) + => Show ( Spline clo crvData ptData ) +deriving anyclass instance ( NFData ptData, NFData ( Curves clo crvData ptData ) ) + => NFData ( Spline clo crvData ptData ) +deriving stock instance Functor ( Curves clo crvData ) => Functor ( Spline clo crvData ) +deriving stock instance Foldable ( Curves clo crvData ) => Foldable ( Spline clo crvData ) +deriving stock instance Traversable ( Curves clo crvData ) => Traversable ( Spline clo crvData ) + +instance KnownSplineType clo => Bifunctor ( Spline clo ) where + bimap fc fp = bimapSpline ( const $ bimap fc fp ) fp +instance KnownSplineType clo => Bifoldable ( Spline clo ) where + bifoldMap fc fp = runIdentity . bifoldSpline @_ @Identity ( const $ bifoldMap ( coerce fc ) ( coerce fp ) ) ( coerce fp ) +instance KnownSplineType clo => Bitraversable ( Spline clo ) where + bitraverse fc fp = bitraverseSpline ( const $ bitraverse fc fp ) fp + +type SplinePts clo = Spline clo () ( Point2D Double ) + + +bimapCurve + :: Functor ( NextPoint clo ) + => ( crvData -> crvData' ) -> ( PointType -> ptData -> ptData' ) + -> Curve clo crvData ptData -> Curve clo crvData' ptData' +bimapCurve f g ( LineTo p1 d ) = LineTo ( g PathPoint <$> p1 ) ( f d ) +bimapCurve f g ( Bezier2To p1 p2 d ) = Bezier2To ( g ControlPoint p1 ) ( g PathPoint <$> p2 ) ( f d ) +bimapCurve f g ( Bezier3To p1 p2 p3 d ) = Bezier3To ( g ControlPoint p1 ) ( g ControlPoint p2 ) ( g PathPoint <$> p3 ) ( f d ) + +bifoldMapCurve + :: forall m clo crvData ptData + . ( Monoid m, Foldable ( NextPoint clo ) ) + => ( crvData -> m ) -> ( PointType -> ptData -> m ) + -> Curve clo crvData ptData -> m +bifoldMapCurve f g ( LineTo p1 d ) = ( foldMap ( g PathPoint ) p1 ) <> f d +bifoldMapCurve f g ( Bezier2To p1 p2 d ) = g ControlPoint p1 <> ( foldMap ( g PathPoint ) p2 ) <> f d +bifoldMapCurve f g ( Bezier3To p1 p2 p3 d ) = g ControlPoint p1 <> g ControlPoint p2 <> ( foldMap ( g PathPoint ) p3 ) <> f d + +bitraverseCurve + :: forall f clo crvData crvData' ptData ptData' + . ( Applicative f, Traversable ( NextPoint clo ) ) + => ( crvData -> f crvData' ) -> ( PointType -> ptData -> f ptData' ) + -> Curve clo crvData ptData -> f ( Curve clo crvData' ptData' ) +bitraverseCurve f g ( LineTo p1 d ) = LineTo <$> traverse ( g PathPoint ) p1 <*> f d +bitraverseCurve f g ( Bezier2To p1 p2 d ) = Bezier2To <$> g ControlPoint p1 <*> traverse ( g PathPoint ) p2 <*> f d +bitraverseCurve f g ( Bezier3To p1 p2 p3 d ) = Bezier3To <$> g ControlPoint p1 <*> g ControlPoint p2 <*> traverse ( g PathPoint ) p3 <*> f d + +dropCurves :: Int -> Spline Open crvData ptData -> Maybe ( Spline Open crvData ptData ) +dropCurves i ( Spline { splineCurves = OpenCurves curves } ) = case Seq.drop ( i - 1 ) curves of + prev :<| next -> Just $ Spline { splineStart = openCurveEnd prev, splineCurves = OpenCurves next } + _ -> Nothing + +splitSplineAt :: Int -> Spline Open crvData ptData -> ( Spline Open crvData ptData, Spline Open crvData ptData ) +splitSplineAt i ( Spline { splineStart, splineCurves = OpenCurves curves } ) = case Seq.splitAt i curves of + ( Empty, next ) -> + ( Spline { splineStart, splineCurves = OpenCurves Empty }, Spline { splineStart, splineCurves = OpenCurves next } ) + ( prev@( _ :|> lastPrev ), next ) -> + ( Spline { splineStart, splineCurves = OpenCurves prev }, Spline { splineStart = openCurveEnd lastPrev, splineCurves = OpenCurves next } ) + +reverseSpline :: forall crvData ptData. Spline Open crvData ptData -> Spline Open crvData ptData +reverseSpline spline@( Spline { splineStart = p0, splineCurves = OpenCurves curves } ) = case curves of + Empty -> spline + prev :|> lst -> Spline { splineStart = openCurveEnd lst, splineCurves = OpenCurves ( go prev lst ) } + where + go :: Seq ( Curve Open crvData ptData ) -> Curve Open crvData ptData -> Seq ( Curve Open crvData ptData ) + go Empty ( LineTo _ dat ) = Empty :|> LineTo ( NextPoint p0 ) dat + go Empty ( Bezier2To p1 _ dat ) = Empty :|> Bezier2To p0 ( NextPoint p1 ) dat + go Empty ( Bezier3To p1 p2 _ dat ) = Empty :|> Bezier3To p0 p1 ( NextPoint p2 ) dat + go ( crvs :|> crv ) ( LineTo _ dat ) = go crvs crv :|> LineTo ( curveEnd crv ) dat + go ( crvs :|> crv ) ( Bezier2To p1 _ dat ) = go crvs crv :|> Bezier2To ( openCurveEnd crv ) ( NextPoint p1 ) dat + go ( crvs :|> crv ) ( Bezier3To p1 p2 _ dat ) = go crvs crv :|> Bezier3To ( openCurveEnd crv ) p1 ( NextPoint p2 ) dat + +splineEnd :: Spline Open crvData ptData -> ptData +splineEnd ( Spline { splineStart, splineCurves = OpenCurves curves } ) = case curves of + Empty -> splineStart + _ :|> lastCurve -> openCurveEnd lastCurve + +catMaybesSpline :: crvData -> ptData -> Maybe ptData -> Maybe ptData -> ptData -> Spline Open crvData ptData +catMaybesSpline dat p0 Nothing Nothing p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( LineTo ( NextPoint p3 ) dat ) } +catMaybesSpline dat p0 ( Just p1 ) Nothing p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To p1 ( NextPoint p3 ) dat ) } +catMaybesSpline dat p0 Nothing ( Just p2 ) p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier2To p2 ( NextPoint p3 ) dat ) } +catMaybesSpline dat p0 ( Just p1 ) ( Just p2 ) p3 = Spline { splineStart = p0, splineCurves = OpenCurves $ Seq.singleton ( Bezier3To p1 p2 ( NextPoint p3 ) dat ) } + +-- | Connect two open curves. +-- +-- It is assumed (not checked) that the end of the first curve is the start of the second curve. +instance Semigroup ( Spline Open crvData ptData ) where + spline1@( Spline { splineStart, splineCurves = segs1 } ) <> spline2@( Spline { splineCurves = segs2 } ) + | null segs1 = spline2 + | null segs2 = spline1 + | otherwise = Spline { splineStart, splineCurves = segs1 <> segs2 } + +-- | Create a curve containing a single (open) cubic Bézier segment. +openCubicBezierCurveSpline :: crvData -> Cubic.Bezier ptData -> Spline Open crvData ptData +openCubicBezierCurveSpline crvData ( Cubic.Bezier {..} ) + = Spline + { splineStart = p0 + , splineCurves = OpenCurves . Seq.singleton $ + Bezier3To + { controlPoint1 = p1 + , controlPoint2 = p2 + , curveEnd = NextPoint p3 + , curveData = crvData + } + } + +-- | Drop the end of an open curve segment to create a "closed" curve (i.e. one that returns to the start). +dropCurveEnd :: Curve Open crvData ptData -> Curve Closed crvData ptData +dropCurveEnd ( LineTo _ dat ) = LineTo BackToStart dat +dropCurveEnd ( Bezier2To cp _ dat ) = Bezier2To cp BackToStart dat +dropCurveEnd ( Bezier3To cp1 cp2 _ dat ) = Bezier3To cp1 cp2 BackToStart dat + +class SplineTypeI clo => KnownSplineType clo where + + type TraversalCt clo ( clo' :: SplineType ) :: Constraint + + -- | Last point of a spline. + lastPoint :: Spline clo crvData ptData -> ptData + + -- | Close a spline if necessary. + adjustSplineType :: forall clo' crvData ptData. SplineTypeI clo' => Spline clo' crvData ptData -> Spline clo crvData ptData + + -- | Indexed traversal of a spline. + ibitraverseSpline + :: forall f crvData ptData crvData' ptData' + . Applicative f + => ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' ) + => Int -> ptData -> Curve clo' crvData ptData -> f ( Curve clo' crvData' ptData' ) + ) + -> ( ptData -> f ptData' ) + -> Spline clo crvData ptData + -> f ( Spline clo crvData' ptData' ) + + -- | Bi-witherable traversal of a spline. + biwitherSpline + :: forall f crvData ptData crvData' ptData' + . Monad f + => ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' ) + => Maybe ptData' -> Curve clo' crvData ptData -> f ( Maybe ( Curve clo' crvData' ptData' ) ) + ) + -> ( ptData -> f ( Maybe ptData' ) ) + -> Spline clo crvData ptData + -> f ( Maybe ( Spline clo crvData' ptData' ) ) + + -- | Traversal of a spline. + bitraverseSpline + :: forall f crvData ptData crvData' ptData' + . Applicative f + => ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' ) + => ptData -> Curve clo' crvData ptData -> f ( Curve clo' crvData' ptData' ) + ) + -> ( ptData -> f ptData' ) + -> Spline clo crvData ptData + -> f ( Spline clo crvData' ptData' ) + + bitraverseSpline fc fp = ibitraverseSpline ( const fc ) fp + + -- | Indexed fold of a spline. + ibifoldSpline + :: forall f m crvData ptData + . ( Applicative f, Monoid m ) + => ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' ) + => Int -> ptData -> Curve clo' crvData ptData -> f m + ) + -> ( ptData -> f m ) + -> Spline clo crvData ptData + -> f m + + ibifoldSpline fc fp + = coerce + . ibitraverseSpline @clo @( Const ( Ap f m ) ) ( coerce fc ) ( coerce fp ) + + + -- | Fold of a spline. + bifoldSpline + :: forall f m crvData ptData + . ( Applicative f, Monoid m ) + => ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' ) + => ptData -> Curve clo' crvData ptData -> f m ) + -> ( ptData -> f m ) + -> Spline clo crvData ptData + -> f m + + bifoldSpline fc fp = ibifoldSpline ( const fc ) fp + + -- | Bifunctor fmap of a spline. + bimapSpline + :: forall crvData ptData crvData' ptData' + . ( forall clo'. ( TraversalCt clo clo', SplineTypeI clo' ) + => ptData -> Curve clo' crvData ptData -> Curve clo' crvData' ptData' + ) + -> ( ptData -> ptData' ) + -> Spline clo crvData ptData + -> Spline clo crvData' ptData' + bimapSpline fc fp + = runIdentity + . bitraverseSpline @clo @Identity ( coerce fc ) ( coerce fp ) + + + +instance KnownSplineType Open where + + type TraversalCt Open clo' = clo' ~ Open + + lastPoint ( Spline { splineStart, splineCurves = OpenCurves curves } ) = + case curves of + Empty -> splineStart + _ :|> lastCurve -> openCurveEnd lastCurve + + adjustSplineType :: forall clo' crvData ptData. SplineTypeI clo' => Spline clo' crvData ptData -> Spline Open crvData ptData + adjustSplineType spline@( Spline { splineStart, splineCurves } ) = case ssplineType @clo' of + SOpen -> spline + SClosed -> case splineCurves of + NoCurves -> Spline { splineStart, splineCurves = OpenCurves Empty } + ClosedCurves prev lst -> Spline { splineStart, splineCurves = OpenCurves $ prev :|> set ( field @"curveEnd" ) ( NextPoint splineStart ) lst } + + ibitraverseSpline fc fp ( Spline { splineStart, splineCurves = OpenCurves curves } ) = + ( \ p cs -> Spline p ( OpenCurves cs ) ) <$> fp splineStart <*> go 0 splineStart curves + where + go _ _ Empty = pure Empty + go i p ( seg :<| segs ) = (:<|) <$> fc i p seg <*> go ( i + 1 ) ( openCurveEnd seg ) segs + + biwitherSpline + :: forall f crvData ptData crvData' ptData' + . Monad f + => ( Maybe ptData' -> Curve Open crvData ptData -> f ( Maybe ( Curve Open crvData' ptData' ) ) ) + -> ( ptData -> f ( Maybe ptData' ) ) + -> Spline Open crvData ptData + -> f ( Maybe ( Spline Open crvData' ptData' ) ) + biwitherSpline fc fp ( Spline { splineStart, splineCurves = OpenCurves curves } ) = do + mbStart' <- fp splineStart + ( curves', mbStart'' ) <- ( `runStateT` ( fmap First mbStart' ) ) $ go mbStart' curves + case mbStart'' of + Nothing -> pure Nothing + Just ( First start' ) -> + pure ( Just $ Spline { splineStart = start', splineCurves = OpenCurves curves' } ) + where + go :: Maybe ptData' -> Seq ( Curve Open crvData ptData ) -> StateT ( Maybe ( First ptData' ) ) f ( Seq ( Curve Open crvData' ptData' ) ) + go _ Empty = pure Empty + go mbStart ( crv :<| crvs ) = do + mbCrv' <- lift $ fc mbStart crv + case mbCrv' of + Nothing -> go mbStart crvs + Just crv' -> do + let + endpoint = openCurveEnd crv' + modify' ( <> Just ( First endpoint ) ) + ( crv' :<| ) <$> go ( Just endpoint ) crvs + +instance KnownSplineType Closed where + + type TraversalCt Closed clo' = () + + lastPoint ( Spline { splineStart } ) = splineStart + + adjustSplineType :: forall clo' crvData ptData. SplineTypeI clo' => Spline clo' crvData ptData -> Spline Closed crvData ptData + adjustSplineType spline@( Spline { splineStart, splineCurves } ) = case ssplineType @clo' of + SClosed -> spline + SOpen -> case splineCurves of + OpenCurves ( Empty ) -> Spline { splineStart, splineCurves = NoCurves } + OpenCurves ( prev :|> lst ) -> Spline { splineStart, splineCurves = ClosedCurves prev ( set ( field @"curveEnd" ) BackToStart lst ) } + + ibitraverseSpline + :: forall f crvData ptData crvData' ptData' + . Applicative f + => ( forall clo'. ( SplineTypeI clo', Traversable ( NextPoint clo' ) ) + => Int -> ptData -> Curve clo' crvData ptData -> f ( Curve clo' crvData' ptData' ) + ) + -> ( ptData -> f ptData' ) + -> Spline Closed crvData ptData + -> f ( Spline Closed crvData' ptData' ) + ibitraverseSpline _ fp ( Spline { splineStart = p0, splineCurves = NoCurves } ) = ( \ p -> Spline p NoCurves ) <$> fp p0 + ibitraverseSpline fc fp ( Spline { splineStart = p0, splineCurves = ClosedCurves prevCurves lastCurve } ) = + ( \ p cs lst -> Spline p ( ClosedCurves cs lst ) ) <$> fp p0 <*> go 0 p0 prevCurves <*> fc n pn lastCurve + where + n :: Int + n = length prevCurves + pn :: ptData + pn = case prevCurves of + Empty -> p0 + _ :|> lastPrev -> openCurveEnd lastPrev + go _ _ Empty = pure Empty + go i p ( seg :<| segs ) = (:<|) <$> fc i p seg <*> go ( i + 1 ) ( openCurveEnd seg ) segs + + biwitherSpline _ fp ( Spline { splineStart, splineCurves = NoCurves } ) = fmap ( \ p -> Spline p NoCurves ) <$> fp splineStart + biwitherSpline fc fp ( Spline { splineStart, splineCurves = ClosedCurves prevCurves lastCurve } ) = do + mbSpline' <- biwitherSpline fc fp ( Spline { splineStart, splineCurves = OpenCurves prevCurves } ) + case mbSpline' of + Nothing -> do + _ <- fc Nothing lastCurve + pure Nothing + Just ( Spline { splineStart = start', splineCurves = OpenCurves prevCurves' } ) -> + case prevCurves' of + Empty -> do + mbLastCurve' <- fc ( Just start' ) lastCurve + case mbLastCurve' of + Nothing -> + pure ( Just $ Spline { splineStart = start', splineCurves = NoCurves } ) + Just lastCurve' -> + pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves Empty lastCurve' } ) + ( prevPrevCurves' :|> prevLastCurve' ) -> do + let + prevPt' = openCurveEnd prevLastCurve' + mbLastCurve' <- fc ( Just prevPt' ) lastCurve + case mbLastCurve' of + Nothing -> + pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevPrevCurves' ( dropCurveEnd prevLastCurve' ) } ) + Just lastCurve' -> + pure ( Just $ Spline { splineStart = start', splineCurves = ClosedCurves prevCurves' lastCurve' } ) diff --git a/src/lib/Math/Bezier/Stroke.hs b/src/lib/Math/Bezier/Stroke.hs index ddbd986..dd74c22 100644 --- a/src/lib/Math/Bezier/Stroke.hs +++ b/src/lib/Math/Bezier/Stroke.hs @@ -1,36 +1,47 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} module Math.Bezier.Stroke - ( StrokePoint(PP, CP, ..) - , Offset(..) - , stroke, joinWithBrush + ( Offset(..) + , CachedStroke(..), discardCache + , computeStrokeOutline, joinWithBrush , withTangent , between, parallel ) where -- base +import Prelude + hiding ( unzip ) import Control.Arrow - ( first ) + ( first, (***) ) import Control.Monad - ( guard ) + ( guard, unless ) +import Data.Bifunctor + ( Bifunctor(bimap) ) +import Data.Foldable + ( for_ ) +import Data.List.NonEmpty + ( unzip ) import Data.Maybe ( fromMaybe, mapMaybe ) import GHC.Generics - ( Generic ) + ( Generic, Generic1 ) -- acts import Data.Act @@ -44,524 +55,615 @@ import Data.Act import Data.Sequence ( Seq(..) ) import qualified Data.Sequence as Seq - ( splitAt, drop, dropWhileL - , zipWith, zipWith3, zipWith4 - ) + ( singleton ) -- deepseq import Control.DeepSeq - ( NFData ) + ( NFData, NFData1 ) -- generic-lens -import Data.Generics.Product.Fields - ( field, field' ) import Data.Generics.Product.Typed ( HasType(typed) ) import Data.GenericLens.Internal - ( set, over, view ) + ( set, view ) --- monad-par -import Control.Monad.Par - ( Par ) -import qualified Control.Monad.Par as Par - ( get, runPar, spawn, spawnP ) +-- groups +import Data.Group + ( Group ) + +-- parallel +import qualified Control.Parallel.Strategies as Strats + ( rdeepseq, parTuple2, using ) + +-- transformers +import Control.Monad.Trans.Class + ( lift ) +import Control.Monad.Trans.Except + ( Except, runExcept, throwE ) +import Control.Monad.Trans.State.Strict + ( StateT, runStateT, evalStateT, get, put ) +import Control.Monad.Trans.Writer.CPS + ( Writer, runWriter, tell ) -- MetaBrush import qualified Math.Bezier.Cubic as Cubic import Math.Bezier.Cubic.Fit ( FitPoint, FitParameters, fitSpline ) +import Math.Bezier.Spline + ( SplineType(..), SSplineType(..), SplineTypeI + , ssplineType, adjustSplineType + , NextPoint(..), fromNextPoint + , KnownSplineType + ( bitraverseSpline, ibifoldSpline, bimapSpline ) + , Spline(..), SplinePts, Curves(..), Curve(..) + , openCurveStart, openCurveEnd + , splitSplineAt, dropCurves + ) import qualified Math.Bezier.Quadratic as Quadratic import Math.Epsilon ( epsilon ) import Math.Module ( Module((^-^), (*^)), Inner((^.^)) - , lerp, squaredNorm + , lerp, squaredNorm, cross ) import Math.Roots ( solveQuadratic ) import Math.Vector2D - ( Point2D(..), Vector2D(..), cross ) + ( Point2D(..), Vector2D(..) ) -------------------------------------------------------------------------------- -data StrokePoint d - = PathPoint - { coords :: !( Point2D Double ) - , pointData :: d - } - | ControlPoint - { coords :: !( Point2D Double ) - , pointData :: d - } - deriving stock ( Show, Generic ) - deriving anyclass NFData - -instance Act ( Vector2D Double ) ( StrokePoint d ) where - (•) v = over ( field' @"coords" ) ( v • ) -instance Act ( Vector2D Double ) ( Seq ( StrokePoint d ) ) where - (•) v = fmap ( v • ) - -pattern PP, CP :: Point2D Double -> StrokePoint () -pattern PP p = PathPoint p () -pattern CP p = ControlPoint p () - data Offset = Offset { offsetIndex :: !Int , offsetParameter :: !( Maybe Double ) , offset :: !( Vector2D Double ) ---, curvature :: !Double } deriving stock ( Show, Generic ) deriving anyclass NFData +data TwoSided a + = TwoSided + { fwd :: !a + , bwd :: !a + } + deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable ) + deriving anyclass ( NFData, NFData1 ) + +type OutlineData = TwoSided ( SplinePts Open, Seq FitPoint ) +instance Semigroup OutlineData where + TwoSided ( fwdSpline1, fwdPts1 ) ( bwdSpline1, bwdPts1 ) <> TwoSided ( fwdSpline2, fwdPts2 ) ( bwdSpline2, bwdPts2 ) = + TwoSided + ( fwdSpline1 <> fwdSpline2, fwdPts1 <> fwdPts2 ) + ( bwdSpline2 <> bwdSpline1, bwdPts2 <> bwdPts1 ) +instance Monoid OutlineData where + mempty = TwoSided empt empt + where + empt :: ( SplinePts Open, Seq FitPoint ) + empt = ( Spline { splineStart = Point2D 0 0, splineCurves = OpenCurves Empty }, Empty ) + +newtype CachedStroke = CachedStroke { upToDateFit :: Maybe OutlineData } + deriving stock ( Show, Generic ) + deriving anyclass NFData + +discardCache :: HasType CachedStroke crvData => crvData -> crvData +discardCache = set ( typed @CachedStroke ) ( CachedStroke Nothing ) + +coords :: forall ptData. HasType ( Point2D Double ) ptData => ptData -> Point2D Double +coords = view typed + -------------------------------------------------------------------------------- -stroke - :: forall x d - . ( Show x, Show d - , HasType ( Seq ( StrokePoint x ) ) d +computeStrokeOutline :: + forall diffParams ( clo :: SplineType ) brushParams crvData ptData + . ( KnownSplineType clo + , Group diffParams, Module Double diffParams + , Torsor diffParams brushParams + , HasType ( Point2D Double ) ptData + , HasType CachedStroke crvData + , NFData ptData, NFData crvData ) => FitParameters - -> Seq ( StrokePoint d ) - -> ( Either ( Seq ( StrokePoint () ) ) ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ), Seq FitPoint ) -stroke _ Empty = ( Left Empty, Empty ) -stroke _ ( spt0 :<| Empty ) = ( Left . removePointData $ ( Point2D 0 0 --> coords spt0 :: Vector2D Double ) • brushShape @x spt0, Empty ) -stroke params allPts@( spt0 :<| spt1 :<| spts ) - | isClosed - = if null ( brushShape @x spt0 ) - then ( Right mempty, mempty ) - else ( Right ( fwdPts, bwdPts ), fwdFits <> bwdFits ) - | otherwise - = if null ( brushShape @x spt0 ) - then ( Left Empty, Empty ) - else ( Left ( startingCap <> fwdPts <> bwdPts ), fwdFits <> bwdFits ) + -> ( ptData -> brushParams ) + -> ( brushParams -> SplinePts Closed ) + -> Spline clo crvData ptData + -> ( Spline clo crvData ptData + , Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed ) + , Seq FitPoint + ) +computeStrokeOutline fitParams ptParams brushFn spline@( Spline { splineStart = spt0, splineCurves } ) = case ssplineType @clo of + -- Open brush path with at least one segment. + SOpen + | OpenCurves curves <- splineCurves + , firstCurve :<| _ <- curves + , prevCurves :|> lastCurve <- curves + , let + endPt :: ptData + endPt = openCurveEnd lastCurve + startTgt, endTgt :: Vector2D Double + startTgt = coords spt0 --> coords ( openCurveStart firstCurve ) + endTgt = case prevCurves of + Empty -> endTangent spt0 spt0 lastCurve + _ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve + startBrush, endBrush :: SplinePts Closed + startBrush = brushShape spt0 + endBrush = brushShape endPt + fwdPts, bwdPts :: SplinePts Open + fwdFits, bwdFits :: Seq FitPoint + newSpline :: Spline clo crvData ptData + ( newSpline, TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) ) + = updateSpline startTgt + startCap, endCap :: SplinePts Open + startCap + = fmap ( MkVector2D ( coords spt0 ) • ) + $ joinWithBrush ( withTangent ( (-1) *^ startTgt ) startBrush ) ( withTangent startTgt startBrush ) startBrush + endCap + = fmap ( MkVector2D ( coords endPt ) • ) + $ joinWithBrush ( withTangent endTgt endBrush ) ( withTangent ( (-1) *^ endTgt ) endBrush ) endBrush + -> ( newSpline + , Left ( adjustSplineType @Closed $ startCap <> fwdPts <> endCap <> bwdPts ) + , fwdFits <> bwdFits + ) + -- Closed brush path with at least one segment. + SClosed + | ClosedCurves prevCurves lastCurve <- splineCurves + , let + startTgt, endTgt :: Vector2D Double + startTgt = case prevCurves of + Empty -> startTangent spt0 spt0 lastCurve + firstCrv :<| _ -> startTangent spt0 spt0 firstCrv + endTgt = case prevCurves of + Empty -> endTangent spt0 spt0 lastCurve + _ :|> lastPrev -> endTangent spt0 ( openCurveEnd lastPrev ) lastCurve + fwdPts, bwdPts :: SplinePts Open + fwdFits, bwdFits :: Seq FitPoint + newSpline :: Spline clo crvData ptData + ( newSpline, TwoSided ( fwdPts, fwdFits ) ( bwdPts, bwdFits ) ) + = updateSpline endTgt + fwdStartCap, bwdStartCap :: SplinePts Open + TwoSided fwdStartCap bwdStartCap + = fmap fst . snd . runWriter + $ tellBrushJoin endTgt spt0 startTgt + -> ( newSpline + , Right ( adjustSplineType @Closed ( fwdStartCap <> fwdPts ), adjustSplineType @Closed ( bwdPts <> bwdStartCap ) ) + , fwdFits <> bwdFits + ) + -- Single point. + _ -> ( spline + , Left $ bimapSpline ( const id ) ( MkVector2D ( coords spt0 ) • ) ( brushShape spt0 ) + , Empty + ) where - startOffset, endOffset :: Vector2D Double - tgt_start, tgt_end :: Vector2D Double - brush_start, brush_end :: Seq ( StrokePoint x ) - startOffset = Point2D 0 0 --> coords spt0 - tgt_start = coords spt0 --> coords spt1 - ( tgt_end, endOffset, brush_end ) = case allPts of - _ :|> sptnm1 :|> sptn -> ( coords sptnm1 --> coords sptn, Point2D 0 0 --> coords sptn, brushShape @x sptn ) - _ -> error "impossible" - brush_start = brushShape @x spt0 + brushShape :: ptData -> SplinePts Closed + brushShape pt = brushFn ( ptParams pt ) - isClosed :: Bool - isClosed = case ( spt1 :<| spts ) of - ( _ :|> PathPoint { coords = lpt } ) - | lpt == coords spt0 - -> True - _ -> False + updateSpline :: Vector2D Double -> ( Spline clo crvData ptData, OutlineData ) + updateSpline lastTgt + = runWriter + . ( `evalStateT` lastTgt ) + $ fmap ( adjustSplineType @clo ) + $ bitraverseSpline + ( \ ptData curve -> do + prev_tgt <- get + let + tgt :: Vector2D Double + tgt = startTangent spt0 ptData curve + lift $ tellBrushJoin prev_tgt ptData tgt + curve' <- lift $ strokeOutline ptData curve + put ( endTangent spt0 ptData curve ) + pure curve' + ) + pure + ( adjustSplineType @Open spline ) - fwdPts, bwdPts :: Seq ( StrokePoint () ) - fwdFits, bwdFits :: Seq FitPoint - ( ( fwdPts, fwdFits ), ( bwdPts, bwdFits ) ) = Par.runPar $ go spt0 ( spt1 :<| spts ) + strokeOutline + :: ptData -> Curve Open crvData ptData + -> Writer OutlineData ( Curve Open crvData ptData ) + strokeOutline sp0 line@( LineTo { curveEnd = NextPoint sp1, curveData } ) = + let + p0, p1 :: Point2D Double + p0 = coords sp0 + p1 = coords sp1 + tgt :: Vector2D Double + tgt = p0 --> p1 + brush :: Double -> SplinePts Closed + brush t = brushFn ( lerp @diffParams t ( ptParams sp0 ) ( ptParams sp1 ) ) + fwd, bwd :: Double -> ( Point2D Double, Vector2D Double ) + fwd t + = ( off t + , if squaredNorm offTgt < epsilon then tgt else offTgt + ) + where + off :: Double -> Point2D Double + off x = offset ( withTangent tgt ( brush x ) ) • lerp @( Vector2D Double ) x p0 p1 + offTgt :: Vector2D Double + offTgt + | t < 0.5 + = 1e9 *^ ( off t --> off (t + 1e-9) ) + | otherwise + = 1e9 *^ ( off (t - 1e-9) --> off t ) + bwd t + = ( off s + , if squaredNorm offTgt < epsilon then (-1) *^ tgt else offTgt + ) + where + s :: Double + s = 1 - t + off :: Double -> Point2D Double + off x = offset ( withTangent ( (-1) *^ tgt ) ( brush x ) ) • lerp @( Vector2D Double ) x p0 p1 + offTgt :: Vector2D Double + offTgt + | s < 0.5 + = 1e9 *^ ( off s --> off (s + 1e-9) ) + | otherwise + = 1e9 *^ ( off (s - 1e-9) --> off s ) + in do + crvData' <- updateCurveData curveData fwd bwd + pure ( line { curveData = crvData' } ) + strokeOutline sp0 bez2@( Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2, curveData } ) = + let + p0, p1, p2 :: Point2D Double + p0 = coords sp0 + p1 = coords sp1 + p2 = coords sp2 + bez :: Quadratic.Bezier ( Point2D Double ) + bez = Quadratic.Bezier {..} + brush :: Double -> SplinePts Closed + brush t = brushFn + $ Quadratic.bezier @diffParams + ( Quadratic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ) t + fwd, bwd :: Double -> ( Point2D Double, Vector2D Double ) + fwd t + = ( off t + , if squaredNorm offTgt < epsilon then Quadratic.bezier' bez t else offTgt + ) + where + off :: Double -> Point2D Double + off x = offset ( withTangent ( Quadratic.bezier' bez x ) ( brush x ) ) • Quadratic.bezier @( Vector2D Double ) bez x + offTgt :: Vector2D Double + offTgt + | t < 0.5 + = 1e9 *^ ( off t --> off (t + 1e-9) ) + | otherwise + = 1e9 *^ ( off (t - 1e-9) --> off t ) + bwd t + = ( off s + , if squaredNorm offTgt < epsilon then (-1) *^ Quadratic.bezier' bez s else offTgt + ) + where + s :: Double + s = 1 - t + off :: Double -> Point2D Double + off x = offset ( withTangent ( (-1) *^ Quadratic.bezier' bez x ) ( brush x ) ) • Quadratic.bezier @( Vector2D Double ) bez x + offTgt :: Vector2D Double + offTgt + | s < 0.5 + = 1e9 *^ ( off s --> off (s + 1e-9) ) + | otherwise + = 1e9 *^ ( off (s - 1e-9) --> off s ) + in do + crvData' <- updateCurveData curveData fwd bwd + pure ( bez2 { curveData = crvData' } ) + strokeOutline sp0 bez3@( Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3, curveData } ) = + let + p0, p1, p2, p3 :: Point2D Double + p0 = coords sp0 + p1 = coords sp1 + p2 = coords sp2 + p3 = coords sp3 + bez :: Cubic.Bezier ( Point2D Double ) + bez = Cubic.Bezier {..} + brush :: Double -> SplinePts Closed + brush t = brushFn + $ Cubic.bezier @diffParams + ( Cubic.Bezier ( ptParams sp0 ) ( ptParams sp1 ) ( ptParams sp2 ) ( ptParams sp3 ) ) t + fwd, bwd :: Double -> ( Point2D Double, Vector2D Double ) + fwd t + = ( off t + , if squaredNorm offTgt < epsilon then Cubic.bezier' bez t else offTgt + ) + where + off :: Double -> Point2D Double + off x = offset ( withTangent ( Cubic.bezier' bez x ) ( brush x ) ) • Cubic.bezier @( Vector2D Double ) bez x + offTgt :: Vector2D Double + offTgt + | t < 0.5 + = 1e9 *^ ( off t --> off (t + 1e-9) ) + | otherwise + = 1e9 *^ ( off (t - 1e-9) --> off t ) + bwd t + = ( off s + , if squaredNorm offTgt < epsilon then (-1) *^ Cubic.bezier' bez s else offTgt + ) + where + s :: Double + s = 1 - t + off :: Double -> Point2D Double + off x = offset ( withTangent ( (-1) *^ Cubic.bezier' bez x ) ( brush x ) ) • Cubic.bezier @( Vector2D Double ) bez x + offTgt :: Vector2D Double + offTgt + | s < 0.5 + = 1e9 *^ ( off s --> off (s + 1e-9) ) + | otherwise + = 1e9 *^ ( off (s - 1e-9) --> off s ) + in do + crvData' <- updateCurveData curveData fwd bwd + pure ( bez3 { curveData = crvData' } ) + + updateCurveData + :: crvData + -> ( Double -> ( Point2D Double, Vector2D Double ) ) + -> ( Double -> ( Point2D Double, Vector2D Double ) ) + -> Writer OutlineData crvData + updateCurveData curveData fwd bwd = case upToDateFit $ view ( typed @CachedStroke ) curveData of + -- Cached fit data is available: use it. + Just ( TwoSided fwdData bwdData ) -> do + tell ( TwoSided fwdData bwdData ) + pure curveData + -- No cached fit: compute the fit anew. + Nothing -> do + let + fwdData, bwdData :: ( SplinePts Open, Seq FitPoint ) + ( fwdData, bwdData ) = + ( fitSpline fitParams fwd, fitSpline fitParams bwd ) + `Strats.using` + ( Strats.parTuple2 Strats.rdeepseq Strats.rdeepseq ) + outlineData :: OutlineData + outlineData = TwoSided fwdData bwdData + tell ( outlineData ) + pure ( set ( typed @CachedStroke ) ( CachedStroke $ Just outlineData ) curveData ) - (<~>) - :: ( Monoid a, Monoid b ) - => ( a, b ) - -> ( a, b ) - -> ( a, b ) - (a1, b1) <~> (a2, b2) = ( a1 <> a2, b2 <> b1 ) -- Connecting paths at a point of discontinuity of the tangent vector direction (G1 discontinuity). -- This happens at corners of the brush path (including endpoints of an open brush path, where the tangent flips direction). - joinAndContinue + tellBrushJoin :: Vector2D Double - -> StrokePoint d - -> Seq ( StrokePoint d ) - -> Par ( ( Seq ( StrokePoint () ), Seq FitPoint ), ( Seq ( StrokePoint () ), Seq FitPoint ) ) - joinAndContinue tgt sp0 ( sp1 :<| sps ) - | tgt' `parallel` tgt - = go sp0 ( sp1 :<| sps ) - | let + -> ptData + -> Vector2D Double + -> Writer OutlineData () + tellBrushJoin prevTgt sp0 tgt + | tgt `parallel` prevTgt + = pure () + | otherwise + = tell brushJoin + where ptOffset :: Vector2D Double ptOffset = Point2D 0 0 --> coords sp0 - = do - let - brushJoin :: ( ( Seq ( StrokePoint () ), Seq FitPoint ), ( Seq ( StrokePoint () ), Seq FitPoint ) ) - brushJoin = - ( ( ptOffset • joinWithBrush ( withTangent tgt brush0 ) ( withTangent tgt' brush0 ) brush0, Empty ) - , ( ptOffset • joinWithBrush ( withTangent ( (-1) *^ tgt' ) brush0 ) ( withTangent ( (-1) *^ tgt ) brush0 ) brush0, Empty ) - ) - next <- go sp0 ( sp1 :<| sps ) - pure ( brushJoin <~> next ) - where - tgt' :: Vector2D Double - tgt' = coords sp0 --> coords sp1 - brush0 :: Seq ( StrokePoint () ) - brush0 = removePointData $ brushShape @x sp0 - joinAndContinue _ _ Empty - -- Closed curve. - | isClosed - = pure $ - if parallel tgt_start tgt_end - then mempty - else ( ( startOffset • joinWithBrush ( withTangent tgt_start brush_start ) ( withTangent tgt_end brush_start ) brush_start, Empty ) - , ( startOffset • joinWithBrush ( withTangent ( (-1) *^ tgt_start ) brush_start ) ( withTangent ( (-1) *^ tgt_end ) brush_start ) brush_start, Empty ) - ) - -- Open curve. - | otherwise - = pure - ( ( endOffset • joinWithBrush ( withTangent tgt_end brush_end ) ( withTangent ( (-1) *^ tgt_end ) brush_end ) brush_end, Empty ) - , ( Empty, Empty ) -- handled separately: see 'startingCap' below - ) - - -- Final cap for an open curve. Handled separately for correct stroke order. - startingCap :: Seq ( StrokePoint () ) - startingCap - = startOffset • joinWithBrush ( withTangent ( (-1) *^ tgt_start ) brush_start ) ( withTangent tgt_start brush_start ) brush_start - - go :: StrokePoint d -> Seq ( StrokePoint d ) -> Par ( ( Seq ( StrokePoint () ), Seq FitPoint ), ( Seq ( StrokePoint () ), Seq FitPoint ) ) - go _ Empty = pure mempty - -- Line. - go sp0 ( sp1 :<| sps ) - | PathPoint {} <- sp1 - , let - p0, p1 :: Point2D Double - p0 = coords sp0 - p1 = coords sp1 - tgt :: Vector2D Double - tgt = p0 --> p1 - brush :: Double -> Seq ( StrokePoint () ) - brush t = lerpBrush t ( brushShape @x sp0 ) ( brushShape @x sp1 ) - fwd, bwd :: Double -> ( Point2D Double, Vector2D Double ) - fwd t - = ( off t - , if squaredNorm offTgt < epsilon then tgt else offTgt - ) - where - off :: Double -> Point2D Double - off x = offset ( withTangent tgt ( brush x ) ) • lerp @( Vector2D Double ) x p0 p1 - offTgt :: Vector2D Double - offTgt - | t < 0.5 - = 1e9 *^ ( off t --> off (t + 1e-9) ) - | otherwise - = 1e9 *^ ( off (t - 1e-9) --> off t ) - bwd t - = ( off s - , if squaredNorm offTgt < epsilon then (-1) *^ tgt else offTgt - ) - where - s :: Double - s = 1 - t - off :: Double -> Point2D Double - off x = offset ( withTangent ( (-1) *^ tgt ) ( brush x ) ) • lerp @( Vector2D Double ) x p0 p1 - offTgt :: Vector2D Double - offTgt - | s < 0.5 - = 1e9 *^ ( off s --> off (s + 1e-9) ) - | otherwise - = 1e9 *^ ( off (s - 1e-9) --> off s ) - = do - fwdIVar <- Par.spawnP ( fitCurve fwd ) - bwdIVar <- Par.spawnP ( fitCurve bwd ) - nextIVar <- Par.spawn ( joinAndContinue tgt sp1 sps ) - fwdCurve <- Par.get fwdIVar - bwdCurve <- Par.get bwdIVar - next <- Par.get nextIVar - pure $ ( fwdCurve, bwdCurve ) <~> next - -- Quadratic Bézier curve. - go sp0 ( sp1 :<| sp2 :<| sps ) - | ControlPoint {} <- sp1 - , PathPoint {} <- sp2 - , let - p0, p1, p2 :: Point2D Double - p0 = coords sp0 - p1 = coords sp1 - p2 = coords sp2 - tgt2 :: Vector2D Double - tgt2 = p1 --> p2 - bez :: Quadratic.Bezier ( Point2D Double ) - bez = Quadratic.Bezier {..} - brush :: Double -> Seq ( StrokePoint () ) - brush t = quadraticBezierBrush t - ( Quadratic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) ) - fwd, bwd :: Double -> ( Point2D Double, Vector2D Double ) - fwd t - = ( off t - , if squaredNorm offTgt < epsilon then Quadratic.bezier' bez t else offTgt - ) - where - off :: Double -> Point2D Double - off x = offset ( withTangent ( Quadratic.bezier' bez x ) ( brush x ) ) • Quadratic.bezier @( Vector2D Double ) bez x - offTgt :: Vector2D Double - offTgt - | t < 0.5 - = 1e9 *^ ( off t --> off (t + 1e-9) ) - | otherwise - = 1e9 *^ ( off (t - 1e-9) --> off t ) - bwd t - = ( off s - , if squaredNorm offTgt < epsilon then (-1) *^ Quadratic.bezier' bez s else offTgt - ) - where - s :: Double - s = 1 - t - off :: Double -> Point2D Double - off x = offset ( withTangent ( (-1) *^ Quadratic.bezier' bez x ) ( brush x ) ) • Quadratic.bezier @( Vector2D Double ) bez x - offTgt :: Vector2D Double - offTgt - | s < 0.5 - = 1e9 *^ ( off s --> off (s + 1e-9) ) - | otherwise - = 1e9 *^ ( off (s - 1e-9) --> off s ) - = do - fwdIVar <- Par.spawnP ( fitCurve fwd ) - bwdIVar <- Par.spawnP ( fitCurve bwd ) - nextIVar <- Par.spawn ( joinAndContinue tgt2 sp2 sps ) - fwdCurve <- Par.get fwdIVar - bwdCurve <- Par.get bwdIVar - next <- Par.get nextIVar - pure $ ( fwdCurve, bwdCurve ) <~> next - -- Cubic Bézier curve. - go sp0 ( sp1 :<| sp2 :<| sp3 :<| sps ) - | ControlPoint {} <- sp1 - , ControlPoint {} <- sp2 - , PathPoint {} <- sp3 - , let - p0, p1, p2, p3 :: Point2D Double - p0 = coords sp0 - p1 = coords sp1 - p2 = coords sp2 - p3 = coords sp3 - tgt3 :: Vector2D Double - tgt3 = p2 --> p3 - bez :: Cubic.Bezier ( Point2D Double ) - bez = Cubic.Bezier {..} - brush :: Double -> Seq ( StrokePoint () ) - brush t = cubicBezierBrush t - ( Cubic.Bezier ( brushShape @x sp0 ) ( brushShape @x sp1 ) ( brushShape @x sp2 ) ( brushShape @x sp3 ) ) - fwd, bwd :: Double -> ( Point2D Double, Vector2D Double ) - fwd t - = ( off t - , if squaredNorm offTgt < epsilon then Cubic.bezier' bez t else offTgt - ) - where - off :: Double -> Point2D Double - off x = offset ( withTangent ( Cubic.bezier' bez x ) ( brush x ) ) • Cubic.bezier @( Vector2D Double ) bez x - offTgt :: Vector2D Double - offTgt - | t < 0.5 - = 1e9 *^ ( off t --> off (t + 1e-9) ) - | otherwise - = 1e9 *^ ( off (t - 1e-9) --> off t ) - bwd t - = ( off s - , if squaredNorm offTgt < epsilon then (-1) *^ Cubic.bezier' bez s else offTgt - ) - where - s :: Double - s = 1 - t - off :: Double -> Point2D Double - off x = offset ( withTangent ( (-1) *^ Cubic.bezier' bez x ) ( brush x ) ) • Cubic.bezier @( Vector2D Double ) bez x - offTgt :: Vector2D Double - offTgt - | s < 0.5 - = 1e9 *^ ( off s --> off (s + 1e-9) ) - | otherwise - = 1e9 *^ ( off (s - 1e-9) --> off s ) - = do - fwdIVar <- Par.spawnP ( fitCurve fwd ) - bwdIVar <- Par.spawnP ( fitCurve bwd ) - nextIVar <- Par.spawn ( joinAndContinue tgt3 sp3 sps ) - fwdCurve <- Par.get fwdIVar - bwdCurve <- Par.get bwdIVar - next <- Par.get nextIVar - pure $ ( fwdCurve, bwdCurve ) <~> next - go p0 ps = error $ "stroke: unrecognised stroke type\n" <> show ( p0 :<| ps ) - - fitCurve - :: ( Double -> ( Point2D Double, Vector2D Double ) ) - -> ( Seq ( StrokePoint () ), Seq FitPoint ) - fitCurve = first splinePoints . fitSpline params + brush0 :: SplinePts Closed + brush0 = brushShape sp0 + fwdJoin, bwdJoin :: SplinePts Open + fwdJoin + = fmap ( ptOffset • ) + $ joinWithBrush ( withTangent prevTgt brush0 ) ( withTangent tgt brush0 ) brush0 + bwdJoin + = fmap ( ptOffset • ) + $ joinWithBrush ( withTangent ( (-1) *^ tgt ) brush0 ) ( withTangent ( (-1) *^ prevTgt ) brush0 ) brush0 + brushJoin :: OutlineData + brushJoin = TwoSided ( fwdJoin, Empty ) ( bwdJoin, Empty ) ----------------------------------- -- Various utility functions -- used in the "stroke" function. ----- -brushShape :: forall x d. HasType ( Seq ( StrokePoint x ) ) d => StrokePoint d -> Seq ( StrokePoint x ) -brushShape = view typed . pointData -removePointData :: Seq ( StrokePoint d ) -> Seq ( StrokePoint () ) -removePointData = fmap ( set ( field @"pointData" ) () ) +startTangent, endTangent :: ( SplineTypeI clo, HasType ( Point2D Double ) ptData ) => ptData -> ptData -> Curve clo crvData ptData -> Vector2D Double +startTangent sp p0 ( LineTo mp1 _ ) = coords p0 --> coords ( fromNextPoint sp mp1 ) +startTangent _ p0 ( Bezier2To p1 _ _ ) = coords p0 --> coords p1 +startTangent _ p0 ( Bezier3To p1 _ _ _ ) = coords p0 --> coords p1 +endTangent sp p0 ( LineTo mp1 _ ) = coords p0 --> coords ( fromNextPoint sp mp1 ) +endTangent sp _ ( Bezier2To p0 mp1 _ ) = coords p0 --> coords ( fromNextPoint sp mp1 ) +endTangent sp _ ( Bezier3To _ p0 mp1 _ ) = coords p0 --> coords ( fromNextPoint sp mp1 ) -lerpBrush :: forall d. Show d => Double -> Seq ( StrokePoint d ) -> Seq ( StrokePoint d ) -> Seq ( StrokePoint () ) -lerpBrush t p0s p1s = Seq.zipWith f p0s p1s - where - f :: StrokePoint d -> StrokePoint d -> StrokePoint () - f ( PathPoint { coords = p0 } ) - ( PathPoint { coords = p1 } ) - = PP $ lerp @( Vector2D Double ) t p0 p1 - f ( ControlPoint { coords = p0 } ) - ( ControlPoint { coords = p1 } ) - = CP $ lerp @( Vector2D Double ) t p0 p1 - f p1 p2 = error $ "stroke: incompatible brushes " <> show [ p1, p2 ] - -quadraticBezierBrush :: forall d. Show d => Double -> Quadratic.Bezier ( Seq ( StrokePoint d ) ) -> Seq ( StrokePoint () ) -quadraticBezierBrush t ( Quadratic.Bezier p0s p1s p2s ) = Seq.zipWith3 f p0s p1s p2s - where - f :: StrokePoint d -> StrokePoint d -> StrokePoint d -> StrokePoint () - f ( PathPoint { coords = p0 } ) - ( PathPoint { coords = p1 } ) - ( PathPoint { coords = p2 } ) - = PP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t - f ( ControlPoint { coords = p0 } ) - ( ControlPoint { coords = p1 } ) - ( ControlPoint { coords = p2 } ) - = CP $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t - f p1 p2 p3 = error $ "stroke: incompatible brushes " <> show [ p1, p2, p3 ] - -cubicBezierBrush :: forall d. Show d => Double -> Cubic.Bezier ( Seq ( StrokePoint d ) ) -> Seq ( StrokePoint () ) -cubicBezierBrush t ( Cubic.Bezier p0s p1s p2s p3s ) = Seq.zipWith4 f p0s p1s p2s p3s - where - f :: StrokePoint d -> StrokePoint d -> StrokePoint d -> StrokePoint d -> StrokePoint () - f ( PathPoint { coords = p0 } ) - ( PathPoint { coords = p1 } ) - ( PathPoint { coords = p2 } ) - ( PathPoint { coords = p3 } ) - = PP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier {..} ) t - f ( ControlPoint { coords = p0 } ) - ( ControlPoint { coords = p1 } ) - ( ControlPoint { coords = p2 } ) - ( ControlPoint { coords = p3 } ) - = CP $ Cubic.bezier @( Vector2D Double ) ( Cubic.Bezier {..} ) t - f p1 p2 p3 p4 = error $ "stroke: incompatible brushes " <> show [ p1, p2, p3, p4 ] - - -splinePoints :: Seq ( Cubic.Bezier ( Point2D Double ) ) -> Seq ( StrokePoint () ) -splinePoints Empty = Empty -splinePoints ps@( Cubic.Bezier p0 _ _ _ :<| _ ) = PP p0 :<| go ps - where - go :: Seq ( Cubic.Bezier ( Point2D Double ) ) -> Seq ( StrokePoint () ) - go Empty = Empty - go ( Cubic.Bezier _ p1 p2 p3 :<| pts ) = CP p1 :<| CP p2 :<| PP p3 :<| go pts +lastTangent :: HasType ( Point2D Double ) ptData => Spline Closed crvData ptData -> Maybe ( Vector2D Double ) +lastTangent ( Spline { splineCurves = NoCurves } ) = Nothing +lastTangent ( Spline { splineStart, splineCurves = ClosedCurves Empty lst } ) = Just $ endTangent splineStart splineStart lst +lastTangent ( Spline { splineStart, splineCurves = ClosedCurves ( _ :|> prev ) lst } ) = Just $ endTangent splineStart ( openCurveEnd prev ) lst -------------------------------------------------------------------------------- -- | Compute the join at a point of discontinuity of the tangent vector direction (G1 discontinuity). -joinWithBrush :: forall d. Show d => Offset -> Offset -> Seq ( StrokePoint d ) -> Seq ( StrokePoint () ) +joinWithBrush :: forall crvData ptData. HasType ( Point2D Double ) ptData => Offset -> Offset -> Spline Closed crvData ptData -> SplinePts Open joinWithBrush ( Offset { offsetIndex = i1, offsetParameter = mb_t1 } ) ( Offset { offsetIndex = i2, offsetParameter = mb_t2 } ) - pts + spline | i2 > i1 = let - pcs, lastAndRest :: Seq ( StrokePoint d ) - ( pcs, lastAndRest ) = Seq.splitAt ( i2 - i1 ) $ Seq.drop i1 pts + pcs, lastAndRest :: Maybe ( SplinePts Open ) + ( pcs, lastAndRest ) + = unzip + $ ( discardCurveData *** discardCurveData ) + . splitSplineAt ( i2 - i1 ) + <$> dropCurves i1 openSpline in - snd ( splitFirstPiece t1 pcs ) <> dropFirstPiece pcs <> fst ( splitFirstPiece t2 lastAndRest ) + fromMaybe empty $ + mconcat + [ snd <$> ( splitFirstPiece t1 =<< pcs ) + , dropFirstPiece =<< pcs + , fst <$> ( splitFirstPiece t2 =<< lastAndRest ) + ] | i2 == i1 && mb_t2 >= mb_t1 = let - pcs :: Seq ( StrokePoint d ) - pcs = Seq.drop i1 pts + pcs :: Maybe ( SplinePts Open ) + pcs = discardCurveData <$> dropCurves i1 openSpline in - fst ( splitFirstPiece t2 $ snd ( splitFirstPiece t1 pcs ) ) + fromMaybe empty + ( fst <$> ( splitFirstPiece t2 =<< snd <$> ( splitFirstPiece t1 =<< pcs ) ) ) | otherwise = let - start, middle, end :: Seq ( StrokePoint d ) - ( ( middle, end ), start ) = first ( Seq.splitAt i2 ) $ Seq.splitAt i1 pts + start, middle, end :: SplinePts Open + ( ( middle, end ), start ) + = ( ( discardCurveData *** discardCurveData ) *** discardCurveData ) + $ first ( splitSplineAt i2 ) + $ splitSplineAt i1 openSpline in - snd ( splitFirstPiece t1 start ) <> dropFirstPiece start <> removePointData middle <> fst ( splitFirstPiece t2 end ) + fromMaybe empty $ + mconcat + [ snd <$> splitFirstPiece t1 start + , dropFirstPiece start + , Just middle + , fst <$> splitFirstPiece t2 end + ] where + empty :: SplinePts Open + empty = Spline { splineStart = Point2D 0 0, splineCurves = OpenCurves Empty } + openSpline :: Spline Open crvData ptData + openSpline = adjustSplineType spline t1, t2 :: Double t1 = fromMaybe 0.5 mb_t1 t2 = fromMaybe 0.5 mb_t2 --- | Drop the first piece in a sequence of Bézier pieces. -dropFirstPiece :: Seq ( StrokePoint d ) -> Seq ( StrokePoint () ) -dropFirstPiece - = removePointData - . Seq.dropWhileL ( \case { ControlPoint {} -> True; _ -> False } ) - . Seq.drop 1 + +discardCurveData + :: ( Bifunctor f, HasType ( Point2D Double ) ptData ) + => f crvData ptData -> f () ( Point2D Double ) +discardCurveData = bimap ( const () ) coords + +-- | Drop the first curve in a Bézier spline. +dropFirstPiece :: HasType ( Point2D Double ) ptData => Spline Open crvData ptData -> Maybe ( SplinePts Open ) +dropFirstPiece ( Spline { splineCurves = OpenCurves curves } ) = case curves of + Empty -> Nothing + fstPiece :<| laterPieces -> + Just $ Spline + { splineStart = coords ( openCurveEnd fstPiece ) + , splineCurves = OpenCurves $ fmap discardCurveData laterPieces + } -- | Subdivide the first piece at the given parameter, discarding the subsequent pieces. -splitFirstPiece :: Show d => Double -> Seq ( StrokePoint d ) -> ( Seq ( StrokePoint () ), Seq ( StrokePoint () ) ) --- Line. -splitFirstPiece t ( sp0 :<| sp1 :<| _ ) - | PathPoint { coords = p0 } <- sp0 - , PathPoint { coords = p1 } <- sp1 - , let - p :: Point2D Double - p = lerp @( Vector2D Double ) t p0 p1 - = ( PP p0 :<| PP p :<| Empty - , PP p :<| PP p1 :<| Empty - ) --- Quadratic Bézier curve. -splitFirstPiece t ( sp0 :<| sp1 :<| sp2 :<| _ ) - | PathPoint { coords = p0 } <- sp0 - , ControlPoint { coords = p1 } <- sp1 - , PathPoint { coords = p2 } <- sp2 - , let - q1, p, r1 :: Point2D Double - ( Quadratic.Bezier _ q1 p, Quadratic.Bezier _ r1 _ ) - = Quadratic.subdivide @( Vector2D Double ) ( Quadratic.Bezier {..} ) t - = ( PP p0 :<| CP q1 :<| PP p :<| Empty - , PP p :<| CP r1 :<| PP p2 :<| Empty - ) --- Cubic Bézier curve. -splitFirstPiece t ( sp0 :<| sp1 :<| sp2 :<| sp3 :<| _ ) - | PathPoint { coords = p0 } <- sp0 - , ControlPoint { coords = p1 } <- sp1 - , ControlPoint { coords = p2 } <- sp2 - , PathPoint { coords = p3 } <- sp3 - , let - q1, q2, p, r1, r2 :: Point2D Double - ( Cubic.Bezier _ q1 q2 p, Cubic.Bezier _ r1 r2 _ ) - = Cubic.subdivide @( Vector2D Double ) ( Cubic.Bezier {..} ) t - = ( PP p0 :<| CP q1 :<| CP q2 :<| PP p :<| Empty - , PP p :<| CP r1 :<| CP r2 :<| PP p3 :<| Empty - ) --- Anything else. -splitFirstPiece _ _ = ( Empty, Empty ) -- error ( "splitFirstPiece: unexpected stroke point data" <> show pcs ) +splitFirstPiece :: HasType ( Point2D Double ) ptData => Double -> Spline Open crvData ptData -> Maybe ( SplinePts Open, SplinePts Open ) +splitFirstPiece t ( Spline { splineStart = sp0, splineCurves = OpenCurves curves } ) = case curves of + Empty -> Nothing + fstPiece :<| _ -> case fstPiece of + LineTo { curveEnd = NextPoint sp1 } -> + let + p1, p :: Point2D Double + p1 = coords sp1 + p = lerp @( Vector2D Double ) t p0 p1 + in + Just + ( Spline + { splineStart = p0 + , splineCurves = OpenCurves . Seq.singleton + $ LineTo { curveEnd = NextPoint p , curveData = () } + } + , Spline + { splineStart = p + , splineCurves = OpenCurves . Seq.singleton + $ LineTo { curveEnd = NextPoint p1, curveData = () } + } + ) + Bezier2To { controlPoint = sp1, curveEnd = NextPoint sp2 } -> + let + p1, p2, q1, p, r1 :: Point2D Double + p1 = coords sp1 + p2 = coords sp2 + ( Quadratic.Bezier _ q1 p, Quadratic.Bezier _ r1 _ ) + = Quadratic.subdivide @( Vector2D Double ) ( Quadratic.Bezier {..} ) t + in + Just + ( Spline + { splineStart = p0 + , splineCurves = OpenCurves . Seq.singleton + $ Bezier2To { controlPoint = q1, curveEnd = NextPoint p , curveData = () } + } + , Spline + { splineStart = p + , splineCurves = OpenCurves . Seq.singleton + $ Bezier2To { controlPoint = r1, curveEnd = NextPoint p2, curveData = () } + } + ) + Bezier3To { controlPoint1 = sp1, controlPoint2 = sp2, curveEnd = NextPoint sp3 } -> + let + p1, p2, p3, q1, q2, p, r1, r2 :: Point2D Double + p1 = coords sp1 + p2 = coords sp2 + p3 = coords sp3 + ( Cubic.Bezier _ q1 q2 p, Cubic.Bezier _ r1 r2 _ ) + = Cubic.subdivide @( Vector2D Double ) ( Cubic.Bezier {..} ) t + in + Just + ( Spline + { splineStart = p0 + , splineCurves = OpenCurves . Seq.singleton + $ Bezier3To { controlPoint1 = q1, controlPoint2 = q2, curveEnd = NextPoint p , curveData = () } + } + , Spline + { splineStart = p + , splineCurves = OpenCurves . Seq.singleton + $ Bezier3To { controlPoint1 = r1, controlPoint2 = r2, curveEnd = NextPoint p3, curveData = () } + } + ) + where + p0 :: Point2D Double + p0 = coords sp0 -------------------------------------------------------------------------------- -- | Finds the point at which a convex nib (given by a piecewise Bézier curve) has the given tangent vector. -- -- Does /not/ check that the provided nib shape is convex. -withTangent :: forall d. Vector2D Double -> Seq ( StrokePoint d ) -> Offset -withTangent tgt ( spt0 :<| spt1 :<| spts ) = - let - tgt0 :: Vector2D Double - tgt0 = coords spt0 --> coords spt1 - in - if parallel tgt tgt0 - then Offset 0 ( Just 0 ) ( MkVector2D $ coords spt0 ) - else go 0 tgt0 spt0 spt1 spts - +withTangent + :: forall crvData ptData + . ( HasType ( Point2D Double ) ptData, Show crvData, Show ptData ) + => Vector2D Double -> Spline Closed crvData ptData -> Offset +withTangent tgt_wanted spline@( Spline { splineStart } ) = case lastTangent spline of + Nothing -> + Offset { offsetIndex = 0, offsetParameter = Just 0, offset = MkVector2D ( coords splineStart ) } + Just tgt_last -> + case runExcept . ( `runStateT` tgt_last ) $ ibifoldSpline go ( \ _ -> pure () ) $ adjustSplineType @Open spline of + Left off -> off + _ -> error $ + "withTangent: could not find any point with given tangent vector\n\ + \tangent vector: " <> show tgt_wanted <> "\n\ + \spline: " <> show spline <> "\n" where - go :: Int -> Vector2D Double -> StrokePoint d -> StrokePoint d -> Seq ( StrokePoint d ) -> Offset - go _ _ ( ControlPoint { } ) _ _ = error "withTangent: path starts with a control point" - -- Line. - go i tgt0 - ( PathPoint { coords = p0 } ) - ( sp1@( PathPoint { coords = p1 } ) ) - ps - | parallel tgt tgt0 - = Offset i Nothing ( MkVector2D $ lerp @( Vector2D Double ) 0.5 p0 p1 ) + go :: Int -> ptData -> Curve Open crvData ptData -> StateT ( Vector2D Double ) ( Except Offset ) () + go i cp cseg = do + tgt_prev <- get + let + p :: Point2D Double + p = coords cp + seg :: Curve Open crvData ( Point2D Double ) + seg = fmap coords cseg + tgt_start, tgt_end :: Vector2D Double + tgt_start = startTangent splineStart cp cseg + tgt_end = endTangent splineStart cp cseg + -- Handle corner. + unless ( parallel tgt_prev tgt_start ) do + for_ ( between tgt_wanted tgt_prev tgt_start ) \ _ -> + lift . throwE $ + Offset + { offsetIndex = i + , offsetParameter = Just 0 + , offset = MkVector2D p + } + -- Handle segment. + lift $ handleSegment i p seg tgt_start + put tgt_end + + handleSegment :: Int -> Point2D Double -> Curve Open crvData ( Point2D Double ) -> Vector2D Double -> Except Offset () + handleSegment i p0 ( LineTo ( NextPoint p1 ) _ ) tgt0 + | parallel tgt_wanted tgt0 + , let + offset :: Vector2D Double + offset = MkVector2D $ lerp @( Vector2D Double ) 0.5 p0 p1 + = throwE ( Offset { offsetIndex = i, offsetParameter = Nothing, offset } ) | otherwise - = continue ( i + 1 ) tgt0 sp1 ps - -- Quadratic Bézier curve. - go i tgt0 - ( PathPoint { coords = p0 } ) - ( ControlPoint { coords = p1 } ) - ( sp2@( PathPoint { coords = p2 } ) :<| ps ) = + = pure () + handleSegment i p0 ( Bezier2To p1 ( NextPoint p2 ) _ ) tgt0 = let tgt1 :: Vector2D Double tgt1 = p1 --> p2 - in case between tgt tgt0 tgt1 of - Just t -> Offset i ( Just t ) ( MkVector2D $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t ) - Nothing -> continue ( i + 2 ) tgt1 sp2 ps - -- Cubic Bézier curve. - go i tgt0 - ( PathPoint { coords = p0 } ) - ( ControlPoint { coords = p1 } ) - ( ControlPoint { coords = p2 } :<| sp3@( PathPoint { coords = p3 } ) :<| ps ) = + in for_ ( between tgt_wanted tgt0 tgt1 ) \ t -> + throwE $ + Offset + { offsetIndex = i + , offsetParameter = Just t + , offset = MkVector2D $ Quadratic.bezier @( Vector2D Double ) ( Quadratic.Bezier {..} ) t + } + handleSegment i p0 ( Bezier3To p1 p2 ( NextPoint p3 ) _ ) tgt0 = let tgt1, tgt2 :: Vector2D Double tgt1 = p1 --> p2 @@ -569,42 +671,30 @@ withTangent tgt ( spt0 :<| spt1 :<| spts ) = bez :: Cubic.Bezier ( Point2D Double ) bez = Cubic.Bezier {..} c01, c12, c23 :: Double - c01 = tgt `cross` tgt0 - c12 = tgt `cross` tgt1 - c23 = tgt `cross` tgt2 + c01 = tgt_wanted `cross` tgt0 + c12 = tgt_wanted `cross` tgt1 + c23 = tgt_wanted `cross` tgt2 correctTangentParam :: Double -> Maybe Double correctTangentParam t | t > -epsilon && t < 1 + epsilon - , tgt ^.^ Cubic.bezier' bez t > epsilon + , tgt_wanted ^.^ Cubic.bezier' bez t > epsilon = Just ( max 0 ( min 1 t ) ) | otherwise = Nothing in - case mapMaybe correctTangentParam $ solveQuadratic c01 ( 2 * ( c12 - c01 ) ) ( c01 + c23 - 2 * c12 ) of - ( t : _ ) - -> Offset i ( Just t ) ( MkVector2D $ Cubic.bezier @( Vector2D Double ) bez t ) - _ - | Just s <- between tgt tgt0 tgt2 - -- Fallback in case we couldn't solve the quadratic for some reason. - -> Offset i ( Just s ) ( MkVector2D $ Cubic.bezier @( Vector2D Double ) bez s ) - -- Otherwise: go to next piece of the curve. - | otherwise - -> continue ( i + 3 ) tgt2 sp3 ps - go _ _ _ _ _ - = error "withTangent: unrecognised path type (more than two consecutive control points)" - - -- Handles corners in the Bézier curve. - continue :: Int -> Vector2D Double -> StrokePoint d -> Seq ( StrokePoint d ) -> Offset - continue _ _ _ Empty = Offset 0 ( Just 0 ) ( MkVector2D $ coords spt0 ) - continue i ptgt p0 ( p1 :<| ps ) = - let - tgt0 :: Vector2D Double - tgt0 = coords p0 --> coords p1 - in case between tgt ptgt tgt0 of - Just _ -> Offset i ( Just 0 ) ( MkVector2D $ coords p0 ) - Nothing -> go i tgt0 p0 p1 ps - -withTangent _ _ = error $ "withTangent: invalid path (fewer than 2 points)" + let + mbParam :: Maybe Double + mbParam = + case mapMaybe correctTangentParam $ solveQuadratic c01 ( 2 * ( c12 - c01 ) ) ( c01 + c23 - 2 * c12 ) of + ( t : _ ) -> Just t + _ -> between tgt_wanted tgt0 tgt2 -- fallback in case we couldn't solve the quadratic for some reason + in for_ mbParam \ t -> + throwE $ + Offset + { offsetIndex = i + , offsetParameter = Just t + , offset = MkVector2D $ Cubic.bezier @( Vector2D Double ) bez t + } -- | Finds whether the query vector @ u @ lies between the two provided vectors @ v0 @, @ v1 @. -- diff --git a/src/lib/Math/Module.hs b/src/lib/Math/Module.hs index 71255cf..f336631 100644 --- a/src/lib/Math/Module.hs +++ b/src/lib/Math/Module.hs @@ -10,7 +10,8 @@ module Math.Module ( Module(..), lerp , Inner(..) , squaredNorm, quadrance, distance - , proj, projC, closestPointToSegment + , proj, projC, closestPointOnSegment + , cross ) where @@ -18,7 +19,7 @@ module Math.Module import Control.Applicative ( liftA2 ) import Data.Monoid - ( Ap(..) ) + ( Ap(..), Sum(..) ) -- acts import Data.Act @@ -28,6 +29,14 @@ import Data.Act ( (-->) ) ) +-- groups +import Data.Group + ( invert ) + +-- MetaBrush +import Math.Vector2D + ( Vector2D(..), Segment(..) ) + -------------------------------------------------------------------------------- infixl 6 ^+^, ^-^ @@ -35,8 +44,9 @@ infix 9 ^*, *^ class Num r => Module r m | m -> r where - {-# MINIMAL (^+^), ( (^*) | (*^) ) #-} + {-# MINIMAL origin, (^+^), ( (^*) | (*^) ) #-} + origin :: m (^+^) :: m -> m -> m (^-^) :: m -> m -> m (*^) :: r -> m -> m @@ -47,6 +57,7 @@ class Num r => Module r m | m -> r where m ^-^ n = m ^+^ (-1) *^ n instance ( Applicative f, Module r m ) => Module r ( Ap f m ) where + origin = pure origin (^+^) = liftA2 (^+^) (^-^) = liftA2 (^-^) (*^) r = fmap ( r *^ ) @@ -79,11 +90,11 @@ proj x y = projC x y *^ y projC :: forall m r. ( Inner r m, Fractional r ) => m -> m -> r projC x y = x ^.^ y / squaredNorm y -closestPointToSegment +closestPointOnSegment :: forall v r p . ( Inner r v, Torsor v p, Fractional r, Ord r ) - => p -> p -> p -> ( r, p ) -closestPointToSegment c p0 p1 + => p -> Segment p -> ( r, p ) +closestPointOnSegment c ( Segment p0 p1 ) | t <= 0 = ( 0, p0 ) | t >= 1 @@ -95,3 +106,36 @@ closestPointToSegment c p0 p1 v01 = p0 --> p1 t :: r t = projC ( p0 --> c ) v01 + + +instance Num a => Module a ( Sum a ) where + + origin = Sum 0 + + (^+^) = (<>) + ( Sum x ) ^-^ ( Sum y ) = Sum ( x - y ) + + c *^ ( Sum x ) = Sum ( c * x ) + ( Sum x ) ^* c = Sum ( x * c ) + +instance Num a => Inner a ( Sum a ) where + Sum a ^.^ Sum b = a * b + + +instance Num a => Module a ( Vector2D a ) where + + origin = pure 0 + + (^+^) = (<>) + p ^-^ q = p <> invert q + + c *^ p = fmap ( c * ) p + p ^* c = fmap ( * c ) p + +instance Num a => Inner a ( Vector2D a ) where + ( Vector2D x1 y1 ) ^.^ ( Vector2D x2 y2 ) + = x1 * x2 + y1 * y2 + +cross :: Num a => Vector2D a -> Vector2D a -> a +cross ( Vector2D x1 y1 ) ( Vector2D x2 y2 ) + = x1 * y2 - x2 * y1 \ No newline at end of file diff --git a/src/lib/Math/Vector2D.hs b/src/lib/Math/Vector2D.hs index 4719d44..555d435 100644 --- a/src/lib/Math/Vector2D.hs +++ b/src/lib/Math/Vector2D.hs @@ -9,7 +9,7 @@ module Math.Vector2D ( Point2D(..), Vector2D(.., Vector2D), Mat22(..) - , cross + , Segment(..) ) where @@ -33,16 +33,12 @@ import Generic.Data -- groups import Data.Group - ( Group ( invert ) ) + ( Group ) -- groups-generic import Data.Group.Generics ( ) --- MetaBrush -import Math.Module - ( Module(..), Inner(..) ) - -------------------------------------------------------------------------------- data Point2D a = Point2D !a !a @@ -63,24 +59,21 @@ newtype Vector2D a = MkVector2D { tip :: Point2D a } pattern Vector2D :: a -> a -> Vector2D a pattern Vector2D x y = MkVector2D ( Point2D x y ) -instance Num a => Module a ( Vector2D a ) where - (^+^) = (<>) - p ^-^ q = p <> invert q - - c *^ p = fmap ( c * ) p - p ^* c = fmap ( * c ) p - -instance Num a => Inner a ( Vector2D a ) where - ( Vector2D x1 y1 ) ^.^ ( Vector2D x2 y2 ) - = x1 * x2 + y1 * y2 - -cross :: Num a => Vector2D a -> Vector2D a -> a -cross ( Vector2D x1 y1 ) ( Vector2D x2 y2 ) - = x1 * y2 - x2 * y1 - data Mat22 a = Mat22 !a !a !a !a deriving stock ( Show, Eq, Generic, Generic1, Functor, Foldable, Traversable ) deriving Applicative via Generically1 Mat22 deriving anyclass ( NFData, NFData1 ) + +data Segment p = + Segment + { segmentStart :: !p + , segmentEnd :: !p + } + deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable ) + deriving ( Semigroup, Monoid, Group ) + via GenericProduct ( Segment p ) + deriving Applicative + via Generically1 Segment + deriving anyclass ( NFData, NFData1 )