-- | Braids. See eg. <https://en.wikipedia.org/wiki/Braid_group>
--
--
-- Based on: 
--
--  * Joan S. Birman, Tara E. Brendle: BRAIDS - A SURVEY
--    <https://www.math.columbia.edu/~jb/Handbook-21.pdf>
--
--
-- Note: This module GHC 7.8, since we use type-level naturals
-- to parametrize the 'Braid' type.
--


{-# LANGUAGE 
      CPP, BangPatterns, 
      ScopedTypeVariables, ExistentialQuantification,
      DataKinds, KindSignatures, Rank2Types,
      TypeOperators, TypeFamilies,
      StandaloneDeriving #-}

module Math.Combinat.Groups.Braid where

--------------------------------------------------------------------------------

import Data.Proxy
import GHC.TypeLits

import Control.Monad

import Data.List ( mapAccumL , foldl' )

import Data.Array.Unboxed
import Data.Array.ST
import Data.Array.IArray
import Data.Array.MArray
import Data.Array.Unsafe
import Data.Array.Base

import Control.Monad.ST

import System.Random

import Math.Combinat.ASCII
import Math.Combinat.Sign
import Math.Combinat.Helper
import Math.Combinat.TypeLevel
import Math.Combinat.Numbers.Series

import Math.Combinat.Permutations ( Permutation(..) , (!!!) )
import qualified Math.Combinat.Permutations as P

--------------------------------------------------------------------------------
-- * Artin generators

-- | A standard Artin generator of a braid: @Sigma i@ represents twisting 
-- the neighbour strands @i@ and @(i+1)@, such that strand @i@ goes /under/ strand @(i+1)@.
--
-- Note: The strands are numbered @1..n@.
data BrGen
  = Sigma    !Int         -- ^ @i@ goes under @(i+1)@
  | SigmaInv !Int         -- ^ @i@ goes above @(i+1)@
  deriving (BrGen -> BrGen -> Bool
(BrGen -> BrGen -> Bool) -> (BrGen -> BrGen -> Bool) -> Eq BrGen
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BrGen -> BrGen -> Bool
$c/= :: BrGen -> BrGen -> Bool
== :: BrGen -> BrGen -> Bool
$c== :: BrGen -> BrGen -> Bool
Eq,Eq BrGen
Eq BrGen
-> (BrGen -> BrGen -> Ordering)
-> (BrGen -> BrGen -> Bool)
-> (BrGen -> BrGen -> Bool)
-> (BrGen -> BrGen -> Bool)
-> (BrGen -> BrGen -> Bool)
-> (BrGen -> BrGen -> BrGen)
-> (BrGen -> BrGen -> BrGen)
-> Ord BrGen
BrGen -> BrGen -> Bool
BrGen -> BrGen -> Ordering
BrGen -> BrGen -> BrGen
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BrGen -> BrGen -> BrGen
$cmin :: BrGen -> BrGen -> BrGen
max :: BrGen -> BrGen -> BrGen
$cmax :: BrGen -> BrGen -> BrGen
>= :: BrGen -> BrGen -> Bool
$c>= :: BrGen -> BrGen -> Bool
> :: BrGen -> BrGen -> Bool
$c> :: BrGen -> BrGen -> Bool
<= :: BrGen -> BrGen -> Bool
$c<= :: BrGen -> BrGen -> Bool
< :: BrGen -> BrGen -> Bool
$c< :: BrGen -> BrGen -> Bool
compare :: BrGen -> BrGen -> Ordering
$ccompare :: BrGen -> BrGen -> Ordering
$cp1Ord :: Eq BrGen
Ord,Int -> BrGen -> ShowS
[BrGen] -> ShowS
BrGen -> String
(Int -> BrGen -> ShowS)
-> (BrGen -> String) -> ([BrGen] -> ShowS) -> Show BrGen
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BrGen] -> ShowS
$cshowList :: [BrGen] -> ShowS
show :: BrGen -> String
$cshow :: BrGen -> String
showsPrec :: Int -> BrGen -> ShowS
$cshowsPrec :: Int -> BrGen -> ShowS
Show)
 
-- | The strand (more precisely, the first of the two strands) the generator twistes
brGenIdx :: BrGen -> Int
brGenIdx :: BrGen -> Int
brGenIdx BrGen
g = case BrGen
g of
  Sigma    Int
i -> Int
i
  SigmaInv Int
i -> Int
i

brGenSign :: BrGen -> Sign
brGenSign :: BrGen -> Sign
brGenSign BrGen
g = case BrGen
g of
  Sigma    Int
_ -> Sign
Plus
  SigmaInv Int
_ -> Sign
Minus

brGenSignIdx :: BrGen -> (Sign,Int)        
brGenSignIdx :: BrGen -> (Sign, Int)
brGenSignIdx BrGen
g = case BrGen
g of
  Sigma    Int
i -> (Sign
Plus ,Int
i)
  SigmaInv Int
i -> (Sign
Minus,Int
i) 

-- | The inverse of a braid generator
invBrGen :: BrGen -> BrGen
invBrGen :: BrGen -> BrGen
invBrGen  BrGen
g = case BrGen
g of
  Sigma    Int
i -> Int -> BrGen
SigmaInv Int
i
  SigmaInv Int
i -> Int -> BrGen
Sigma    Int
i

--------------------------------------------------------------------------------
-- * The braid type
  
-- | The braid group @B_n@ on @n@ strands.
-- The number @n@ is encoded as a type level natural in the type parameter.
--
-- Braids are represented as words in the standard generators and their
-- inverses.
newtype Braid (n :: Nat) = Braid [BrGen] deriving (Int -> Braid n -> ShowS
[Braid n] -> ShowS
Braid n -> String
(Int -> Braid n -> ShowS)
-> (Braid n -> String) -> ([Braid n] -> ShowS) -> Show (Braid n)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (n :: Nat). Int -> Braid n -> ShowS
forall (n :: Nat). [Braid n] -> ShowS
forall (n :: Nat). Braid n -> String
showList :: [Braid n] -> ShowS
$cshowList :: forall (n :: Nat). [Braid n] -> ShowS
show :: Braid n -> String
$cshow :: forall (n :: Nat). Braid n -> String
showsPrec :: Int -> Braid n -> ShowS
$cshowsPrec :: forall (n :: Nat). Int -> Braid n -> ShowS
Show)

-- | The number of strands in the braid
numberOfStrands :: KnownNat n => Braid n -> Int
numberOfStrands :: Braid n -> Int
numberOfStrands = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> (Braid n -> Integer) -> Braid n -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n -> Integer) -> (Braid n -> Proxy n) -> Braid n -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Braid n -> Proxy n
forall (n :: Nat). Braid n -> Proxy n
braidProxy where                                                         
  braidProxy :: Braid n -> Proxy n
  braidProxy :: Braid n -> Proxy n
braidProxy Braid n
_ = Proxy n
forall k (t :: k). Proxy t
Proxy

-- | Sometimes we want to hide the type-level parameter @n@, for example when
-- dynamically creating braids whose size is known only at runtime.
data SomeBraid = forall n. KnownNat n => SomeBraid (Braid n)

someBraid :: Int -> (forall (n :: Nat). KnownNat n => Braid n) -> SomeBraid
someBraid :: Int -> (forall (n :: Nat). KnownNat n => Braid n) -> SomeBraid
someBraid Int
n forall (n :: Nat). KnownNat n => Braid n
polyBraid = 
  case SomeNat
snat of    
    SomeNat Proxy n
pxy -> Braid n -> SomeBraid
forall (n :: Nat). KnownNat n => Braid n -> SomeBraid
SomeBraid (Braid n -> Proxy n -> Braid n
forall k (f :: k -> *) (a :: k). f a -> Proxy a -> f a
asProxyTypeOf1 Braid n
forall (n :: Nat). KnownNat n => Braid n
polyBraid Proxy n
pxy)
  where
    snat :: SomeNat
snat = case Integer -> Maybe SomeNat
someNatVal (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n :: Integer) of
      Just SomeNat
sn -> SomeNat
sn
      Maybe SomeNat
Nothing -> String -> SomeNat
forall a. HasCallStack => String -> a
error String
"someBraid: input is not a natural number"

withSomeBraid :: SomeBraid -> (forall n. KnownNat n => Braid n -> a) -> a
withSomeBraid :: SomeBraid -> (forall (n :: Nat). KnownNat n => Braid n -> a) -> a
withSomeBraid SomeBraid
sbraid forall (n :: Nat). KnownNat n => Braid n -> a
f = case SomeBraid
sbraid of SomeBraid Braid n
braid -> Braid n -> a
forall (n :: Nat). KnownNat n => Braid n -> a
f Braid n
braid

