{-# 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 = ((v n, QDiagram b v n Any) -> QDiagram b v n Any)
-> [(v n, QDiagram b v n Any)] -> QDiagram b v n Any
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap ((v n -> QDiagram b v n Any -> QDiagram b v n Any)
-> (v n, QDiagram b v n Any) -> QDiagram b v n Any
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry v n -> QDiagram b v n Any -> QDiagram b v n Any
Vn (QDiagram b v n Any) -> QDiagram b v n Any -> QDiagram b v n Any
forall t. Transformable t => Vn t -> t -> t
translate) ([(v n, QDiagram b v n Any)] -> QDiagram b v n Any)
-> (([(v n, QDiagram b v n Any)], [QDiagram b v n Any])
    -> [(v n, QDiagram b v n Any)])
-> ([(v n, QDiagram b v n Any)], [QDiagram b v n Any])
-> QDiagram b v n Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(v n, QDiagram b v n Any)], [QDiagram b v n Any])
-> [(v n, QDiagram b v n Any)]
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 = (Point v n -> Bool)
-> [v n] -> Point v n -> [a] -> ([(v n, a)], [a])
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 (Bool -> Bool) -> (Point v n -> Bool) -> Point v n -> Bool
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 = ((v n, (n, n)) -> (n, n)) -> [(v n, (n, n))] -> [(n, n)]
forall a b. (a -> b) -> [a] -> [b]
map (v n, (n, n)) -> (n, n)
forall a b. (a, b) -> b
snd ([(v n, (n, n))] -> [(n, n)])
-> ([(n, n)] -> [(v n, (n, n))]) -> [(n, n)] -> [(n, n)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v n] -> [(n, n)] -> [(v n, (n, n))]
forall a b. [a] -> [b] -> [(a, b)]
zip [v n]
axis ([(n, n)] -> [(n, n)]) -> [(n, n)] -> [(n, n)]
forall a b. (a -> b) -> a -> b
$ (n, n) -> [(n, n)]
forall a. a -> [a]
repeat (n
0, n
0)
  norms :: [v n]
norms = (v n -> v n) -> [v n] -> [v n]
forall a b. (a -> b) -> [a] -> [b]
map v n -> v n
forall a (f :: * -> *).
(Floating a, Metric f, Epsilon a) =>
f a -> f a
normalize [v n]
axis
  getVector :: [n] -> v n
