Layer.hs

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 )