{-# LANGUAGE MultiWayIf        #-}
{-# LANGUAGE OverloadedStrings #-}
{-|
Copyright   : Written by David Himmelstrup
License     : Unlicense
Maintainer  : lemmih@gmail.com
Stability   : experimental
Portability : POSIX
-}
module Reanimate.Math.Balloon
  ( balloon
  , balloon'
  ) where

import           Control.Lens
import qualified Data.Vector                as V
import           Graphics.SvgTree           (drawAttributes)
import           Linear.V2
import           Linear.Vector
import           Reanimate.Animation
import           Reanimate.Math.Common
import           Reanimate.Math.Polygon
import           Reanimate.Morph.Common     (toShapes)
import           Reanimate.Svg.Constructors

-- import           Debug.Trace

-- | Inflate SVG shapes like a balloon. This works by hiding corners
--   that are more than @t@ percent distant from the starting point
--   relative to the maximum diameter of the shape.
--
--   Example:
--
-- @
-- 'animate' $ 'balloon' ('scale' 8 $ 'center' $ 'Reanimate.LaTeX.latex' \"X\")
-- @
--
--   <<docs/gifs/doc_balloon.gif>>
balloon :: SVG -> (Double -> SVG)
balloon :: SVG -> Double -> SVG
balloon = Double -> SVG -> Double -> SVG
balloon' Double
0.01

-- | Same as @balloon'@ but with a given tolerance for converting
--   SVG shapes to polygons.
balloon' :: Double -> SVG -> (Double -> SVG)
balloon' :: Double -> SVG -> Double -> SVG
balloon' Double
tol SVG
svg = \Double
t ->
    [SVG] -> SVG
mkGroup
    [ Polygon -> SVG
polygonShape (Double -> Polygon
gen Double
t) SVG -> (SVG -> SVG) -> SVG
forall a b. a -> (a -> b) -> b
& (DrawAttributes -> Identity DrawAttributes) -> SVG -> Identity SVG
forall c. HasDrawAttributes c => Lens' c DrawAttributes
drawAttributes ((DrawAttributes -> Identity DrawAttributes)
 -> SVG -> Identity SVG)
-> DrawAttributes -> SVG -> SVG
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DrawAttributes
attr
    | (DrawAttributes
attr, Double -> Polygon
gen) <- [(DrawAttributes, Double -> Polygon)]
lst ]
  where
    polygonShape :: Polygon -> SVG
    polygonShape :: Polygon -> SVG
polygonShape Polygon
p = [(Double, Double)] -> SVG
mkLinePathClosed
      [ (Double
x,Double
y) | V2 Double
x Double
y <- (V2 Rational -> V2 Double) -> [V2 Rational] -> [V2 Double]
forall a b. (a -> b) -> [a] -> [b]
map ((Rational -> Double) -> V2 Rational -> V2 Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rational -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac) ([V2 Rational] -> [V2 Double]) -> [V2 Rational] -> [V2 Double]
forall a b. (a -> b) -> a -> b
$ Vector (V2 Rational) -> [V2 Rational]
forall a. Vector a -> [a]
V.toList (Polygon -> Vector (V2 Rational)
forall a. APolygon a -> Vector (V2 a)
polygonPoints Polygon
p) ]
    lst :: [(DrawAttributes, Double -> Polygon)]
lst =
      [ (DrawAttributes
attr, Polygon -> Double -> Polygon
balloonP (Polygon -> Double -> Polygon) -> Polygon -> Double -> Polygon
forall a b. (a -> b) -> a -> b
$ Polygon -> Polygon
shiftLongestDiameter Polygon
poly)
      | (DrawAttributes
attr, Polygon
poly) <- Double -> SVG -> [(DrawAttributes, Polygon)]
toShapes Double
tol SVG
svg
      ]

-- x <= 1
-- diameter (balloonP x p) = diameter p * x
balloonP :: Polygon -> Double -> Polygon
balloonP :: Polygon -> Double -> Polygon
balloonP Polygon
p = \Double
t ->
    let targetLength :: Double
targetLength = Double
d Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
t
        nodeVisible :: Int -> Bool
nodeVisible Int
x = Vector Double
ds Vector Double -> Int -> Double
forall a. Vector a -> Int -> a
V.! Int
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
targetLength
        -- Move 'a' closer to 'target' such that the length from point 0 to 'a'
        -- is targetLength.
        moveCloser :: Int -> V2 Rational -> V2 Rational
        moveCloser :: Int -> V2 Rational -> V2 Rational
moveCloser Int
target V2 Rational
a =
          let targetDist :: Double
targetDist = Vector Double
ds Vector Double -> Int -> Double
forall a. Vector a -> Int -> a
V.! Int
target
              aDist :: Double
aDist = V2 Rational -> V2 Rational -> Double
forall a. (Real a, Fractional a) => V2 a -> V2 a -> Double
distance' (Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
target) V2 Rational
a
              frac :: Rational
frac = Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
min Rational
1 (Rational -> Rational) -> Rational -> Rational
forall a b. (a -> b) -> a -> b
$ Double -> Rational
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> Rational) -> Double -> Rational
forall a b. (a -> b) -> a -> b
$ (Double
targetLength Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
targetDist) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
aDist
          in Rational -> V2 Rational -> V2 Rational -> V2 Rational
forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp Rational
frac V2 Rational
a (Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
target)
        worker :: Int -> [V2 Rational]
worker Int
0 = [Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
0]
        worker Int
a =
          let b :: Int
b = Polygon -> Int -> Int
forall a. APolygon a -> Int -> Int
pNext Polygon
p Int
a in
          if Int -> Bool
nodeVisible Int
a Bool -> Bool -> Bool
&& Int -> Bool
nodeVisible Int
b
            then [Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
a, Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
b]
            else
              Int -> Int -> V2 Rational -> V2 Rational -> [Int] -> [V2 Rational]
forall t t.
t -> t -> V2 Rational -> V2 Rational -> [Int] -> [V2 Rational]
chunkRight Int
a Int
b (Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
a) (Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
b) (([Int], [Int]) -> [Int]
forall a b. (a, b) -> a
fst (([Int], [Int]) -> [Int]) -> ([Int], [Int]) -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> ([Int], [Int])
getFunnel Int
a Int
b) [V2 Rational] -> [V2 Rational] -> [V2 Rational]
forall a. [a] -> [a] -> [a]
++
              Int -> Int -> [V2 Rational]
chunkCenter Int
a Int
b [V2 Rational] -> [V2 Rational] -> [V2 Rational]
forall a. [a] -> [a] -> [a]
++
              Int -> Int -> V2 Rational -> V2 Rational -> [Int] -> [V2 Rational]
forall t t.
t -> t -> V2 Rational -> V2 Rational -> [Int] -> [V2 Rational]
chunkLeft Int
a Int
b (Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
a) (Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
b) (([Int], [Int]) -> [Int]
forall a b. (a, b) -> b
snd (([Int], [Int]) -> [Int]) -> ([Int], [Int]) -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> ([Int], [Int])
getFunnel Int
a Int
b)
        chunkRight :: t -> t -> V2 Rational -> V2 Rational -> [Int] -> [V2 Rational]
chunkRight t
ai t
bi V2 Rational
a V2 Rational
b (Int
x:Int
y:[Int]
xs) =
          case (V2 Rational, V2 Rational)
-> (V2 Rational, V2 Rational) -> Maybe (V2 Rational)
forall a.
(Fractional a, Ord a) =>
(V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a)
rayIntersect (V2 Rational
a,V2 Rational
b) (Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
x,Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
y) of
            Just V2 Rational
u ->
              if Int -> Bool
nodeVisible Int
x
                then
                    (V2 Rational -> V2 Rational) -> [V2 Rational] -> [V2 Rational]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> V2 Rational -> V2 Rational
moveCloser Int
x) (V2 Rational -> V2 Rational -> [V2 Rational]
forall a (f :: * -> *).
(Enum a, Additive f, Fractional a) =>
f a -> f a -> [f a]
split V2 Rational
a V2 Rational
u) [V2 Rational] -> [V2 Rational] -> [V2 Rational]
forall a. [a] -> [a] -> [a]
++
                    t -> t -> V2 Rational -> V2 Rational -> [Int] -> [V2 Rational]