getVector = [v n] -> v n
forall (f :: * -> *) (v :: * -> *) a.
(Foldable f, Additive v, Num a) =>
f (v a) -> v a
sumV ([v n] -> v n) -> ([n] -> [v n]) -> [n] -> v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v n -> n -> v n) -> [v n] -> [n] -> [v n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith v n -> n -> v n
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
    = ((v n -> [v n]) -> [v n] -> [[v n]])
-> [v n] -> (v n -> [v n]) -> [[v n]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (v n -> [v n]) -> [v n] -> [[v n]]
forall a b. (a -> b) -> [a] -> [b]
map [v n]
norms
    ((v n -> [v n]) -> [[v n]]) -> (v n -> [v n]) -> [[v n]]
forall a b. (a -> b) -> a -> b
$ \v n
v -> (Point v n -> v n) -> [Point v n] -> [v n]
forall a b. (a -> b) -> [a] -> [b]
map (Point v n -> Point v n -> Diff (Point v) n
forall a. Num a => Point v a -> Point v a -> Diff (Point v) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point v n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin) [v n -> a -> Point v n
forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a) =>
v n -> a -> Point v n
envelopeP (v n -> v n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated v n
v) a
d, v n -> a -> Point v n
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)]
_ [] = ([(v n, a)]
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.
    = ([(v n, a)], [a])
-> ((v n, [(n, n)]) -> ([(v n, a)], [a]))
-> Maybe (v n, [(n, n)])
-> ([(v n, a)], [a])
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([(v n, a)]
forall a. Monoid a => a
mempty, a
da -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ds)
            (\(v n
v, [(n, n)]
scs') -> ([(v n, a)] -> [(v n, a)])
-> ([(v n, a)], [a]) -> ([(v n, a)], [a])
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((v n
v, a
d)(v n, a) -> [(v n, a)] -> [(v n, a)]
forall a. a -> [a] -> [a]
:) (([(v n, a)], [a]) -> ([(v n, a)], [a]))
-> ([(v n, a)], [a]) -> ([(v n, a)], [a])
forall a b. (a -> b) -> a -> b
$ [(n, n)] -> [a] -> ([(v n, a)], [a])
rec [(n, n)]
scs' [a]
ds)
    (Maybe (v n, [(n, n)]) -> ([(v n, a)], [a]))
-> Maybe (v n, [(n, n)]) -> ([(v n, a)], [a])
forall a b. (a -> b) -> a -> b
$ ((v n, [(n, n)]) -> Bool)
-> [(v n, [(n, n)])] -> Maybe (v n, [(n, n)])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (v n -> Bool
check (v n -> Bool)
-> ((v n, [(n, n)]) -> v n) -> (v n, [(n, n)]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v n, [(n, n)]) -> v n
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 = ([v n] -> Bool) -> [[v n]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Point v n -> Bool
f (Point v n -> Bool) -> ([v n] -> Point v n) -> [v n] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point v n
start Point v n -> Diff (Point v) n -> Point v n
forall a. Num a => Point v a -> Diff (Point v) a -> Point v a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^) (v n -> Point v n) -> ([v n] -> v n) -> [v n] -> Point v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [v n] -> v n
forall (f :: * -> *) (v :: * -> *) a.
(Foldable f, Additive v, Num a) =>
f (v a) -> v a
sumV ([v n] -> v n) -> ([v n] -> [v n]) -> [v n] -> v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (v n
vv n -> [v n] -> [v n]
forall a. a -> [a] -> [a]
:)) ([[v n]] -> Bool) -> [[v n]] -> Bool
forall a b. (a -> b) -> a -> b
$ [[v n]] -> [[v n]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [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, b -> b -> b
forall a. Ord a => a -> a -> a
max b
m (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$ b
x b -> b -> b
forall a. Num a => a -> a -> a
+ f b -> b
forall a. Floating a => f a -> a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm f b
b)
    maxB [f b]
_ (b, b)
_ = [Char] -> (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 = ([(n, n)] -> (v n, [(n, n)])) -> [[(n, n)]] -> [(v n, [(n, n)])]
forall a b. (a -> b) -> [a] -> [b]
map ([n] -> v n
getVector ([n] -> v n) -> ([(n, n)] -> [n]) -> [(n, n)] -> v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((n, n) -> n) -> [(n, n)] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map (n, n) -> n
forall a b. (a, b) -> a
fst ([(n, n)] -> v n)
-> ([(n, n)] -> [(n, n)]) -> [(n, n)] -> (v n, [(n, n)])
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ([v n] -> (n, n) -> (n, n)) -> [[v n]] -> [(n, n)] -> [(n, n)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [v n] -> (n, n) -> (n, n)
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.
              ([[(n, n)]] -> [(v n, [(n, n)])])
-> ([[(n, n)]] -> [[(n, n)]]) -> [[(n, n)]] -> [(v n, [(n, n)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(n, n)] -> [(n, n)] -> [(n, n)])
-> [[(n, n)]] -> [[(n, n)]] -> [[(n, n)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [(n, n)] -> [(n, n)] -> [(n, n)]
forall a. [a] -> [a] -> [a]
(++) ([(n, n)] -> [[(n, n)]]
forall a. [a] -> [[a]]
inits ([(n, n)] -> [[(n, n)]]) -> [(n, n)] -> [[(n, n)]]
forall a b. (a -> b) -> a -> b
$ (n, n) -> [(n, n)]
forall a. a -> [a]
repeat (n
0, n
0))
              ([[(n, n)]] -> [[(n, n)]])
-> ([[(n, n)]] -> [[(n, n)]]) -> [[(n, n)]] -> [[(n, n)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(n, n)] -> [(n, n)]) -> [[(n, n)]] -> [[(n, n)]]
forall a b. (a -> b) -> [a] -> [b]
map [(n, n)] -> [(n, n)]
forall {b}. [(b, b)] -> [(b, b)]
dupFirstY
              ([[(n, n)]] -> [[(n, n)]])
-> ([[(n, n)]] -> [[(n, n)]]) -> [[(n, n)]] -> [[(n, n)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(n, n)]] -> [[(n, n)]]
forall a. HasCallStack => [a] -> [a]
init ([[(n, n)]] -> [(v n, [(n, n)])])
-> [[(n, n)]] -> [(v n, [(n, n)])]
forall a b. (a -> b) -> a -> b
$ [(n, n)] -> [[(n, n)]]
forall a. [a] -> [[a]]
tails [(n, n)]
scs

    dupFirstY :: [(b, b)] -> [(b, b)]
dupFirstY ((b
_,b
x):[(b, b)]
xs) = (b
x,b
x)(b, b) -> [(b, b)] -> [(b, b)]
forall a. a -> [a] -> [a]
:[(b, b)]
xs
    dupFirstY [(b, b)]
_          = [Char] -> [(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>