mkBraid :: (forall n. KnownNat n => Braid n -> a) -> Int -> [BrGen] -> a
mkBraid :: (forall (n :: Nat). KnownNat n => Braid n -> a)
-> Int -> [BrGen] -> a
mkBraid forall (n :: Nat). KnownNat n => Braid n -> a
f Int
n [BrGen]
w = a
y where
  sb :: SomeBraid
sb = Int -> (forall (n :: Nat). KnownNat n => Braid n) -> SomeBraid
someBraid Int
n ([BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid [BrGen]
w)
  y :: a
y  = SomeBraid -> (forall (n :: Nat). KnownNat n => Braid n -> a) -> a
forall a.
SomeBraid -> (forall (n :: Nat). KnownNat n => Braid n -> a) -> a
withSomeBraid SomeBraid
sb forall (n :: Nat). KnownNat n => Braid n -> a
f

withBraid 
  :: Int
  -> (forall (n :: Nat). KnownNat n => Braid n)
  -> (forall (n :: Nat). KnownNat n => Braid n -> a) 
  -> a
withBraid :: Int
-> (forall (n :: Nat). KnownNat n => Braid n)
-> (forall (n :: Nat). KnownNat n => Braid n -> a)
-> a
withBraid Int
n forall (n :: Nat). KnownNat n => Braid n
polyBraid forall (n :: Nat). KnownNat n => Braid n -> a
f = 
  case SomeNat
snat of    
    SomeNat Proxy n
pxy -> Braid n -> a
forall (n :: Nat). KnownNat n => Braid n -> a
f (Braid n -> Proxy n -> Braid n
forall k (f :: k -> *) (a :: k). f a -> Proxy a -> f a
asProxyTypeOf1 Braid n
forall (n :: Nat). KnownNat n => Braid n
polyBraid Proxy n
pxy)
  where
    snat :: SomeNat
snat = case Integer -> Maybe SomeNat
someNatVal (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n :: Integer) of
      Just SomeNat
sn -> SomeNat
sn
      Maybe SomeNat
Nothing -> String -> SomeNat
forall a. HasCallStack => String -> a
error String
"withBraid: input is not a natural number"

--------------------------------------------------------------------------------

braidWord :: Braid n -> [BrGen]
braidWord :: Braid n -> [BrGen]
braidWord (Braid [BrGen]
gs) = [BrGen]
gs

braidWordLength :: Braid n -> Int
braidWordLength :: Braid n -> Int
braidWordLength (Braid [BrGen]
gs) = [BrGen] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BrGen]
gs

-- | Embeds a smaller braid group into a bigger braid group    
extend :: (n1 <= n2) => Braid n1 -> Braid n2
extend :: Braid n1 -> Braid n2
extend (Braid [BrGen]
gs) = [BrGen] -> Braid n2
forall (n :: Nat). [BrGen] -> Braid n
Braid [BrGen]
gs

