brush-stroking (empty) → 0.1.0.0
raw patch · 14 files changed
+3350/−0 lines, 14 filesdep +actsdep +aesondep +aeson-pretty
Dependencies added: acts, aeson, aeson-pretty, atomic-file-ops, base, brush-strokes, bytestring, containers, deepseq, directory, filepath, generic-lens, gi-cairo-connector, gi-cairo-render, groups, hashable, hermes-json, lens, mtl, scientific, stm, text, transformers, unordered-containers
Files
- brush-stroking.cabal +160/−0
- changelog.md +5/−0
- readme.md +19/−0
- src/BrushStroking/Asset/Brushes.hs +138/−0
- src/BrushStroking/Brush.hs +175/−0
- src/BrushStroking/Document.hs +153/−0
- src/BrushStroking/Document/Serialise.hs +375/−0
- src/BrushStroking/Hover.hs +86/−0
- src/BrushStroking/Layer.hs +125/−0
- src/BrushStroking/Records.hs +527/−0
- src/BrushStroking/Render/Stroke.hs +829/−0
- src/BrushStroking/Serialisable.hs +226/−0
- src/BrushStroking/Stroke.hs +427/−0
- src/BrushStroking/Unique.hs +105/−0
+ brush-stroking.cabal view
@@ -0,0 +1,160 @@+cabal-version: 3.0 +name: brush-stroking +version: 0.1.0.0 +synopsis: Brush strokes document model and renderer +category: Calligraphy, Font, Geometry, Graphics +license: BSD-3-Clause +homepage: https://https://gitlab.com/sheaf/metabrush/-/tree/master/brush-stroking +author: Sam Derbyshire +maintainer: Sam Derbyshire +build-type: Simple +description: + + Document model and renderer, companion to the + <https://hackage.haskell.org/package/brush-strokes brush-strokes> library. + + This library deals with documents that are made up of many brush strokes, + in a hierarchical layer structure, and supports serialisation and rendering + of such documents. + +extra-doc-files: + readme.md + changelog.md + +source-repository head + type: git + location: https://gitlab.com/sheaf/MetaBrush + +common common + + default-extensions: + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveTraversable + DeriveGeneric + DerivingVia + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralisedNewtypeDeriving + InstanceSigs + LambdaCase + LexicalNegation + MagicHash + MultiWayIf + NamedFieldPuns + NoStarIsType + PatternSynonyms + RankNTypes + RecordWildCards + RoleAnnotations + StandaloneDeriving + StandaloneKindSignatures + TupleSections + TypeApplications + TypeFamilyDependencies + TypeOperators + UnboxedTuples + ViewPatterns + + if impl(ghc >= 9.8) + default-extensions: + TypeAbstractions + + ghc-options: + -Wall + -Wcompat + -fwarn-missing-local-signatures + -fwarn-incomplete-patterns + -fwarn-incomplete-uni-patterns + -fwarn-missing-deriving-strategies + -fno-warn-unticked-promoted-constructors + + autogen-modules: + Paths_brush_stroking + + other-modules: + Paths_brush_stroking + +library + + import: + common + + hs-source-dirs: + src + + default-language: + Haskell2010 + + exposed-modules: + BrushStroking.Asset.Brushes + , BrushStroking.Brush + , BrushStroking.Document + , BrushStroking.Document.Serialise + , BrushStroking.Hover + , BrushStroking.Layer + , BrushStroking.Records + , BrushStroking.Render.Stroke + , BrushStroking.Serialisable + , BrushStroking.Stroke + , BrushStroking.Unique + + build-depends: + brush-strokes + ^>= 0.1.0.0 + + , base + >= 4.17 && < 5 + + -- cairo dependencies, for rendering + , gi-cairo-render + >= 0.1.0 && < 0.2 + , gi-cairo-connector + >= 0.1.0 && < 0.2 + + -- ... all other dependencies + , acts + ^>= 0.3.1.0 + , aeson + >= 2.2 && < 2.3 + , aeson-pretty + >= 0.8 && < 0.9 + , atomic-file-ops + ^>= 0.3.0.0 + , bytestring + >= 0.10.10.0 && < 0.13 + , containers + >= 0.6.0.1 && < 0.9 + , deepseq + >= 1.4.4.0 && < 1.6 + , directory + >= 1.3.4.0 && < 1.4 + , filepath + >= 1.4.2.1 && < 1.6 + , generic-lens + >= 2.2 && < 2.5 + , groups + ^>= 0.5.3 + , hashable + >= 1.3.0.0 && < 1.6 + , hermes-json + >= 0.7.0.0 && < 0.9 + , lens + >= 4.19.2 && < 6 + , mtl + >= 2.2.2 && < 2.4 + , scientific + >= 0.3.6.2 && < 0.4 + , stm + ^>= 2.5.0.0 + , text + >= 2.0 && < 3 + , transformers + >= 0.5.6.2 && < 0.7 + , unordered-containers + >= 0.2.11 && < 0.3
+ changelog.md view
@@ -0,0 +1,5 @@+# Changelog for `brush-stroking` + +## 0.1.0.0 – 2026-03-28 + +Initial Hackage release.
+ readme.md view
@@ -0,0 +1,19 @@+# `brush-stroking` + +This is a companion library to the `brush-strokes` package, providing a simple +document model and rendering (using `cairo`). + +## Installation notes + +This library requires the `cairo` C system library. + +Here are some ways to install it: + + - On Linux, you will need to install the ``cairo`` development libraries + and the GObject introspection data. On Debian for example, you can run: + `apt-get install pkg-config libcairo2-dev libgirepository1.0-dev` + - On Windows, you will need to use the MSYS2 installation that is provided by + `ghcup`. In an `MSYS2` shell, you can run: + `pacman -S -q --noconfirm mingw64/mingw-w64-x86_64-pkg-config mingw64/mingw-w64-x86_64-cairo mingw64/mingw-w64-x86_64-gobject-introspection` + - On MacOS, you should be able to use ``brew`` (untested): + `brew install pkgconf cairo gobject-introspection`
+ src/BrushStroking/Asset/Brushes.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module BrushStroking.Asset.Brushes + ( SomeBrush(..) + , lookupBrush, brushes, brushesList, brushNames + , CircleBrushFields , circle + , EllipseBrushFields , ellipse + , TearDropBrushFields , tearDrop + , RoundedTearDropBrushFields, roundedTearDrop + ) where + +-- base +import Prelude + hiding + ( Num(..), Floating(..), (^), (/), fromInteger, fromRational ) +import Data.Coerce + ( coerce ) +import Data.Kind + ( Type ) +import GHC.Exts + ( fromString ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + ( toLower ) + +-- unordered-containers +import Data.HashMap.Strict + ( HashMap ) +import qualified Data.HashMap.Strict as HashMap + ( fromList, lookup ) + +-- brush-strokes +import Calligraphy.Brushes + ( circleBrush, ellipseBrush + , tearDropBrush + , roundTearDropBrush ) +import Math.Linear +import Math.Ring + +-- MetaBrush +import BrushStroking.Brush + ( BrushName(..), NamedBrush(..), WithParams(..) ) +import BrushStroking.Records + ( KnownSymbols ) + +-------------------------------------------------------------------------------- + +type SomeBrush :: Type +data SomeBrush where + SomeBrush + :: forall brushFields + . KnownSymbols brushFields + => { someBrush :: !( NamedBrush brushFields ) + } + -> SomeBrush + +lookupBrush :: Text -> Maybe SomeBrush +lookupBrush nm = HashMap.lookup ( Text.toLower nm ) brushes + +-- | All brushes supported by this application. +brushes :: HashMap Text SomeBrush +brushes = + HashMap.fromList + [ ( nm, b ) + | b@( SomeBrush ( NamedBrush { brushName = BrushName nm } ) ) <- brushesList + ] + +-- | Like 'brushes', but in a list (for when order matters). +brushesList :: [ SomeBrush ] +brushesList = [ SomeBrush circle + , SomeBrush ellipse + , SomeBrush tearDrop + , SomeBrush roundedTearDrop ] + +brushNames :: [ Text ] +brushNames = map getName brushesList + where + getName :: SomeBrush -> Text + getName ( SomeBrush ( NamedBrush { brushName = BrushName nm } ) ) = nm + +-------------------------------------------------------------------------------- + +type CircleBrushFields = '[ "a" ] +-- | A circular brush with the given radius. +circle :: NamedBrush CircleBrushFields +circle = + NamedBrush + { brushName = BrushName "circle" + , brushFunction = WithParams deflts $ coerce circleBrush + } + where + deflts = ℝ1 10 +{-# INLINE circle #-} + +type EllipseBrushFields = '[ "a", "b", "phi" ] +-- | An elliptical brush with the given semi-major and semi-minor axes and +-- angle of rotation. +ellipse :: NamedBrush EllipseBrushFields +ellipse = + NamedBrush + { brushName = BrushName "ellipse" + , brushFunction = WithParams deflts $ coerce ellipseBrush + } + where + deflts = ℝ3 10 7 0 +{-# INLINE ellipse #-} + +type TearDropBrushFields = '[ "a", "b", "phi" ] +-- | A tear-drop shape with the given half-width, half-height and angle of rotation. +tearDrop :: NamedBrush TearDropBrushFields +tearDrop = + NamedBrush + { brushName = BrushName "tear-drop" + , brushFunction = WithParams deflts $ coerce tearDropBrush + } + where + deflts = ℝ3 10 7 0 +{-# INLINE tearDrop #-} + +type RoundedTearDropBrushFields = '[ "a", "b", "phi" ] +-- | A rounded tear-drop shape, inspired by the paper +-- "Calligraphy Brush Trajectory Control of by a Robotic Arm". +roundedTearDrop :: NamedBrush RoundedTearDropBrushFields +roundedTearDrop = + NamedBrush + { brushName = BrushName "rounded tear-drop" + , brushFunction = WithParams deflts $ coerce roundTearDropBrush + } + where + deflts = ℝ3 14 5 ( 3 * pi / 4 ) +{-# INLINE roundedTearDrop #-}
+ src/BrushStroking/Brush.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +module BrushStroking.Brush + ( WithParams(..) + , BrushName(..), NamedBrush(..) + , BrushFunction , PointFields + , provePointFields, duplicates + ) + where + +-- base +import Data.Kind + ( Type, Constraint ) +import Data.List + ( nub ) +import Data.Typeable + ( Typeable ) +import GHC.Exts + ( Proxy#, proxy# ) +import GHC.TypeLits + ( Symbol, someSymbolVal + , SomeSymbol(..) + ) +import GHC.TypeNats + ( Nat, type (<=) ) + +-- deepseq +import Control.DeepSeq + ( NFData(..) ) + +-- hashable +import Data.Hashable + ( Hashable(..) ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + ( unpack ) + +-- brush-strokes +import Calligraphy.Brushes + ( Brush(..) ) +import Math.Differentiable + ( DiffInterp, IVness(..) ) +import Math.Linear + +-- MetaBrush +import BrushStroking.Records + ( KnownSymbols, Length, Record ) +import BrushStroking.Serialisable + ( Serialisable ) + +-------------------------------------------------------------------------------- + +-- | A brush, with default parameter values. +type WithParams :: Nat -> Type +data WithParams nbParams = + WithParams + { defaultParams :: ℝ nbParams + , withParams :: Brush nbParams + } + +-------------------------------------------------------------------------------- + +-- | A brush function: a function from a record of parameters to a closed spline. +type BrushFunction :: [ Symbol ] -> Type +type BrushFunction brushFields = + WithParams ( Length brushFields ) + +type BrushName :: [ Symbol ] -> Type +newtype BrushName brushFields = BrushName Text + deriving newtype ( Eq, Ord, NFData, Hashable ) +instance Show ( BrushName brushFields ) where + show ( BrushName nm ) = Text.unpack nm +type role BrushName representational + +type NamedBrush :: [ Symbol ] -> Type +data NamedBrush brushFields where + NamedBrush + :: forall brushFields nbBrushFields + . ( nbBrushFields ~ Length brushFields + , 1 <= nbBrushFields + , KnownSymbols brushFields + , PointFields brushFields + + , Show ( ℝ nbBrushFields ), NFData ( ℝ nbBrushFields ) + ) + => { brushName :: !( BrushName brushFields ) + , brushFunction :: !( BrushFunction brushFields ) + } + -> NamedBrush brushFields + +instance Show ( NamedBrush brushFields ) where + show ( NamedBrush { brushName } ) = show brushName +instance NFData ( NamedBrush brushFields ) where + rnf ( NamedBrush { brushName } ) + = rnf brushName +instance Eq ( NamedBrush brushFields ) where + NamedBrush { brushName = name1 } == NamedBrush { brushName = name2 } + = name1 == name2 +instance Ord ( NamedBrush brushFields ) where + compare ( NamedBrush { brushName = name1 } ) ( NamedBrush { brushName = name2 } ) + = compare name1 name2 +instance Hashable ( NamedBrush brushFields ) where + hashWithSalt salt ( NamedBrush { brushName } ) = + hashWithSalt salt brushName + +type PointFields :: [ Symbol ] -> Constraint +class ( KnownSymbols pointFields, Typeable pointFields + , Serialisable ( Record pointFields ) + , Show ( Record pointFields ) + , Show ( ℝ ( Length pointFields ) ) + , NFData ( Record pointFields ) + , Representable Double ( ℝ ( Length pointFields ) ) + , RepDim ( ℝ ( Length pointFields ) ) ~ Length pointFields + , DiffInterp 2 NonIV ( Length pointFields ) + , DiffInterp 3 IsIV ( Length pointFields ) + ) + => PointFields pointFields where { } +instance ( KnownSymbols pointFields, Typeable pointFields + , Serialisable ( Record pointFields ) + , Show ( Record pointFields ) + , Show ( ℝ ( Length pointFields ) ) + , NFData ( Record pointFields ) + , Representable Double ( ℝ ( Length pointFields ) ) + , RepDim ( ℝ ( Length pointFields ) ) ~ Length pointFields + , DiffInterp 2 NonIV ( Length pointFields ) + , DiffInterp 3 IsIV ( Length pointFields ) + ) + => PointFields pointFields where { } + +-- | Assumes the input has no duplicates (doesn't check.) +provePointFields :: [ Text ] + -> ( forall pointFields. PointFields pointFields => Proxy# pointFields -> r ) + -> r +provePointFields fieldNames k = + case fieldNames of + [] + -> k ( proxy# @'[] ) + [ f1 ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + -> k ( proxy# @'[ f1 ] ) + [ f1, f2 ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 ) + -> k ( proxy# @'[ f1, f2 ] ) + [ f1, f2, f3 ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 ) + , SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 ) + -> k ( proxy# @'[ f1, f2, f3 ] ) + [ f1, f2, f3, f4 ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 ) + , SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 ) + , SomeSymbol @f4 _ <- someSymbolVal ( Text.unpack f4 ) + -> k ( proxy# @'[ f1, f2, f3, f4 ] ) + _ -> error $ "I haven't defined ℝ " ++ show ( length fieldNames ) +{-# INLINE provePointFields #-} + +duplicates :: [ Text ] -> [ Text ] +duplicates = nub . duplicatesAcc [] [] + where + duplicatesAcc :: [ Text ] -> [ Text ] -> [ Text ] -> [ Text ] + duplicatesAcc _ dups [] = dups + duplicatesAcc seen dups ( k : kvs ) + | k `elem` seen + = duplicatesAcc seen ( k : dups ) kvs + | otherwise + = duplicatesAcc ( k : seen ) dups kvs
+ src/BrushStroking/Document.hs view
@@ -0,0 +1,153 @@+module BrushStroking.Document where + +-- base +import GHC.Generics + ( Generic ) + +-- containers +import Data.Map.Strict + ( Map ) +import qualified Data.Map.Strict as Map +import Data.Set + ( Set ) +import qualified Data.Set as Set + +-- deepseq +import Control.DeepSeq + ( NFData(..) ) + +-- text +import Data.Text + ( Text ) + +-- brush-strokes +import Math.Linear + ( ℝ(..), T(..) ) + +-- MetaBrush +import BrushStroking.Layer + ( LayerMetadata, emptyHierarchy ) +import BrushStroking.Stroke + ( StrokeHierarchy, PointIndex ) +import BrushStroking.Unique + ( Unique ) + +-------------------------------------------------------------------------------- + +-- | Document, together with some extra metadata. +data Document + = Document + { documentContent :: !DocumentContent + -- ^ Main document content, which we keep track throughout history. + , documentMetadata :: !DocumentMetadata + -- ^ Metadata about the document, that we don't track throughout history. + } + deriving stock ( Show, Generic ) + deriving anyclass NFData + +newtype Zoom = Zoom { zoomFactor :: Double } + deriving stock ( Show, Eq, Ord ) + deriving newtype NFData + +-- | A collection of points, indexed first by the stroke they belong to +-- and then their position in that stroke. +newtype StrokePoints = StrokePoints { strokePoints :: Map Unique ( Set PointIndex ) } + deriving newtype ( Eq, Show, NFData ) + -- Invariant: the sets are never empty. + +instance Semigroup StrokePoints where + ( StrokePoints pts1 ) <> ( StrokePoints pts2 ) = + StrokePoints ( Map.unionWith Set.union pts1 pts2 ) +instance Monoid StrokePoints where + mempty = StrokePoints Map.empty + +-- | Remove the second set of points from the first. +differenceStrokePoints :: StrokePoints -> StrokePoints -> StrokePoints +differenceStrokePoints ( StrokePoints pts1 ) ( StrokePoints pts2 ) = + StrokePoints $ + Map.differenceWith remove pts1 pts2 + where + remove :: Set PointIndex -> Set PointIndex -> Maybe ( Set PointIndex ) + remove old new = + let new' = old Set.\\ new + in if null new' + then Nothing + else Just new' + +noStrokePoints :: StrokePoints -> Bool +noStrokePoints ( StrokePoints pts ) = null pts + +elemStrokePoint :: Unique -> PointIndex -> StrokePoints -> Bool +elemStrokePoint u i ( StrokePoints pts ) = + case Map.lookup u pts of + Nothing -> False + Just is -> Set.member i is + +-- | Metadata about a document and its content, that we don't track through +-- history. +data DocumentMetadata = + Metadata + { documentName :: !Text + , documentFilePath :: !( Maybe FilePath ) + , viewportCenter :: !( ℝ 2 ) + , documentZoom :: !Zoom + , documentSize :: !( Maybe DocumentSize ) + , documentGuides :: !( Map Unique Guide ) + , layerMetadata :: !LayerMetadata + , selectedPoints :: !StrokePoints + } + deriving stock ( Show, Generic ) + deriving anyclass NFData + +data DocumentSize = + DocumentSize + { documentTopLeft, documentBottomRight :: !( ℝ 2 ) } + deriving stock ( Show, Generic ) + deriving anyclass NFData + +-- | Main content of document (data which we keep track of throughout history). +data DocumentContent + = Content + { unsavedChanges :: !Bool + -- ^ Whether this current content is unsaved. + , strokeHierarchy :: !StrokeHierarchy + -- ^ Hierarchical structure of layers and groups. + } + deriving stock ( Show, Generic ) + deriving anyclass NFData + +-- | A guide, i.e. a horizontal or vertical line used for alignment. +data Guide + = Guide + { guidePoint :: !( ℝ 2 ) -- ^ point on the guide line + , guideNormal :: !( T ( ℝ 2 ) ) -- ^ /normalised/ normal vector of the guide + } + deriving stock ( Show, Generic ) + deriving anyclass NFData + +emptyDocument :: Text -> Document +emptyDocument docName = + Document + { documentContent = emptyDocumentContent + , documentMetadata = emptyDocumentMetadata docName + } + +emptyDocumentContent :: DocumentContent +emptyDocumentContent = + Content + { strokeHierarchy = emptyHierarchy + , unsavedChanges = False + } + +emptyDocumentMetadata :: Text -> DocumentMetadata +emptyDocumentMetadata docName = + Metadata + { documentName = docName + , documentFilePath = Nothing + , viewportCenter = ℝ2 0 0 + , documentZoom = Zoom { zoomFactor = 1 } + , documentSize = Nothing + , documentGuides = Map.empty + , layerMetadata = mempty + , selectedPoints = mempty + }
+ src/BrushStroking/Document/Serialise.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module BrushStroking.Document.Serialise + ( documentToJSON, documentFromJSON + , saveDocument, loadDocument + ) + where + +-- base +import Control.Monad + ( unless ) +import Control.Monad.ST + ( RealWorld, stToIO ) +import Control.Exception + ( try ) +import qualified Data.Bifunctor as Bifunctor + ( first ) +import Data.Maybe + ( fromMaybe, maybeToList ) +import Data.STRef + ( newSTRef ) +import Data.Traversable + ( for ) +import Data.Version + ( Version(versionBranch) ) +import GHC.Exts + ( Proxy# ) + +-- aeson +import Data.Aeson + ( (.=) ) +import qualified Data.Aeson as Aeson + +-- aeson-pretty +import qualified Data.Aeson.Encode.Pretty as PrettyAeson + +-- atomic-file-ops +import System.IO.AtomicFileOps + ( atomicReplaceFile ) + +-- bytestring +import qualified Data.ByteString as Strict + ( ByteString ) +import qualified Data.ByteString as Strict.ByteString + ( readFile ) +import qualified Data.ByteString.Lazy as Lazy + ( ByteString ) + +-- containers +import qualified Data.Map.Strict as Map + +-- directory +import System.Directory + ( canonicalizePath, createDirectoryIfMissing, doesFileExist ) + +-- filepath +import System.FilePath + ( takeDirectory ) + +-- hermes-json +import qualified Data.Hermes as Hermes + +-- stm +import qualified Control.Concurrent.STM as STM + ( atomically ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + ( pack, unwords, unpack ) + +-- transformers +import Control.Monad.IO.Class + ( MonadIO(liftIO) ) +import qualified Control.Monad.Trans.Reader as Reader + +-- unordered-containers +import Data.HashMap.Strict + ( HashMap ) +import qualified Data.HashMap.Strict as HashMap + +-- brush-strokes +import Math.Bezier.Spline + ( SplineType(..), SSplineType(..), SplineTypeI(..) ) +import Math.Bezier.Stroke + ( CachedStroke(..) ) +import Math.Linear + ( ℝ(..) ) + +-- MetaBrush +import BrushStroking.Brush + ( provePointFields, duplicates ) +import BrushStroking.Document +import BrushStroking.Layer + ( LayerMetadata(..) ) +import BrushStroking.Serialisable +import BrushStroking.Stroke +import BrushStroking.Records + ( Record, knownSymbols ) +import BrushStroking.Unique + ( UniqueSupply, freshUnique ) +import qualified Paths_brush_stroking as Cabal + ( version ) + +-------------------------------------------------------------------------------- + +-- | Serialise a document to JSON (in the form of a lazy bytestring). +documentToJSON :: Document -> Lazy.ByteString +documentToJSON = PrettyAeson.encodePretty' $ + PrettyAeson.Config + { PrettyAeson.confIndent = PrettyAeson.Spaces 4 + , PrettyAeson.confCompare = compFn + , PrettyAeson.confNumFormat = PrettyAeson.Generic + , PrettyAeson.confTrailingNewline = False + } + where + order :: HashMap Text Int + order = + HashMap.fromList $ + zip + [ "version", "name", "zoom", "center", "strokes", "splineStart", "point", "coords", "closed" ] + [ 0 .. ] + compFn :: Text -> Text -> Ordering + compFn x y + | x == y + = EQ + | let mbIx1 = HashMap.lookup x order + mbIx2 = HashMap.lookup y order + = case ( mbIx1, mbIx2 ) of + ( Nothing, Just {} ) -> GT + ( Just {}, Nothing ) -> LT + ( Just i1, Just i2 ) -> compare i1 i2 + ( Nothing, Nothing ) -> compare x y + +-- | Parse a document from JSON (given by a strict bytestring). +-- +-- Updates the store of brushes by adding any new brushes contained in the document. +documentFromJSON + :: UniqueSupply + -> Maybe FilePath + -> Strict.ByteString + -> IO ( Either Text Document ) +documentFromJSON uniqueSupply mbFilePath docData = do + mbDoc <- + try @Hermes.HermesException $ + Hermes.decodeEitherIO ( decodeDocument uniqueSupply mbFilePath ) docData + return $ Bifunctor.first Hermes.formatException mbDoc + +-------------------------------------------------------------------------------- + +-- | Save a MetaBrush document to a file (in JSON format). +saveDocument :: FilePath -> Document -> IO () +saveDocument path doc = do + path' <- canonicalizePath path + let + dir :: FilePath + dir = takeDirectory path' + createDirectoryIfMissing True dir + exists <- doesFileExist path + unless exists do + writeFile path "" + atomicReplaceFile Nothing path' ( documentToJSON doc ) + +-- | Load a MetaBrush document. +loadDocument :: UniqueSupply -> FilePath -> IO ( Either Text Document ) +loadDocument uniqueSupply fp = do + exists <- doesFileExist fp + if exists + then ( documentFromJSON uniqueSupply ( Just fp ) =<< Strict.ByteString.readFile fp ) + else pure ( Left $ "No file at " <> Text.pack fp ) + +-------------------------------------------------------------------------------- + +instance Aeson.ToJSON brushParams => Aeson.ToJSON ( PointData brushParams ) where + toJSON ( PointData { pointCoords, brushParams } ) = + Aeson.object + [ "coords" .= pointCoords + , "brushParams" .= brushParams ] + +instance FromJSON brushParams => FromJSON ( PointData brushParams ) where + decoder = + Hermes.object $ do + pointCoords <- key "coords" + brushParams <- key "brushParams" + pure ( PointData { pointCoords, brushParams } ) + +decodeFields :: Hermes.Decoder [ Text ] +decodeFields = do + fields <- Hermes.list Hermes.text + case duplicates fields of + [] -> pure fields + [dup] -> fail ( "Duplicate field name " <> Text.unpack dup <> " in brush record type" ) + dups -> fail ( "Duplicate field names in brush record type:\n" <> Text.unpack ( Text.unwords dups ) ) + + +instance Aeson.ToJSON Stroke where + toJSON + ( Stroke + { strokeSpline = strokeSpline :: StrokeSpline clo ( Record pointFields ) + , strokeBrushName + } + ) = + let + closed :: Bool + closed = case ssplineType @clo of + SClosed -> True + SOpen -> False + mbEncodeBrush = case strokeBrushName of + Nothing -> [] + Just brushNm -> [ "brush" .= Aeson.object [ "name" .= brushNm ] ] + in + Aeson.object $ + [ "closed" .= closed + , "pointFields" .= knownSymbols @pointFields + , "spline" .= strokeSpline + ] ++ mbEncodeBrush + +newCurveData :: Integer -> Hermes.FieldsDecoder ( CurveData RealWorld ) +newCurveData i = do + emptyCache <- liftIO . stToIO $ CachedStroke <$> newSTRef Nothing + return $ + CurveData + { curveIndex = fromInteger i + , cachedStroke = emptyCache + } + +instance FromJSON Stroke where + decoder = Hermes.object do + strokeClosed <- key "closed" + mbBrushNm <- Hermes.atKeyOptional "brush" $ Hermes.object $ key "name" + pointFields <- Hermes.atKey "pointFields" decodeFields + -- decodeFields ensured there were no duplicate field names. + provePointFields pointFields \ ( _ :: Proxy# pointFields ) -> + if strokeClosed + then do + strokeSpline <- Hermes.atKey "spline" ( decodeSpline @Closed @( PointData ( Record pointFields ) ) newCurveData ) + pure $ case mbBrushNm of + Nothing -> + Stroke { strokeSpline, strokeBrushName = Nothing } + Just brushNm -> + Stroke { strokeSpline, strokeBrushName = Just brushNm } + else do + strokeSpline <- Hermes.atKey "spline" ( decodeSpline @Open @( PointData ( Record pointFields ) ) newCurveData ) + pure $ case mbBrushNm of + Nothing -> + Stroke { strokeSpline, strokeBrushName = Nothing } + Just brushNm -> + Stroke { strokeSpline, strokeBrushName = Just brushNm } + +instance Aeson.ToJSON Layer where + toJSON layer = + Aeson.object $ + [ "name" .= layerName layer + ] ++ ( if layerVisible layer then [ ] else [ "visible" .= False ] ) + ++ ( if layerLocked layer then [ "locked" .= True ] else [] ) + ++ case layer of + GroupLayer { groupChildren } -> + [ "contents" .= groupChildren ] + StrokeLayer { layerStroke } -> + [ "stroke" .= layerStroke ] + +decodeLayer :: UniqueSupply -> Hermes.Decoder Layer +decodeLayer uniqueSupply = Hermes.object $ do + mbLayerName <- keyOptional "name" + mbLayerVisible <- keyOptional "visible" + mbLayerLocked <- keyOptional "locked" + let layerVisible = fromMaybe True mbLayerVisible + layerLocked = fromMaybe False mbLayerLocked + mbLayerStroke <- keyOptional "stroke" + case mbLayerStroke of + Nothing -> do + let layerName = fromMaybe "Group" mbLayerName + groupChildren <- fromMaybe [] <$> Hermes.atKeyOptional "contents" ( Hermes.list ( decodeLayer uniqueSupply ) ) + pure ( GroupLayer { layerName, layerVisible, layerLocked, groupChildren } ) + Just layerStroke -> do + let layerName = fromMaybe "Stroke" mbLayerName + pure ( StrokeLayer { layerName, layerVisible, layerLocked, layerStroke } ) + + +instance Aeson.ToJSON Guide where + toJSON ( Guide { guidePoint, guideNormal } ) = + Aeson.object + [ "point" .= guidePoint, "normal" .= guideNormal ] + +instance FromJSON Guide where + decoder = Hermes.object do + guidePoint <- key "point" + guideNormal <- key "normal" + return $ Guide { guidePoint, guideNormal } + +instance Aeson.ToJSON DocumentSize where + toJSON ( DocumentSize { documentTopLeft = p1, documentBottomRight = p2 } ) = + Aeson.toJSON [ p1, p2 ] +instance FromJSON DocumentSize where + decoder = do + xys <- Hermes.list decoder + case xys of + [ ℝ2 x1 y1, ℝ2 x2 y2 ] -> + return $ + DocumentSize + { documentTopLeft = ℝ2 ( min x1 x2 ) ( min y1 y2 ) + , documentBottomRight = ℝ2 ( max x1 x2 ) ( max y1 y2 ) + } + _ -> fail $ unlines + [ "Cannot parse 'DocumentSize'." + , "Expected 2 points, but got: " ++ show ( length xys ) ++ "." + ] + +decodeDocumentMetadata + :: UniqueSupply + -> Maybe FilePath + -> LayerMetadata + -> Hermes.FieldsDecoder DocumentMetadata +decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata = do + mbDocName <- keyOptional "name" + mbCenter <- keyOptional "center" + zoomFactor <- keyOptional "zoom" + guides <- keyOptional "guides" + mbDocSize <- keyOptional "size" + documentGuides <- fmap Map.fromList . liftIO . STM.atomically $ + for ( fromMaybe [] guides ) $ \ guide -> do + u <- Reader.runReaderT freshUnique uniqueSupply + return ( u, guide ) + return $ + Metadata + { documentName = fromMaybe ( documentName defaultMeta ) mbDocName + , documentFilePath = mbFilePath + , viewportCenter = fromMaybe ( viewportCenter defaultMeta ) mbCenter + , documentZoom = maybe ( Zoom 1 ) Zoom zoomFactor + , documentGuides + , layerMetadata + , selectedPoints = mempty + , documentSize = mbDocSize + } + where + defaultMeta = documentMetadata $ emptyDocument "Document" + +instance Aeson.ToJSON Document where + toJSON ( Document { documentMetadata = meta, documentContent } ) = + Aeson.object $ + [ "version" .= versionBranch Cabal.version + , "name" .= documentName meta + ] ++ + [ "size" .= sz | sz <- maybeToList ( documentSize meta ) ] + ++ + [ "center" .= viewportCenter meta + , "zoom" .= ( zoomFactor $ documentZoom meta ) + , "strokes" .= ( strokeHierarchyLayers ( layerMetadata meta ) ( strokeHierarchy documentContent ) ) + ] ++ if null guides then [] else [ "guides" .= guides ] + where + guides = Map.elems $ documentGuides meta + +decodeDocument :: UniqueSupply -> Maybe FilePath -> Hermes.Decoder Document +decodeDocument uniqueSupply mbFilePath = + Hermes.object do + let + unsavedChanges :: Bool + unsavedChanges = False + mbLayers1 <- Hermes.atKeyOptional "strokes" ( Hermes.list ( decodeLayer uniqueSupply ) ) + -- Preserve back-compat (a previous format used 'content.strokes' instead of 'strokes'). + mbLayers2 <- Hermes.atKeyOptional "content" ( Hermes.object $ Hermes.atKeyOptional "strokes" ( Hermes.list ( decodeLayer uniqueSupply ) ) ) + let layers = fromMaybe [] mbLayers1 <> fromMaybe [] ( fromMaybe ( Just [] ) mbLayers2 ) + ( layerMetadata, strokeHierarchy ) <- ( `Reader.runReaderT` uniqueSupply ) $ layersStrokeHierarchy layers + let documentContent = Content { unsavedChanges, strokeHierarchy } + documentMetadata <- decodeDocumentMetadata uniqueSupply mbFilePath layerMetadata + return $ + Document + { documentMetadata + , documentContent + }
+ src/BrushStroking/Hover.hs view
@@ -0,0 +1,86 @@+module BrushStroking.Hover where + +-- base +import GHC.Generics + ( Generic ) + +-- acts +import Data.Act + ( Act(..) ) + + +-- deepseq +import Control.DeepSeq + ( NFData(..) ) + +-- brush-strokes +import Math.Module + ( quadrance + , closestPointOnSegment + ) +import Math.Linear + ( ℝ(..), T(..), Segment(..) ) + +-- MetaBrush +import BrushStroking.Document + +-------------------------------------------------------------------------------- + +-- | An axis-aligned bounding box. +data AABB + = AABB + { topLeft, botRight :: !( ℝ 2 ) } + deriving stock ( Show, Generic ) + deriving anyclass NFData + +-- | Create an 'AABB'. +mkAABB :: ℝ 2 -> ℝ 2 -> AABB +mkAABB ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) = AABB ( ℝ2 xmin ymin ) ( ℝ2 xmax ymax ) + where + ( xmin, xmax ) + | x1 > x2 = ( x2, x1 ) + | otherwise = ( x1, x2 ) + ( ymin, ymax ) + | y1 > y2 = ( y2, y1 ) + | otherwise = ( y1, y2 ) + +-- | A hover (mouse cursor or entire rectangle). +data HoverContext + = MouseHover !( ℝ 2 ) + | RectangleHover !AABB + deriving stock ( Show, Generic ) + deriving anyclass NFData + +instance Act ( T ( ℝ 2 ) ) HoverContext where + v • MouseHover p = MouseHover ( v • p ) + v • RectangleHover ( AABB p1 p2 ) = RectangleHover ( AABB ( v • p1 ) ( v • p2 ) ) + +instance Act ( T ( ℝ 2 ) ) ( Maybe HoverContext ) where + (•) v = fmap ( v • ) + +class Hoverable a where + hovered :: HoverContext -> Zoom -> a -> Bool + +instance Hoverable ( ℝ 2 ) where + hovered ( MouseHover p ) zoom q + = inLargePointClickRange zoom p q + hovered ( RectangleHover ( AABB ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) ) ) _ ( ℝ2 x y ) + = x >= x1 && x <= x2 && y >= y1 && y <= y2 + +instance Hoverable ( Segment ( ℝ 2 ) ) where + hovered ( MouseHover p ) zoom seg + = hovered ( MouseHover p ) zoom p' + where + ( _, p' ) = closestPointOnSegment @( T ( ℝ 2 ) ) p seg + hovered hov@(RectangleHover {} ) zoom ( Segment p0 p1 ) + -- Only consider a segment to be "hovered" if it lies entirely within the + -- hover rectangle, not just if the hover rectangle intersects it. + = hovered hov zoom p0 && hovered hov zoom p1 + +inLargePointClickRange :: Zoom -> ℝ 2 -> ℝ 2 -> Bool +inLargePointClickRange ( Zoom { zoomFactor } ) c p = + quadrance @( T ( ℝ 2 ) ) c p < 16 / ( zoomFactor * zoomFactor ) + +inSmallPointClickRange :: Zoom -> ℝ 2 -> ℝ 2 -> Bool +inSmallPointClickRange ( Zoom { zoomFactor } ) c p = + quadrance @( T ( ℝ 2 ) ) c p < 6 / ( zoomFactor * zoomFactor )
+ src/BrushStroking/Layer.hs view
@@ -0,0 +1,125 @@+module BrushStroking.Layer where + +-- base +import Data.Word + ( Word32 ) +import GHC.Generics + ( Generically(..), Generic ) +import GHC.Stack + +-- containers +import Data.Map.Strict + ( Map ) +import qualified Data.Map.Strict as Map +import Data.Set + ( Set ) + +-- deepseq +import Control.DeepSeq + ( NFData(..) ) + +-- text +import Data.Text + ( Text ) + +-- MetaBrush +import Debug.Utils + ( trace ) +import BrushStroking.Unique + ( Unique ) + +-------------------------------------------------------------------------------- + +-- | A layer: either a stroke or a group. +data Layer + = StrokeLayer { layerUnique :: !Unique } + | GroupLayer { layerUnique :: !Unique } + deriving stock ( Show, Eq, Generic ) + deriving anyclass NFData + +-- | Metadata about layers, e.g. their names and their visibilities. +data LayerMetadata = + LayerMetadata + { layerNames :: !( Map Unique Text ) + , invisibleLayers :: !( Set Unique ) + , lockedLayers :: !( Set Unique ) + } + deriving stock ( Show, Generic ) + deriving anyclass NFData + deriving ( Semigroup, Monoid ) + via Generically LayerMetadata + +-- | A parent of a layer. +data Parent a + -- | The layer is at the top level. + = Root + -- | The layer has this parent. + | Parent !a + deriving stock ( Show, Eq, Ord, Functor, Generic ) + deriving anyclass NFData + +-- | An item within a parent. +data WithinParent a = + WithinParent + { parent :: !( Parent Unique ) + , item :: !a + } + deriving stock ( Show, Eq, Generic, Functor ) + deriving anyclass NFData + +-- | A child layer within a parent. +type ChildLayer = WithinParent Unique +-- | A child layer, with its index among the list of children of its parent. +type ChildLayerPosition = WithinParent Word32 + +-- | Where to position something relative to another layer. +data RelativePosition + = Above + | Below + deriving stock ( Eq, Ord, Show ) + +-- | Content in a hierarchical tree-like structure. +data Hierarchy a = + Hierarchy + { topLevel :: ![ Unique ] + , groups :: !( Map Unique [ Unique ] ) + , content :: !( Map Unique a ) + } + deriving stock ( Show, Eq, Functor, Generic ) + deriving anyclass NFData + +emptyHierarchy :: Hierarchy a +emptyHierarchy = + Hierarchy + { topLevel = [] + , groups = Map.empty + , content = Map.empty + } + +lookupChildren :: HasCallStack => Parent Unique -> Hierarchy a -> [ Unique ] +lookupChildren p h = case lookupChildren_maybe p h of + Nothing -> + trace ( unlines [ "internal error in 'lookupChildren'" + , "no data for parent " ++ show p + , "" + , "call stack: " ++ prettyCallStack callStack ] + ) [] + Just cs -> cs + +lookupChildren_maybe :: Parent Unique -> Hierarchy a -> Maybe [ Unique ] +lookupChildren_maybe Root ( Hierarchy { topLevel } ) = Just topLevel +lookupChildren_maybe ( Parent u ) ( Hierarchy { groups } ) = groups Map.!? u + +insertGroup :: Parent Unique -> [ Unique ] -> Hierarchy a -> Hierarchy a +insertGroup Root us h = h { topLevel = us } +insertGroup ( Parent u ) us h = h { groups = Map.insert u us ( groups h ) } + +-- | Delete the key of a layer in a 'Hierarchy'. +-- +-- Does not remove it from any child lists, just from the "keys" of the maps. +deleteLayerKey :: Unique -> Hierarchy a -> ( Hierarchy a, Maybe [ Unique ] ) +deleteLayerKey u ( Hierarchy tl gs cs ) = + case Map.updateLookupWithKey ( \ _ _ -> Nothing ) u gs of + ( mbChildren, gs' ) -> + let cs' = Map.delete u cs + in ( Hierarchy tl gs' cs', mbChildren )
+ src/BrushStroking/Records.hs view
@@ -0,0 +1,527 @@+{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +module BrushStroking.Records where + +-- base +import Data.Functor + ( (<&>) ) +import Data.Kind + ( Type, Constraint ) +import Data.List + ( findIndex, intersperse, sortBy ) +import Data.Ord + ( comparing ) +import Data.Typeable + ( Typeable, eqT ) +import Data.Type.Equality + ( (:~:)(Refl) ) +import GHC.Exts + ( Proxy#, proxy# ) +import GHC.Show + ( showCommaSpace ) +import GHC.TypeLits + ( Symbol, KnownSymbol, symbolVal' + , SomeSymbol(..), someSymbolVal + ) +import GHC.TypeNats + ( Nat, KnownNat + , type (<=), type (<=?), type (+) + ) +import Unsafe.Coerce + ( unsafeCoerce ) + +-- acts +import Data.Act + ( Act(..), Torsor(..) ) + +-- containers +import qualified Data.Map.Strict as Map + +-- deepseq +import Control.DeepSeq + ( NFData(..) ) + +-- groups +import Data.Group + ( Group(..) ) + +-- text +import Data.Text + ( Text ) +import qualified Data.Text as Text + ( pack, unpack ) + +-- MetaBrush +import Math.Differentiable +import Math.Linear +import Math.Module + ( Module ) + +-------------------------------------------------------------------------------- + +-- | A record of 'Double' values. +type Record :: [ k ] -> Type +newtype Record ks = MkR { recordKeyVals :: ℝ ( Length ks ) } + +deriving newtype + instance Eq ( ℝ ( Length ks ) ) + => Eq ( Record ks ) +deriving newtype + instance Ord ( ℝ ( Length ks ) ) + => Ord ( Record ks ) +deriving newtype + instance NFData ( ℝ ( Length ks ) ) + => NFData ( Record ks ) + +-- | Show a record, using the given type-level field names. +instance ( KnownSymbols ks, Representable Double ( ℝ ( Length ks ) ) ) + => Show ( Record ks ) where + showsPrec p ( MkR r ) + = showParen ( p >= 11 ) + $ showString "{" + . foldr (.) id ( intersperse showCommaSpace fields ) + . showString "}" + where + fields :: [ ShowS ] + fields = + zip [ 1.. ] ( knownSymbols @ks ) <&> \ ( i, fld ) -> + let v = index r ( Fin i ) + in showString ( Text.unpack fld ) . showString " = " . showsPrec 0 v + +deriving via ( T ( ℝ ( Length ks ) ) ) + instance Semigroup ( T ( ℝ ( Length ks ) ) ) + => Semigroup ( T ( Record ks ) ) +deriving via ( T ( ℝ ( Length ks ) ) ) + instance Monoid ( T ( ℝ ( Length ks ) ) ) + => Monoid ( T ( Record ks ) ) +deriving via ( T ( ℝ ( Length ks ) ) ) + instance Group ( T ( ℝ ( Length ks ) ) ) + => Group ( T ( Record ks ) ) +deriving via ( T ( ℝ ( Length ks ) ) ) + instance Module Double ( T ( ℝ ( Length ks ) ) ) + => Module Double ( T ( Record ks ) ) + +instance ( Act ( T ( ℝ ( Length ks ) ) ) ( ℝ ( Length ks ) ) + , Semigroup ( T ( ℝ ( Length ks ) ) ) ) + => Act ( T ( Record ks ) ) ( Record ks ) where + T ( MkR g ) • MkR a = MkR ( T g • a ) +instance ( Torsor ( T ( ℝ ( Length ks ) ) ) ( ℝ ( Length ks ) ) + , Group ( T ( ℝ ( Length ks ) ) ) ) + => Torsor ( T ( Record ks ) ) ( Record ks ) where + MkR g --> MkR a = T $ MkR $ unT $ g --> a + +type instance RepDim ( Record ks ) = Length ks +deriving newtype instance ( KnownNat (Length ks) + , Representable r ( ℝ ( Length ks ) ) ) + => Representable r ( Record ks ) + +-------------------------------------------------------------------------------- + +type Length :: [ k ] -> Nat +type family Length xs where + Length '[] = 0 + Length ( _ : xs ) = 1 + Length xs + +type KnownSymbols :: [ Symbol ] -> Constraint +class Typeable ks => KnownSymbols ks where + knownSymbols :: [ Text ] +instance KnownSymbols '[] where + knownSymbols = [] + {-# INLINE knownSymbols #-} +instance ( KnownSymbol k, KnownSymbols ks ) => KnownSymbols ( k ': ks ) where + knownSymbols = Text.pack ( symbolVal' @k proxy# ) : knownSymbols @ks + {-# INLINE knownSymbols #-} + +-------------------------------------------------------------------------------- +-- Intersection of two records. + +{- Note [intersect and specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The "intersect" function does two things: + + 1. Given a row of "path" parameters (the parametrs that vary along the stroke path), + and a row of "brush" parameters (used to parametrise the brush shape), + it computes an intersection row, which is the row for which the main + brush stroking algorithms is going to be used with. + + 2. Additionally, to ensure good performance, we dispatch and then call + the continuation with specific arguments. This requires: + + - INLINE pragmas on 'intersection, 'doIntersection' etc + - explicit type applications of the continuation argument to specific types + - usage of oneShot + + This allows us to dispatch and call the appropriately specialised function, + instead of the overloaded function. + + It's essentially the following pattern: + + type C :: Type -> Constraint + type C t = ( Show t, NFData t, Num t, ... ) + -- a big bunch of constraints + + bigOverloadedFn :: forall t. C t => t -> Bool + + callOfBigFn :: Typeable t => t -> Bool + callOfBigFn x = ensureSpecialisation @t $ bigOverloadedFn ( 3 * x + 1 ) + + {-# INLINE ensureSpecialisation #-} + ensureSpecialisation :: forall x r. KnownNat x => ( forall y. C y => r ) -> r + ensureSpecialisation f + | Just Refl <- eqT @x @1 + = f @Int + | Just Refl <- eqT @x @2 + = f @Word + | Just Refl <- eqT @x @3 + = f @Double + ... + | otherwise + = error "ensureSpecialisation: unsupported type" +-} + +{-# INLINE intersect #-} +intersect :: forall r1 r2 kont + . ( KnownSymbols r1, KnownSymbols r2 ) + => ( Intersection r1 r2 -> kont ) -> kont +intersect f = + doIntersection @r1 @r2 \ ( lg1 :: Proxy# l1 ) ( lg2 :: Proxy# l2 ) ( _ :: Proxy# r1r2 ) ( lg12 :: Proxy# l12 ) r1_idxs r2_idxs -> + case ( eqT @r1 @r2, eqT @r2 @r1r2 ) of + ( Just Refl, Just Refl ) -> + -- Shortcut when the two rows are equal + f $ Intersection lg1 lg2 lg12 id id ( \ _ -> id ) ( \ _ -> id ) + _ -> + let + project1 :: Record r1 -> Record r1r2 + project1 = \ ( MkR r1 ) -> MkR $ projection ( (!) r1_idxs ) r1 + {-# INLINE project1 #-} + + project2 :: Record r2 -> Record r1r2 + project2 = \ ( MkR r2 ) -> MkR $ projection ( (!) r2_idxs ) r2 + {-# INLINE project2 #-} + + inject1 :: Record r1 -> Record r1r2 -> Record r1 + inject1 = \ ( MkR r1 ) -> \ ( MkR r1r2 ) -> MkR $ injection ( \ i -> find ( == i ) r1_idxs ) r1r2 r1 + {-# INLINE inject1 #-} + + inject2 :: Record r2 -> Record r1r2 -> Record r2 + inject2 = \ ( MkR r2 ) -> \ ( MkR r1r2 ) -> MkR $ injection ( \ i -> find ( == i ) r2_idxs ) r1r2 r2 + {-# INLINE inject2 #-} + in + f $ Intersection { lg1, lg2, lg12, project1, project2, inject1, inject2 } + +data Intersection r1 r2 where + Intersection + :: forall r1r2 r1 r2 l12 l1 l2 + . ( l12 ~ Length r1r2, l1 ~ Length r1, l2 ~ Length r2 + , l1 <= 4, l2 <= 4, l12 <= 4 + , l12 <= l1, l12 <= l2 + , KnownSymbols r1r2 + , Representable Double ( ℝ l1 ) + , Show ( ℝ l1 ), NFData ( ℝ l1 ) + , Show ( ℝ l2 ), NFData ( ℝ l2 ) + , Representable Double ( ℝ l2 ) + , Representable Double ( ℝ l12 ) + , Show ( ℝ l12 ), NFData ( ℝ l12 ) + ) + => { lg1 :: Proxy# l1 + , lg2 :: Proxy# l2 + , lg12 :: Proxy# l12 + , project1 :: Record r1 -> Record r1r2 + -- ^ project out fields present in both rows + -- (linear non-decreasing mapping) + , project2 :: Record r2 -> Record r1r2 + -- ^ project out fields present in both rows + -- (linear non-decreasing mapping) + , inject1 :: Record r1 -> Record r1r2 -> Record r1 + -- ^ overrides the components of the first record with the second + -- (linear non-decreasing mapping in its second argument) + , inject2 :: Record r2 -> Record r1r2 -> Record r2 + -- ^ overrides the components of the first record with the second + -- (linear non-decreasing mapping in its second argument) + } -> Intersection r1 r2 + +{-# INLINE doIntersection #-} +doIntersection + :: forall r1 r2 kont + . ( KnownSymbols r1, KnownSymbols r2 + ) + => ( forall r1r2 l12 l1 l2. + ( l1 ~ Length r1, l2 ~ Length r2 + , l1 <= 4, l2 <= 4, l12 <= 4 + , r1r2 ~ Intersect r1 r2 + , KnownSymbols r1r2, l12 ~ Length r1r2 + , l12 <= l1, l12 <= l2 + , Representable Double ( ℝ l1 ) + , Show ( ℝ l1 ), NFData ( ℝ l1 ) + , Show ( ℝ l2 ), NFData ( ℝ l2 ) + , Representable Double ( ℝ l2 ) + , Representable Double ( ℝ l12 ) + , Show ( ℝ l12 ), NFData ( ℝ l12 ) + ) + => Proxy# l1 -> Proxy# l2 -> Proxy# r1r2 -> Proxy# l12 -> Vec l12 ( Fin l1 ) -> Vec l12 ( Fin l2 ) -> kont ) + -> kont +doIntersection k = + proveDicts @r1 $ \ ( px_l1 :: Proxy# l1 ) -> + proveDicts @r2 $ \ ( px_l2 :: Proxy# l2 ) -> + case knownSymbols @r1 `intersectLists` knownSymbols @r2 of + + [ ] + | Refl <- ( unsafeCoerce Refl :: '[ ] :~: Intersect r1 r2 ) + , Refl <- ( unsafeCoerce Refl :: ( 0 <=? l1 ) :~: True ) + , Refl <- ( unsafeCoerce Refl :: ( 0 <=? l2 ) :~: True ) + -> k @'[ ] px_l1 px_l2 proxy# ( proxy# :: Proxy# 0 ) + ( Vec [] ) + ( Vec [] ) + + [ ( f1, r1_i1, r2_i1 ) ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , Refl <- ( unsafeCoerce Refl :: '[ f1 ] :~: Intersect r1 r2 ) + , Refl <- ( unsafeCoerce Refl :: ( 1 <=? l1 ) :~: True ) + , Refl <- ( unsafeCoerce Refl :: ( 1 <=? l2 ) :~: True ) + -> k @'[ f1 ] px_l1 px_l2 proxy# ( proxy# :: Proxy# 1 ) + ( Vec [ Fin r1_i1 ] ) + ( Vec [ Fin r2_i1 ] ) + + [ ( f1, r1_i1, r2_i1 ) + , ( f2, r1_i2, r2_i2 ) ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 ) + , Refl <- ( unsafeCoerce Refl :: '[ f1, f2 ] :~: Intersect r1 r2 ) + , Refl <- ( unsafeCoerce Refl :: ( 2 <=? l1 ) :~: True ) + , Refl <- ( unsafeCoerce Refl :: ( 2 <=? l2 ) :~: True ) + -> k @'[ f1, f2 ] px_l1 px_l2 proxy# ( proxy# :: Proxy# 2 ) + ( Vec [ Fin r1_i1, Fin r1_i2 ] ) + ( Vec [ Fin r2_i1, Fin r2_i2 ] ) + + [ ( f1, r1_i1, r2_i1 ) + , ( f2, r1_i2, r2_i2 ) + , ( f3, r1_i3, r2_i3 ) ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 ) + , SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 ) + , Refl <- ( unsafeCoerce Refl :: '[ f1, f2, f3 ] :~: Intersect r1 r2 ) + , Refl <- ( unsafeCoerce Refl :: ( 3 <=? l1 ) :~: True ) + , Refl <- ( unsafeCoerce Refl :: ( 3 <=? l2 ) :~: True ) + -> k @'[ f1, f2, f3 ] px_l1 px_l2 proxy# ( proxy# :: Proxy# 3 ) + ( Vec [ Fin r1_i1, Fin r1_i2, Fin r1_i3 ] ) + ( Vec [ Fin r2_i1, Fin r2_i2, Fin r2_i3 ] ) + + [ ( f1, r1_i1, r2_i1 ) + , ( f2, r1_i2, r2_i2 ) + , ( f3, r1_i3, r2_i3 ) + , ( f4, r1_i4, r2_i4 ) ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 ) + , SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 ) + , SomeSymbol @f4 _ <- someSymbolVal ( Text.unpack f4 ) + , Refl <- ( unsafeCoerce Refl :: [ f1, f2, f3, f4 ] :~: Intersect r1 r2 ) + , Refl <- ( unsafeCoerce Refl :: ( 4 <=? l1 ) :~: True ) + , Refl <- ( unsafeCoerce Refl :: ( 4 <=? l2 ) :~: True ) + -> k @'[ f1, f2, f3, f4 ] px_l1 px_l2 proxy# ( proxy# :: Proxy# 4 ) + ( Vec [ Fin r1_i1, Fin r1_i2, Fin r1_i3, Fin r1_i4 ] ) + ( Vec [ Fin r2_i1, Fin r2_i2, Fin r2_i3, Fin r2_i4 ] ) + + other -> + error $ "Intersection not defined in dimension " ++ show ( length other ) + +{-# INLINE proveDicts #-} +proveDicts + :: forall r kont + . ( KnownSymbols r ) => + ( forall l + . ( Length r ~ l, l <= 4 + , Representable Double ( ℝ l ) + , Show ( ℝ l ), NFData ( ℝ l ) + ) + => Proxy# l -> kont + ) + -> kont +proveDicts k = + case knownSymbols @r of + [ ] + | Refl <- ( unsafeCoerce Refl :: Length r :~: 0 ) + -> k @0 proxy# + [ _ ] + | Refl <- ( unsafeCoerce Refl :: Length r :~: 1 ) + -> k @1 proxy# + [ _, _ ] + | Refl <- ( unsafeCoerce Refl :: Length r :~: 2 ) + -> k @2 proxy# + [ _, _, _ ] + | Refl <- ( unsafeCoerce Refl :: Length r :~: 3 ) + -> k @3 proxy# + [ _, _, _, _ ] + | Refl <- ( unsafeCoerce Refl :: Length r :~: 4 ) + -> k @4 proxy# + _ -> + error "proveDicts: instances not defined in dimension >= 5" + +------ +-- Functions for intersection. + +intersectLists :: forall k. Eq k => [ k ] -> [ k ] -> [ ( k, Word, Word ) ] +intersectLists = go 1 + where + go :: Word -> [ k ] -> [ k ] -> [ ( k, Word, Word ) ] + go _ [] _ + = [] + go i ( k : ks ) r + | Just j <- findIndex ( k == ) r + = ( k, i, fromIntegral j + 1 ) : go ( i + 1 ) ks r + | otherwise + = go ( i + 1 ) ks r + +type Intersect :: [ k ] -> [ k ] -> [ k ] +type family Intersect r1 r2 where + Intersect '[] _ = '[] + Intersect ( k ': ks ) r = DoIntersection k ks r ( Elem k r ) + +type DoIntersection :: k -> [ k ] -> [ k ] -> Bool -> [ k ] +type family DoIntersection k ks r mb_j where + DoIntersection _ ks r False = Intersect ks r + DoIntersection k ks r True = k ': Intersect ks r + +type Elem :: k -> [ k ] -> Bool +type family Elem k ks where + Elem _ '[] = False + Elem k ( k ': _ ) = True + Elem k ( _ ': ks ) = Elem k ks + +-------------------------------------------------------------------------------- +-- Union of two records. + +data Union r1 r2 where + Union + :: forall r1r2 r1 r2 l12 + . ( l12 ~ Length r1r2 + , KnownSymbols r1r2 + , Representable Double ( ℝ l12 ) + , Show ( ℝ l12 ) + , NFData ( ℝ l12 ) + , DiffInterp 2 NonIV l12 + , DiffInterp 3 IsIV l12 + ) + => { unionWith :: ( Double -> Double -> Double ) + -> Record r1 -> Record r2 -> Record r1r2 + -- ^ union of two records + } -> Union r1 r2 + +{-# INLINE union #-} +union :: forall r1 r2 l1 l2 + . ( KnownSymbols r1, KnownSymbols r2 + , l1 ~ Length r1, l2 ~ Length r2 + , Representable Double ( ℝ l1 ) + , Representable Double ( ℝ l2 ) + , Show ( ℝ l1 ) + , Show ( ℝ l2 ) + , NFData ( ℝ l2 ) + , DiffInterp 2 NonIV l2 + , DiffInterp 3 IsIV l2 + ) + => Union r1 r2 +union + -- Shortcut when the two rows are equal. + | Just Refl <- eqT @r1 @r2 + = Union { unionWith = \ f ( MkR l ) ( MkR r ) -> MkR @Symbol @r1 ( tabulate $ \ i -> f ( index l i ) ( index r i ) ) } + | otherwise + = doUnion @r1 @r2 \ ( _ :: Proxy# r1r2 ) idxs -> + let + unionWith :: ( Double -> Double -> Double ) + -> Record r1 -> Record r2 -> Record r1r2 + unionWith f = \ ( MkR r1 ) ( MkR r2 ) -> MkR $ tabulate $ \ i -> + case idxs ! i of + InBoth i1 i2 -> f ( index r1 i1 ) ( index r2 i2 ) + InL i1 -> index r1 i1 + InR i2 -> index r2 i2 + in Union { unionWith } + + +data LR l r + = InBoth !l !r + | InL !l + | InR !r + deriving stock ( Eq, Show ) + +bimapLR :: ( l1 -> l2 ) -> ( r1 -> r2 ) -> LR l1 r1 -> LR l2 r2 +bimapLR f g = \case + InL l -> InL ( f l ) + InR r -> InR ( g r ) + InBoth l r -> InBoth ( f l ) ( g r ) + +instance ( Ord l, Ord r ) => Ord ( LR l r ) where + compare a b = compare ( getL a, getR a ) ( getL b, getR b ) + where + getL :: LR l r -> Maybe l + getL ( InL l ) = Just l + getL ( InBoth l _ ) = Just l + getL ( InR {} ) = Nothing + getR :: LR l r -> Maybe r + getR ( InL {} ) = Nothing + getR ( InBoth _ r ) = Just r + getR ( InR r ) = Just r + +{-# INLINE doUnion #-} +doUnion + :: forall r1 r2 l1 l2 kont + . ( KnownSymbols r1, KnownSymbols r2 + , l1 ~ Length r1, l2 ~ Length r2 + ) + => ( forall r1r2 l12. + ( KnownSymbols r1r2, l12 ~ Length r1r2 + , DiffInterp 2 NonIV l12 + , DiffInterp 3 IsIV l12 + , Representable Double ( ℝ l12 ) + , Show ( ℝ l12 ) + , NFData ( ℝ l12 ) + ) + => Proxy# r1r2 -> Vec l12 ( LR ( Fin l1 ) ( Fin l2 ) ) -> kont ) + -> kont +doUnion k = + case knownSymbols @r1 `unionLists` knownSymbols @r2 of + + [ ] + -> k @'[ ] proxy# + ( Vec [] ) + + [ ( f1, i1 ) ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + -> k @'[ f1 ] proxy# + ( Vec $ map ( bimapLR Fin Fin ) [ i1 ] ) + + [ ( f1, i1 ), ( f2, i2 ) ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 ) + -> k @'[ f1, f2 ]proxy# + ( Vec $ map ( bimapLR Fin Fin ) [ i1, i2 ] ) + + [ ( f1, i1 ), ( f2, i2 ), ( f3, i3 ) ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 ) + , SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 ) + -> k @'[ f1, f2, f3 ] proxy# + ( Vec $ map ( bimapLR Fin Fin ) [ i1, i2, i3 ] ) + + [ ( f1, i1 ), ( f2, i2 ), ( f3, i3 ), ( f4, i4 ) ] + | SomeSymbol @f1 _ <- someSymbolVal ( Text.unpack f1 ) + , SomeSymbol @f2 _ <- someSymbolVal ( Text.unpack f2 ) + , SomeSymbol @f3 _ <- someSymbolVal ( Text.unpack f3 ) + , SomeSymbol @f4 _ <- someSymbolVal ( Text.unpack f4 ) + -> k @'[ f1, f2, f3, f4 ] proxy# + ( Vec $ map ( bimapLR Fin Fin ) [ i1, i2, i3, i4 ] ) + + other -> error $ "Union not defined in dimension " ++ show ( length other ) + +unionLists :: forall k. Ord k => [ k ] -> [ k ] -> [ ( k, LR Word Word ) ] +unionLists l r = sortBy ( comparing snd ) + $ Map.toList + $ Map.unionWith f + ( Map.fromList [ ( k, InL i ) | k <- l | i <- [ 1 .. ] ] ) + ( Map.fromList [ ( k, InR i ) | k <- r | i <- [ 1 .. ] ] ) + where + f :: LR Word Word -> LR Word Word -> LR Word Word + f ( InL i ) ( InR j ) = InBoth i j + f _ _ = error "unionList: internal error"
+ src/BrushStroking/Render/Stroke.hs view
@@ -0,0 +1,829 @@+{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +module BrushStroking.Render.Stroke + ( Renders(..), compositeRenders, blankRender + , RenderColours(..), RGBA(..) + , StrokeRenderData(..) + , strokeRenderData + , WantedElements(..) + , renderStroke + , drawRectangle, drawSelectionRectangle + , withRGBA + + , Renderable(..), NoExtraRenderData(..) + ) + where + +-- base +import Control.Monad + ( when ) +import Control.Monad.ST + ( RealWorld, ST ) +import Data.Coerce + ( coerce ) +import Data.Fixed + ( mod' ) +import Data.Foldable + ( for_, sequenceA_, traverse_ ) +import Data.Functor.Compose + ( Compose(..) ) +import Data.Kind + ( Type, Constraint ) +import Data.Maybe + ( fromMaybe ) +import GHC.Generics + ( Generic, Generic1, Generically1(..) ) +import GHC.Exts + ( Proxy# ) + +-- acts +import Data.Act + ( Act(..) ) + +-- containers +import qualified Data.Map.Strict as Map +import Data.Sequence + ( Seq(..) ) +import Data.Set + ( Set ) +import qualified Data.Set as Set + +-- deepseq +import Control.DeepSeq + ( NFData(..), deepseq ) + +-- gi-cairo-render +import qualified GI.Cairo.Render as Cairo + +-- text +import Data.Text + ( Text ) + +-- transformers +import Control.Monad.Trans.Class + ( lift ) +import Control.Monad.Trans.State.Strict + ( StateT, evalStateT, get, put ) + +-- brush-strokes +import Calligraphy.Brushes + ( Brush(..), getUnrotated ) +import Math.Algebra.Dual + ( D2𝔸1(..), fun ) +import qualified Math.Bezier.Cubic as Cubic + ( Bezier(..), fromQuadratic ) +import Math.Bezier.Cubic.Fit + ( FitPoint(..), FitParameters, FwdBwd(..) ) +import qualified Math.Bezier.Quadratic as Quadratic + ( Bezier(..) ) +import Math.Bezier.Spline +import Math.Bezier.Stroke + ( Cusp(..), invalidateCache + , computeStrokeOutline_specialise + , RootSolvingAlgorithm + ) +import Math.Epsilon + ( epsilon ) +import Math.Linear + ( ℝ(..), T(..) + , rotate + ) +import Math.Module + ( Module((*^)), normalise ) +import Math.Root.Isolation + ( RootIsolationOptions ) + +-- MetaBrush +import BrushStroking.Asset.Brushes + ( SomeBrush(..), lookupBrush ) +import BrushStroking.Brush + ( NamedBrush(..), WithParams(..) ) +import BrushStroking.Document +import BrushStroking.Document.Serialise + ( ) -- 'Serialisable' instances +import BrushStroking.Hover + ( HoverContext(..), Hoverable(..) + ) +import BrushStroking.Records +import BrushStroking.Stroke +import BrushStroking.Unique + ( Unique ) + +-------------------------------------------------------------------------------- + +data Renders a + = Renders + { renderStrokes, renderPath, renderDebug + , renderBrushes, renderBrushWidgets + , renderCLines, renderCPts, renderPPts :: a + } + deriving stock ( Show, Functor, Foldable, Traversable, Generic, Generic1 ) + deriving Applicative + via Generically1 Renders + +blankRender :: Renders ( Cairo.Render () ) +blankRender = pure ( pure () ) + +compositeRenders :: Renders ( Cairo.Render () ) -> Cairo.Render () +compositeRenders = sequenceA_ + +toAll :: Cairo.Render () -> Compose Renders Cairo.Render () +toAll action = Compose ( pure action ) + +data WantedElements + = WantedElements + { wantPoints :: !Bool + , wantPaths :: !Bool + , wantBrushes :: !Bool + } deriving stock ( Show, Eq ) + +data RGBA = RGBA { r, g, b, a :: !Double } + deriving stock ( Eq, Show ) + +data RenderColours a + = RenderColours + { path, brush, brushStroke + , pathPoint, pathPointOutline + , selected, selectedOutline + , pointSelected, pointHover + , controlPoint, controlPointLine, controlPointOutline + , brushWidget, brushWidgetHover + , base, empty, emptyOutline + :: !a + } + deriving stock ( Show, Eq, Generic, Generic1, Functor, Foldable, Traversable ) + deriving Applicative + via Generically1 RenderColours + +-- | Utility type to gather information needed to render a stroke. +-- +-- - No outline: just the underlying spline. +-- - Outline: keep track of the function which returns brush shape. +data StrokeRenderData extraData where + StrokeRenderData + :: forall pointParams clo extraData + . ( KnownSplineType clo, Show pointParams, NFData pointParams ) + => { strokeDataSpline :: !( StrokeSpline clo pointParams ) } + -> StrokeRenderData extraData + StrokeWithOutlineRenderData + :: forall pointParams clo extraData + . ( KnownSplineType clo, Show pointParams, NFData pointParams ) + => { strokeDataSpline :: !( StrokeSpline clo pointParams ) + , strokeOutlineData :: !( Either + ( SplinePts Closed ) + ( SplinePts Closed, SplinePts Closed ) + , Seq FitPoint + , [ Cusp ] + ) + , strokeBrushFunction :: pointParams -> SplinePts Closed + , strokeExtraData :: !( extraData pointParams ) + } + -> StrokeRenderData extraData + +instance ( forall flds. NFData ( extraData flds ) ) => NFData ( StrokeRenderData extraData ) where + rnf ( StrokeRenderData spline ) = + rnf spline + rnf ( StrokeWithOutlineRenderData + { strokeDataSpline + , strokeOutlineData + , strokeExtraData } ) = + strokeDataSpline + `deepseq` + strokeOutlineData + `deepseq` + strokeExtraData + `deepseq` + () + +-------------------------------------------------------------------------------- + +type Renderable :: ( Type -> Type ) -> Constraint +class Renderable f where + renderAt + :: RenderColours RGBA + -> Zoom + -> Maybe HoverContext + -> PointData pointParams + -> f pointParams + -> Compose Renders Cairo.Render () + +type NoExtraRenderData :: Type -> Type +data NoExtraRenderData pointParams = NoExtraRenderData + deriving stock ( Eq, Ord, Show, Generic ) + deriving anyclass NFData +instance Renderable NoExtraRenderData where + renderAt _ _ _ _ _ = pure () + +-- | Compute the data necessary to render a stroke. +-- +-- - If the stroke has an associated brush, this consists of: +-- - the path that the brush follows, +-- - the computed outline (using fitting algorithm), +-- - the brush shape function, +-- - the brush widget (UI for modifying brush parameters). +-- - Otherwise, this consists of the underlying spline path only. +strokeRenderData + :: ( forall pointParams brushFields + . KnownSymbols brushFields + => Text + -> ( pointParams -> Record brushFields ) + -> extraData pointParams + ) + -> RootSolvingAlgorithm + -> Maybe ( RootIsolationOptions 1 1, RootIsolationOptions 1 2, RootIsolationOptions 2 3 ) + -> FitParameters + -> Stroke + -> ST s ( StrokeRenderData extraData ) +strokeRenderData mkExtraData rootAlgo mbCuspOptions fitParams + ( Stroke + { strokeSpline = spline :: StrokeSpline clo ( Record pointFields ) + , strokeBrushName = mbStrokeBrush + } + ) = case mbStrokeBrush of + Just brushName + | Just + ( SomeBrush + ( NamedBrush { brushFunction = fn } :: NamedBrush brushFields ) + ) <- lookupBrush brushName + , WithParams + { defaultParams = brush_defaults + , withParams = brush@( Brush { brushBaseShape, mbRotation = mbRot } ) + } <- fn + -> -- This is the key place where we need to perform impedance matching + -- between the collection of parameters supplied along a stroke and + -- the collection of parameters expected by the brush. + intersect @pointFields @brushFields + \ ( Intersection + { lg2 = ( _ :: Proxy# nbBrushFields ) + , lg12 = ( _ :: Proxy# nbUsedFields ) + , inject2 + , project1 = toUsedParams :: Record pointFields -> Record usedFields } + ) -> do + let embedUsedParams = inject2 $ MkR brush_defaults + + -- Compute the outline using the brush function. + ( outline, fitPts, cusps ) <- + computeStrokeOutline_specialise @clo @nbUsedFields @nbBrushFields + rootAlgo mbCuspOptions fitParams + ( coerce toUsedParams . brushParams ) ( coerce embedUsedParams ) + brush ( coCache spline ) + pure $ + StrokeWithOutlineRenderData + { strokeDataSpline = spline + , strokeOutlineData = ( outline, fitPts, cusps ) + , strokeBrushFunction = + \ params -> + let MkR brushParams = embedUsedParams $ toUsedParams params + unrotatedShape = fun ( getUnrotated brushBaseShape ) brushParams + -- TODO: remove this logic which is duplicated + -- from elsewhere. The type should make it + -- impossible to forget to apply the rotation. + in case mbRot of + Nothing -> unrotatedShape + Just getθ -> + let θ = getθ brushParams + cosθ = cos θ + sinθ = sin θ + in fmap ( unT . rotate cosθ sinθ . T ) unrotatedShape + , strokeExtraData = + mkExtraData brushName ( embedUsedParams . toUsedParams ) + } + _ -> pure $ + StrokeRenderData + { strokeDataSpline = spline } + +renderStroke + :: Renderable extraData + => RenderColours RGBA + -> WantedElements + -> StrokePoints + -> Maybe HoverContext + -> Bool -- ^ want debug visualisations? + -> Zoom + -> ( Maybe Unique, StrokeRenderData extraData ) + -> Compose Renders Cairo.Render () +renderStroke cols@( RenderColours { brush } ) wanted selPts mbHoverContext debug zoom ( mbUnique, strokeData ) = + case strokeData of + StrokeRenderData { strokeDataSpline } -> + renderStrokeSpline cols wanted strokeSelPts mbHoverContext zoom ( const ( pure () ) ) strokeDataSpline + StrokeWithOutlineRenderData + { strokeDataSpline + , strokeOutlineData = ( strokeOutlineData, fitPts, cusps ) + , strokeBrushFunction + , strokeExtraData = extraData + } -> + renderStrokeSpline cols wanted strokeSelPts mbHoverContext zoom + ( when ( wantBrushes wanted ) + . ( \ pt -> + renderBrushShape ( cols { path = brush } ) mbHoverContext ( Zoom $ 2 * zoomFactor zoom ) + strokeBrushFunction + ( extraData ) + pt + ) + ) + strokeDataSpline + *> Compose blankRender + { renderStrokes = drawOutline cols debug zoom strokeOutlineData + , renderDebug = + when debug $ drawDebugInfo cols zoom ( fitPts, cusps ) + } + where + strokeSelPts = + case mbUnique of + Nothing -> Set.empty + Just u -> fromMaybe Set.empty $ Map.lookup u ( strokePoints selPts ) + +-- | 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). +renderStrokeSpline + :: forall clo pointData + . ( Show pointData, KnownSplineType clo ) + => RenderColours RGBA -> WantedElements + -> Set PointIndex -> Maybe HoverContext -> Zoom + -> ( PointData pointData -> Compose Renders Cairo.Render () ) + -> Spline clo ( CurveData RealWorld ) ( PointData pointData ) + -> Compose Renders Cairo.Render () +renderStrokeSpline cols wanted selPts mbHover zoom renderSubcontent spline = + bifoldSpline ( renderSplineCurve ( splineStart spline ) ) ( renderSplinePoint FirstPoint ) spline + + where + renderSplinePoint :: PointIndex -> PointData pointData -> Compose Renders Cairo.Render () + renderSplinePoint i sp0 + = Compose blankRender + { renderPPts = + when ( wantPoints wanted ) do + drawPoint cols selPts mbHover zoom i sp0 + } + *> renderSubcontent sp0 + renderSplineCurve + :: forall clo' + . SplineTypeI clo' + => PointData pointData -> PointData pointData -> Curve clo' ( CurveData RealWorld ) ( PointData pointData ) -> Compose Renders Cairo.Render () + renderSplineCurve start p0 ( LineTo np1 ( CurveData { curveIndex } ) ) + = Compose blankRender + { renderPPts = when ( wantPoints wanted ) do + for_ np1 \ p1 -> + drawPoint cols selPts mbHover zoom ( PointIndex curveIndex PathPoint ) p1 + , renderPath = when ( wantPaths wanted ) do + drawLine cols zoom PathPoint p0 ( fromNextPoint start np1 ) + } + *> for_ np1 \ p1 -> renderSubcontent p1 + renderSplineCurve start p0 ( Bezier2To p1 np2 ( CurveData { curveIndex } ) ) + = Compose blankRender + { renderCLines + = when ( wantPoints wanted ) do + drawLine cols zoom ( ControlPoint Bez2Cp ) p0 p1 + drawLine cols zoom ( ControlPoint Bez2Cp ) p1 ( fromNextPoint start np2 ) + , renderCPts + = when ( wantPoints wanted ) do + drawPoint cols selPts mbHover zoom ( PointIndex curveIndex $ ControlPoint Bez2Cp ) p1 + , renderPPts + = when ( wantPoints wanted ) do + for_ np2 \ p2 -> + drawPoint cols selPts mbHover zoom ( PointIndex curveIndex PathPoint ) p2 + , renderPath + = when ( wantPaths wanted ) do + 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 ( CurveData { curveIndex } ) ) + = Compose blankRender + { renderCLines + = when ( wantPoints wanted ) do + drawLine cols zoom ( ControlPoint Bez3Cp1 ) p0 p1 + drawLine cols zoom ( ControlPoint Bez3Cp2 ) p2 ( fromNextPoint start np3 ) + , renderCPts + = when ( wantPoints wanted ) do + drawPoint cols selPts mbHover zoom ( PointIndex curveIndex $ ControlPoint Bez3Cp1 ) p1 + drawPoint cols selPts mbHover zoom ( PointIndex curveIndex $ ControlPoint Bez3Cp2 ) p2 + , renderPPts + = when ( wantPoints wanted ) do + for_ np3 \ p3 -> + drawPoint cols selPts mbHover zoom ( PointIndex curveIndex $ PathPoint ) p3 + , renderPath + = when ( wantPaths wanted ) do + drawCubicBezier cols zoom ( coords <$> Cubic.Bezier { p0, p1, p2, p3 = fromNextPoint start np3 } ) + } + *> renderSubcontent p1 + *> renderSubcontent p2 + *> for_ np3 \ p3 -> renderSubcontent p3 + +drawPoint :: RenderColours RGBA -> Set PointIndex -> Maybe HoverContext -> Zoom -> PointIndex -> PointData brushData -> Cairo.Render () +drawPoint ( RenderColours {..} ) selPts mbHover zoom@( Zoom { zoomFactor } ) i pt + | i == FirstPoint || pointType i == PathPoint + = do + let + x, y :: Double + ℝ2 x y = coords pt + hsqrt3 :: Double + hsqrt3 = sqrt 0.75 + isSelected = i `Set.member` selPts + hover + | Just hov <- mbHover + = hovered hov zoom ( ℝ2 x y ) + | otherwise + = False + + Cairo.save + Cairo.translate x y + Cairo.scale ( 3 / zoomFactor ) ( 3 / zoomFactor ) + + Cairo.moveTo 1 0 + Cairo.lineTo 0.5 hsqrt3 + Cairo.lineTo -0.5 hsqrt3 + Cairo.lineTo -1 0 + Cairo.lineTo -0.5 -hsqrt3 + Cairo.lineTo 0.5 -hsqrt3 + Cairo.closePath + + Cairo.setLineWidth 1.0 + if isSelected + then withRGBA pathPoint Cairo.setSourceRGBA + else withRGBA pathPointOutline Cairo.setSourceRGBA + Cairo.strokePreserve + + if | isSelected + -> withRGBA pointSelected Cairo.setSourceRGBA + | hover + -> withRGBA pointHover Cairo.setSourceRGBA + | otherwise + -> withRGBA pathPoint Cairo.setSourceRGBA + Cairo.fill + + Cairo.restore + | otherwise + = do + let + x, y :: Double + ℝ2 x y = coords pt + isSelected = i `Set.member` selPts + hover + | Just hov <- mbHover + = hovered hov zoom ( ℝ2 x y ) + | otherwise + = False + + Cairo.save + Cairo.translate x y + Cairo.scale ( 3 / zoomFactor ) ( 3 / zoomFactor ) + + Cairo.arc 0 0 1 0 ( 2 * pi ) + + Cairo.setLineWidth 1.0 + if isSelected + then withRGBA controlPoint Cairo.setSourceRGBA + else withRGBA controlPointOutline Cairo.setSourceRGBA + Cairo.strokePreserve + + if | isSelected + -> withRGBA pointSelected Cairo.setSourceRGBA + | hover + -> withRGBA pointHover Cairo.setSourceRGBA + | otherwise + -> withRGBA controlPoint Cairo.setSourceRGBA + Cairo.fill + + withRGBA controlPoint Cairo.setSourceRGBA + Cairo.fill + + Cairo.restore + +drawLine :: RenderColours RGBA -> Zoom -> PointType -> PointData b -> PointData b -> Cairo.Render () +drawLine ( RenderColours { path, controlPointLine } ) ( Zoom zoom ) pointType p1 p2 = do + let + x1, y1, x2, y2 :: Double + ℝ2 x1 y1 = coords p1 + ℝ2 x2 y2 = coords p2 + + Cairo.save + Cairo.moveTo x1 y1 + Cairo.lineTo x2 y2 + + case pointType of + PathPoint -> do + Cairo.setLineWidth ( 5 / zoom ) + withRGBA path Cairo.setSourceRGBA + ControlPoint {} -> do + Cairo.setLineWidth ( 3 / zoom ) + withRGBA controlPointLine Cairo.setSourceRGBA + Cairo.stroke + + Cairo.restore + +drawQuadraticBezier :: RenderColours RGBA -> Zoom -> Quadratic.Bezier ( ℝ 2 ) -> Cairo.Render () +drawQuadraticBezier cols zoom bez = + drawCubicBezier cols zoom + ( Cubic.fromQuadratic @( T ( ℝ 2 ) ) bez ) + +drawCubicBezier :: RenderColours RGBA -> Zoom -> Cubic.Bezier ( ℝ 2 ) -> Cairo.Render () +drawCubicBezier ( RenderColours { path } ) ( Zoom { zoomFactor } ) + ( Cubic.Bezier + { p0 = ℝ2 x0 y0 + , p1 = ℝ2 x1 y1 + , p2 = ℝ2 x2 y2 + , p3 = ℝ2 x3 y3 + } + ) + = do + + Cairo.save + + Cairo.moveTo x0 y0 + Cairo.curveTo x1 y1 x2 y2 x3 y3 + + Cairo.setLineWidth ( 6 / zoomFactor ) + withRGBA path Cairo.setSourceRGBA + Cairo.stroke + + Cairo.restore + +drawOutline + :: RenderColours RGBA -> Bool -> Zoom + -> Either ( SplinePts Closed ) ( SplinePts Closed, SplinePts Closed ) + -> Cairo.Render () +drawOutline ( RenderColours {..} ) debug ( Zoom { zoomFactor } ) strokeData = do + Cairo.save + withRGBA brushStroke Cairo.setSourceRGBA + case strokeData of + Left outline -> do + makeOutline outline + case debug of + False -> Cairo.fill + True -> do + Cairo.fillPreserve + Cairo.setSourceRGBA 0 0 0 0.75 + Cairo.setLineWidth ( 2 / zoomFactor ) + Cairo.stroke + Right ( fwd, bwd ) -> do + makeOutline fwd + makeOutline bwd + case debug of + False -> Cairo.fill + True -> do + Cairo.fillPreserve + Cairo.setSourceRGBA 0 0 0 0.75 + Cairo.setLineWidth ( 2 / zoomFactor ) + Cairo.stroke + Cairo.restore + where + makeOutline :: SplinePts Closed -> Cairo.Render () + makeOutline spline = bifoldSpline + ( drawCurve ( splineStart spline ) ) + ( \ ( ℝ2 x y ) -> Cairo.moveTo x y ) + spline + + drawCurve :: forall clo. SplineTypeI clo => ℝ 2 -> ℝ 2 -> Curve clo () ( ℝ 2 ) -> Cairo.Render () + drawCurve start ( ℝ2 x0 y0 ) crv = case crv of + LineTo mp1 _ -> + let ℝ2 x1 y1 = fromNextPoint start mp1 + in Cairo.lineTo x1 y1 + Bezier2To ( ℝ2 x1 y1 ) mp2 _ -> + let ℝ2 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 ( ℝ2 x1 y1 ) ( ℝ2 x2 y2 ) mp3 _ -> + let ℝ2 x3 y3 = fromNextPoint start mp3 + in Cairo.curveTo x1 y1 x2 y2 x3 y3 + +drawDebugInfo :: RenderColours RGBA -> Zoom + -> ( Seq FitPoint, [ Cusp ] ) + -> Cairo.Render () +drawDebugInfo cols zoom@( Zoom { zoomFactor } ) ( fitPts, cusps ) = do + Cairo.setLineWidth ( 2 / zoomFactor ) + ( `evalStateT` 0 ) $ traverse_ ( drawFitPoint cols zoom ) fitPts + for_ cusps ( drawCusp cols zoom ) + +drawFitPoint :: RenderColours RGBA -> Zoom -> FitPoint -> StateT Double Cairo.Render () +drawFitPoint _ zoom ( FitPoint { fitDotProduct = dot, fitDir = fwdOrBwd, fitPoint = ℝ2 x y } ) = do + + hue <- get + put ( hue + 0.01 ) + let + r, g, b :: Double + ( r, g, b ) = hsl2rgb hue 0.9 0.4 + lift do + Cairo.save + Cairo.translate x y + drawFitPointHelper zoom ( fwdOrBwd, dot ) r g b + Cairo.restore + +drawFitPoint _ ( Zoom { zoomFactor } ) ( JoinPoint { joinDir = mbDir, joinPoint = ℝ2 x y } ) = lift do + + -- Draw a little red or blue circle. + Cairo.save + Cairo.translate x y + Cairo.arc 0 0 ( 4 / zoomFactor ) 0 ( 2 * pi ) + case mbDir of + Fwd -> do + -- Forward: red. + Cairo.setSourceRGBA 0.87 0.23 0.18 0.9 + Cairo.setLineWidth ( 3 / zoomFactor ) + Bwd -> do + -- Backwards: blue. + Cairo.setSourceRGBA 0.24 0.45 0.9 0.9 + Cairo.setLineWidth ( 3 / zoomFactor ) + Cairo.stroke + Cairo.restore + +drawFitPoint _ zoom@( Zoom { zoomFactor } ) ( FitTangent { fitDotProduct = dot, fitDir = fwdOrBwd, fitPoint = ℝ2 x y, fitTangent = tgt } ) = do + + hue <- get + put ( hue + 0.01 ) + let + r, g, b :: Double + ( r, g, b ) = hsl2rgb hue 0.9 0.4 + V2 tx ty = 10 *^ normalise tgt + lift do + Cairo.save + Cairo.translate x y + Cairo.moveTo 0 0 + Cairo.lineTo tx ty + Cairo.setLineWidth ( 2 / zoomFactor ) + Cairo.setSourceRGBA r g b 0.8 + Cairo.stroke + drawFitPointHelper zoom ( fwdOrBwd, dot ) r g b + Cairo.restore + +drawFitPointHelper :: Zoom -> ( FwdBwd, Double ) -> Double -> Double -> Double -> Cairo.Render () +drawFitPointHelper ( Zoom { zoomFactor } ) ( fwdOrBwd, dot ) r g b = do + Cairo.moveTo 0 0 + Cairo.arc 0 0 ( 4 / zoomFactor ) 0 ( 2 * pi ) + Cairo.setSourceRGBA r g b 0.8 + Cairo.fill + Cairo.moveTo 0 0 + case fwdOrBwd of + Fwd -> do + -- Forwards: little dot above + Cairo.arc 0 ( -1 / zoomFactor ) ( 1 / zoomFactor ) 0 ( 2 * pi ) + Bwd -> do + -- Backwards: little dot below + Cairo.arc 0 ( 1 / zoomFactor ) ( 1 / zoomFactor ) 0 ( 2 * pi ) + if | dot > epsilon + -> Cairo.setSourceRGBA 0.87 0.23 0.18 0.8 + | dot < -epsilon + -> Cairo.setSourceRGBA 0.24 0.45 0.9 0.8 + | otherwise + -> Cairo.setSourceRGBA 0.5 0.5 0.5 0.8 + Cairo.fill + +drawCusp :: RenderColours RGBA -> Zoom -> Cusp -> Cairo.Render () +drawCusp _ ( Zoom { zoomFactor } ) + ( Cusp { cuspPathCoords = D21 { _D21_v = ℝ2 px py + , _D21_dx = tgt } + , cuspStrokeCoords = ℝ2 cx cy + , cornerCusp = isCorner + } ) = do + + -- Draw a line perpendicular to the underlying path at the cusp. + let + !( V2 tx ty ) = ( 6 / zoomFactor ) *^ normalise tgt + setCol = + if isCorner + then Cairo.setSourceRGBA 1 1 1 0.75 + else Cairo.setSourceRGBA 0 0 0 0.75 + Cairo.save + Cairo.translate px py + Cairo.moveTo -ty tx + Cairo.lineTo ty -tx + setCol + Cairo.setLineWidth ( 2 / zoomFactor ) + Cairo.stroke + Cairo.restore + + -- Draw a circle around the outline cusp point. + Cairo.save + Cairo.translate cx cy + Cairo.arc 0 0 ( 4 / zoomFactor ) 0 ( 2 * pi ) + setCol + Cairo.stroke + Cairo.restore + +drawSelectionRectangle :: RenderColours RGBA -> Double -> ℝ 2 -> ℝ 2 -> Cairo.Render () +drawSelectionRectangle ( RenderColours { selected, selectedOutline } ) = + drawRectangle ( Just selected, Just selectedOutline ) + +drawRectangle :: ( Maybe RGBA, Maybe RGBA ) -> Double -> ℝ 2 -> ℝ 2 -> Cairo.Render () +drawRectangle ( mbFillCol, mbStrokeCol ) zoom ( ℝ2 a_x a_y ) ( ℝ2 b_x b_y ) = do + + -- Offset by half the line width, + -- so that the rectangle exactly encloses the contents. + let + width = 1 / zoom + x0 = min a_x b_x - 0.5 * width + x1 = max a_x b_x + 0.5 * width + y0 = min a_y b_y - 0.5 * width + y1 = max a_y b_y + 0.5 * width + + Cairo.save + + Cairo.moveTo x0 y0 + Cairo.lineTo x1 y0 + Cairo.lineTo x1 y1 + Cairo.lineTo x0 y1 + Cairo.closePath + + for_ mbFillCol $ \ fillCol -> do + withRGBA fillCol Cairo.setSourceRGBA + case mbStrokeCol of + Nothing -> Cairo.fill + Just {} -> Cairo.fillPreserve + + for_ mbStrokeCol $ \ strokeCol -> do + Cairo.setLineWidth width + withRGBA strokeCol Cairo.setSourceRGBA + Cairo.stroke + + Cairo.restore + +{- +drawCross :: RenderColours RGBA -> Double -> Cairo.Render () +drawCross ( RenderColours {..} ) zoom = do + Cairo.save + + Cairo.setLineWidth 1.5 + withRGBA brushCenter Cairo.setSourceRGBA + + Cairo.scale ( 1.5 / zoom ) ( 1.5 / zoom ) + + Cairo.moveTo -3 -3 + Cairo.lineTo 3 3 + Cairo.stroke + + Cairo.moveTo -3 3 + Cairo.lineTo 3 -3 + Cairo.stroke + + Cairo.restore +-} + +renderBrushShape + :: Renderable extraData + => RenderColours RGBA -> Maybe HoverContext -> Zoom + -> ( pointParams -> SplinePts Closed ) + -> extraData pointParams + -> PointData pointParams + -> Compose Renders Cairo.Render () +renderBrushShape cols mbHoverContext zoom brushFn extraData pt = + let + x, y :: Double + ℝ2 x y = coords pt + brushPts :: SplinePts Closed + brushPts = brushFn ( brushParams pt ) + mbHoverContext' :: Maybe HoverContext + mbHoverContext' = V2 -x -y • mbHoverContext + brushWanted = + WantedElements + { wantPoints = False + , wantPaths = True + , wantBrushes = True + } + in + toAll do + Cairo.save + Cairo.translate x y + *> renderStrokeSpline cols brushWanted Set.empty mbHoverContext zoom ( const $ pure () ) + ( noCurveData brushPts ) + *> renderAt cols zoom mbHoverContext' pt extraData + *> toAll Cairo.restore + where + noCurveData :: Spline Closed () ( ℝ 2 ) -> Spline Closed ( CurveData RealWorld ) ( PointData () ) + noCurveData = + bimapSpline + ( \ _ -> bimapCurve ( \ _ -> CurveData 987654321 ( invalidateCache undefined ) ) ( \ _ p -> PointData p () ) ) + ( \ p -> PointData p () ) + +-------------------------------------------------------------------------------- +-- Utilities + +withRGBA :: RGBA -> ( Double -> Double -> Double -> Double -> r ) -> r +withRGBA ( RGBA r g b a ) f = f r g b a + +hsl2rgb :: Double -> Double -> Double -> ( Double, Double, Double ) +hsl2rgb h s l = case hc2rgb h c of + ( r, g, b ) -> ( r + m, g + m, b + m ) + where + c = ( 1 - abs ( 2 * l - 1 ) ) * s + m = l - c / 2 + +hc2rgb :: Double -> Double -> ( Double, Double, Double ) +hc2rgb h c + | h' <= 1 = ( c, x, 0 ) + | h' <= 2 = ( x, c, 0 ) + | h' <= 3 = ( 0, c, x ) + | h' <= 4 = ( 0, x, c ) + | h' <= 5 = ( x, 0, c ) + | otherwise = ( c, 0, x ) + where + h' = ( h * 6 ) `mod'` 6 + hTrunc = truncate h' :: Int + hMod2 = fromIntegral ( hTrunc `mod` 2 ) + ( h' - fromIntegral hTrunc ) + x = c * ( 1 - abs ( hMod2 - 1 ) )
+ src/BrushStroking/Serialisable.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module BrushStroking.Serialisable + ( Serialisable + + -- * FromJSON (using hermes-json) + , FromJSON(..) + , key, keyOptional + + , decodeSequence + , decodeCurve + , decodeCurves + , decodeSpline + ) + where + +-- base +import Data.Functor + ( (<&>) ) +import Data.IORef + ( newIORef, atomicModifyIORef' ) +import Data.Maybe + ( fromMaybe ) +import Unsafe.Coerce + ( unsafeCoerce ) + +-- aeson +import Data.Aeson + ( ToJSON(..), (.=) ) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as Aeson + +-- containers +import Data.Sequence + ( Seq ) +import qualified Data.Sequence as Seq + ( empty, fromList ) + +-- hermes-json +import qualified Data.Hermes as Hermes + +-- text +import Data.Text + ( Text ) + +-- transformers +import Control.Monad.IO.Class + ( MonadIO(liftIO) ) + +-- meta-brushes +import Math.Bezier.Spline + ( Spline(..), SplineType(..), SSplineType(..), SplineTypeI(..) + , Curves(..), Curve(..), NextPoint(..) + ) +import Math.Linear + ( ℝ(..), T(..) + , Fin(..), Representable(tabulate, index) + ) +import BrushStroking.Records + +-------------------------------------------------------------------------------- + +class ( Aeson.ToJSON a, FromJSON a ) => Serialisable a where +instance ( Aeson.ToJSON a, FromJSON a ) => Serialisable a where + +class FromJSON a where + decoder :: Hermes.Decoder a + +instance FromJSON Bool where + decoder = Hermes.bool +instance FromJSON Double where + decoder = Hermes.double +instance FromJSON Text where + decoder = Hermes.text +instance FromJSON a => FromJSON [a] where + decoder = Hermes.list decoder + +key :: FromJSON a => Text -> Hermes.FieldsDecoder a +key k = Hermes.atKey k decoder +keyOptional :: FromJSON a => Text -> Hermes.FieldsDecoder (Maybe a) +keyOptional k = Hermes.atKeyOptional k decoder + +instance MonadIO Hermes.Decoder where + liftIO a = unsafeCoerce $ \ ( _ :: Hermes.Object ) ( _ :: Hermes.HermesEnv ) -> a +instance MonadIO Hermes.FieldsDecoder where + liftIO a = unsafeCoerce $ \ ( _ :: Hermes.Object ) -> ( liftIO @Hermes.Decoder a ) + +instance Aeson.ToJSON ( ℝ 2 ) where + toJSON ( ℝ2 x y ) = Aeson.object [ "x" .= x, "y" .= y ] + toEncoding ( ℝ2 x y ) = Aeson.pairs ( "x" .= x <> "y" .= y ) + +instance FromJSON ( ℝ 2 ) where + decoder = + Hermes.object $ + ℝ2 <$> key "x" <*> key "y" + +deriving newtype instance Aeson.ToJSON ( T ( ℝ 2 ) ) +instance FromJSON ( T ( ℝ 2 ) ) where + decoder = T <$> decoder @( ℝ 2 ) + +instance ( KnownSymbols ks, Representable Double ( ℝ ( Length ks ) ) ) + => Aeson.ToJSON ( Record ks ) where + toJSON r = Aeson.object $ + zip [1..] ( knownSymbols @ks ) <&> \ ( i, fld ) -> + ( Aeson.fromText fld .= index r ( Fin i ) ) + +instance ( KnownSymbols ks, Representable Double ( ℝ ( Length ks ) ) ) + => FromJSON ( Record ks ) where + decoder = + Hermes.object $ + decodeFields <$> + traverse key ( knownSymbols @ks ) + where + decodeFields :: [ Double ] -> Record ks + decodeFields coords = + MkR $ tabulate \ ( Fin i ) -> + coords !! ( fromIntegral i - 1 ) + +-------------------------------------------------------------------------------- + +instance ( SplineTypeI clo, Aeson.ToJSON ptData ) => Aeson.ToJSON ( Curve clo crvData ptData ) where + toJSON curve = Aeson.object $ + case ssplineType @clo of + SOpen -> + case curve of + LineTo ( NextPoint p1 ) _ -> + [ "p1" .= p1 ] + Bezier2To p1 ( NextPoint p2 ) _ -> + [ "p1" .= p1, "p2" .= p2 ] + Bezier3To p1 p2 ( NextPoint p3 ) _ -> + [ "p1" .= p1, "p2" .= p2, "p3" .= p3 ] + SClosed -> + case curve of + LineTo BackToStart _ -> [] + Bezier2To p1 BackToStart _ -> + [ "p1" .= p1 ] + Bezier3To p1 p2 BackToStart _ -> + [ "p1" .= p1, "p2" .= p2 ] +instance ( SplineTypeI clo, Aeson.ToJSON ptData ) => Aeson.ToJSON ( Curves clo crvData ptData ) where + toJSON curves = case ssplineType @clo of + SOpen -> toJSON ( openCurves curves ) + SClosed -> + case curves of + NoCurves -> Aeson.object [ ] + ClosedCurves prevs lst -> + Aeson.object + [ "prevOpenCurves" .= prevs + , "lastClosedCurve" .= lst + ] +instance ( SplineTypeI clo, Aeson.ToJSON ptData ) => Aeson.ToJSON ( Spline clo crvData ptData ) where + toJSON ( Spline { splineStart, splineCurves } ) = + Aeson.object + [ "splineStart" .= splineStart + , "splineCurves" .= splineCurves ] + +decodeSequence :: Hermes.Decoder a -> Hermes.Decoder ( Seq a ) +decodeSequence dec = Seq.fromList <$> Hermes.list dec + +decodeCurve + :: forall clo ptData crvData + . ( SplineTypeI clo, FromJSON ptData ) + => Hermes.FieldsDecoder crvData + -> Hermes.Decoder ( Curve clo crvData ptData ) +decodeCurve decodeCurveData = do + Hermes.object do + crvData <- decodeCurveData + case ssplineType @clo of + SOpen -> do + p1 <- key "p1" + mb_p2 <- keyOptional "p2" + case mb_p2 of + Nothing -> + pure $ LineTo ( NextPoint p1 ) crvData + Just p2 -> do + mb_p3 <- keyOptional "p3" + case mb_p3 of + Nothing -> pure $ Bezier2To p1 ( NextPoint p2 ) crvData + Just p3 -> pure $ Bezier3To p1 p2 ( NextPoint p3 ) crvData + SClosed -> do + mb_p1 <- keyOptional "p1" + case mb_p1 of + Nothing -> + pure $ LineTo BackToStart crvData + Just p1 -> do + mb_p2 <- keyOptional "p2" + case mb_p2 of + Nothing -> pure $ Bezier2To p1 BackToStart crvData + Just p2 -> pure $ Bezier3To p1 p2 BackToStart crvData + +decodeCurves + :: forall clo ptData crvData + . ( SplineTypeI clo, FromJSON ptData ) + => Hermes.FieldsDecoder crvData + -> Hermes.Decoder ( Curves clo crvData ptData ) +decodeCurves decodeCrvData = do + case ssplineType @clo of + SOpen -> do + OpenCurves <$> decodeSequence ( decodeCurve @Open decodeCrvData ) + SClosed -> Hermes.object do + mbLastCurve <- Hermes.atKeyOptional "lastClosedCurve" ( decodeCurve @Closed decodeCrvData ) + case mbLastCurve of + Nothing -> pure NoCurves + Just lastCurve -> do + prevCurves <- fromMaybe Seq.empty <$> + Hermes.atKeyOptional "prevOpenCurves" ( decodeSequence $ decodeCurve @Open decodeCrvData ) + pure ( ClosedCurves prevCurves lastCurve ) + +decodeSpline + :: forall clo ptData crvData + . ( SplineTypeI clo, FromJSON ptData ) + => ( Integer -> Hermes.FieldsDecoder crvData ) + -> Hermes.Decoder ( Spline clo crvData ptData ) +decodeSpline newCurve = do + ref <- liftIO $ newIORef 0 + let newCrvData :: Hermes.FieldsDecoder crvData + newCrvData = do + i <- liftIO $ atomicModifyIORef' ref ( \ o -> ( o + 1, o ) ) + newCurve i + Hermes.object $ do + splineStart <- key "splineStart" + splineCurves <- Hermes.atKey "splineCurves" ( decodeCurves @clo newCrvData ) + pure ( Spline { splineStart, splineCurves } )
+ src/BrushStroking/Stroke.hs view
@@ -0,0 +1,427 @@+{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +module BrushStroking.Stroke where + +-- base +import Control.Arrow + ( (***) ) +import Control.Monad.ST + ( ST, RealWorld, runST ) +import Data.Coerce + ( coerce ) +import Data.Foldable + ( foldr' ) +import Data.Functor.Identity + ( Identity(..) ) +import Data.Kind + ( Type ) +import Data.Maybe + ( mapMaybe ) +import GHC.Generics + ( Generic, Generic1 ) +import GHC.Stack +import GHC.TypeLits + ( Symbol ) +import Unsafe.Coerce + ( unsafeCoerce ) + +-- acts +import Data.Act + ( Act(..), Torsor(..) ) + +-- containers +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +-- deepseq +import Control.DeepSeq + ( NFData(..), NFData1 ) + +-- generic-lens +import Data.Generics.Product.Fields + ( field' ) + +-- groups +import Data.Group + ( Group(..) ) + +-- lens +import Control.Lens + ( Lens' + , view, over + ) + +-- text +import Data.Text + ( Text ) + +-- transformers +import Control.Monad.IO.Class + ( MonadIO ) +import Control.Monad.Trans.Reader + ( ReaderT ) +import Control.Monad.Trans.State.Strict + ( StateT ) +import qualified Control.Monad.Trans.State.Strict as State + +-- brush-strokes +import Math.Bezier.Spline + ( Spline(..), KnownSplineType + , PointType(..), bitraverseSpline, bitraverseCurve + ) +import Math.Bezier.Stroke + ( CachedStroke, newCache ) +import Math.Module + ( Module + ( origin, (^+^), (^-^), (*^) ) + ) +import Math.Linear + ( ℝ(..), T(..) ) +import Debug.Utils + ( trace ) + +-- MetaBrush +import BrushStroking.Brush + ( PointFields ) +import BrushStroking.Layer + ( LayerMetadata(..) + , Hierarchy(..), emptyHierarchy + , Parent(..), WithinParent(..) + ) +import BrushStroking.Records +import BrushStroking.Unique + ( Unique, UniqueSupply, freshUnique ) + +-------------------------------------------------------------------------------- + +-- | Data attached to each point on a spline. +data PointData params + = PointData + { pointCoords :: !( ℝ 2 ) + , brushParams :: !params + } + deriving stock ( Show, Generic, Functor, Foldable, Traversable ) + deriving anyclass NFData + +-- | Data attached to each curve in a spline. +data CurveData s = + CurveData + { curveIndex :: !Rational + , cachedStroke :: !( CachedStroke s ) + } + deriving stock Generic + deriving anyclass NFData + +instance Show ( CurveData s ) where + show ( CurveData { curveIndex } ) = show curveIndex +instance Eq ( CurveData s ) where + ( CurveData { curveIndex = i1 } ) == ( CurveData { curveIndex = i2 } ) + = i1 == i2 +instance Ord ( CurveData s ) where + compare ( CurveData { curveIndex = i1 } ) ( CurveData { curveIndex = i2 } ) + = compare i1 i2 + +-- | An index for a point on a spline. +data PointIndex + = FirstPoint + | PointIndex + -- | Which curve the point belongs to. + { pointCurve :: !Rational + -- | Index within a curve. + , pointType :: !PointType + } + deriving stock ( Show, Eq, Ord, Generic ) + deriving anyclass NFData + +_coords :: Lens' ( PointData brushParams ) ( ℝ 2 ) +_coords = field' @"pointCoords" + +coords :: PointData brushParams -> ℝ 2 +coords = view _coords + +type StrokeSpline clo brushParams = + Spline clo ( CurveData RealWorld ) ( PointData brushParams ) + +type Stroke :: Type +data Stroke where + Stroke + :: forall clo ( pointFields :: [ Symbol ] ) + . ( KnownSplineType clo , PointFields pointFields ) + => + { strokeBrushName :: !( Maybe Text ) + , strokeSpline :: !( StrokeSpline clo ( Record pointFields ) ) + } + -> Stroke +deriving stock instance Show Stroke +instance NFData Stroke where + rnf ( Stroke { strokeBrushName, strokeSpline } ) + = rnf strokeBrushName `seq` rnf strokeSpline + +_strokeSpline + :: forall f + . Functor f + => ( forall clo pointParams ( pointFields :: [ Symbol ] ) + . ( KnownSplineType clo + , pointParams ~ Record pointFields + , PointFields pointFields + ) + => 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 :: [ Symbol ] ) + . ( KnownSplineType clo + , pointParams ~ Record pointFields + , PointFields pointFields + ) + => StrokeSpline clo pointParams + -> StrokeSpline clo pointParams + ) + -> Stroke -> Stroke +overStrokeSpline f = coerce ( _strokeSpline @Identity ( coerce . f ) ) + +setStrokeBrush + :: Maybe Text + -> Stroke -> Stroke +setStrokeBrush mbBrushName + ( Stroke { strokeSpline = ( oldStrokeSpline :: StrokeSpline clo pointParams ) } ) = + -- Invalidate all of the cached brush strokes. + let spline' :: ST s ( Spline clo ( CurveData s ) ( PointData pointParams ) ) + spline' = bitraverseSpline + ( \ _ -> bitraverseCurve invalidateCurve ( const return ) ) + return + oldStrokeSpline + in + Stroke + { strokeSpline = runST $ coCache <$> spline' + , strokeBrushName = mbBrushName } + where + invalidateCurve :: CurveData RealWorld -> ST s ( CurveData s ) + invalidateCurve crv = do + noCache <- newCache + return $ crv { cachedStroke = noCache } + +{-# NOINLINE coCache #-} +coCache :: forall s t clo ptData. Spline clo ( CurveData s ) ptData -> Spline clo ( CurveData t ) ptData +coCache = unsafeCoerce + +instance Act ( T ( ℝ 2 ) ) ( PointData params ) where + v • ( dat@( PointData { pointCoords = p } ) ) = + dat { pointCoords = v • p } + +data DiffPointData diffBrushParams + = DiffPointData + { diffVector :: !( T ( ℝ 2 ) ) + , diffParams :: !diffBrushParams + } + deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable ) + deriving anyclass ( NFData, NFData1 ) + +instance Module Double diffBrushParams => Semigroup ( DiffPointData diffBrushParams ) where + DiffPointData v1 p1 <> DiffPointData v2 p2 = + DiffPointData ( v1 <> v2 ) ( p1 ^+^ p2 ) +instance Module Double diffBrushParams => Monoid ( DiffPointData diffBrushParams ) where + mempty = DiffPointData mempty origin +instance Module Double diffBrushParams => Group ( DiffPointData diffBrushParams ) where + invert ( DiffPointData v1 p1 ) = + DiffPointData ( invert v1 ) ( -1 *^ p1 ) + +instance ( Module Double diffBrushParams, Act diffBrushParams brushParams ) + => Act ( DiffPointData diffBrushParams ) ( PointData brushParams ) where + (•) ( DiffPointData { diffVector = dp, diffParams = db } ) + = over _coords ( dp • ) + . over ( field' @"brushParams" ) ( db • ) +instance ( Module Double diffBrushParams, Torsor diffBrushParams brushParams ) + => Torsor ( DiffPointData diffBrushParams ) ( PointData brushParams ) where + ( PointData + { pointCoords = p1 + , brushParams = b1 + } ) <-- + ( PointData + { pointCoords = p2 + , brushParams = b2 } ) = + DiffPointData + { diffVector = p1 <-- p2 + , diffParams = b1 <-- b2 + } + +instance Module Double brushParams => Module Double ( DiffPointData brushParams ) where + origin = mempty + (^+^) = (<>) + x ^-^ y = x <> invert y + d *^ DiffPointData v1 p1 = + DiffPointData ( d *^ v1 ) ( d *^ p1 ) + +-------------------------------------------------------------------------------- + +-- | Metadata about a stroke, such as its name or its visibility. +data StrokeMetadata + = StrokeMetadata + { strokeName :: !Text + , strokeVisible :: !Bool + , strokeLocked :: !Bool + } + +type StrokeHierarchy = Hierarchy Stroke + +data UpdateStroke + = PreserveStroke + | DeleteStroke + | UpdateStrokeTo !Stroke + deriving stock Show + +-- | Traverse through a stroke hierarchy. +forStrokeHierarchy + :: forall f + . ( HasCallStack, Applicative f ) + => LayerMetadata + -> StrokeHierarchy + -> ( WithinParent Unique -> Stroke -> StrokeMetadata -> f UpdateStroke ) + -> f StrokeHierarchy +forStrokeHierarchy + ( LayerMetadata { layerNames, invisibleLayers, lockedLayers } ) hierarchy0 f = + foldr' ( g Root ( True, False ) ) ( pure hierarchy0 ) ( topLevel hierarchy0 ) + where + + insertMaybe :: Parent Unique -> Unique -> StrokeHierarchy -> UpdateStroke -> StrokeHierarchy + insertMaybe mbPar u old@( Hierarchy oldTl oldGps oldStrokes ) = \case + PreserveStroke -> old + UpdateStrokeTo s -> Hierarchy oldTl oldGps ( Map.insert u s oldStrokes ) + DeleteStroke -> + let newStrokes = Map.delete u oldStrokes + in case mbPar of + Root -> + Hierarchy ( filter ( /= u ) oldTl ) oldGps newStrokes + Parent par -> + Hierarchy oldTl ( Map.adjust ( filter ( /= u ) ) par oldGps ) newStrokes + + + g :: Parent Unique -> ( Bool, Bool ) -> Unique -> f StrokeHierarchy -> f StrokeHierarchy + g par ( vis, lock ) u acc = + let vis' = vis && not ( u `Set.member` invisibleLayers ) + lock' = lock || u `Set.member` lockedLayers + in + case Map.lookup u ( groups hierarchy0 ) of + Nothing -> + case ( Map.lookup u layerNames, Map.lookup u ( content hierarchy0 ) ) of + ( Just strokeName, Just oldStroke ) -> + let + meta = + StrokeMetadata + { strokeName + , strokeVisible = vis' + , strokeLocked = lock' + } + in + insertMaybe par u <$> acc <*> f ( WithinParent par u ) oldStroke meta + _ -> + trace + ( unlines + [ "internal error in 'forStrokeHierarchy'" + , "failed to look up stroke with unique " ++ show u + , "" + , "call stack: " ++ prettyCallStack callStack + ] + ) acc + + Just ds -> + foldr' ( g ( Parent u ) ( vis', lock' ) ) acc ds + +-------------------------------------------------------------------------------- + +-- | Recursive representation of a stroke hierarchy. +-- +-- Used for serialisation/deserialisation only. +type Layers = [ Layer ] + +-- | Layer in a recursive representation of a stroke hierarchy. +-- +-- Used for serialisation/deserialisation only. +data Layer + = StrokeLayer + { layerName :: !Text + , layerVisible :: !Bool + , layerLocked :: !Bool + , layerStroke :: !Stroke + } + | GroupLayer + { layerName :: !Text + , layerVisible :: !Bool + , layerLocked :: !Bool + , groupChildren :: !Layers + } + deriving stock Show + +strokeHierarchyLayers :: HasCallStack => LayerMetadata -> StrokeHierarchy -> Layers +strokeHierarchyLayers + ( LayerMetadata { layerNames, invisibleLayers, lockedLayers } ) + ( Hierarchy topLevel hierarchy content ) = mapMaybe go topLevel + where + go :: Unique -> Maybe Layer + go layerUnique = + let + layerVisible = not $ layerUnique `Set.member` invisibleLayers + layerLocked = layerUnique `Set.member` lockedLayers + in + case Map.lookup layerUnique hierarchy of + Nothing + | Just layerName <- Map.lookup layerUnique layerNames + , Just layerStroke <- Map.lookup layerUnique content + -> + Just $ + StrokeLayer + { layerName, layerVisible, layerLocked, layerStroke } + | otherwise + -> trace + ( unlines [ "internal error in 'strokeHierarchyLayers" + , "could not retrieve data for layer with unique: " ++ show layerUnique + , "" + , "call stack: " ++ prettyCallStack callStack + ] + ) Nothing + Just cs + | Just layerName <- Map.lookup layerUnique layerNames + -> Just $ + GroupLayer + { layerName, layerVisible, layerLocked + , groupChildren = mapMaybe go cs + } + | otherwise + -> trace + ( unlines [ "internal error in 'strokeHierarchyLayers" + , "could not retrieve data for group with unique: " ++ show layerUnique + , "" + , "call stack: " ++ prettyCallStack callStack + ] + ) Nothing + +{-# INLINEABLE layersStrokeHierarchy #-} +layersStrokeHierarchy :: forall m. MonadIO m => Layers -> ReaderT UniqueSupply m ( LayerMetadata, StrokeHierarchy ) +layersStrokeHierarchy lays = ( `State.execStateT` ( mempty, emptyHierarchy ) ) $ do + us <- traverse go lays + State.modify' ( \ ( meta, hierarchy ) -> ( meta, hierarchy { topLevel = us } ) ) + where + go :: Layer -> StateT ( LayerMetadata, StrokeHierarchy ) ( ReaderT UniqueSupply m ) Unique + go l = do + u <- freshUnique + let updMeta ( LayerMetadata nms invis locked ) = + LayerMetadata + { layerNames = Map.insert u ( layerName l ) nms + , invisibleLayers = if layerVisible l then invis else Set.insert u invis + , lockedLayers = if layerLocked l then Set.insert u locked else locked + } + updHierarchy <- case l of + StrokeLayer { layerStroke } -> + return $ \ h -> h { content = Map.insert u layerStroke ( content h ) } + GroupLayer { groupChildren } -> do + us <- traverse go groupChildren + return $ \ h -> h { groups = Map.insert u us ( groups h ) } + State.modify' ( updMeta *** updHierarchy ) + return u + +--------------------------------------------------------------------------------
+ src/BrushStroking/Unique.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +module BrushStroking.Unique + ( MonadUnique(freshUnique) + , Unique, unsafeUnique + , uniqueText + , UniqueSupply, newUniqueSupply + , uniqueMapFromList + ) + where + +-- base +import Control.Arrow + ( (&&&) ) +import Data.Int + ( Int64 ) +import Data.Word + ( Word32 ) +import Foreign.Storable + ( Storable ) + +-- containers +import Data.Map.Strict + ( Map ) +import qualified Data.Map.Strict as Map + ( fromList ) + +-- deepseq +import Control.DeepSeq + ( NFData ) + +-- generic-lens +import Data.Generics.Product.Typed + ( HasType(typed) ) + +-- lens +import Control.Lens + ( view ) + +-- mtl +import Control.Monad.Reader + ( MonadReader(..) ) + +-- stm +import Control.Concurrent.STM + ( STM ) +import qualified Control.Concurrent.STM as STM + +-- text +import Data.Text + ( 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, Enum, Storable, NFData ) + +unsafeUnique :: Word32 -> Unique +unsafeUnique i = Unique ( -(fromIntegral i) - 1 ) + +uniqueText :: Unique -> Text +uniqueText ( Unique i ) + | i >= 0 + = "%" <> Text.pack ( show i ) + | otherwise + = "§" <> Text.pack ( show $ -i - 1 ) + +newtype UniqueSupply = UniqueSupply { uniqueSupplyTVar :: STM.TVar Unique } + +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 ) + liftIO $ STM.atomically $ STM.stateTVar uniqueSupplyTVar doSucc + +instance MonadUnique ( ReaderT UniqueSupply STM ) where + freshUnique = do + UniqueSupply { uniqueSupplyTVar } <- ask + lift $ STM.stateTVar uniqueSupplyTVar doSucc + +doSucc :: Unique -> ( Unique, Unique ) +doSucc uniq@( Unique !i ) = ( uniq, Unique ( succ i ) ) +