-- | Normal form of braids, take 1.
--
-- We implement the Adyan-Thurston-ElRifai-Morton solution to the word problem in braid groups.
--
--
-- Based on:
--
-- * [1] Joan S. Birman, Tara E. Brendle: BRAIDS - A SURVEY
--   <https://www.math.columbia.edu/~jb/Handbook-21.pdf> (chapter 5.1)
--
-- * [2] Elsayed A. Elrifai, Hugh R. Morton: Algorithms for positive braids
--

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

module Math.Combinat.Groups.Braid.NF  
  ( -- * Normal form
    BraidNF (..)
  , nfReprWord
  , braidNormalForm
  , braidNormalForm'
  , braidNormalFormNaive'
    -- * Starting and finishing sets
  , permWordStartingSet
  , permWordFinishingSet    
  , permutationStartingSet
  , permutationFinishingSet    
  )
  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 Math.Combinat.Helper
import Math.Combinat.Sign

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

import Math.Combinat.Groups.Braid

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

-- | A unique normal form for braids, called the /left-greedy normal form/.
-- It looks like @Delta^i*P@, where @Delta@ is the positive half-twist, @i@ is an integer,
-- and @P@ is a positive word, which can be further decomposed into non-@Delta@ /permutation words/; 
-- these words themselves are not unique, but the permutations they realize /are/ unique.
--
-- This will solve the word problem relatively fast, 
-- though it is not the fastest known algorithm.
--
data BraidNF (n :: Nat) = BraidNF
  { BraidNF n -> Int
_nfDeltaExp :: !Int              -- ^ the exponent of @Delta@
  , BraidNF n -> [Permutation]
_nfPerms    :: [Permutation]     -- ^ the permutations
  }
  deriving (BraidNF n -> BraidNF n -> Bool
(BraidNF n -> BraidNF n -> Bool)
-> (BraidNF n -> BraidNF n -> Bool) -> Eq (BraidNF n)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (n :: Nat). BraidNF n -> BraidNF n -> Bool
/= :: BraidNF n -> BraidNF n -> Bool
$c/= :: forall (n :: Nat). BraidNF n -> BraidNF n -> Bool
== :: BraidNF n -> BraidNF n -> Bool
$c== :: forall (n :: Nat). BraidNF n -> BraidNF n -> Bool
Eq,Eq (BraidNF n)
Eq (BraidNF n)
-> (BraidNF n -> BraidNF n -> Ordering)
-> (BraidNF n -> BraidNF n -> Bool)
-> (BraidNF n -> BraidNF n -> Bool)
-> (BraidNF n -> BraidNF n -> Bool)
-> (BraidNF n -> BraidNF n -> Bool)
-> (BraidNF n -> BraidNF n -> BraidNF n)
-> (BraidNF n -> BraidNF n -> BraidNF n)
-> Ord (BraidNF n)
BraidNF n -> BraidNF n -> Bool
BraidNF n -> BraidNF n -> Ordering
BraidNF n -> BraidNF n -> BraidNF n
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
forall (n :: Nat). Eq (BraidNF n)
forall (n :: Nat). BraidNF n -> BraidNF n -> Bool
forall (n :: Nat). BraidNF n -> BraidNF n -> Ordering
forall (n :: Nat). BraidNF n -> BraidNF n -> BraidNF n
min :: BraidNF n -> BraidNF n -> BraidNF n
$cmin :: forall (n :: Nat). BraidNF n -> BraidNF n -> BraidNF n
max :: BraidNF n -> BraidNF n -> BraidNF n
$cmax :: forall (n :: Nat). BraidNF n -> BraidNF n -> BraidNF n
>= :: BraidNF n -> BraidNF n -> Bool
$c>= :: forall (n :: Nat). BraidNF n -> BraidNF n -> Bool
> :: BraidNF n -> BraidNF n -> Bool
$c> :: forall (n :: Nat). BraidNF n -> BraidNF n -> Bool
<= :: BraidNF n -> BraidNF n -> Bool
$c<= :: forall (n :: Nat). BraidNF n -> BraidNF n -> Bool
< :: BraidNF n -> BraidNF n -> Bool
$c< :: forall (n :: Nat). BraidNF n -> BraidNF n -> Bool
compare :: BraidNF n -> BraidNF n -> Ordering
$ccompare :: forall (n :: Nat). BraidNF n -> BraidNF n -> Ordering
$cp1Ord :: forall (n :: Nat). Eq (BraidNF n)
Ord,Int -> BraidNF n -> ShowS
[BraidNF n] -> ShowS
BraidNF n -> String
(Int -> BraidNF n -> ShowS)
-> (BraidNF n -> String)
-> ([BraidNF n] -> ShowS)
-> Show (BraidNF n)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (n :: Nat). Int -> BraidNF n -> ShowS
forall (n :: Nat). [BraidNF n] -> ShowS
forall (n :: Nat). BraidNF n -> String
showList :: [BraidNF n] -> ShowS
$cshowList :: forall (n :: Nat). [BraidNF n] -> ShowS
show :: BraidNF n -> String
$cshow :: forall (n :: Nat). BraidNF n -> String
showsPrec :: Int -> BraidNF n -> ShowS
$cshowsPrec :: forall (n :: Nat). Int -> BraidNF n -> ShowS
Show)

