{-# 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
         AName(..)

        -- ** Names
       , Name(..), IsName(..), (.>)

        -- ** 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 Graphics.Rendering.Diagrams.Util

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

-- | Class for those types 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) => IsName a where
  toName :: a -> Name
  toName = Name . (:[]) . AName

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

-- | Atomic names.  @AName@ is just an existential wrapper around
--   things which are 'Typeable', 'Ord' and 'Show'.
data AName where
  AName :: (Typeable a, Ord a, Show a) => a -> AName
  deriving (Typeable)

instance IsName AName where
  toName = Name . (:[])

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

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

instance IsName Name where
  toName = id

-- | Convenient operator for writing qualified names with atomic
--   components of different types.  Instead of writing @toName a1 \<\>
--   toName a2 \<\> toName a3@ you can just write @a1 .> a2 .> a3@.
(.>) :: (IsName a1, IsName a2) => a1 -> a2 -> Name
a1 .> a2 = toName a1 <> toName a2

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

-- | Of course, names can be qualified using @(.>)@.
instance Qualifiable Name where
  (|>) = (.>)

infixr 5 |>
infixr 5 .>

------------------------------------------------------------
--  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), IsName 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 :: IsName 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 :: IsName a => a -> Point v -> Bounds v -> NameMap v -> NameMap v
rememberAs n p b (NameMap names) = NameMap $ M.insertWith (++) (toName 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 :: IsName n => n -> NameMap v -> Maybe [(Point v, Bounds v)]
lookupN a (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
        n = toName a