{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards       #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
module Reanimate.Math.SSSP
  ( -- * Single-Source-Shortest-Path
    SSSP
  , sssp                -- :: (Fractional a, Ord a) => Ring a -> Dual -> SSSP
  , ssspFinger
  , dual                -- :: Int -> Triangulation -> Dual
  , Dual(..)
  , DualTree(..)
    -- * Misc
  , dualToTriangulation -- :: Ring Rational -> Dual -> Triangulation
  , visibilityArray     -- :: Ring Rational -> V.Vector [Int]
  , naive               -- :: Ring Rational -> SSSP
  , naive2              -- :: Ring Rational -> SSSP
  , drawDual            -- :: Dual -> String
  ) where

import           Control.Monad
import           Control.Monad.ST
import qualified Data.FingerTree            as F
import           Data.Foldable
import           Data.List
import qualified Data.Map                   as Map
import           Data.Maybe
import           Data.STRef
import           Data.Tree
import qualified Data.Vector                as V
import qualified Data.Vector.Mutable        as MV
import           Reanimate.Math.Common
import           Reanimate.Math.Triangulate

-- import           Debug.Trace

type SSSP = V.Vector Int


-- ssspParent :: Polygon -> SSSP -> Int -> Int
-- ssspParent p sTree x =
--     (sTree V.! ((x - polygonOffset p) `mod` n) + polygonOffset p) `mod` n
--   where
--     n = polygonSize p

visibilityArray :: Ring Rational -> V.Vector [Int]
visibilityArray :: Ring Rational -> Vector [Int]
visibilityArray Ring Rational
p = Vector [Int]
arr
  where
    n :: Int
n = Ring Rational -> Int
forall a. Ring a -> Int
ringSize Ring Rational
p
    arr :: Vector [Int]
arr = [[Int]] -> Vector [Int]
forall a. [a] -> Vector a
V.fromList
        [ Int -> [Int]
visibility Int
y
        | Int
y <- [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
        ]
    visibility :: Int -> [Int]
visibility Int
y =
      [ Int
i
      | Int
i <- [Int
0..Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
      , Int
y Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Vector [Int]
arr Vector [Int] -> Int -> [Int]
forall a. Vector a -> Int -> a
V.! Int
i ] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++
      [ Int
i
      | Int
i <- [Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 .. Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
      , let pI :: V2 Rational
pI = Ring Rational -> Int -> V2 Rational
forall a. Ring a -> Int -> V2 a
ringAccess Ring Rational
p Int
i
            isOpen :: Bool
isOpen = V2 Rational -> V2 Rational -> V2 Rational -> Bool
forall a.
(Fractional a, Ord a, Epsilon a) =>
V2 a -> V2 a -> V2 a -> Bool
isRightTurn V2 Rational
pYp V2 Rational
pY V2 Rational
pYn
      , Ring Rational -> Int -> Int
forall a. Ring a -> Int -> Int
ringClamp Ring Rational
p (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i Bool -> Bool -> Bool
|| Ring Rational -> Int -> Int
forall a. Ring a -> Int -> Int
ringClamp Ring Rational
p (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i Bool -> Bool -> Bool
|| if Bool
isOpen
        then V2 Rational -> V2 Rational -> V2 Rational -> Bool
forall a.
(Fractional a, Ord a, Epsilon a) =>
V2 a -> V2 a -> V2 a -> Bool
isLeftTurnOrLinear V2 Rational
pY V2 Rational
pYn V2 Rational
pI Bool -> Bool -> Bool
||
             V2 Rational -> V2 Rational -> V2 Rational -> Bool
forall a.
(Fractional a, Ord a, Epsilon a) =>
V2 a -> V2 a -> V2 a -> Bool
isLeftTurnOrLinear V2 Rational
pYp V2 Rational
pY V2 Rational
pI
        else Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ V2 Rational -> V2 Rational -> V2 Rational -> Bool
forall a.
(Fractional a, Ord a, Epsilon a) =>
V2 a -> V2 a -> V2 a -> Bool
isRightTurn V2 Rational
pY V2 Rational
pYn V2 Rational
pI Bool -> Bool -> Bool
||
                   V2 Rational -> V2 Rational -> V2 Rational -> Bool
forall a.
(Fractional a, Ord a, Epsilon a) =>
V2 a -> V2 a -> V2 a -> Bool
isRightTurn V2 Rational
pYp V2 Rational
pY V2 Rational
pI
      , let myEdges :: [(Int, Int)]
myEdges = [(Int
e1,Int
e2) | (Int
e1,Int
e2) <- [(Int, Int)]
edges, Int
e1Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=Int
y, Int
e1Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=Int
i, Int
e2Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=Int
y,Int
e2Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/=Int
i]
      , ((V2 Rational, V2 Rational) -> Bool)
-> [(V2 Rational, V2 Rational)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe (V2 Rational) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (V2 Rational) -> Bool)
-> ((V2 Rational, V2 Rational) -> Maybe (V2 Rational))
-> (V2 Rational, V2 Rational)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V2 Rational, V2 Rational)
-> (V2 Rational, V2 Rational) -> Maybe (V2 Rational)
forall a.
(Ord a, Fractional a) =>
(V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a)
lineIntersect (V2 Rational
pY,V2 Rational
pI))
              [ (Ring Rational -> Int -> V2 Rational
forall a. Ring a -> Int -> V2 a
ringAccess Ring Rational
p Int
e1, Ring Rational -> Int -> V2 Rational
forall a. Ring a -> Int -> V2 a
ringAccess Ring Rational
p Int
e2) | (Int
e1,Int
e2) <- [(Int, Int)]
myEdges ]]
      where
        pY :: V2 Rational
pY = Ring Rational -> Int -> V2 Rational
forall a. Ring a -> Int -> V2 a
ringAccess Ring Rational
p Int
y
        pYn :: V2 Rational
pYn = Ring Rational -> Int -> V2 Rational
forall a. Ring a -> Int -> V2 a
ringAccess Ring Rational
p (Int -> V2 Rational) -> Int -> V2 Rational
forall a b. (a -> b) -> a -> b
$ Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
        pYp :: V2 Rational
pYp = Ring Rational -> Int -> V2 Rational
forall a. Ring a -> Int -> V2 a
ringAccess Ring Rational
p (Int -> V2 Rational) -> Int -> V2 Rational
forall a b. (a -> b) -> a -> b
$ Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1
        edges :: [(Int, Int)]
edges = [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ([Int] -> [Int]
forall a. [a] -> [a]
tail [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
0])



-- Iterative Single Source Shortest Path solver. Quite slow.
naive :: Ring Rational -> SSSP
naive :: Ring Rational -> SSSP
naive Ring Rational
p =
    [Int] -> SSSP
forall a. [a] -> Vector a
V.fromList ([Int] -> SSSP) -> [Int] -> SSSP
forall a b. (a -> b) -> a -> b
$ Map Int Int -> [Int]
forall k a. Map k a -> [a]
Map.elems (Map Int Int -> [Int]) -> Map Int Int -> [Int]
forall a b. (a -> b) -> a -> b
$
    ((Rational, Int) -> Int) -> Map Int (Rational, Int) -> Map Int Int
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Rational, Int) -> Int
forall a b. (a, b) -> b
snd (Map Int (Rational, Int) -> Map Int Int)
-> Map Int (Rational, Int) -> Map Int Int
forall a b. (a -> b) -> a -> b
$
    Map Int (Rational, Int) -> Map Int (Rational, Int)
worker Map Int (Rational, Int)
initial
  where
    initial :: Map Int (Rational, Int)
initial = Int -> (Rational, Int) -> Map Int (Rational, Int)
forall k a. k -> a -> Map k a
Map.singleton Int
0 (Rational
0,Int
0)
    visibility :: Vector [Int]
visibility = Ring Rational -> Vector [Int]
visibilityArray Ring Rational
p
    worker :: Map.Map Int (Rational, Int) -> Map.Map Int (Rational, Int)
    worker :: Map Int (Rational, Int) -> Map Int (Rational, Int)
worker Map Int (Rational, Int)
m
        | Map Int (Rational, Int)
mMap Int (Rational, Int) -> Map Int (Rational, Int) -> Bool
forall a. Eq a => a -> a -> Bool
==Map Int (Rational, Int)
newM   = Map Int (Rational, Int)
newM
        | Bool
otherwise = Map Int (Rational, Int) -> Map Int (Rational, Int)
worker Map Int (Rational, Int)
newM
      where
        ms' :: [Map Int (Rational, Int)]
ms' = [ [(Int, (Rational, Int))] -> Map Int (Rational, Int)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                    [ case Int -> Map Int (Rational, Int) -> Maybe (Rational, Int)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
v Map Int (Rational, Int)
m of
                        Maybe (Rational, Int)
Nothing -> (Int
v, (Rational
distThroughI, Int
i))
                        Just (Rational
otherDist,Int
parent)
                          | Rational
otherDist Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
distThroughI -> (Int
v, (Rational
distThroughI, Int
i))
                          | Bool
otherwise -> (Int
v, (Rational
otherDist, Int
parent))
                    | Int
v <- Vector [Int]
visibility Vector [Int] -> Int -> [Int]
forall a. Vector a -> Int -> a
V.! Int
i
                    , let distThroughI :: Rational
distThroughI = Rational
dist Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ V2 Rational -> V2 Rational -> Rational
forall a. (Real a, Fractional a) => V2 a -> V2 a -> a
approxDist (Ring Rational -> Int -> V2 Rational
forall a. Ring a -> Int -> V2 a
ringAccess Ring Rational
p Int
i) (Ring Rational -> Int -> V2 Rational
forall a. Ring a -> Int -> V2 a
ringAccess Ring Rational
p Int
v) ]
              | (Int
i,(Rational
dist,Int
_)) <- Map Int (Rational, Int) -> [(Int, (Rational, Int))]
forall k a. Map k a -> [(k, a)]
Map.toList Map Int (Rational, Int)
m
              ]
        newM :: Map Int (Rational, Int)
newM = ((Rational, Int) -> (Rational, Int) -> (Rational, Int))
-> [Map Int (Rational, Int)] -> Map Int (Rational, Int)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith (Rational, Int) -> (Rational, Int) -> (Rational, Int)
forall a b. Ord a => (a, b) -> (a, b) -> (a, b)
g (Map Int (Rational, Int)
mMap Int (Rational, Int)
-> [Map Int (Rational, Int)] -> [Map Int (Rational, Int)]
forall a. a -> [a] -> [a]
:[Map Int (Rational, Int)]
ms') :: Map.Map Int (Rational,Int)
    g :: (a, b) -> (a, b) -> (a, b)
g (a, b)
a (a, b)
b = if (a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< (a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
b then (a, b)
a else (a, b)
b

naive2 :: Ring Rational -> SSSP
naive2 :: Ring Rational -> SSSP
naive2 Ring Rational
p = (forall s. ST s SSSP) -> SSSP
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s SSSP) -> SSSP) -> (forall s. ST s SSSP) -> SSSP
forall a b. (a -> b) -> a -> b
$ do
    MVector s Int
parents <- Int -> Int -> ST s (MVector (PrimState (ST s)) Int)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MVector (PrimState m) a)
MV.replicate (Ring Rational -> Int
forall a. Ring a -> Int
ringSize Ring Rational
p) (-Int
1)
    MVector s Rational
costs <- Int -> Rational -> ST s (MVector (PrimState (ST s)) Rational)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MVector (PrimState m) a)
MV.replicate (Ring Rational -> Int
forall a. Ring a -> Int
ringSize Ring Rational
p) (-Rational
1)
    MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.write MVector s Int
MVector (PrimState (ST s)) Int
parents Int
0 Int
0
    MVector (PrimState (ST s)) Rational -> Int -> Rational -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.write MVector s Rational
MVector (PrimState (ST s)) Rational
costs Int
0 Rational
0
    STRef s Bool
changedRef <- Bool -> ST s (STRef s Bool)
forall a s. a -> ST s (STRef s a)
newSTRef Bool
False
    let loop :: Int -> ST s ()
loop Int
i
          | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Ring Rational -> Int
forall a. Ring a -> Int
ringSize Ring Rational
p = do
            Bool
changed <- STRef s Bool -> ST s Bool
forall s a. STRef s a -> ST s a
readSTRef STRef s Bool
changedRef
            Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
changed (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
              STRef s Bool -> Bool -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Bool
changedRef Bool
False
              Int -> ST s ()
loop Int
0
          | Bool
otherwise = do
            Rational
myCost <- MVector (PrimState (ST s)) Rational -> Int -> ST s Rational
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MV.read MVector s Rational
MVector (PrimState (ST s)) Rational
costs Int
i
            Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Rational
myCost Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
              [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Vector [Int]
visibility Vector [Int] -> Int -> [Int]
forall a. Vector a -> Int -> a
V.! Int
i) ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
                -- n is visible from i.
                Rational
theirCost <- MVector (PrimState (ST s)) Rational -> Int -> ST s Rational
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> m a
MV.read MVector s Rational
MVector (PrimState (ST s)) Rational
costs Int
n
                let throughCost :: Rational
throughCost = Rational
myCost Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ V2 Rational -> V2 Rational -> Rational
forall a. (Real a, Fractional a) => V2 a -> V2 a -> a
approxDist (Ring Rational -> Int -> V2 Rational
forall a. Ring a -> Int -> V2 a
ringAccess Ring Rational
p Int
i) (Ring Rational -> Int -> V2 Rational
forall a. Ring a -> Int -> V2 a
ringAccess Ring Rational
p Int
n)
                Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Rational
throughCost Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
theirCost Bool -> Bool -> Bool
|| Rational
theirCost Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
                    MVector (PrimState (ST s)) Int -> Int -> Int -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.write MVector s Int
MVector (PrimState (ST s)) Int
parents Int
n Int
i
                    MVector (PrimState (ST s)) Rational -> Int -> Rational -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.write MVector s Rational
MVector (PrimState (ST s)) Rational
costs Int
n Rational
throughCost
                    STRef s Bool -> Bool -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Bool
changedRef Bool
True
            Int -> ST s ()
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    Int -> ST s ()
loop Int
0
    MVector (PrimState (ST s)) Int -> ST s SSSP
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> m (Vector a)
V.unsafeFreeze MVector s Int
MVector (PrimState (ST s)) Int
parents
  where
    visibility :: Vector [Int]
visibility = Ring Rational -> Vector [Int]
visibilityArray Ring Rational
p

-- Dual of triangulated polygon
data Dual = Dual (Int,Int,Int) -- (a,b,c)
                  DualTree -- borders ca
                  DualTree -- borders bc
  deriving (Int -> Dual -> ShowS
[Dual] -> ShowS
Dual -> String
(Int -> Dual -> ShowS)
-> (Dual -> String) -> ([Dual] -> ShowS) -> Show Dual
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Dual] -> ShowS
$cshowList :: [Dual] -> ShowS
show :: Dual -> String
$cshow :: Dual -> String
showsPrec :: Int -> Dual -> ShowS
$cshowsPrec :: Int -> Dual -> ShowS
Show)

data DualTree
  = EmptyDual
  | NodeDual Int -- axb triangle, a and b are from parent.
      DualTree -- borders xb
      DualTree -- borders ax
  deriving (Int -> DualTree -> ShowS
[DualTree] -> ShowS
DualTree -> String
(Int -> DualTree -> ShowS)
-> (DualTree -> String) -> ([DualTree] -> ShowS) -> Show DualTree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DualTree] -> ShowS
$cshowList :: [DualTree] -> ShowS
show :: DualTree -> String
$cshow :: DualTree -> String
showsPrec :: Int -> DualTree -> ShowS
$cshowsPrec :: Int -> DualTree -> ShowS
Show)