-- | A braid word representing the given normal form
nfReprWord :: KnownNat n => BraidNF n -> Braid n
nfReprWord :: BraidNF n -> Braid n
nfReprWord (BraidNF Int
k [Permutation]
perms) = 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
$ [Braid n] -> Braid n
forall (n :: Nat). [Braid n] -> Braid n
composeMany ([Braid n]
deltas [Braid n] -> [Braid n] -> [Braid n]
forall a. [a] -> [a] -> [a]
++ [Braid n]
rest) where

  deltas :: [Braid n]
deltas 
    | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0     = Int -> Braid n -> [Braid n]
forall a. Int -> a -> [a]
replicate   Int
k           Braid n
forall (n :: Nat). KnownNat n => Braid n
halfTwist
    | Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0     = Int -> Braid n -> [Braid n]
forall a. Int -> a -> [a]
replicate (-Int
k) (Braid n -> Braid n
forall (n :: Nat). Braid n -> Braid n
inverse Braid n
forall (n :: Nat). KnownNat n => Braid n
halfTwist)
    | Bool
otherwise = []

  rest :: [Braid n]
rest = (Permutation -> Braid n) -> [Permutation] -> [Braid n]
forall a b. (a -> b) -> [a] -> [b]
map Permutation -> Braid n
forall (n :: Nat). KnownNat n => Permutation -> Braid n
permutationBraid [Permutation]
perms

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

-- | Computes the normal form of a braid. We apply free reduction first, it should be faster that way.
braidNormalForm :: KnownNat n => Braid n -> BraidNF n
braidNormalForm :: Braid n -> BraidNF n
braidNormalForm = Braid n -> BraidNF n
forall (n :: Nat). KnownNat n => Braid n -> BraidNF n
braidNormalForm' (Braid n -> BraidNF n)
-> (Braid n -> Braid n) -> Braid n -> BraidNF n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Braid n -> Braid n
forall (n :: Nat). Braid n -> Braid n
freeReduceBraidWord

-- | This function does not apply free reduction before computing the normal form
braidNormalForm' :: KnownNat n => Braid n -> BraidNF n
braidNormalForm' :: Braid n -> BraidNF n
braidNormalForm' braid :: Braid n
braid@(Braid [BrGen]
gens) = Int -> [Permutation] -> BraidNF n
forall (n :: Nat). Int -> [Permutation] -> BraidNF n
BraidNF (Int
dexpInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
pexp) [Permutation]
perms where
  n :: Int
n = Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid
  invless :: [XGen]
invless = Int -> [BrGen] -> [XGen]
replaceInverses Int
n [BrGen]
gens
  (Int
dexp,[XGen]
posxword) = Int -> [XGen] -> (Int, [XGen])
moveDeltasLeft Int
n [XGen]
invless
  factors :: [[Int]]
factors = Int -> [Int] -> [[Int]]
leftGreedyFactors Int
n ([Int] -> [[Int]]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ Int -> [XGen] -> [Int]
expandPosXWord Int
n [XGen]
posxword
  (Int
pexp,[Permutation]
perms) = Int -> [Permutation] -> (Int, [Permutation])
normalizePermFactors Int
n ([Permutation] -> (Int, [Permutation]))
-> [Permutation] -> (Int, [Permutation])
forall a b. (a -> b) -> a -> b
$ ([Int] -> Permutation) -> [[Int]] -> [Permutation]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [Int] -> Permutation
_braidPermutation Int
n) [[Int]]
factors

-- | This one uses the naive inverse replacement method. Probably somewhat slower than 'braidNormalForm''.
braidNormalFormNaive' :: KnownNat n => Braid n -> BraidNF n
braidNormalFormNaive' :: Braid n -> BraidNF n
braidNormalFormNaive' braid :: Braid n
braid@(Braid [BrGen]
gens) = Int -> [Permutation] -> BraidNF n
forall (n :: Nat). Int -> [Permutation] -> BraidNF n
BraidNF (Int
dexpInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
pexp) [Permutation]
perms where
  n :: Int
n = Braid n -> Int
forall (n :: Nat). KnownNat n => Braid n -> Int
numberOfStrands Braid n
braid
  invless :: [XGen]
invless = [BrGen] -> [XGen]
replaceInversesNaive [BrGen]
gens
  (Int
dexp,[XGen]
posxword) = Int -> [XGen] -> (Int, [XGen])
moveDeltasLeft Int
n [XGen]
invless
  factors :: [[Int]]
factors = Int -> [Int] -> [[Int]]
leftGreedyFactors Int
n ([Int] -> [[Int]]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ Int -> [XGen] -> [Int]
expandPosXWord Int
n [XGen]
posxword
  (Int
pexp,[Permutation]
perms) = Int -> [Permutation] -> (Int, [Permutation])
normalizePermFactors Int
n ([Permutation] -> (Int, [Permutation]))
-> [Permutation] -> (Int, [Permutation])
forall a b. (a -> b) -> a -> b
$ ([Int] -> Permutation) -> [[Int]] -> [Permutation]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [Int] -> Permutation
_braidPermutation Int
n) [[Int]]
factors

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

-- | Replaces groups of @sigma_i^-1@ generators by @(Delta^-1 * P)@, 
-- where @P@ is a positive word.
--
-- This should be more clever (resulting in shorter words) than the naive version below
--
replaceInverses :: Int -> [BrGen] -> [XGen]
replaceInverses :: Int -> [BrGen] -> [XGen]
replaceInverses Int
n [BrGen]
gens = [BrGen] -> [XGen]
worker [BrGen]
gens where

  worker :: [BrGen] -> [XGen]
