metabrush/src/app/MetaBrush/Document.hs

{-# 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  #-}

module MetaBrush.Document
  ( AABB(..), mkAABB
  , Document(..), DocumentContent(..)
  , emptyDocument
  , Stroke(..), StrokeSpline, _strokeSpline, overStrokeSpline
  , PointData(..), BrushPointData(..), DiffPointData(..)
  , Brush(..), emptyBrush
  , FocusState(..), Hoverable(..), HoverContext(..)
  , Guide(..)
  , _selection, _coords, coords
  , addGuide, selectedGuide
  )
  where

-- base
import Data.Coerce
  ( coerce )
import Data.Functor.Identity
  ( Identity(..) )
import Data.Kind
  ( Type )
import Data.Semigroup
  ( Arg(..), Min(..), ArgMin )
import GHC.Generics
  ( Generic, 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 )
import qualified SuperRecord
  ( Intersect, rnil )

-- text
import Data.Text
  ( Text )
import qualified Data.Text as Text
  ( unpack )

-- transformers
import Control.Monad.Trans.Reader
  ( ReaderT, runReaderT )

-- MetaBrush
import Math.Bezier.Spline
  ( Spline(..), KnownSplineType, Curves(..) )
import Math.Bezier.Stroke
  ( CachedStroke )
import Math.Module
  ( Module
    ( origin, (^+^), (^-^), (*^) )
  , Inner((^.^))
  , squaredNorm, quadrance
  )
import Math.Vector2D
  ( Point2D(..), Vector2D(..) )
import {-# SOURCE #-} MetaBrush.Document.Serialise
  ( Serialisable(..) )
import MetaBrush.MetaParameter.AST
  ( STypesI, Adapted, AdaptableFunction(..), BrushFunction )
import MetaBrush.MetaParameter.Interpolation
  ( Interpolatable(..) ) -- + orphan instances
import MetaBrush.UI.Viewport
  ( Ruler(..) )
import MetaBrush.Unique
  ( 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
  }
  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 ( PointData brushParams )

data Stroke where
  Stroke
    :: ( KnownSplineType clo
       , pointParams ~ Super.Rec pointFields, STypesI pointFields
       , brushParams ~ Super.Rec brushFields, STypesI brushFields
       , usedParams  ~ Super.Rec usedFields , STypesI usedFields
       , usedFields  ~ ( brushFields `SuperRecord.Intersect` pointFields )
       , Show brushParams, NFData brushParams
       , Show pointParams, NFData pointParams
       , Interpolatable pointParams
       , Interpolatable usedParams
       , Serialisable pointParams
       , Adapted brushFields pointFields usedFields
       )
    =>
      { strokeName    :: Text
      , strokeVisible :: !Bool
      , strokeUnique  :: Unique
      , strokeBrush   :: Brush brushFields
      , strokeSpline  :: !( StrokeSpline clo pointParams )
      }
    -> Stroke
deriving stock instance Show Stroke
instance NFData Stroke where
  rnf ( Stroke { strokeName, strokeVisible, strokeUnique, strokeSpline } )
    = deepseq strokeSpline
    . deepseq strokeUnique
    . deepseq strokeVisible
    $ rnf strokeName

_strokeSpline
  :: forall f
  .  Functor f
  => (  forall clo pointParams pointFields
     .  ( KnownSplineType clo
        , Show pointParams, NFData pointParams
        , pointParams ~ Super.Rec pointFields, STypesI pointFields
        , Interpolatable pointParams
        , Serialisable pointParams
        )
     => StrokeSpline clo pointParams
     -> f ( StrokeSpline clo pointParams )
     )
  -> Stroke -> f Stroke
_strokeSpline f ( Stroke { strokeSpline = oldStrokeSpline, .. } )
  = ( \ newSpline -> Stroke { strokeSpline = newSpline, .. } ) <$> f oldStrokeSpline

overStrokeSpline
  :: (  forall clo pointParams pointFields
     .  ( KnownSplineType clo
        , Show pointParams, NFData pointParams
        , pointParams ~ Super.Rec pointFields, STypesI pointFields
        , Interpolatable pointParams
        , Serialisable pointParams
        )
     => StrokeSpline clo pointParams
     -> StrokeSpline clo pointParams
     )
  -> Stroke -> Stroke
overStrokeSpline f = coerce ( _strokeSpline @Identity ( coerce . f ) )


data Brush ( brushFields :: [ Type ] )
  = BrushData
  { brushName     :: !Text
  , brushCode     :: !Text
  , brushFunction :: !( BrushFunction brushFields )
  }

instance Show ( Brush brushFields ) where
  show ( BrushData { brushName } ) = Text.unpack brushName

-- Brush parameters using open records.
emptyBrush :: Brush '[]
emptyBrush = BrushData "Empty brush" ""
  ( AdaptableFunction ( const SuperRecord.rnil, const $ Spline ( Point2D 0 0 ) NoCurves ) )

data PointData params
  = PointData
  { 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
      }
    }

--------------------------------------------------------------------------------

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