chunkRight t
ai t
bi V2 Rational
u V2 Rational
b (Int
yInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
xs)
                else t -> t -> V2 Rational -> V2 Rational -> [Int] -> [V2 Rational]
chunkRight t
ai t
bi V2 Rational
u V2 Rational
b (Int
yInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
xs)
            Maybe (V2 Rational)
_ -> -- error $ "chunkRight: urk: " ++ show (ai,bi,x,y)
              if Int -> Bool
nodeVisible Int
x
                then (V2 Rational -> V2 Rational) -> [V2 Rational] -> [V2 Rational]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> V2 Rational -> V2 Rational
moveCloser Int
x) [V2 Rational
a]
                else []
        chunkRight t
_ai t
_bi V2 Rational
_a V2 Rational
_b [Int]
_ = []
        chunkLeft :: t -> t -> V2 Rational -> V2 Rational -> [Int] -> [V2 Rational]
chunkLeft t
ai t
bi V2 Rational
a V2 Rational
b (Int
x:Int
y:[Int]
xs) =
          case (V2 Rational, V2 Rational)
-> (V2 Rational, V2 Rational) -> Maybe (V2 Rational)
forall a.
(Fractional a, Ord a) =>
(V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a)
rayIntersect (V2 Rational
a,V2 Rational
b) (Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
x,Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
y) of
            Just V2 Rational