drawDual :: Dual -> String
drawDual :: Dual -> String
drawDual Dual
d = Tree String -> String
drawTree (Tree String -> String) -> Tree String -> String
forall a b. (a -> b) -> a -> b
$
  case Dual
d of
    Dual (Int
a,Int
b,Int
c) DualTree
l DualTree
r -> String -> Forest String -> Tree String
forall a. a -> Forest a -> Tree a
Node ((Int, Int, Int) -> String
forall a. Show a => a -> String
show (Int
a,Int
b,Int
c)) [Int -> Int -> DualTree -> Tree String
worker Int
c Int
a DualTree
l, Int -> Int -> DualTree -> Tree String
worker Int
b Int
c DualTree
r]
  where
    worker :: Int -> Int -> DualTree -> Tree String
worker Int
_a Int
_b DualTree
EmptyDual = String -> Forest String -> Tree String
forall a. a -> Forest a -> Tree a
Node String
"Leaf" []
    worker Int
a Int
b (NodeDual Int
x DualTree
l DualTree
r) =
      String -> Forest String -> Tree String
forall a. a -> Forest a -> Tree a
Node ((Int, Int, Int) -> String
forall a. Show a => a -> String
show (Int
b,Int
a,Int
x)) [Int -> Int -> DualTree -> Tree String
worker Int
x Int
b DualTree
l, Int -> Int -> DualTree -> Tree String
worker Int
a Int
x DualTree
r]

