{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE ConstraintKinds         #-}
{-# LANGUAGE FlexibleContexts        #-}
{-# LANGUAGE TypeFamilies            #-}
{-# LANGUAGE TypeOperators           #-}
{-# LANGUAGE UndecidableInstances    #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Align
-- Copyright   :  (c) 2011-2013 diagrams-lib team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- The /alignment/ of an object refers to the position of its local
-- origin with respect to its envelope.  This module defines the
-- 'Alignable' class for things which can be aligned, as well as a
-- default implementation in terms of 'HasOrigin' and 'Enveloped',
-- along with several utility methods for alignment.
--
-----------------------------------------------------------------------------

module Diagrams.Align
       ( -- * Alignable class

         Alignable(..)
       , alignBy'Default
       , envelopeBoundary
       , traceBoundary

         -- * General alignment functions

       , align
       , snug
       , centerV, center
       , snugBy
       , snugCenterV, snugCenter

       ) where

import           Diagrams.Core
import           Diagrams.Util    (applyAll)

import           Data.Maybe       (fromMaybe)
import           Data.Ord         (comparing)
import           Data.Traversable
import           Prelude

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

import           Linear.Affine
import           Linear.Metric
import           Linear.Vector

-- | Class of things which can be aligned.
class Alignable a where

  -- | @alignBy v d a@ moves the origin of @a@ along the vector
  --   @v@. If @d = 1@, the origin is moved to the edge of the
  --   boundary in the direction of @v@; if @d = -1@, it moves to the
  --   edge of the boundary in the direction of the negation of @v@.
  --   Other values of @d@ interpolate linearly (so for example, @d =
  --   0@ centers the origin along the direction of @v@).
  alignBy' :: (InSpace v n a, Fractional n, HasOrigin a)
           => (v n -> a -> Point v n) -> v n -> n -> a -> a
  alignBy' = forall (v :: * -> *) n a.
(InSpace v n a, Fractional n, HasOrigin a) =>
(v n -> a -> Point v n) -> v n -> n -> a -> a
alignBy'Default

  defaultBoundary :: (V a ~ v, N a ~ n) => v n -> a -> Point v n

  alignBy :: (InSpace v n a, Fractional n, HasOrigin a)
          => v n -> n -> a -> a
  alignBy = forall a (v :: * -> *) n.
(Alignable a, InSpace v n a, Fractional n, HasOrigin a) =>
(v n -> a -> Point v n) -> v n -> n -> a -> a
alignBy' forall a (v :: * -> *) n.
(Alignable a, V a ~ v, N a ~ n) =>
v n -> a -> Point v n
defaultBoundary

-- | Default implementation of 'alignBy' for types with 'HasOrigin'
--   and 'AdditiveGroup' instances.
alignBy'Default :: (InSpace v n a, Fractional n, HasOrigin a)
                => (v n -> a -> Point v n) -> v n -> n -> a -> a
alignBy'Default :: forall (v :: * -> *) n a.
(InSpace v n a, Fractional n, HasOrigin a) =>
(v n -> a -> Point v n) -> v n -> n -> a -> a
alignBy'Default v n -> a -> Point v n
boundary v n
v n
d a
a = forall t. HasOrigin t => Point (V t) (N t) -> t -> t
moveOriginTo (forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp ((n
d forall a. Num a => a -> a -> a
+ n
1) forall a. Fractional a => a -> a -> a
/ n
2)
                                                    (v n -> a -> Point v n
boundary v n
v a
a)
                                                    (v n -> a -> Point v n
boundary (forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated v n
v) a
a)
                                              ) a
a
{-# ANN alignBy'Default ("HLint: ignore Use camelCase" :: String) #-}


-- | Some standard functions which can be used as the `boundary` argument to
--  `alignBy'`.
envelopeBoundary :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Point v n
envelopeBoundary :: forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a) =>
v n -> a -> Point v n
envelopeBoundary = forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a) =>
v n -> a -> Point v n
envelopeP

traceBoundary :: (V a ~ v, N a ~ n, Num n, Traced a) => v n -> a -> Point v n
traceBoundary :: forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Num n, Traced a) =>
v n -> a -> Point v n
traceBoundary v n
v a
a = forall a. a -> Maybe a -> a
fromMaybe forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin (forall n a.
(n ~ N a, Num n, Traced a) =>
Point (V a) n -> V a n -> a -> Maybe (Point (V a) n)
maxTraceP forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin v n
v a
a)

combineBoundaries
  :: (InSpace v n a, Metric v, Ord n, F.Foldable f)
  => (v n -> a -> Point v n) -> v n -> f a -> Point v n
combineBoundaries :: forall (v :: * -> *) n a (f :: * -> *).
(InSpace v n a, Metric v, Ord n, Foldable f) =>
(v n -> a -> Point v n) -> v n -> f a -> Point v n
combineBoundaries v n -> a -> Point v n
b v n
v f a
fa
  = v n -> a -> Point v n
b v n
v forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
F.maximumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
dot v n
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-.forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin) forall b c a. (b -> c) -> (a -> b) -> a -> c
. v n -> a -> Point v n
b v n
v)) f a
fa

