{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

-- The UndecidableInstances flag is needed under 6.12.3 for the
-- HasOrigin (a,b) instance.

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Core.HasOrigin
-- Copyright   :  (c) 2011 diagrams-core team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Types which have an intrinsic notion of a \"local origin\",
-- /i.e./ things which are /not/ invariant under translation.
--
-----------------------------------------------------------------------------

module Diagrams.Core.HasOrigin
       ( HasOrigin(..), moveOriginBy, moveTo, place
       ) where

import qualified Data.Map              as M
import qualified Data.Set              as S

import           Diagrams.Core.Measure
import           Diagrams.Core.Points  ()
import           Diagrams.Core.V

import           Linear.Affine
import           Linear.Vector

-- | Class of types which have an intrinsic notion of a \"local
--   origin\", i.e. things which are not invariant under translation,
--   and which allow the origin to be moved.
--
--   One might wonder why not just use 'Transformable' instead of
--   having a separate class for 'HasOrigin'; indeed, for types which
--   are instances of both we should have the identity
--
--   @
--   moveOriginTo (origin .^+ v) === translate (negated v)
--   @
--
--   The reason is that some things (e.g. vectors, 'Trail's) are
--   transformable but are translationally invariant, i.e. have no
--   origin.
class HasOrigin t where

  -- | Move the local origin to another point.
  --
  --   Note that this function is in some sense dual to 'translate'
  --   (for types which are also 'Transformable'); moving the origin
  --   itself while leaving the object \"fixed\" is dual to fixing the
  --   origin and translating the diagram.
  moveOriginTo :: Point (V t) (N t) -> t -> t

-- | Move the local origin by a relative vector.
moveOriginBy :: (V t ~ v, N t ~ n, HasOrigin t) => v n -> t -> t
moveOriginBy :: forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, HasOrigin t) =>
v n -> t -> t
moveOriginBy = forall t. HasOrigin t => Point (V t) (N t) -> t -> t
moveOriginTo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. f a -> Point f a
P

-- | Translate the object by the translation that sends the origin to
--   the given point. Note that this is dual to 'moveOriginTo', i.e. we
--   should have
--
--   @
--   moveTo (origin .^+ v) === moveOriginTo (origin .^- v)
--   @
--
--   For types which are also 'Transformable', this is essentially the
--   same as 'translate', i.e.
--
--   @
--   moveTo (origin .^+ v) === translate v
--   @
moveTo :: (InSpace v n t, HasOrigin t) => Point v n -> t -> t
moveTo :: forall (v :: * -> *) n t.
(InSpace v n t, HasOrigin t) =>
Point v n -> t -> t
moveTo = forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, HasOrigin t) =>
v n -> t -> t
moveOriginBy forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-.)

-- | A flipped variant of 'moveTo', provided for convenience.  Useful
--   when writing a function which takes a point as an argument, such
--   as when using 'withName' and friends.
place :: (InSpace v n t, HasOrigin t) => t -> Point v n -> t
place :: forall (v :: * -> *) n t.
(InSpace v n t, HasOrigin t) =>
t -> Point v n -> t
place = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (v :: * -> *) n t.
(InSpace v n t, HasOrigin t) =>
Point v n -> t -> t
moveTo

instance HasOrigin t => HasOrigin (Measured n t) where
  moveOriginTo :: Point (V (Measured n t)) (N (Measured n t))
-> Measured n t -> Measured n t
moveOriginTo = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. HasOrigin t => Point (V t) (N t) -> t -> t
moveOriginTo

instance (Additive v, Num n) => HasOrigin (Point v n) where
  moveOriginTo :: Point (V (Point v n)) (N (Point v n)) -> Point v n -> Point v n
moveOriginTo (P V (Point v n) (N (Point v n))
u) Point v n
p = Point v n
p forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.-^ V (Point v n) (N (Point v n))
u

instance (HasOrigin t, HasOrigin s, SameSpace s t) => HasOrigin (s, t) where
  moveOriginTo :: Point (V (s, t)) (N (s, t)) -> (s, t) -> (s, t)
moveOriginTo Point (V (s, t)) (N (s, t))
p (s
x,t
y) = (forall t. HasOrigin t => Point (V t) (N t) -> t -> t
moveOriginTo Point (V (s, t)) (N (s, t))
p s
x, forall t. HasOrigin t => Point (V t) (N t) -> t -> t
moveOriginTo Point (V (s, t)) (N (s, t))
p t
y)

instance HasOrigin t => HasOrigin [t] where
  moveOriginTo :: Point (V [t]) (N [t]) -> [t] -> [t]
moveOriginTo = forall a b. (a -> b) -> [a] -> [b]
map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. HasOrigin t => Point (V t) (N t) -> t -> t
moveOriginTo

instance (HasOrigin t, Ord t) => HasOrigin (S.Set t) where
  moveOriginTo :: Point (V (Set t)) (N (Set t)) -> Set t -> Set t
moveOriginTo = forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. HasOrigin t => Point (V t) (N t) -> t -> t
moveOriginTo

instance HasOrigin t => HasOrigin (M.Map k t) where
  moveOriginTo :: Point (V (Map k t)) (N (Map k t)) -> Map k t -> Map k t
moveOriginTo = forall a b k. (a -> b) -> Map k a -> Map k b
M.map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. HasOrigin t => Point (V t) (N t) -> t -> t
moveOriginTo