dualToTriangulation :: Ring Rational -> Dual -> Triangulation
dualToTriangulation :: Ring Rational -> Dual -> Vector [Int]
dualToTriangulation Ring Rational
p Dual
d = Int -> [(Int, Int)] -> Vector [Int]
edgesToTriangulation (Ring Rational -> Int
forall a. Ring a -> Int
ringSize Ring Rational
p) ([(Int, Int)] -> Vector [Int]) -> [(Int, Int)] -> Vector [Int]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Bool) -> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int, Int) -> Bool
goodEdge ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$
    case Dual
d of
      Dual (Int
a,Int
b,Int
c) DualTree
l DualTree
r ->
        (Int
a,Int
b)(Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:(Int
a,Int
c)(Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:(Int
b,Int
c)(Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:Int -> Int -> DualTree -> [(Int, Int)]
worker Int
c Int
a DualTree
l [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++ Int -> Int -> DualTree -> [(Int, Int)]
worker Int
b Int
c DualTree
r
  where
    goodEdge :: (Int, Int) -> Bool
goodEdge (Int
a,Int
b)
      = Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Ring Rational -> Int -> Int
forall a. Ring a -> Int -> Int
ringClamp Ring Rational
p (Int
bInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Bool -> Bool -> Bool
&& Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Ring Rational -> Int -> Int
forall a. Ring a -> Int -> Int
ringClamp Ring Rational
p (Int
bInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
    worker :: Int -> Int -> DualTree -> [(Int, Int)]
worker Int
_a Int
_b DualTree
EmptyDual = []
    worker Int
a Int
b (NodeDual Int
x DualTree
l DualTree
r) =
      (Int
a,Int
x) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
: (Int
x, Int
b) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
: Int -> Int -> DualTree -> [(Int, Int)]
worker Int
x Int
b DualTree
l [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++ Int -> Int -> DualTree -> [(Int, Int)]
worker Int
a Int
x DualTree
r

-- Dual path:
-- (Int,Int,Int) + V.Vector Int + V.Vector LeftOrRight

-- simplifyDual :: DualTree -> DualTree
-- -- simplifyDual (NodeDual x EmptyDual EmptyDual) = NodeLeaf x
-- -- simplifyDual (NodeDual x l EmptyDual) = NodeDualL x l
-- -- simplifyDual (NodeDual x EmptyDual r) = NodeDualR x r
-- simplifyDual d = d

dual :: Int -> Triangulation -> Dual
dual :: Int -> Vector [Int] -> Dual
dual Int
root Vector [Int]
t =
  case [Int]
hasTriangle of
    []    -> String -> Dual
forall a. HasCallStack => String -> a
error String
"weird triangulation"
    -- [] -> Dual (0,1,V.length t-1) EmptyDual (dualTree t (1, (V.length t-1)) 0)
    (Int
x:[Int]
_) -> (Int, Int, Int) -> DualTree -> DualTree -> Dual
Dual (Int
root,Int
rootNext,Int
x) (Vector [Int] -> (Int, Int) -> Int -> DualTree
dualTree Vector [Int]
t (Int
x,Int
root) Int
rootNext) (Vector [Int] -> (Int, Int) -> Int -> DualTree
dualTree Vector [Int]
t (Int
rootNext,Int
x) Int
root)
  where
    rootNext :: Int
rootNext = Int -> Int
idx (Int
rootInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    rootPrev :: Int
rootPrev = Int -> Int
idx (Int
rootInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
    rootNNext :: Int
rootNNext = Int -> Int
idx (Int
rootInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)
    idx :: Int -> Int
idx Int
i = Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n
    hasTriangle :: [Int]
hasTriangle = (Int
rootPrev Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Vector [Int]
t Vector [Int] -> Int -> [Int]
forall a. Vector a -> Int -> a
V.! Int
root) [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` (Int
rootNNext Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Vector [Int]
t Vector [Int] -> Int -> [Int]
forall a. Vector a -> Int -> a
V.! Int
rootNext)
    n :: Int
n = Vector [Int] -> Int
forall a. Vector a -> Int
V.length Vector [Int]
t

-- a=6, b=0, e=1
dualTree :: Triangulation -> (Int,Int) -> Int -> DualTree
dualTree :: Vector [Int] -> (Int, Int) -> Int -> DualTree
dualTree Vector [Int]
t (Int
a,Int
b) Int
e = -- simplifyDual $
    case [Int]
hasTriangle of
      [] -> DualTree
EmptyDual
      [Int
ab] ->
        Int -> DualTree -> DualTree -> DualTree
NodeDual Int
ab
          (Vector [Int] -> (Int, Int) -> Int -> DualTree
dualTree Vector [Int]
t (Int
ab,Int
b) Int
a)
          (Vector [Int] -> (Int, Int) -> Int -> DualTree
dualTree Vector [Int]
t (Int
a,Int
ab) Int
b)
      [Int]
_ -> String -> DualTree
forall a. HasCallStack => String -> a
error (String -> DualTree) -> String -> DualTree
forall a b. (a -> b) -> a -> b
$ String
"Invalid triangulation: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Int, Int, Int, [Int]) -> String
forall a. Show a => a -> String
show (Int
a,Int
b,Int
e,[Int]
hasTriangle)
  where
    hasTriangle :: [Int]
hasTriangle = (Int -> Int
prev Int
a Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int -> Int
next Int
a Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Vector [Int]
t Vector [Int] -> Int -> [Int]
forall a. Vector a -> Int -> a
V.! Int
a) [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` (Int -> Int
prev Int
b Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Int -> Int
next Int
b Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Vector [Int]
t Vector [Int] -> Int -> [Int]
forall a. Vector a -> Int -> a
V.! Int
b)
      [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Int
e]
    n :: Int
n = Vector [Int] -> Int
forall a. Vector a -> Int
V.length Vector [Int]
t
    next :: Int -> Int
next Int
x = (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n
    prev :: Int -> Int
prev Int
x = (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n


-- dualRoot :: Dual -> Int
-- dualRoot (Dual (a,_,_) _ _) = a

-- O(n*ln n), could be O(n) if I could figure out how to use fingertrees...
sssp :: (Fractional a, Ord a, Epsilon a) => Ring a -> Dual -> SSSP
sssp :: Ring a -> Dual -> SSSP
sssp Ring a
p Dual
d = [(Int, Int)] -> SSSP
forall a. [(Int, a)] -> Vector a
toSSSP ([(Int, Int)] -> SSSP) -> [(Int, Int)] -> SSSP
forall a b. (a -> b) -> a -> b
$
    case Dual
d of
      Dual (Int
a,Int
b,Int
c) DualTree
l DualTree
r ->
        (Int
a, Int
a) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:
        (Int
b, Int
a) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:
        (Int
c, Int
a) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:
        [Int] -> [Int] -> Int -> DualTree -> [(Int, Int)]
worker [Int
c] [Int
b] Int
a DualTree
r [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++
        Int -> Int -> DualTree -> [(Int, Int)]
loopLeft Int
a Int
c DualTree
l
  where
    toSSSP :: [(Int, a)] -> Vector a
toSSSP =
      [a] -> Vector a
forall a. [a] -> Vector a
V.fromList ([a] -> Vector a) -> ([(Int, a)] -> [a]) -> [(Int, a)] -> Vector a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, a) -> a) -> [(Int, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Int, a) -> a
forall a b. (a, b) -> b
snd ([(Int, a)] -> [a])
-> ([(Int, a)] -> [(Int, a)]) -> [(Int, a)] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, a) -> Int) -> [(Int, a)] -> [(Int, a)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int, a) -> Int
forall a b. (a, b) -> a
fst
    loopLeft :: Int -> Int -> DualTree -> [(Int, Int)]
loopLeft Int
a Int
outer DualTree
l =
      case DualTree
l of
        DualTree
EmptyDual -> []
        NodeDual Int
x DualTree
l' DualTree
r' ->
          (Int
x,Int
a) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:
          [Int] -> [Int] -> Int -> DualTree -> [(Int, Int)]
worker [Int
x] [Int
outer] Int
a DualTree
r' [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++
          Int -> Int -> DualTree -> [(Int, Int)]
loopLeft Int
a Int
x DualTree
l'
    searchFn :: (V2 a -> V2 a -> V2 a -> Bool)
-> Int -> Int -> [Int] -> Maybe (Int, [Int], [Int])
searchFn V2 a -> V2 a -> V2 a -> Bool
_checkStep Int
_cusp Int
_x [] = Maybe (Int, [Int], [Int])
forall a. Maybe a
Nothing
    searchFn V2 a -> V2 a -> V2 a -> Bool
checkStep Int
cusp Int
x (Int
y:[Int]
ys)
      | Bool -> Bool
not (V2 a -> V2 a -> V2 a -> Bool
checkStep (Ring a -> Int -> V2 a
forall a. Ring a -> Int -> V2 a
ringAccess Ring a
p Int
cusp) (Ring a -> Int -> V2 a
forall a. Ring a -> Int -> V2 a
ringAccess Ring a
p Int
y) (Ring a -> Int -> V2 a
forall a. Ring a -> Int -> V2 a
ringAccess Ring a
p Int
x))
        = (Int, [Int], [Int]) -> Maybe (Int, [Int], [Int])
forall a. a -> Maybe a
Just ((Int, [Int], [Int]) -> Maybe (Int, [Int], [Int]))
-> (Int, [Int], [Int]) -> Maybe (Int, [Int], [Int])
forall a b. (a -> b) -> a -> b
$ [Int] -> Int -> [Int] -> (Int, [Int], [Int])
helper [] Int
y [Int]
ys
      | Bool
otherwise = Maybe (Int, [Int], [Int])
forall a. Maybe a
Nothing
      where
        helper :: [Int] -> Int -> [Int] -> (Int, [Int], [Int])
helper [Int]
acc Int
v [] = (Int
v, [], [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
acc)
        helper [Int]
acc Int
v1 (Int
v2:[Int]
vs)
          | V2 a -> V2 a -> V2 a -> Bool
checkStep (Ring a -> Int -> V2 a
forall a. Ring a -> Int -> V2 a
ringAccess Ring a
p Int
v1) (Ring a -> Int -> V2 a
forall a. Ring a -> Int -> V2 a
ringAccess Ring a
p Int
v2) (Ring a -> Int -> V2 a
forall a. Ring a -> Int -> V2 a
ringAccess Ring a
p Int
x) =
            (Int
v1, Int
v2Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
vs, [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
acc)
          | Bool
otherwise = [Int] -> Int -> [Int] -> (Int, [Int], [Int])
helper (Int
v1Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
acc) Int
v2 [Int]
vs
    searchRight :: Int -> Int -> [Int] -> Maybe (Int, [Int], [Int])
searchRight = (V2 a -> V2 a -> V2 a -> Bool)
-> Int -> Int -> [Int] -> Maybe (Int, [Int], [Int])
searchFn V2 a -> V2 a -> V2 a -> Bool
forall a.
(Fractional a, Ord a, Epsilon a) =>
V2 a -> V2 a -> V2 a -> Bool
isLeftTurn
    searchLeft :: Int -> Int -> [Int] -> Maybe (Int, [Int], [Int])
searchLeft = (V2 a -> V2 a -> V2 a -> Bool)
-> Int -> Int -> [Int] -> Maybe (Int, [Int], [Int])
searchFn V2 a -> V2 a -> V2 a -> Bool
forall a.
(Fractional a, Ord a, Epsilon a) =>
V2 a -> V2 a -> V2 a -> Bool
isRightTurn
    -- adj x = x -- ringClamp p (x-dualRoot d)
    -- optTrace msg =
    --   if False -- dualRoot d == 1 || dualRoot d == 0
    --     then trace msg
    --     else id
    worker :: [Int] -> [Int] -> Int -> DualTree -> [(Int, Int)]
worker [Int]
_ [Int]
_ Int
_ DualTree
EmptyDual = []
    worker [Int]
f1 [Int]
f2 Int
cusp (NodeDual Int
x DualTree
l DualTree
r) =
        -- (optTrace ("Funnel: " ++ show
        --       (map adj $ toList f1
        --       ,adj cusp
        --       ,map adj $ toList f2
        --       ,adj x
        --       , dualRoot d))
        --   ) $
        case Int -> Int -> [Int] -> Maybe (Int, [Int], [Int])
searchLeft Int
cusp Int
x ([Int] -> [Int]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [Int]
f1) of
          Just (Int
v, [Int]
f1Hi, [Int]
f1Lo) ->
                -- optTrace ("  Visble from left: " ++ show (adj x,adj v)) $
                (Int
x, Int
v::Int) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:
                [Int] -> [Int] -> Int -> DualTree -> [(Int, Int)]
worker [Int]
f1Hi [Int
x] Int
v DualTree
l [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++
                [Int] -> [Int] -> Int -> DualTree -> [(Int, Int)]
worker ([Int]
f1Lo [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
v, Int
x]) [Int]
f2 Int
cusp DualTree
r
          Maybe (Int, [Int], [Int])
Nothing ->
            case Int -> Int -> [Int] -> Maybe (Int, [Int], [Int])
searchRight Int
cusp Int
x ([Int] -> [Int]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [Int]
f2) of
              Just (Int
v, [Int]
f2Hi, [Int]
f2Lo) ->
                -- optTrace ("  Visble from right: " ++ show (adj x,adj v)) $
                (Int
x, Int
v::Int) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:
                [Int] -> [Int] -> Int -> DualTree -> [(Int, Int)]
worker [Int]
f1 ([Int]
f2Lo [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
v, Int
x]) Int
cusp DualTree
l [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++
                [Int] -> [Int] -> Int -> DualTree -> [(Int, Int)]
worker [Int
x] [Int]
f2Hi Int
v DualTree
r
              Maybe (Int, [Int], [Int])
Nothing ->
                -- optTrace ("  Visble from cusp: " ++ show (adj x,adj cusp)) $
                (Int
x, Int
cusp::Int) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:
                [Int] -> [Int] -> Int -> DualTree -> [(Int, Int)]
worker [Int]
f1 [Int
x] Int
cusp DualTree
l [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++
                [Int] -> [Int] -> Int -> DualTree -> [(Int, Int)]
worker [Int
x] [Int]
f2 Int
cusp DualTree
r

data MinMax = MinMax Int Int | MinMaxEmpty deriving (Int -> MinMax -> ShowS
[MinMax] -> ShowS
MinMax -> String
(Int -> MinMax -> ShowS)
-> (MinMax -> String) -> ([MinMax] -> ShowS) -> Show MinMax
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MinMax] -> ShowS
$cshowList :: [MinMax] -> ShowS
show :: MinMax -> String
$cshow :: MinMax -> String
showsPrec :: Int -> MinMax -> ShowS
$cshowsPrec :: Int -> MinMax -> ShowS
Show)
instance Semigroup MinMax where
  MinMax
MinMaxEmpty <> :: MinMax -> MinMax -> MinMax
<> MinMax
b = MinMax
b
  MinMax
a <> MinMax
MinMaxEmpty = MinMax
a
  MinMax Int
a Int
_b <> MinMax Int
_c Int
d
    = Int -> Int -> MinMax
MinMax Int
a Int
d
instance Monoid MinMax where
  mempty :: MinMax
mempty = MinMax
MinMaxEmpty

type Chain = F.FingerTree MinMax Int
data Funnel = Funnel
  { Funnel -> Chain
funnelLeft  :: Chain
  , Funnel -> Int
funnelCusp  :: Int
  , Funnel -> Chain
funnelRight :: Chain
  }

instance F.Measured MinMax Int where
  measure :: Int -> MinMax
measure Int
i = Int -> Int -> MinMax
MinMax Int
i Int
i

splitFunnel :: (Epsilon a, Fractional a, Ord a) => Ring a -> Int -> Funnel -> (Int, Funnel, Funnel)
splitFunnel :: Ring a -> Int -> Funnel -> (Int, Funnel, Funnel)
splitFunnel Ring a
p Int
x Funnel{Int
Chain
funnelRight :: Chain
funnelCusp :: Int
funnelLeft :: Chain
funnelRight :: Funnel -> Chain
funnelCusp :: Funnel -> Int
funnelLeft :: Funnel -> Chain
..}
    | Bool
isOnLeftChain =
      case (V2 a -> V2 a -> V2 a -> Bool) -> Chain -> (Chain, Int, Chain)
doSearch V2 a -> V2 a -> V2 a -> Bool
forall a.
(Fractional a, Ord a, Epsilon a) =>
V2 a -> V2 a -> V2 a -> Bool
isRightTurn Chain
funnelLeft of
        (Chain
lower, Int
t, Chain
upper) ->
          ( Int
t
          , Chain -> Int -> Chain -> Funnel
Funnel Chain
upper Int
t (Int -> Chain
forall v a. Measured v a => a -> FingerTree v a
F.singleton Int
x)
          , Chain -> Int -> Chain -> Funnel
Funnel (Chain
lower Chain -> Int -> Chain
forall v a. Measured v a => FingerTree v a -> a -> FingerTree v a
F.|> Int
t Chain -> Int -> Chain
forall v a. Measured v a => FingerTree v a -> a -> FingerTree v a
F.|> Int
x) Int
funnelCusp Chain
funnelRight)
    | Bool
isOnRightChain =
      case (V2 a -> V2 a -> V2 a -> Bool) -> Chain -> (Chain, Int, Chain)
doSearch V2 a -> V2 a -> V2 a -> Bool
forall a.
(Fractional a, Ord a, Epsilon a) =>
V2 a -> V2 a -> V2 a -> Bool
isLeftTurn Chain
funnelRight of
        (Chain
lower, Int
t, Chain
upper) ->
          ( Int
t
          , Chain -> Int -> Chain -> Funnel
Funnel Chain
funnelLeft Int
funnelCusp (Chain
lower Chain -> Int -> Chain
forall v a. Measured v a => FingerTree v a -> a -> FingerTree v a
F.|> Int
t Chain -> Int -> Chain
forall v a. Measured v a => FingerTree v a -> a -> FingerTree v a
F.|> Int
x)
          , Chain -> Int -> Chain -> Funnel
Funnel (Int -> Chain
forall v a. Measured v a => a -> FingerTree v a
F.singleton Int
x) Int
t Chain
upper)
    | Bool
otherwise =
      ( Int
funnelCusp
      , Chain -> Int -> Chain -> Funnel
Funnel Chain
funnelLeft Int
funnelCusp (Int -> Chain
forall v a. Measured v a => a -> FingerTree v a
F.singleton Int
x)
      , Chain -> Int -> Chain -> Funnel
Funnel (Int -> Chain
forall v a. Measured v a => a -> FingerTree v a
F.singleton Int
x) Int
funnelCusp Chain
funnelRight)
  where
    isOnLeftChain :: Bool
isOnLeftChain  = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      V2 a -> V2 a -> V2 a -> Bool
forall a.
(Fractional a, Ord a, Epsilon a) =>
V2 a -> V2 a -> V2 a -> Bool
isLeftTurnOrLinear V2 a
cuspElt (V2 a -> V2 a -> Bool) -> Maybe (V2 a) -> Maybe (V2 a -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (V2 a)
leftElt Maybe (V2 a -> Bool) -> Maybe (V2 a) -> Maybe Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> V2 a -> Maybe (V2 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure V2 a
targetElt
    isOnRightChain :: Bool
isOnRightChain = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      V2 a -> V2 a -> V2 a -> Bool
forall a.
(Fractional a, Ord a, Epsilon a) =>
V2 a -> V2 a -> V2 a -> Bool
isRightTurnOrLinear V2 a
cuspElt (V2 a -> V2 a -> Bool) -> Maybe (V2 a) -> Maybe (V2 a -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (V2 a)
rightElt Maybe (V2 a -> Bool) -> Maybe (V2 a) -> Maybe Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> V2 a -> Maybe (V2 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure V2 a
targetElt
    doSearch :: (V2 a -> V2 a -> V2 a -> Bool) -> Chain -> (Chain, Int, Chain)
doSearch V2 a -> V2 a -> V2 a -> Bool
fn Chain
chain =
      case (MinMax -> MinMax -> Bool) -> Chain -> SearchResult MinMax Int
forall v a.
Measured v a =>
(v -> v -> Bool) -> FingerTree v a -> SearchResult v a
F.search ((V2 a -> V2 a -> V2 a -> Bool) -> MinMax -> MinMax -> Bool
searchChain V2 a -> V2 a -> V2 a -> Bool
fn) (Chain
chain::Chain) of
        F.Position Chain
lower Int
t Chain
upper -> (Chain
lower, Int
t, Chain
upper)
        SearchResult MinMax Int
F.OnLeft                 -> String -> (Chain, Int, Chain)
forall a. HasCallStack => String -> a
error String
"cannot happen"
        SearchResult MinMax Int
F.OnRight                -> String -> (Chain, Int, Chain)
forall a. HasCallStack => String -> a
error String
"cannot happen"
        SearchResult MinMax Int
F.Nowhere                -> String -> (Chain, Int, Chain)
forall a. HasCallStack => String -> a
error String
"cannot happen"
    searchChain :: (V2 a -> V2 a -> V2 a -> Bool) -> MinMax -> MinMax -> Bool
searchChain V2 a -> V2 a -> V2 a -> Bool
_ MinMax
MinMaxEmpty MinMax
_             = Bool
False
    searchChain V2 a -> V2 a -> V2 a -> Bool
_ MinMax
_ MinMax
MinMaxEmpty             = Bool
True
    searchChain V2 a -> V2 a -> V2 a -> Bool
check (MinMax Int
_ Int
l) (MinMax Int
r Int
_) =
      V2 a -> V2 a -> V2 a -> Bool
check (Ring a -> Int -> V2 a
forall a. Ring a -> Int -> V2 a
ringAccess Ring a
p Int
l) (Ring a -> Int -> V2 a
forall a. Ring a -> Int -> V2 a
ringAccess Ring a
p Int
r) V2 a
targetElt
    cuspElt :: V2 a
cuspElt   = Ring a -> Int -> V2 a
forall a. Ring a -> Int -> V2 a
ringAccess Ring a
p Int
funnelCusp
    targetElt :: V2 a
targetElt = Ring a -> Int -> V2 a
forall a. Ring a -> Int -> V2 a
ringAccess Ring a
p Int
x
    leftElt :: Maybe (V2 a)
leftElt   = Ring a -> Int -> V2 a
forall a. Ring a -> Int -> V2 a
ringAccess Ring a
p (Int -> V2 a) -> Maybe Int -> Maybe (V2 a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chain -> Maybe Int
forall v a. Measured v a => FingerTree v a -> Maybe a
chainLeft Chain
funnelLeft
    rightElt :: Maybe (V2 a)
rightElt  = Ring a -> Int -> V2 a
forall a. Ring a -> Int -> V2 a
ringAccess Ring a
p (Int -> V2 a) -> Maybe Int -> Maybe (V2 a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Chain -> Maybe Int
forall v a. Measured v a => FingerTree v a -> Maybe a
chainLeft Chain
funnelRight
    chainLeft :: FingerTree v a -> Maybe a
chainLeft FingerTree v a
chain =
      case FingerTree v a -> ViewL (FingerTree v) a
forall v a.
Measured v a =>
FingerTree v a -> ViewL (FingerTree v) a
F.viewl FingerTree v a
chain of
        ViewL (FingerTree v) a
F.EmptyL   -> Maybe a
forall a. Maybe a
Nothing
        a
elt F.:< FingerTree v a
_ -> a -> Maybe a
forall a. a -> Maybe a
Just a
elt

-- O(n)
ssspFinger :: (Epsilon a, Fractional a, Ord a) => Ring a -> Dual -> SSSP
ssspFinger :: Ring a -> Dual -> SSSP
ssspFinger Ring a
p Dual
d = [(Int, Int)] -> SSSP
forall a. [(Int, a)] -> Vector a
toSSSP ([(Int, Int)] -> SSSP) -> [(Int, Int)] -> SSSP
forall a b. (a -> b) -> a -> b
$
    case Dual
d of
      Dual (Int
a,Int
b,Int
c) DualTree
l DualTree
r ->
        (Int
a, Int
a) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:
        (Int
b, Int
a) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:
        (Int
c, Int
a) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:
        Funnel -> DualTree -> [(Int, Int)]
worker (Chain -> Int -> Chain -> Funnel
Funnel (Int -> Chain
forall v a. Measured v a => a -> FingerTree v a
F.singleton Int
c) Int
a (Int -> Chain
forall v a. Measured v a => a -> FingerTree v a
F.singleton Int
b)) DualTree
r [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++
        Int -> Int -> DualTree -> [(Int, Int)]
loopLeft Int
a Int
c DualTree
l
  where
    toSSSP :: [(Int, a)] -> Vector a
toSSSP =
      [a] -> Vector a
forall a. [a] -> Vector a
V.fromList ([a] -> Vector a) -> ([(Int, a)] -> [a]) -> [(Int, a)] -> Vector a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, a) -> a) -> [(Int, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Int, a) -> a
forall a b. (a, b) -> b
snd ([(Int, a)] -> [a])
-> ([(Int, a)] -> [(Int, a)]) -> [(Int, a)] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, a) -> Int) -> [(Int, a)] -> [(Int, a)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int, a) -> Int
forall a b. (a, b) -> a
fst
    loopLeft :: Int -> Int -> DualTree -> [(Int, Int)]
loopLeft Int
a Int
outer DualTree
l =
      case DualTree
l of
        DualTree
EmptyDual -> []
        NodeDual Int
x DualTree
l' DualTree
r' ->
          (Int
x,Int
a) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:
          Funnel -> DualTree -> [(Int, Int)]
worker (Chain -> Int -> Chain -> Funnel
Funnel (Int -> Chain
forall v a. Measured v a => a -> FingerTree v a
F.singleton Int
x) Int
a (Int -> Chain
forall v a. Measured v a => a -> FingerTree v a
F.singleton Int
outer)) DualTree
r' [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++
          Int -> Int -> DualTree -> [(Int, Int)]
loopLeft Int
a Int
x DualTree
l'
    worker :: Funnel -> DualTree -> [(Int, Int)]
worker Funnel
_ DualTree
EmptyDual = []
    worker Funnel
f (NodeDual Int
x DualTree
l DualTree
r) =
      case Ring a -> Int -> Funnel -> (Int, Funnel, Funnel)
forall a.
(Epsilon a, Fractional a, Ord a) =>
Ring a -> Int -> Funnel -> (Int, Funnel, Funnel)
splitFunnel Ring a
p Int
x Funnel
f of
        (Int
v, Funnel
fL, Funnel
fR) ->
          (Int
x, Int
v) (Int, Int) -> [(Int, Int)] -> [(Int, Int)]
forall a. a -> [a] -> [a]
:
          Funnel -> DualTree -> [(Int, Int)]
worker Funnel
fL DualTree
l [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
++
          Funnel -> DualTree -> [(Int, Int)]
worker Funnel
fR DualTree
r