worker [] = []
  worker [BrGen]
xs = [BrGen] -> [XGen]
replaceNegs [BrGen]
neg [XGen] -> [XGen] -> [XGen]
forall a. [a] -> [a] -> [a]
++ (BrGen -> XGen) -> [BrGen] -> [XGen]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> XGen
XSigma (Int -> XGen) -> (BrGen -> Int) -> BrGen -> XGen
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BrGen -> Int
brGenIdx) [BrGen]
pos [XGen] -> [XGen] -> [XGen]
forall a. [a] -> [a] -> [a]
++ [BrGen] -> [XGen]
worker [BrGen]
rest where 
    ([BrGen]
neg,[BrGen]
tmp ) = (BrGen -> Bool) -> [BrGen] -> ([BrGen], [BrGen])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Sign -> Bool
isMinus (Sign -> Bool) -> (BrGen -> Sign) -> BrGen -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BrGen -> Sign
brGenSign) [BrGen]
xs
    ([BrGen]
pos,[BrGen]
rest) = (BrGen -> Bool) -> [BrGen] -> ([BrGen], [BrGen])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Sign -> Bool
isPlus  (Sign -> Bool) -> (BrGen -> Sign) -> BrGen -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BrGen -> Sign
brGenSign) [BrGen]
tmp
  
  replaceNegs :: [BrGen] -> [XGen]
replaceNegs [BrGen]
gs = ([Int] -> [XGen]) -> [[Int]] -> [XGen]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Int] -> [XGen]
replaceFac [[Int]]
facs where
    facs :: [[Int]]
facs = Int -> [Int] -> [[Int]]
leftGreedyFactors Int
n ([Int] -> [[Int]]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ (BrGen -> Int) -> [BrGen] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map BrGen -> Int
brGenIdx [BrGen]
gs
  
  replaceFac :: [Int] -> [XGen]
replaceFac [Int]
idxs = Int -> XGen
XDelta (-Int
1) XGen -> [XGen] -> [XGen]
forall a. a -> [a] -> [a]
: (Int -> XGen) -> [Int] -> [XGen]
forall a b. (a -> b) -> [a] -> [b]
map Int -> XGen
XSigma (Permutation -> [Int]
_permutationBraid Permutation
perm) where
    perm :: Permutation
perm = (Int -> Permutation
P.reversePermutation Int
n) Permutation -> Permutation -> Permutation
`P.multiplyPermutation` (Int -> [Int] -> Permutation
P.adjacentTranspositions Int
n [Int]
idxs)


-- | Replaces @sigma_i^-1@ generators by @(Delta^-1 * L_i)@.
replaceInversesNaive :: [BrGen] -> [XGen]
replaceInversesNaive :: [BrGen] -> [XGen]
replaceInversesNaive [BrGen]
gens = (BrGen -> [XGen]) -> [BrGen] -> [XGen]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BrGen -> [XGen]
f [BrGen]
gens where 
  f :: BrGen -> [XGen]
f (Sigma    Int
i) = [ Int -> XGen
XSigma Int
i ]
  f (SigmaInv Int
i) = [ Int -> XGen
XDelta (-Int
1) , Int -> XGen
XL Int
i ]

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

-- | Temporary data structure to be used during the normal form computation
data XGen
  = XDelta !Int   -- ^ @Delta^k@
  | XSigma !Int   -- ^ @Sigma_j@
  | XL     !Int   -- ^ @L_j = Delta * sigma_j^-1@
  | XTauL  !Int   -- ^ @tau(L_j)@
  deriving (XGen -> XGen -> Bool
(XGen -> XGen -> Bool) -> (XGen -> XGen -> Bool) -> Eq XGen
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: XGen -> XGen -> Bool
$c/= :: XGen -> XGen -> Bool
== :: XGen -> XGen -> Bool
$c== :: XGen -> XGen -> Bool
Eq,Int -> XGen -> ShowS
[XGen] -> ShowS
XGen -> String
(Int -> XGen -> ShowS)
-> (XGen -> String) -> ([XGen] -> ShowS) -> Show XGen
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [XGen] -> ShowS
$cshowList :: [XGen] -> ShowS
show :: XGen -> String
$cshow :: XGen -> String
showsPrec :: Int -> XGen -> ShowS
$cshowsPrec :: Int -> XGen -> ShowS
Show)

isXDelta :: XGen -> Bool
isXDelta :: XGen -> Bool
isXDelta XGen
x = case XGen
x of { XDelta {} -> Bool
True ; XGen
_ -> Bool
False }

-- | We move the all @Delta@'s to the left
moveDeltasLeft :: Int -> [XGen] -> (Int,[XGen])
moveDeltasLeft :: Int -> [XGen] -> (Int, [XGen])
moveDeltasLeft Int
n [XGen]
input = (Int
finalExp, [XGen]
finalPosWord) where
  
  (XDelta Int
finalExp : [XGen]
finalPosWord) =  [XGen] -> [XGen]
forall a. [a] -> [a]
reverse ([XGen] -> [XGen]) -> [XGen] -> [XGen]
forall a b. (a -> b) -> a -> b
$ Int -> [XGen] -> [XGen]
worker Int
0 ([XGen] -> [XGen]
forall a. [a] -> [a]
reverse [XGen]
input) 

  -- we start from the right end, and work towards the left end
  worker :: Int -> [XGen] -> [XGen]
worker  Int
dexp [] = [ Int -> XGen
XDelta Int
dexp ]
  worker !Int
dexp [XGen]
xs = [XGen]
this' [XGen] -> [XGen] -> [XGen]
forall a. [a] -> [a] -> [a]
++ Int -> [XGen] -> [XGen]
worker Int
dexp' [XGen]
rest where 
    ([XGen]
delta,[XGen]
notdelta) = (XGen -> Bool) -> [XGen] -> ([XGen], [XGen])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span XGen -> Bool
isXDelta [XGen]
xs
    ([XGen]
this ,[XGen]
rest    ) = (XGen -> Bool) -> [XGen] -> ([XGen], [XGen])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Bool -> Bool
not (Bool -> Bool) -> (XGen -> Bool) -> XGen -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XGen -> Bool
isXDelta) [XGen]
notdelta
    dexp' :: Int
