mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 23:03:38 +00:00
437 lines
13 KiB
Haskell
437 lines
13 KiB
Haskell
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DeriveTraversable #-}
|
|
{-# LANGUAGE DerivingVia #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PolyKinds #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module MetaBrush.Document
|
|
( AABB(..), mkAABB
|
|
, Document(..), DocumentContent(..)
|
|
, emptyDocument
|
|
, Stroke(..), StrokeSpline, _strokeSpline, overStrokeSpline
|
|
, PointData(..), BrushPointData(..), DiffPointData(..)
|
|
, FocusState(..), Hoverable(..), HoverContext(..)
|
|
, Guide(..)
|
|
, _selection, _coords, coords
|
|
, addGuide, selectedGuide
|
|
)
|
|
where
|
|
|
|
-- base
|
|
import Control.Monad.ST
|
|
( RealWorld )
|
|
import Data.Coerce
|
|
( coerce )
|
|
import Data.Functor.Identity
|
|
( Identity(..) )
|
|
import Data.Semigroup
|
|
( Arg(..), Min(..), ArgMin )
|
|
import GHC.Generics
|
|
( Generic, Generic1 )
|
|
|
|
-- acts
|
|
import Data.Act
|
|
( Act(..), Torsor(..) )
|
|
|
|
-- containers
|
|
import Data.Map.Strict
|
|
( Map )
|
|
import qualified Data.Map.Strict as Map
|
|
( empty, insert )
|
|
|
|
-- deepseq
|
|
import Control.DeepSeq
|
|
( NFData(..), NFData1, deepseq )
|
|
|
|
-- generic-lens
|
|
import Data.Generics.Product.Fields
|
|
( field' )
|
|
|
|
-- groups
|
|
import Data.Group
|
|
( Group(..) )
|
|
|
|
-- lens
|
|
import Control.Lens
|
|
( Lens'
|
|
, set, view, over
|
|
)
|
|
|
|
-- stm
|
|
import Control.Concurrent.STM
|
|
( STM )
|
|
|
|
-- superrecord
|
|
import qualified SuperRecord as Super
|
|
( Rec )
|
|
|
|
-- text
|
|
import Data.Text
|
|
( Text )
|
|
|
|
-- transformers
|
|
import Control.Monad.Trans.Reader
|
|
( ReaderT, runReaderT )
|
|
|
|
-- MetaBrush
|
|
import Math.Bezier.Spline
|
|
( Spline(..), KnownSplineType )
|
|
import Math.Bezier.Stroke
|
|
( CachedStroke )
|
|
import Math.Module
|
|
( Module
|
|
( origin, (^+^), (^-^), (*^) )
|
|
, Inner((^.^))
|
|
, squaredNorm, quadrance
|
|
)
|
|
import Math.Vector2D
|
|
( Point2D(..), Vector2D(..) )
|
|
import MetaBrush.Brush
|
|
( Brush, BrushReference )
|
|
import {-# SOURCE #-} MetaBrush.Document.Serialise
|
|
( Serialisable(..) )
|
|
import MetaBrush.MetaParameter.AST
|
|
( STypesI(..) )
|
|
import MetaBrush.MetaParameter.Interpolation
|
|
( Interpolatable(..) ) -- + orphan instances
|
|
import MetaBrush.UI.Viewport
|
|
( Ruler(..) )
|
|
import MetaBrush.Unique
|
|
( UniqueSupply, Unique, freshUnique )
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
data AABB
|
|
= AABB
|
|
{ topLeft, botRight :: !( Point2D Double ) }
|
|
deriving stock ( Show, Generic )
|
|
deriving anyclass NFData
|
|
|
|
mkAABB :: Point2D Double -> Point2D Double -> AABB
|
|
mkAABB ( Point2D x1 y1 ) ( Point2D x2 y2 ) = AABB ( Point2D xmin ymin ) ( Point2D xmax ymax )
|
|
where
|
|
( xmin, xmax )
|
|
| x1 > x2 = ( x2, x1 )
|
|
| otherwise = ( x1, x2 )
|
|
( ymin, ymax )
|
|
| y1 > y2 = ( y2, y1 )
|
|
| otherwise = ( y1, y2 )
|
|
|
|
-- | Document, together with some extra metadata.
|
|
data Document
|
|
= Document
|
|
{ displayName :: !Text
|
|
, mbFilePath :: !( Maybe FilePath )
|
|
, viewportCenter :: !( Point2D Double )
|
|
, zoomFactor :: !Double
|
|
, documentUnique :: Unique
|
|
, documentContent :: !DocumentContent
|
|
, documentBrushes :: !( Map Unique Brush )
|
|
}
|
|
deriving stock ( Show, Generic )
|
|
deriving anyclass NFData
|
|
|
|
-- | Main content of document (data which we kept track of throughout history).
|
|
data DocumentContent
|
|
= Content
|
|
{ unsavedChanges :: !Bool
|
|
, latestChange :: !Text
|
|
, guides :: !( Map Unique Guide )
|
|
, strokes :: ![ Stroke ]
|
|
}
|
|
deriving stock ( Show, Generic )
|
|
deriving anyclass NFData
|
|
|
|
type StrokeSpline ty brushParams = Spline ty ( CachedStroke RealWorld ) ( PointData brushParams )
|
|
|
|
data Stroke where
|
|
Stroke
|
|
:: ( KnownSplineType clo
|
|
, pointParams ~ Super.Rec pointFields, STypesI pointFields
|
|
, Show pointParams, NFData pointParams
|
|
, Interpolatable pointParams
|
|
, Serialisable pointParams
|
|
)
|
|
=>
|
|
{ strokeName :: !Text
|
|
, strokeVisible :: !Bool
|
|
, strokeUnique :: Unique
|
|
, strokeBrushRef :: !( BrushReference pointFields )
|
|
, strokeSpline :: !( StrokeSpline clo pointParams )
|
|
}
|
|
-> Stroke
|
|
deriving stock instance Show Stroke
|
|
instance NFData Stroke where
|
|
rnf ( Stroke { strokeName, strokeVisible, strokeUnique, strokeBrushRef, strokeSpline } )
|
|
= deepseq strokeSpline
|
|
. deepseq strokeBrushRef
|
|
. deepseq strokeUnique
|
|
. deepseq strokeVisible
|
|
$ rnf strokeName
|
|
|
|
_strokeSpline
|
|
:: forall f
|
|
. Functor f
|
|
=> ( forall clo pointParams pointFields
|
|
. ( KnownSplineType clo
|
|
, Show pointParams, NFData pointParams
|
|
, pointParams ~ Super.Rec pointFields, STypesI pointFields
|
|
, Interpolatable pointParams
|
|
, Serialisable pointParams
|
|
)
|
|
=> StrokeSpline clo pointParams
|
|
-> f ( StrokeSpline clo pointParams )
|
|
)
|
|
-> Stroke -> f Stroke
|
|
_strokeSpline f ( Stroke { strokeSpline = oldStrokeSpline, .. } )
|
|
= ( \ newSpline -> Stroke { strokeSpline = newSpline, .. } ) <$> f oldStrokeSpline
|
|
|
|
overStrokeSpline
|
|
:: ( forall clo pointParams pointFields
|
|
. ( KnownSplineType clo
|
|
, Show pointParams, NFData pointParams
|
|
, pointParams ~ Super.Rec pointFields, STypesI pointFields
|
|
, Interpolatable pointParams
|
|
, Serialisable pointParams
|
|
)
|
|
=> StrokeSpline clo pointParams
|
|
-> StrokeSpline clo pointParams
|
|
)
|
|
-> Stroke -> Stroke
|
|
overStrokeSpline f = coerce ( _strokeSpline @Identity ( coerce . f ) )
|
|
|
|
|
|
data PointData params
|
|
= PointData
|
|
{ pointCoords :: !( Point2D Double )
|
|
, pointState :: FocusState
|
|
, brushParams :: !params
|
|
}
|
|
deriving stock ( Show, Generic )
|
|
deriving anyclass NFData
|
|
|
|
data BrushPointData
|
|
= BrushPointData
|
|
{ brushPointState :: FocusState }
|
|
deriving stock ( Show, Generic )
|
|
deriving anyclass NFData
|
|
|
|
data FocusState
|
|
= Normal
|
|
| Hover
|
|
| Selected
|
|
deriving stock ( Show, Eq, Generic )
|
|
deriving anyclass NFData
|
|
|
|
instance Semigroup FocusState where
|
|
Selected <> _ = Selected
|
|
Normal <> s = s
|
|
_ <> Selected = Selected
|
|
s <> Normal = s
|
|
_ <> _ = Hover
|
|
instance Monoid FocusState where
|
|
mempty = Normal
|
|
|
|
emptyDocument :: Text -> Unique -> Document
|
|
emptyDocument docName unique =
|
|
Document
|
|
{ displayName = docName
|
|
, mbFilePath = Nothing
|
|
, viewportCenter = Point2D 0 0
|
|
, zoomFactor = 1
|
|
, documentUnique = unique
|
|
, documentContent =
|
|
Content
|
|
{ unsavedChanges = False
|
|
, latestChange = "New document"
|
|
, strokes = []
|
|
, guides = Map.empty
|
|
}
|
|
, documentBrushes = Map.empty
|
|
}
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
data HoverContext
|
|
= MouseHover !( Point2D Double )
|
|
| RectangleHover !AABB
|
|
deriving stock ( Show, Generic )
|
|
deriving anyclass NFData
|
|
|
|
instance Act ( Vector2D Double ) HoverContext where
|
|
v • MouseHover p = MouseHover ( v • p )
|
|
v • RectangleHover ( AABB p1 p2 ) = RectangleHover ( AABB ( v • p1 ) ( v • p2 ) )
|
|
|
|
instance Act ( Vector2D Double ) ( Maybe HoverContext ) where
|
|
(•) v = fmap ( v • )
|
|
|
|
class Hoverable a where
|
|
hovered :: Maybe HoverContext -> Double -> a -> FocusState
|
|
|
|
instance Hoverable ( Point2D Double ) where
|
|
hovered Nothing _ _ = Normal
|
|
hovered ( Just ( MouseHover p ) ) zoom q
|
|
| quadrance @( Vector2D Double ) p q * zoom ^ ( 2 :: Int ) < 16
|
|
= Hover
|
|
| otherwise
|
|
= Normal
|
|
hovered ( Just ( RectangleHover ( AABB ( Point2D x1 y1 ) ( Point2D x2 y2 ) ) ) ) _ ( Point2D x y )
|
|
| x >= x1 && x <= x2 && y >= y1 && y <= y2
|
|
= Hover
|
|
| otherwise
|
|
= Normal
|
|
|
|
class HasSelection pt where
|
|
_selection :: Lens' pt FocusState
|
|
instance HasSelection ( PointData brushParams ) where
|
|
_selection = field' @"pointState"
|
|
instance HasSelection BrushPointData where
|
|
_selection = field' @"brushPointState"
|
|
|
|
_coords :: Lens' ( PointData brushParams ) ( Point2D Double )
|
|
_coords = field' @"pointCoords"
|
|
|
|
coords :: PointData brushParams -> Point2D Double
|
|
coords = view _coords
|
|
|
|
data FocusDifference
|
|
= DifferentFocus
|
|
| SameFocus
|
|
deriving stock ( Show, Generic )
|
|
deriving anyclass NFData
|
|
|
|
instance Semigroup FocusDifference where
|
|
SameFocus <> SameFocus = SameFocus
|
|
_ <> _ = DifferentFocus
|
|
|
|
instance Monoid FocusDifference where
|
|
mempty = SameFocus
|
|
|
|
instance Group FocusDifference where
|
|
invert = id
|
|
|
|
data DiffPointData diffBrushParams
|
|
= DiffPointData
|
|
{ diffVector :: !( Vector2D Double )
|
|
, diffParams :: !diffBrushParams
|
|
, diffState :: !FocusDifference
|
|
}
|
|
deriving stock ( Show, Generic, Generic1, Functor, Foldable, Traversable )
|
|
deriving anyclass ( NFData, NFData1 )
|
|
|
|
instance Module Double diffBrushParams => Semigroup ( DiffPointData diffBrushParams ) where
|
|
DiffPointData v1 p1 s1 <> DiffPointData v2 p2 s2 =
|
|
DiffPointData ( v1 <> v2 ) ( p1 ^+^ p2 ) ( s1 <> s2 )
|
|
instance Module Double diffBrushParams => Monoid ( DiffPointData diffBrushParams ) where
|
|
mempty = DiffPointData mempty origin mempty
|
|
instance Module Double diffBrushParams => Group ( DiffPointData diffBrushParams ) where
|
|
invert ( DiffPointData v1 p1 s1 ) =
|
|
DiffPointData ( invert v1 ) ( (-1) *^ p1 ) ( invert s1 )
|
|
|
|
instance ( Module Double diffBrushParams, Act diffBrushParams brushParams )
|
|
=> Act ( DiffPointData diffBrushParams ) ( PointData brushParams ) where
|
|
(•) ( DiffPointData { diffVector = dp, diffParams = db, diffState = focusDiff } )
|
|
= over _coords ( dp • )
|
|
. over ( field' @"brushParams" ) ( db • )
|
|
. ( case focusDiff of { SameFocus -> id; DifferentFocus -> set ( field' @"pointState" ) Normal } )
|
|
instance ( Module Double diffBrushParams, Torsor diffBrushParams brushParams )
|
|
=> Torsor ( DiffPointData diffBrushParams ) ( PointData brushParams ) where
|
|
( PointData { pointCoords = p1, brushParams = b1, pointState = s1 } ) <-- ( PointData { pointCoords = p2, brushParams = b2, pointState = s2 } ) =
|
|
DiffPointData
|
|
{ diffVector = p1 <-- p2
|
|
, diffParams = b1 <-- b2
|
|
, diffState = if s1 == s2 then SameFocus else DifferentFocus
|
|
}
|
|
instance Module Double brushParams => Module Double ( DiffPointData brushParams ) where
|
|
origin = mempty
|
|
(^+^) = (<>)
|
|
x ^-^ y = x <> invert y
|
|
d *^ DiffPointData v1 p1 s1 = DiffPointData ( d *^ v1 ) ( d *^ p1 ) s1
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Guides.
|
|
|
|
data Guide
|
|
= Guide
|
|
{ guidePoint :: !( Point2D Double ) -- ^ point on the guide line
|
|
, guideNormal :: !( Vector2D Double ) -- ^ /normalised/ normal vector of the guide
|
|
, guideFocus :: !FocusState
|
|
, guideUnique :: Unique
|
|
}
|
|
deriving stock ( Show, Generic )
|
|
deriving anyclass NFData
|
|
|
|
-- | Try to select a guide at the given document coordinates.
|
|
selectedGuide :: Point2D Double -> Document -> Maybe Guide
|
|
selectedGuide c ( Document { zoomFactor, documentContent = Content { guides } } ) =
|
|
\case { Min ( Arg _ g ) -> g } <$> foldMap ( selectGuide_maybe c zoomFactor ) guides
|
|
|
|
selectGuide_maybe :: Point2D Double -> Double -> Guide -> Maybe ( ArgMin Double Guide )
|
|
selectGuide_maybe c zoom guide@( Guide { guidePoint = p, guideNormal = n } )
|
|
| sqDist * zoom ^ ( 2 :: Int ) < 4
|
|
= Just ( Min ( Arg sqDist guide ) )
|
|
| otherwise
|
|
= Nothing
|
|
where
|
|
t :: Double
|
|
t = ( c --> p ) ^.^ n
|
|
sqDist :: Double
|
|
sqDist = t ^ ( 2 :: Int ) / squaredNorm n
|
|
|
|
-- | Add new guide after a mouse drag from a ruler area.
|
|
addGuide :: UniqueSupply -> Ruler -> Point2D Double -> Document -> STM Document
|
|
addGuide uniqueSupply ruler p doc = ( `runReaderT` uniqueSupply ) $ ( field' @"documentContent" . field' @"guides" ) insertNewGuides doc
|
|
where
|
|
insertNewGuides :: Map Unique Guide -> ReaderT UniqueSupply STM ( Map Unique Guide )
|
|
insertNewGuides gs = case ruler of
|
|
RulerCorner
|
|
-> do
|
|
uniq1 <- freshUnique
|
|
uniq2 <- freshUnique
|
|
let
|
|
guide1, guide2 :: Guide
|
|
guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideFocus = Normal, guideUnique = uniq1 }
|
|
guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideFocus = Normal, guideUnique = uniq2 }
|
|
pure ( Map.insert uniq2 guide2 . Map.insert uniq1 guide1 $ gs )
|
|
TopRuler
|
|
-> do
|
|
uniq1 <- freshUnique
|
|
let
|
|
guide1 :: Guide
|
|
guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideFocus = Normal, guideUnique = uniq1 }
|
|
pure ( Map.insert uniq1 guide1 gs )
|
|
LeftRuler
|
|
-> do
|
|
uniq2 <- freshUnique
|
|
let
|
|
guide2 :: Guide
|
|
guide2 = Guide { guidePoint = p, guideNormal = Vector2D 1 0, guideFocus = Normal, guideUnique = uniq2 }
|
|
pure ( Map.insert uniq2 guide2 gs )
|
|
|
|
instance Hoverable Guide where
|
|
hovered ( Just ( MouseHover c ) ) zoom guide
|
|
| Just _ <- selectGuide_maybe c zoom guide
|
|
= Hover
|
|
| otherwise
|
|
= Normal
|
|
hovered _ _ _ = Normal
|