u ->
              if Int -> Bool
nodeVisible Int
x
                then
                    t -> t -> V2 Rational -> V2 Rational -> [Int] -> [V2 Rational]
chunkLeft t
ai t
bi V2 Rational
a V2 Rational
u (Int
yInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
xs) [V2 Rational] -> [V2 Rational] -> [V2 Rational]
forall a. [a] -> [a] -> [a]
++
                    (V2 Rational -> V2 Rational) -> [V2 Rational] -> [V2 Rational]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> V2 Rational -> V2 Rational
moveCloser Int
x) (V2 Rational -> V2 Rational -> [V2 Rational]
forall a (f :: * -> *).
(Enum a, Additive f, Fractional a) =>
f a -> f a -> [f a]
split V2 Rational
u V2 Rational
b)
                else t -> t -> V2 Rational -> V2 Rational -> [Int] -> [V2 Rational]
chunkLeft t
ai t
bi V2 Rational
a V2 Rational
u (Int
yInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
xs)
            Maybe (V2 Rational)
_ -> -- error $ "chunkLeft: urk: " ++ show (ai,bi, x,y)
              if Int -> Bool
nodeVisible Int
x
                then (V2 Rational -> V2 Rational) -> [V2 Rational] -> [V2 Rational]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> V2 Rational -> V2 Rational
moveCloser Int
x) [V2 Rational
b]
                else []
        chunkLeft t
_ai t
_bi V2 Rational
_a V2 Rational
_b [Int]
_ = []
        chunkCenter :: Int -> Int -> [V2 Rational]
chunkCenter Int
a Int
b =
          let ([Int]
aF, [Int]
bF) = Int -> Int -> ([Int], [Int])
getFunnel Int
a Int
b
              aP :: V2 Rational
aP = Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
a
              bP :: V2 Rational
bP = Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
b in
          case ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
aF, [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
bF) of
            ([Int
x], [Int
_]) | Int -> Bool
nodeVisible Int
x ->
                (V2 Rational -> V2 Rational) -> [V2 Rational] -> [V2 Rational]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> V2 Rational -> V2 Rational
moveCloser Int
x) (V2 Rational -> V2 Rational -> [V2 Rational]
forall a (f :: * -> *).
(Enum a, Additive f, Fractional a) =>
f a -> f a -> [f a]
split V2 Rational
aP V2 Rational
bP)
            ([Int
x], Int
_:Int
left:[Int]
_) | Int -> Bool
nodeVisible Int
x ->
              case (V2 Rational, V2 Rational)
-> (V2 Rational, V2 Rational) -> Maybe (V2 Rational)
forall a.
(Fractional a, Ord a) =>
(V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a)
rayIntersect (V2 Rational
aP,V2 Rational
bP) (Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
x,Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
left) of
                Just V2 Rational
v  ->
                  (V2 Rational -> V2 Rational) -> [V2 Rational] -> [V2 Rational]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> V2 Rational -> V2 Rational
moveCloser Int
x) (V2 Rational -> V2 Rational -> [V2 Rational]
forall a (f :: * -> *).
(Enum a, Additive f, Fractional a) =>
f a -> f a -> [f a]
split V2 Rational
aP V2 Rational
v)
                Maybe (V2 Rational)
Nothing -> (V2 Rational -> V2 Rational) -> [V2 Rational] -> [V2 Rational]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> V2 Rational -> V2 Rational
moveCloser Int
x) [V2 Rational
aP,V2 Rational
bP]
            (Int
x:Int
right:[Int]
_, [Int
_]) | Int -> Bool
nodeVisible Int
x ->
              case (V2 Rational, V2 Rational)
-> (V2 Rational, V2 Rational) -> Maybe (V2 Rational)
forall a.
(Fractional a, Ord a) =>
(V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a)
rayIntersect (V2 Rational
aP,V2 Rational
bP) (Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
x,Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
right) of
                Just V2 Rational
