{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
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
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 :: ( 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 :: 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 :: 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 :: 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
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]
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)
= 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
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
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."
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)
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."