-- | Apply \"free reduction\" to the word, that is, iteratively remove @sigma_i sigma_i^-1@ pairs.
-- The resulting braid is clearly equivalent to the original.
freeReduceBraidWord :: Braid n -> Braid n
freeReduceBraidWord :: Braid n -> Braid n
freeReduceBraidWord (Braid [BrGen]
orig) = [BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid ([BrGen] -> [BrGen]
loop [BrGen]
orig) where

  loop :: [BrGen] -> [BrGen]
loop [BrGen]
w = case [BrGen] -> Maybe [BrGen]
reduceStep [BrGen]
w of
    Maybe [BrGen]
Nothing -> [BrGen]
w
    Just [BrGen]
w' -> [BrGen] -> [BrGen]
loop [BrGen]
w'
  
  reduceStep :: [BrGen] -> Maybe [BrGen]
  reduceStep :: [BrGen] -> Maybe [BrGen]
reduceStep = Bool -> [BrGen] -> Maybe [BrGen]
go Bool
False where    
    go :: Bool -> [BrGen] -> Maybe [BrGen]
go !Bool
changed [BrGen]
w = case [BrGen]
w of
      (Sigma    Int
x : SigmaInv Int
y : [BrGen]
rest) | Int
xInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
y   -> Bool -> [BrGen] -> Maybe [BrGen]
go Bool
True [BrGen]
rest
      (SigmaInv Int
x : Sigma    Int
y : [BrGen]
rest) | Int
xInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
y   -> Bool -> [BrGen] -> Maybe [BrGen]
go Bool
True [BrGen]
rest
      (BrGen
this : [BrGen]
rest)                             -> ([BrGen] -> [BrGen]) -> Maybe [BrGen] -> Maybe [BrGen]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (BrGen
thisBrGen -> [BrGen] -> [BrGen]
forall a. a -> [a] -> [a]
:) (Maybe [BrGen] -> Maybe [BrGen]) -> Maybe [BrGen] -> Maybe [BrGen]
forall a b. (a -> b) -> a -> b
$ Bool -> [BrGen] -> Maybe [BrGen]
go Bool
changed [BrGen]
rest
      [BrGen]
_                                         -> if Bool
changed then [BrGen] -> Maybe [BrGen]
forall a. a -> Maybe a
Just [BrGen]
w else Maybe [BrGen]
forall a. Maybe a
Nothing

--------------------------------------------------------------------------------
-- * Some specific braids

-- | The braid generator @sigma_i@ as a braid
sigma :: KnownNat n => Int -> Braid (n :: Nat)
sigma :: Int -> Braid n
sigma Int
k = Braid n
braid where
  braid :: Braid n
braid = if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid
    then [BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid [Int -> BrGen
Sigma Int
k]
    else String -> Braid n
forall a. HasCallStack => String -> a
error String
"sigma: braid generator index out of range"

-- | The braid generator @sigma_i^(-1)@ as a braid
sigmaInv :: KnownNat n => Int -> Braid (n :: Nat)
sigmaInv :: Int -> Braid n
sigmaInv Int
k = Braid n
braid where
  braid :: Braid n
braid = if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid
    then [BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid [Int -> BrGen
SigmaInv Int
k]
    else String -> Braid n
forall a. HasCallStack => String -> a
error String
"sigma: braid generator index out of range"

-- | @doubleSigma s t@ (for s<t)is the generator @sigma_{s,t}@ in Birman-Ko-Lee's
-- \"new presentation\". It twistes the strands @s@ and @t@ while going over all
-- other strands. For @t==s+1@ we get back @sigma s@
-- 
doubleSigma :: KnownNat n => Int -> Int -> Braid (n :: Nat)
doubleSigma :: Int -> Int -> Braid n
doubleSigma Int
s Int
t = Braid n
braid where
  n :: Int
n = Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid
  braid :: Braid n
braid
    | Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n   = String -> Braid n
forall a. HasCallStack => String -> a
error String
"doubleSigma: s index out of range"
    | Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n   = String -> Braid n
forall a. HasCallStack => String -> a
error String
"doubleSigma: t index out of range"
    | Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
t           = String -> Braid n
forall a. HasCallStack => String -> a
error String
"doubleSigma: s >= t"
    | Bool
otherwise        = [BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid ([BrGen] -> Braid n) -> [BrGen] -> Braid n
forall a b. (a -> b) -> a -> b
$
       [ Int -> BrGen
Sigma Int
i | Int
i<-[Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2..Int
s] ] [BrGen] -> [BrGen] -> [BrGen]
forall a. [a] -> [a] -> [a]
++ [ Int -> BrGen
SigmaInv Int
i | Int
i<-[Int
sInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1..Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ]

-- | @positiveWord [2,5,1]@ is shorthand for the word @sigma_2*sigma_5*sigma_1@.
positiveWord :: KnownNat n => [Int] -> Braid (n :: Nat)
positiveWord :: [Int] -> Braid n
positiveWord [Int]
idxs = Braid n
braid where
  braid :: Braid n
braid = [BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid ((Int -> BrGen) -> [Int] -> [BrGen]
forall a b. (a -> b) -> [a] -> [b]
map Int -> BrGen
gen [Int]
idxs) 
  n :: Int
n     = Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid
  gen :: Int -> BrGen
gen Int
i = if Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0 Bool -> Bool -> Bool
&& Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
n then Int -> BrGen
Sigma Int
i else String -> BrGen
forall a. HasCallStack => String -> a
error String
"positiveWord: index out of range"
       
-- | The (positive) half-twist of all the braid strands, usually denoted by @Delta@.
halfTwist :: KnownNat n => Braid n
halfTwist :: Braid n
halfTwist = Braid n
braid where
  braid :: Braid n
braid = [BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid ([BrGen] -> Braid n) -> [BrGen] -> Braid n
forall a b. (a -> b) -> a -> b
$ (Int -> BrGen) -> [Int] -> [BrGen]
forall a b. (a -> b) -> [a] -> [b]
map Int -> BrGen
Sigma ([Int] -> [BrGen]) -> [Int] -> [BrGen]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
_halfTwist Int
n 
  n :: Int
n     = Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid

-- | The untyped version of 'halfTwist'
_halfTwist :: Int -> [Int]
_halfTwist :: Int -> [Int]
_halfTwist Int
n = [Int]
gens where
  gens :: [Int]
gens  = [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Int -> [Int]
sub Int
k | Int
k<-[Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ]
  sub :: Int -> [Int]
sub Int
k = [ Int
j | Int
j<-[Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2..Int
k] ]
  
-- | Synonym for 'halfTwist'
theGarsideBraid :: KnownNat n => Braid n
theGarsideBraid :: Braid n
theGarsideBraid = Braid n
forall (n :: Nat). KnownNat n => Braid n
halfTwist 

-- | The inner automorphism defined by @tau(X) = Delta^-1 X Delta@, 
-- where @Delta@ is the positive half-twist.
-- 
-- This sends each generator @sigma_j@ to @sigma_(n-j)@.
--
tau :: KnownNat n => Braid n -> Braid n
tau :: Braid n -> Braid n
tau braid :: Braid n
braid@(Braid [BrGen]
gens) = [BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid ((BrGen -> BrGen) -> [BrGen] -> [BrGen]
forall a b. (a -> b) -> [a] -> [b]
map BrGen -> BrGen
f [BrGen]
gens) where
  n :: Int
n = Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid
  f :: BrGen -> BrGen
f (Sigma    Int
i) = Int -> BrGen
Sigma    (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i)
  f (SigmaInv Int
i) = Int -> BrGen
SigmaInv (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i)


-- | The involution @tau@ on permutations (permutation braids)
--
tauPerm :: Permutation -> Permutation
tauPerm :: Permutation -> Permutation
tauPerm Permutation
perm = Int -> [Int] -> Permutation
P.toPermutationUnsafeN Int
n [ (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Permutation
perm Permutation -> Int -> Int
!!! (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) | Int
i<-[Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ] where
  n :: Int
n = Permutation -> Int
P.permutationSize Permutation
perm

--------------------------------------------------------------------------------
-- * Group operations

-- | The trivial braid
identity :: Braid n
identity :: Braid n
identity = [BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid []

-- | The inverse of a braid. Note: we do not perform reduction here,
-- as a word is reduced if and only if its inverse is reduced.
inverse :: Braid n -> Braid n
inverse :: Braid n -> Braid n
inverse = [BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid ([BrGen] -> Braid n) -> (Braid n -> [BrGen]) -> Braid n -> Braid n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [BrGen] -> [BrGen]
forall a. [a] -> [a]
reverse ([BrGen] -> [BrGen]) -> (Braid n -> [BrGen]) -> Braid n -> [BrGen]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BrGen -> BrGen) -> [BrGen] -> [BrGen]
forall a b. (a -> b) -> [a] -> [b]
map BrGen -> BrGen
invBrGen ([BrGen] -> [BrGen]) -> (Braid n -> [BrGen]) -> Braid n -> [BrGen]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Braid n -> [BrGen]
forall (n :: Nat). Braid n -> [BrGen]
braidWord

-- | Composes two braids, doing free reduction on the result 
-- (that is, removing @(sigma_k * sigma_k^-1)@ pairs@)
compose :: Braid n -> Braid n -> Braid n
compose :: Braid n -> Braid n -> Braid n
compose (Braid [BrGen]
gs) (Braid [BrGen]
hs) = Braid n -> Braid n
forall (n :: Nat). Braid n -> Braid n
freeReduceBraidWord (Braid n -> Braid n) -> Braid n -> Braid n
forall a b. (a -> b) -> a -> b
$ [BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid ([BrGen]
gs[BrGen] -> [BrGen] -> [BrGen]
forall a. [a] -> [a] -> [a]
++[BrGen]
hs)

composeMany :: [Braid n] -> Braid n
composeMany :: [Braid n] -> Braid n
composeMany = Braid n -> Braid n
forall (n :: Nat). Braid n -> Braid n
freeReduceBraidWord (Braid n -> Braid n)
-> ([Braid n] -> Braid n) -> [Braid n] -> Braid n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid ([BrGen] -> Braid n)
-> ([Braid n] -> [BrGen]) -> [Braid n] -> Braid n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[BrGen]] -> [BrGen]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[BrGen]] -> [BrGen])
-> ([Braid n] -> [[BrGen]]) -> [Braid n] -> [BrGen]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Braid n -> [BrGen]) -> [Braid n] -> [[BrGen]]
forall a b. (a -> b) -> [a] -> [b]
map Braid n -> [BrGen]
forall (n :: Nat). Braid n -> [BrGen]
braidWord 

-- | Composes two braids without doing any reduction.
composeDontReduce :: Braid n -> Braid n -> Braid n
composeDontReduce :: Braid n -> Braid n -> Braid n
composeDontReduce (Braid [BrGen]
gs) (Braid [BrGen]
hs) = [BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid ([BrGen]
gs[BrGen] -> [BrGen] -> [BrGen]
forall a. [a] -> [a] -> [a]
++[BrGen]
hs)

--------------------------------------------------------------------------------
-- * Braid permutations

-- | A braid is pure if its permutation is trivial
isPureBraid :: KnownNat n => Braid n -> Bool
isPureBraid :: Braid n -> Bool
isPureBraid Braid n
braid = (Braid n -> Permutation
forall (n :: Nat). KnownNat n => Braid n -> Permutation
braidPermutation Braid n
braid Permutation -> Permutation -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Permutation
P.identityPermutation Int
n) where
  n :: Int
n = Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid

-- | Returns the left-to-right permutation associated to the braid. 
-- We follow the strands /from the left to the right/ (or from the top to the 
-- bottom), and return the permutation taking the left side to the right side.
--
-- This is compatible with /right/ (standard) action of the permutations:
-- @permuteRight (braidPermutationRight b1)@ corresponds to the left-to-right
-- permutation of the strands; also:
--
-- > (braidPermutation b1) `multiply` (braidPermutation b2) == braidPermutation (b1 `compose` b2)
--
-- Writing the right numbering of the strands below the left numbering,
-- we got the two-line notation of the permutation.
--
braidPermutation :: KnownNat n => Braid n -> Permutation
braidPermutation :: Braid n -> Permutation
braidPermutation braid :: Braid n
braid@(Braid [BrGen]
gens) = Permutation
perm where
  n :: Int
n    = Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid
  perm :: Permutation
perm = Int -> [Int] -> Permutation
_braidPermutation Int
n ((BrGen -> Int) -> [BrGen] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map BrGen -> Int
brGenIdx [BrGen]
gens)

-- | This is an untyped version of 'braidPermutation'
_braidPermutation :: Int -> [Int] -> Permutation
_braidPermutation :: Int -> [Int] -> Permutation
_braidPermutation Int
n [Int]
idxs = UArray Int Int -> Permutation
P.uarrayToPermutationUnsafe ((forall s. ST s (STUArray s Int Int)) -> UArray Int Int
forall i e. (forall s. ST s (STUArray s i e)) -> UArray i e
runSTUArray forall s. ST s (STUArray s Int Int)
action) where

  action :: forall s. ST s (STUArray s Int Int) 
  action :: ST s (STUArray s Int Int)
action = do 
    STUArray s Int Int
arr <- (Int, Int) -> ST s (STUArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
1,Int
n) 
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
n] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
arr Int
i Int
i
    STUArray s Int Int -> [Int] -> ST s (STUArray s Int Int)
forall (m :: * -> *) (a :: * -> * -> *) e a.
(MArray a e m, Ix a, Num a) =>
a a e -> [a] -> m (a a e)
worker STUArray s Int Int
arr [Int]
idxs
    STUArray s Int Int -> ST s (STUArray s Int Int)
forall (m :: * -> *) a. Monad m => a -> m a
return STUArray s Int Int
arr
    
  worker :: a a e -> [a] -> m (a a e)
worker a a e
arr = [a] -> m (a a e)
go where
    go :: [a] -> m (a a e)
go []     = a a e -> m (a a e)
forall (m :: * -> *) a. Monad m => a -> m a
return a a e
arr 
    go (a
i:[a]
is) = do
      e
a <- a a e -> a -> m e
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray a a e
arr  a
i
      e
b <- a a e -> a -> m e
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray a a e
arr (a
ia -> a -> a
forall a. Num a => a -> a -> a
+a
1)
      a a e -> a -> e -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray a a e
arr  a
i    e
b
      a a e -> a -> e -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray a a e
arr (a
ia -> a -> a
forall a. Num a => a -> a -> a
+a
1) e
a
      [a] -> m (a a e)
go [a]
is

--------------------------------------------------------------------------------
-- * Permutation braids

-- | A positive braid word contains only positive (@Sigma@) generators.
isPositiveBraidWord :: KnownNat n => Braid n -> Bool
isPositiveBraidWord :: Braid n -> Bool
isPositiveBraidWord (Braid [BrGen]
gs) = (BrGen -> Bool) -> [BrGen] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Sign -> Bool
isPlus (Sign -> Bool) -> (BrGen -> Sign) -> BrGen -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BrGen -> Sign
brGenSign) [BrGen]
gs 

-- | A /permutation braid/ is a positive braid where any two strands cross
-- at most one, and /positively/. 
--
isPermutationBraid :: KnownNat n => Braid n -> Bool
isPermutationBraid :: Braid n -> Bool
isPermutationBraid Braid n
braid = Braid n -> Bool
forall (n :: Nat). KnownNat n => Braid n -> Bool
isPositiveBraidWord Braid n
braid Bool -> Bool -> Bool
&& Bool
crosses where
  crosses :: Bool
crosses     = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Int -> Int -> Bool
check Int
i Int
j | Int
i<-[Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1], Int
j<-[Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1..Int
n] ] 
  check :: Int -> Int -> Bool
check Int
i Int
j   = Int -> Bool
forall a. (Eq a, Num a) => a -> Bool
zeroOrOne (UArray (Int, Int) Int
lkMatrix UArray (Int, Int) Int -> (Int, Int) -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! (Int
i,Int
j)) 
  zeroOrOne :: a -> Bool
zeroOrOne a
a = (a
aa -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
1 Bool -> Bool -> Bool
|| a
aa -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
0)
  lkMatrix :: UArray (Int, Int) Int
lkMatrix    = Braid n -> UArray (Int, Int) Int
forall (n :: Nat). KnownNat n => Braid n -> UArray (Int, Int) Int
linkingMatrix   Braid n
braid
  n :: Int
n           = Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid

-- | Untyped version of 'isPermutationBraid' for positive words.
_isPermutationBraid :: Int -> [Int] -> Bool
_isPermutationBraid :: Int -> [Int] -> Bool
_isPermutationBraid Int
n [Int]
gens = Bool
crosses where
  crosses :: Bool
crosses     = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Int -> Int -> Bool
check Int
i Int
j | Int
i<-[Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1], Int
j<-[Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1..Int
n] ] 
  check :: Int -> Int -> Bool
check Int
i Int
j   = Int -> Bool
forall a. (Eq a, Num a) => a -> Bool
zeroOrOne (UArray (Int, Int) Int
lkMatrix UArray (Int, Int) Int -> (Int, Int) -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! (Int
i,Int
j)) 
  zeroOrOne :: a -> Bool
zeroOrOne a
a = (a
aa -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
1 Bool -> Bool -> Bool
|| a
aa -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
0)
  lkMatrix :: UArray (Int, Int) Int
lkMatrix    = Int -> [BrGen] -> UArray (Int, Int) Int
_linkingMatrix Int
n ([BrGen] -> UArray (Int, Int) Int)
-> [BrGen] -> UArray (Int, Int) Int
forall a b. (a -> b) -> a -> b
$ (Int -> BrGen) -> [Int] -> [BrGen]
forall a b. (a -> b) -> [a] -> [b]
map Int -> BrGen
Sigma [Int]
gens

-- | For any permutation this functions returns a /permutation braid/ realizing
-- that permutation. Note that this is not unique, so we make an arbitrary choice
-- (except for the permutation @[n,n-1..1]@ reversing the order, in which case 
-- the result must be the half-twist braid).
-- 
-- The resulting braid word will have a length at most @choose n 2@ (and will have
-- that length only for the permutation @[n,n-1..1]@)
--
-- > braidPermutationRight (permutationBraid perm) == perm
-- > isPermutationBraid    (permutationBraid perm) == True
--
permutationBraid :: KnownNat n => Permutation -> Braid n
permutationBraid :: Permutation -> Braid n
permutationBraid Permutation
perm = Braid n
braid where
  n1 :: Int
n1 = Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid
  n2 :: Int
n2 = Permutation -> Int
P.permutationSize Permutation
perm
  braid :: Braid n
braid = if Int
n1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n2
    then [BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid ((Int -> BrGen) -> [Int] -> [BrGen]
forall a b. (a -> b) -> [a] -> [b]
map Int -> BrGen
Sigma ([Int] -> [BrGen]) -> [Int] -> [BrGen]
forall a b. (a -> b) -> a -> b
$ Permutation -> [Int]
_permutationBraid Permutation
perm)
    else String -> Braid n
forall a. HasCallStack => String -> a
error (String -> Braid n) -> String -> Braid n
forall a b. (a -> b) -> a -> b
$ String
"permutationBraid: incompatible n: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" vs. " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n2

-- | Untyped version of 'permutationBraid'
_permutationBraid :: Permutation -> [Int]
_permutationBraid :: Permutation -> [Int]
_permutationBraid = [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Int]] -> [Int])
-> (Permutation -> [[Int]]) -> Permutation -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation -> [[Int]]
_permutationBraid'

-- | Returns the individual \"phases\" of the a permutation braid realizing the
-- given permutation.
_permutationBraid' :: Permutation -> [[Int]]
_permutationBraid' :: Permutation -> [[Int]]
_permutationBraid' Permutation
perm = (forall s. ST s [[Int]]) -> [[Int]]
forall a. (forall s. ST s a) -> a
runST forall s. ST s [[Int]]
action where
  n :: Int
n = Permutation -> Int
P.permutationSize Permutation
perm

  action :: forall s. ST s [[Int]]
  action :: ST s [[Int]]
action = do

    -- cfwd = the current state of strands    : cfwd!j = where is strand #j now?
    -- cinv = the inverse of that permutation : cinv!i = which strand is on the #i position now?

    STUArray s Int Int
cfwd <- (Int, Int) -> ST s (STUArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
1,Int
n) :: ST s (STUArray s Int Int)
    STUArray s Int Int
cinv <- (Int, Int) -> ST s (STUArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
1,Int
n) :: ST s (STUArray s Int Int)
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
n] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
j -> do
      STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
cfwd Int
j Int
j
      STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
cinv Int
j Int
j

    let doSwap :: Int -> ST s ()
doSwap Int
i = do     
          Int
a <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
cinv  Int
i
          Int
b <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
cinv (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
          STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
cinv  Int
i    Int
b
          STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
cinv (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
a

          Int
u <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
cfwd Int
a
          Int
v <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
cfwd Int
b
          STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
cfwd Int
a Int
v
          STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
cfwd Int
b Int
u

    -- at the k-th phase, we move the (inv!k)-th strand, which is the k-th strand /on the RHS/, to correct position.
    let worker :: Int -> ST s [[Int]]
worker Int
phase
          | Int
phase Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n  = [[Int]] -> ST s [[Int]]
forall (m :: * -> *) a. Monad m => a -> m a
return []
          | Bool
otherwise   = do
              let tgt :: Int
tgt = Permutation -> Int -> Int
P.lookupPermutation Permutation
perm Int
phase  -- (arr ! phase)
              Int
src <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
cfwd Int
tgt
              let this :: [Int]
this = [Int
srcInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Int
srcInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2..Int
phase]
              (Int -> ST s ()) -> [Int] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> ST s ()
doSwap ([Int] -> ST s ()) -> [Int] -> ST s ()
forall a b. (a -> b) -> a -> b
$ [Int]
this 
              [[Int]]
rest <- Int -> ST s [[Int]]
worker (Int
phaseInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
              [[Int]] -> ST s [[Int]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int]
this[Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
:[[Int]]
rest)

    Int -> ST s [[Int]]
worker Int
1
 

-- | We compute the linking numbers between all pairs of strands:
--
-- > linkingMatrix braid ! (i,j) == strandLinking braid i j 
--
linkingMatrix :: KnownNat n => Braid n -> UArray (Int,Int) Int
linkingMatrix :: Braid n -> UArray (Int, Int) Int
linkingMatrix braid :: Braid n
braid@(Braid [BrGen]
gens) = Int -> [BrGen] -> UArray (Int, Int) Int
_linkingMatrix (Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid) [BrGen]
gens where

-- | Untyped version of 'linkingMatrix'
_linkingMatrix :: Int -> [BrGen] -> UArray (Int,Int) Int
_linkingMatrix :: Int -> [BrGen] -> UArray (Int, Int) Int
_linkingMatrix Int
n [BrGen]
gens = (forall s. ST s (STUArray s (Int, Int) Int))
-> UArray (Int, Int) Int
forall i e. (forall s. ST s (STUArray s i e)) -> UArray i e
runSTUArray forall s. ST s (STUArray s (Int, Int) Int)
action where

  action :: forall s. ST s (STUArray s (Int,Int) Int)
  action :: ST s (STUArray s (Int, Int) Int)
action = do
    STUArray s Int Int
perm <- (Int, Int) -> ST s (STUArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
1,Int
n) :: ST s (STUArray s Int Int)
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
n] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
perm Int
i Int
i
    let doSwap :: Int -> ST s ()
        doSwap :: Int -> ST s ()
doSwap Int
i = do
          Int
a <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
perm  Int
i
          Int
b <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
perm (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
          STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
perm  Int
i    Int
b
          STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
perm (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
a
               
    STUArray s (Int, Int) Int
mat <- ((Int, Int), (Int, Int)) -> Int -> ST s (STUArray s (Int, Int) Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray ((Int
1,Int
1),(Int
n,Int
n)) Int
0 :: ST s (STUArray s (Int,Int) Int)
    let doAdd :: Int -> Int -> Int -> ST s ()
        doAdd :: Int -> Int -> Int -> ST s ()
doAdd Int
i Int
j Int
pm1 = do
          Int
x <- STUArray s (Int, Int) Int -> (Int, Int) -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s (Int, Int) Int
mat (Int
i,Int
j)
          STUArray s (Int, Int) Int -> (Int, Int) -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s (Int, Int) Int
mat (Int
i,Int
j) (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
pm1) 
          STUArray s (Int, Int) Int -> (Int, Int) -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s (Int, Int) Int
mat (Int
j,Int
i) (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
pm1)
       
    [BrGen] -> (BrGen -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [BrGen]
gens ((BrGen -> ST s ()) -> ST s ()) -> (BrGen -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \BrGen
g -> do
      let (Sign
sgn,Int
k) = BrGen -> (Sign, Int)
brGenSignIdx BrGen
g
      Int
u <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
perm  Int
k 
      Int
v <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
perm (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
      Int -> Int -> Int -> ST s ()
doAdd Int
u Int
v (Sign -> Int
forall a. Num a => Sign -> a
signValue Sign
sgn)
      Int -> ST s ()
doSwap Int
k 
        
    STUArray s (Int, Int) Int -> ST s (STUArray s (Int, Int) Int)
forall (m :: * -> *) a. Monad m => a -> m a
return STUArray s (Int, Int) Int
mat
    
    
-- | The linking number between two strands numbered @i@ and @j@ 
-- (numbered such on the /left/ side).
strandLinking :: KnownNat n => Braid n -> Int -> Int -> Int
strandLinking :: Braid n -> Int -> Int -> Int
strandLinking braid :: Braid n
braid@(Braid [BrGen]
gens) Int
i0 Int
j0 
  | Int
i0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
i0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n  = String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
"strandLinkingNumber: invalid strand index i: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i0
  | Int
j0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
j0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n  = String -> Int
forall a. HasCallStack => String -> a
error (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String
"strandLinkingNumber: invalid strand index j: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
j0
  | Int
i0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j0          = Int
0
  | Bool
otherwise         = Int -> Int -> [BrGen] -> Int
forall a. Num a => Int -> Int -> [BrGen] -> a
go Int
i0 Int
j0 [BrGen]
gens
  where
    n :: Int
n = Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid
    
    go :: Int -> Int -> [BrGen] -> a
go !Int
i !Int
j []     = a
0
    go !Int
i !Int
j (BrGen
g:[BrGen]
gs)  
      | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k   Bool -> Bool -> Bool
&& Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1  = a
s a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> Int -> [BrGen] -> a
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [BrGen]
gs
      | Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k   Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1  = a
s a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> Int -> [BrGen] -> a
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [BrGen]
gs
      | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k                =     Int -> Int -> [BrGen] -> a
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)  Int
j    [BrGen]
gs
      |             Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1  =     Int -> Int -> [BrGen] -> a
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)  Int
j    [BrGen]
gs
      | Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k                =     Int -> Int -> [BrGen] -> a
go  Int
i    (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [BrGen]
gs
      |             Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1  =     Int -> Int -> [BrGen] -> a
go  Int
i    (Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [BrGen]
gs
      | Bool
otherwise             =     Int -> Int -> [BrGen] -> a
go  Int
i     Int
j    [BrGen]
gs
      where
        (Sign
sgn,Int
k) = BrGen -> (Sign, Int)
brGenSignIdx BrGen
g
        s :: a
s = Sign -> a
forall a. Num a => Sign -> a
signValue Sign
sgn

--------------------------------------------------------------------------------
-- * Growth 

-- | Bronfman's recursive formula for the reciprocial of the growth function 
-- of /positive/ braids. It was already known (by Deligne) that these generating functions 
-- are reciprocials of polynomials; Bronfman [1] gave a recursive formula for them.
--
-- > let count n l = length $ nub $ [ braidNormalForm w | w <- allPositiveBraidWords n l ]
-- > let convertPoly (1:cs) = zip (map negate cs) [1..]
-- > pseries' (convertPoly $ bronfmanH n) == expandBronfmanH n == [ count n l | l <- [0..] ] 
--
-- * [1] Aaron Bronfman: Growth functions of a class of monoids. Preprint, 2001
--
bronfmanH :: Int -> [Int]
bronfmanH :: Int -> [Int]
bronfmanH Int
n = [[Int]]
bronfmanHsList [[Int]] -> Int -> [Int]
forall a. [a] -> Int -> a
!! Int
n

-- | An infinite list containing the Bronfman polynomials:
--
-- > bronfmanH n = bronfmanHsList !! n
--
bronfmanHsList :: [[Int]]
bronfmanHsList :: [[Int]]
bronfmanHsList = [[Int]]
list where
  list :: [[Int]]
list = (Int -> [Int]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Int]
go [Int
0..]
  go :: Int -> [Int]
go Int
0 = [Int
1]
  go Int
n = [[Int]] -> [Int]
forall a. Num a => [[a]] -> [a]
sumSeries [ Int -> [Int] -> [Int]
forall a b. (Integral a, Num b) => a -> [b] -> [b]
sgn Int
i ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate (Int -> Int
forall a. Integral a => a -> a
choose2 Int
i) Int
0 [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [[Int]]
list [[Int]] -> Int -> [Int]
forall a. [a] -> Int -> a
!! (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) | Int
i<-[Int
1..Int
n] ]
  sgn :: a -> [b] -> [b]
sgn a
i = if a -> Bool
forall a. Integral a => a -> Bool
odd a
i then [b] -> [b]
forall a. a -> a
id else (b -> b) -> [b] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map b -> b
forall a. Num a => a -> a
negate
  choose2 :: a -> a
choose2 a
k = a -> a -> a
forall a. Integral a => a -> a -> a
div (a
ka -> a -> a
forall a. Num a => a -> a -> a
*(a
ka -> a -> a
forall a. Num a => a -> a -> a
-a
1)) a
2

-- | Expands the reciprocial of @H(n)@ into an infinite power series,
-- giving the growth function of the positive braids on @n@ strands.
expandBronfmanH :: Int -> [Int]
expandBronfmanH :: Int -> [Int]
expandBronfmanH Int
n = [(Int, Int)] -> [Int]
forall a. Num a => [(a, Int)] -> [a]
pseries' ([Int] -> [(Int, Int)]
forall a b. (Eq a, Num a, Num b, Enum b) => [a] -> [(a, b)]
convertPoly ([Int] -> [(Int, Int)]) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
bronfmanH Int
n) where
  convertPoly :: [a] -> [(a, b)]
convertPoly (a
1:[a]
cs) = [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map a -> a
forall a. Num a => a -> a
negate [a]
cs) [b
1..]
   
--------------------------------------------------------------------------------
-- * ASCII diagram

instance KnownNat n => DrawASCII (Braid n) where
  ascii :: Braid n -> ASCII
ascii = Braid n -> ASCII
forall (n :: Nat). KnownNat n => Braid n -> ASCII
horizBraidASCII

-- | Horizontal braid diagram, drawn from left to right,
-- with strands numbered from the bottom to the top
horizBraidASCII :: KnownNat n => Braid n -> ASCII
horizBraidASCII :: Braid n -> ASCII
horizBraidASCII = Bool -> Braid n -> ASCII
forall (n :: Nat). KnownNat n => Bool -> Braid n -> ASCII
horizBraidASCII' Bool
True

-- | Horizontal braid diagram, drawn from left to right.
-- The boolean flag indicates whether to flip the strands
-- vertically ('True' means bottom-to-top, 'False' means top-to-bottom) 
horizBraidASCII' :: KnownNat n => Bool -> Braid n -> ASCII
horizBraidASCII' :: Bool -> Braid n -> ASCII
horizBraidASCII' Bool
flipped braid :: Braid n
braid@(Braid [BrGen]
gens) = ASCII
final where

  n :: Int
n = Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid
 
  final :: ASCII
final        = VAlign -> Int -> ASCII -> ASCII
vExtendWith VAlign
VTop Int
1 (ASCII -> ASCII) -> ASCII -> ASCII
forall a b. (a -> b) -> a -> b
$ [ASCII] -> ASCII
hCatTop [ASCII]
allBlocks
  allBlocks :: [ASCII]
allBlocks    = [ASCII]
prelude [ASCII] -> [ASCII] -> [ASCII]
forall a. [a] -> [a] -> [a]
++ [ASCII]
middleBlocks [ASCII] -> [ASCII] -> [ASCII]
forall a. [a] -> [a] -> [a]
++ [ASCII]
epilogue
  prelude :: [ASCII]
prelude      = [ ASCII
numberBlock   , ASCII
spaceBlock , ASCII
beginEndBlock ] 
  epilogue :: [ASCII]
epilogue     = [ ASCII
beginEndBlock , ASCII
spaceBlock , ASCII
numberBlock'  ]
  middleBlocks :: [ASCII]
middleBlocks = (BrGen -> ASCII) -> [BrGen] -> [ASCII]
forall a b. (a -> b) -> [a] -> [b]
map BrGen -> ASCII
block [BrGen]
gens 
  
  block :: BrGen -> ASCII
block BrGen
g = case BrGen
g of
    Sigma    Int
i -> Int -> [String] -> ASCII
block' Int
i ([String] -> ASCII) -> [String] -> ASCII
forall a b. (a -> b) -> a -> b
$ if Bool
flipped then [String]
over  else [String]
under
    SigmaInv Int
i -> Int -> [String] -> ASCII
block' Int
i ([String] -> ASCII) -> [String] -> ASCII
forall a b. (a -> b) -> a -> b
$ if Bool
flipped then [String]
under else [String]
over

  block' :: Int -> [String] -> ASCII
block' Int
i [String]
middle = [String] -> ASCII
asciiFromLines ([String] -> ASCII) -> [String] -> ASCII
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
2 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat 
                  ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [[String]]
forall a. Int -> a -> [a]
replicate Int
a [String]
horiz [[String]] -> [[String]] -> [[String]]
forall a. [a] -> [a] -> [a]
++ [[String]
space3, [String]
middle] [[String]] -> [[String]] -> [[String]]
forall a. [a] -> [a] -> [a]
++ Int -> [String] -> [[String]]
forall a. Int -> a -> [a]
replicate Int
b [String]
horiz
    where 
      (Int
a,Int
b) = if Bool
flipped then (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) else (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

  -- cycleN :: Int -> [a] -> [a]
  -- cycleN n = concat . replicate n

  spaceBlock :: ASCII
spaceBlock    = (Int, Int) -> ASCII
transparentBox (Int
1,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2)
  beginEndBlock :: ASCII
beginEndBlock = [String] -> ASCII
asciiFromLines ([String] -> ASCII) -> [String] -> ASCII
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
2 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [[String]]
forall a. Int -> a -> [a]
replicate Int
n [String]
horiz
  numberBlock :: ASCII
numberBlock   = [Int] -> ASCII
mkNumbers [Int
1..Int
n]
  numberBlock' :: ASCII
numberBlock'  = [Int] -> ASCII
mkNumbers ([Int] -> ASCII) -> [Int] -> ASCII
forall a b. (a -> b) -> a -> b
$ Permutation -> [Int]
P.fromPermutation (Permutation -> [Int]) -> Permutation -> [Int]
forall a b. (a -> b) -> a -> b
$ Braid n -> Permutation
forall (n :: Nat). KnownNat n => Braid n -> Permutation
braidPermutation Braid n
braid

  mkNumbers :: [Int] -> ASCII
  mkNumbers :: [Int] -> ASCII
mkNumbers [Int]
list = HAlign -> VSep -> [ASCII] -> ASCII
vCatWith HAlign
HRight (Int -> VSep
VSepSpaces Int
2) ([ASCII] -> ASCII) -> [ASCII] -> ASCII
forall a b. (a -> b) -> a -> b
$ (Int -> ASCII) -> [Int] -> [ASCII]
forall a b. (a -> b) -> [a] -> [b]
map Int -> ASCII
forall a. Show a => a -> ASCII
asciiShow 
                 ([Int] -> [ASCII]) -> [Int] -> [ASCII]
forall a b. (a -> b) -> a -> b
$ (if Bool
flipped then [Int] -> [Int]
forall a. [a] -> [a]
reverse else [Int] -> [Int]
forall a. a -> a
id) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int]
list

  under :: [String]
under  = [ String
"\\ /" , String
" / "  , String
"/ \\" ]
  over :: [String]
over   = [ String
"\\ /" , String
" \\ " , String
"/ \\" ]
  horiz :: [String]
horiz  = [ String
"   "  , String
"   "  , String
"___"  ]
  space3 :: [String]
space3 = [ String
"   "  , String
"   "  , String
"   "  ]

--------------------------------------------------------------------------------

{- this is unusably ugly and vertically loooong

-- | Vertical braid diagram, drawn from the top to the bottom.
-- Strands are numbered from the left to the right.
--
-- Writing down the strand numbers from the top and and the bottom
-- gives the two-line notation of the permutation realized by the braid.
--
verticalBraidASCII :: KnownNat n => Braid n -> ASCII
verticalBraidASCII braid@(Braid gens) = final where

  n = numberOfStrands braid
 
  final        = hExtendWith HLeft 1 $ vCatLeft allBlocks
  allBlocks    = prelude ++ middleBlocks ++ epilogue
  prelude      = [ numberBlock   , spaceBlock , beginEndBlock ] 
  epilogue     = [ beginEndBlock , spaceBlock , numberBlock'  ]
  middleBlocks = map block gens 
  
  block g = case g of
    Sigma    i -> block' i under
    SigmaInv i -> block' i over

  block' i middle = asciiFromLines (map f middle) where
    f xs = drop 1 $ concat $ h (i-1) ++ ["   ",xs] ++ h (n-i-1)
    h k  = replicate k "  |"

  spaceBlock    = transparentBox (n*3-2,1)
  beginEndBlock = asciiFromLines $ replicate 3 $ drop 1 $ concat (replicate n "  |")
  numberBlock   = mkNumbers [1..n]
  numberBlock'  = mkNumbers $ P.fromPermutation $ braidPermutation braid

  mkNumbers :: [Int] -> ASCII
  mkNumbers list = asciiFromString (drop 1 $ concatMap show3 list)
  show3 k = let s = show k 
            in  replicate (3-length s) ' ' ++ s

  under  = [ "\\ /" , " / "  , "/ \\" ]
  over   = [ "\\ /" , " \\ " , "/ \\" ]

-}

--------------------------------------------------------------------------------
-- * List of all words

-- | All positive braid words of the given length
allPositiveBraidWords :: KnownNat n => Int -> [Braid n]
allPositiveBraidWords :: Int -> [Braid n]
allPositiveBraidWords Int
l = [Braid n]
braids where
  n :: Int
n = Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands ([Braid n] -> Braid n
forall a. [a] -> a
head [Braid n]
braids)
  braids :: [Braid n]
braids = ([BrGen] -> Braid n) -> [[BrGen]] -> [Braid n]
forall a b. (a -> b) -> [a] -> [b]
map [BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid ([[BrGen]] -> [Braid n]) -> [[BrGen]] -> [Braid n]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> [[BrGen]]
_allPositiveBraidWords Int
n Int
l 

-- | All braid words of the given length
allBraidWords :: KnownNat n => Int -> [Braid n]
allBraidWords :: Int -> [Braid n]
allBraidWords Int
l = [Braid n]
braids where
  n :: Int
n = Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands ([Braid n] -> Braid n
forall a. [a] -> a
head [Braid n]
braids)
  braids :: [Braid n]
braids = ([BrGen] -> Braid n) -> [[BrGen]] -> [Braid n]
forall a b. (a -> b) -> [a] -> [b]
map [BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid ([[BrGen]] -> [Braid n]) -> [[BrGen]] -> [Braid n]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> [[BrGen]]
_allBraidWords Int
n Int
l 

-- | Untyped version of 'allPositiveBraidWords'
_allPositiveBraidWords :: Int -> Int -> [[BrGen]]
_allPositiveBraidWords :: Int -> Int -> [[BrGen]]
_allPositiveBraidWords Int
n = Int -> [[BrGen]]
go where
  go :: Int -> [[BrGen]]
go Int
0 = [[]]
  go Int
k = [ Int -> BrGen
Sigma Int
i BrGen -> [BrGen] -> [BrGen]
forall a. a -> [a] -> [a]
: [BrGen]
rest | Int
i<-[Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] , [BrGen]
rest <- Int -> [[BrGen]]
go (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) ]

-- | Untyped version of 'allBraidWords'
_allBraidWords :: Int -> Int -> [[BrGen]]
_allBraidWords :: Int -> Int -> [[BrGen]]
_allBraidWords Int
n = Int -> [[BrGen]]
go where
  go :: Int -> [[BrGen]]
go Int
0 = [[]]
  go Int
k = [ BrGen
gen BrGen -> [BrGen] -> [BrGen]
forall a. a -> [a] -> [a]
: [BrGen]
rest | BrGen
gen <- [BrGen]
gens , [BrGen]
rest <- Int -> [[BrGen]]
go (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) ]
  gens :: [BrGen]
gens = [[BrGen]] -> [BrGen]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [ Int -> BrGen
Sigma Int
i , Int -> BrGen
SigmaInv Int
i ] | Int
i<-[Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ]

--------------------------------------------------------------------------------
-- * Random braids  

-- | Random braid word of the given length
randomBraidWord :: (RandomGen g, KnownNat n) => Int -> g -> (Braid n, g)
randomBraidWord :: Int -> g -> (Braid n, g)
randomBraidWord Int
len g
g = (Braid n
braid, g
g') where
  braid :: Braid n
braid  = [BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid [BrGen]
w
  n :: Int
n      = Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid
  ([BrGen]
w,g
g') = Int -> Int -> g -> ([BrGen], g)
forall g. RandomGen g => Int -> Int -> g -> ([BrGen], g)
_randomBraidWord Int
n Int
len g
g

-- | Random /positive/ braid word of the given length
randomPositiveBraidWord :: (RandomGen g, KnownNat n) => Int -> g -> (Braid n, g)
randomPositiveBraidWord :: Int -> g -> (Braid n, g)
randomPositiveBraidWord Int
len g
g = (Braid n
braid, g
g') where
  braid :: Braid n
braid  = [BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid [BrGen]
w
  n :: Int
n      = Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid
  ([BrGen]
w,g
g') = Int -> Int -> g -> ([BrGen], g)
forall g. RandomGen g => Int -> Int -> g -> ([BrGen], g)
_randomPositiveBraidWord Int
n Int
len g
g

--------------------------------------------------------------------------------

-- | Given a braid word, we perturb it randomly @m@ times using the braid relations,
-- so that the resulting new braid word is equivalent to the original.
--
-- Useful for testing.
--
randomPerturbBraidWord :: forall n g. (RandomGen g, KnownNat n) => Int -> Braid n -> g -> (Braid n, g)
randomPerturbBraidWord :: Int -> Braid n -> g -> (Braid n, g)
randomPerturbBraidWord Int
m braid :: Braid n
braid@(Braid [BrGen]
xs) g
g = ([BrGen] -> Braid n
forall (n :: Nat). [BrGen] -> Braid n
Braid [BrGen]
word' , g
g') where

  ([BrGen]
word',g
g') = Int -> Int -> [BrGen] -> g -> ([BrGen], g)
go Int
m ([BrGen] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BrGen]
xs) [BrGen]
xs g
g 

  n :: Int
n = Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid

  -- | A random pair cancelling each other
  rndE :: g -> ([BrGen],g)
  rndE :: g -> ([BrGen], g)
rndE g
g = ([BrGen]
e1,g
g'') where
    (Int
i , g
g'  ) = (Int, Int) -> g -> (Int, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
1,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) g
g 
    (Bool
b , g
g'' ) = g -> (Bool, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random          g
g'
    e0 :: [BrGen]
e0 = [Int -> BrGen
SigmaInv Int
i, Int -> BrGen
Sigma Int
i] 
    e1 :: [BrGen]
e1 = if Bool
b then [BrGen] -> [BrGen]
forall a. [a] -> [a]
reverse [BrGen]
e0 else [BrGen]
e0

  brg :: Sign -> Int -> BrGen
brg    Sign
s Int
i = case Sign
s of { Sign
Plus -> Int -> BrGen
Sigma    Int
i ; Sign
Minus -> Int -> BrGen
SigmaInv Int
i }
  brginv :: Sign -> Int -> BrGen
brginv Sign
s Int
i = case Sign
s of { Sign
Plus -> Int -> BrGen
SigmaInv Int
i ; Sign
Minus -> Int -> BrGen
Sigma    Int
i }

  go :: Int -> Int -> [BrGen] -> g -> ([BrGen], g)
  go :: Int -> Int -> [BrGen] -> g -> ([BrGen], g)
go !Int
cnt !Int
len ![BrGen]
word !g
g 

    | Int
cnt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0   = ([BrGen]
word, g
g)

    | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
2   = let w' :: [BrGen]
w' = if Bool
b1 then ([BrGen]
e[BrGen] -> [BrGen] -> [BrGen]
forall a. [a] -> [a] -> [a]
++[BrGen]
word) else ([BrGen]
word[BrGen] -> [BrGen] -> [BrGen]
forall a. [a] -> [a] -> [a]
++[BrGen]
e)        -- if it is short, we just add a trivial pair somewhere
                   in  g -> Int -> [BrGen] -> ([BrGen], g)
continue g
g4 (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) [BrGen]
w'

    | Int -> Int
forall a. Num a => a -> a
abs (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
j) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2            = g -> Int -> [BrGen] -> ([BrGen], g)
continue g
g4  Int
len    ([BrGen]
as [BrGen] -> [BrGen] -> [BrGen]
forall a. [a] -> [a] -> [a]
++ BrGen
vBrGen -> [BrGen] -> [BrGen]
forall a. a -> [a] -> [a]
:BrGen
uBrGen -> [BrGen] -> [BrGen]
forall a. a -> [a] -> [a]
:[BrGen]
bs)         -- they commute, so we just commute them

    | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j Bool -> Bool -> Bool
&& Sign
sSign -> Sign -> Bool
forall a. Eq a => a -> a -> Bool
/=Sign
t            = g -> Int -> [BrGen] -> ([BrGen], g)
continue g
g4 (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2) ([BrGen]
as [BrGen] -> [BrGen] -> [BrGen]
forall a. [a] -> [a] -> [a]
++ [BrGen]
bs    )         -- they are inverse of each other, so we kill them

    | Int -> Int
forall a. Num a => a -> a
abs (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
j) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Sign
s Sign -> Sign -> Bool
forall a. Eq a => a -> a -> Bool
== Sign
t  = let mid :: [BrGen]
mid = if Bool
b1 
                                        then [ Sign -> Int -> BrGen
brg Sign
s Int
j , Sign -> Int -> BrGen
brg Sign
s Int
i , Sign -> Int -> BrGen
brg Sign
s Int
j , Sign -> Int -> BrGen
brginv Sign
s Int
i ]   -- insert pair and
                                        else [ Sign -> Int -> BrGen
brginv Sign
s Int
j , Sign -> Int -> BrGen
brg Sign
s Int
i , Sign -> Int -> BrGen
brg Sign
s Int
j , Sign -> Int -> BrGen
brg Sign
s Int
i ]   -- apply ternary relation 
                                  in  g -> Int -> [BrGen] -> ([BrGen], g)
continue g
g4 (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) ([BrGen]
as [BrGen] -> [BrGen] -> [BrGen]
forall a. [a] -> [a] -> [a]
++ [BrGen]
mid [BrGen] -> [BrGen] -> [BrGen]
forall a. [a] -> [a] -> [a]
++ [BrGen]
bs)

    | Bool
otherwise                 = let mid :: [BrGen]
mid = if Bool
b1
                                        then (BrGen
u BrGen -> [BrGen] -> [BrGen]
forall a. a -> [a] -> [a]
: [BrGen]
e [BrGen] -> [BrGen] -> [BrGen]
forall a. [a] -> [a] -> [a]
++ [BrGen
v])
                                        else if Bool
b2
                                          then [BrGen
u,BrGen
v] [BrGen] -> [BrGen] -> [BrGen]
forall a. [a] -> [a] -> [a]
++ [BrGen]
e
                                          else [BrGen]
e [BrGen] -> [BrGen] -> [BrGen]
forall a. [a] -> [a] -> [a]
++ [BrGen
u,BrGen
v]
                                  in g -> Int -> [BrGen] -> ([BrGen], g)
continue g
g4 (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) ([BrGen]
as[BrGen] -> [BrGen] -> [BrGen]
forall a. [a] -> [a] -> [a]
++(BrGen
uBrGen -> [BrGen] -> [BrGen]
forall a. a -> [a] -> [a]
:[BrGen]
e)[BrGen] -> [BrGen] -> [BrGen]
forall a. [a] -> [a] -> [a]
++[BrGen
v][BrGen] -> [BrGen] -> [BrGen]
forall a. [a] -> [a] -> [a]
++[BrGen]
bs)          -- otherwise we just insert an trivial pair         

    where

      (Int
pos         , g
g1 ) = (Int, Int) -> g -> (Int, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0,Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2) g
g
      (Bool
b1 :: Bool  , g
g2 ) = g -> (Bool, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random g
g1
      (Bool
b2 :: Bool  , g
g3 ) = g -> (Bool, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random g
g2
      ([BrGen]
e           , g
g4 ) = g -> ([BrGen], g)
rndE   g
g3
      ([BrGen]
as,BrGen
u:BrGen
v:[BrGen]
bs) = Int -> [BrGen] -> ([BrGen], [BrGen])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
pos [BrGen]
word
      (Sign
s,Int
i) = BrGen -> (Sign, Int)
brGenSignIdx BrGen
u
      (Sign
t,Int
j) = BrGen -> (Sign, Int)
brGenSignIdx BrGen
v
  
      continue :: g -> Int -> [BrGen] -> ([BrGen], g)
continue g
g' Int
len' [BrGen]
word' = Int -> Int -> [BrGen] -> g -> ([BrGen], g)
go (Int
cntInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
len' [BrGen]
word' g
g'

--------------------------------------------------------------------------------

-- | This version of 'randomBraidWord' may be convenient to avoid the type level stuff
withRandomBraidWord 
  :: RandomGen g 
  => (forall n. KnownNat n => Braid n -> a) 
  -> Int                -- ^ number of strands
  -> Int                -- ^ length of the random word
  -> g -> (a, g)
withRandomBraidWord :: (forall (n :: Nat). KnownNat n => Braid n -> a)
-> Int -> Int -> g -> (a, g)
withRandomBraidWord forall (n :: Nat). KnownNat n => Braid n -> a
f Int
n Int
len = Rand g a -> g -> (a, g)
forall g a. Rand g a -> g -> (a, g)
runRand (Rand g a -> g -> (a, g)) -> Rand g a -> g -> (a, g)
forall a b. (a -> b) -> a -> b
$ do
  (forall (n :: Nat). KnownNat n => Braid n -> a)
-> (forall (n :: Nat). KnownNat n => RandT g Identity (Braid n))
-> Int
-> Rand g a
forall (m :: * -> *) (f :: Nat -> *) int a.
(Integral int, Monad m) =>
(forall (n :: Nat). KnownNat n => f n -> a)
-> (forall (n :: Nat). KnownNat n => m (f n)) -> int -> m a
withSelectedM forall (n :: Nat). KnownNat n => Braid n -> a
f ((g -> (Braid n, g)) -> Rand g (Braid n)
forall g a. (g -> (a, g)) -> Rand g a
rand ((g -> (Braid n, g)) -> Rand g (Braid n))
-> (g -> (Braid n, g)) -> Rand g (Braid n)
forall a b. (a -> b) -> a -> b
$ Int -> g -> (Braid n, g)
forall g (n :: Nat).
(RandomGen g, KnownNat n) =>
Int -> g -> (Braid n, g)
randomBraidWord Int
len) Int
n

-- | This version of 'randomPositiveBraidWord' may be convenient to avoid the type level stuff
withRandomPositiveBraidWord 
  :: RandomGen g 
  => (forall n. KnownNat n => Braid n -> a) 
  -> Int                -- ^ number of strands
  -> Int                -- ^ length of the random word
  -> g -> (a, g)
withRandomPositiveBraidWord :: (forall (n :: Nat). KnownNat n => Braid n -> a)
-> Int -> Int -> g -> (a, g)
withRandomPositiveBraidWord forall (n :: Nat). KnownNat n => Braid n -> a
f Int
n Int
len = Rand g a -> g -> (a, g)
forall g a. Rand g a -> g -> (a, g)
runRand (Rand g a -> g -> (a, g)) -> Rand g a -> g -> (a, g)
forall a b. (a -> b) -> a -> b
$ do
  (forall (n :: Nat). KnownNat n => Braid n -> a)
-> (forall (n :: Nat). KnownNat n => RandT g Identity (Braid n))
-> Int
-> Rand g a
forall (m :: * -> *) (f :: Nat -> *) int a.
(Integral int, Monad m) =>
(forall (n :: Nat). KnownNat n => f n -> a)
-> (forall (n :: Nat). KnownNat n => m (f n)) -> int -> m a
withSelectedM forall (n :: Nat). KnownNat n => Braid n -> a
f ((g -> (Braid n, g)) -> Rand g (Braid n)
forall g a. (g -> (a, g)) -> Rand g a
rand ((g -> (Braid n, g)) -> Rand g (Braid n))
-> (g -> (Braid n, g)) -> Rand g (Braid n)
forall a b. (a -> b) -> a -> b
$ Int -> g -> (Braid n, g)
forall g (n :: Nat).
(RandomGen g, KnownNat n) =>
Int -> g -> (Braid n, g)
randomPositiveBraidWord Int
len) Int
n

-- | Untyped version of 'randomBraidWord'
_randomBraidWord 
  :: (RandomGen g) 
  => Int                -- ^ number of strands
  -> Int                -- ^ length of the random word
  -> g -> ([BrGen], g)
_randomBraidWord :: Int -> Int -> g -> ([BrGen], g)
_randomBraidWord Int
n Int
len = Rand g [BrGen] -> g -> ([BrGen], g)
forall g a. Rand g a -> g -> (a, g)
runRand (Rand g [BrGen] -> g -> ([BrGen], g))
-> Rand g [BrGen] -> g -> ([BrGen], g)
forall a b. (a -> b) -> a -> b
$ Int -> RandT g Identity BrGen -> Rand g [BrGen]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len (RandT g Identity BrGen -> Rand g [BrGen])
-> RandT g Identity BrGen -> Rand g [BrGen]
forall a b. (a -> b) -> a -> b
$ do
  Int
k <- (Int, Int) -> Rand g Int
forall g a. (RandomGen g, Random a) => (a, a) -> Rand g a
randChoose (Int
1,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
  Sign
s <- Rand g Sign
forall g a. (RandomGen g, Random a) => Rand g a
randRoll
  BrGen -> RandT g Identity BrGen
forall (m :: * -> *) a. Monad m => a -> m a
return (BrGen -> RandT g Identity BrGen)
-> BrGen -> RandT g Identity BrGen
forall a b. (a -> b) -> a -> b
$ case Sign
s of
    Sign
Plus  -> Int -> BrGen
Sigma Int
k
    Sign
Minus -> Int -> BrGen
SigmaInv Int
k

-- | Untyped version of 'randomPositiveBraidWord'
_randomPositiveBraidWord 
  :: (RandomGen g) 
  => Int             -- ^ number of strands
  -> Int             -- ^ length of the random word
  -> g -> ([BrGen], g)
_randomPositiveBraidWord :: Int -> Int -> g -> ([BrGen], g)
_randomPositiveBraidWord Int
n Int
len = Rand g [BrGen] -> g -> ([BrGen], g)
forall g a. Rand g a -> g -> (a, g)
runRand (Rand g [BrGen] -> g -> ([BrGen], g))
-> Rand g [BrGen] -> g -> ([BrGen], g)
forall a b. (a -> b) -> a -> b
$ Int -> RandT g Identity BrGen -> Rand g [BrGen]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len (RandT g Identity BrGen -> Rand g [BrGen])
-> RandT g Identity BrGen -> Rand g [BrGen]
forall a b. (a -> b) -> a -> b
$ do
  (Int -> BrGen) -> RandT g Identity Int -> RandT g Identity BrGen
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int -> BrGen
Sigma (RandT g Identity Int -> RandT g Identity BrGen)
-> RandT g Identity Int -> RandT g Identity BrGen
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> RandT g Identity Int
forall g a. (RandomGen g, Random a) => (a, a) -> Rand g a
randChoose (Int
1,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)

--------------------------------------------------------------------------------