metabrush/src/app/MetaBrush/Document.hs

{-# LANGUAGE BlockArguments        #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE TypeApplications      #-}

module MetaBrush.Document
  ( AABB(..), mkAABB
  , Document(..), emptyDocument
  , Stroke(..)
  , PointData(..), BrushPointData(..)
  , FocusState(..), Hoverable(..), HoverContext(..)
  , _selection, _brush
  , Guide(..)
  , addGuide, selectedGuide
  )
  where

-- base
import Data.Semigroup
  ( Arg(..), Min(..), ArgMin )
import GHC.Generics
  ( Generic )

-- acts
import Data.Act
  ( Act
    ( (•) )
  , Torsor
    ( (-->) )
  )

-- containers
import Data.Map.Strict
  ( Map )
import qualified Data.Map.Strict as Map
  ( insert )
import qualified Data.Map.Strict as Map
  ( empty )
import Data.Sequence
  ( Seq )

-- generic-lens
import Data.Generics.Product.Fields
  ( field' )
import Data.Generics.Product.Typed
  ( HasType(typed) )

-- lens
import Control.Lens
  ( Lens' )

-- stm
import Control.Concurrent.STM
  ( STM )

-- text
import Data.Text
  ( Text )

-- MetaBrush
import Math.Bezier.Stroke
  ( StrokePoint(..) )
import Math.Module
  ( Inner((^.^)), squaredNorm, quadrance )
import Math.Vector2D
  ( Point2D(..), Vector2D(..) )
import MetaBrush.UI.Viewport
  ( Ruler(..) )
import MetaBrush.Unique
  ( UniqueSupply, Unique, freshUnique )

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

data AABB
  = AABB
  { topLeft, botRight :: !( Point2D Double ) }
  deriving stock Show

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 )

data Document
  = Document
    { displayName    :: !Text
    , mbFilePath     :: !( Maybe FilePath )
    , unsavedChanges :: !Bool
    , viewportCenter :: !( Point2D Double )
    , zoomFactor     :: !Double
    , documentUnique :: Unique
    , strokes        :: ![ Stroke ]
    , guides         :: !( Map Unique Guide )
    }
  deriving stock ( Show, Generic )

data Stroke
  = Stroke
  { strokeName    :: Text
  , strokeVisible :: !Bool
  , strokeUnique  :: Unique
  , strokePoints  :: !( Seq ( StrokePoint PointData ) )
  }
  deriving stock ( Show, Generic )

data PointData
  = PointData
  { pointState :: FocusState
  , brushShape :: Seq ( StrokePoint BrushPointData )
  }
  deriving stock ( Show, Generic )

data BrushPointData
  = BrushPointData
  { brushPointState :: FocusState }
  deriving stock ( Show, Generic )

data FocusState
  = Normal
  | Hover
  | Selected
  deriving stock ( Show, Eq )

instance Semigroup FocusState where
  Selected <> _        = Selected
  Normal   <> s        = s
  _        <> Selected = Selected
  s        <> Normal   = s
  _        <> _        = Hover
instance Monoid FocusState where
  mempty = Normal

_selection :: HasType FocusState pt => Lens' ( StrokePoint pt ) FocusState
_selection = field' @"pointData" . typed @FocusState

_brush :: Lens' ( StrokePoint PointData ) ( Seq ( StrokePoint BrushPointData ) )
_brush = field' @"pointData" . field' @"brushShape"

emptyDocument :: Text -> Unique -> Document
emptyDocument docName unique =
  Document
    { displayName    = docName
    , mbFilePath     = Nothing
    , unsavedChanges = False
    , viewportCenter = Point2D 0 0
    , zoomFactor     = 1
    , documentUnique = unique
    , strokes        = []
    , guides         = Map.empty
    }

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

data HoverContext
  = MouseHover     !( Point2D Double )
  | RectangleHover !AABB
  deriving stock Show

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

--------------------------------------------------------------------------------
-- 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 )

-- | Try to select a guide at the given document coordinates.
selectedGuide :: Point2D Double -> Document -> Maybe Guide
selectedGuide c ( Document { zoomFactor, 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 = ( field' @"guides" ) insertNewGuides
  where
    insertNewGuides :: Map Unique Guide -> STM ( Map Unique Guide )
    insertNewGuides gs = case ruler of
      RulerCorner
        -> do
          uniq1 <- freshUnique uniqueSupply
          uniq2 <- freshUnique uniqueSupply
          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 uniqueSupply
          let
            guide1 :: Guide
            guide1 = Guide { guidePoint = p, guideNormal = Vector2D 0 1, guideFocus = Normal, guideUnique = uniq1 }
          pure ( Map.insert uniq1 guide1 gs )
      LeftRuler
        -> do
          uniq2 <- freshUnique uniqueSupply
          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