{-# LANGUAGE TypeSynonymInstances
           , FlexibleInstances
           , FlexibleContexts
           , TypeFamilies
           , GeneralizedNewtypeDeriving
           , MultiParamTypeClasses
           , OverlappingInstances
           , TupleSections
           , GADTs
           , DeriveDataTypeable
           , UndecidableInstances
  #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Diagrams.Names
-- Copyright   :  (c) 2011 diagrams-core team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- This module defines a type of names which can be used for referring
-- to locations within diagrams, and related types.
--
-----------------------------------------------------------------------------

module Graphics.Rendering.Diagrams.Names
       (-- * Names
        -- ** Atomic names
         Atomic(..)
       , AName(..)

        -- ** Names
       , Name(..), toName

        -- ** Qualifiable
       , Qualifiable(..), (.>), (||>)

         -- * Name maps

       , NameMap(..)

         -- ** Constructing name maps
       , fromNames, fromNamesB
       , rememberAs

         -- ** Searching within name maps
       , lookupN
       ) where

import Graphics.Rendering.Diagrams.V
import Graphics.Rendering.Diagrams.Monoids
import Graphics.Rendering.Diagrams.HasOrigin
import Graphics.Rendering.Diagrams.Points
import Graphics.Rendering.Diagrams.Bounds
import Graphics.Rendering.Diagrams.Transform

import Data.VectorSpace

import Data.List (intercalate, isSuffixOf)
import qualified Data.Map as M
import Data.Monoid
import Control.Arrow ((***), second)
import Control.Monad (mplus)

import Data.Typeable

------------------------------------------------------------
--  Names  -------------------------------------------------
------------------------------------------------------------

-- | @Atomic@ types are those which can be used as names.  They must
--   support 'Typeable' (to facilitate extracting them from
--   existential wrappers), 'Ord' (for comparison and efficient
--   storage) and 'Show'.
class (Typeable a, Ord a, Show a) => Atomic a where
  toAName :: a -> AName
  toAName = AName

instance Atomic ()
instance Atomic Bool
instance Atomic Char
instance Atomic Int
instance Atomic Float
instance Atomic Double
instance Atomic Integer
instance Atomic String
instance Atomic a => Atomic [a]
instance (Atomic a, Atomic b) => Atomic (a,b)
instance (Atomic a, Atomic b, Atomic c) => Atomic (a,b,c)

-- | Atomic names.  @AName@ is just an existential wrapper around
--   'Atomic' values.
data AName where
  AName :: Atomic a => a -> AName
  deriving (Typeable)

instance Atomic AName where
  toAName = id

instance Eq AName where
  (AName a1) == (AName a2) =
    case cast a2 of
      Nothing  -> False
      Just a2' -> a1 == a2'

instance Ord AName where
  (AName a1) `compare` (AName a2) =
    case cast a2 of
      Nothing  -> (show $ typeOf a1) `compare` (show $ typeOf a2)
      Just a2' -> a1 `compare` a2'

instance Show AName where
  show (AName a) = show a

-- | A (qualified) name is a (possibly empty) sequence of atomic names.
newtype Name = Name [AName]
  deriving (Eq, Ord, Monoid)

instance Show Name where
  show (Name ns) = intercalate " |> " $ map show ns

-- | Convert an atomic name to a name.
toName :: Atomic a => a -> Name
toName = Name . (:[]) . toAName

-- | Instances of 'Qualifiable' are things which can be qualified by
--   prefixing them with an atomic name.
class Qualifiable q where
  -- | Qualify with the given name.
  (|>) :: Atomic a => a -> q -> q

-- | Of course, names can be qualified.
instance Qualifiable Name where
  a |> (Name as) = Name (toAName a : as)

-- | Convenient operator for writing complete names in the form @a1 |>
--   a2 |> a3 ||> a4@.  In particular, @a1 .> a2@ is equivalent to
--   @a1 |> toName a2@.
(.>) :: (Atomic a1, Atomic a2) => a1 -> a2 -> Name
a1 .> a2 = a1 |> toName a2

infixr 2 |>
infixr 2 .>

-- | Qualify by an entire qualified name.  @(a1 |> a2 .> a3) ||> q@ is
--   equivalent to @a1 |> a2 |> a3 |> q@.
(||>) :: Qualifiable q => Name -> q -> q
Name as ||> q = foldr (|>) q as

------------------------------------------------------------
--  Name maps  ---------------------------------------------
------------------------------------------------------------

-- | A 'NameMap' is a map associating names to pairs of points (local
--   origins) and bounding functions.  There can be multiple (point,
--   bounding function) pairs associated with each name.
newtype NameMap v = NameMap (M.Map Name [(Point v, TransInv (Bounds v))])
  deriving (Show)

-- Note, in some sense it would be nicer to use Sets instead of a
-- list, but then we would have to put Ord constraints on v
-- everywhere. =P

-- Note also that we wrap the bounds with TransInv.  This is because
-- the base point of each bounding function should be thought of as
-- the paired Point, *not* as the origin of the current vector space.
-- In other words, the point gets translated "for both of them".

type instance V (NameMap v) = v

-- | 'NameMap's form a monoid with the empty map as the identity, and
--   map union as the binary operation.  No information is ever lost:
--   if two maps have the same name in their domain, the resulting map
--   will associate that name to the concatenation of the information
--   associated with that name.
instance Monoid (NameMap v) where
  mempty = NameMap M.empty
  (NameMap s1) `mappend` (NameMap s2) = NameMap $ M.unionWith (++) s1 s2

instance (AdditiveGroup (Scalar v), Fractional (Scalar v), InnerSpace v)
      => HasOrigin (NameMap v) where
  moveOriginTo p (NameMap m) = NameMap $ M.map (map (moveOriginTo p *** moveOriginTo p)) m

instance (AdditiveGroup (Scalar v), InnerSpace v, Floating (Scalar v), HasLinearMap v)
  => Transformable (NameMap v) where
  transform t (NameMap ns) = NameMap $ M.map (map (papply t *** transform t)) ns

-- | 'NameMap's are qualifiable: if @ns@ is a 'NameMap', then @a |>
--   ns@ is the same 'NameMap' except with every name qualified by
--   @a@.
instance Qualifiable (NameMap v) where
  a |> (NameMap names) = NameMap $ M.mapKeys (a |>) names

-- | Construct a 'NameMap' from a list of (name, point) pairs.  The
--   bounding functions will be empty.
fromNames :: (AdditiveGroup (Scalar v), Ord (Scalar v), Atomic a)
          => [(a, Point v)] -> NameMap v
fromNames = NameMap . M.fromList . map (toName *** ((:[]) . (,mempty)))

-- | Construct a 'NameMap' from a list of associations between names
--   and (point, bounds) pairs.
fromNamesB :: Atomic a => [(a, (Point v, Bounds v))] -> NameMap v
fromNamesB = NameMap . M.fromList . map (toName *** (return . second TransInv))

-- | Give a name to a point and bounding function.
rememberAs :: Name -> Point v -> Bounds v -> NameMap v -> NameMap v
rememberAs n p b (NameMap names) = NameMap $ M.insertWith (++) n [(p,TransInv b)] names

-- | A name acts on a name map by qualifying every name in it.
instance Action Name (NameMap v) where
  act = (||>)

-- | Names don't act on anything else.
instance Action Name a


-- Searching in name maps.

-- | Look for the given name in a name map, returning a list of points
--   and bounding regions associated with that name.  If no names
--   match the given name exactly, return all the points associated
--   with names of which the given name is a suffix.
lookupN :: Name -> NameMap v -> Maybe [(Point v, Bounds v)]
lookupN n (NameMap m)
  = (fmap . map . second) unTransInv
    (M.lookup n m `mplus`
    (flatten . filter ((n `nameSuffixOf`) . fst) . M.assocs $ m))
  where (Name n1) `nameSuffixOf` (Name n2) = n1 `isSuffixOf` n2
        flatten [] = Nothing
        flatten xs = Just . concatMap snd $ xs