instance (Metric v, OrderedField n) => Alignable (Envelope v n) where
  defaultBoundary :: forall (v :: * -> *) n.
(V (Envelope v n) ~ v, N (Envelope v n) ~ n) =>
v n -> Envelope v n -> Point v n
defaultBoundary = forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a) =>
v n -> a -> Point v n
envelopeBoundary

instance (Metric v, OrderedField n) => Alignable (Trace v n) where
  defaultBoundary :: forall (v :: * -> *) n.
(V (Trace v n) ~ v, N (Trace v n) ~ n) =>
v n -> Trace v n -> Point v n
defaultBoundary = forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Num n, Traced a) =>
v n -> a -> Point v n
traceBoundary

instance (V b ~ v, N b ~ n, Metric v, OrderedField n, Alignable b) => Alignable [b] where
  defaultBoundary :: forall (v :: * -> *) n.
(V [b] ~ v, N [b] ~ n) =>
v n -> [b] -> Point v n
defaultBoundary = forall (v :: * -> *) n a (f :: * -> *).
(InSpace v n a, Metric v, Ord n, Foldable f) =>
(v n -> a -> Point v n) -> v n -> f a -> Point v n
combineBoundaries forall a (v :: * -> *) n.
(Alignable a, V a ~ v, N a ~ n) =>
v n -> a -> Point v n
defaultBoundary

instance (V b ~ v, N b ~ n, Metric v, OrderedField n, Alignable b)
    => Alignable (S.Set b) where
  defaultBoundary :: forall (v :: * -> *) n.
(V (Set b) ~ v, N (Set b) ~ n) =>
v n -> Set b -> Point v n
defaultBoundary = forall (v :: * -> *) n a (f :: * -> *).
(InSpace v n a, Metric v, Ord n, Foldable f) =>
(v n -> a -> Point v n) -> v n -> f a -> Point v n
combineBoundaries forall a (v :: * -> *) n.
(Alignable a, V a ~ v, N a ~ n) =>
v n -> a -> Point v n
defaultBoundary

instance (V b ~ v, N b ~ n, Metric v, OrderedField n, Alignable b)
    => Alignable (M.Map k b) where
  defaultBoundary :: forall (v :: * -> *) n.
(V (Map k b) ~ v, N (Map k b) ~ n) =>
v n -> Map k b -> Point v n
defaultBoundary = forall (v :: * -> *) n a (f :: * -> *).
(InSpace v n a, Metric v, Ord n, Foldable f) =>
(v n -> a -> Point v n) -> v n -> f a -> Point v n
combineBoundaries forall a (v :: * -> *) n.
(Alignable a, V a ~ v, N a ~ n) =>
v n -> a -> Point v n
defaultBoundary

instance (Metric v, OrderedField n, Monoid' m)
    => Alignable (QDiagram b v n m) where
  defaultBoundary :: forall (v :: * -> *) n.
(V (QDiagram b v n m) ~ v, N (QDiagram b v n m) ~ n) =>
v n -> QDiagram b v n m -> Point v n
defaultBoundary = forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a) =>
v n -> a -> Point v n
envelopeBoundary

-- | Although the 'alignBy' method for the @(b -> a)@ instance is
--   sensible, there is no good implementation for
--   'defaultBoundary'. Instead, we provide a total method, but one that
--   is not sensible. This should not present a serious problem as long
--   as your use of 'Alignable' happens through 'alignBy'.
instance (InSpace v n a, HasOrigin a, Alignable a) => Alignable (b -> a) where
  alignBy :: forall (v :: * -> *) n.
(InSpace v n (b -> a), Fractional n, HasOrigin (b -> a)) =>
v n -> n -> (b -> a) -> b -> a
alignBy v n
v n
d b -> a
f b
b     = forall a (v :: * -> *) n.
(Alignable a, InSpace v n a, Fractional n, HasOrigin a) =>
v n -> n -> a -> a
alignBy v n
v n
d (b -> a
f b
b)
  defaultBoundary :: forall (v :: * -> *) n.
(V (b -> a) ~ v, N (b -> a) ~ n) =>
v n -> (b -> a) -> Point v n
defaultBoundary v n
_ b -> a
_ = forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin

