{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Layout.Wrap
-- Copyright   :  (c) 2012 Michael Sloan
-- License     :  BSD-style (see the LICENSE file)
-- Maintainer  :  Michael Sloan <mgsloan at gmail>
--
-- An algorithm for filling space in a fashion akin to word-wrapping.
--
------------------------------------------------------------------------

module Diagrams.Layout.Wrap where

import           Control.Arrow    (first, (&&&))
import qualified Data.Foldable    as F
import           Data.List        (find, inits, tails)
import           Diagrams.Prelude hiding (start)
import           Linear.Epsilon

-- TODO: Take into account the negative bounds, and iteratively refine
--   the list selection.

-- TODO: Search for a region before / after the target pick.

-- | @wrapDiagram@ post-processes the results of @wrapOutside@ /
--   @wrapInside@ into a Diagram of the result.  This only works when
--   applying them to a list of diagrams.
wrapDiagram :: (Metric v, OrderedField n)
            => ([(v n, QDiagram b v n Any)], [QDiagram b v n Any]) -> QDiagram b v n Any
wrapDiagram :: forall (v :: * -> *) n b.
(Metric v, OrderedField n) =>
([(v n, QDiagram b v n Any)], [QDiagram b v n Any])
-> QDiagram b v n Any
wrapDiagram = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall t. Transformable t => Vn t -> t -> t
translate) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst

-- | @wrapOutside@ is the same as @wrapInside@, but with an inverted
--   predicate.
wrapOutside :: ( Enveloped a, V a ~ v, N a ~ n
               , Epsilon n -- See [6.12.3] note below
               )
            => (Point v n -> Bool) -> [v n] -> Point v n -> [a] -> ([(v n, a)], [a])
wrapOutside :: forall a (v :: * -> *) n.
(Enveloped a, V a ~ v, N a ~ n, Epsilon n) =>
(Point v n -> Bool)
-> [v n] -> Point v n -> [a] -> ([(v n, a)], [a])
wrapOutside Point v n -> Bool
f = forall a (v :: * -> *) n.
(Enveloped a, V a ~ v, N a ~ n, Metric v, OrderedField n,
 Epsilon n) =>
(Point v n -> Bool)
-> [v n] -> Point v n -> [a] -> ([(v n, a)], [a])
wrapInside (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point v n -> Bool
f)

-- | @wrapInside@ greedily wraps content to fill a space defined by a
--   predicate.  It is passed a list of vectors which express the
--   order of dimensions to be filled.  In other words, wrapping RTL
--   text is done by passing in [unitX, unitY], to first exhaust
--   space horizontally, and then vertically.
--
--   Note that this function does not guarantee that there are not
--   points inside each positioned item for which the predicate is
--   False.  Instead, only the corners of the bounds, along each axii,
--   are used.
wrapInside :: forall a v n.
           ( Enveloped a, V a ~ v, N a ~ n
           , Metric v, OrderedField n, Epsilon n -- See [6.12.3] note below
           )
           => (Point v n -> Bool) -> [v n] -> Point v n
           -> [a] -> ([(v n, a)], [a])
wrapInside :: forall a (v :: * -> *) n.
(Enveloped a, V a ~ v, N a ~ n, Metric v, OrderedField n,
 Epsilon n) =>
(Point v n -> Bool)
-> [v n] -> Point v n -> [a] -> ([(v n, a)], [a])
wrapInside Point v n -> Bool
f [v n]
axis Point v n
start = [(n, n)] -> [a] -> ([(v n, a)], [a])
rec [(n, n)]
zeros
 where
  zeros :: [(n, n)]
zeros = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [v n]
axis forall a b. (a -> b) -> a -> b
$ forall a. a -> [a]
repeat (n
0, n
0)
  norms :: [v n]
norms = forall a b. (a -> b) -> [a] -> [b]
map forall a (f :: * -> *).
(Floating a, Metric f, Epsilon a) =>
f a -> f a
normalize [v n]
axis
  getVector :: [n] -> v n
getVector = forall (f :: * -> *) (v :: * -> *) a.
(Foldable f, Additive v, Num a) =>
f (v a) -> v a
sumV forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
(^*) [v n]
norms

-- [[min bound, max bound]] of each axis.
  boundsScalars :: a -> [[v n]]
  boundsScalars :: a -> [[v n]]
boundsScalars a
d
    = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [v n]
norms
    forall a b. (a -> b) -> a -> b