u  -> (V2 Rational -> V2 Rational) -> [V2 Rational] -> [V2 Rational]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> V2 Rational -> V2 Rational
moveCloser Int
x) (V2 Rational -> V2 Rational -> [V2 Rational]
forall a (f :: * -> *).
(Enum a, Additive f, Fractional a) =>
f a -> f a -> [f a]
split V2 Rational
u V2 Rational
bP)
                Maybe (V2 Rational)
Nothing -> (V2 Rational -> V2 Rational) -> [V2 Rational] -> [V2 Rational]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> V2 Rational -> V2 Rational
moveCloser Int
x) [V2 Rational
aP,V2 Rational
bP] -- error $ "urk: " ++ show (a,b, right)
            (Int
x:Int
right:[Int]
_, Int
_:Int
left:[Int]
_) | Int -> Bool
nodeVisible Int
x ->
              case (V2 Rational, V2 Rational)
-> (V2 Rational, V2 Rational) -> Maybe (V2 Rational)
forall a.
(Fractional a, Ord a) =>
(V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a)
rayIntersect (V2 Rational
aP,V2 Rational
bP) (Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
x,Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
right) of
                Just V2 Rational
u ->
                  case (V2 Rational, V2 Rational)
-> (V2 Rational, V2 Rational) -> Maybe (V2 Rational)
forall a.
(Fractional a, Ord a) =>
(V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a)
rayIntersect (V2 Rational
aP,V2 Rational
bP) (Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
x,Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
left) of
                    Just V2 Rational
v  -> (V2 Rational -> V2 Rational) -> [V2 Rational] -> [V2 Rational]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> V2 Rational -> V2 Rational
moveCloser Int
x) (V2 Rational -> V2 Rational -> [V2 Rational]
forall a (f :: * -> *).
(Enum a, Additive f, Fractional a) =>
f a -> f a -> [f a]
split V2 Rational
u V2 Rational
v)
                    Maybe (V2 Rational)
Nothing -> (V2 Rational -> V2 Rational) -> [V2 Rational] -> [V2 Rational]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> V2 Rational -> V2 Rational
moveCloser Int
x) [V2 Rational
aP,V2 Rational
bP]
                Maybe (V2 Rational)
Nothing -> (V2 Rational -> V2 Rational) -> [V2 Rational] -> [V2 Rational]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> V2 Rational -> V2 Rational
moveCloser Int
x) [V2 Rational
aP,V2 Rational
bP]
            ([Int], [Int])
_ -> []
    in Vector (V2 Rational) -> Polygon
forall a. PolyCtx a => Vector (V2 a) -> APolygon a
mkPolygon (Vector (V2 Rational) -> Polygon)
-> Vector (V2 Rational) -> Polygon
forall a b. (a -> b) -> a -> b
$ [V2 Rational] -> Vector (V2 Rational)
forall a. [a] -> Vector a
V.fromList ([V2 Rational] -> Vector (V2 Rational))
-> [V2 Rational] -> Vector (V2 Rational)
forall a b. (a -> b) -> a -> b
$ [V2 Rational] -> [V2 Rational]
forall a. Eq a => [a] -> [a]
clearDups ([V2 Rational] -> [V2 Rational]) -> [V2 Rational] -> [V2 Rational]
forall a b. (a -> b) -> a -> b
$
        (Int -> [V2 Rational]) -> [Int] -> [V2 Rational]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Int -> [V2 Rational]