-- | @align v@ aligns an enveloped object along the edge in the
--   direction of @v@.  That is, it moves the local origin in the
--   direction of @v@ until it is on the edge of the envelope.  (Note
--   that if the local origin is outside the envelope to begin with,
--   it may have to move \"backwards\".)
align :: (InSpace v n a, Fractional n, Alignable a, HasOrigin a) => v n -> a -> a
align :: forall (v :: * -> *) n a.
(InSpace v n a, Fractional n, Alignable a, HasOrigin a) =>
v n -> a -> a
align v n
v = forall a (v :: * -> *) n.
(Alignable a, InSpace v n a, Fractional n, HasOrigin a) =>
v n -> n -> a -> a
alignBy v n
v n
1

-- | Version of @alignBy@ specialized to use @traceBoundary@
snugBy :: (InSpace v n a, Fractional n, Alignable a, Traced a, HasOrigin a)
       => v n -> n -> a -> a
snugBy :: forall (v :: * -> *) n a.
(InSpace v n a, Fractional n, Alignable a, Traced a,
 HasOrigin a) =>
v n -> n -> a -> a
snugBy = forall a (v :: * -> *) n.
(Alignable a, InSpace v n a, Fractional n, HasOrigin a) =>
(v n -> a -> Point v n) -> v n -> n -> a -> a
alignBy' forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Num n, Traced a) =>
v n -> a -> Point v n
traceBoundary

-- | Like align but uses trace.
snug :: (InSpace v n a, Fractional n, Alignable a, Traced a, HasOrigin a)
      => v n -> a -> a
snug :: forall (v :: * -> *) n a.
(InSpace v n a, Fractional n, Alignable a, Traced a,
 HasOrigin a) =>
v n -> a -> a
snug v n
v = forall (v :: * -> *) n a.
(InSpace v n a, Fractional n, Alignable a, Traced a,
 HasOrigin a) =>
v n -> n -> a -> a
snugBy v n
v n
1

-- | @centerV v@ centers an enveloped object along the direction of
--   @v@.
centerV :: (InSpace v n a, Fractional n, Alignable a, HasOrigin a) => v n -> a -> a
centerV :: forall (v :: * -> *) n a.
(InSpace v n a, Fractional n, Alignable a, HasOrigin a) =>
v n -> a -> a
centerV v n
v = forall a (v :: * -> *) n.
(Alignable a, InSpace v n a, Fractional n, HasOrigin a) =>
v n -> n -> a -> a
alignBy v n
v n
0

-- | @center@ centers an enveloped object along all of its basis vectors.
center :: (InSpace v n a, Fractional n, Traversable v, Alignable a, HasOrigin a) => a -> a
center :: forall (v :: * -> *) n a.
(InSpace v n a, Fractional n, Traversable v, Alignable a,
 HasOrigin a) =>
a -> a
center = forall a. [a -> a] -> a -> a
applyAll [a -> a]
fs
  where
    fs :: [a -> a]
fs = forall a b. (a -> b) -> [a] -> [b]
map forall (v :: * -> *) n a.
(InSpace v n a, Fractional n, Alignable a, HasOrigin a) =>
v n -> a -> a
centerV forall (t :: * -> *) a. (Additive t, Traversable t, Num a) => [t a]
basis

-- | Like @centerV@ using trace.
snugCenterV
  :: (InSpace v n a, Fractional n, Alignable a, Traced a, HasOrigin a)
   => v n -> a -> a
snugCenterV :: forall (v :: * -> *) n a.
(InSpace v n a, Fractional n, Alignable a, Traced a,
 HasOrigin a) =>
v n -> a -> a
snugCenterV v n
v = forall a (v :: * -> *) n.
(Alignable a, InSpace v n a, Fractional n, HasOrigin a) =>
(v n -> a -> Point v n) -> v n -> n -> a -> a
alignBy' forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Num n, Traced a) =>
v n -> a -> Point v n
traceBoundary v n
v n
0

-- | Like @center@ using trace.
snugCenter :: (InSpace v n a, Traversable v, Fractional n, Alignable a, HasOrigin a, Traced a)
           => a -> a
snugCenter :: forall (v :: * -> *) n a.
(InSpace v n a, Traversable v, Fractional n, Alignable a,
 HasOrigin a, Traced a) =>
a -> a
snugCenter = forall a. [a -> a] -> a -> a
applyAll [a -> a]
fs
  where
    fs :: [a -> a]
fs = forall a b. (a -> b) -> [a] -> [b]
map forall (v :: * -> *) n a.
(InSpace v n a, Fractional n, Alignable a, Traced a,
 HasOrigin a) =>
v n -> a -> a
snugCenterV forall (t :: * -> *) a. (Additive t, Traversable t, Num a) => [t a]
basis

{-# ANN module ("HLint: ignore Use camelCase" :: String) #-}