$ \v n
v -> forall a b. (a -> b) -> [a] -> [b]
map (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 a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a) =>
v n -> a -> Point v n
envelopeP (forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated v n
v) a
d, forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a) =>
v n -> a -> Point v n
envelopeP v n
v a
d]

-- Recurses on the list of items to lay out, maintaing a current set of
-- coefficients for the different axii, each paired with the maximum
-- boundary seen in that direction.
  rec :: [(n, n)] -> [a] -> ([(v n, a)], [a])
  rec :: [(n, n)] -> [a] -> ([(v n, a)], [a])
rec [(n, n)]
_ [] = (forall a. Monoid a => a
mempty, [])
  rec [(n, n)]
scs (a
d:[a]
ds)
-- Recurse a satisfactory position can be found, otherwise yields the
-- list of the remaining diagrams to be laid out.
    = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Monoid a => a
mempty, a
dforall a. a -> [a] -> [a]
:[a]
ds)
            (\(v n
v, [(n, n)]
scs') -> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((v n
v, a
d)forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ [(n, n)] -> [a] -> ([(v n, a)], [a])
rec [(n, n)]
scs' [a]
ds)
    forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (v n -> Bool
check forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(v n, [(n, n)])]
potential
   where
    curB :: [[v n]]
curB = a -> [[v n]]
boundsScalars a
d

-- Yields whether a given vector offset avoids collision.
    check :: v n -> Bool
check v n
v = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Point v n -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point v n
start forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (v :: * -> *) a.
(Foldable f, Additive v, Num a) =>
f (v a) -> v a
sumV forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v n
vforall a. a -> [a] -> [a]
:)) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [[v n]]
curB

-- Updates the max bounds of an axis.
    maxB :: [f b] -> (b, b) -> (b, b)
maxB [f b
_, f b
b] (b
x, b
m) = (b
x, forall a. Ord a => a -> a -> a
max b
m forall a b. (a -> b) -> a -> b
$ b
x forall a. Num a => a -> a -> a
+ forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm f b
b)
    maxB [f b]
_ (b, b)
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"Diagrams.Layout.Wrap.wrapInside:maxB: pattern-match failure.  Please report this as a bug."

-- List of potential offsets to try, each paired with an updated list
-- of current / maxbound scalar coefficients for the axis.
    potential :: [(v n, [(n, n)])]
potential = forall a b. (a -> b) -> [a] -> [b]
map ([n] -> v n
getVector forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {b} {f :: * -> *}.
(Ord b, Metric f, Floating b) =>
[f b] -> (b, b) -> (b, b)
maxB [[v n]]
curB)
-- Try setting an axis to its max-seen bound, zeroing all preceding.
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. [a] -> [a] -> [a]
(++) (forall a. [a] -> [[a]]
inits forall a b. (a -> b) -> a -> b
$ forall a. a -> [a]
repeat (n
0, n
0))
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {b}. [(b, b)] -> [(b, b)]
dupFirstY
              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
init forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]]
tails [(n, n)]
scs

    dupFirstY :: [(b, b)] -> [(b, b)]
dupFirstY ((b
_,b
x):[(b, b)]
xs) = (b
x,b
x)forall a. a -> [a] -> [a]
:[(b, b)]
xs
    dupFirstY [(b, b)]
_          = forall a. HasCallStack => [Char] -> a
error [Char]
"Diagrams.Layout.Wrap.wrapInside:dupFirstY: pattern-match failure.  Please report this as a bug."

-- [6.12.3]: It should be possible to infer the Metric v and
--   OrderedField n constraints from Enveloped a, v ~ V a,
--   but GHC 6.12.3 cannot, so we redundantly list them here to
--   preserve support for 6.12.3.
-- TODO this comment is obsolete; we certainly do not support GHC 6.12.3

--   Attempt at diagrams-haddock example, but I don't understand how Wrap works
--
--   > import Diagrams.Layout.Wrap
--   > import Control.Arrow (first)
--   > wrapInsideEx = position ((map . first $ (origin .+^)) ds)
--   >   where (ds,_) = wrapInside
--   >                    (getAny . (runQuery . query $ (circle 15 :: D V2 n)))
--   >                    [unitX, unitY]
--   >                    (origin)
--   >                    (repeat (circle 1 # fc black))
--
--   <diagrams/wrapInsideEx.svg#diagram=wrapInsideEx&width=200>