dexp' = Int
dexp Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [XGen] -> Int
sumDeltas [XGen]
delta
    this' :: [XGen]
this' = if Int -> Bool
forall a. Integral a => a -> Bool
even Int
dexp' 
      then [XGen]
this
      else (XGen -> XGen) -> [XGen] -> [XGen]
forall a b. (a -> b) -> [a] -> [b]
map XGen -> XGen
xtau [XGen]
this

  sumDeltas :: [XGen] -> Int
  sumDeltas :: [XGen] -> Int
sumDeltas [XGen]
xs = (Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0 [ Int
k | XDelta Int
k <- [XGen]
xs ]

  -- | The @X -> Delta^-1 * X * Delta@ inner automorphism
  xtau :: XGen -> XGen
  xtau :: XGen -> XGen
xtau (XSigma Int
j) = Int -> XGen
XSigma (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
j)
  xtau (XDelta Int
k) = Int -> XGen
XDelta Int
k  
  xtau (XL     Int
k) = Int -> XGen
XTauL  Int
k  
  xtau (XTauL  Int
k) = Int -> XGen
XL     Int
k  

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

-- | Expands a /positive/ \"X-word\" into a positive braid word
expandPosXWord :: Int -> [XGen] -> [Int]
expandPosXWord :: Int -> [XGen] -> [Int]
expandPosXWord Int
n = (XGen -> [Int]) -> [XGen] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap XGen -> [Int]
f where

  posHalfTwist :: [Int]
posHalfTwist = Int -> [Int]
_halfTwist Int
n

  jtau :: Int -> Int
  jtau :: Int -> Int
jtau Int
j = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
j

  posLTable :: Array Int [Int]
posLTable    = (Int, Int) -> [[Int]] -> Array Int [Int]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
1,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [ Permutation -> [Int]
_permutationBraid (Int -> Int -> Permutation
posLPerm Int
n Int
i) | Int
i<-[Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ] :: Array Int [Int]
  posTauLTable :: Array Int [Int]
posTauLTable = ([Int] -> [Int]) -> Array Int [Int] -> Array Int [Int]
forall (a :: * -> * -> *) e' e i.
(IArray a e', IArray a e, Ix i) =>
(e' -> e) -> a i e' -> a i e
amap ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Int
jtau) Array Int [Int]
posLTable

  -- posRTable = listArray (1,n-1) [ _permutationBraid (posRPerm n i) | i<-[1..n-1] ] :: Array Int [Int]

  f :: XGen -> [Int]
f XGen
x = case XGen
x of
    XSigma Int
i -> [Int
i]
    XL     Int
i -> Array Int [Int]
posLTable    Array Int [Int] -> Int -> [Int]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
i
    XTauL  Int
i -> Array Int [Int]
posTauLTable Array Int [Int] -> Int -> [Int]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
i
    XDelta Int
i 
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0     -> [[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Int -> [Int] -> [[Int]]
forall a. Int -> a -> [a]
replicate Int
i [Int]
posHalfTwist)
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0     -> String -> [Int]
forall a. HasCallStack => String -> a
error String
"expandPosXWord: negative delta power"
      | Bool
otherwise -> []

  -- word :: Braid n -> [Int]
  -- word (Braid gens) = map brGenIdx gens


-- | Expands an \"X-word\" into a braid word. Useful for debugging.
expandAnyXWord :: forall n. KnownNat n => [XGen] -> Braid n
expandAnyXWord :: [XGen] -> Braid n
expandAnyXWord [XGen]
xgens = 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 = [Braid n] -> Braid n
forall (n :: Nat). [Braid n] -> Braid n
composeMany ((XGen -> Braid n) -> [XGen] -> [Braid n]
forall a b. (a -> b) -> [a] -> [b]
map XGen -> Braid n
f [XGen]
xgens)

  posHalfTwist :: Braid n
posHalfTwist = Braid n
forall (n :: Nat). KnownNat n => Braid n
halfTwist            :: Braid n
  negHalfTwist :: Braid n
negHalfTwist = Braid n -> Braid n
forall (n :: Nat). Braid n -> Braid n
inverse Braid n
posHalfTwist :: Braid n

  posLTable :: Array Int (Braid n)
posLTable    = (Int, Int) -> [Braid n] -> Array Int (Braid n)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
1,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) [ Permutation -> Braid n
forall (n :: Nat). KnownNat n => Permutation -> Braid n
permutationBraid (Int -> Int -> Permutation
posLPerm Int
n Int
i) | Int
i<-[Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ] :: Array Int (Braid n)
  posTauLTable :: Array Int (Braid n)
posTauLTable = (Braid n -> Braid n) -> Array Int (Braid n) -> Array Int (Braid n)
forall (a :: * -> * -> *) e' e i.
(IArray a e', IArray a e, Ix i) =>
(e' -> e) -> a i e' -> a i e
amap Braid n -> Braid n
forall (n :: Nat). KnownNat n => Braid n -> Braid n
tau Array Int (Braid n)
posLTable

  -- posRTable = listArray (1,n-1) [ permutationBraid (posRPerm n i) | i<-[1..n-1] ] :: Array Int (Braid n)

  f :: XGen -> Braid n
  f :: XGen -> Braid n
f XGen
x = case XGen
x of
    XSigma Int
i -> Int -> Braid n
forall (n :: Nat). KnownNat n => Int -> Braid n
sigma Int
i
    XL     Int
i -> Array Int (Braid n)
posLTable    Array Int (Braid n) -> Int -> Braid n
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
i
    XTauL  Int
i -> Array Int (Braid n)
posTauLTable Array Int (Braid n) -> Int -> Braid n
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Int
i
    XDelta Int
i 
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0     -> [Braid n] -> Braid n
forall (n :: Nat). [Braid n] -> Braid n
composeMany (Int -> Braid n -> [Braid n]
forall a. Int -> a -> [a]
replicate   Int
i  Braid n
posHalfTwist)
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0     -> [Braid n] -> Braid n
forall (n :: Nat). [Braid n] -> Braid n
composeMany (Int -> Braid n -> [Braid n]
forall a. Int -> a -> [a]
replicate (-Int
i) Braid n
negHalfTwist)
      | Bool
otherwise -> Braid n
forall (n :: Nat). Braid n
identity

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

-- | @posL k@ (denoted as @L_k@) is a /positive word/ which 
-- satisfies @Delta = L_k * sigma_k@, or:
-- 
-- > (inverse halfTwist) `compose` (posL k) ~=~ sigmaInv k@
-- 
-- Thus we can replace any word with a positive word plus some @Delta^-1@\'s
--
posL :: KnownNat n => Int -> Braid n
posL :: Int -> Braid n
posL Int
k = 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 = Permutation -> Braid n
forall (n :: Nat). KnownNat n => Permutation -> Braid n
permutationBraid (Int -> Int -> Permutation
posLPerm Int
n Int
k)

-- | @posR k n@ (denoted as @R_k@) is a /permutation braid/ which 
-- satisfies @Delta = sigma_k * R_k@
-- 
-- > (posR k) `compose` (inverse halfTwist) ~=~ sigmaInv k@
-- 
-- Thus we can replace any word with a positive word plus some @Delta^-1@'s
--
posR :: KnownNat n => Int -> Braid n
posR :: Int -> Braid n
posR Int
k = 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 = Permutation -> Braid n
forall (n :: Nat). KnownNat n => Permutation -> Braid n
permutationBraid (Int -> Int -> Permutation
posRPerm Int
n Int
k)

-- | The permutation @posL k :: Braid n@ is realizing
posLPerm :: Int -> Int -> Permutation
posLPerm :: Int -> Int -> Permutation
posLPerm Int
n Int
k 
  | Int
kInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0 Bool -> Bool -> Bool
&& Int
kInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
n  = (Int -> Permutation
P.reversePermutation Int
n Permutation -> Permutation -> Permutation
`P.multiplyPermutation` Int -> Int -> Permutation
P.adjacentTransposition Int
n Int
k)
  | Bool
otherwise   = String -> Permutation
forall a. HasCallStack => String -> a
error String
"posLPerm: index out of range"

-- | The permutation @posR k :: Braid n@ is realizing
posRPerm :: Int -> Int -> Permutation
posRPerm :: Int -> Int -> Permutation
posRPerm Int
n Int
k 
  | Int
kInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0 Bool -> Bool -> Bool
&& Int
kInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
n  = (Int -> Int -> Permutation
P.adjacentTransposition Int
n Int
k Permutation -> Permutation -> Permutation
`P.multiplyPermutation` Int -> Permutation
P.reversePermutation Int
n )
  | Bool
otherwise   = String -> Permutation
forall a. HasCallStack => String -> a
error String
"posRPerm: index out of range"

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

-- | We recognize left-greedy factors which are @Delta@-s (easy, since they are the only ones
-- with length @(n choose 2)@), and move them to the left, returning their summed exponent
-- and the filtered new factors. We also filter trivial permutations (which should only happen 
-- for the trivial braid, but it happens there?)
--
filterDeltaFactors :: Int -> [[Int]] -> (Int, [[Int]])
filterDeltaFactors :: Int -> [[Int]] -> (Int, [[Int]])
filterDeltaFactors Int
n [[Int]]
facs = (Int
exp',[[Int]]
facs'') where

  (Int
exp',[[Int]]
facs') = Int -> [[Int]] -> (Int, [[Int]])
forall a. Integral a => a -> [[Int]] -> (a, [[Int]])
go Int
0 ([[Int]] -> [[Int]]
forall a. [a] -> [a]
reverse [[Int]]
facs)

  jtau :: Int -> Int
jtau Int
j = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
j
  facs'' :: [[Int]]
facs'' = [[Int]] -> [[Int]]
forall a. [a] -> [a]
reverse [[Int]]
facs'
  maxlen :: Int
maxlen = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
*(Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) Int
2

  go :: a -> [[Int]] -> (a, [[Int]])
go !a
e []       = (a
e,[])
  go !a
e ([Int]
xs:[[Int]]
xxs)  
    | [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
xs             = a -> [[Int]] -> (a, [[Int]])
go a
e [[Int]]
xxs
    | [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
maxlen = a -> [[Int]] -> (a, [[Int]])
go (a
ea -> a -> a
forall a. Num a => a -> a -> a
+a
1) [[Int]]
xxs
    | Bool
otherwise           =  
        if a -> Bool
forall a. Integral a => a -> Bool
even a
e
          then let (a
e',[[Int]]
yys) = a -> [[Int]] -> (a, [[Int]])
go a
e [[Int]]
xxs in (a
e' ,          [Int]
xs [Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
: [[Int]]
yys) 
          else let (a
e',[[Int]]
yys) = a -> [[Int]] -> (a, [[Int]])
go a
e [[Int]]
xxs in (a
e' , (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Int
jtau [Int]
xs [Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
: [[Int]]
yys)  

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

-- | The /starting set/ of a positive braid P is the subset of @[1..n-1]@ defined by
-- 
-- > S(P) = [ i | P = sigma_i * Q , Q is positive ] = [ i | (sigma_i^-1 * P) is positive ] 
--
-- This function returns the starting set a positive word, assuming it 
-- is a /permutation braid/ (see Lemma 2.4 in [2])
--
permWordStartingSet :: Int -> [Int] -> [Int]
permWordStartingSet :: Int -> [Int] -> [Int]
permWordStartingSet Int
n [Int]
xs = Int -> [Int] -> [Int]
permWordFinishingSet Int
n ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
xs)

-- | The /finishing set/ of a positive braid P is the subset of @[1..n-1]@ defined by
-- 
-- > F(P) = [ i | P = Q * sigma_i , Q is positive ] = [ i | (P * sigma_i^-1) is positive ] 
--
-- This function returns the finishing set, assuming the input is a /permutation braid/
--
permWordFinishingSet :: Int -> [Int] -> [Int]
permWordFinishingSet :: Int -> [Int] -> [Int]
permWordFinishingSet Int
n [Int]
input = (forall s. ST s [Int]) -> [Int]
forall a. (forall s. ST s a) -> a
runST forall s. ST s [Int]
action where

  action :: forall s. ST s [Int]
  action :: ST s [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
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
input ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \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
    ((Int -> ST s Bool) -> [Int] -> ST s [Int])
-> [Int] -> (Int -> ST s Bool) -> ST s [Int]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> ST s Bool) -> [Int] -> ST s [Int]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM [Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> ST s Bool) -> ST s [Int])
-> (Int -> ST s Bool) -> ST s [Int]
forall a b. (a -> b) -> a -> b
$ \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) 
      Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
bInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
a)                    -- Lemma 2.4 in [2]

-- | This satisfies
-- 
-- > permutationStartingSet p == permWordStartingSet n (_permutationBraid p)
--
permutationStartingSet :: Permutation -> [Int]
permutationStartingSet :: Permutation -> [Int]
permutationStartingSet = Permutation -> [Int]
permutationFinishingSet (Permutation -> [Int])
-> (Permutation -> Permutation) -> Permutation -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation -> Permutation
P.inversePermutation

-- | This satisfies
-- 
-- > permutationFinishingSet p == permWordFinishingSet n (_permutationBraid p)
--
permutationFinishingSet :: Permutation -> [Int]
permutationFinishingSet :: Permutation -> [Int]
permutationFinishingSet Permutation
perm
  = [ Int
i | Int
i<-[Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] , Permutation
perm Permutation -> Int -> Int
!!! Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Permutation
perm Permutation -> Int -> Int
!!! (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ] where n :: Int
n = Permutation -> Int
P.permutationSize Permutation
perm

-- | Returns the list of permutations failing Lemma 2.5 in [2] 
-- (so an empty list means the implementaton is correct)
fails_lemmma_2_5 :: Int -> [Permutation]
fails_lemmma_2_5 :: Int -> [Permutation]
fails_lemmma_2_5 Int
n = [ Permutation
p | Permutation
p <- Int -> [Permutation]
P.permutations Int
n , Bool -> Bool
not (Permutation -> Bool
test Permutation
p) ] where
  test :: Permutation -> Bool
test Permutation
p = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Int -> Bool
check Int
i | Int
i<-[Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ] where
    w :: [Int]
w = Permutation -> [Int]
_permutationBraid Permutation
p
    s :: [Int]
s = Int -> [Int] -> [Int]
permWordStartingSet Int
n [Int]
w
    check :: Int -> Bool
check Int
i = Int -> [Int] -> Bool
_isPermutationBraid Int
n (Int
iInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
w) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Int
i [Int]
s)

-------------------------------------------------------------------------------- 
                    
-- | Given factors defined as permutation braids, we normalize them
-- to /left-canonical form/ by ensuring that
--
-- * for each consecutive pair @(P,Q)@ the finishing set F(P) contains the starting set S(Q)
--
-- * all @Delta@-s (corresponding to the reverse permutation) are moved to the left
--
-- * all trivial factors are filtered out
--
-- Unfortunately, it seems that we may need multiple sweeps to do that...
--
normalizePermFactors :: Int -> [Permutation] -> (Int,[Permutation])
normalizePermFactors :: Int -> [Permutation] -> (Int, [Permutation])
normalizePermFactors Int
n = Int -> [Permutation] -> (Int, [Permutation])
go Int
0 where
  go :: Int -> [Permutation] -> (Int, [Permutation])
go !Int
acc [Permutation]
input = 
    if (Int
expInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 Bool -> Bool -> Bool
&& [Permutation]
input [Permutation] -> [Permutation] -> Bool
forall a. Eq a => a -> a -> Bool
== [Permutation]
output) 
      then (Int
acc,[Permutation]
input) 
      else Int -> [Permutation] -> (Int, [Permutation])
go (Int
accInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
exp) [Permutation]
output 
    where 
      (Int
exp,[Permutation]
output) = Int -> [Permutation] -> (Int, [Permutation])
normalizePermFactors1 Int
n [Permutation]
input

-- | Does 1 sweep of the above normalization process.
-- Unfortunately, it seems that we may need to do this multiple times...
--
normalizePermFactors1 :: Int -> [Permutation] -> (Int,[Permutation])
normalizePermFactors1 :: Int -> [Permutation] -> (Int, [Permutation])
normalizePermFactors1 Int
n [Permutation]
input = (Int
exp, [Permutation] -> [Permutation]
forall a. [a] -> [a]
reverse [Permutation]
output) where
  (Int
exp, [Permutation]
output) = Int -> [Permutation] -> (Int, [Permutation])
worker Int
0 ([Permutation] -> [Permutation]
forall a. [a] -> [a]
reverse [Permutation]
input)

  -- Notes: We work in reverse order, from the right to the left.
  -- We maintain the number of Delta-s pushed through; the tau involutions
  -- are implicit in the parity of this number
  --
  worker :: Int -> [Permutation] -> (Int,[Permutation])
  worker :: Int -> [Permutation] -> (Int, [Permutation])
worker = Int -> Int -> Int -> [Permutation] -> (Int, [Permutation])
worker' Int
0 Int
0
  
  -- We also maintain additional 0/1 flip flags for the first two permutations
  -- this is a little bit of hack but it should work nicely
  --
  worker' :: Int -> Int -> Int -> [Permutation] -> (Int,[Permutation])
  worker' :: Int -> Int -> Int -> [Permutation] -> (Int, [Permutation])
worker' !Int
ep !Int
eq !Int
e (!Permutation
p : rest :: [Permutation]
rest@(!Permutation
q : [Permutation]
rest')) 

    -- check if the very first element is identity or Delta 
    -- (note: these are tau-invariants)

    | Permutation -> Bool
isIdentityPermutation Permutation
p  = Int -> Int -> Int -> [Permutation] -> (Int, [Permutation])
worker'  Int
eq  Int
0  Int
e    [Permutation]
rest
    | Permutation -> Bool
isReversePermutation  Permutation
p  = Int -> Int -> Int -> [Permutation] -> (Int, [Permutation])
worker'  Int
eq  Int
0 (Int
eInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Permutation]
rest

    -- check if the second element is identity or Delta 
    -- this is necessary since we "fatten" the second element and it can possibly
    -- become Delta after a while (?)

    | Permutation -> Bool
isIdentityPermutation Permutation
q  = Int -> Int -> Int -> [Permutation] -> (Int, [Permutation])
worker'  Int
ep    Int
0  Int
e    (Permutation
p Permutation -> [Permutation] -> [Permutation]
forall a. a -> [a] -> [a]
: [Permutation]
rest')
    | Permutation -> Bool
isReversePermutation  Permutation
q  = Int -> Int -> Int -> [Permutation] -> (Int, [Permutation])
worker' (Int
epInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Int
0 (Int
eInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Permutation
p Permutation -> [Permutation] -> [Permutation]
forall a. a -> [a] -> [a]
: [Permutation]
rest')    

    -- ok so we have something like "... : Q : P"
    -- if F(Q) contains S(P) then we can move on; 
    -- otherwise there is an element j in S(P) \\ F(Q), so we can 
    -- replace it by "... : Qj : jP"

    | Bool
otherwise = 
        case Permutation -> [Int]
permutationStartingSet Permutation
preal [Int] -> [Int] -> [Int]
forall a. Eq a => [a] -> [a] -> [a]
\\ Permutation -> [Int]
permutationFinishingSet Permutation
qreal of  
          []    -> let (Int
e',[Permutation]
rs) = Int -> Int -> Int -> [Permutation] -> (Int, [Permutation])
worker' Int
eq Int
0 Int
e [Permutation]
rest in (Int
e', Permutation
preal Permutation -> [Permutation] -> [Permutation]
forall a. a -> [a] -> [a]
: [Permutation]
rs)
          (Int
j:[Int]
_) -> Int -> Int -> Int -> [Permutation] -> (Int, [Permutation])
worker' (-Int
e) (-Int
e) Int
e (Permutation
p'Permutation -> [Permutation] -> [Permutation]
forall a. a -> [a] -> [a]
:Permutation
q'Permutation -> [Permutation] -> [Permutation]
forall a. a -> [a] -> [a]
:[Permutation]
rest') where 
                     s :: Permutation
s  = Int -> Int -> Permutation
P.adjacentTransposition Int
n Int
j
                     p' :: Permutation
p' = Permutation -> Permutation -> Permutation
P.multiplyPermutation Permutation
s Permutation
preal
                     q' :: Permutation
q' = Permutation -> Permutation -> Permutation
P.multiplyPermutation Permutation
qreal Permutation
s
        where
          preal :: Permutation
preal = Int -> Permutation -> Permutation
oddTau (Int
eInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
ep) Permutation
p       -- the "real" p
          qreal :: Permutation
qreal = Int -> Permutation -> Permutation
oddTau (Int
eInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
eq) Permutation
q       -- the "real" q

  worker' Int
_   Int
_  !Int
e [ ] = (Int
e,[])
  worker' !Int
ep Int
_  !Int
e [Permutation
p] 
    | Permutation -> Bool
isIdentityPermutation Permutation
p  = (Int
e   , [])
    | Permutation -> Bool
isReversePermutation  Permutation
p  = (Int
eInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 , [])
    | Bool
otherwise                = (Int
e   , [Int -> Permutation -> Permutation
oddTau (Int
eInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
ep) Permutation
p] )

  oddTau :: Int -> Permutation -> Permutation
  oddTau :: Int -> Permutation -> Permutation
oddTau !Int
e Permutation
p = if Int -> Bool
forall a. Integral a => a -> Bool
even Int
e then Permutation
p else Permutation -> Permutation
tauPerm Permutation
p

{-
  checkDelta :: Int -> Permutation -> [Permutation] -> (Int,[Permutation])
  checkDelta !e !p !rest 
    | P.isIdentityPermutation p  = worker  e    rest
    | isReversePermutation    p  = worker (e+1) rest
    | otherwise                  = let (e',rs) = worker e rest in (e', oddTau e p : rs)
-}        

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

-- | Given a /positive/ word, we apply left-greedy factorization of
-- that word into subwords representing /permutation braids/.
--
-- Example 5.1 from the above handbook:
--
-- > leftGreedyFactors 7 [1,3,2,2,1,3,3,2,3,2] == [[1,3,2],[2,1,3],[3,2,3],[2]]
--
leftGreedyFactors :: Int -> [Int] -> [[Int]]
leftGreedyFactors :: Int -> [Int] -> [[Int]]
leftGreedyFactors Int
n [Int]
input = ([Int] -> Bool) -> [[Int]] -> [[Int]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Int] -> Bool) -> [Int] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ (forall s. ST s [[Int]]) -> [[Int]]
forall a. (forall s. ST s a) -> a
runST ([Int] -> ST s [[Int]]
forall s. [Int] -> ST s [[Int]]
action [Int]
input) where

  action :: forall s. [Int] -> ST s [[Int]]
  action :: [Int] -> ST s [[Int]]
action [Int]
input = 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 clearMat :: ST s ()
clearMat = [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 -> 
          [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 -> 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
0
          
    let doAdd1 :: Int -> Int -> ST s Int
        doAdd1 :: Int -> Int -> ST s Int
doAdd1 Int
i Int
j = 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)
          let y :: Int
y = Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
          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
y 
          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
y
          Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
y
           
    let worker :: [Int] -> ST s [[Int]]
        worker :: [Int] -> ST s [[Int]]
worker []     = [[Int]] -> ST s [[Int]]
forall (m :: * -> *) a. Monad m => a -> m a
return [[]]
        worker (Int
p:[Int]
ps) = do
          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
p 
          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
pInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
          Int
c <- Int -> Int -> ST s Int
doAdd1 Int
u Int
v 
          Int -> ST s ()
doSwap Int
p
          if Int
cInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=Int
1
            then do
              ([Int]
f:[[Int]]
fs) <- [Int] -> ST s [[Int]]
worker [Int]
ps
              [[Int]] -> ST s [[Int]]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int
pInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
f)[Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
:[[Int]]
fs)
            else do
              ST s ()
clearMat
              [[Int]]
fs <- [Int] -> ST s [[Int]]
worker (Int
pInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
ps)
              [[Int]] -> ST s [[Int]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([][Int] -> [[Int]] -> [[Int]]
forall a. a -> [a] -> [a]
:[[Int]]
fs)
              
    [Int] -> ST s [[Int]]
worker [Int]
input

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

{-

-- | Finds ternary braid relations, and returns them as a list of indices, decorated
-- with a flag specifying which side of the relation we found, a sign specifying
-- whether it is a relation between positive or negative generators.
--
findTernaryBraidRelations :: Braid n -> [(Int,Bool,Sign)]
findTernaryBraidRelations (Braid gens) = go 0 gens where
  go !k (Sigma a : rest@(Sigma b : Sigma c : _))  
    | a==c && b==a+1 = (k,True ,Plus) : go (k+1) rest
    | a==c && b==a-1 = (k,False,Plus) : go (k+1) rest
    | otherwise      =                  go (k+1) rest
  go !k (SigmaInv a : rest@(SigmaInv b : SigmaInv c : _))  
    | a==c && b==a+1 = (k,True ,Minus) : go (k+1) rest
    | a==c && b==a-1 = (k,False,Minus) : go (k+1) rest
    | otherwise      =                   go (k+1) rest
  go !k (x:xs) = go (k+1) xs
  go _  []     = []

-- | Finds subsequences like @(i,i+1,i)@ and @(i+1,i,i+1)@, and returns them
-- and a list of indices, plus a flag specifying which one we found (the first 
-- one is 'True', second one is 'False')
--
_findTernaryBraidRelations :: [Int] -> [(Int,Bool)]
_findTernaryBraidRelations = go 0 where
  go !k (a:rest@(b:c:_))  
    | a==c && b==a+1 = (k,True ) : go (k+1) rest
    | a==c && b==a-1 = (k,False) : go (k+1) rest
    | otherwise      =             go (k+1) rest
  go !k (x:xs) = go (k+1) xs
  go _  []     = []

-}

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