worker [Int
0..Polygon -> Int
forall a. APolygon a -> Int
pSize Polygon
pInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
  where
    clearDups :: [a] -> [a]
clearDups (a
x:a
y:[a]
xs)
      | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y = [a] -> [a]
clearDups (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)
    clearDups (a
x:[a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
clearDups [a]
xs
    clearDups [] = []

    getParents :: Int -> [Int]
getParents Int
0 = []
    getParents Int
x =
      let parent :: Int
parent = Polygon -> Int -> Int -> Int
forall a. APolygon a -> Int -> Int -> Int
pParent Polygon
p Int
0 Int
x
      in Int
parent Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int -> [Int]
getParents Int
parent
    getFunnel :: Int -> Int -> ([Int], [Int])
getFunnel Int
a Int
b =
      let aP :: [Int]
aP = Int -> [Int]
getParents Int
a
          bP :: [Int]
bP = Int -> [Int]
getParents Int
b in
      ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
takeUntil (Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
bP) [Int]
aP
      ,(Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
takeUntil (Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
aP) [Int]
bP)
    split :: f a -> f a -> [f a]
split f a
aP f a
bP =
      let steps :: a
steps = a
50 in
      [ a -> f a -> f a -> f a
forall (f :: * -> *) a.
(Additive f, Num a) =>
a -> f a -> f a -> f a
lerp (a
ta -> a -> a
forall a. Fractional a => a -> a -> a
/a
steps) f a
bP f a
aP
      | a
t <- [a
0 .. a
steps]
      ]
    d :: Double
d = Vector Double -> Double
forall a. Ord a => Vector a -> a
V.maximum Vector Double
ds
    ds :: Vector Double
ds = Polygon -> Vector Double
ssspDistances Polygon
p

takeUntil :: (a -> Bool) -> [a] -> [a]
takeUntil :: (a -> Bool) -> [a] -> [a]
takeUntil a -> Bool
_fn [] = []
takeUntil a -> Bool
fn (a
x:[a]
xs)
  | a -> Bool
fn a
x = [a
x]
  | Bool
otherwise = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
takeUntil a -> Bool
fn [a]
xs

diameter :: Polygon -> Double
diameter :: Polygon -> Double
diameter Polygon
p = Vector Double -> Double
forall a. Ord a => Vector a -> a
V.maximum (Polygon -> Vector Double
ssspDistances Polygon
p)

shiftLongestDiameter :: Polygon -> Polygon
shiftLongestDiameter :: Polygon -> Polygon
shiftLongestDiameter Polygon
p = Double -> Polygon -> [Polygon] -> Polygon
findBest Double
0 Polygon
p (Polygon -> [Polygon]
forall a. APolygon a -> [APolygon a]
pCycles Polygon
p)
  where
    margin :: Double
margin = Double
0.01
    findBest :: Double -> Polygon -> [Polygon] -> Polygon
findBest Double
_score Polygon
elt [] = Polygon
elt
    findBest Double
score Polygon
elt (Polygon
x:[Polygon]
xs) =
      let newScore :: Double
newScore = Polygon -> Double
diameter Polygon
x in
      if
        | Double
newScoreDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
score Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
score Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
margin    -> Double -> Polygon -> [Polygon] -> Polygon
findBest Double
newScore Polygon
x [Polygon]
xs
        | Double
scoreDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
newScore Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
newScore Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
margin -> Double -> Polygon -> [Polygon] -> Polygon
findBest Double
score Polygon
elt [Polygon]
xs
        | Polygon -> Polygon -> Bool
forall a. (Num a, Ord a) => APolygon a -> APolygon a -> Bool
isTopLeft Polygon
x Polygon
elt                    -> Double -> Polygon -> [Polygon] -> Polygon
findBest Double
newScore Polygon
x [Polygon]
xs
        | Bool
otherwise                          -> Double -> Polygon -> [Polygon] -> Polygon
findBest Double
score Polygon
elt [Polygon]
xs
    isTopLeft :: APolygon a -> APolygon a -> Bool
isTopLeft APolygon a
a APolygon a
b =
      case APolygon a -> Int -> V2 a
forall a. APolygon a -> Int -> V2 a
pAccess APolygon a
a Int
0V2 a -> V2 a -> V2 a
forall a. Num a => a -> a -> a
-APolygon a -> Int -> V2 a
forall a. APolygon a -> Int -> V2 a
pAccess APolygon a
b Int
0 of
        V2 a
x a
y -> a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
x

-- Shortest distances from point 0 to all other points.
ssspDistances :: Polygon -> V.Vector Double
ssspDistances :: Polygon -> Vector Double
ssspDistances Polygon
p = Vector Double
arr
  where
    arr :: Vector Double
arr = Int -> (Int -> Double) -> Vector Double
forall a. Int -> (Int -> a) -> Vector a
V.generate (Polygon -> Int
forall a. APolygon a -> Int
pSize Polygon
p) ((Int -> Double) -> Vector Double)
-> (Int -> Double) -> Vector Double
forall a b. (a -> b) -> a -> b
$ \Int
i ->
      case Int
i of
        Int
0 -> Double
0
        Int
_ ->
          let parent :: Int
parent = Polygon -> Int -> Int -> Int
forall a. APolygon a -> Int -> Int -> Int
pParent Polygon
p Int
0 Int
i in
          Vector Double
arr Vector Double -> Int -> Double
forall a. Vector a -> Int -> a
V.! Int
parent Double -> Double -> Double
forall a. Num a => a -> a -> a
+ V2 Rational -> V2 Rational -> Double
forall a. (Real a, Fractional a) => V2 a -> V2 a -> Double
distance' (Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
i) (Polygon -> Int -> V2 Rational
forall a. APolygon a -> Int -> V2 a
pAccess Polygon
p Int
parent)